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)) =