From a56bbdae559af6986e5afa52587e9d97302c832f Mon Sep 17 00:00:00 2001 From: Aleksandr Pak Date: Sun, 24 Jul 2022 19:37:10 +0300 Subject: [PATCH 1/6] [#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/6] [#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/6] [#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/6] [#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" From 13fa4f78fc870eec781ede74a9193a6ddaaaa43c Mon Sep 17 00:00:00 2001 From: Aleksandr Pak Date: Thu, 28 Jul 2022 15:16:42 +0300 Subject: [PATCH 5/6] [#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 | 11 ++- lib/Backend/Commands.hs | 75 ++++++++++++++----- lib/CLI/Parser.hs | 29 +++++-- lib/CLI/Types.hs | 17 ++++- lib/Coffer/PrettyPrint.hs | 25 ++++--- lib/Web/Server.hs | 28 ++++--- .../set-field-command/set-field-command.bats | 10 +-- 7 files changed, 142 insertions(+), 53 deletions(-) diff --git a/app/cli/Main.hs b/app/cli/Main.hs index 6cdd2a3a..13424fc1 100644 --- a/app/cli/Main.hs +++ b/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 diff --git a/lib/Backend/Commands.hs b/lib/Backend/Commands.hs index f8769170..c97c1a01 100644 --- a/lib/Backend/Commands.hs +++ b/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) diff --git a/lib/CLI/Parser.hs b/lib/CLI/Parser.hs index e0c5b1dc..b74eb785 100644 --- a/lib/CLI/Parser.hs +++ b/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 diff --git a/lib/CLI/Types.hs b/lib/CLI/Types.hs index 65d8d9fc..37fedd59 100644 --- a/lib/CLI/Types.hs +++ b/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 diff --git a/lib/Coffer/PrettyPrint.hs b/lib/Coffer/PrettyPrint.hs index 1a11433e..c3905ec0 100644 --- a/lib/Coffer/PrettyPrint.hs +++ b/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 diff --git a/lib/Web/Server.hs b/lib/Web/Server.hs index 30f392f7..15065ce9 100644 --- a/lib/Web/Server.hs +++ b/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) @@ -208,12 +217,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) @@ -226,7 +234,7 @@ setField run path field visibility contents = run (CmdSetField SetFieldOptions { sfoQPath = QualifiedPath Nothing path , sfoFieldName = field - , sfoFieldContents = Just contents + , sfoFieldContents = contents , sfoVisibility = visibility }) >>= handleSetFieldResult diff --git a/tests/golden/set-field-command/set-field-command.bats b/tests/golden/set-field-command/set-field-command.bats index f8c1b982..3e2b1373 100644 --- a/tests/golden/set-field-command/set-field-command.bats +++ b/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 - < Date: Tue, 2 Aug 2022 20:23:03 +0300 Subject: [PATCH 6/6] [#119] Edit docs and README --- README.md | 1 + app/cli/Main.hs | 1 - docs/web-api-error-codes.md | 10 ++++++++-- lib/Backend/Commands.hs | 2 +- lib/Web/Server.hs | 4 ++-- 5 files changed, 12 insertions(+), 6 deletions(-) diff --git a/README.md b/README.md index e619ac9d..eb902016 100644 --- a/README.md +++ b/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 diff --git a/app/cli/Main.hs b/app/cli/Main.hs index 13424fc1..4b60fdd9 100644 --- a/app/cli/Main.hs +++ b/app/cli/Main.hs @@ -88,7 +88,6 @@ main = do res@SFREntryNotFound{} -> printError $ buildSetFieldResult CLI res res@SFRSuccess{} -> printSuccess $ buildSetFieldResult CLI res - SomeCommand cmd@CmdSetFieldVisibility{} -> do runCommand config cmd >>= \case res@SFVREntryNotFound{} -> printError $ buildSetFieldVisibilityResult CLI res diff --git a/docs/web-api-error-codes.md b/docs/web-api-error-codes.md index 4b1439e3..273bea1c 100644 --- a/docs/web-api-error-codes.md +++ b/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 | diff --git a/lib/Backend/Commands.hs b/lib/Backend/Commands.hs index c97c1a01..eaca6b2c 100644 --- a/lib/Backend/Commands.hs +++ b/lib/Backend/Commands.hs @@ -150,7 +150,7 @@ setFieldCmd updateOrInsertField nowUtc updateOrInsertField :: UTCTime -> Maybe Field -> Field - updateOrInsertField nowUtc fieldMb = case fieldMb of + updateOrInsertField nowUtc = \case Nothing -> -- The field does not yet exist, insert a new one. newField nowUtc fieldContents diff --git a/lib/Web/Server.hs b/lib/Web/Server.hs index 15065ce9..c15d8ffe 100644 --- a/lib/Web/Server.hs +++ b/lib/Web/Server.hs @@ -74,9 +74,9 @@ handleSetFieldVisibilityResult :: SetFieldVisibilityResult -> Handler Entry handleSetFieldVisibilityResult = \case SFVRSuccess _ qEntry -> pure $ qpPath qEntry res@SFVREntryNotFound{} -> - throwCofferServerError err404 300 (pretty res) + throwCofferServerError err404 350 (pretty res) res@SFVRFieldNotFound{} -> - throwCofferServerError err404 301 (pretty res) + throwCofferServerError err404 351 (pretty res) where pretty = resultToText buildSetFieldVisibilityResult