[#119] Change set-field Web-API

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

lib/Web/Server.hs

@@ -129,19 +129,18 @@ makeServer
   :: (SomeBackend -> (forall a. Command a -> Handler a))
   -> Server API
 makeServer run backend
-  =    view   (run backend)
-  :<|> create (run backend)
-  :<|>
-    (\txt fkey ->
-         private (run backend) txt fkey
-    :<|> public  (run backend) txt fkey
-    :<|> set     (run backend) txt fkey
-    )
-  :<|> deleteField (run backend)
-  :<|> find'       (run backend)
-  :<|> rename      (run backend)
-  :<|> copy'       (run backend)
-  :<|> delete'     (run backend)
+  =    view               (run backend)
+  :<|> create             (run backend)
+  :<|> setField           (run backend)
+  :<|> (\path field->
+            setFieldVisibility (run backend) path field Public
+       :<|> setFieldVisibility (run backend) path field Private
+       )
+  :<|> deleteField        (run backend)
+  :<|> find'              (run backend)
+  :<|> rename             (run backend)
+  :<|> copy'              (run backend)
+  :<|> delete'            (run backend)
   :<|>
     (\path tag' ->
          tag (run backend) path tag' False
@@ -202,44 +201,33 @@ create run coPath coForce (NewEntry coFields coTags) =
 
     pretty = resultToText buildCreateError
 
-private
-  :: (forall a. Command a -> Handler a)
-  -> EntryPath
-  -> FieldName
-  -> Handler Entry
-private run sfoPath sfoFieldName  = do
-  run (CmdSetField SetFieldOptions
-    { sfoQPath = QualifiedPath Nothing sfoPath
-    , sfoFieldName
-    , sfoFieldContents = Nothing
-    , sfoVisibility = Just Private
-    }) >>= handleSetFieldResult
-
-public
+setFieldVisibility
   :: (forall a. Command a -> Handler a)
   -> EntryPath
   -> FieldName
+  -> FieldVisibility
   -> Handler Entry
-public run sfoPath sfoFieldName  =
+setFieldVisibility run path field visibility =
   run (CmdSetField SetFieldOptions
-    { sfoQPath = QualifiedPath Nothing sfoPath
-    , sfoFieldName
+    { sfoQPath = QualifiedPath Nothing path
+    , sfoFieldName = field
     , sfoFieldContents = Nothing
-    , sfoVisibility = Just Public
+    , sfoVisibility = Just visibility
     }) >>= handleSetFieldResult
 
-set
+setField
   :: (forall a. Command a -> Handler a)
   -> EntryPath
   -> FieldName
-  -> Maybe FieldContents
+  -> Maybe FieldVisibility
+  -> FieldContents
   -> Handler Entry
-set run sfoPath sfoFieldName sfoFieldContents =
+setField run path field visibility contents =
   run (CmdSetField SetFieldOptions
-    { sfoQPath = QualifiedPath Nothing sfoPath
-    , sfoFieldName
-    , sfoFieldContents = sfoFieldContents
-    , sfoVisibility = Nothing
+    { sfoQPath = QualifiedPath Nothing path
+    , sfoFieldName = field
+    , sfoFieldContents = Just contents
+    , sfoVisibility = visibility
     }) >>= handleSetFieldResult
 
 deleteField

tests/server-integration/Common/Common.hs

@@ -86,7 +86,7 @@ unit_incorrect_field_name_fromHttpApiData :: IO()
 unit_incorrect_field_name_fromHttpApiData = cofferTest do
   createEntry "entry"
 
-  try @HttpException ( setField "entry" "fieldname:." "contents" )
+  try @HttpException ( setField "entry" "fieldname:." Nothing "contents" )
     >>= unwrapStatusCodeError \response bs -> do
       bs @?= "Error parsing query parameter field failed: Field name can only contain the following characters: 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_;'"
       responseStatus response @?= status400

tests/server-integration/CopyAndRename/Common.hs

@@ -150,7 +150,7 @@ copyOrRenameCreateErrors copy = cofferTest do
 copyOrRenameUpdatesOnlyEntrysModificationTime :: Bool -> IO ()
 copyOrRenameUpdatesOnlyEntrysModificationTime copy = cofferTest do
   createEntry "entry"
-  response <- setField "entry" "field" "contents"
+  response <- setField "entry" "field" Nothing "contents"
   let modifiedDate = responseBody response ^?! key "dateModified"
 
   t1 <- getCurrentTime

tests/server-integration/DeleteField/DeleteFieldTest.hs

@@ -39,7 +39,7 @@ executeDeleteField path field =
 unit_delete_field :: IO ()
 unit_delete_field = cofferTest do
   createEntry "entry"
-  void $ setField "entry" "field" "contents"
+  void $ setField "entry" "field" Nothing "contents"
 
   response <- executeDeleteField "entry" "field"
 
@@ -79,7 +79,7 @@ unit_delete_field_field_not_found = cofferTest do
 unit_delete_field_updates_entry's_modification_time :: IO ()
 unit_delete_field_updates_entry's_modification_time = cofferTest do
   createEntry "entry"
-  response <- setField "entry" "field" "contents"
+  response <- setField "entry" "field" Nothing "contents"
 
   let oldModificationTime = responseBody response ^?! key "dateModified"
 

tests/server-integration/SetField/SetFieldTest.hs

@@ -6,21 +6,22 @@ module SetField.SetFieldTest where
 
 import Control.Exception (try)
 import Control.Lens
-import Data.Aeson
+import Data.Aeson (Value)
 import Data.Aeson.Lens
 import Data.Aeson.QQ.Simple (aesonQQ)
 import Data.Text (Text)
 import Data.Time
+import Network.HTTP.Client (responseStatus)
 import Network.HTTP.Req
-import Network.HTTP.Types (status400, status404)
+import Network.HTTP.Types (status404, status415)
 import Test.Tasty.HUnit
 import Utils
 
 unit_set_new_field :: IO ()
 unit_set_new_field = cofferTest do
   createEntry "entry"
 
-  response <- setField "entry" "newField" "contents"
+  response <- setField "entry" "newField" Nothing "contents"
   response @=
     [aesonQQ|
       {
@@ -41,26 +42,16 @@ unit_set_new_field = cofferTest do
 unit_set_field_private :: IO ()
 unit_set_field_private = cofferTest do
   createEntry "entry"
-  setField "entry" "public-field" "contents"
-  response <-
-    executeCommand
-      POST
-      ["set-field", "private"]
-      NoReqBody
-      (jsonResponse @Value)
-      ( mconcat
-          [ "path" =: ("entry" :: Text)
-          , "field" =: ("public-field" :: Text)
-          ]
-      )
+
+  response <- setField "entry" "private-field" (Just "private") "contents"
 
   let fieldMb =
         responseBody response
           & scrubDates
-          & findField "public-field"
+          & findField "private-field"
 
   case fieldMb of
-    Nothing -> assertFailure $ "Expected field \"public-field\", found nothing"
+    Nothing -> assertFailure $ "Expected field \"private-field\", found nothing"
     Just value ->
       value @?=
         [aesonQQ|
@@ -73,18 +64,9 @@ unit_set_field_private = cofferTest do
 
 unit_set_field_public :: IO ()
 unit_set_field_public = cofferTest do
-  unit_set_field_private
-  response <-
-    executeCommand
-      POST
-      ["set-field", "public"]
-      NoReqBody
-      (jsonResponse @Value)
-      ( mconcat
-          [ "path" =: ("entry" :: Text)
-          , "field" =: ("public-field" :: Text)
-          ]
-      )
+  createEntry "entry"
+
+  response <- setField "entry" "public-field" (Just "public") "contents"
 
   let fieldMb =
         responseBody response
@@ -105,7 +87,7 @@ unit_set_field_public = cofferTest do
 
 unit_set_field_entry_not_found :: IO ()
 unit_set_field_entry_not_found = cofferTest do
-  try @HttpException (setField "entry" "field" "contents") >>=
+  try @HttpException (setField "entry" "field" Nothing "contents") >>=
     processStatusCodeError status404
       [aesonQQ|
         [
@@ -116,40 +98,38 @@ unit_set_field_entry_not_found = cofferTest do
         ]
       |]
 
+-- | Request with no body in set-field must be invalid
+-- HTTP Exception with 415 status code (unsupported
+-- media type) is expected
 unit_set_field_missing_field_contents :: IO ()
 unit_set_field_missing_field_contents = cofferTest do
   createEntry "entry"
 
-  try @HttpException
-    (
-      executeCommand
-        POST
-        ["set-field"]
-        (ReqBodyJson Null)
-        (jsonResponse @Value)
-        ( mconcat
-            [ "path" =: ("entry" :: Text)
-            , "field" =: ("field" :: Text)
-            ]
-        )
-    ) >>=
-    processStatusCodeError status400
-      [aesonQQ|
-        [
-          {
-            "error": "The entry at '/entry' does not yet have a field 'field'.\nIn order to create a new field, please include 'FIELDCONTENTS' in the body.",
-            "code": 301
-          }
+  result <- try @HttpException
+    (executeCommand
+      POST
+      ["set-field"]
+      NoReqBody
+      (jsonResponse @Value)
+      (mconcat
+        [ "path" =: ("/entry" :: Text)
+        , "field" =: ("field" :: Text)
         ]
-      |]
+      )
+    )
+
+  flip unwrapStatusCodeError result $ \response _ ->
+    if responseStatus response == status415
+    then pure ()
+    else assertFailure $ "Expected Http status 415, got: " <> show response
 
 unit_set_field_updates_modification_date :: IO ()
 unit_set_field_updates_modification_date = cofferTest do
   createEntry "entry"
-  setField "entry" "field" "contents"
+  setField "entry" "field" Nothing "contents"
 
   t1 <- getCurrentTime
-  response <- setField "entry" "field" "contents2"
+  response <- setField "entry" "field" Nothing "contents2"
   t2 <- getCurrentTime
 
   let newModifiedDate = responseBody response ^?! key "dateModified" . _JSON @_ @UTCTime
@@ -158,3 +138,45 @@ unit_set_field_updates_modification_date = cofferTest do
 
   assertBool "Dates are not equal"
     $ responseBody response ^?! key "fields" . key "field" . key "dateModified" . _JSON == newModifiedDate
+
+unit_set_field_visibility_public :: IO ()
+unit_set_field_visibility_public = cofferTest do
+  createEntry "dir/entry"
+  setField "dir/entry" "public-field" (Just "private") "contents"
+  fieldMb <-
+    changeFieldVisibility "dir/entry" "public-field" "public"
+      <&> scrubDates
+      <&> findField "public-field"
+
+  case fieldMb of
+    Nothing -> assertFailure $ "Expected field \"public-field\", found nothing"
+    Just value ->
+      value @?=
+        [aesonQQ|
+          {
+            "visibility": "public",
+            "dateModified": "",
+            "contents": "contents"
+          }
+        |]
+
+unit_set_field_visibility_private :: IO ()
+unit_set_field_visibility_private = cofferTest do
+  createEntry "dir/entry"
+  setField "dir/entry" "private-field" (Just "public") "contents"
+  fieldMb <-
+    changeFieldVisibility "dir/entry" "private-field" "private"
+      <&> scrubDates
+      <&> findField "private-field"
+
+  case fieldMb of
+    Nothing -> assertFailure $ "Expected field \"private-field\", found nothing"
+    Just value ->
+      value @?=
+        [aesonQQ|
+          {
+            "visibility": "private",
+            "dateModified": "",
+            "contents": "contents"
+          }
+        |]

tests/server-integration/Tag/TagTest.hs

@@ -102,7 +102,7 @@ unit_tag_duplicate_tag = cofferTest do
 unit_tag_updates_only_entry's_modification_time :: IO ()
 unit_tag_updates_only_entry's_modification_time = cofferTest do
   createEntry "entry"
-  response <- setField "entry" "field" "contents"
+  response <- setField "entry" "field" Nothing  "contents"
   let modificationTime = responseBody response ^?! key "dateModified"
   t1 <- getCurrentTime
   response <- addOrRemoveTag POST "entry" "tag"