diff --git a/app/cli/Main.hs b/app/cli/Main.hs index 41311e11..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) @@ -86,12 +87,13 @@ main = do runCommand config cmd >>= \case res@SFREntryNotFound{} -> printError $ buildSetFieldResult CLI res res@SFRSuccess{} -> printSuccess $ buildSetFieldResult CLI res - + SomeCommand cmd@CmdSetFieldVisibility{} -> do runCommand config cmd >>= \case - res@SFREntryNotFound{} -> printError $ buildSetFieldResult CLI res - res@SFRSuccess{} -> printSuccess $ buildSetFieldResult CLI res + 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 diff --git a/lib/Backend/Commands.hs b/lib/Backend/Commands.hs index fec613bc..45f75861 100644 --- a/lib/Backend/Commands.hs +++ b/lib/Backend/Commands.hs @@ -35,7 +35,7 @@ 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, FieldContents, FieldName, FieldVisibility(..), contents, dateModified, + (Entry, EntryTag, Field, FieldName, FieldVisibility(..), contents, dateModified, fieldContents, fields, newEntry, newField, path, visibility) import Entry qualified as E import Error (CofferError(..), InternalCommandsError(EntryPathDoesntHavePrefix)) @@ -115,24 +115,18 @@ createCmd void $ writeEntry backend entry pure $ CRSuccess qEntryPath { qpPath = entry } -updateVisibility :: Maybe FieldVisibility -> Field -> Field -updateVisibility newVisibilityMb field = - field & visibility %~ \current -> fromMaybe current newVisibilityMb - -setFieldCommon - :: forall r. - (Members '[BackendEffect, Embed IO, Error CofferError, Error SetFieldResult] r) - => Config - -> QualifiedPath EntryPath - -> FieldName - -> Either (FieldContents, Maybe FieldVisibility) FieldVisibility - -> Sem r SetFieldResult -setFieldCommon +setFieldCmd + :: forall r + . (Members '[BackendEffect, Embed IO, Error CofferError, Error SetFieldResult] r) + => Config -> SetFieldOptions -> Sem r SetFieldResult +setFieldCmd config - qEntryPath@(QualifiedPath backendNameMb entryPath) - fieldName - operation - = do + (SetFieldOptions + qEntryPath@(QualifiedPath backendNameMb entryPath) + fieldName + fieldContents + visibilityMb + ) = do backend <- getBackend config backendNameMb readEntry backend entryPath >>= \case Nothing -> do @@ -147,96 +141,60 @@ setFieldCommon updateOrInsert nowUtc entry = entry & dateModified .~ nowUtc - & fields . at fieldName %%~ updateOrInsertField nowUtc + & fields . at fieldName %%~ updateOrInsertFieldFull nowUtc - updateOrInsertField :: UTCTime -> Maybe Field -> Sem r (Maybe Field) - updateOrInsertField nowUtc fieldMb = case (operation, fieldMb) of - (Left (fieldContents, _), Nothing) -> + updateOrInsertFieldFull :: UTCTime -> Maybe Field -> Sem r (Maybe Field) + updateOrInsertFieldFull nowUtc = + pure . Just . + (visibility %~ \current -> fromMaybe current visibilityMb) . + updateOrInsertField nowUtc + + updateOrInsertField :: UTCTime -> Maybe Field -> Field + updateOrInsertField nowUtc fieldMb = case fieldMb of + Nothing -> -- The field does not yet exist, insert a new one. - pure $ Just $ newField nowUtc fieldContents - & updateVisibility newVisibilityMb - (Left (fieldContents, _), Just field) -> + newField nowUtc fieldContents + Just field -> -- The field already exists, update it. - pure $ Just $ field + field & dateModified .~ nowUtc & contents .~ fieldContents - & updateVisibility newVisibilityMb - (Right _, Nothing) -> - -- Updating visibility of a non-existent field - pure Nothing - (Right _, Just field) -> - -- Updating visibility of a field - pure $ Just $ field - & dateModified .~ nowUtc - & updateVisibility newVisibilityMb - - newVisibilityMb :: Maybe FieldVisibility - newVisibilityMb = case operation of - Left (_, visibilityMb) -> visibilityMb - Right visibility -> Just visibility -setFieldCmd +setFieldVisibilityCmd :: forall r - . (Members '[BackendEffect, Embed IO, Error CofferError, Error SetFieldResult] r) - => Config -> SetFieldOptions -> Sem r SetFieldResult -setFieldCmd + . (Members '[BackendEffect, Embed IO, Error CofferError, Error SetFieldVisibilityResult] r) + => Config -> SetFieldVisibilityOptions -> Sem r SetFieldVisibilityResult +setFieldVisibilityCmd config - (SetFieldOptions + (SetFieldVisibilityOptions qEntryPath@(QualifiedPath backendNameMb entryPath) fieldName - contents - fieldVisibilityMb) - = do + fieldVisibility + ) = do backend <- getBackend config backendNameMb readEntry backend entryPath >>= \case Nothing -> do - pure $ SFREntryNotFound qEntryPath + pure $ SFVREntryNotFound qEntryPath Just entry -> do nowUtc <- embed getCurrentTime - updatedEntry <- updateOrInsert nowUtc entry + updatedEntry <- update nowUtc entry void $ writeEntry backend updatedEntry - pure $ SFRSuccess fieldName (QualifiedPath backendNameMb updatedEntry) + pure $ SFVRSuccess fieldName (QualifiedPath backendNameMb updatedEntry) where - updateOrInsert :: UTCTime -> Entry -> Sem r Entry - updateOrInsert nowUtc entry = + update :: UTCTime -> Entry -> Sem r Entry + update nowUtc entry = entry & dateModified .~ nowUtc - & fields . at fieldName %%~ updateOrInsertField nowUtc - - updateOrInsertField :: UTCTime -> Maybe Field -> Sem r (Maybe Field) - updateOrInsertField nowUtc fieldMb = case (operation, fieldMb) of - (Left (fieldContents, _), Nothing) -> - -- The field does not yet exist, insert a new one. - pure $ Just $ newField nowUtc fieldContents - & updateVisibility newVisibilityMb - (Left (fieldContents, _), Just field) -> - -- The field already exists, update it. - pure $ Just $ field - & dateModified .~ nowUtc - & contents .~ fieldContents - & updateVisibility newVisibilityMb - (Right _, Nothing) -> - -- Updating visibility of a non-existent field - pure Nothing - (Right _, Just field) -> - -- Updating visibility of a field - pure $ Just $ field - & dateModified .~ nowUtc - & updateVisibility newVisibilityMb + & fields . at fieldName %%~ (fmap Just . updateField nowUtc) - newVisibilityMb :: Maybe FieldVisibility - newVisibilityMb = case operation of - Left (_, visibilityMb) -> visibilityMb - Right visibility -> Just visibility + updateField :: UTCTime -> Maybe Field -> Sem r Field + updateField nowUtc fieldMb = + updateVisibility fieldMb + <&> dateModified .~ nowUtc -setFieldVisibilityCmd - :: forall r - . (Members '[BackendEffect, Embed IO, Error CofferError, Error SetFieldResult] r) - => Config -> SetFieldVisibilityOptions -> Sem r SetFieldResult -setFieldVisibilityCmd - config - (SetFieldVisibilityOptions qEntryPath fieldName visibility) - = setFieldCommon config qEntryPath fieldName (Right visibility) + 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/Types.hs b/lib/CLI/Types.hs index 42e4f255..37fedd59 100644 --- a/lib/CLI/Types.hs +++ b/lib/CLI/Types.hs @@ -39,7 +39,7 @@ data Command res where CmdView :: ViewOptions -> Command ViewResult CmdCreate :: CreateOptions -> Command CreateResult CmdSetField :: SetFieldOptions -> Command SetFieldResult - CmdSetFieldVisibility :: SetFieldVisibilityOptions -> Command SetFieldResult + CmdSetFieldVisibility :: SetFieldVisibilityOptions -> Command SetFieldVisibilityResult CmdDeleteField :: DeleteFieldOptions -> Command DeleteFieldResult CmdFind :: FindOptions -> Command (Maybe Directory) CmdRename :: RenameOptions -> Command RenameResult @@ -87,7 +87,7 @@ data SetFieldResult data SetFieldVisibilityResult = SFVRSuccess FieldName (QualifiedPath Entry) | SFVREntryNotFound (QualifiedPath EntryPath) - | SFVRFieldNotFound FieldName + | SFVRFieldNotFound FieldName (QualifiedPath EntryPath) deriving stock (Show) data DeleteFieldResult diff --git a/lib/Coffer/PrettyPrint.hs b/lib/Coffer/PrettyPrint.hs index a798f054..c3905ec0 100644 --- a/lib/Coffer/PrettyPrint.hs +++ b/lib/Coffer/PrettyPrint.hs @@ -80,6 +80,20 @@ buildSetFieldResult _ = \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 384a4025..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 @@ -69,6 +70,16 @@ handleSetFieldResult = \case 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) @@ -217,7 +228,7 @@ setFieldVisibility run path field visibility = { sfvoQPath = QualifiedPath Nothing path , sfvoFieldName = field , sfvoVisibility = visibility - }) >>= handleSetFieldResult + }) >>= handleSetFieldVisibilityResult setField :: (forall a. Command a -> Handler a) 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 - <