[#119] Change set-field Web-API

Problem: `set-field` route was used both for changing visibility and setting fields. This resulted in ambiguous behavior in case of missing contents and visibility options. Solution: require contents for setting field and allow changing visibility for convenience. Add `set-field-visibility` request which doesn't require field contents.
serokell · Jul 24, 2022 · a56bbda · a56bbda
1 parent f376160
commit a56bbda
Show file tree

Hide file tree

Showing 10 changed files with 74 additions and 118 deletions.
diff --git a/lib/Entry.hs b/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)

diff --git a/lib/Web/API.hs b/lib/Web/API.hs
@@ -30,12 +30,15 @@ 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
+      :> ReqBody '[JSON] FieldVisibility
+      :> Post '[JSON] Entry
 
     :<|> "delete-field"
       :> RequiredParam "path" EntryPath

diff --git a/lib/Web/Server.hs b/lib/Web/Server.hs
@@ -129,19 +129,15 @@ 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)
+  :<|> setFieldVisibility (run backend)
+  :<|> 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 +198,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

diff --git a/tests/server-integration/Common/Common.hs b/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

diff --git a/tests/server-integration/CopyAndRename/Common.hs b/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

diff --git a/tests/server-integration/DeleteField/DeleteFieldTest.hs b/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"
 

diff --git a/tests/server-integration/SetField/SetFieldTest.hs b/tests/server-integration/SetField/SetFieldTest.hs
@@ -6,21 +6,19 @@ module SetField.SetFieldTest where
 
 import Control.Exception (try)
 import Control.Lens
-import Data.Aeson
 import Data.Aeson.Lens
 import Data.Aeson.QQ.Simple (aesonQQ)
-import Data.Text (Text)
 import Data.Time
 import Network.HTTP.Req
-import Network.HTTP.Types (status400, status404)
+import Network.HTTP.Types (status404)
 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 +39,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 False) "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 +61,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 True) "contents"
 
   let fieldMb =
         responseBody response
@@ -105,7 +84,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 +95,16 @@ unit_set_field_entry_not_found = cofferTest do
         ]
       |]
 
-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
-          }
-        ]
-      |]
+-- unit_set_field_missing_field_contents :: IO ()
+-- TODO: add test that expects an error in case of missing contents
 
 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

diff --git a/tests/server-integration/Tag/TagTest.hs b/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"

diff --git a/tests/server-integration/Utils.hs b/tests/server-integration/Utils.hs
@@ -102,8 +102,8 @@ scrubDates =
 cofferTest :: IO () -> IO ()
 cofferTest test = deleteRecords >> test
 
-setField :: Text -> Text -> Text -> IO (JsonResponse Value)
-setField path name contents =
+setField :: Text -> Text -> Maybe Bool -> Text -> IO (JsonResponse Value)
+setField path name public contents =
   executeCommand
     POST
     ["set-field"]
@@ -112,25 +112,24 @@ setField path name contents =
     ( mconcat
         [ "path" =: path
         , "field" =: name
+        , queryParam "visibility" visibility
         ]
     )
+  where
+    visibility = boolToVisibility <$> public
 
 changeFieldVisibility :: Text -> Text -> Bool -> IO ()
 changeFieldVisibility path field public = void $
   executeCommand
     POST
-    ["set-field", visibility]
-    NoReqBody
+    ["set-field-visibility"]
+    (ReqBodyJson $ String $ boolToVisibility public)
     ignoreResponse
     ( mconcat
         [ "path" =: path
         , "field" =: field
         ]
     )
-  where
-    visibility
-      | public = "public"
-      | otherwise = "private"
 
 -- | Finds field in entry
 findField :: Text -> Value -> Maybe Value
@@ -265,3 +264,11 @@ addOrRemoveTag method path tag =
         , "tag" =: tag
         ]
     )
+
+-- Util functions
+
+-- | Converts Bool to "public" and "private".
+-- true is public
+boolToVisibility :: Bool -> Text
+boolToVisibility True  = "public"
+boolToVisibility False = "private"
diff --git a/tests/server-integration/View/ViewTest.hs b/tests/server-integration/View/ViewTest.hs
@@ -16,8 +16,8 @@ import Utils
 unit_view_an_entry :: IO ()
 unit_view_an_entry = cofferTest do
   createEntry "dir/entry"
-  void $ setField "dir/entry" "public-field" "contents"
-  void $ setField "dir/entry" "private-field" "multiline\ncontents"
+  void $ setField "dir/entry" "public-field" Nothing "contents"
+  void $ setField "dir/entry" "private-field" Nothing "multiline\ncontents"
   changeFieldVisibility "dir/entry" "private-field" False
 
   response <-