From 1ae203469cae357766036579d02f5f7121a9f84f Mon Sep 17 00:00:00 2001 From: Aleksandr Pak Date: Thu, 28 Jul 2022 15:16:42 +0300 Subject: [PATCH] [#119] Add `set-field-visibility` to CLI and refactor `set-field` Problem: See issue #119. Solution: Split `set-field` command into a `set-field` with contents and `set-field-visibility`. --- app/cli/Main.hs | 11 ++- lib/Backend/Commands.hs | 79 ++++++++++++++----- lib/CLI/Parser.hs | 29 +++++-- lib/CLI/Types.hs | 17 +++- lib/Coffer/PrettyPrint.hs | 25 +++--- lib/Web/Server.hs | 28 ++++--- .../set-field-command/set-field-command.bats | 10 +-- 7 files changed, 144 insertions(+), 55 deletions(-) diff --git a/app/cli/Main.hs b/app/cli/Main.hs index 6cdd2a3a..13424fc1 100644 --- a/app/cli/Main.hs +++ b/app/cli/Main.hs @@ -12,7 +12,8 @@ import CLI.PrettyPrint import CLI.Types import Coffer.PrettyPrint (PrettyPrintMode(CLI), buildCopyResult, buildCreateResult, buildDeleteFieldResult, - buildDeleteResult, buildRenameResult, buildSetFieldResult, buildTagResult, buildViewResult) + buildDeleteResult, buildRenameResult, buildSetFieldResult, buildSetFieldVisibilityResult, + buildTagResult, buildViewResult) import Config (Config(..), configCodec) import Control.Lens import Data.Maybe (fromMaybe) @@ -85,9 +86,15 @@ main = do SomeCommand cmd@CmdSetField{} -> do runCommand config cmd >>= \case res@SFREntryNotFound{} -> printError $ buildSetFieldResult CLI res - res@SFRMissingFieldContents{} -> printError $ buildSetFieldResult CLI res res@SFRSuccess{} -> printSuccess $ buildSetFieldResult CLI res + + SomeCommand cmd@CmdSetFieldVisibility{} -> do + runCommand config cmd >>= \case + res@SFVREntryNotFound{} -> printError $ buildSetFieldVisibilityResult CLI res + res@SFVRSuccess{} -> printSuccess $ buildSetFieldVisibilityResult CLI res + res@SFVRFieldNotFound{} -> printError $ buildSetFieldVisibilityResult CLI res + SomeCommand cmd@CmdDeleteField{} -> do runCommand config cmd >>= \case res@DFREntryNotFound{} -> printError $ buildDeleteFieldResult CLI res diff --git a/lib/Backend/Commands.hs b/lib/Backend/Commands.hs index f8769170..45f75861 100644 --- a/lib/Backend/Commands.hs +++ b/lib/Backend/Commands.hs @@ -35,8 +35,8 @@ import Data.Time (UTCTime, getCurrentTime, utctDay) import Data.Time.Calendar.Compat (pattern YearMonthDay) import Data.Time.Calendar.Month.Compat (pattern MonthDay) import Entry - (Entry, EntryTag, Field, FieldName, FieldVisibility(..), contents, dateModified, fieldContents, - fields, newEntry, newField, path, visibility) + (Entry, EntryTag, Field, FieldName, FieldVisibility(..), contents, dateModified, + fieldContents, fields, newEntry, newField, path, visibility) import Entry qualified as E import Error (CofferError(..), InternalCommandsError(EntryPathDoesntHavePrefix)) import GHC.Exts (Down(..), sortWith) @@ -51,6 +51,7 @@ runCommand config = \case CmdView opts -> catchAndReturn $ viewCmd config opts CmdCreate opts -> catchAndReturn $ createCmd config opts CmdSetField opts -> catchAndReturn $ setFieldCmd config opts + CmdSetFieldVisibility opts -> catchAndReturn $ setFieldVisibilityCmd config opts CmdDeleteField opts -> deleteFieldCmd config opts CmdFind opts -> findCmd config opts CmdRename opts -> catchAndReturn $ renameCmd config opts @@ -120,8 +121,12 @@ setFieldCmd => Config -> SetFieldOptions -> Sem r SetFieldResult setFieldCmd config - (SetFieldOptions qEntryPath@(QualifiedPath backendNameMb entryPath) fieldName fieldContentsMb visibilityMb) - = do + (SetFieldOptions + qEntryPath@(QualifiedPath backendNameMb entryPath) + fieldName + fieldContents + visibilityMb + ) = do backend <- getBackend config backendNameMb readEntry backend entryPath >>= \case Nothing -> do @@ -136,26 +141,60 @@ setFieldCmd updateOrInsert nowUtc entry = entry & dateModified .~ nowUtc - & fields . at fieldName %%~ updateOrInsertField nowUtc + & fields . at fieldName %%~ updateOrInsertFieldFull nowUtc + + updateOrInsertFieldFull :: UTCTime -> Maybe Field -> Sem r (Maybe Field) + updateOrInsertFieldFull nowUtc = + pure . Just . + (visibility %~ \current -> fromMaybe current visibilityMb) . + updateOrInsertField nowUtc - updateOrInsertField :: UTCTime -> Maybe Field -> Sem r (Maybe Field) - updateOrInsertField nowUtc = \case + updateOrInsertField :: UTCTime -> Maybe Field -> Field + updateOrInsertField nowUtc fieldMb = case fieldMb of + Nothing -> + -- The field does not yet exist, insert a new one. + newField nowUtc fieldContents Just field -> -- The field already exists, update it. - pure $ Just $ field + field & dateModified .~ nowUtc - & contents %~ do \currentContents -> fromMaybe currentContents fieldContentsMb - & visibility %~ do \currentPrivate -> fromMaybe currentPrivate visibilityMb - Nothing -> - -- The field does not yet exist, insert a new one. - case fieldContentsMb of - Just fieldContents -> pure $ Just $ newField nowUtc fieldContents - & visibility %~ do \currentPrivate -> fromMaybe currentPrivate visibilityMb - -- If we're trying to insert a new field, but the user has not specified - -- what the field contents should be, return an error. - Nothing -> do - let qEntryPath = QualifiedPath backendNameMb entryPath - throw $ SFRMissingFieldContents fieldName qEntryPath + & contents .~ fieldContents + +setFieldVisibilityCmd + :: forall r + . (Members '[BackendEffect, Embed IO, Error CofferError, Error SetFieldVisibilityResult] r) + => Config -> SetFieldVisibilityOptions -> Sem r SetFieldVisibilityResult +setFieldVisibilityCmd + config + (SetFieldVisibilityOptions + qEntryPath@(QualifiedPath backendNameMb entryPath) + fieldName + fieldVisibility + ) = do + backend <- getBackend config backendNameMb + readEntry backend entryPath >>= \case + Nothing -> do + pure $ SFVREntryNotFound qEntryPath + Just entry -> do + nowUtc <- embed getCurrentTime + updatedEntry <- update nowUtc entry + void $ writeEntry backend updatedEntry + pure $ SFVRSuccess fieldName (QualifiedPath backendNameMb updatedEntry) + where + update :: UTCTime -> Entry -> Sem r Entry + update nowUtc entry = + entry + & dateModified .~ nowUtc + & fields . at fieldName %%~ (fmap Just . updateField nowUtc) + + updateField :: UTCTime -> Maybe Field -> Sem r Field + updateField nowUtc fieldMb = + updateVisibility fieldMb + <&> dateModified .~ nowUtc + + updateVisibility :: Maybe Field -> Sem r Field + updateVisibility Nothing = throw $ SFVRFieldNotFound fieldName qEntryPath + updateVisibility (Just field) = pure $ field & visibility .~ fieldVisibility deleteFieldCmd :: (Members '[BackendEffect, Embed IO, Error CofferError] r) diff --git a/lib/CLI/Parser.hs b/lib/CLI/Parser.hs index e0c5b1dc..b74eb785 100644 --- a/lib/CLI/Parser.hs +++ b/lib/CLI/Parser.hs @@ -66,6 +66,8 @@ commandParser = "Create a new entry at the specified path" , mkCommand "set-field" CmdSetField setFieldOptions "Set a field on the entry at the specified path" + , mkCommand "set-field-visibility" CmdSetFieldVisibility setFieldVisibilityOptions + "Change a field's visibility on the entry at the specified path" , mkCommand "delete-field" CmdDeleteField deleteFieldOptions "Delete a field from the entry at the specified path" , mkCommand "find" CmdFind findOptions @@ -166,12 +168,9 @@ setFieldOptions = [ metavar "FIELDNAME" , help "The name of the field to set" ]) - <*> optional (argument readFieldContents $ mconcat + <*> argument readFieldContents ( mconcat [ metavar "FIELDCONTENTS" - , help $ unlines - [ "The contents to insert into the field." - , "Required when creating a new field, optional otherwise." - ] + , help $ "The contents to insert into the field." ]) <*> optional (option readFieldVisibility $ mconcat [ long "visibility" @@ -185,6 +184,26 @@ setFieldOptions = ] ]) +setFieldVisibilityOptions :: Parser SetFieldVisibilityOptions +setFieldVisibilityOptions = + SetFieldVisibilityOptions + <$> argument readQualifiedEntryPath ( mconcat + [ metavar "ENTRYPATH" + , help "The path to set the field visibility on, this must already exist as an entry" + ]) + <*> argument readFieldName ( mconcat + [ metavar "FIELDNAME" + , help "The name of the field to set" + ]) + <*> argument readFieldVisibility ( mconcat + [ metavar "VISIBILITY" + , help $ unlines + [ "Whether to mark this field as 'public' or 'private'" + , "Private fields can only be viewed with 'coffer view'," + , "and will be hidden when using other commands." + ] + ]) + deleteFieldOptions :: Parser DeleteFieldOptions deleteFieldOptions = DeleteFieldOptions diff --git a/lib/CLI/Types.hs b/lib/CLI/Types.hs index 65d8d9fc..37fedd59 100644 --- a/lib/CLI/Types.hs +++ b/lib/CLI/Types.hs @@ -39,6 +39,7 @@ data Command res where CmdView :: ViewOptions -> Command ViewResult CmdCreate :: CreateOptions -> Command CreateResult CmdSetField :: SetFieldOptions -> Command SetFieldResult + CmdSetFieldVisibility :: SetFieldVisibilityOptions -> Command SetFieldVisibilityResult CmdDeleteField :: DeleteFieldOptions -> Command DeleteFieldResult CmdFind :: FindOptions -> Command (Maybe Directory) CmdRename :: RenameOptions -> Command RenameResult @@ -81,7 +82,12 @@ data CreateResult data SetFieldResult = SFRSuccess FieldName (QualifiedPath Entry) | SFREntryNotFound (QualifiedPath EntryPath) - | SFRMissingFieldContents FieldName (QualifiedPath EntryPath) + deriving stock (Show) + +data SetFieldVisibilityResult + = SFVRSuccess FieldName (QualifiedPath Entry) + | SFVREntryNotFound (QualifiedPath EntryPath) + | SFVRFieldNotFound FieldName (QualifiedPath EntryPath) deriving stock (Show) data DeleteFieldResult @@ -136,11 +142,18 @@ data CreateOptions = CreateOptions data SetFieldOptions = SetFieldOptions { sfoQPath :: QualifiedPath EntryPath , sfoFieldName :: FieldName - , sfoFieldContents :: Maybe FieldContents + , sfoFieldContents :: FieldContents , sfoVisibility :: Maybe FieldVisibility } deriving stock (Show) +data SetFieldVisibilityOptions = SetFieldVisibilityOptions + { sfvoQPath :: QualifiedPath EntryPath + , sfvoFieldName :: FieldName + , sfvoVisibility :: FieldVisibility + } + deriving stock (Show) + data DeleteFieldOptions = DeleteFieldOptions { dfoQPath :: QualifiedPath EntryPath , dfoFieldName :: FieldName diff --git a/lib/Coffer/PrettyPrint.hs b/lib/Coffer/PrettyPrint.hs index 1a11433e..c3905ec0 100644 --- a/lib/Coffer/PrettyPrint.hs +++ b/lib/Coffer/PrettyPrint.hs @@ -68,17 +68,8 @@ buildCreateResult mode = \case |] buildSetFieldResult :: PrettyPrintMode -> SetFieldResult -> Builder -buildSetFieldResult mode = \case +buildSetFieldResult _ = \case SFREntryNotFound path -> buildEntryNotFound path - SFRMissingFieldContents fieldName path -> do - let fieldContentsMessage :: Builder = - case mode of - CLI -> "In order to create a new field, please include the 'FIELDCONTENTS' argument." - WebAPI -> "In order to create a new field, please include 'FIELDCONTENTS' in the body." - [int|s| - The entry at '#{path}' does not yet have a field '#{fieldName}'. - #{fieldContentsMessage} - |] SFRSuccess fieldName qEntry -> do let entry = qpPath qEntry let qPath = view E.path <$> qEntry @@ -89,6 +80,20 @@ buildSetFieldResult mode = \case #{field ^. E.contents} |] +buildSetFieldVisibilityResult :: PrettyPrintMode -> SetFieldVisibilityResult -> Builder +buildSetFieldVisibilityResult _ = \case + SFVRSuccess fieldName qEntry -> do + let entry = qpPath qEntry + let qPath = view E.path <$> qEntry + let field = entry ^?! E.fields . ix fieldName + [int|s| + Set visibility of field '#{fieldName}' \ + at '#{qPath}' to #{field ^. E.visibility} + |] + SFVREntryNotFound path -> buildEntryNotFound path + SFVRFieldNotFound field qPath -> [int||The entry at '#{qPath}' does not have a field '#{field}'.|] + + buildDeleteFieldResult :: PrettyPrintMode -> DeleteFieldResult -> Builder buildDeleteFieldResult _ = \case DFREntryNotFound path -> buildEntryNotFound path diff --git a/lib/Web/Server.hs b/lib/Web/Server.hs index de29ed57..f83ea151 100644 --- a/lib/Web/Server.hs +++ b/lib/Web/Server.hs @@ -26,7 +26,8 @@ import Coffer.Directory (Directory, singleton) import Coffer.Path (EntryPath, Path, QualifiedPath(QualifiedPath, qpPath)) import Coffer.PrettyPrint (PrettyPrintMode(WebAPI), buildCopyOrRenameResult, buildCreateError, buildDeleteFieldResult, - buildDeleteResult, buildSetFieldResult, buildTagResult, buildViewResult) + buildDeleteResult, buildSetFieldResult, buildSetFieldVisibilityResult, buildTagResult, + buildViewResult) import Data.Aeson import Data.Aeson.Casing import Data.Aeson.TH @@ -66,11 +67,19 @@ handleSetFieldResult = \case SFRSuccess _ qEntry -> pure $ qpPath qEntry res@SFREntryNotFound{} -> throwCofferServerError err404 300 (pretty res) - res@SFRMissingFieldContents{} -> - throwCofferServerError err400 301 (pretty res) where pretty = resultToText buildSetFieldResult +handleSetFieldVisibilityResult :: SetFieldVisibilityResult -> Handler Entry +handleSetFieldVisibilityResult = \case + SFVRSuccess _ qEntry -> pure $ qpPath qEntry + res@SFVREntryNotFound{} -> + throwCofferServerError err404 300 (pretty res) + res@SFVRFieldNotFound{} -> + throwCofferServerError err404 301 (pretty res) + where + pretty = resultToText buildSetFieldVisibilityResult + handleCopyOrRenameResult :: Bool -> CopyResult -> Handler [(EntryPath, EntryPath)] handleCopyOrRenameResult rename = \case CPRSuccess _ paths -> pure (paths <&> bimap qpPath qpPath) @@ -215,12 +224,11 @@ setFieldVisibility -> FieldVisibility -> Handler Entry setFieldVisibility run path field visibility = - run (CmdSetField SetFieldOptions - { sfoQPath = QualifiedPath Nothing path - , sfoFieldName = field - , sfoFieldContents = Nothing - , sfoVisibility = Just visibility - }) >>= handleSetFieldResult + run (CmdSetFieldVisibility SetFieldVisibilityOptions + { sfvoQPath = QualifiedPath Nothing path + , sfvoFieldName = field + , sfvoVisibility = visibility + }) >>= handleSetFieldVisibilityResult setField :: (forall a. Command a -> Handler a) @@ -233,7 +241,7 @@ setField run path field visibility contents = run (CmdSetField SetFieldOptions { sfoQPath = QualifiedPath Nothing path , sfoFieldName = field - , sfoFieldContents = Just contents + , sfoFieldContents = contents , sfoVisibility = visibility }) >>= handleSetFieldResult diff --git a/tests/golden/set-field-command/set-field-command.bats b/tests/golden/set-field-command/set-field-command.bats index f8c1b982..3e2b1373 100644 --- a/tests/golden/set-field-command/set-field-command.bats +++ b/tests/golden/set-field-command/set-field-command.bats @@ -27,12 +27,11 @@ EOF test: aba [2000-01-01 01:01:01] EOF - run coffer set-field /a/b test -V private + run coffer set-field-visibility /a/b test private assert_success assert_output - <