From 3879569eebc5b2fdfe51b70d0400ea378e821b24 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Fri, 19 Apr 2019 15:56:07 +0200 Subject: [PATCH] handler: fix: make slide content optional --- infra/handler/app/Test.hs | 12 ++++----- infra/handler/src/DeckGo/Handler.hs | 38 ++++++++++++++++++++++++----- 2 files changed, 38 insertions(+), 12 deletions(-) diff --git a/infra/handler/app/Test.hs b/infra/handler/app/Test.hs index e4b6d366e..220b3c639 100644 --- a/infra/handler/app/Test.hs +++ b/infra/handler/app/Test.hs @@ -43,7 +43,7 @@ main = do Left err -> error $ "Expected new deck, got error: " <> show err Right (Item deckId _) -> pure deckId - let someSlide = Slide "foo" "bar" HMS.empty + let someSlide = Slide (Just "foo") "bar" HMS.empty slideId <- runClientM (slidesPost' b deckId someSlide) clientEnv >>= \case Left err -> error $ "Expected new slide, got error: " <> show err @@ -65,7 +65,11 @@ main = do Right deck -> if deck == (Item deckId newDeck) then pure () else (error $ "Expected get deck, got: " <> show deck) - let updatedSlide = Slide "foo" "quux" HMS.empty + let updatedSlide = Slide Nothing "quux" HMS.empty + + runClientM (slidesPut' b deckId slideId updatedSlide) clientEnv >>= \case + Left err -> error $ "Expected new slide, got error: " <> show err + Right {} -> pure () runClientM (slidesPut' b deckId slideId updatedSlide) clientEnv >>= \case Left err -> error $ "Expected new slide, got error: " <> show err @@ -89,7 +93,6 @@ main = do Right decks -> if decks == [] then pure () else (error $ "Expected no decks, got: " <> show decks) - let someUser = User { userFirebaseId = someFirebaseId, userAnonymous = False } runClientM (usersPost' b someUser) clientEnv >>= \case @@ -108,9 +111,6 @@ main = do -- TODO: test that creating user with token that has different user as sub -- fails - - - usersGet' :: ClientM [Item UserId User] _usersGetUserId' :: UserId -> ClientM (Item UserId User) usersPost' :: T.Text -> User -> ClientM (Item UserId User) diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index 5b0a1afe4..a6e45b12b 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -27,6 +27,7 @@ module DeckGo.Handler where import Control.Lens hiding ((.=)) import Control.Monad +import Data.Maybe import Control.Monad.Except import Data.Aeson ((.=), (.:), (.!=), (.:?)) import Data.Proxy @@ -268,7 +269,7 @@ newtype SlideId = SlideId { unSlideId :: T.Text } instance ToParamSchema SlideId data Slide = Slide - { slideContent :: T.Text + { slideContent :: Maybe T.Text , slideTemplate :: T.Text , slideAttributes :: HMS.HashMap T.Text T.Text } deriving (Show, Eq) @@ -276,7 +277,7 @@ data Slide = Slide instance FromJSONObject Slide where parseJSONObject = \obj -> Slide <$> - obj .:? "content" .!= "" <*> + obj .:? "content" .!= Nothing <*> obj .: "template" <*> obj .:? "attributes" .!= HMS.empty @@ -728,7 +729,11 @@ slidesPut env fuid deckId slideId slide = do res <- runAWS env $ Aws.send $ DynamoDB.updateItem "Slides" & DynamoDB.uiUpdateExpression .~ Just - "SET SlideContent = :c, SlideTemplate = :t, SlideAttributes = :a" & + (dynamoSet $ + (if isJust (slideContent slide) + then [ Set "SlideContent" ":c" ] + else [ Remove "SlideContent" ]) <> + [ Set "SlideTemplate" ":t", Set "SlideAttributes" ":a"]) & DynamoDB.uiExpressionAttributeValues .~ slideToItem' slide & DynamoDB.uiReturnValues .~ Just DynamoDB.UpdatedNew & DynamoDB.uiKey .~ HMS.singleton "SlideId" @@ -915,13 +920,19 @@ deckAttributesFromAttributeValue attr = slideToItem :: SlideId -> Slide -> HMS.HashMap T.Text DynamoDB.AttributeValue slideToItem slideId Slide{slideContent, slideTemplate, slideAttributes} = HMS.singleton "SlideId" (slideIdToAttributeValue slideId) <> - HMS.singleton "SlideContent" (slideContentToAttributeValue slideContent) <> + (maybe + HMS.empty + (\content -> HMS.singleton "SlideContent" (slideContentToAttributeValue content)) + slideContent) <> HMS.singleton "SlideTemplate" (slideTemplateToAttributeValue slideTemplate) <> HMS.singleton "SlideAttributes" (slideAttributesToAttributeValue slideAttributes) slideToItem' :: Slide -> HMS.HashMap T.Text DynamoDB.AttributeValue slideToItem' Slide{slideContent, slideTemplate, slideAttributes} = - HMS.singleton ":c" (slideContentToAttributeValue slideContent) <> + (maybe + HMS.empty + (\content -> HMS.singleton ":c" (slideContentToAttributeValue content)) + slideContent) <> HMS.singleton ":t" (slideTemplateToAttributeValue slideTemplate) <> HMS.singleton ":a" (slideAttributesToAttributeValue slideAttributes) @@ -929,7 +940,9 @@ itemToSlide :: HMS.HashMap T.Text DynamoDB.AttributeValue -> Maybe (Item SlideId itemToSlide item = do slideId <- HMS.lookup "SlideId" item >>= slideIdFromAttributeValue - slideContent <- HMS.lookup "SlideContent" item >>= slideContentFromAttributeValue + slideContent <- case HMS.lookup "SlideContent" item of + Nothing -> Just Nothing + Just c -> Just <$> slideContentFromAttributeValue c slideTemplate <- HMS.lookup "SlideTemplate" item >>= slideTemplateFromAttributeValue slideAttributes <- HMS.lookup "SlideAttributes" item >>= slideAttributesFromAttributeValue @@ -1001,3 +1014,16 @@ randomText len allowedChars = T.pack <$> randomString len allowedChars newId :: IO T.Text newId = randomText 32 (['0' .. '9'] <> ['a' .. 'z']) + +data DynamoUpdateExpr + = Set T.Text T.Text + | Remove T.Text + +dynamoSet :: [DynamoUpdateExpr] -> T.Text +dynamoSet exprs = setExpr <> " " <> removeExpr + where + setExpr = "SET " <> T.intercalate "," sts + removeExpr = "REMOVE " <> T.intercalate "," removes + (sts, removes) = foldr f ([], []) exprs + f (Set l r) (ls, rs) = (ls <> [l <> " = " <> r], rs) + f (Remove t ) (ls, rs) = (ls, rs <> [t])