handler: get decks and slides by id

Author: nmattia

infra/handler/app/Test.hs

@@ -41,6 +41,11 @@ main = do
     Right decks ->
       if decks == [WithId deckId newDeck] then pure () else (error $ "Expected updated decks, got: " <> show decks)
 
+  runClientM (decksGetDeckId' deckId) clientEnv >>= \case
+    Left err -> error $ "Expected decks, got error: " <> show err
+    Right deck ->
+      if deck == (WithId deckId newDeck) then pure () else (error $ "Expected get deck, got: " <> show deck)
+
   runClientM slidesGet' clientEnv >>= \case
     Left err -> error $ "Expected slides, got error: " <> show err
     Right slides ->
@@ -57,6 +62,11 @@ main = do
     Right slides ->
       if slides == [WithId slideId updatedSlide] then pure () else (error $ "Expected updated slides, got: " <> show slides)
 
+  runClientM (slidesGetSlideId' slideId) clientEnv >>= \case
+    Left err -> error $ "Expected updated slide, got error: " <> show err
+    Right slide ->
+      if slide == (WithId slideId updatedSlide) then pure () else (error $ "Expected updated slide, got: " <> show slide)
+
   runClientM (slidesDelete' slideId) clientEnv >>= \case
     Left err -> error $ "Expected slide delete, got error: " <> show err
     Right {} -> pure ()
@@ -77,13 +87,27 @@ main = do
 
 -- 'client' allows you to produce operations to query an API from a client.
 decksGet' :: ClientM [WithId DeckId Deck]
+decksGetDeckId' :: DeckId -> ClientM (WithId DeckId Deck)
 decksPost' :: Deck -> ClientM (WithId DeckId Deck)
 decksPut' :: DeckId -> Deck -> ClientM (WithId DeckId Deck)
 decksDelete' :: DeckId -> ClientM ()
 slidesGet' :: ClientM [WithId SlideId Slide]
+slidesGetSlideId' :: SlideId -> ClientM (WithId SlideId Slide)
 slidesPost' :: Slide -> ClientM (WithId SlideId Slide)
 slidesPut' :: SlideId -> Slide -> ClientM (WithId SlideId Slide)
 slidesDelete' :: SlideId -> ClientM ()
-((decksGet' :<|> decksPost' :<|> decksPut' :<|> decksDelete') :<|>
-  (slidesGet' :<|> slidesPost' :<|> slidesPut' :<|> slidesDelete')
+((
+  decksGet' :<|>
+  decksGetDeckId' :<|>
+  decksPost' :<|>
+  decksPut' :<|>
+  decksDelete'
+  ) :<|>
+  (
+  slidesGet' :<|>
+  slidesGetSlideId' :<|>
+  slidesPost' :<|>
+  slidesPut' :<|>
+  slidesDelete'
+  )
   ) = client api

infra/handler/src/DeckGo/Handler.hs

@@ -108,12 +108,14 @@ type API =
 
 type DecksAPI =
     Get '[JSON] [WithId DeckId Deck] :<|>
+    Capture "deck_id" DeckId :> Get '[JSON] (WithId DeckId Deck) :<|>
     ReqBody '[JSON] Deck :> Post '[JSON] (WithId DeckId Deck) :<|>
     Capture "deck_id" DeckId :> ReqBody '[JSON] Deck :> Put '[JSON] (WithId DeckId Deck) :<|>
     Capture "deck_id" DeckId :> Delete '[JSON] ()
 
 type SlidesAPI =
     Get '[JSON] [WithId SlideId Slide] :<|>
+    Capture "slide_id" SlideId :> Get '[JSON] (WithId SlideId Slide) :<|>
     ReqBody '[JSON] Slide :> Post '[JSON] (WithId SlideId Slide) :<|>
     Capture "slide_id" SlideId :> ReqBody '[JSON] Slide :> Put '[JSON] (WithId SlideId Slide) :<|>
     Capture "slide_id" SlideId :> Delete '[JSON] ()
@@ -133,11 +135,13 @@ server env = serveDecks :<|> serveSlides
   where
     serveDecks =
       decksGet env :<|>
+      decksGetDeckId env :<|>
       decksPost env :<|>
       decksPut env :<|>
       decksDelete env
     serveSlides =
       slidesGet env :<|>
+      slidesGetSlideId env :<|>
       slidesPost env :<|>
       slidesPut env :<|>
       slidesDelete env
@@ -156,6 +160,32 @@ decksGet env = do
         liftIO $ print e
         Servant.throwError Servant.err500
 
+decksGetDeckId :: Aws.Env -> DeckId -> Servant.Handler (WithId DeckId Deck)
+decksGetDeckId env deckId = do
+    res <- runAWS env $ Aws.send $ DynamoDB.getItem "Decks" &
+        DynamoDB.giKey .~ HMS.singleton "DeckId" (deckIdToAttributeValue deckId)
+    case res of
+      Right getItemResponse -> do
+        case getItemResponse ^. DynamoDB.girsResponseStatus of
+          200 -> pure ()
+          404 -> do
+            liftIO $ putStrLn $ "Item not found: " <> show getItemResponse
+            Servant.throwError Servant.err404
+          s -> do
+            liftIO $
+              putStrLn $ "Unkown response status: " <> show s <>
+              " in response " <> show getItemResponse
+            Servant.throwError Servant.err500
+
+        case itemToDeck (getItemResponse ^. DynamoDB.girsItem) of
+          Nothing -> do
+            liftIO $ putStrLn $ "Could not parse response: " <> show getItemResponse
+            Servant.throwError Servant.err500
+          Just deck -> pure deck
+      Left e -> do
+        liftIO $ print e
+        Servant.throwError Servant.err500
+
 decksPost :: Aws.Env -> Deck -> Servant.Handler (WithId DeckId Deck)
 decksPost env deck = do
 
@@ -226,6 +256,32 @@ slidesGet env = do
         liftIO $ print e
         Servant.throwError Servant.err500
 
+slidesGetSlideId :: Aws.Env -> SlideId -> Servant.Handler (WithId SlideId Slide)
+slidesGetSlideId env slideId = do
+    res <- runAWS env $ Aws.send $ DynamoDB.getItem "Slides" &
+        DynamoDB.giKey .~ HMS.singleton "SlideId" (slideIdToAttributeValue slideId)
+    case res of
+      Right getItemResponse -> do
+        case getItemResponse ^. DynamoDB.girsResponseStatus of
+          200 -> pure ()
+          404 -> do
+            liftIO $ putStrLn $ "Item not found: " <> show getItemResponse
+            Servant.throwError Servant.err404
+          s -> do
+            liftIO $
+              putStrLn $ "Unkown response status: " <> show s <>
+              " in response " <> show getItemResponse
+            Servant.throwError Servant.err500
+
+        case itemToSlide (getItemResponse ^. DynamoDB.girsItem) of
+          Nothing -> do
+            liftIO $ putStrLn $ "Could not parse response: " <> show getItemResponse
+            Servant.throwError Servant.err500
+          Just slide -> pure slide
+      Left e -> do
+        liftIO $ print e
+        Servant.throwError Servant.err500
+
 slidesPost :: Aws.Env -> Slide -> Servant.Handler (WithId SlideId Slide)
 slidesPost env slide = do
     slideId <- liftIO $ SlideId <$> newId