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

Protect Slides API #98

Merged
merged 6 commits into from
Apr 19, 2019
Merged

Protect Slides API #98

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
310e77b
handler: feat: move slides API under /decks
nmattia Apr 19, 2019
3eeaec0
handler: feat: protect GET slids
nmattia Apr 19, 2019
3c2f26b
handler: feat: remove GET slides
nmattia Apr 19, 2019
da6eef8
handler: feat: protect slide post
nmattia Apr 19, 2019
b07280f
handler: feat: protect slide put and del
nmattia Apr 19, 2019
e59f92f
handler: fix: fix slides api
nmattia Apr 19, 2019
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
33 changes: 8 additions & 25 deletions infra/handler/app/Test.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -45,7 +45,7 @@ main = do

let someSlide = Slide "foo" "bar" HMS.empty

slideId <- runClientM (slidesPost' b someSlide) clientEnv >>= \case
slideId <- runClientM (slidesPost' b deckId someSlide) clientEnv >>= \case
Left err -> error $ "Expected new slide, got error: " <> show err
Right (Item slideId _) -> pure slideId

Expand All @@ -65,36 +65,21 @@ main = do
Right deck ->
if deck == (Item deckId newDeck) then pure () else (error $ "Expected get deck, got: " <> show deck)

runClientM (slidesGet' b) clientEnv >>= \case
Left err -> error $ "Expected slides, got error: " <> show err
Right slides ->
if slides == [Item slideId someSlide] then pure () else (error $ "Expected slides, got: " <> show slides)

let updatedSlide = Slide "foo" "quux" HMS.empty

runClientM (slidesPut' b slideId updatedSlide) clientEnv >>= \case
runClientM (slidesPut' b deckId slideId updatedSlide) clientEnv >>= \case
Left err -> error $ "Expected new slide, got error: " <> show err
Right {} -> pure ()

runClientM (slidesGet' b) clientEnv >>= \case
Left err -> error $ "Expected updated slides, got error: " <> show err
Right slides ->
if slides == [Item slideId updatedSlide] then pure () else (error $ "Expected updated slides, got: " <> show slides)

runClientM (slidesGetSlideId' b slideId) clientEnv >>= \case
runClientM (slidesGetSlideId' b deckId slideId) clientEnv >>= \case
Left err -> error $ "Expected updated slide, got error: " <> show err
Right slide ->
if slide == (Item slideId updatedSlide) then pure () else (error $ "Expected updated slide, got: " <> show slide)

runClientM (slidesDelete' b slideId) clientEnv >>= \case
runClientM (slidesDelete' b deckId slideId) clientEnv >>= \case
Left err -> error $ "Expected slide delete, got error: " <> show err
Right {} -> pure ()

runClientM (slidesGet' b) 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' b deckId) clientEnv >>= \case
Left err -> error $ "Expected deck delete, got error: " <> show err
Right {} -> pure ()
Expand Down Expand Up @@ -138,11 +123,10 @@ decksPost' :: T.Text -> Deck -> ClientM (Item DeckId Deck)
decksPut' :: T.Text -> DeckId -> Deck -> ClientM (Item DeckId Deck)
decksDelete' :: T.Text -> DeckId -> ClientM ()

slidesGet' :: T.Text -> ClientM [Item SlideId Slide]
slidesGetSlideId' :: T.Text -> SlideId -> ClientM (Item SlideId Slide)
slidesPost' :: T.Text -> Slide -> ClientM (Item SlideId Slide)
slidesPut' :: T.Text -> SlideId -> Slide -> ClientM (Item SlideId Slide)
slidesDelete' :: T.Text -> SlideId -> ClientM ()
slidesGetSlideId' :: T.Text -> DeckId -> SlideId -> ClientM (Item SlideId Slide)
slidesPost' :: T.Text -> DeckId -> Slide -> ClientM (Item SlideId Slide)
slidesPut' :: T.Text -> DeckId -> SlideId -> Slide -> ClientM (Item SlideId Slide)
slidesDelete' :: T.Text -> DeckId -> SlideId -> ClientM ()
((
usersGet' :<|>
_usersGetUserId' :<|>
Expand All @@ -158,7 +142,6 @@ slidesDelete' :: T.Text -> SlideId -> ClientM ()
decksDelete'
) :<|>
(
slidesGet' :<|>
slidesGetSlideId' :<|>
slidesPost' :<|>
slidesPut' :<|>
Expand Down
145 changes: 115 additions & 30 deletions infra/handler/src/DeckGo/Handler.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -136,10 +136,10 @@ instance ToJSONObject User where

instance Aeson.FromJSON User where
parseJSON = Aeson.withObject "User" parseJSONObject

instance Aeson.ToJSON User where
toJSON = Aeson.Object . toJSONObject


instance ToSchema (Item UserId User) where
declareNamedSchema _ = pure $ NamedSchema (Just "UserWithId") mempty

Expand Down Expand Up @@ -179,6 +179,24 @@ data Deck = Deck
, deckAttributes :: HMS.HashMap T.Text T.Text
} deriving (Show, Eq)


{-
data Deck = Deck
{ deckSlides :: [SlideId]
, deckOwnerId :: UserId
, deckAttributes :: HMS.HashMap T.Text T.Text
, deckTitle :: T.Text
, deckDescription :: Maybe T.Text
, deckAuthor :: Maybe T.Text
, deckHashTags :: [CI T.Text]
, deckPublicationDate :: Maybe UTCTime
} deriving (Show, Eq)
-}



-- /decks/<deck-id>/publish

instance FromJSONObject Deck where
parseJSONObject = \obj ->
Deck
Expand Down Expand Up @@ -215,16 +233,16 @@ instance ToParamSchema DeckId where
-- SLIDES

type SlidesAPI =
Protected :> Get '[JSON] [Item SlideId Slide] :<|>
Protected :>
Protected :> Capture "deck_id" DeckId :> "slides" :>
Capture "slide_id" SlideId :> Get '[JSON] (Item SlideId Slide) :<|>
Protected :>
Protected :> Capture "deck_id" DeckId :> "slides" :>
ReqBody '[JSON] Slide :> Post '[JSON] (Item SlideId Slide) :<|>
Protected :>
Protected :> Capture "deck_id" DeckId :> "slides" :>
Capture "slide_id" SlideId :>
ReqBody '[JSON] Slide :>
Put '[JSON] (Item SlideId Slide) :<|>
Protected :> Capture "slide_id" SlideId :> Delete '[JSON] ()
Protected :> Capture "deck_id" DeckId :> "slides" :>
Capture "slide_id" SlideId :> Delete '[JSON] ()

instance ToSchema (Item SlideId Slide) where
declareNamedSchema _ = pure $ NamedSchema (Just "SlideWithId") mempty
Expand Down Expand Up @@ -277,7 +295,7 @@ instance Aeson.ToJSON Slide where
type API =
"users" :> UsersAPI :<|>
"decks" :> DecksAPI :<|>
"slides" :> SlidesAPI
"decks" :> SlidesAPI

api :: Proxy API
api = Proxy
Expand Down Expand Up @@ -309,7 +327,6 @@ server env = serveUsers :<|> serveDecks :<|> serveSlides
decksPut env :<|>
decksDelete env
serveSlides =
slidesGet env :<|>
slidesGetSlideId env :<|>
slidesPost env :<|>
slidesPut env :<|>
Expand Down Expand Up @@ -548,7 +565,18 @@ decksPut env fuid deckId deck = do
pure $ Item deckId deck

decksDelete :: Aws.Env -> Firebase.UserId -> DeckId -> Servant.Handler ()
decksDelete env _ deckId = do
decksDelete env fuid deckId = do

getDeck env deckId >>= \case
Nothing -> do
liftIO $ putStrLn $ unwords
[ "Trying to DELETE", show deckId, "but deck doesn't exist." ]
Servant.throwError Servant.err404
Just Deck{deckOwnerId} -> do
when (Firebase.unUserId fuid /= unFirebaseId (unUserId deckOwnerId)) $ do
liftIO $ putStrLn $ unwords $
[ "Deck was DELETEd", show deckId, "but requester is not the owner", show fuid ]
Servant.throwError Servant.err404

res <- runAWS env $ Aws.send $ DynamoDB.deleteItem "Decks" &
DynamoDB.diKey .~ HMS.singleton "DeckId"
Expand Down Expand Up @@ -600,23 +628,28 @@ getDeck env deckId = do

-- SLIDES

slidesGet :: Aws.Env -> Firebase.UserId -> Servant.Handler [Item SlideId Slide]
slidesGet env _ = do
res <- runAWS env $ Aws.send $ DynamoDB.scan "Slides"
case res of
Right scanResponse ->
case sequence $ scanResponse ^. DynamoDB.srsItems <&> itemToSlide of
Nothing -> do
liftIO $ putStrLn $ "Could not parse respose: " <> show scanResponse
Servant.throwError Servant.err500
Just ids -> pure ids
slidesGetSlideId :: Aws.Env -> Firebase.UserId -> DeckId -> SlideId -> Servant.Handler (Item SlideId Slide)
slidesGetSlideId env fuid deckId slideId = do

Left e -> do
liftIO $ print e
Servant.throwError Servant.err500
getDeck env deckId >>= \case
Nothing -> do
liftIO $ putStrLn $ unwords
[ "Trying to GET slide", show slideId, "of deck", show deckId
, "but deck doesn't exist." ]
Servant.throwError Servant.err404
Just deck@Deck{deckOwnerId, deckSlides} -> do
when (Firebase.unUserId fuid /= unFirebaseId (unUserId deckOwnerId)) $ do
liftIO $ putStrLn $ unwords $
[ "Trying to GET slide", show slideId, "of deck", show deck
, "but requester is not the owner", show fuid ]
Servant.throwError Servant.err404

unless (slideId `elem` deckSlides) $ do
liftIO $ putStrLn $ unwords $
[ "Trying to GET slide", show slideId, "of deck", show deck
, "but slide doesn't belong to deck owned by", show fuid ]
Servant.throwError Servant.err404

slidesGetSlideId :: Aws.Env -> Firebase.UserId -> SlideId -> Servant.Handler (Item SlideId Slide)
slidesGetSlideId env _ slideId = do
res <- runAWS env $ Aws.send $ DynamoDB.getItem "Slides" &
DynamoDB.giKey .~ HMS.singleton "SlideId" (slideIdToAttributeValue slideId)
case res of
Expand All @@ -641,8 +674,22 @@ slidesGetSlideId env _ slideId = do
liftIO $ print e
Servant.throwError Servant.err500

slidesPost :: Aws.Env -> Firebase.UserId -> Slide -> Servant.Handler (Item SlideId Slide)
slidesPost env _ slide = do
slidesPost :: Aws.Env -> Firebase.UserId -> DeckId -> Slide -> Servant.Handler (Item SlideId Slide)
slidesPost env fuid deckId slide = do

getDeck env deckId >>= \case
Nothing -> do
liftIO $ putStrLn $ unwords
[ "Trying to POST slide", show slide, "of deck", show deckId
, "but deck doesn't exist." ]
Servant.throwError Servant.err404
Just deck@Deck{deckOwnerId} -> do
when (Firebase.unUserId fuid /= unFirebaseId (unUserId deckOwnerId)) $ do
liftIO $ putStrLn $ unwords $
[ "Trying to POST slide", show slide, "of deck", show deck
, "but requester is not the owner", show fuid ]
Servant.throwError Servant.err404

slideId <- liftIO $ SlideId <$> newId

res <- runAWS env $
Expand All @@ -657,8 +704,27 @@ slidesPost env _ slide = do

pure $ Item slideId slide

slidesPut :: Aws.Env -> Firebase.UserId -> SlideId -> Slide -> Servant.Handler (Item SlideId Slide)
slidesPut env _ slideId slide = do
slidesPut :: Aws.Env -> Firebase.UserId -> DeckId -> SlideId -> Slide -> Servant.Handler (Item SlideId Slide)
slidesPut env fuid deckId slideId slide = do

getDeck env deckId >>= \case
Nothing -> do
liftIO $ putStrLn $ unwords
[ "Trying to PUT slide", show slideId, "of deck", show deckId
, "but deck doesn't exist." ]
Servant.throwError Servant.err404
Just deck@Deck{deckOwnerId, deckSlides} -> do
when (Firebase.unUserId fuid /= unFirebaseId (unUserId deckOwnerId)) $ do
liftIO $ putStrLn $ unwords $
[ "Trying to PUT slide", show slideId, "of deck", show deck
, "but requester is not the owner", show fuid ]
Servant.throwError Servant.err404

unless (slideId `elem` deckSlides) $ do
liftIO $ putStrLn $ unwords $
[ "Trying to PUT slide", show slideId, "of deck", show deck
, "but slide doesn't belong to deck owned by", show fuid ]
Servant.throwError Servant.err404

res <- runAWS env $ Aws.send $ DynamoDB.updateItem "Slides" &
DynamoDB.uiUpdateExpression .~ Just
Expand All @@ -676,8 +742,27 @@ slidesPut env _ slideId slide = do

pure $ Item slideId slide

slidesDelete :: Aws.Env -> Firebase.UserId -> SlideId -> Servant.Handler ()
slidesDelete env _ slideId = do
slidesDelete :: Aws.Env -> Firebase.UserId -> DeckId -> SlideId -> Servant.Handler ()
slidesDelete env fuid deckId slideId = do

getDeck env deckId >>= \case
Nothing -> do
liftIO $ putStrLn $ unwords
[ "Trying to DELETE slide", show slideId, "of deck", show deckId
, "but deck doesn't exist." ]
Servant.throwError Servant.err404
Just deck@Deck{deckOwnerId, deckSlides} -> do
when (Firebase.unUserId fuid /= unFirebaseId (unUserId deckOwnerId)) $ do
liftIO $ putStrLn $ unwords $
[ "Trying to DELETE slide", show slideId, "of deck", show deck
, "but requester is not the owner", show fuid ]
Servant.throwError Servant.err404

unless (slideId `elem` deckSlides) $ do
liftIO $ putStrLn $ unwords $
[ "Trying to DELETE slide", show slideId, "of deck", show deck
, "but slide doesn't belong to deck owned by", show fuid ]
Servant.throwError Servant.err404

res <- runAWS env $ Aws.send $ DynamoDB.deleteItem "Slides" &
DynamoDB.diKey .~ HMS.singleton "SlideId"
Expand Down