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

Commit 092a8e9

Browse files
nmattianmattia
authored
Merge pull request #197 from deckgo/nm-pres-content
Presentation content
2 parents e5823c0 + 83f3f49 commit 092a8e9

File tree

7 files changed

+170
-64
lines changed

7 files changed

+170
-64
lines changed

‎infra/google-public-keys.json‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
11
{
2-
"548f3f987b17319fed8cd7683f5225a2964c699d": "-----BEGIN CERTIFICATE-----\nMIIDHDCCAgSgAwIBAgIIbXbaIQZL78cwDQYJKoZIhvcNAQEFBQAwMTEvMC0GA1UE\nAxMmc2VjdXJldG9rZW4uc3lzdGVtLmdzZXJ2aWNlYWNjb3VudC5jb20wHhcNMTkw\nNjA1MjEyMDU1WhcNMTkwNjIyMDkzNTU1WjAxMS8wLQYDVQQDEyZzZWN1cmV0b2tl\nbi5zeXN0ZW0uZ3NlcnZpY2VhY2NvdW50LmNvbTCCASIwDQYJKoZIhvcNAQEBBQAD\nggEPADCCAQoCggEBAMFQMriyb7HnFGXih8MyAa3sW1CiT9nY4kdOfuifV8WGv6xr\nyxlwwQfeRBG52nzGOdeGu4rzS7L3Ckk6NYV9lWieDY9chT0ZJ84PWhCZZMNcJ6ol\nzc9e0K0HJJC+vt3zNxBzrVRELYItjhkwZOPLTGmPUAzq/w1wJpBDm664OWVA9fKp\n69v6XhAB/V9erBGNlKF6VRPpv9JbKA2SrXJGiAOMUemxHhCdI2l7jH9wgh51S4oI\neFZ5smYkjF/a+ec3T1PaTBC4Kn1/+vfbNmDcVxYfgdfczYfmif39tLujFO7Y1b6J\nWQvEHsp6f59A/uTe4o9dskipPGQEIpOXe6hwW5sCAwEAAaM4MDYwDAYDVR0TAQH/\nBAIwADAOBgNVHQ8BAf8EBAMCB4AwFgYDVR0lAQH/BAwwCgYIKwYBBQUHAwIwDQYJ\nKoZIhvcNAQEFBQADggEBAHlXlTv+YjJnIkOXb9SNMRO9ZSeFAV0ld2ETg9B8FYsY\nZ5L/AnkOxLzYa2Q305Oi6pg4UDg2iLBXK7EFVSileC9DQwISoS/GffrOOtWxs48o\nUoiNd4eAbswxuXIjGoq5We9JT9hYxSVubsPYys1pcjQCX+NttehZpnaJ2yam8gLV\n3+2NenC1PUj6DBvycFvs4QuHNVBJfImhp2sjV/yw/DNWSLXqWCImMxLJCQLOAzYo\nXpkfOK+IBG4P3WHwLty1ZtwuIr+475WIvT5iyZdRmg8doKx4qF7ILYmvtBUipoY6\np7bcc0tn/qr11UKA6xJn+tJ/xNXaEBXcrfozhFIG71I=\n-----END CERTIFICATE-----\n",
3-
"5ceea489cd2fd641312042324c91c1720c66a57b": "-----BEGIN CERTIFICATE-----\nMIIDHDCCAgSgAwIBAgIIHsFXBrzdL0YwDQYJKoZIhvcNAQEFBQAwMTEvMC0GA1UE\nAxMmc2VjdXJldG9rZW4uc3lzdGVtLmdzZXJ2aWNlYWNjb3VudC5jb20wHhcNMTkw\nNTI4MjEyMDU1WhcNMTkwNjE0MDkzNTU1WjAxMS8wLQYDVQQDEyZzZWN1cmV0b2tl\nbi5zeXN0ZW0uZ3NlcnZpY2VhY2NvdW50LmNvbTCCASIwDQYJKoZIhvcNAQEBBQAD\nggEPADCCAQoCggEBAK9Lsu7vi+NhpGXViMiQPvYNrtCXf4MXhEEyJO123o+90VC9\njJGq7OOWLnB/JAjOqxY8G0rWn6Y4tBimcTvHK5+yCIeCZNDShkYAjQhS41cgYTW3\nE/UaQ0wpPlHjgKtT7bnKqWfBi9NL0I7GM9sgPyJ4BcDGajXbFedCFdCfXWl4qO1i\nq1lRvZVQX+79HOHL1/PDdfKlKX8DfBVTtupmVTSyEGpbr7zdMk3Smz3zLOiBXmsN\nMrdF47P9wx6G9LtgLwN52lG+AakadrW0ewFrGryr8Pybu12EUNmt0/cBLVLAw/GD\np5x0oSRRSKsLLEA4U208gr6u7csJ9MOAg09zrP8CAwEAAaM4MDYwDAYDVR0TAQH/\nBAIwADAOBgNVHQ8BAf8EBAMCB4AwFgYDVR0lAQH/BAwwCgYIKwYBBQUHAwIwDQYJ\nKoZIhvcNAQEFBQADggEBAG5mvRvd5ec6P3+kURgqXAy3NW5wPiHRiAPPzz41CBom\nFz/OCjXZ2bfUSVB4DG5WXdOPCbuUG6UFxPSNhqvUNfXv6j9p9QRJjjwRwACfod+s\nddz9lIQT/JCgO7hx8ILhhwSAmFtl75EWjDfn4Srvi8+nh1oW4v1XmVDSpJBs/y/k\nVCqjpONpChCrnDoJH5A2qK1MsbVCjSwyM998uXDTMDSSFuhVEdIvk0RZ5BpgZnGX\ntku/DINys3qy93fApXBHZf9ZE5RSH+Egvv6IV7r2xKv6q94dO4gQGsNkVMSeijgm\nMzDbyPPHQ7jfqRJ1wlkOOJW/PMe/AupHBn1/ycxcTa0=\n-----END CERTIFICATE-----\n"
2+
"980ed0d7866895ca43c20dafc859f18c6701e796": "-----BEGIN CERTIFICATE-----\nMIIDHDCCAgSgAwIBAgIIdjVTTMeinDQwDQYJKoZIhvcNAQEFBQAwMTEvMC0GA1UE\nAxMmc2VjdXJldG9rZW4uc3lzdGVtLmdzZXJ2aWNlYWNjb3VudC5jb20wHhcNMTkw\nNjEzMjEyMDU1WhcNMTkwNjMwMDkzNTU1WjAxMS8wLQYDVQQDEyZzZWN1cmV0b2tl\nbi5zeXN0ZW0uZ3NlcnZpY2VhY2NvdW50LmNvbTCCASIwDQYJKoZIhvcNAQEBBQAD\nggEPADCCAQoCggEBAMLJICckCQaObIgcY6Yc8f4jaQOv6jGziQeMuhtzJWpTjuQX\nrQ+s9ZS73oum3MbsFCozRIbfqd6q7TwAqY4umuxBG6m8Vih4SC39TGP8HYPMbk3y\neD9Z9MnQHrn0B63N0rgg3K5aQVf73TSFUCG9TCSxSQgKA3MhlZ0St6Co4rj7PnmS\nLduEAK+cd/gXSCpe7DJv4gJ81DgeD94abEDts2ooqKe9PnP2kUck2AMbIxgsxVih\nVkstNRKrVFMIHxvDFgiUqa/b/gQwk2FlCS2EXNgcoTzDLtzKGbdkXFP84U0f95Ty\nLynf3pL25tumgjVRxPOy1BNop3eaqMiZtYaix/sCAwEAAaM4MDYwDAYDVR0TAQH/\nBAIwADAOBgNVHQ8BAf8EBAMCB4AwFgYDVR0lAQH/BAwwCgYIKwYBBQUHAwIwDQYJ\nKoZIhvcNAQEFBQADggEBAD8RWbeJ8QMA1NYpvxvtJ8sjANYWy4pQ2UffeuHwUkEU\n4bgbtNMB6CTf/RuNYfmS2LEmM6V0v6CGEZ2wb4pUjiKw8mqaQPfq9/mJe3jTx3RY\niibFiVp+nP8fYT22G/VD3VblSJS130N4SEM70q31NBTvZ3ASBENGkHddDOpAkQ0Y\n9EZtjj+ap9Fuqdt7xC5mGXCZHTw0k0z1SDo6+06VEk+SqGhEHeuMx8o949OR4GMG\npiMpmzS4yzAAurAQLEf732f/j5H4TnSAtVYEyLQwkHlDpG8HxALVwzDi0pJ1Zi+9\n3OHhDZNrslhtA4sdxLaAXQl45B/z2p/GOvpV/cGb41E=\n-----END CERTIFICATE-----\n",
3+
"abdf6c8bccb498703dfc9dfb804b4e16bb242534": "-----BEGIN CERTIFICATE-----\nMIIDHDCCAgSgAwIBAgIIASvSoOXjmEkwDQYJKoZIhvcNAQEFBQAwMTEvMC0GA1UE\nAxMmc2VjdXJldG9rZW4uc3lzdGVtLmdzZXJ2aWNlYWNjb3VudC5jb20wHhcNMTkw\nNjIxMjEyMDU1WhcNMTkwNzA4MDkzNTU1WjAxMS8wLQYDVQQDEyZzZWN1cmV0b2tl\nbi5zeXN0ZW0uZ3NlcnZpY2VhY2NvdW50LmNvbTCCASIwDQYJKoZIhvcNAQEBBQAD\nggEPADCCAQoCggEBAMsEx2JxES1kBBXWOhRDMRiuiTwxYf4pyh+dCkFPF/iHqniJ\nuBlsxhCIDGLQPc4u+A1cwVIYVWfJlsTq8aOcH4am/9d77cAoUfwHQRjASzfOSIlT\nJD2iaS1S6Yemi10vLsv0tODVDBmrxzI9ie4TSCCuFmRnCxUD3v25MQ1u0xgHVoSf\n0ArLc6Bk6Rkl3Af7RR+Z6D5qHFvxkVz0L7vC6bKfZPDSgm0jDRCiaBxl5yWp7fQq\nIMy7GgIgBV/Qma3LtNJp03Qa7FwwkwLXSyoJ7cejgxNte64GzVA8gnFuRr6zEjfl\n7JvDYdGm0W6ynbzCKJ4BImHbEkm4QEuGxskS4IMCAwEAAaM4MDYwDAYDVR0TAQH/\nBAIwADAOBgNVHQ8BAf8EBAMCB4AwFgYDVR0lAQH/BAwwCgYIKwYBBQUHAwIwDQYJ\nKoZIhvcNAQEFBQADggEBAIVQeY7QdxoW1rwpZQ08i5TSSWENpZxOKraNPLg4mAv1\nX5StmDbc9B7oVMmHfPl8IoPs9S5HTx6vhhmyGZyC1ahYsH5Od5TaP/ujWgnRxfDw\nl8GXRRQdY4CKc+C/Y9cGhd5Iot9Mo96b7a+02+Y28RAL8dD0ANlmTzsszBSY97N7\ngi1alUa2yphsF7KYLhG/IX29r86vE0QIEVI8UOx0p68+T757UGq97n0tNhy36Vr8\nsmrhdM7bUetfRn5jbrnVnSGXYGu1wrLfTrAK6aM4D0hwA9NGQETtYrqXHujc0lTc\nRcQi0s+X4Y2l2fySusJrwvp4zUdQtHMRQTLBeYGENxY=\n-----END CERTIFICATE-----\n"
44
}

