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

lib/Backend/Commands.hs

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

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

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

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

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
 

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
 }