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

Commit 0bdcbcb

Browse files
nmattianmattia
authored
Merge pull request #98 from deckgo/nm-protect-more
Protect Slides API
2 parents 937d5b0 + e59f92f commit 0bdcbcb

File tree

2 files changed

+123
-55
lines changed

2 files changed

+123
-55
lines changed

‎infra/handler/app/Test.hs‎

Lines changed: 8 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -45,7 +45,7 @@ main = do
4545

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

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

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

68-
runClientM (slidesGet' b) clientEnv >>= \case
69-
Left err -> error $ "Expected slides, got error: " <> show err
70-
Right slides ->
71-
if slides == [Item slideId someSlide] then pure () else (error $ "Expected slides, got: " <> show slides)
72-
7368
let updatedSlide = Slide "foo" "quux" HMS.empty
7469

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

79-
runClientM (slidesGet' b) clientEnv >>= \case
80-
Left err -> error $ "Expected updated slides, got error: " <> show err
81-
Right slides ->
82-
if slides == [Item slideId updatedSlide] then pure () else (error $ "Expected updated slides, got: " <> show slides)
83-
84-
runClientM (slidesGetSlideId' b slideId) clientEnv >>= \case
74+
runClientM (slidesGetSlideId' b deckId slideId) clientEnv >>= \case
8575
Left err -> error $ "Expected updated slide, got error: " <> show err
8676
Right slide ->
8777
if slide == (Item slideId updatedSlide) then pure () else (error $ "Expected updated slide, got: " <> show slide)
8878

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

93-
runClientM (slidesGet' b) clientEnv >>= \case
94-
Left err -> error $ "Expected no slides, got error: " <> show err
95-
Right slides ->
96-
if slides == [] then pure () else (error $ "Expected no slides, got: " <> show slides)
97-
9883
runClientM (decksDelete' b deckId) clientEnv >>= \case
9984
Left err -> error $ "Expected deck delete, got error: " <> show err
10085
Right {} -> pure ()
@@ -138,11 +123,10 @@ decksPost' :: T.Text -> Deck -> ClientM (Item DeckId Deck)
138123
decksPut' :: T.Text -> DeckId -> Deck -> ClientM (Item DeckId Deck)
139124
decksDelete' :: T.Text -> DeckId -> ClientM ()
140125

141-
slidesGet' :: T.Text -> ClientM [Item SlideId Slide]
142-
slidesGetSlideId' :: T.Text -> SlideId -> ClientM (Item SlideId Slide)
143-
slidesPost' :: T.Text -> Slide -> ClientM (Item SlideId Slide)
144-
slidesPut' :: T.Text -> SlideId -> Slide -> ClientM (Item SlideId Slide)
145-
slidesDelete' :: T.Text -> SlideId -> ClientM ()
126+
slidesGetSlideId' :: T.Text -> DeckId -> SlideId -> ClientM (Item SlideId Slide)
127+
slidesPost' :: T.Text -> DeckId -> Slide -> ClientM (Item SlideId Slide)
128+
slidesPut' :: T.Text -> DeckId -> SlideId -> Slide -> ClientM (Item SlideId Slide)
129+
slidesDelete' :: T.Text -> DeckId -> SlideId -> ClientM ()
146130
((
147131
usersGet' :<|>
148132
_usersGetUserId' :<|>
@@ -158,7 +142,6 @@ slidesDelete' :: T.Text -> SlideId -> ClientM ()
158142
decksDelete'
159143
) :<|>
160144
(
161-
slidesGet' :<|>
162145
slidesGetSlideId' :<|>
163146
slidesPost' :<|>
164147
slidesPut' :<|>

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

Lines changed: 115 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -136,10 +136,10 @@ instance ToJSONObject User where
136136

137137
instance Aeson.FromJSON User where
138138
parseJSON = Aeson.withObject "User" parseJSONObject
139+
139140
instance Aeson.ToJSON User where
140141
toJSON = Aeson.Object . toJSONObject
141142

142-
143143
instance ToSchema (Item UserId User) where
144144
declareNamedSchema _ = pure $ NamedSchema (Just "UserWithId") mempty
145145

@@ -179,6 +179,24 @@ data Deck = Deck
179179
, deckAttributes :: HMS.HashMap T.Text T.Text
180180
} deriving (Show, Eq)
181181

182+
183+
{-
184+
data Deck = Deck
185+
{ deckSlides :: [SlideId]
186+
, deckOwnerId :: UserId
187+
, deckAttributes :: HMS.HashMap T.Text T.Text
188+
, deckTitle :: T.Text
189+
, deckDescription :: Maybe T.Text
190+
, deckAuthor :: Maybe T.Text
191+
, deckHashTags :: [CI T.Text]
192+
, deckPublicationDate :: Maybe UTCTime
193+
} deriving (Show, Eq)
194+
-}
195+
196+
197+
198+
-- /decks/<deck-id>/publish
199+
182200
instance FromJSONObject Deck where
183201
parseJSONObject = \obj ->
184202
Deck
@@ -215,16 +233,16 @@ instance ToParamSchema DeckId where
215233
-- SLIDES
216234

217235
type SlidesAPI =
218-
Protected :> Get '[JSON] [Item SlideId Slide] :<|>
219-
Protected :>
236+
Protected :> Capture "deck_id" DeckId :> "slides" :>
220237
Capture "slide_id" SlideId :> Get '[JSON] (Item SlideId Slide) :<|>
221-
Protected :>
238+
Protected :> Capture "deck_id" DeckId :> "slides" :>
222239
ReqBody '[JSON] Slide :> Post '[JSON] (Item SlideId Slide) :<|>
223-
Protected :>
240+
Protected :> Capture "deck_id" DeckId :> "slides" :>
224241
Capture "slide_id" SlideId :>
225242
ReqBody '[JSON] Slide :>
226243
Put '[JSON] (Item SlideId Slide) :<|>
227-
Protected :> Capture "slide_id" SlideId :> Delete '[JSON] ()
244+
Protected :> Capture "deck_id" DeckId :> "slides" :>
245+
Capture "slide_id" SlideId :> Delete '[JSON] ()
228246

229247
instance ToSchema (Item SlideId Slide) where
230248
declareNamedSchema _ = pure $ NamedSchema (Just "SlideWithId") mempty
@@ -277,7 +295,7 @@ instance Aeson.ToJSON Slide where
277295
type API =
278296
"users" :> UsersAPI :<|>
279297
"decks" :> DecksAPI :<|>
280-
"slides" :> SlidesAPI
298+
"decks" :> SlidesAPI
281299

282300
api :: Proxy API
283301
api = Proxy
@@ -309,7 +327,6 @@ server env = serveUsers :<|> serveDecks :<|> serveSlides
309327
decksPut env :<|>
310328
decksDelete env
311329
serveSlides =
312-
slidesGet env :<|>
313330
slidesGetSlideId env :<|>
314331
slidesPost env :<|>
315332
slidesPut env :<|>
@@ -548,7 +565,18 @@ decksPut env fuid deckId deck = do
548565
pure $ Item deckId deck
549566

550567
decksDelete :: Aws.Env -> Firebase.UserId -> DeckId -> Servant.Handler ()
551-
decksDelete env _ deckId = do
568+
decksDelete env fuid deckId = do
569+
570+
getDeck env deckId >>= \case
571+
Nothing -> do
572+
liftIO $ putStrLn $ unwords
573+
[ "Trying to DELETE", show deckId, "but deck doesn't exist." ]
574+
Servant.throwError Servant.err404
575+
Just Deck{deckOwnerId} -> do
576+
when (Firebase.unUserId fuid /= unFirebaseId (unUserId deckOwnerId)) $ do
577+
liftIO $ putStrLn $ unwords $
578+
[ "Deck was DELETEd", show deckId, "but requester is not the owner", show fuid ]
579+
Servant.throwError Servant.err404
552580

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

601629
-- SLIDES
602630

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

614-
Left e -> do
615-
liftIO $ print e
616-
Servant.throwError Servant.err500
634+
getDeck env deckId >>= \case
635+
Nothing -> do
636+
liftIO $ putStrLn $ unwords
637+
[ "Trying to GET slide", show slideId, "of deck", show deckId
638+
, "but deck doesn't exist." ]
639+
Servant.throwError Servant.err404
640+
Just deck@Deck{deckOwnerId, deckSlides} -> do
641+
when (Firebase.unUserId fuid /= unFirebaseId (unUserId deckOwnerId)) $ do
642+
liftIO $ putStrLn $ unwords $
643+
[ "Trying to GET slide", show slideId, "of deck", show deck
644+
, "but requester is not the owner", show fuid ]
645+
Servant.throwError Servant.err404
646+
647+
unless (slideId `elem` deckSlides) $ do
648+
liftIO $ putStrLn $ unwords $
649+
[ "Trying to GET slide", show slideId, "of deck", show deck
650+
, "but slide doesn't belong to deck owned by", show fuid ]
651+
Servant.throwError Servant.err404
617652

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

644-
slidesPost :: Aws.Env -> Firebase.UserId -> Slide -> Servant.Handler (Item SlideId Slide)
645-
slidesPost env _ slide = do
677+
slidesPost :: Aws.Env -> Firebase.UserId -> DeckId -> Slide -> Servant.Handler (Item SlideId Slide)
678+
slidesPost env fuid deckId slide = do
679+
680+
getDeck env deckId >>= \case
681+
Nothing -> do
682+
liftIO $ putStrLn $ unwords
683+
[ "Trying to POST slide", show slide, "of deck", show deckId
684+
, "but deck doesn't exist." ]
685+
Servant.throwError Servant.err404
686+
Just deck@Deck{deckOwnerId} -> do
687+
when (Firebase.unUserId fuid /= unFirebaseId (unUserId deckOwnerId)) $ do
688+
liftIO $ putStrLn $ unwords $
689+
[ "Trying to POST slide", show slide, "of deck", show deck
690+
, "but requester is not the owner", show fuid ]
691+
Servant.throwError Servant.err404
692+
646693
slideId <- liftIO $ SlideId <$> newId
647694

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

658705
pure $ Item slideId slide
659706

660-
slidesPut :: Aws.Env -> Firebase.UserId -> SlideId -> Slide -> Servant.Handler (Item SlideId Slide)
661-
slidesPut env _ slideId slide = do
707+
slidesPut :: Aws.Env -> Firebase.UserId -> DeckId -> SlideId -> Slide -> Servant.Handler (Item SlideId Slide)
708+
slidesPut env fuid deckId slideId slide = do
709+
710+
getDeck env deckId >>= \case
711+
Nothing -> do
712+
liftIO $ putStrLn $ unwords
713+
[ "Trying to PUT slide", show slideId, "of deck", show deckId
714+
, "but deck doesn't exist." ]
715+
Servant.throwError Servant.err404
716+
Just deck@Deck{deckOwnerId, deckSlides} -> do
717+
when (Firebase.unUserId fuid /= unFirebaseId (unUserId deckOwnerId)) $ do
718+
liftIO $ putStrLn $ unwords $
719+
[ "Trying to PUT slide", show slideId, "of deck", show deck
720+
, "but requester is not the owner", show fuid ]
721+
Servant.throwError Servant.err404
722+
723+
unless (slideId `elem` deckSlides) $ do
724+
liftIO $ putStrLn $ unwords $
725+
[ "Trying to PUT slide", show slideId, "of deck", show deck
726+
, "but slide doesn't belong to deck owned by", show fuid ]
727+
Servant.throwError Servant.err404
662728

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

677743
pure $ Item slideId slide
678744

679-
slidesDelete :: Aws.Env -> Firebase.UserId -> SlideId -> Servant.Handler ()
680-
slidesDelete env _ slideId = do
745+
slidesDelete :: Aws.Env -> Firebase.UserId -> DeckId -> SlideId -> Servant.Handler ()
746+
slidesDelete env fuid deckId slideId = do
747+
748+
getDeck env deckId >>= \case
749+
Nothing -> do
750+
liftIO $ putStrLn $ unwords
751+
[ "Trying to DELETE slide", show slideId, "of deck", show deckId
752+
, "but deck doesn't exist." ]
753+
Servant.throwError Servant.err404
754+
Just deck@Deck{deckOwnerId, deckSlides} -> do
755+
when (Firebase.unUserId fuid /= unFirebaseId (unUserId deckOwnerId)) $ do
756+
liftIO $ putStrLn $ unwords $
757+
[ "Trying to DELETE slide", show slideId, "of deck", show deck
758+
, "but requester is not the owner", show fuid ]
759+
Servant.throwError Servant.err404
760+
761+
unless (slideId `elem` deckSlides) $ do
762+
liftIO $ putStrLn $ unwords $
763+
[ "Trying to DELETE slide", show slideId, "of deck", show deck
764+
, "but slide doesn't belong to deck owned by", show fuid ]
765+
Servant.throwError Servant.err404
681766

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

0 commit comments

Comments
 (0)