‎infra/handler/app/Test.hs‎

Lines changed: 42 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -50,7 +50,7 @@ withEnv act = do
5050

5151
withServer :: (Warp.Port -> IO a) -> IO a
5252
withServer act =
53-
withEnv $ \env -> withS3 env $ withSQS env $ withDynamoDB env $
53+
withPresURL $ withEnv $ \env -> withS3 env $ withSQS env $ withDynamoDB env $
5454
withPristineDB $ \conn -> do
5555
(port, socket) <- Warp.openFreePort
5656
let warpSettings = Warp.setPort port $ Warp.defaultSettings
@@ -64,6 +64,9 @@ withServer act =
6464
) >>= \case
6565
Left () -> error "Server returned"
6666
Right a -> pure a
67+
where
68+
withPresURL =
69+
bracket_ (setEnv "DECKGO_PRESENTATIONS_URL" "foo.bar.baz") (unsetEnv "DECKGO_PRESENTATIONS_URL")
6770

6871
is'
6972
:: Aws.AsError a
@@ -204,10 +207,24 @@ main = do
204207

205208
testPresDeploys :: IO ()
206209
testPresDeploys = withEnv $ \env -> withS3 env $ do
207-
deployPresentation env (Username "josph") (Deckname "some-deck")
210+
let someFirebaseId = FirebaseId "the-uid" -- from ./token
211+
let someUserId = UserId someFirebaseId
212+
213+
let someSlide = Slide (Just "foo") "bar" HMS.empty
214+
someSlideId = SlideId "foo-id"
215+
216+
let newDeck = Deck
217+
{ deckSlides = [ someSlideId ]
218+
, deckDeckname = Deckname "bar"
219+
, deckDeckbackground = Just (Deckbackground "bar")
220+
, deckOwnerId = someUserId
221+
, deckAttributes = HMS.singleton "foo" "bar"
222+
}
223+
224+
deployPresentation env (Username "josph") newDeck [someSlide]
208225
-- XXX: tests the obj diffing by making sure we can upload a presentation
209226
-- twice without errors
210-
deployPresentation env (Username "josph") (Deckname "some-deck")
227+
deployPresentation env (Username "josph") newDeck [someSlide]
211228

