[#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

@@ -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

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)

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

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

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)

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 - <<EOF
-[SUCCESS] Set field 'test' (private) at '/a/b' to:
-aba
+[SUCCESS] Set visibility of field 'test' at '/a/b' to private
 EOF
 
   run cleanOutput coffer find
@@ -56,12 +55,11 @@ EOF
 @test "change visibility on non existing field" {
   coffer create /a/b
 
-  run coffer set-field /a/b not-exist -V public
+  run coffer set-field-visibility /a/b not-exist public
 
   assert_failure
   assert_output - <<EOF
-[ERROR] The entry at '/a/b' does not yet have a field 'not-exist'.
-In order to create a new field, please include the 'FIELDCONTENTS' argument.
+[ERROR] The entry at '/a/b' does not have a field 'not-exist'.
 EOF
 }