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..432b5616 100644 --- a/lib/Web/API.hs +++ b/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 diff --git a/lib/Web/Server.hs b/lib/Web/Server.hs index 98b15f35..30f392f7 100644 --- a/lib/Web/Server.hs +++ b/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 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..5387727c 100644 --- a/tests/server-integration/SetField/SetFieldTest.hs +++ b/tests/server-integration/SetField/SetFieldTest.hs @@ -6,13 +6,14 @@ 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 @@ -20,7 +21,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 +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" + } + |] 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..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 -> Text -> IO (JsonResponse Value) -setField path name contents = +setField :: Text -> Text -> Maybe Text -> Text -> IO (JsonResponse Value) +setField path name visibility contents = executeCommand POST ["set-field"] @@ -112,25 +112,24 @@ setField path name contents = ( mconcat [ "path" =: path , "field" =: name + , queryParam "visibility" visibility ] ) -changeFieldVisibility :: Text -> Text -> Bool -> IO () -changeFieldVisibility path field public = void $ - executeCommand - POST - ["set-field", visibility] - NoReqBody - ignoreResponse - ( mconcat - [ "path" =: path - , "field" =: field - ] - ) - where - visibility - | public = "public" - | otherwise = "private" +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 diff --git a/tests/server-integration/View/ViewTest.hs b/tests/server-integration/View/ViewTest.hs index 691c3e27..2f992979 100644 --- a/tests/server-integration/View/ViewTest.hs +++ b/tests/server-integration/View/ViewTest.hs @@ -16,9 +16,9 @@ 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" - changeFieldVisibility "dir/entry" "private-field" False + void $ setField "dir/entry" "public-field" Nothing "contents" + void $ setField "dir/entry" "private-field" Nothing "multiline\ncontents" + changeFieldVisibility "dir/entry" "private-field" "private" response <- executeCommand