[#119] Refactor set-field in CLI and WebAPI

README.md

@@ -26,6 +26,7 @@ Available commands:
                            returning only the specified field for each entry
   create                   Create a new entry at the specified path
   set-field                Set a field on the entry at the specified path
+  set-field-visibility     Set a field's visibility on the entry at the specified path
   delete-field             Delete a field from the entry at the specified path
   find                     Find and list entries, optionally filtering
   rename                   Rename an entry or directory

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

docs/web-api-error-codes.md

@@ -9,7 +9,8 @@
 These codes are grouped in the following way:
 - `view` errors: 100-102
 - `create` errors: 200-202
-- `set-field` errors: 300-301
+- `set-field` errors: 300
+- `set-field-visibility` errors: 350-351
 - `delete-field` errors: 400-401
 - `rename`/`copy` errors: 500-505
 - `delete` errors: 600-601
@@ -37,7 +38,12 @@ See the following tables for detailed explanations of error codes.
 | Error                  | Code |
 |:-----------------------|:----:|
 | Entry not found        | 300  |
-| Missing field contents | 301  |
+
+## Set-field-visibility
+| Error                  | Code |
+|:-----------------------|:----:|
+| Entry not found        | 350  |
+| Field not found        | 351  |
 
 ## Delete-field
 | Error           | Code |

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 :: UTCTime -> Maybe Field -> Field
     updateOrInsertField nowUtc = \case
+      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/Entry.hs

@@ -137,6 +137,12 @@ instance A.FromJSON FieldVisibility where
     "private" -> pure Private
     other -> fail $ "expecting either 'public' or 'private', but found: '" <> T.unpack other <> "'"
 
+instance FromHttpApiData FieldVisibility where
+  parseUrlPiece = \case
+    "public"  -> Right Public
+    "private" -> Right Private
+    other     -> Left $ "expecting either 'public' or 'private', but found: '" <> other <> "'"
+
 newtype FieldContents = FieldContents { unFieldContents :: Text }
   deriving stock (Show, Eq, Ord)
   deriving newtype (Hashable, A.FromJSON, A.ToJSON, A.FromJSONKey, A.ToJSONKey)

lib/Web/API.hs

@@ -30,12 +30,16 @@ type API
     :<|> "set-field"
       :> RequiredParam "path" EntryPath
       :> RequiredParam "field" FieldName
-      :>
-        (    "private" :> Post '[JSON] Entry
-        :<|> "public"  :> Post '[JSON] Entry
-        :<|> ReqBody '[JSON] (Maybe FieldContents)
-          :> Post '[JSON] Entry
-        )
+      :> OptionalParam "visibility" FieldVisibility
+      :> ReqBody '[JSON] FieldContents
+      :> Post '[JSON] Entry
+
+    :<|> "set-field-visibility"
+      :> RequiredParam "path" EntryPath
+      :> RequiredParam "field" FieldName
+      :> (    "public"  :> Post '[JSON] Entry
+         :<|> "private" :> Post '[JSON] Entry
+         )
 
     :<|> "delete-field"
       :> RequiredParam "path" EntryPath