From cfa6ceb3ddf6b1e3f2382c1255d717e6a54e100c Mon Sep 17 00:00:00 2001 From: Diogo Castro Date: Sat, 9 Apr 2022 16:55:26 +0100 Subject: [PATCH 1/9] [#28] Remove unnecessary `HasData` instance Problem: `KvResponse` has: * a `krKdata` field * a generated `HasKdata` instance (generated by `makeLensesWith`) * a manually defined `HasDdata` instance There's no need to have both instances. Solution: * Delete the manually defined `HasDdata` instance * Rename the field to `krDdata`, so that `makeLensesWith` will automatically generate a `HasDdata` instance instead of `HasKdata`. --- lib/Backend/Vault/Kv/Internal.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/lib/Backend/Vault/Kv/Internal.hs b/lib/Backend/Vault/Kv/Internal.hs index 71d87c9a..e9d60478 100644 --- a/lib/Backend/Vault/Kv/Internal.hs +++ b/lib/Backend/Vault/Kv/Internal.hs @@ -60,12 +60,11 @@ data KvResponse a = , krLeaseId :: T.Text , krRenewable :: Bool , krLeaseDuration :: Int - , krKdata :: a + , krDdata :: a } deriving stock (Show) makeLensesWith abbreviatedFields ''KvResponse - -- | -- A type defining the response from the Vault server at endpoint -- '/v1//metadata/'. This is all actually always wrapped @@ -159,11 +158,6 @@ data UpdateMetadata = deriving stock (Show) makeLensesWith abbreviatedFields ''UpdateMetadata --- Overloaded Lens accessors - -instance {-# OVERLAPPABLE #-} a ~ b => HasDdata (KvResponse a) b where - ddata = kdata - -- JSON serialization/deserialization, logically some ADTs need to only be deserialized, -- others serialized, but never both. From 7ac73134a9bcb38978a0fdf31732f648aaf4c932 Mon Sep 17 00:00:00 2001 From: Diogo Castro Date: Sat, 9 Apr 2022 16:59:08 +0100 Subject: [PATCH 2/9] [#28] Export one identifier per line Problem: Some of our export lists: * are disorganized (e.g. `Field` is not followed by `newField`, `newEntryTag` appears before `EntryTag`, etc). * export multiple definitions in the same line, making git diffs that affect these liens hard to read. Solution: * Reorganize export lists so that each type is followed by its constructors/accessors/optics. * Export one definition per line. * Use haddock sections (e.g. `-- * Routes`) where it makes sense. --- lib/Backend.hs | 6 +++++- lib/Backend/Vault/Kv/Internal.hs | 23 ++++++++++++++++------- lib/Entry.hs | 24 ++++++++++++++++++------ 3 files changed, 39 insertions(+), 14 deletions(-) diff --git a/lib/Backend.hs b/lib/Backend.hs index fd5be93d..e472b7ef 100644 --- a/lib/Backend.hs +++ b/lib/Backend.hs @@ -3,7 +3,11 @@ -- SPDX-License-Identifier: MPL-2.0 module Backend - ( BackendEffect (..), readSecret, writeSecret, listSecrets, deleteSecret + ( BackendEffect (..) + , readSecret + , writeSecret + , listSecrets + , deleteSecret , Backend (..) , SomeBackend (..) , Effects diff --git a/lib/Backend/Vault/Kv/Internal.hs b/lib/Backend/Vault/Kv/Internal.hs index e9d60478..be140de0 100644 --- a/lib/Backend/Vault/Kv/Internal.hs +++ b/lib/Backend/Vault/Kv/Internal.hs @@ -4,28 +4,37 @@ module Backend.Vault.Kv.Internal ( KvResponse (..) - , requestId, leaseId, renewable, leaseDuration + , requestId + , leaseId + , renewable + , leaseDuration + , ddata , ReadSecret (..) - , secret, createdTime, deletionTime, destroyed, version + , secret + , customMetadata + , createdTime + , deletionTime + , destroyed + , version , ListSecrets (..) , unListSecrets , PostSecret (..) , cas , PatchSecret , UpdateMetadata (..) - , maxVersions, casRequired, deleteVersionAfter + , maxVersions + , casRequired + , deleteVersionAfter , VaultToken (..) - , ddata, customMetadata - + -- * Routes + , routes , readSecret , listSecrets , postSecret , patchSecret , updateMetadata , deleteSecret - - , routes ) where diff --git a/lib/Entry.hs b/lib/Entry.hs index 1c77a5bd..be26753c 100644 --- a/lib/Entry.hs +++ b/lib/Entry.hs @@ -3,16 +3,28 @@ -- SPDX-License-Identifier: MPL-2.0 module Entry - ( dateModified + ( FieldKey , keyCharSet - , Entry, EntryConvertible (..), newEntry - , path, masterField, fields - , Field (..), FieldKey, newField, getFieldKey - , newFieldKey, newEntryTag, getEntryTag - , visibility, value, tags, EntryTag + , newFieldKey + , getFieldKey + , EntryTag + , newEntryTag + , getEntryTag , FieldVisibility(..) , FieldValue (..) , fieldValue + , Field (..) + , dateModified + , newField + , visibility + , value + , Entry + , newEntry + , path + , masterField + , fields + , tags + , EntryConvertible (..) ) where From ce204054892ca25301b4a1160f4346a5c281cc54 Mon Sep 17 00:00:00 2001 From: Diogo Castro Date: Sat, 9 Apr 2022 17:04:12 +0100 Subject: [PATCH 3/9] [#28] Fix indentation of `where` blocks Problem: The `code_style.md` says: > Indent the `where` keyword with 2 spaces and the definitions within > the `where` clause with 2 more spaces. However, some `where` blocks use the wrong indentation. Solution: remove excessive indentation in `where` blocks. --- lib/Backends.hs | 27 +++++------ lib/Entry/Json.hs | 114 +++++++++++++++++++++++----------------------- 2 files changed, 72 insertions(+), 69 deletions(-) diff --git a/lib/Backends.hs b/lib/Backends.hs index f53d8bc1..94246d3c 100644 --- a/lib/Backends.hs +++ b/lib/Backends.hs @@ -17,20 +17,21 @@ import Validation (Validation(Failure)) backendPackedCodec :: TomlCodec SomeBackend backendPackedCodec = Toml.Codec input output - where input :: Toml.TomlEnv SomeBackend - input toml = case HS.lookup "type" $ Toml.tomlPairs toml of - Just t -> do - case Toml.backward Toml._Text t >>= supportedBackends of - Right c -> c toml - Left e -> Failure - [ Toml.BiMapError "type" e - ] - Nothing -> Failure - [ Toml.BiMapError "type" $ Toml.ArbitraryError - "Backend doesn't have a `type` key" + where + input :: Toml.TomlEnv SomeBackend + input toml = case HS.lookup "type" $ Toml.tomlPairs toml of + Just t -> do + case Toml.backward Toml._Text t >>= supportedBackends of + Right c -> c toml + Left e -> Failure + [ Toml.BiMapError "type" e ] - output (SomeBackend a) = SomeBackend <$> Toml.codecWrite _codec a - <* Toml.codecWrite (Toml.text "type") "vault" + Nothing -> Failure + [ Toml.BiMapError "type" $ Toml.ArbitraryError + "Backend doesn't have a `type` key" + ] + output (SomeBackend a) = SomeBackend <$> Toml.codecWrite _codec a + <* Toml.codecWrite (Toml.text "type") "vault" supportedBackends :: T.Text -> Either Toml.TomlBiMapError (Toml.TomlEnv SomeBackend) diff --git a/lib/Entry/Json.hs b/lib/Entry/Json.hs index 44107635..3730ce72 100644 --- a/lib/Entry/Json.hs +++ b/lib/Entry/Json.hs @@ -23,66 +23,68 @@ newtype JsonEntry = JsonEntry A.Value fieldConverter :: (Prism A.Value A.Value E.Field E.Field) fieldConverter = prism' to from - where to :: E.Field -> A.Value - to field = - A.object - [ "date_modified" A..= (field ^. E.dateModified) - , "visibility" A..= (field ^. E.visibility) - , "value" A..= (field ^. E.value . E.fieldValue) - ] - from (A.Object o) = do - dateModified <- HS.lookup "date_modified" o - >>= \case A.String t -> Just t ; _ -> Nothing - >>= iso8601ParseM . T.unpack - value <- HS.lookup "value" o - >>= \case - A.String t -> Just t - _ -> Nothing - _visibility <- HS.lookup "visibility" o >>= resultToMaybe . A.fromJSON - pure - $ E.newField dateModified (FieldValue value) - & E.visibility .~ _visibility - from _ = Nothing + where + to :: E.Field -> A.Value + to field = + A.object + [ "date_modified" A..= (field ^. E.dateModified) + , "visibility" A..= (field ^. E.visibility) + , "value" A..= (field ^. E.value . E.fieldValue) + ] + from (A.Object o) = do + dateModified <- HS.lookup "date_modified" o + >>= \case A.String t -> Just t ; _ -> Nothing + >>= iso8601ParseM . T.unpack + value <- HS.lookup "value" o + >>= \case + A.String t -> Just t + _ -> Nothing + _visibility <- HS.lookup "visibility" o >>= resultToMaybe . A.fromJSON + pure + $ E.newField dateModified (FieldValue value) + & E.visibility .~ _visibility + from _ = Nothing instance E.EntryConvertible JsonEntry where entry = prism' to from - where to :: Entry -> JsonEntry - to entry = - JsonEntry $ A.object - [ "path" A..= pretty @_ @T.Text (entry ^. E.path) - , "date_modified" A..= (entry ^. E.dateModified) - , "master_field" A..= (entry ^. E.masterField) - , "fields" A..= (HS.fromList . over (each . _1) E.getFieldKey . HS.toList . HS.map (^. re fieldConverter) $ (entry ^. E.fields)) - , "tags" A..= (entry ^. E.tags) - ] - from (JsonEntry (A.Object o)) = - do - path <- HS.lookup "path" o - >>= (\case A.String t -> Just t ; _ -> Nothing) - >>= eitherToMaybe . Path.mkEntryPath - dateModified <- HS.lookup "date_modified" o - >>= \case A.String t -> Just t ; _ -> Nothing - >>= iso8601ParseM . T.unpack - let _masterField = HS.lookup "master_field" o >>= \case - A.String t -> eitherToMaybe $ E.newFieldKey t - _ -> Nothing - _fields <- do - value <- HS.lookup "fields" o - obj <- value ^? A._Object - keyFields <- - forM (HS.toList obj) $ \(text, value) -> do - key <- eitherToMaybe $ E.newFieldKey text - field <- value ^? fieldConverter - pure (key, field) - pure $ HS.fromList keyFields - _tags <- HS.lookup "tags" o >>= resultToMaybe . A.fromJSON + where + to :: Entry -> JsonEntry + to entry = + JsonEntry $ A.object + [ "path" A..= pretty @_ @T.Text (entry ^. E.path) + , "date_modified" A..= (entry ^. E.dateModified) + , "master_field" A..= (entry ^. E.masterField) + , "fields" A..= (HS.fromList . over (each . _1) E.getFieldKey . HS.toList . HS.map (^. re fieldConverter) $ (entry ^. E.fields)) + , "tags" A..= (entry ^. E.tags) + ] + from (JsonEntry (A.Object o)) = + do + path <- HS.lookup "path" o + >>= (\case A.String t -> Just t ; _ -> Nothing) + >>= eitherToMaybe . Path.mkEntryPath + dateModified <- HS.lookup "date_modified" o + >>= \case A.String t -> Just t ; _ -> Nothing + >>= iso8601ParseM . T.unpack + let _masterField = HS.lookup "master_field" o >>= \case + A.String t -> eitherToMaybe $ E.newFieldKey t + _ -> Nothing + _fields <- do + value <- HS.lookup "fields" o + obj <- value ^? A._Object + keyFields <- + forM (HS.toList obj) $ \(text, value) -> do + key <- eitherToMaybe $ E.newFieldKey text + field <- value ^? fieldConverter + pure (key, field) + pure $ HS.fromList keyFields + _tags <- HS.lookup "tags" o >>= resultToMaybe . A.fromJSON - pure - $ E.newEntry path dateModified - & E.masterField .~ _masterField - & E.fields .~ _fields - & E.tags .~ _tags - from _ = Nothing + pure + $ E.newEntry path dateModified + & E.masterField .~ _masterField + & E.fields .~ _fields + & E.tags .~ _tags + from _ = Nothing resultToMaybe :: A.Result a -> Maybe a resultToMaybe = \case From e837c1d8d22d623a2ad4f8029ce9701a76a0d0d9 Mon Sep 17 00:00:00 2001 From: Diogo Castro Date: Sat, 9 Apr 2022 17:13:20 +0100 Subject: [PATCH 4/9] [#28] Remove excessive indentation Problem: The `code_style.md` says: > Indent your code blocks with *2 spaces*. However, some blocks use the wrong indentation. Solution: remove excessive indentation. --- lib/Backend/Vault/Kv.hs | 71 +++++++++++++++++++++-------------------- lib/Backends.hs | 26 +++++++-------- lib/Coffer/Util.hs | 22 ++++++------- lib/Entry/Json.hs | 61 +++++++++++++++++------------------ 4 files changed, 91 insertions(+), 89 deletions(-) diff --git a/lib/Backend/Vault/Kv.hs b/lib/Backend/Vault/Kv.hs index 58f5b278..217c15b6 100644 --- a/lib/Backend/Vault/Kv.hs +++ b/lib/Backend/Vault/Kv.hs @@ -52,10 +52,10 @@ data VaultKvBackend = vaultKvCodec :: TomlCodec VaultKvBackend vaultKvCodec = VaultKvBackend - <$> backendNameCodec "name" Toml..= vbName - <*> didimatch baseUrlToText textToBaseUrl (Toml.text "address") Toml..= vbAddress - <*> Toml.text "mount" Toml..= vbMount - <*> Toml.dimatch tokenToText textToToken (Toml.text "token") Toml..= vbToken + <$> backendNameCodec "name" Toml..= vbName + <*> didimatch baseUrlToText textToBaseUrl (Toml.text "address") Toml..= vbAddress + <*> Toml.text "mount" Toml..= vbMount + <*> Toml.dimatch tokenToText textToToken (Toml.text "token") Toml..= vbToken where tokenToText (I.VaultToken t) = Just t textToToken t = I.VaultToken t @@ -102,15 +102,15 @@ getEnv backend = -- 2. If it is @ConnectionError@, then we would get @ConnectError@ -- 3. Otherwise we would get @MarshallingFailed@ exceptionHandler :: ClientError -> Maybe CofferError -exceptionHandler = - \case FailureResponse _request response -> - case statusCode $ responseStatusCode response of - 404 -> Nothing - e -> Just $ OtherError (T.pack $ show e) - DecodeFailure _ _ -> Just MarshallingFailed - UnsupportedContentType _ _ -> Just MarshallingFailed - InvalidContentTypeHeader _ -> Just MarshallingFailed - ConnectionError _ -> Just ConnectError +exceptionHandler = \case + FailureResponse _request response -> + case statusCode $ responseStatusCode response of + 404 -> Nothing + e -> Just $ OtherError (T.pack $ show e) + DecodeFailure _ _ -> Just MarshallingFailed + UnsupportedContentType _ _ -> Just MarshallingFailed + InvalidContentTypeHeader _ -> Just MarshallingFailed + ConnectionError _ -> Just ConnectError -- | Runs an IO action and throws an error if happens. embedCatchClientError @@ -118,10 +118,11 @@ embedCatchClientError => Member (Error CofferError) r => IO a -> Sem r a -embedCatchClientError io = embed (catch @ClientError (io <&> Left) (pure . Right . exceptionHandler)) >>= - \case Left l -> pure l - Right (Just r) -> throw r - Right Nothing -> throw $ OtherError "404" +embedCatchClientError io = + embed (catch @ClientError (io <&> Left) (pure . Right . exceptionHandler)) >>= \case + Left l -> pure l + Right (Just r) -> throw r + Right Nothing -> throw $ OtherError "404" -- | Runs an IO action and throws an error only if it isn't a failure response with status code 404. -- Otherwise, it would be Nothing. @@ -130,10 +131,11 @@ embedCatchClientErrorMaybe => Member (Error CofferError) r => IO a -> Sem r (Maybe a) -embedCatchClientErrorMaybe io = embed (catch @ClientError (io <&> Left) (pure . Right . exceptionHandler)) >>= - \case Left l -> (pure . Just) l - Right (Just r) -> throw r - Right Nothing -> pure Nothing +embedCatchClientErrorMaybe io = + embed (catch @ClientError (io <&> Left) (pure . Right . exceptionHandler)) >>= \case + Left l -> (pure . Just) l + Right (Just r) -> throw r + Right Nothing -> pure Nothing orThrow :: Member (Error e) r @@ -167,10 +169,10 @@ kvWriteSecret backend entry = do secret = I.PostSecret { I.psCas = Nothing , I.psDdata = - HS.insert "#$coffer" (TL.toStrict $ A.encodeToLazyText cofferSpecials) - . HS.map (^. E.value . E.fieldValue) - . HS.mapKeys E.getFieldKey - $ entry ^. E.fields + HS.insert "#$coffer" (TL.toStrict $ A.encodeToLazyText cofferSpecials) + . HS.map (^. E.value . E.fieldValue) + . HS.mapKeys E.getFieldKey + $ entry ^. E.fields } env <- getEnv backend void $ embedCatchClientError do @@ -192,19 +194,20 @@ kvReadSecret backend path = do _visibility <- cofferSpecials ^? fields . at key . _Just . visibility _key <- eitherToMaybe $ E.newFieldKey key - Just (_key - , E.newField _modTime (FieldValue value) - & E.visibility .~ _visibility - ) + Just + (_key + , E.newField _modTime (FieldValue value) + & E.visibility .~ _visibility + ) fields <- (secrets & each %%~ keyAndValueToField <&> HS.fromList) `orThrow` MarshallingFailed _tags <- cofferSpecials ^. tags - & Set.toList - & mapM E.newEntryTag - <&> Set.fromList - & eitherToMaybe - & (`orThrow` MarshallingFailed) + & Set.toList + & mapM E.newEntryTag + <&> Set.fromList + & eitherToMaybe + & (`orThrow` MarshallingFailed) fieldKey <- case cofferSpecials ^. masterKey of diff --git a/lib/Backends.hs b/lib/Backends.hs index 94246d3c..854e0b14 100644 --- a/lib/Backends.hs +++ b/lib/Backends.hs @@ -19,19 +19,19 @@ backendPackedCodec :: TomlCodec SomeBackend backendPackedCodec = Toml.Codec input output where input :: Toml.TomlEnv SomeBackend - input toml = case HS.lookup "type" $ Toml.tomlPairs toml of - Just t -> do - case Toml.backward Toml._Text t >>= supportedBackends of - Right c -> c toml - Left e -> Failure - [ Toml.BiMapError "type" e - ] - Nothing -> Failure - [ Toml.BiMapError "type" $ Toml.ArbitraryError - "Backend doesn't have a `type` key" - ] - output (SomeBackend a) = SomeBackend <$> Toml.codecWrite _codec a - <* Toml.codecWrite (Toml.text "type") "vault" + input toml = + case HS.lookup "type" $ Toml.tomlPairs toml of + Just t -> do + case Toml.backward Toml._Text t >>= supportedBackends of + Right c -> c toml + Left e -> Failure [ Toml.BiMapError "type" e ] + Nothing -> Failure + [ Toml.BiMapError "type" $ Toml.ArbitraryError + "Backend doesn't have a `type` key" + ] + output (SomeBackend a) = do + SomeBackend <$> Toml.codecWrite _codec a + <* Toml.codecWrite (Toml.text "type") "vault" supportedBackends :: T.Text -> Either Toml.TomlBiMapError (Toml.TomlEnv SomeBackend) diff --git a/lib/Coffer/Util.hs b/lib/Coffer/Util.hs index 5e6feec6..7934643a 100644 --- a/lib/Coffer/Util.hs +++ b/lib/Coffer/Util.hs @@ -35,14 +35,14 @@ didimatch -> TomlCodec a -- ^ Source 'Codec' object -> TomlCodec b -- ^ Target 'Codec' object didimatch matchB matchA codec = Toml.Codec - { Toml.codecRead = \t -> case Toml.codecRead codec t of - Success a -> - case matchA a of - Left err -> Failure [Toml.ParseError $ Toml.TomlParseError err] - Right b -> Success b - Failure b -> Failure b - , Toml.codecWrite = \b -> do - a <- Toml.eitherToTomlState $ matchB b - a' <- Toml.codecWrite codec a - Toml.eitherToTomlState $ matchA a' - } + { Toml.codecRead = \t -> case Toml.codecRead codec t of + Success a -> + case matchA a of + Left err -> Failure [Toml.ParseError $ Toml.TomlParseError err] + Right b -> Success b + Failure b -> Failure b + , Toml.codecWrite = \b -> do + a <- Toml.eitherToTomlState $ matchB b + a' <- Toml.codecWrite codec a + Toml.eitherToTomlState $ matchA a' + } diff --git a/lib/Entry/Json.hs b/lib/Entry/Json.hs index 3730ce72..96bbae30 100644 --- a/lib/Entry/Json.hs +++ b/lib/Entry/Json.hs @@ -33,12 +33,11 @@ fieldConverter = prism' to from ] from (A.Object o) = do dateModified <- HS.lookup "date_modified" o - >>= \case A.String t -> Just t ; _ -> Nothing - >>= iso8601ParseM . T.unpack - value <- HS.lookup "value" o - >>= \case - A.String t -> Just t - _ -> Nothing + >>= \case A.String t -> Just t ; _ -> Nothing + >>= iso8601ParseM . T.unpack + value <- HS.lookup "value" o >>= \case + A.String t -> Just t + _ -> Nothing _visibility <- HS.lookup "visibility" o >>= resultToMaybe . A.fromJSON pure $ E.newField dateModified (FieldValue value) @@ -58,32 +57,32 @@ instance E.EntryConvertible JsonEntry where , "tags" A..= (entry ^. E.tags) ] from (JsonEntry (A.Object o)) = - do - path <- HS.lookup "path" o - >>= (\case A.String t -> Just t ; _ -> Nothing) - >>= eitherToMaybe . Path.mkEntryPath - dateModified <- HS.lookup "date_modified" o - >>= \case A.String t -> Just t ; _ -> Nothing - >>= iso8601ParseM . T.unpack - let _masterField = HS.lookup "master_field" o >>= \case - A.String t -> eitherToMaybe $ E.newFieldKey t - _ -> Nothing - _fields <- do - value <- HS.lookup "fields" o - obj <- value ^? A._Object - keyFields <- - forM (HS.toList obj) $ \(text, value) -> do - key <- eitherToMaybe $ E.newFieldKey text - field <- value ^? fieldConverter - pure (key, field) - pure $ HS.fromList keyFields - _tags <- HS.lookup "tags" o >>= resultToMaybe . A.fromJSON + do + path <- HS.lookup "path" o + >>= (\case A.String t -> Just t ; _ -> Nothing) + >>= eitherToMaybe . Path.mkEntryPath + dateModified <- HS.lookup "date_modified" o + >>= \case A.String t -> Just t ; _ -> Nothing + >>= iso8601ParseM . T.unpack + let _masterField = HS.lookup "master_field" o >>= \case + A.String t -> eitherToMaybe $ E.newFieldKey t + _ -> Nothing + _fields <- do + value <- HS.lookup "fields" o + obj <- value ^? A._Object + keyFields <- + forM (HS.toList obj) $ \(text, value) -> do + key <- eitherToMaybe $ E.newFieldKey text + field <- value ^? fieldConverter + pure (key, field) + pure $ HS.fromList keyFields + _tags <- HS.lookup "tags" o >>= resultToMaybe . A.fromJSON - pure - $ E.newEntry path dateModified - & E.masterField .~ _masterField - & E.fields .~ _fields - & E.tags .~ _tags + pure + $ E.newEntry path dateModified + & E.masterField .~ _masterField + & E.fields .~ _fields + & E.tags .~ _tags from _ = Nothing resultToMaybe :: A.Result a -> Maybe a From 2ce16e95f2557fd4d7941b9f29db21e0475566d7 Mon Sep 17 00:00:00 2001 From: Diogo Castro Date: Sat, 9 Apr 2022 18:10:04 +0100 Subject: [PATCH 5/9] [#28] Simplify with `BlockArguments` Problem: We're using `$` before `do` blocks and lambda expressions. But, thanks to `BlockArguments`, we don't need to do that. Solution: Remove `$` where it's not needed. --- lib/Backend/Vault/Kv.hs | 2 +- lib/Backend/Vault/Kv/Internal.hs | 6 +++--- lib/Entry/Json.hs | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/lib/Backend/Vault/Kv.hs b/lib/Backend/Vault/Kv.hs index 217c15b6..b59fd630 100644 --- a/lib/Backend/Vault/Kv.hs +++ b/lib/Backend/Vault/Kv.hs @@ -228,7 +228,7 @@ kvReadSecret backend path = do kvListSecrets :: Effects r => VaultKvBackend -> Path -> Sem r (Maybe [T.Text]) kvListSecrets backend path = do env <- getEnv backend - embedCatchClientErrorMaybe $ do + embedCatchClientErrorMaybe do response <- listSecrets env (getPathSegments path) pure $ response ^. I.ddata . I.unListSecrets where diff --git a/lib/Backend/Vault/Kv/Internal.hs b/lib/Backend/Vault/Kv/Internal.hs index be140de0..6daf0754 100644 --- a/lib/Backend/Vault/Kv/Internal.hs +++ b/lib/Backend/Vault/Kv/Internal.hs @@ -171,11 +171,11 @@ makeLensesWith abbreviatedFields ''UpdateMetadata -- others serialized, but never both. instance FromJSON ListSecrets where - parseJSON = withObject "ListSecrets" $ \o -> + parseJSON = withObject "ListSecrets" \o -> ListSecrets <$> o .: "keys" instance FromJSON ReadSecret where - parseJSON = withObject "ReadSecret" $ \o -> do + parseJSON = withObject "ReadSecret" \o -> do metadata <- o .: "metadata" ReadSecret <$> o .: "data" @@ -186,7 +186,7 @@ instance FromJSON ReadSecret where <*> metadata .: "version" instance FromJSON a => FromJSON (KvResponse a) where - parseJSON = withObject "KvResponse" $ \o -> + parseJSON = withObject "KvResponse" \o -> KvResponse <$> o .: "request_id" <*> o .: "lease_id" diff --git a/lib/Entry/Json.hs b/lib/Entry/Json.hs index 96bbae30..7c908a38 100644 --- a/lib/Entry/Json.hs +++ b/lib/Entry/Json.hs @@ -71,7 +71,7 @@ instance E.EntryConvertible JsonEntry where value <- HS.lookup "fields" o obj <- value ^? A._Object keyFields <- - forM (HS.toList obj) $ \(text, value) -> do + forM (HS.toList obj) \(text, value) -> do key <- eitherToMaybe $ E.newFieldKey text field <- value ^? fieldConverter pure (key, field) From a255f7221add3d6464d24aeb5a5f4e4353699a0d Mon Sep 17 00:00:00 2001 From: Diogo Castro Date: Sat, 9 Apr 2022 18:31:04 +0100 Subject: [PATCH 6/9] [#28] Align data constructors Problem: The `code_style.md` says: > Align the constructors in a data type definition However, some data constructors are not aligned. Solution: align all data constructors. --- lib/Error.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Error.hs b/lib/Error.hs index 59ad3bd5..b26725ea 100644 --- a/lib/Error.hs +++ b/lib/Error.hs @@ -9,8 +9,8 @@ module Error import BackendName (BackendName) import Data.Text qualified as T -data CofferError = - MarshallingFailed +data CofferError + = MarshallingFailed | ConnectError | BackendNotFound BackendName | OtherError T.Text From 76e7dd34169d700ff1924072edd62826ac3bb8f8 Mon Sep 17 00:00:00 2001 From: Diogo Castro Date: Sat, 9 Apr 2022 19:02:38 +0100 Subject: [PATCH 7/9] [#28] Avoid qualifying common type names Problem: Types like `Text`, `HashMap` and `Set` are not meant to be imported qualified. Only the _functions_ from their respective modules are meant to be imported qualified. The docs for `Data.Set` (https://hackage.haskell.org/package/containers-0.6.5.1/docs/Data-Set.html) provide a good illustration: ``` import Data.Set (Set) import qualified Data.Set as Set ``` Solution: import these types unqualified. --- lib/Backend.hs | 16 +++++----- lib/Backend/Commands.hs | 3 +- lib/Backend/Vault/Kv.hs | 34 ++++++++++---------- lib/Backend/Vault/Kv/Internal.hs | 53 ++++++++++++++++---------------- lib/BackendName.hs | 7 +++-- lib/Backends.hs | 4 +-- lib/Config.hs | 9 +++--- lib/Entry.hs | 16 +++++----- lib/Entry/Json.hs | 36 ++++++++++++---------- lib/Error.hs | 4 +-- 10 files changed, 96 insertions(+), 86 deletions(-) diff --git a/lib/Backend.hs b/lib/Backend.hs index e472b7ef..e8b2f83c 100644 --- a/lib/Backend.hs +++ b/lib/Backend.hs @@ -16,8 +16,8 @@ where import BackendName (BackendName) import Coffer.Path (EntryPath, Path) -import Data.Text qualified as T -import Entry qualified as E +import Data.Text (Text) +import Entry (Entry) import Error (CofferError) import Polysemy import Polysemy.Error (Error) @@ -28,9 +28,9 @@ type Effects r = (Member (Embed IO) r, Member (Error CofferError) r) class Show a => Backend a where _name :: a -> BackendName _codec :: Toml.TomlCodec a - _writeSecret :: Effects r => a -> E.Entry -> Sem r () - _readSecret :: Effects r => a -> EntryPath -> Sem r (Maybe E.Entry) - _listSecrets :: Effects r => a -> Path -> Sem r (Maybe [T.Text]) + _writeSecret :: Effects r => a -> Entry -> Sem r () + _readSecret :: Effects r => a -> EntryPath -> Sem r (Maybe Entry) + _listSecrets :: Effects r => a -> Path -> Sem r (Maybe [Text]) _deleteSecret :: Effects r => a -> EntryPath -> Sem r () data SomeBackend where @@ -44,11 +44,11 @@ data BackendEffect m a where -- | Overwrites any entry that might already exist at that path. -- It does /not overwrite/ directories. -- If a directory with that path already exists, you'll end up with an entry /and/ a directory sharing the same path. - WriteSecret :: SomeBackend -> E.Entry -> BackendEffect m () + WriteSecret :: SomeBackend -> Entry -> BackendEffect m () -- | Returns path segments: if the segment is suffixed by @/@ then that indicates a directory; -- otherwise it's an entry - ReadSecret :: SomeBackend -> EntryPath -> BackendEffect m (Maybe E.Entry) - ListSecrets :: SomeBackend -> Path -> BackendEffect m (Maybe [T.Text]) + ReadSecret :: SomeBackend -> EntryPath -> BackendEffect m (Maybe Entry) + ListSecrets :: SomeBackend -> Path -> BackendEffect m (Maybe [Text]) -- | Once all entries are deleted from a directory, then the directory disappears -- (i.e. @ListSecrets@ will no longer list that directory) DeleteSecret :: SomeBackend -> EntryPath -> BackendEffect m () diff --git a/lib/Backend/Commands.hs b/lib/Backend/Commands.hs index 7d8d1187..fd211848 100644 --- a/lib/Backend/Commands.hs +++ b/lib/Backend/Commands.hs @@ -27,6 +27,7 @@ import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe) import Data.Set (Set) import Data.Set qualified as Set +import Data.Text (Text) import Data.Text qualified as T import Data.Time (UTCTime, getCurrentTime, utctDay) import Data.Time.Calendar.Compat (pattern YearMonthDay) @@ -291,7 +292,7 @@ data CopyOperation = CopyOperation getOperationPaths :: CopyOperation -> (EntryPath, EntryPath) getOperationPaths (CopyOperation old new) = (old ^. E.path, new ^. E.path) -{-# ANN buildCopyOperations ("HLint: ignore Redundant <$>" :: T.Text) #-} +{-# ANN buildCopyOperations ("HLint: ignore Redundant <$>" :: Text) #-} buildCopyOperations :: forall r . ( Member BackendEffect r diff --git a/lib/Backend/Vault/Kv.hs b/lib/Backend/Vault/Kv.hs index b59fd630..32e23a09 100644 --- a/lib/Backend/Vault/Kv.hs +++ b/lib/Backend/Vault/Kv.hs @@ -13,19 +13,21 @@ import BackendName (BackendName, backendNameCodec) import Coffer.Path (EntryPath, HasPathSegments, Path, PathSegment, pathSegments, unPathSegment) import Coffer.Util (didimatch) import Control.Exception (catch) -import Control.Lens +import Control.Lens hiding ((.=)) import Control.Monad (void) import Data.Aeson qualified as A import Data.Aeson.Text qualified as A import Data.Either.Extra (eitherToMaybe, maybeToEither) import Data.HashMap.Internal.Strict qualified as HS +import Data.HashMap.Strict (HashMap) +import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Text.Lazy qualified as TL import Data.Time (UTCTime) -import Entry (FieldValue(FieldValue), FieldVisibility) +import Entry (Entry, FieldValue(FieldValue), FieldVisibility) import Entry qualified as E import Error (CofferError(..)) import GHC.Generics (Generic) @@ -38,32 +40,32 @@ import Servant.Client (BaseUrl(BaseUrl), ClientEnv, ClientError(..), Scheme(Http, Https), mkClientEnv, parseBaseUrl, showBaseUrl) import Servant.Client.Core.Response (responseStatusCode) -import Toml (TomlCodec) +import Toml (TomlCodec, (.=)) import Toml qualified data VaultKvBackend = VaultKvBackend { vbName :: BackendName , vbAddress :: BaseUrl - , vbMount :: T.Text + , vbMount :: Text , vbToken :: I.VaultToken } deriving stock (Show) vaultKvCodec :: TomlCodec VaultKvBackend vaultKvCodec = VaultKvBackend - <$> backendNameCodec "name" Toml..= vbName - <*> didimatch baseUrlToText textToBaseUrl (Toml.text "address") Toml..= vbAddress - <*> Toml.text "mount" Toml..= vbMount - <*> Toml.dimatch tokenToText textToToken (Toml.text "token") Toml..= vbToken + <$> backendNameCodec "name" .= vbName + <*> didimatch baseUrlToText textToBaseUrl (Toml.text "address") .= vbAddress + <*> Toml.text "mount" .= vbMount + <*> Toml.dimatch tokenToText textToToken (Toml.text "token") .= vbToken where tokenToText (I.VaultToken t) = Just t textToToken t = I.VaultToken t - baseUrlToText :: BaseUrl -> Either T.Text T.Text + baseUrlToText :: BaseUrl -> Either Text Text baseUrlToText = Right . T.pack . showBaseUrl - textToBaseUrl :: T.Text -> Either T.Text BaseUrl + textToBaseUrl :: Text -> Either Text BaseUrl textToBaseUrl = maybeToEither "Cannot parse base url" . parseBaseUrl . T.unpack data FieldMetadata = FieldMetadata @@ -76,10 +78,10 @@ makeLensesWith abbreviatedFields ''FieldMetadata data CofferSpecials = CofferSpecials - { csMasterKey :: Maybe T.Text + { csMasterKey :: Maybe Text , csGlobalDateModified :: UTCTime - , csFields :: HS.HashMap T.Text FieldMetadata - , csTags :: Set.Set T.Text + , csFields :: HashMap Text FieldMetadata + , csTags :: Set Text } deriving stock (Show, Generic) deriving anyclass (A.ToJSON, A.FromJSON) @@ -149,7 +151,7 @@ getPathSegments => s -> [Text] getPathSegments path = path ^.. pathSegments . each . to unPathSegment -kvWriteSecret :: Effects r => VaultKvBackend -> E.Entry -> Sem r () +kvWriteSecret :: Effects r => VaultKvBackend -> Entry -> Sem r () kvWriteSecret backend entry = do let cofferSpecials = CofferSpecials @@ -180,7 +182,7 @@ kvWriteSecret backend entry = do where postSecret env = (I.routes env ^. I.postSecret) (vbMount backend) (vbToken backend) -kvReadSecret :: Effects r => VaultKvBackend -> EntryPath -> Sem r (Maybe E.Entry) +kvReadSecret :: Effects r => VaultKvBackend -> EntryPath -> Sem r (Maybe Entry) kvReadSecret backend path = do env <- getEnv backend embedCatchClientErrorMaybe (readSecret env (getPathSegments path) Nothing) >>= \case @@ -225,7 +227,7 @@ kvReadSecret backend path = do where readSecret env = (I.routes env ^. I.readSecret) (vbMount backend) (vbToken backend) -kvListSecrets :: Effects r => VaultKvBackend -> Path -> Sem r (Maybe [T.Text]) +kvListSecrets :: Effects r => VaultKvBackend -> Path -> Sem r (Maybe [Text]) kvListSecrets backend path = do env <- getEnv backend embedCatchClientErrorMaybe do diff --git a/lib/Backend/Vault/Kv/Internal.hs b/lib/Backend/Vault/Kv/Internal.hs index 6daf0754..369800aa 100644 --- a/lib/Backend/Vault/Kv/Internal.hs +++ b/lib/Backend/Vault/Kv/Internal.hs @@ -42,8 +42,9 @@ import Control.Exception (throwIO) import Control.Lens hiding ((.=)) import Data.Aeson import Data.Aeson.Types qualified as AT +import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HS -import Data.Text qualified as T +import Data.Text (Text) import Servant.API import Servant.API.Generic import Servant.Client @@ -65,8 +66,8 @@ import Servant.Client.Generic (AsClientT, genericClientHoist) -- > } data KvResponse a = KvResponse - { krRequestId :: T.Text - , krLeaseId :: T.Text + { krRequestId :: Text + , krLeaseId :: Text , krRenewable :: Bool , krLeaseDuration :: Int , krDdata :: a @@ -85,7 +86,7 @@ makeLensesWith abbreviatedFields ''KvResponse -- > , "q1" -- > ] -- > } -newtype ListSecrets = ListSecrets { _unListSecrets :: [T.Text] } +newtype ListSecrets = ListSecrets { _unListSecrets :: [Text] } deriving stock (Show) makeLenses ''ListSecrets @@ -111,10 +112,10 @@ makeLenses ''ListSecrets -- > } data ReadSecret = ReadSecret - { rsSecret :: HS.HashMap T.Text T.Text - , rsCustomMetadata :: HS.HashMap T.Text T.Text - , rsCreatedTime :: T.Text - , rsDeletionTime :: T.Text + { rsSecret :: HashMap Text Text + , rsCustomMetadata :: HashMap Text Text + , rsCreatedTime :: Text + , rsDeletionTime :: Text , rsDestroyed :: Bool , rsVersion :: Int } @@ -138,7 +139,7 @@ makeLensesWith abbreviatedFields ''ReadSecret data PostSecret = PostSecret { psCas :: Maybe Int - , psDdata :: HS.HashMap T.Text T.Text + , psDdata :: HashMap Text Text } deriving stock (Show) type PatchSecret = PostSecret @@ -161,8 +162,8 @@ data UpdateMetadata = UpdateMetadata { umMaxVersions :: Maybe Int , umCasRequired :: Maybe Bool - , umDeleteVersionAfter :: Maybe T.Text - , umCustomMetadata :: HS.HashMap T.Text T.Text + , umDeleteVersionAfter :: Maybe Text + , umCustomMetadata :: HashMap Text Text } deriving stock (Show) makeLensesWith abbreviatedFields ''UpdateMetadata @@ -229,7 +230,7 @@ instance ReflectMethod 'LIST where -- TODO - A place holder, for a perhaps more complicated type. One with pinned memory which is -- overwritten many times or something like that -newtype VaultToken = VaultToken T.Text +newtype VaultToken = VaultToken Text deriving stock (Eq, Show) -- Could this be somehow automated? newtypes are just meaningless wrapper anyways, at least to GHC. @@ -246,54 +247,54 @@ data Routes route = { -- | To read a secret under a path use `readSecret` rReadSecret :: route :- "v1" - :> Capture "mount" T.Text + :> Capture "mount" Text :> "data" :> VaultTokenHeader - :> CaptureAll "segments" T.Text + :> CaptureAll "segments" Text :> QueryParam "version" Int :> Get '[JSON] (KvResponse ReadSecret) -- | To patch a secret under a path use `patchSecret` , rPatchSecret :: route :- "v1" - :> Capture "mount" T.Text + :> Capture "mount" Text :> "data" :> VaultTokenHeader - :> CaptureAll "segments" T.Text + :> CaptureAll "segments" Text :> ReqBody '[JSON] PatchSecret - :> Patch '[JSON] (KvResponse (HS.HashMap T.Text Value)) + :> Patch '[JSON] (KvResponse (HashMap Text Value)) -- | To post a secret to a path use `postSecret` , rPostSecret :: route :- "v1" - :> Capture "mount" T.Text + :> Capture "mount" Text :> "data" :> VaultTokenHeader - :> CaptureAll "segments" T.Text + :> CaptureAll "segments" Text :> ReqBody '[JSON] PostSecret - :> Post '[JSON] (KvResponse (HS.HashMap T.Text Value)) + :> Post '[JSON] (KvResponse (HashMap Text Value)) -- | To list the paths under a path use `listSecrets` , rListSecrets :: route :- "v1" - :> Capture "mount" T.Text + :> Capture "mount" Text :> "metadata" :> VaultTokenHeader - :> CaptureAll "segments" T.Text + :> CaptureAll "segments" Text :> Verb 'LIST 200 '[JSON] (KvResponse ListSecrets) -- | To update metadata under a path use `updateMetadata` , rUpdateMetadata :: route :- "v1" - :> Capture "mount" T.Text + :> Capture "mount" Text :> "metadata" :> VaultTokenHeader - :> CaptureAll "segments" T.Text + :> CaptureAll "segments" Text :> ReqBody '[JSON] UpdateMetadata :> Post '[JSON] () -- | To delete secret under a path use `deleteSecret` , rDeleteSecret :: route :- "v1" - :> Capture "mount" T.Text + :> Capture "mount" Text :> "metadata" :> VaultTokenHeader - :> CaptureAll "segments" T.Text + :> CaptureAll "segments" Text :> Delete '[JSON] NoContent } deriving stock (Generic) diff --git a/lib/BackendName.hs b/lib/BackendName.hs index 20cb9c52..f76d5c8f 100644 --- a/lib/BackendName.hs +++ b/lib/BackendName.hs @@ -13,18 +13,19 @@ module BackendName import Coffer.Util (didimatch) import Data.Aeson qualified as A import Data.Hashable (Hashable) +import Data.Text (Text) import Data.Text qualified as T import Fmt (Buildable) import Toml qualified -newtype BackendName = UnsafeBackendName T.Text +newtype BackendName = UnsafeBackendName Text deriving stock (Show, Eq) deriving newtype (A.ToJSON, A.ToJSONKey, A.FromJSON, A.FromJSONKey, Hashable, Buildable) backendNameCharSet :: [Char] backendNameCharSet = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "-_;" -newBackendName :: T.Text -> Either T.Text BackendName +newBackendName :: Text -> Either Text BackendName newBackendName t | T.null t = Left "Backend name should contain at least 1 character" @@ -33,7 +34,7 @@ newBackendName t | otherwise = Right $ UnsafeBackendName t -getBackendName :: BackendName -> T.Text +getBackendName :: BackendName -> Text getBackendName (UnsafeBackendName t) = t backendNameCodec :: Toml.Key -> Toml.TomlCodec BackendName diff --git a/lib/Backends.hs b/lib/Backends.hs index 854e0b14..1b40ebc0 100644 --- a/lib/Backends.hs +++ b/lib/Backends.hs @@ -10,7 +10,7 @@ module Backends import Backend (Backend(..), SomeBackend(..)) import Backend.Vault.Kv (VaultKvBackend) import Data.HashMap.Strict qualified as HS -import Data.Text qualified as T +import Data.Text (Text) import Toml (TomlCodec) import Toml qualified import Validation (Validation(Failure)) @@ -34,6 +34,6 @@ backendPackedCodec = Toml.Codec input output <* Toml.codecWrite (Toml.text "type") "vault" supportedBackends - :: T.Text -> Either Toml.TomlBiMapError (Toml.TomlEnv SomeBackend) + :: Text -> Either Toml.TomlBiMapError (Toml.TomlEnv SomeBackend) supportedBackends "vault-kv" = Right $ fmap SomeBackend . Toml.codecRead (_codec @VaultKvBackend) supportedBackends _ = Left (Toml.ArbitraryError "Unknown backend type") diff --git a/lib/Config.hs b/lib/Config.hs index 765c86cd..da54b18c 100644 --- a/lib/Config.hs +++ b/lib/Config.hs @@ -8,13 +8,14 @@ import Backend (Backend(..), SomeBackend(..)) import BackendName (BackendName, backendNameCodec) import Backends (backendPackedCodec) import Data.Foldable (toList) +import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HS -import Toml (TomlCodec) +import Toml (TomlCodec, (.=)) import Toml qualified data Config = Config - { backends :: HS.HashMap BackendName SomeBackend + { backends :: HashMap BackendName SomeBackend , mainBackend :: BackendName } deriving stock (Show) @@ -23,7 +24,7 @@ data Config = configCodec :: TomlCodec Config configCodec = Config <$> Toml.dimap toList listToHs - (Toml.list backendPackedCodec "backend") Toml..= backends - <*> backendNameCodec "main_backend" Toml..= mainBackend + (Toml.list backendPackedCodec "backend") .= backends + <*> backendNameCodec "main_backend" .= mainBackend where listToHs list = HS.fromList $ fmap (\y@(SomeBackend x) -> (_name x, y)) list diff --git a/lib/Entry.hs b/lib/Entry.hs index be26753c..539d8e11 100644 --- a/lib/Entry.hs +++ b/lib/Entry.hs @@ -31,8 +31,10 @@ where import Coffer.Path (EntryPath) import Control.Lens import Data.Aeson qualified as A +import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HS import Data.Hashable (Hashable) +import Data.Set (Set) import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T @@ -41,7 +43,7 @@ import Fmt (Buildable, build) import System.Console.ANSI (SGR(Reset), setSGRCode) import System.Console.ANSI.Codes (csi) -newtype FieldKey = UnsafeFieldKey T.Text +newtype FieldKey = UnsafeFieldKey Text deriving stock (Show, Eq) deriving newtype (A.ToJSON, A.ToJSONKey, A.FromJSON, A.FromJSONKey, Hashable, Buildable) @@ -56,10 +58,10 @@ newFieldKey t Left $ "Tags can only contain the following characters: '" <> T.pack keyCharSet <> "'" | otherwise = Right $ UnsafeFieldKey t -getFieldKey :: FieldKey -> T.Text +getFieldKey :: FieldKey -> Text getFieldKey (UnsafeFieldKey t) = t -newtype EntryTag = UnsafeEntryTag T.Text +newtype EntryTag = UnsafeEntryTag Text deriving stock (Show, Eq, Ord) deriving newtype (A.ToJSON, A.FromJSON, Buildable) @@ -71,7 +73,7 @@ newEntryTag tag Left $ "Tags can only contain the following characters: '" <> T.pack keyCharSet <> "'" | otherwise = Right $ UnsafeEntryTag tag -getEntryTag :: EntryTag -> T.Text +getEntryTag :: EntryTag -> Text getEntryTag (UnsafeEntryTag t) = t data FieldVisibility = Public | Private @@ -92,7 +94,7 @@ instance A.FromJSON FieldVisibility where "private" -> pure Private other -> fail $ "expecting either 'public' or 'private', but found: '" <> T.unpack other <> "'" -newtype FieldValue = FieldValue { unFieldValue :: T.Text } +newtype FieldValue = FieldValue { unFieldValue :: Text } deriving stock (Show, Eq, Ord) makeLensesFor [("unFieldValue", "fieldValue")] ''FieldValue @@ -129,8 +131,8 @@ data Entry = { ePath :: EntryPath , eDateModified :: UTCTime , eMasterField :: Maybe FieldKey - , eFields :: HS.HashMap FieldKey Field - , eTags :: S.Set EntryTag + , eFields :: HashMap FieldKey Field + , eTags :: Set EntryTag } deriving stock (Show, Eq) makeLensesWith abbreviatedFields ''Entry diff --git a/lib/Entry/Json.hs b/lib/Entry/Json.hs index 7c908a38..1b60f009 100644 --- a/lib/Entry/Json.hs +++ b/lib/Entry/Json.hs @@ -5,31 +5,33 @@ module Entry.Json where import Coffer.Path qualified as Path -import Control.Lens +import Control.Lens hiding ((.=)) import Control.Monad (forM) +import Data.Aeson (FromJSON, ToJSON, Value, fromJSON, (.=)) import Data.Aeson qualified as A import Data.Aeson.Lens qualified as A import Data.Either.Extra (eitherToMaybe) import Data.HashMap.Strict qualified as HS +import Data.Text (Text) import Data.Text qualified as T import Data.Time.Format.ISO8601 (iso8601ParseM) -import Entry (Entry, FieldValue(FieldValue)) +import Entry (Entry, EntryConvertible, Field, FieldValue(FieldValue)) import Entry qualified as E import Fmt (pretty) -newtype JsonEntry = JsonEntry A.Value +newtype JsonEntry = JsonEntry Value deriving stock (Show) - deriving newtype (A.ToJSON, A.FromJSON) + deriving newtype (ToJSON, FromJSON) -fieldConverter :: (Prism A.Value A.Value E.Field E.Field) +fieldConverter :: (Prism Value Value Field Field) fieldConverter = prism' to from where - to :: E.Field -> A.Value + to :: Field -> Value to field = A.object - [ "date_modified" A..= (field ^. E.dateModified) - , "visibility" A..= (field ^. E.visibility) - , "value" A..= (field ^. E.value . E.fieldValue) + [ "date_modified" .= (field ^. E.dateModified) + , "visibility" .= (field ^. E.visibility) + , "value" .= (field ^. E.value . E.fieldValue) ] from (A.Object o) = do dateModified <- HS.lookup "date_modified" o @@ -38,23 +40,23 @@ fieldConverter = prism' to from value <- HS.lookup "value" o >>= \case A.String t -> Just t _ -> Nothing - _visibility <- HS.lookup "visibility" o >>= resultToMaybe . A.fromJSON + _visibility <- HS.lookup "visibility" o >>= resultToMaybe . fromJSON pure $ E.newField dateModified (FieldValue value) & E.visibility .~ _visibility from _ = Nothing -instance E.EntryConvertible JsonEntry where +instance EntryConvertible JsonEntry where entry = prism' to from where to :: Entry -> JsonEntry to entry = JsonEntry $ A.object - [ "path" A..= pretty @_ @T.Text (entry ^. E.path) - , "date_modified" A..= (entry ^. E.dateModified) - , "master_field" A..= (entry ^. E.masterField) - , "fields" A..= (HS.fromList . over (each . _1) E.getFieldKey . HS.toList . HS.map (^. re fieldConverter) $ (entry ^. E.fields)) - , "tags" A..= (entry ^. E.tags) + [ "path" .= pretty @_ @Text (entry ^. E.path) + , "date_modified" .= (entry ^. E.dateModified) + , "master_field" .= (entry ^. E.masterField) + , "fields" .= (HS.fromList . over (each . _1) E.getFieldKey . HS.toList . HS.map (^. re fieldConverter) $ (entry ^. E.fields)) + , "tags" .= (entry ^. E.tags) ] from (JsonEntry (A.Object o)) = do @@ -76,7 +78,7 @@ instance E.EntryConvertible JsonEntry where field <- value ^? fieldConverter pure (key, field) pure $ HS.fromList keyFields - _tags <- HS.lookup "tags" o >>= resultToMaybe . A.fromJSON + _tags <- HS.lookup "tags" o >>= resultToMaybe . fromJSON pure $ E.newEntry path dateModified diff --git a/lib/Error.hs b/lib/Error.hs index b26725ea..5764cdec 100644 --- a/lib/Error.hs +++ b/lib/Error.hs @@ -7,11 +7,11 @@ module Error ) where import BackendName (BackendName) -import Data.Text qualified as T +import Data.Text (Text) data CofferError = MarshallingFailed | ConnectError | BackendNotFound BackendName - | OtherError T.Text + | OtherError Text deriving stock (Show) From 10a1d4642723ff4f5cbf3d1211345eb3650a1cc2 Mon Sep 17 00:00:00 2001 From: Diogo Castro Date: Sat, 9 Apr 2022 19:03:12 +0100 Subject: [PATCH 8/9] [#28] Avoid importing internal modules Problem: In a couple of places we're import internal modules from third-party libraries. We should avoid doing that where possible. Solution: Switch to import those definitions from their public modules. --- lib/Backend/Vault/Kv.hs | 2 +- lib/CLI/PrettyPrint.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Backend/Vault/Kv.hs b/lib/Backend/Vault/Kv.hs index 32e23a09..daa7e1b9 100644 --- a/lib/Backend/Vault/Kv.hs +++ b/lib/Backend/Vault/Kv.hs @@ -18,8 +18,8 @@ import Control.Monad (void) import Data.Aeson qualified as A import Data.Aeson.Text qualified as A import Data.Either.Extra (eitherToMaybe, maybeToEither) -import Data.HashMap.Internal.Strict qualified as HS import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HS import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) diff --git a/lib/CLI/PrettyPrint.hs b/lib/CLI/PrettyPrint.hs index 57dd1b78..018d2403 100644 --- a/lib/CLI/PrettyPrint.hs +++ b/lib/CLI/PrettyPrint.hs @@ -14,8 +14,8 @@ import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T -import Data.Text.Internal.Builder (toLazyText) import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Builder (toLazyText) import Data.Time import Entry import Fmt From ff55709fe42db0a69503bc229d0367ff4a261181 Mon Sep 17 00:00:00 2001 From: Diogo Castro Date: Sat, 9 Apr 2022 19:26:44 +0100 Subject: [PATCH 9/9] [#28] Shorten lengthy lines Problem: The `code_style.md` says: > You *should* keep maximum line length below *80 characters*. If > necessary, you *may* use up to *100 characters*, although this is > discouraged. You *should* wrap imports at *100 characters*. However, some lines exceed that limit by a lot. Solution: refactor those lines so they don't exceed the limit. --- lib/Backend/Commands.hs | 88 +++++++++++++++++++++++++---------------- lib/Backend/Vault/Kv.hs | 3 +- lib/CLI/Parser.hs | 25 +++++++++--- lib/CLI/PrettyPrint.hs | 11 +++++- lib/Entry/Json.hs | 8 +++- 5 files changed, 91 insertions(+), 44 deletions(-) diff --git a/lib/Backend/Commands.hs b/lib/Backend/Commands.hs index fd211848..c9492bd6 100644 --- a/lib/Backend/Commands.hs +++ b/lib/Backend/Commands.hs @@ -44,7 +44,7 @@ import Polysemy.Error (Error, throw) import Validation (Validation(Failure, Success)) runCommand - :: (Member BackendEffect r, Member (Embed IO) r, Member (Error CofferError) r) + :: (Members '[BackendEffect, Embed IO, Error CofferError] r) => Config -> Command res -> Sem r res runCommand config = \case CmdView opts -> catchAndReturn $ viewCmd config opts @@ -58,7 +58,7 @@ runCommand config = \case CmdTag opts -> catchAndReturn $ tagCmd config opts viewCmd - :: (Member BackendEffect r, Member (Error CofferError) r, Member (Error ViewResult) r) + :: (Members '[BackendEffect, Error CofferError, Error ViewResult] r) => Config -> ViewOptions -> Sem r ViewResult viewCmd config (ViewOptions (QualifiedPath backendNameMb path) fieldNameMb) = do backend <- getBackend config backendNameMb @@ -87,9 +87,12 @@ viewCmd config (ViewOptions (QualifiedPath backendNameMb path) fieldNameMb) = do createCmd :: forall r - . (Member BackendEffect r, Member (Error CofferError) r, Member (Embed IO) r, Member (Error CreateResult) r) + . (Members '[BackendEffect, Embed IO, Error CofferError, Error CreateResult] r) => Config -> CreateOptions -> Sem r CreateResult -createCmd config (CreateOptions (QualifiedPath backendNameMb entryPath) _edit force tags fields privateFields) = do +createCmd + config + (CreateOptions (QualifiedPath backendNameMb entryPath) _edit force tags fields privateFields) + = do backend <- getBackend config backendNameMb nowUtc <- embed getCurrentTime let @@ -110,9 +113,12 @@ createCmd config (CreateOptions (QualifiedPath backendNameMb entryPath) _edit fo setFieldCmd :: forall r - . (Member BackendEffect r, Member (Error CofferError) r, Member (Embed IO) r, Member (Error SetFieldResult) r) + . (Members '[BackendEffect, Embed IO, Error CofferError, Error SetFieldResult] r) => Config -> SetFieldOptions -> Sem r SetFieldResult -setFieldCmd config (SetFieldOptions (QualifiedPath backendNameMb entryPath) fieldName fieldContentsMb visibilityMb) = do +setFieldCmd + config + (SetFieldOptions (QualifiedPath backendNameMb entryPath) fieldName fieldContentsMb visibilityMb) + = do backend <- getBackend config backendNameMb readSecret backend entryPath >>= \case Nothing -> pure $ SFREntryNotFound entryPath @@ -146,7 +152,7 @@ setFieldCmd config (SetFieldOptions (QualifiedPath backendNameMb entryPath) fiel Nothing -> throw $ SFRMissingFieldContents entryPath deleteFieldCmd - :: (Member BackendEffect r, Member (Error CofferError) r, Member (Embed IO) r) + :: (Members '[BackendEffect, Embed IO, Error CofferError] r) => Config -> DeleteFieldOptions -> Sem r DeleteFieldResult deleteFieldCmd config (DeleteFieldOptions (QualifiedPath backendNameMb path) fieldName) = do backend <- getBackend config backendNameMb @@ -163,7 +169,9 @@ deleteFieldCmd config (DeleteFieldOptions (QualifiedPath backendNameMb path) fie void $ writeSecret backend newEntry pure $ DFRSuccess newEntry -findCmd :: (Member BackendEffect r, Member (Error CofferError) r) => Config -> FindOptions -> Sem r (Maybe Directory) +findCmd + :: (Members '[BackendEffect, Error CofferError] r) + => Config -> FindOptions -> Sem r (Maybe Directory) findCmd config (FindOptions qPathMb textMb sortMb filters filterFields) = do let backendNameMb = qPathMb >>= qpBackendName backend <- getBackend config backendNameMb @@ -255,14 +263,18 @@ findCmd config (FindOptions qPathMb textMb sortMb filters filterFields) = do OpEQ -> (==) renameCmd - :: forall r. - ( Member BackendEffect r - , Member (Embed IO) r - , Member (Error CofferError) r - , Member (Error RenameResult) r - ) + :: forall r + . (Members '[BackendEffect, Embed IO, Error CofferError, Error RenameResult] r) => Config -> RenameOptions -> Sem r RenameResult -renameCmd config (RenameOptions dryRun (QualifiedPath oldBackendNameMb oldPath) (QualifiedPath newBackendNameMb newPath) force) = do +renameCmd + config + (RenameOptions + dryRun + (QualifiedPath oldBackendNameMb oldPath) + (QualifiedPath newBackendNameMb newPath) + force + ) + = do oldBackend <- getBackend config oldBackendNameMb newBackend <- getBackend config newBackendNameMb operations <- buildCopyOperations oldBackend newBackend oldPath newPath force @@ -275,7 +287,8 @@ renameCmd config (RenameOptions dryRun (QualifiedPath oldBackendNameMb oldPath) flip filter operations \(CopyOperation old _) -> none (\(CopyOperation _ new) -> old ^. path == new ^. path) operations - -- If directory/entry was successfully copied, then we can delete old directory/entry without delete errors. + -- If directory/entry was successfully copied, + -- then we can delete old directory/entry without delete errors. unless dryRun do forM_ pathsToDelete \(CopyOperation old _) -> do let qPath = QualifiedPath oldBackendNameMb (Path.entryPathAsPath (old ^. path)) @@ -295,11 +308,7 @@ getOperationPaths (CopyOperation old new) = (old ^. E.path, new ^. E.path) {-# ANN buildCopyOperations ("HLint: ignore Redundant <$>" :: Text) #-} buildCopyOperations :: forall r - . ( Member BackendEffect r - , Member (Embed IO) r - , Member (Error CofferError) r - , Member (Error CopyResult) r - ) + . (Members '[BackendEffect, Embed IO, Error CofferError, Error CopyResult] r) => SomeBackend -> SomeBackend -> Path -> Path -> Bool -> Sem r [CopyOperation] buildCopyOperations oldBackend newBackend oldPath newPath force = do entryOrDir <- getEntryOrDirThrow oldBackend CPRPathNotFound oldPath @@ -344,7 +353,10 @@ buildCopyOperations oldBackend newBackend oldPath newPath force = do CopyOperation old (new & dateModified .~ nowUtc) -- | Performs a check on `CopyOperation` and returns @Failure@ if any of checks fail. - validateCopyOperation :: SomeBackend -> CopyOperation -> Sem r (Validation [(EntryPath, CreateError)] Entry) + validateCopyOperation + :: SomeBackend + -> CopyOperation + -> Sem r (Validation [(EntryPath, CreateError)] Entry) validateCopyOperation backend (CopyOperation old new) = checkCreateEntry backend force new <&> first \err -> [(old ^. path, err)] @@ -354,13 +366,17 @@ runCopyOperations backend operations = do forM_ newEntries (writeSecret backend) copyCmd - :: ( Member BackendEffect r - , Member (Embed IO) r - , Member (Error CofferError) r - , Member (Error CopyResult) r - ) + :: (Members '[BackendEffect, Embed IO, Error CofferError, Error CopyResult] r) => Config -> CopyOptions -> Sem r CopyResult -copyCmd config (CopyOptions dryRun (QualifiedPath oldBackendNameMb oldPath) (QualifiedPath newBackendNameMb newPath) force) = do +copyCmd + config + (CopyOptions + dryRun + (QualifiedPath oldBackendNameMb oldPath) + (QualifiedPath newBackendNameMb newPath) + force + ) + = do oldBackend <- getBackend config oldBackendNameMb newBackend <- getBackend config newBackendNameMb operations <- buildCopyOperations oldBackend newBackend oldPath newPath force @@ -371,7 +387,7 @@ copyCmd config (CopyOptions dryRun (QualifiedPath oldBackendNameMb oldPath) (Qua pure $ CPRSuccess $ getOperationPaths <$> operations deleteCmd - :: (Member BackendEffect r, Member (Error CofferError) r, Member (Error DeleteResult) r) + :: (Members '[BackendEffect, Embed IO, Error CofferError, Error DeleteResult] r) => Config -> DeleteOptions -> Sem r DeleteResult deleteCmd config (DeleteOptions dryRun (QualifiedPath backendNameMb path) recursive) = do backend <- getBackend config backendNameMb @@ -390,7 +406,7 @@ deleteCmd config (DeleteOptions dryRun (QualifiedPath backendNameMb path) recurs tagCmd :: forall r - . (Member BackendEffect r, Member (Error CofferError) r, Member (Embed IO) r, Member (Error TagResult) r) + . (Members '[BackendEffect, Embed IO, Error CofferError, Error TagResult] r) => Config -> TagOptions -> Sem r TagResult tagCmd config (TagOptions (QualifiedPath backendNameMb entryPath) tag delete) = do backend <- getBackend config backendNameMb @@ -441,7 +457,7 @@ pathIsEntry backend entryPath = -- | Returns the entry or directory that the path points to. -- If the path doesn't exist at all, throws an error. getEntryOrDirThrow - :: (Member BackendEffect r, Member (Error CofferError) r, Member (Error e) r) + :: (Members '[BackendEffect, Error CofferError, Error e] r) => SomeBackend -> (Path -> e) -> Path -> Sem r (Either Entry Directory) getEntryOrDirThrow backend mkError path = do getEntryOrDir backend path >>= \case @@ -452,7 +468,7 @@ getEntryOrDirThrow backend mkError path = do -- If the path doesn't exist at all, returns `Nothing`. getEntryOrDir :: forall r - . (Member BackendEffect r, Member (Error CofferError) r) + . (Members '[BackendEffect, Error CofferError] r) => SomeBackend -> Path -> Sem r (Maybe (Either Entry Directory)) getEntryOrDir backend path = tryGetEntry path >>= \case @@ -508,7 +524,9 @@ getEntryOrDir backend path = -- -- Note: the root path @/@ cannot possibly be occupied by an entry, -- therefore we skip the check for that path. -getEntriesInEntryPath :: forall r. Member BackendEffect r => SomeBackend -> EntryPath -> Sem r [EntryPath] +getEntriesInEntryPath + :: forall r. Member BackendEffect r + => SomeBackend -> EntryPath -> Sem r [EntryPath] getEntriesInEntryPath backend entryPath = do let parentDirsExceptRoot = entryPath & Path.entryPathParentDirs @@ -546,7 +564,9 @@ checkCreateEntry backend force entry = catchAndReturn act pure $ Success entry -getBackend :: forall r. Member (Error CofferError) r => Config -> Maybe BackendName -> Sem r SomeBackend +getBackend + :: forall r. Member (Error CofferError) r + => Config -> Maybe BackendName -> Sem r SomeBackend getBackend config backendNameMb = do let backendName = fromMaybe (mainBackend config) backendNameMb let backendsHashMap = backends config diff --git a/lib/Backend/Vault/Kv.hs b/lib/Backend/Vault/Kv.hs index daa7e1b9..42d6a98d 100644 --- a/lib/Backend/Vault/Kv.hs +++ b/lib/Backend/Vault/Kv.hs @@ -100,7 +100,8 @@ getEnv backend = url = vbAddress backend -- | Handles @ClientError@ in the following way: --- 1. If it is @FailureResponse@ and status code isn't 404, then we would get an error. It status code is 404, the result would be Nothing +-- 1. If it is @FailureResponse@ and status code isn't 404, then we would get an error. +-- It status code is 404, the result would be Nothing -- 2. If it is @ConnectionError@, then we would get @ConnectError@ -- 3. Otherwise we would get @MarshallingFailed@ exceptionHandler :: ClientError -> Maybe CofferError diff --git a/lib/CLI/Parser.hs b/lib/CLI/Parser.hs index 70302630..be3a2d45 100644 --- a/lib/CLI/Parser.hs +++ b/lib/CLI/Parser.hs @@ -120,7 +120,9 @@ createOptions = CreateOptions <$> argument readQualifiedEntryPath ( mconcat [ metavar "ENTRYPATH" - , help "The path to insert the new entry into, this must not already be a directory or an entry unless `-f` is specified" + , help + "The path to insert the new entry into, this must not already be \ + \a directory or an entry unless `-f` is specified" ]) <*> switch ( mconcat [ long "edit" @@ -134,7 +136,9 @@ createOptions = <*> switch ( mconcat [ long "force" , short 'f' - , help "If a directory or entry already exists under the specified path, delete it and insert this entry instead" + , help + "If a directory or entry already exists under the specified path, \ + \delete it and insert this entry instead" ]) <*> (Set.fromList <$> many ( option readEntryTag $ mconcat [ long "tag" @@ -145,7 +149,9 @@ createOptions = <*> many ( option readFieldInfo $ mconcat [ long "field" , metavar "NAME=CONTENT" - , help "A field to insert into the new entry, with the format 'fieldname=fieldcontents', this may be specified multiple times" + , help + "A field to insert into the new entry, with the format 'fieldname=fieldcontents', \ + \this may be specified multiple times" ]) <*> many ( option readFieldInfo $ mconcat [ long "privatefield" @@ -170,7 +176,10 @@ setFieldOptions = ]) <*> optional (argument readFieldValue $ mconcat [ metavar "FIELDCONTENTS" - , help "The contents to insert into the field. Required when creating a new field, optional otherwise" + , help $ unlines + [ "The contents to insert into the field." + , "Required when creating a new field, optional otherwise." + ] ]) <*> optional (option readFieldVisibility $ mconcat [ long "visibility" @@ -251,7 +260,9 @@ renameOptions = <*> switch ( mconcat [ long "force" , short 'f' - , help "If a directory or entry already exists under the specified path, delete it and insert this entry instead" + , help + "If a directory or entry already exists under the specified path, \ + \delete it and insert this entry instead" ]) copyOptions :: Parser CopyOptions @@ -273,7 +284,9 @@ copyOptions = <*> switch ( mconcat [ long "force" , short 'f' - , help "If a directory or entry already exists under the specified path, delete it and insert this entry instead" + , help + "If a directory or entry already exists under the specified path, \ + \delete it and insert this entry instead" ]) deleteOptions :: Parser DeleteOptions diff --git a/lib/CLI/PrettyPrint.hs b/lib/CLI/PrettyPrint.hs index 018d2403..88b590dd 100644 --- a/lib/CLI/PrettyPrint.hs +++ b/lib/CLI/PrettyPrint.hs @@ -60,10 +60,17 @@ buildTags tags = buildFields :: [(FieldKey, Field)] -> [Builder] buildFields fields = do let formattedFields = fields <&> buildField - let maxFieldLength = formattedFields <&> (\(firstLine, _) -> TL.length (toLazyText firstLine) & fromIntegral @Int64 @Int) & maximum + let maxFieldLength = + formattedFields + <&> (\(firstLine, _) -> TL.length (toLazyText firstLine) & fromIntegral @Int64 @Int) + & maximum formattedFields `zip` fields <&> \((firstLine, otherLinesMb), (_, field)) -> do - let formattedFirstLine = padRightF maxFieldLength ' ' firstLine <> " " <> buildDate (field ^. dateModified) + let formattedFirstLine = mconcat + [ padRightF maxFieldLength ' ' firstLine + , " " + , buildDate (field ^. dateModified) + ] case otherLinesMb of Nothing -> formattedFirstLine Just otherLines -> unlinesF [formattedFirstLine, otherLines] diff --git a/lib/Entry/Json.hs b/lib/Entry/Json.hs index 1b60f009..23637a54 100644 --- a/lib/Entry/Json.hs +++ b/lib/Entry/Json.hs @@ -55,7 +55,13 @@ instance EntryConvertible JsonEntry where [ "path" .= pretty @_ @Text (entry ^. E.path) , "date_modified" .= (entry ^. E.dateModified) , "master_field" .= (entry ^. E.masterField) - , "fields" .= (HS.fromList . over (each . _1) E.getFieldKey . HS.toList . HS.map (^. re fieldConverter) $ (entry ^. E.fields)) + , "fields" .= + ( HS.fromList + . over (each . _1) E.getFieldKey + . HS.toList + . HS.map (^. re fieldConverter) + $ (entry ^. E.fields) + ) , "tags" .= (entry ^. E.tags) ] from (JsonEntry (A.Object o)) =