Skip to content
This repository was archived by the owner on Feb 6, 2024. It is now read-only.

Commit 297375e

Browse files
nmattianmattia
committed
handler: fix PUT
1 parent 8f942db commit 297375e

File tree

4 files changed

+191
-74
lines changed

4 files changed

+191
-74
lines changed

‎infra/default.nix‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -55,7 +55,6 @@ rec
5555
echo "Running tests"
5656
${handler}/bin/test
5757
58-
5958
touch $out
6059
'';
6160
}

‎infra/handler/app/Test.hs‎

Lines changed: 58 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,69 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE LambdaCase #-}
3+
14
import Network.HTTP.Client (newManager, defaultManagerSettings)
25
import Servant.API
36
import Servant.Client
47
import DeckGo.Handler
8+
import qualified Data.HashMap.Strict as HMS
59

610
main :: IO ()
711
main = do
812
manager' <- newManager defaultManagerSettings
9-
res <- runClientM decksGet' (mkClientEnv manager' (BaseUrl Http "localhost" 8080 ""))
10-
case res of
11-
Left err -> putStrLn $ "Error: " ++ show err
12-
Right books -> putStrLn $ "Got " <> show (length books)
13+
14+
let clientEnv = mkClientEnv manager' (BaseUrl Http "localhost" 8080 "")
15+
16+
runClientM decksGet' clientEnv >>= \case
17+
Left err -> error $ "Expected decks, got error: " <> show err
18+
Right [] -> pure ()
19+
Right decks -> error $ "Expected 0 decks, got: " <> show decks
20+
21+
let someDeck = Deck { deckSlides = [] }
22+
23+
deckId <- runClientM (decksPost' someDeck) clientEnv >>= \case
24+
Left err -> error $ "Expected new deck, got error: " <> show err
25+
Right (WithId deckId _) -> pure deckId
26+
27+
let someSlide = Slide "foo" "bar" HMS.empty
28+
29+
slideId <- runClientM (slidesPost' someSlide) clientEnv >>= \case
30+
Left err -> error $ "Expected new slide, got error: " <> show err
31+
Right (WithId slideId _) -> pure slideId
32+
33+
let newDeck = Deck { deckSlides = [ slideId ] }
34+
35+
runClientM (decksPut' deckId newDeck) clientEnv >>= \case
36+
Left err -> error $ "Expected updated deck, got error: " <> show err
37+
Right {} -> pure ()
38+
39+
runClientM decksGet' clientEnv >>= \case
40+
Left err -> error $ "Expected decks, got error: " <> show err
41+
Right decks ->
42+
if decks == [WithId deckId newDeck] then pure () else (error $ "Expected updated decks, got: " <> show decks)
43+
44+
runClientM slidesGet' clientEnv >>= \case
45+
Left err -> error $ "Expected slides, got error: " <> show err
46+
Right slides ->
47+
if slides == [WithId slideId someSlide] then pure () else (error $ "Expected slides, got: " <> show slides)
48+
49+
let updatedSlide = Slide "foo" "quux" HMS.empty
50+
51+
runClientM (slidesPut' slideId updatedSlide) clientEnv >>= \case
52+
Left err -> error $ "Expected new slide, got error: " <> show err
53+
Right {} -> pure ()
54+
55+
runClientM slidesGet' clientEnv >>= \case
56+
Left err -> error $ "Expected updated slides, got error: " <> show err
57+
Right slides ->
58+
if slides == [WithId slideId updatedSlide] then pure () else (error $ "Expected updated slides, got: " <> show slides)
1359

1460
-- 'client' allows you to produce operations to query an API from a client.
1561
decksGet' :: ClientM [WithId DeckId Deck]
16-
((decksGet' :<|> _ :<|> _) :<|> _ ) = client api
62+
decksPost' :: Deck -> ClientM (WithId DeckId Deck)
63+
decksPut' :: DeckId -> Deck -> ClientM (WithId DeckId Deck)
64+
slidesGet' :: ClientM [WithId SlideId Slide]
65+
slidesPost' :: Slide -> ClientM (WithId SlideId Slide)
66+
slidesPut' :: SlideId -> Slide -> ClientM (WithId SlideId Slide)
67+
((decksGet' :<|> decksPost' :<|> decksPut') :<|>
68+
(slidesGet' :<|> slidesPost' :<|> slidesPut')
69+
) = client api

‎infra/handler/src/DeckGo/Handler.hs‎

Lines changed: 126 additions & 65 deletions
Original file line numberDiff line numberDiff line change
@@ -14,8 +14,8 @@ import Control.Monad
1414
import Control.Lens hiding ((.=))
1515
import Data.Proxy
1616
import Servant.API
17-
import Data.Maybe
1817
import qualified Data.Text as T
18+
import qualified Data.Text.Encoding as T
1919
import qualified Data.HashMap.Strict as HMS
2020
import UnliftIO
2121
import Data.Aeson ((.=), (.:), (.!=), (.:?))
@@ -31,22 +31,23 @@ import qualified System.Random as Random
3131
------------------------------------------------------------------------------
3232

3333
data WithId id a = WithId id a
34+
deriving (Show, Eq)
3435

3536
newtype DeckId = DeckId { unDeckId :: T.Text }
36-
deriving newtype (Aeson.FromJSON, Aeson.ToJSON, FromHttpApiData, ToHttpApiData)
37+
deriving newtype (Aeson.FromJSON, Aeson.ToJSON, FromHttpApiData, ToHttpApiData, Show, Eq)
3738

3839
data Deck = Deck
3940
{ deckSlides :: [SlideId]
40-
}
41+
} deriving (Show, Eq)
4142

4243
newtype SlideId = SlideId { unSlideId :: T.Text }
43-
deriving newtype (Aeson.FromJSON, Aeson.ToJSON, FromHttpApiData, ToHttpApiData)
44+
deriving newtype (Aeson.FromJSON, Aeson.ToJSON, FromHttpApiData, ToHttpApiData, Show, Eq)
4445

4546
data Slide = Slide
4647
{ slideContent :: T.Text
4748
, slideTemplate :: T.Text
4849
, slideAttributes :: HMS.HashMap T.Text T.Text
49-
}
50+
} deriving (Show, Eq)
5051

5152
instance Aeson.FromJSON Deck where
5253
parseJSON = Aeson.withObject "decK" $ \obj ->
@@ -135,11 +136,15 @@ decksGet :: Aws.Env -> Servant.Handler [WithId DeckId Deck]
135136
decksGet env = do
136137
res <- runAWS env $ Aws.send $ DynamoDB.scan "Decks"
137138
case res of
138-
Right scanResponse -> pure $ catMaybes $
139-
scanResponse ^. DynamoDB.srsItems <&> itemToDeck
139+
Right scanResponse ->
140+
case sequence $ scanResponse ^. DynamoDB.srsItems <&> itemToDeck of
141+
Nothing -> do
142+
liftIO $ putStrLn $ "Could not parse response: " <> show scanResponse
143+
Servant.throwError Servant.err500
144+
Just ids -> pure ids
140145
Left e -> do
141146
liftIO $ print e
142-
pure []
147+
Servant.throwError Servant.err500
143148

144149
decksPost :: Aws.Env -> Deck -> Servant.Handler (WithId DeckId Deck)
145150
decksPost env deck = do
@@ -150,22 +155,28 @@ decksPost env deck = do
150155
DynamoDB.piItem .~ deckToItem deckId deck
151156

152157
case res of
153-
Right x -> liftIO $ print x
154-
Left e -> liftIO $ print e
158+
Right {} -> pure ()
159+
Left e -> do
160+
liftIO $ print e
161+
Servant.throwError Servant.err500
155162

156163
pure $ WithId deckId deck
157164

158165
decksPut :: Aws.Env -> DeckId -> Deck -> Servant.Handler (WithId DeckId Deck)
159166
decksPut env deckId deck = do
160167

161168
res <- runAWS env $ Aws.send $ DynamoDB.updateItem "Decks" &
162-
DynamoDB.uiUpdateExpression .~ Just "DeckSlides = :DeckSlides" &
163-
DynamoDB.uiExpressionAttributeValues .~ deckToItem deckId deck &
164-
DynamoDB.uiReturnValues .~ Just DynamoDB.UpdatedNew
169+
DynamoDB.uiUpdateExpression .~ Just "SET DeckSlides = :s" &
170+
DynamoDB.uiExpressionAttributeValues .~ deckToItem' deck &
171+
DynamoDB.uiReturnValues .~ Just DynamoDB.UpdatedNew &
172+
DynamoDB.uiKey .~ HMS.singleton "DeckId"
173+
(deckIdToAttributeValue deckId)
165174

166175
case res of
167-
Right x -> liftIO $ print x
168-
Left e -> liftIO $ print e
176+
Right {} -> pure ()
177+
Left e -> do
178+
liftIO $ print e
179+
Servant.throwError Servant.err500
169180

170181
pure $ WithId deckId deck
171182

@@ -181,11 +192,16 @@ slidesGet :: Aws.Env -> Servant.Handler [WithId SlideId Slide]
181192
slidesGet env = do
182193
res <- runAWS env $ Aws.send $ DynamoDB.scan "Slides"
183194
case res of
184-
Right scanResponse -> pure $ catMaybes $
185-
scanResponse ^. DynamoDB.srsItems <&> itemToSlide
195+
Right scanResponse ->
196+
case sequence $ scanResponse ^. DynamoDB.srsItems <&> itemToSlide of
197+
Nothing -> do
198+
liftIO $ putStrLn $ "Could not parse respose: " <> show scanResponse
199+
Servant.throwError Servant.err500
200+
Just ids -> pure ids
201+
186202
Left e -> do
187203
liftIO $ print e
188-
pure []
204+
Servant.throwError Servant.err500
189205

190206
slidesPost :: Aws.Env -> Slide -> Servant.Handler (WithId SlideId Slide)
191207
slidesPost env slide = do
@@ -196,8 +212,10 @@ slidesPost env slide = do
196212
DynamoDB.piItem .~ slideToItem slideId slide
197213

198214
case res of
199-
Right x -> liftIO $ print x
200-
Left e -> liftIO $ print e
215+
Right {} -> pure ()
216+
Left e -> do
217+
liftIO $ print e
218+
Servant.throwError Servant.err500
201219

202220
pure $ WithId slideId slide
203221

@@ -206,13 +224,17 @@ slidesPut env slideId slide = do
206224

207225
res <- runAWS env $ Aws.send $ DynamoDB.updateItem "Slides" &
208226
DynamoDB.uiUpdateExpression .~ Just
209-
"SlideContent = :SlideContent, SlideTemplate = :SlideTemplate, SlideAttributes = :SlideAttributes" &
210-
DynamoDB.uiExpressionAttributeValues .~ slideToItem slideId slide &
211-
DynamoDB.uiReturnValues .~ Just DynamoDB.UpdatedNew
227+
"SET SlideContent = :c, SlideTemplate = :t, SlideAttributes = :a" &
228+
DynamoDB.uiExpressionAttributeValues .~ slideToItem' slide &
229+
DynamoDB.uiReturnValues .~ Just DynamoDB.UpdatedNew &
230+
DynamoDB.uiKey .~ HMS.singleton "SlideId"
231+
(slideIdToAttributeValue slideId)
212232

213233
case res of
214234
Right x -> liftIO $ print x
215-
Left e -> liftIO $ print e
235+
Left e -> do
236+
liftIO $ print e
237+
Servant.throwError Servant.err500
216238

217239
pure $ WithId slideId slide
218240

@@ -228,60 +250,99 @@ randomText len allowedChars = T.pack <$> randomString len allowedChars
228250
newId :: IO T.Text
229251
newId = randomText 32 (['0' .. '9'] <> ['a' .. 'z'])
230252

253+
deckIdToAttributeValue :: DeckId -> DynamoDB.AttributeValue
254+
deckIdToAttributeValue (DeckId deckId) =
255+
DynamoDB.attributeValue & DynamoDB.avS .~ Just deckId
256+
257+
deckIdFromAttributeValue :: DynamoDB.AttributeValue -> Maybe DeckId
258+
deckIdFromAttributeValue attr = DeckId <$> attr ^. DynamoDB.avS
259+
260+
deckSlidesToAttributeValue :: [SlideId] -> DynamoDB.AttributeValue
261+
deckSlidesToAttributeValue deckSlides =
262+
DynamoDB.attributeValue & DynamoDB.avL .~
263+
(slideIdToAttributeValue <$> deckSlides)
264+
265+
deckSlidesFromAttributeValue :: DynamoDB.AttributeValue -> Maybe [SlideId]
266+
deckSlidesFromAttributeValue attr =
267+
traverse slideIdFromAttributeValue (attr ^. DynamoDB.avL)
268+
269+
slideIdToAttributeValue :: SlideId -> DynamoDB.AttributeValue
270+
slideIdToAttributeValue (SlideId slideId) =
271+
DynamoDB.attributeValue & DynamoDB.avS .~ Just slideId
272+
273+
slideIdFromAttributeValue :: DynamoDB.AttributeValue -> Maybe SlideId
274+
slideIdFromAttributeValue attr = SlideId <$> attr ^. DynamoDB.avS
275+
231276
deckToItem :: DeckId -> Deck -> HMS.HashMap T.Text DynamoDB.AttributeValue
232277
deckToItem deckId Deck{deckSlides} =
233-
HMS.singleton "DeckId"
234-
(DynamoDB.attributeValue & DynamoDB.avS .~ Just (unDeckId deckId)) <>
235-
(if null deckSlides
236-
then HMS.empty
237-
else
238-
HMS.singleton "DeckSlides"
239-
(DynamoDB.attributeValue & DynamoDB.avSS .~ (unSlideId <$> deckSlides))
240-
)
278+
HMS.singleton "DeckId" (deckIdToAttributeValue deckId) <>
279+
HMS.singleton "DeckSlides" (deckSlidesToAttributeValue deckSlides)
280+
281+
deckToItem' :: Deck -> HMS.HashMap T.Text DynamoDB.AttributeValue
282+
deckToItem' Deck{deckSlides} =
283+
HMS.singleton ":s" (deckSlidesToAttributeValue deckSlides)
241284

242285
itemToDeck :: HMS.HashMap T.Text DynamoDB.AttributeValue -> Maybe (WithId DeckId Deck)
243286
itemToDeck item = do
244-
deckIdAttr <- HMS.lookup "DeckId" item
245-
deckIdString <- deckIdAttr ^. DynamoDB.avS
246-
deckId <- pure $ DeckId deckIdString
247-
deckSlides <- pure $ case HMS.lookup "DeckSlides" item of
248-
Nothing -> []
249-
Just slides -> slides ^. DynamoDB.avSS <&> SlideId
287+
deckId <- HMS.lookup "DeckId" item >>= deckIdFromAttributeValue
288+
deckSlides <- HMS.lookup "DeckSlides" item >>= deckSlidesFromAttributeValue
250289
pure $ WithId deckId Deck{..}
251290

252-
253291
slideToItem :: SlideId -> Slide -> HMS.HashMap T.Text DynamoDB.AttributeValue
254292
slideToItem slideId Slide{slideContent, slideTemplate, slideAttributes} =
255-
HMS.singleton "SlideId"
256-
(DynamoDB.attributeValue & DynamoDB.avS .~ Just (unSlideId slideId)) <>
257-
HMS.singleton "SlideContent"
258-
(DynamoDB.attributeValue & DynamoDB.avS .~ Just slideContent) <>
259-
HMS.singleton "SlideTemplate"
260-
(DynamoDB.attributeValue & DynamoDB.avS .~ Just slideTemplate) <>
261-
(if HMS.null slideAttributes
262-
then HMS.empty
263-
else
264-
HMS.singleton "SlideAttributes"
265-
(DynamoDB.attributeValue & DynamoDB.avM .~ (
266-
(\txt -> DynamoDB.attributeValue & DynamoDB.avS .~ Just txt) <$>
267-
slideAttributes
268-
))
269-
)
293+
HMS.singleton "SlideId" (slideIdToAttributeValue slideId) <>
294+
HMS.singleton "SlideContent" (slideContentToAttributeValue slideContent) <>
295+
HMS.singleton "SlideTemplate" (slideTemplateToAttributeValue slideTemplate) <>
296+
HMS.singleton "SlideAttributes" (slideAttributesToAttributeValue slideAttributes)
297+
298+
slideContentToAttributeValue :: T.Text -> DynamoDB.AttributeValue
299+
slideContentToAttributeValue content =
300+
DynamoDB.attributeValue & DynamoDB.avB .~ Just (T.encodeUtf8 content)
301+
302+
slideContentFromAttributeValue :: DynamoDB.AttributeValue -> Maybe T.Text
303+
slideContentFromAttributeValue attr = toSlideContent <$> attr ^. DynamoDB.avB
304+
where
305+
toSlideContent = T.decodeUtf8
306+
307+
slideTemplateToAttributeValue :: T.Text -> DynamoDB.AttributeValue
308+
slideTemplateToAttributeValue content =
309+
DynamoDB.attributeValue & DynamoDB.avB .~ Just (T.encodeUtf8 content)
310+
311+
slideTemplateFromAttributeValue :: DynamoDB.AttributeValue -> Maybe T.Text
312+
slideTemplateFromAttributeValue attr = toSlideTemplate <$> attr ^. DynamoDB.avB
313+
where
314+
toSlideTemplate = T.decodeUtf8
315+
316+
slideAttributesToAttributeValue :: HMS.HashMap T.Text T.Text -> DynamoDB.AttributeValue
317+
slideAttributesToAttributeValue attributes =
318+
DynamoDB.attributeValue & DynamoDB.avM .~
319+
HMS.map attributeValueToAttributeValue attributes
320+
where
321+
attributeValueToAttributeValue :: T.Text -> DynamoDB.AttributeValue
322+
attributeValueToAttributeValue attrValue =
323+
DynamoDB.attributeValue & DynamoDB.avB .~ Just (T.encodeUtf8 attrValue)
324+
325+
slideAttributesFromAttributeValue :: DynamoDB.AttributeValue -> Maybe (HMS.HashMap T.Text T.Text)
326+
slideAttributesFromAttributeValue attr =
327+
traverse attributeValueFromAttributeValue (attr ^. DynamoDB.avM)
328+
where
329+
attributeValueFromAttributeValue :: DynamoDB.AttributeValue -> Maybe T.Text
330+
attributeValueFromAttributeValue attrValue =
331+
T.decodeUtf8 <$> attrValue ^. DynamoDB.avB
332+
333+
slideToItem' :: Slide -> HMS.HashMap T.Text DynamoDB.AttributeValue
334+
slideToItem' Slide{slideContent, slideTemplate, slideAttributes} =
335+
HMS.singleton ":c" (slideContentToAttributeValue slideContent) <>
336+
HMS.singleton ":t" (slideTemplateToAttributeValue slideTemplate) <>
337+
HMS.singleton ":a" (slideAttributesToAttributeValue slideAttributes)
270338

271339
itemToSlide :: HMS.HashMap T.Text DynamoDB.AttributeValue -> Maybe (WithId SlideId Slide)
272340
itemToSlide item = do
273-
slideIdAttr <- HMS.lookup "SlideId" item
274-
slideIdString <- slideIdAttr ^. DynamoDB.avS
275-
slideId <- pure $ SlideId slideIdString
276-
277-
slideContentAttr <- HMS.lookup "SlideContent" item
278-
slideContent <- slideContentAttr ^. DynamoDB.avS
341+
slideId <- HMS.lookup "SlideId" item >>= slideIdFromAttributeValue
279342

280-
slideTemplateAttr <- HMS.lookup "SlideTemplate" item
281-
slideTemplate <- slideTemplateAttr ^. DynamoDB.avS
343+
slideContent <- HMS.lookup "SlideContent" item >>= slideContentFromAttributeValue
282344

283-
slideAttributesAttr <- HMS.lookup "SlideAttributes" item
284-
slideAttributes <- pure $ slideAttributesAttr ^. DynamoDB.avM &
285-
HMS.mapMaybe (\attr -> attr ^. DynamoDB.avS)
345+
slideTemplate <- HMS.lookup "SlideTemplate" item >>= slideTemplateFromAttributeValue
346+
slideAttributes <- HMS.lookup "SlideAttributes" item >>= slideAttributesFromAttributeValue
286347

287348
pure $ WithId slideId Slide{..}

‎infra/shell.nix‎

Lines changed: 7 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,10 @@
11
with
22
{ pkgs = import ./nix {};
33
};
4-
pkgs.mkShell
5-
{ buildInputs = with pkgs; [ niv terraform awscli ];
6-
}
4+
let
5+
pkg = pkgs.haskellPackages.developPackage
6+
{ root = ./handler; };
7+
in
8+
pkg.overrideAttrs(attr: {
9+
buildInputs = with pkgs; [ niv terraform awscli ];
10+
})

0 commit comments

Comments
 (0)