212229
testUsersGet :: IO ()
213230
testUsersGet = withPristineDB $ \conn -> do
@@ -388,10 +405,30 @@ testServer = withServer $ \port -> do
388405
Right users -> error $ "Expected 0 users, got: " <> show users
389406

390407
runClientM (decksGet' b (Just someUserId)) clientEnv >>= \case
408+
-- TODO: shouldn't this be a 404?
391409
Left e -> error $ "Expected decks, got error: " <> show e
392410
Right [] -> pure ()
393411
Right decks -> error $ "Expected 0 decks, got: " <> show decks
394412

413+
414+
let someUserInfo = UserInfo
415+
{ userInfoFirebaseId = someFirebaseId
416+
, userInfoEmail = Just "[email protected]" }
417+
Right someUser = userInfoToUser someUserInfo
418+
419+
runClientM (usersPost' b someUserInfo) clientEnv >>= \case
420+
Left e -> error $ "Expected user, got error: " <> show e
421+
Right (Item userId user) ->
422+
if user == someUser && userId == someUserId then pure () else (error $ "Expected same user, got: " <> show user)
423+
424+
runClientM (usersPost' b someUserInfo) clientEnv >>= \case
425+
-- TODO: test that user is returned here, even on 409
426+
Left (FailureResponse resp) ->
427+
if HTTP.statusCode (responseStatusCode resp) == 409 then pure () else
428+
error $ "Got unexpected response: " <> show resp
429+
Left e -> error $ "Expected 409, got error: " <> show e
430+
Right item -> error $ "Expected failure, got success: " <> show item
431+
395432
deckId <- runClientM (decksPost' b someDeck) clientEnv >>= \case
396433
Left e -> error $ "Expected new deck, got error: " <> show e
397434
Right (Item deckId _) -> pure deckId
@@ -416,7 +453,7 @@ testServer = withServer $ \port -> do
416453

417454
runClientM (decksPostPublish' b deckId) clientEnv >>= \case
418455
Left e -> error $ "Expected publish, got error: " <> show e
419-
Right () -> pure ()
456+
Right {} -> pure ()
420457

421458
runClientM (decksGet' b (Just someUserId)) clientEnv >>= \case
422459
Left e -> error $ "Expected decks, got error: " <> show e
@@ -456,24 +493,6 @@ testServer = withServer $ \port -> do
456493
Right decks ->
457494
unless (decks == []) (error $ "Expected no decks, got: " <> show decks)
458495

459-
let someUserInfo = UserInfo
460-
{ userInfoFirebaseId = someFirebaseId
461-
, userInfoEmail = Just "[email protected]" }
462-
Right someUser = userInfoToUser someUserInfo
463-
464-
runClientM (usersPost' b someUserInfo) clientEnv >>= \case
465-
Left e -> error $ "Expected user, got error: " <> show e
466-
Right (Item userId user) ->
467-
if user == someUser && userId == someUserId then pure () else (error $ "Expected same user, got: " <> show user)
468-
469-
runClientM (usersPost' b someUserInfo) clientEnv >>= \case
470-
-- TODO: test that user is returned here, even on 409
471-
Left (FailureResponse resp) ->
472-
if HTTP.statusCode (responseStatusCode resp) == 409 then pure () else
473-
error $ "Got unexpected response: " <> show resp
474-
Left e -> error $ "Expected 409, got error: " <> show e
475-
Right item -> error $ "Expected failure, got success: " <> show item
476-
477496
-- TODO: test that creating user with token that has different user as sub
478497
-- fails
479498

@@ -485,7 +504,7 @@ _usersDelete' :: T.Text -> UserId -> ClientM ()
485504

486505
decksGet' :: T.Text -> Maybe UserId -> ClientM [Item DeckId Deck]
487506
decksGetDeckId' :: T.Text -> DeckId -> ClientM (Item DeckId Deck)
488-
decksPostPublish' :: T.Text -> DeckId -> ClientM ()
507+
decksPostPublish' :: T.Text -> DeckId -> ClientM PresResponse
489508
decksPost' :: T.Text -> Deck -> ClientM (Item DeckId Deck)
490509
decksPut' :: T.Text -> DeckId -> Deck -> ClientM (Item DeckId Deck)
491510
decksDelete' :: T.Text -> DeckId -> ClientM ()

‎infra/handler/package.yaml‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,7 @@ dependencies:
2929
- servant-swagger
3030
- servant-swagger-ui
3131
- swagger2
32+
- tagsoup
3233
- text
3334
- unliftio
3435
- temporary

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

Lines changed: 64 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -201,6 +201,9 @@ instance Aeson.ToJSON UserInfo where
201201
instance ToSchema (Item UserId User) where
202202
declareNamedSchema _ = pure $ NamedSchema (Just "UserWithId") mempty
203203

204+
instance ToSchema PresResponse where
205+
declareNamedSchema _ = pure $ NamedSchema (Just "PresResponse") mempty
206+
204207
instance ToSchema User where
205208
declareNamedSchema _ = pure $ NamedSchema (Just "User") mempty
206209

@@ -226,7 +229,7 @@ type DecksAPI =
226229
Protected :>
227230
Capture "deck_id" DeckId :>
228231
"publish" :>
229-
Post '[JSON] () :<|>
232+
Post '[JSON] PresResponse :<|> -- XXX
230233
Protected :> ReqBody '[JSON] Deck :> Post '[JSON] (Item DeckId Deck) :<|>
231234
Protected :>
232235
Capture "deck_id" DeckId :>
@@ -385,7 +388,7 @@ server env conn = serveUsers :<|> serveDecks :<|> serveSlides
385388
serveDecks =
386389
decksGet env :<|>
387390
decksGetDeckId env :<|>
388-
decksPostPublish env :<|>
391+
decksPostPublish env conn :<|>
389392
decksPost env :<|>
390393
decksPut env :<|>
391394
decksDelete env
@@ -760,8 +763,24 @@ decksGetDeckId env fuid deckId = do
760763

761764
pure deck
762765

763-
decksPostPublish :: Aws.Env -> Firebase.UserId -> DeckId -> Servant.Handler ()
764-
decksPostPublish (fixupEnv -> env) _ deckId = do
766+
data PresResponse = PresResponse T.Text
767+
768+
instance Aeson.ToJSON PresResponse where
769+
toJSON (PresResponse t) = Aeson.object [ "url" .= t ]
770+
771+
instance Aeson.FromJSON PresResponse where
772+
parseJSON = Aeson.withObject "pres-response" $ \o ->
773+
PresResponse <$> o .: "url"
774+
775+
776+
decksPostPublish
777+
:: Aws.Env
778+
-> HC.Connection
779+
-> Firebase.UserId
780+
-> DeckId
781+
-> Servant.Handler PresResponse
782+
-- TODO: AUTH!!!!
783+
decksPostPublish (fixupEnv -> env) conn _ deckId = do
765784

766785
-- TODO: check auth
767786

@@ -788,6 +807,23 @@ decksPostPublish (fixupEnv -> env) _ deckId = do
788807
liftIO $ print e
789808
Servant.throwError Servant.err500
790809

810+
presUrl <- liftIO (getEnv "DECKGO_PRESENTATIONS_URL")
811+
liftIO (deckGetDeckIdDB env deckId) >>= \case
812+
Nothing -> Servant.throwError Servant.err500
813+
Just deck -> do
814+
let dname = deckDeckname deck
815+
iface <- liftIO $ getDbInterface conn
816+
liftIO (fmap itemContent <$> dbGetUserById iface (deckOwnerId deck)) >>= \case
817+
Nothing -> do
818+
liftIO $ putStrLn "No User Id"
819+
Servant.throwError Servant.err500
820+
Just user -> case userUsername user of
821+
Nothing -> do
822+
liftIO $ putStrLn "No username"
823+
Servant.throwError Servant.err500
824+
Just uname ->
825+
pure $ PresResponse $ "https://" <> T.pack presUrl <> "/" <> presentationPrefix uname dname
826+
791827
fixupEnv :: Aws.Env -> Aws.Env
792828
fixupEnv = Aws.configure $ SQS.sqs
793829
{ Aws._svcEndpoint = \reg -> do
@@ -960,7 +996,13 @@ slidesPutStatement = Statement sql encoder decoder True
960996
contramap (Aeson.toJSON . slideAttributes . view _2) (HE.param HE.json)
961997
decoder = HD.unit
962998

963-
slidesGetSlideId :: Aws.Env -> HC.Connection -> Firebase.UserId -> DeckId -> SlideId -> Servant.Handler (Item SlideId Slide)
999+
slidesGetSlideId
1000+
:: Aws.Env
1001+
-> HC.Connection
1002+
-> Firebase.UserId
1003+
-> DeckId
1004+
-> SlideId
1005+
-> Servant.Handler (Item SlideId Slide)
9641006
slidesGetSlideId env conn fuid deckId slideId = do
9651007

9661008
getDeck env deckId >>= \case
@@ -1452,3 +1494,20 @@ dynamoSet exprs = T.unwords exprs'
14521494
(sts, removes) = foldr f ([], []) exprs
14531495
f (Set l r) (ls, rs) = (ls <> [l <> " = " <> r], rs)
14541496
f (Remove t ) (ls, rs) = (ls, rs <> [t])
1497+
1498+
presentationPrefix :: Username -> Deckname -> T.Text
1499+
presentationPrefix uname dname =
1500+
unUsername uname <> "/" <> sanitizeDeckname dname <> "/"
1501+
1502+
sanitizeDeckname :: Deckname -> T.Text
1503+
sanitizeDeckname = T.toLower . strip . dropBadChars . unDeckname
1504+
where
1505+
strip :: T.Text -> T.Text
1506+
strip = T.dropAround ( == '-' )
1507+
dropBadChars :: T.Text -> T.Text
1508+
dropBadChars = T.concatMap
1509+
$ \case
1510+
c | isAscii c && isAlphaNum c -> T.singleton c
1511+
| c == ' ' -> T.singleton '-'
1512+
| otherwise -> ""
1513+

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

Lines changed: 57 additions & 31 deletions
Original file line numberDiff line numberDiff line change
@@ -11,9 +11,9 @@ module DeckGo.Presenter where
1111
import Control.Lens hiding ((.=))
1212
import Control.Monad
1313
import Data.Bifunctor
14-
import Data.Char (isAscii, isAlphaNum)
1514
import Data.Function
1615
import Data.List (foldl')
16+
import Data.Maybe
1717
import Data.String
1818
import DeckGo.Handler
1919
import DeckGo.Prelude
@@ -36,6 +36,7 @@ import qualified Network.AWS.S3 as S3
3636
import qualified Network.Mime as Mime
3737
import qualified System.Directory as Dir
3838
import qualified System.IO.Temp as Temp
39+
import qualified Text.HTML.TagSoup as TagSoup
3940

4041
data Err = Err T.Text SomeException
4142
deriving (Show, Exception)
@@ -73,30 +74,69 @@ listPresentationObjects env bucket uname dname =
7374

7475
withPresentationFiles
7576
:: Username
76-
-> Deckname
77+
-> Deck
78+
-> [Slide]
7779
-> ([(FilePath, S3.ObjectKey, S3.ETag)] -> IO a)
7880
-> IO a
79-
withPresentationFiles uname dname act = do
81+
withPresentationFiles uname deck slides act = do
8082
deckgoStarterDist <- getEnv "DECKGO_STARTER_DIST"
8183
Temp.withSystemTempDirectory "dist" $ \dir -> do
8284
Tar.extract dir deckgoStarterDist
83-
interpolateFile uname dname $ dir </> "index.html"
84-
interpolateFile uname dname $ dir </> "manifest.json"
85+
mapFile processIndex $ dir </> "index.html"
86+
mapFile interpol $ dir </> "manifest.json"
8587
putStrLn "Listing files..."
8688
files <- listDirectoryRecursive dir
8789
files' <- forM files $ \(fp, components) -> do
8890
etag <- fileETag fp
8991
let okey = mkObjectKey uname dname components
9092
pure (fp, okey, etag)
9193
act files'
92-
93-
interpolateFile :: Username -> Deckname -> FilePath -> IO ()
94-
interpolateFile uname dname fp = do
95-
T.readFile fp >>= T.writeFile fp . interpol
9694
where
95+
dname = deckDeckname deck
96+
processIndex :: T.Text -> T.Text
97+
processIndex =
98+
TagSoup.renderTags . processTags deck slides . TagSoup.parseTags .
99+
interpol
97100
interpol =
98101
T.replace "{{DECKDECKGO_TITLE}}" (unDeckname dname) .
99-
T.replace "{{DECKDECKGO_AUTHOR}}" (unUsername uname)
102+
T.replace "{{DECKDECKGO_AUTHOR}}" (unUsername uname) .
103+
-- TODO: description
104+
T.replace "{{DECKDECKGO_DESCRIPTION}}" "(no description given)" .
105+
T.replace "{{DECKDECKGO_BASE_HREF}}"
106+
("/" <> presentationPrefix uname dname)
107+
108+
mapFile :: (T.Text -> T.Text) -> FilePath -> IO ()
109+
mapFile f fp = do
110+
T.readFile fp >>= T.writeFile fp . f
111+
112+
type Tag = TagSoup.Tag T.Text
113+
114+
processTags :: Deck -> [Slide] -> [Tag] -> [Tag]
115+
processTags deck slides = concatMap $ \case
116+
TagSoup.TagOpen str (HMS.fromList -> attrs)
117+
| str == "deckgo-deck" -> do
118+
[ TagSoup.TagOpen str (HMS.toList (deckAttributes deck <> attrs)) ] <>
119+
(concatMap slideTags slides) <>
120+
(maybe [] deckBackgroundTags (deckDeckbackground deck))
121+
t -> [t]
122+
123+
deckBackgroundTags :: Deckbackground -> [Tag]
124+
deckBackgroundTags (unDeckbackground -> bg) =
125+
[ TagSoup.TagOpen "div" (HMS.toList $ HMS.singleton "slot" "background")
126+
] <> TagSoup.parseTags bg <>
127+
[ TagSoup.TagClose "div"
128+
]
129+
130+
slideTags :: Slide -> [Tag]
131+
slideTags slide =
132+
[ TagSoup.TagOpen
133+
("deckgo-slide-" <> slideTemplate slide)
134+
(HMS.toList (slideAttributes slide))
135+
] <> maybe [] TagSoup.parseTags (slideContent slide) <>
136+
[ TagSoup.TagClose
137+
("deckgo-slide-" <> slideTemplate slide)
138+
]
139+
100140

101141
listObjects :: Aws.Env -> S3.BucketName -> Maybe T.Text -> IO [S3.Object]
102142
listObjects (fixupEnv' -> env) bname mpref = xif ([],Nothing) $ \f (es, ct) ->
@@ -136,17 +176,19 @@ deployDeck env conn deckId = do
136176
Nothing -> pure () -- TODO
137177
Just user -> case userUsername user of
138178
Nothing -> pure () -- TODO
139-
Just uname ->
140-
deployPresentation env uname (deckDeckname deck)
179+
Just uname -> do
180+
slides <- catMaybes <$> mapM (dbGetSlideById iface) (deckSlides deck)
181+
deployPresentation env uname deck slides
141182

142-
deployPresentation :: Aws.Env -> Username -> Deckname -> IO ()
143-
deployPresentation (fixupEnv' -> env) uname dname = do
183+
deployPresentation :: Aws.Env -> Username -> Deck -> [Slide] -> IO ()
184+
deployPresentation (fixupEnv' -> env) uname deck slides = do
144185
bucketName <- getEnv "BUCKET_NAME"
145186
let bucket = S3.BucketName (T.pack bucketName)
187+
let dname = deckDeckname deck
146188
putStrLn "Listing current objects"
147189
currentObjs <- listPresentationObjects env bucket uname dname
148190
putStrLn "Listing presentations files"
149-
withPresentationFiles uname dname $ \files -> do
191+
withPresentationFiles uname deck slides $ \files -> do
150192
let
151193
currentObjs' =
152194
(\obj ->
@@ -207,26 +249,10 @@ fixupEnv' = Aws.configure $ S3.s3
207249
(Aws._svcEndpoint S3.s3 reg) & Aws.endpointHost .~ T.encodeUtf8 new
208250
}
209251

210-
presentationPrefix :: Username -> Deckname -> T.Text
211-
presentationPrefix uname dname =
212-
unUsername uname <> "/" <> sanitizeDeckname dname <> "/"
213-
214252
mkObjectKey :: Username -> Deckname -> [T.Text] -> S3.ObjectKey
215253
mkObjectKey uname dname components = S3.ObjectKey $
216254
presentationPrefix uname dname <> T.intercalate "/" components
217255

218-
sanitizeDeckname :: Deckname -> T.Text
219-
sanitizeDeckname = T.toLower . strip . dropBadChars . unDeckname
220-
where
221-
strip :: T.Text -> T.Text
222-
strip = T.dropAround ( == '-' )
223-
dropBadChars :: T.Text -> T.Text
224-
dropBadChars = T.concatMap
225-
$ \case
226-
c | isAscii c && isAlphaNum c -> T.singleton c
227-
| c == ' ' -> T.singleton '-'
228-
| otherwise -> ""
229-
230256
fileETag :: FilePath -> IO S3.ETag
231257
fileETag fp =
232258
-- XXX: The 'show' step is very import, it's what converts the Digest to

0 commit comments

Comments
 (0)