From a56bbdae559af6986e5afa52587e9d97302c832f Mon Sep 17 00:00:00 2001 From: Aleksandr Pak Date: Sun, 24 Jul 2022 19:37:10 +0300 Subject: [PATCH 1/4] [#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. --- lib/Entry.hs | 6 ++ lib/Web/API.hs | 15 ++-- lib/Web/Server.hs | 61 ++++++---------- tests/server-integration/Common/Common.hs | 2 +- .../CopyAndRename/Common.hs | 2 +- .../DeleteField/DeleteFieldTest.hs | 4 +- .../SetField/SetFieldTest.hs | 73 ++++--------------- tests/server-integration/Tag/TagTest.hs | 2 +- tests/server-integration/Utils.hs | 23 ++++-- tests/server-integration/View/ViewTest.hs | 4 +- 10 files changed, 74 insertions(+), 118 deletions(-) diff --git a/lib/Entry.hs b/lib/Entry.hs index 7cb01b0f..b451d337 100644 --- 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 index dcb340ce..da966026 100644 --- 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 index 98b15f35..f7dce8c0 100644 --- 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 index 2f9c8517..f08322fc 100644 --- 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 index dc2215b4..db1e5ccf 100644 --- 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 index 4ecfd814..52dc8347 100644 --- 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 index 0ad541d9..cb5b8518 100644 --- a/tests/server-integration/SetField/SetFieldTest.hs +++ b/tests/server-integration/SetField/SetFieldTest.hs @@ -6,13 +6,11 @@ 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 @@ -20,7 +18,7 @@ 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 index c5a6128a..02f3c2fd 100644 --- 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 index e5f48a3e..cdecdbfa 100644 --- 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 index 691c3e27..5931fa59 100644 --- 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 <- From f9c5fa605fdd95971ca563a96a4d82f81636c468 Mon Sep 17 00:00:00 2001 From: Aleksandr Pak Date: Tue, 26 Jul 2022 16:04:48 +0300 Subject: [PATCH 2/4] [#119] Add test for `set-field-visibility` --- .../SetField/SetFieldTest.hs | 51 +++++++++++++++++++ 1 file changed, 51 insertions(+) diff --git a/tests/server-integration/SetField/SetFieldTest.hs b/tests/server-integration/SetField/SetFieldTest.hs index cb5b8518..1dc4e06b 100644 --- a/tests/server-integration/SetField/SetFieldTest.hs +++ b/tests/server-integration/SetField/SetFieldTest.hs @@ -6,8 +6,11 @@ module SetField.SetFieldTest where import Control.Exception (try) import Control.Lens +import Data.Aeson (Value) import Data.Aeson.Lens import Data.Aeson.QQ.Simple (aesonQQ) +import Data.Functor (void) +import Data.Text (Text) import Data.Time import Network.HTTP.Req import Network.HTTP.Types (status404) @@ -113,3 +116,51 @@ 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 :: IO () +unit_set_field_visibility = cofferTest do + createEntry "dir/entry" + void $ setField "dir/entry" "private-field" Nothing "contents" + void $ setField "dir/entry" "public-field" Nothing "contents" + changeFieldVisibility "dir/entry" "private-field" False + changeFieldVisibility "dir/entry" "public-field" True + + response <- + executeCommand + GET + ["view"] + NoReqBody + (jsonResponse @Value) + ("path" =: (("dir/entry") :: Text)) + + response @= + [aesonQQ| + { + "entries": [], + "subdirs": { + "dir": { + "entries": [ + { + "path": "/dir/entry", + "dateModified": "", + "masterField": null, + "fields": { + "public-field": { + "dateModified": "", + "visibility": "public", + "contents": "contents" + }, + "private-field": { + "dateModified": "", + "visibility": "private", + "contents": "contents" + } + }, + "tags": [] + } + ], + "subdirs": {} + } + } + } + |] From 4a373e2bc5f3a05ca3e259a97384860ab359ff0a Mon Sep 17 00:00:00 2001 From: Aleksandr Pak Date: Thu, 28 Jul 2022 17:57:17 +0300 Subject: [PATCH 3/4] [#119] Remove JSON body from set-field-visibility --- lib/Web/API.hs | 5 +++-- lib/Web/Server.hs | 12 +++++++++++- tests/server-integration/SetField/SetFieldTest.hs | 4 ++-- tests/server-integration/Utils.hs | 8 ++++---- tests/server-integration/View/ViewTest.hs | 2 +- 5 files changed, 21 insertions(+), 10 deletions(-) diff --git a/lib/Web/API.hs b/lib/Web/API.hs index da966026..432b5616 100644 --- a/lib/Web/API.hs +++ b/lib/Web/API.hs @@ -37,8 +37,9 @@ type API :<|> "set-field-visibility" :> RequiredParam "path" EntryPath :> RequiredParam "field" FieldName - :> ReqBody '[JSON] FieldVisibility - :> Post '[JSON] Entry + :> ( "public" :> Post '[JSON] Entry + :<|> "private" :> Post '[JSON] Entry + ) :<|> "delete-field" :> RequiredParam "path" EntryPath diff --git a/lib/Web/Server.hs b/lib/Web/Server.hs index f7dce8c0..de29ed57 100644 --- a/lib/Web/Server.hs +++ b/lib/Web/Server.hs @@ -125,6 +125,13 @@ reportErrors io = do Right (Right a) -> do return a +-- setFieldVisibility +-- :: (forall a. Command a -> Handler a) +-- -> Bool +-- -> EntryPath +-- -> FieldName +-- -> Handler Entry + makeServer :: (SomeBackend -> (forall a. Command a -> Handler a)) -> Server API @@ -132,7 +139,10 @@ makeServer run backend = view (run backend) :<|> create (run backend) :<|> setField (run backend) - :<|> setFieldVisibility (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) diff --git a/tests/server-integration/SetField/SetFieldTest.hs b/tests/server-integration/SetField/SetFieldTest.hs index 1dc4e06b..95bc35ee 100644 --- a/tests/server-integration/SetField/SetFieldTest.hs +++ b/tests/server-integration/SetField/SetFieldTest.hs @@ -122,8 +122,8 @@ unit_set_field_visibility = cofferTest do createEntry "dir/entry" void $ setField "dir/entry" "private-field" Nothing "contents" void $ setField "dir/entry" "public-field" Nothing "contents" - changeFieldVisibility "dir/entry" "private-field" False - changeFieldVisibility "dir/entry" "public-field" True + changeFieldVisibility "dir/entry" "private-field" "private" + changeFieldVisibility "dir/entry" "public-field" "public" response <- executeCommand diff --git a/tests/server-integration/Utils.hs b/tests/server-integration/Utils.hs index cdecdbfa..2260542b 100644 --- a/tests/server-integration/Utils.hs +++ b/tests/server-integration/Utils.hs @@ -118,12 +118,12 @@ setField path name public contents = where visibility = boolToVisibility <$> public -changeFieldVisibility :: Text -> Text -> Bool -> IO () -changeFieldVisibility path field public = void $ +changeFieldVisibility :: Text -> Text -> Text -> IO () +changeFieldVisibility path field visibility = void $ executeCommand POST - ["set-field-visibility"] - (ReqBodyJson $ String $ boolToVisibility public) + ["set-field-visibility", visibility] + NoReqBody ignoreResponse ( mconcat [ "path" =: path diff --git a/tests/server-integration/View/ViewTest.hs b/tests/server-integration/View/ViewTest.hs index 5931fa59..2f992979 100644 --- a/tests/server-integration/View/ViewTest.hs +++ b/tests/server-integration/View/ViewTest.hs @@ -18,7 +18,7 @@ unit_view_an_entry = cofferTest do createEntry "dir/entry" void $ setField "dir/entry" "public-field" Nothing "contents" void $ setField "dir/entry" "private-field" Nothing "multiline\ncontents" - changeFieldVisibility "dir/entry" "private-field" False + changeFieldVisibility "dir/entry" "private-field" "private" response <- executeCommand From e5e088d8d771d501129a1398cbdef0dacc7b1d4c Mon Sep 17 00:00:00 2001 From: Aleksandr Pak Date: Tue, 2 Aug 2022 17:22:27 +0300 Subject: [PATCH 4/4] [#119] Refactor and new test for missing contents in `set-field` --- lib/Web/Server.hs | 7 -- .../SetField/SetFieldTest.hs | 116 ++++++++++-------- tests/server-integration/Utils.hs | 40 +++--- 3 files changed, 82 insertions(+), 81 deletions(-) diff --git a/lib/Web/Server.hs b/lib/Web/Server.hs index de29ed57..30f392f7 100644 --- a/lib/Web/Server.hs +++ b/lib/Web/Server.hs @@ -125,13 +125,6 @@ reportErrors io = do Right (Right a) -> do return a --- setFieldVisibility --- :: (forall a. Command a -> Handler a) --- -> Bool --- -> EntryPath --- -> FieldName --- -> Handler Entry - makeServer :: (SomeBackend -> (forall a. Command a -> Handler a)) -> Server API diff --git a/tests/server-integration/SetField/SetFieldTest.hs b/tests/server-integration/SetField/SetFieldTest.hs index 95bc35ee..5387727c 100644 --- a/tests/server-integration/SetField/SetFieldTest.hs +++ b/tests/server-integration/SetField/SetFieldTest.hs @@ -9,11 +9,11 @@ import Control.Lens import Data.Aeson (Value) import Data.Aeson.Lens import Data.Aeson.QQ.Simple (aesonQQ) -import Data.Functor (void) import Data.Text (Text) import Data.Time +import Network.HTTP.Client (responseStatus) import Network.HTTP.Req -import Network.HTTP.Types (status404) +import Network.HTTP.Types (status404, status415) import Test.Tasty.HUnit import Utils @@ -43,7 +43,7 @@ unit_set_field_private :: IO () unit_set_field_private = cofferTest do createEntry "entry" - response <- setField "entry" "private-field" (Just False) "contents" + response <- setField "entry" "private-field" (Just "private") "contents" let fieldMb = responseBody response @@ -66,7 +66,7 @@ unit_set_field_public :: IO () unit_set_field_public = cofferTest do createEntry "entry" - response <- setField "entry" "public-field" (Just True) "contents" + response <- setField "entry" "public-field" (Just "public") "contents" let fieldMb = responseBody response @@ -98,8 +98,30 @@ unit_set_field_entry_not_found = cofferTest do ] |] --- unit_set_field_missing_field_contents :: IO () --- TODO: add test that expects an error in case of missing contents +-- | 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" + + 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 @@ -117,50 +139,44 @@ 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 :: IO () -unit_set_field_visibility = cofferTest do +unit_set_field_visibility_public :: IO () +unit_set_field_visibility_public = cofferTest do createEntry "dir/entry" - void $ setField "dir/entry" "private-field" Nothing "contents" - void $ setField "dir/entry" "public-field" Nothing "contents" - changeFieldVisibility "dir/entry" "private-field" "private" - changeFieldVisibility "dir/entry" "public-field" "public" - - response <- - executeCommand - GET - ["view"] - NoReqBody - (jsonResponse @Value) - ("path" =: (("dir/entry") :: Text)) + setField "dir/entry" "public-field" (Just "private") "contents" + fieldMb <- + changeFieldVisibility "dir/entry" "public-field" "public" + <&> scrubDates + <&> findField "public-field" - response @= - [aesonQQ| - { - "entries": [], - "subdirs": { - "dir": { - "entries": [ - { - "path": "/dir/entry", - "dateModified": "", - "masterField": null, - "fields": { - "public-field": { - "dateModified": "", - "visibility": "public", - "contents": "contents" - }, - "private-field": { - "dateModified": "", - "visibility": "private", - "contents": "contents" - } - }, - "tags": [] - } - ], - "subdirs": {} + 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" + } + |] diff --git a/tests/server-integration/Utils.hs b/tests/server-integration/Utils.hs index 2260542b..af51d9f8 100644 --- 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 -> Maybe Bool -> Text -> IO (JsonResponse Value) -setField path name public contents = +setField :: Text -> Text -> Maybe Text -> Text -> IO (JsonResponse Value) +setField path name visibility contents = executeCommand POST ["set-field"] @@ -115,21 +115,21 @@ setField path name public contents = , queryParam "visibility" visibility ] ) - where - visibility = boolToVisibility <$> public -changeFieldVisibility :: Text -> Text -> Text -> IO () -changeFieldVisibility path field visibility = void $ - executeCommand - POST - ["set-field-visibility", visibility] - NoReqBody - ignoreResponse - ( mconcat - [ "path" =: path - , "field" =: field - ] - ) +changeFieldVisibility :: Text -> Text -> Text -> IO Value +changeFieldVisibility path field visibility = do + response <- + executeCommand + POST + ["set-field-visibility", visibility] + NoReqBody + (jsonResponse @Value) + ( mconcat + [ "path" =: path + , "field" =: field + ] + ) + pure $ responseBody response -- | Finds field in entry findField :: Text -> Value -> Maybe Value @@ -264,11 +264,3 @@ 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"