diff --git a/infra/handler/app/Test.hs b/infra/handler/app/Test.hs index e8513003b..64925d484 100644 --- a/infra/handler/app/Test.hs +++ b/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 diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index 8e132e5c4..3aa3e2cea 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/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