handler: implement DELETE

Author: nmattia

infra/handler/app/Test.hs

@@ -57,13 +57,33 @@ main = do
     Right slides ->
       if slides == [WithId slideId updatedSlide] then pure () else (error $ "Expected updated slides, got: " <> show slides)
 
+  runClientM (slidesDelete' slideId) clientEnv >>= \case
+    Left err -> error $ "Expected slide delete, got error: " <> show err
+    Right {} -> pure ()
+
+  runClientM slidesGet' clientEnv >>= \case
+    Left err -> error $ "Expected no slides, got error: " <> show err
+    Right slides ->
+      if slides == [] then pure () else (error $ "Expected no slides, got: " <> show slides)
+
+  runClientM (decksDelete' deckId) clientEnv >>= \case
+    Left err -> error $ "Expected deck delete, got error: " <> show err
+    Right {} -> pure ()
+
+  runClientM decksGet' clientEnv >>= \case
+    Left err -> error $ "Expected no decks, got error: " <> show err
+    Right decks ->
+      if decks == [] then pure () else (error $ "Expected no decks, got: " <> show decks)
+
 -- 'client' allows you to produce operations to query an API from a client.
 decksGet' :: 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]
 slidesPost' :: Slide -> ClientM (WithId SlideId Slide)
 slidesPut' :: SlideId -> Slide -> ClientM (WithId SlideId Slide)
-((decksGet' :<|> decksPost' :<|> decksPut') :<|>
-  (slidesGet' :<|> slidesPost' :<|> slidesPut')
+slidesDelete' :: SlideId -> ClientM ()
+((decksGet' :<|> decksPost' :<|> decksPut' :<|> decksDelete') :<|>
+  (slidesGet' :<|> slidesPost' :<|> slidesPut' :<|> slidesDelete')
   ) = client api

infra/handler/src/DeckGo/Handler.hs

@@ -109,12 +109,14 @@ type API =
 type DecksAPI =
     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 :> ReqBody '[JSON] Deck :> Put '[JSON] (WithId DeckId Deck) :<|>
+    Capture "deck_id" DeckId :> Delete '[JSON] ()
 
 type SlidesAPI =
     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 :> ReqBody '[JSON] Slide :> Put '[JSON] (WithId SlideId Slide) :<|>
+    Capture "slide_id" SlideId :> Delete '[JSON] ()
 
 api :: Proxy API
 api = Proxy
@@ -129,8 +131,16 @@ application env = Servant.serve api (server env)
 server :: Aws.Env -> Servant.Server API
 server env = serveDecks :<|> serveSlides
   where
-    serveDecks = decksGet env :<|> decksPost env :<|> decksPut env
-    serveSlides = slidesGet env :<|> slidesPost env :<|> slidesPut env
+    serveDecks =
+      decksGet env :<|>
+      decksPost env :<|>
+      decksPut env :<|>
+      decksDelete env
+    serveSlides =
+      slidesGet env :<|>
+      slidesPost env :<|>
+      slidesPut env :<|>
+      slidesDelete env
 
 decksGet :: Aws.Env -> Servant.Handler [WithId DeckId Deck]
 decksGet env = do
@@ -180,6 +190,19 @@ decksPut env deckId deck = do
 
     pure $ WithId deckId deck
 
+decksDelete :: Aws.Env -> DeckId -> Servant.Handler ()
+decksDelete env deckId = do
+
+    res <- runAWS env $ Aws.send $ DynamoDB.deleteItem "Decks" &
+        DynamoDB.diKey .~ HMS.singleton "DeckId"
+          (deckIdToAttributeValue deckId)
+
+    case res of
+      Right {} -> pure ()
+      Left e -> do
+        liftIO $ print e
+        Servant.throwError Servant.err500
+
 runAWS :: MonadIO m => Aws.Env -> Aws.AWS a -> m (Either SomeException a)
 runAWS env =
     liftIO .
@@ -238,6 +261,19 @@ slidesPut env slideId slide = do
 
     pure $ WithId slideId slide
 
+slidesDelete :: Aws.Env -> SlideId -> Servant.Handler ()
+slidesDelete env slideId = do
+
+    res <- runAWS env $ Aws.send $ DynamoDB.deleteItem "Slides" &
+        DynamoDB.diKey .~  HMS.singleton "SlideId"
+          (slideIdToAttributeValue slideId)
+
+    case res of
+      Right x -> liftIO $ print x
+      Left e -> do
+        liftIO $ print e
+        Servant.throwError Servant.err500
+
 randomString :: Int -> [Char] -> IO String
 randomString len allowedChars =
   replicateM len $ do