Dirty implementation of presentation content

Author: nmattia

infra/handler/app/Test.hs

@@ -50,7 +50,7 @@ withEnv act = do
 
 withServer :: (Warp.Port -> IO a) -> IO a
 withServer act =
-    withEnv $ \env -> withS3 env $ withSQS env $ withDynamoDB env $
+    withPresURL $ withEnv $ \env -> withS3 env $ withSQS env $ withDynamoDB env $
       withPristineDB $ \conn -> do
         (port, socket) <- Warp.openFreePort
         let warpSettings = Warp.setPort port $ Warp.defaultSettings
@@ -64,6 +64,9 @@ withServer act =
           ) >>= \case
             Left () -> error "Server returned"
             Right a -> pure a
+  where
+    withPresURL =
+      bracket_ (setEnv "DECKGO_PRESENTATIONS_URL" "foo.bar.baz") (unsetEnv "DECKGO_PRESENTATIONS_URL")
 
 is'
   :: Aws.AsError a
@@ -204,10 +207,24 @@ main = do
 
 testPresDeploys :: IO ()
 testPresDeploys = withEnv $ \env -> withS3 env $ do
-    deployPresentation env (Username "josph") (Deckname "some-deck")
+    let someFirebaseId = FirebaseId "the-uid" -- from ./token
+    let someUserId = UserId someFirebaseId
+
+    let someSlide = Slide (Just "foo") "bar" HMS.empty
+        someSlideId = SlideId "foo-id"
+
+    let newDeck = Deck
+          { deckSlides = [ someSlideId ]
+          , deckDeckname = Deckname "bar"
+          , deckDeckbackground = Just (Deckbackground "bar")
+          , deckOwnerId = someUserId
+          , deckAttributes = HMS.singleton "foo" "bar"
+          }
+
+    deployPresentation env (Username "josph") newDeck [someSlide]
     -- XXX: tests the obj diffing by making sure we can upload a presentation
     -- twice without errors
-    deployPresentation env (Username "josph") (Deckname "some-deck")
+    deployPresentation env (Username "josph") newDeck [someSlide]
 
 testUsersGet :: IO ()
 testUsersGet = withPristineDB $ \conn -> do
@@ -388,10 +405,30 @@ testServer = withServer $ \port -> do
     Right users -> error $ "Expected 0 users, got: " <> show users
 
   runClientM (decksGet' b (Just someUserId)) clientEnv >>= \case
+    -- TODO: shouldn't this be a 404?
     Left e -> error $ "Expected decks, got error: " <> show e
     Right [] -> pure ()
     Right decks -> error $ "Expected 0 decks, got: " <> show decks
 
+
+  let someUserInfo = UserInfo
+        { userInfoFirebaseId = someFirebaseId
+        , userInfoEmail = Just "[email protected]" }
+      Right someUser = userInfoToUser someUserInfo
+
+  runClientM (usersPost' b someUserInfo) clientEnv >>= \case
+    Left e -> error $ "Expected user, got error: " <> show e
+    Right (Item userId user) ->
+      if user == someUser && userId == someUserId then pure () else (error $ "Expected same user, got: " <> show user)
+
+  runClientM (usersPost' b someUserInfo) clientEnv >>= \case
+    -- TODO: test that user is returned here, even on 409
+    Left (FailureResponse resp) ->
+      if HTTP.statusCode (responseStatusCode resp) == 409 then pure () else
+        error $ "Got unexpected response: " <> show resp
+    Left e -> error $ "Expected 409, got error: " <> show e
+    Right item -> error $ "Expected failure, got success: " <> show item
+
   deckId <- runClientM (decksPost' b someDeck) clientEnv >>= \case
     Left e -> error $ "Expected new deck, got error: " <> show e
     Right (Item deckId _) -> pure deckId
@@ -416,7 +453,7 @@ testServer = withServer $ \port -> do
 
   runClientM (decksPostPublish' b deckId) clientEnv >>= \case
     Left e -> error $ "Expected publish, got error: " <> show e
-    Right () -> pure ()
+    Right {} -> pure ()
 
   runClientM (decksGet' b (Just someUserId)) clientEnv >>= \case
     Left e -> error $ "Expected decks, got error: " <> show e
@@ -456,24 +493,6 @@ testServer = withServer $ \port -> do
     Right decks ->
       unless (decks == []) (error $ "Expected no decks, got: " <> show decks)
 
-  let someUserInfo = UserInfo
-        { userInfoFirebaseId = someFirebaseId
-        , userInfoEmail = Just "[email protected]" }
-      Right someUser = userInfoToUser someUserInfo
-
-  runClientM (usersPost' b someUserInfo) clientEnv >>= \case
-    Left e -> error $ "Expected user, got error: " <> show e
-    Right (Item userId user) ->
-      if user == someUser && userId == someUserId then pure () else (error $ "Expected same user, got: " <> show user)
-
-  runClientM (usersPost' b someUserInfo) clientEnv >>= \case
-    -- TODO: test that user is returned here, even on 409
-    Left (FailureResponse resp) ->
-      if HTTP.statusCode (responseStatusCode resp) == 409 then pure () else
-        error $ "Got unexpected response: " <> show resp
-    Left e -> error $ "Expected 409, got error: " <> show e
-    Right item -> error $ "Expected failure, got success: " <> show item
-
   -- TODO: test that creating user with token that has different user as sub
   -- fails
 
@@ -485,7 +504,7 @@ _usersDelete' :: T.Text -> UserId -> ClientM ()
 
 decksGet' :: T.Text -> Maybe UserId -> ClientM [Item DeckId Deck]
 decksGetDeckId' :: T.Text -> DeckId -> ClientM (Item DeckId Deck)
-decksPostPublish' :: T.Text -> DeckId -> ClientM ()
+decksPostPublish' :: T.Text -> DeckId -> ClientM PresResponse
 decksPost' :: T.Text -> Deck -> ClientM (Item DeckId Deck)
 decksPut' :: T.Text -> DeckId -> Deck -> ClientM (Item DeckId Deck)
 decksDelete' :: T.Text -> DeckId -> ClientM ()

infra/handler/package.yaml

@@ -29,6 +29,7 @@ dependencies:
     - servant-swagger
     - servant-swagger-ui
     - swagger2
+    - tagsoup
     - text
     - unliftio
     - temporary

infra/handler/src/DeckGo/Handler.hs

@@ -201,6 +201,9 @@ instance Aeson.ToJSON UserInfo where
 instance ToSchema (Item UserId User) where
   declareNamedSchema _ = pure $ NamedSchema (Just "UserWithId") mempty
 
+instance ToSchema PresResponse where
+  declareNamedSchema _ = pure $ NamedSchema (Just "PresResponse") mempty
+
 instance ToSchema User where
   declareNamedSchema _ = pure $ NamedSchema (Just "User") mempty
 
@@ -226,7 +229,7 @@ type DecksAPI =
     Protected :>
       Capture "deck_id" DeckId :>
       "publish" :>
-      Post '[JSON] () :<|>
+      Post '[JSON] PresResponse :<|> -- XXX
     Protected :> ReqBody '[JSON] Deck :> Post '[JSON] (Item DeckId Deck) :<|>
     Protected :>
       Capture "deck_id" DeckId :>
@@ -385,7 +388,7 @@ server env conn = serveUsers :<|> serveDecks :<|> serveSlides
     serveDecks =
       decksGet env :<|>
       decksGetDeckId env :<|>
-      decksPostPublish env :<|>
+      decksPostPublish env conn :<|>
       decksPost env :<|>
       decksPut env :<|>
       decksDelete env
@@ -760,8 +763,24 @@ decksGetDeckId env fuid deckId = do
 
     pure deck
 
-decksPostPublish :: Aws.Env -> Firebase.UserId -> DeckId -> Servant.Handler ()
-decksPostPublish (fixupEnv -> env) _ deckId = do
+data PresResponse = PresResponse T.Text
+
+instance Aeson.ToJSON PresResponse where
+  toJSON (PresResponse t) = Aeson.object [ "url" .= t ]
+
+instance Aeson.FromJSON PresResponse where
+  parseJSON = Aeson.withObject "pres-response" $ \o ->
+    PresResponse <$> o .: "url"
+
+
+decksPostPublish
+  :: Aws.Env
+  -> HC.Connection
+  -> Firebase.UserId
+  -> DeckId
+  -> Servant.Handler PresResponse
+  -- TODO: AUTH!!!!
+decksPostPublish (fixupEnv -> env) conn _ deckId = do
 
     -- TODO: check auth
 
@@ -788,6 +807,23 @@ decksPostPublish (fixupEnv -> env) _ deckId = do
         liftIO $ print e
         Servant.throwError Servant.err500
 
+    presUrl <- liftIO (getEnv "DECKGO_PRESENTATIONS_URL")
+    liftIO (deckGetDeckIdDB env deckId) >>= \case
+      Nothing -> Servant.throwError Servant.err500
+      Just deck -> do
+        let dname = deckDeckname deck
+        iface <- liftIO $ getDbInterface conn
+        liftIO (fmap itemContent <$> dbGetUserById iface (deckOwnerId deck)) >>= \case
+          Nothing -> do
+            liftIO $ putStrLn "No User Id"
+            Servant.throwError Servant.err500
+          Just user -> case userUsername user of
+            Nothing -> do
+              liftIO $ putStrLn "No username"
+              Servant.throwError Servant.err500
+            Just uname ->
+              pure $ PresResponse $ "https://" <> T.pack presUrl <> "/" <> presentationPrefix uname dname
+
 fixupEnv :: Aws.Env -> Aws.Env
 fixupEnv = Aws.configure $ SQS.sqs
   { Aws._svcEndpoint = \reg -> do
@@ -960,7 +996,13 @@ slidesPutStatement = Statement sql encoder decoder True
       contramap (Aeson.toJSON . slideAttributes . view _2) (HE.param HE.json)
     decoder = HD.unit
 
-slidesGetSlideId :: Aws.Env -> HC.Connection -> Firebase.UserId -> DeckId -> SlideId -> Servant.Handler (Item SlideId Slide)
+slidesGetSlideId
+  :: Aws.Env
+  -> HC.Connection
+  -> Firebase.UserId
+  -> DeckId
+  -> SlideId
+  -> Servant.Handler (Item SlideId Slide)
 slidesGetSlideId env conn fuid deckId slideId = do
 
     getDeck env deckId >>= \case
@@ -1452,3 +1494,20 @@ dynamoSet exprs = T.unwords exprs'
     (sts, removes) = foldr f ([], []) exprs
     f (Set l r) (ls, rs) = (ls <> [l <> " = " <> r], rs)
     f (Remove t ) (ls, rs) = (ls, rs <> [t])
+
+presentationPrefix :: Username -> Deckname -> T.Text
+presentationPrefix uname dname =
+    unUsername uname <> "/" <>  sanitizeDeckname dname <> "/"
+
+sanitizeDeckname :: Deckname -> T.Text
+sanitizeDeckname = T.toLower . strip . dropBadChars . unDeckname
+  where
+    strip :: T.Text -> T.Text
+    strip = T.dropAround ( == '-' )
+    dropBadChars :: T.Text -> T.Text
+    dropBadChars = T.concatMap
+      $ \case
+        c | isAscii c && isAlphaNum c -> T.singleton c
+          | c == ' ' -> T.singleton '-'
+          | otherwise -> ""
+

infra/handler/src/DeckGo/Presenter.hs

@@ -11,9 +11,9 @@ module DeckGo.Presenter where
 import Control.Lens hiding ((.=))
 import Control.Monad
 import Data.Bifunctor
-import Data.Char (isAscii, isAlphaNum)
 import Data.Function
 import Data.List (foldl')
+import Data.Maybe
 import Data.String
 import DeckGo.Handler
 import DeckGo.Prelude
@@ -36,6 +36,7 @@ import qualified Network.AWS.S3 as S3
 import qualified Network.Mime as Mime
 import qualified System.Directory as Dir
 import qualified System.IO.Temp as Temp
+import qualified Text.HTML.TagSoup as TagSoup
 
 data Err = Err T.Text SomeException
   deriving (Show, Exception)
@@ -73,30 +74,67 @@ listPresentationObjects env bucket uname dname =
 
 withPresentationFiles
   :: Username
-  -> Deckname
+  -> Deck
+  -> [Slide]
   -> ([(FilePath, S3.ObjectKey, S3.ETag)] -> IO a)
   -> IO a
-withPresentationFiles uname dname act = do
+withPresentationFiles uname deck slides act = do
     deckgoStarterDist <- getEnv "DECKGO_STARTER_DIST"
     Temp.withSystemTempDirectory "dist" $ \dir -> do
       Tar.extract dir deckgoStarterDist
-      interpolateFile uname dname $ dir </> "index.html"
-      interpolateFile uname dname $ dir </> "manifest.json"
+      mapFile processIndex $ dir </> "index.html"
+      mapFile interpol $ dir </> "manifest.json"
       putStrLn "Listing files..."
       files <- listDirectoryRecursive dir
       files' <- forM files $ \(fp, components) -> do
         etag <- fileETag fp
         let okey = mkObjectKey uname dname components
         pure (fp, okey, etag)
       act files'
-
-interpolateFile :: Username -> Deckname -> FilePath -> IO ()
-interpolateFile uname dname fp = do
-    T.readFile fp >>= T.writeFile fp . interpol
   where
+    dname = deckDeckname deck
+    processIndex :: T.Text -> T.Text
+    processIndex =
+      TagSoup.renderTags . processTags deck slides . TagSoup.parseTags .
+      interpol
     interpol =
       T.replace "{{DECKDECKGO_TITLE}}" (unDeckname dname) .
-      T.replace "{{DECKDECKGO_AUTHOR}}" (unUsername uname)
+      T.replace "{{DECKDECKGO_AUTHOR}}" (unUsername uname) .
+      -- TODO: description
+      T.replace "{{DECKDECKGO_DESCRIPTION}}" "(no description given)" .
+      T.replace "{{DECKDECKGO_BASE_HREF}}"
+        ("/" <> presentationPrefix uname dname)
+
+mapFile :: (T.Text -> T.Text) -> FilePath -> IO ()
+mapFile f fp = do
+    T.readFile fp >>= T.writeFile fp . f
+
+type Tag = TagSoup.Tag T.Text
+
+processTags :: Deck -> [Slide] -> [Tag] -> [Tag]
+processTags deck slides = concatMap $ \case
+  TagSoup.TagOpen str (HMS.fromList -> attrs)
+    | str == "deckgo-deck" -> do
+        [ TagSoup.TagOpen str (HMS.toList (deckAttributes deck <> attrs)) ] <>
+          (concatMap slideTags slides) <>
+          (maybe [] (\dbg ->
+              [deckBackgroundTag dbg])
+            (deckDeckbackground deck))
+  t -> [t]
+
+deckBackgroundTag :: Deckbackground -> Tag
+deckBackgroundTag (unDeckbackground -> bg) = TagSoup.TagText bg
+
+slideTags :: Slide -> [Tag]
+slideTags slide =
+    [ TagSoup.TagOpen
+        ("deckgo-slide-" <> slideTemplate slide)
+        (HMS.toList (slideAttributes slide))
+    ] <> maybe [] TagSoup.parseTags (slideContent slide) <>
+    [ TagSoup.TagClose
+        ("deckgo-slide-" <> slideTemplate slide)
+    ]
+
 
 listObjects :: Aws.Env -> S3.BucketName -> Maybe T.Text -> IO [S3.Object]
 listObjects (fixupEnv' -> env) bname mpref = xif ([],Nothing) $ \f (es, ct) ->
@@ -136,17 +174,19 @@ deployDeck env conn deckId = do
           Nothing -> pure () -- TODO
           Just user -> case userUsername user of
             Nothing -> pure () -- TODO
-            Just uname ->
-              deployPresentation env uname (deckDeckname deck)
+            Just uname -> do
+              slides <- catMaybes <$> mapM (dbGetSlideById iface) (deckSlides deck)
+              deployPresentation env uname deck slides
 
-deployPresentation :: Aws.Env -> Username -> Deckname -> IO ()
-deployPresentation (fixupEnv' -> env) uname dname = do
+deployPresentation :: Aws.Env -> Username -> Deck -> [Slide] -> IO ()
+deployPresentation (fixupEnv' -> env) uname deck slides = do
     bucketName <- getEnv "BUCKET_NAME"
     let bucket = S3.BucketName (T.pack bucketName)
+    let dname = deckDeckname deck
     putStrLn "Listing current objects"
     currentObjs <- listPresentationObjects env bucket uname dname
     putStrLn "Listing presentations files"
-    withPresentationFiles uname dname $ \files -> do
+    withPresentationFiles uname deck slides $ \files -> do
       let
         currentObjs' =
           (\obj ->
@@ -207,26 +247,10 @@ fixupEnv' = Aws.configure $ S3.s3
       (Aws._svcEndpoint S3.s3 reg) & Aws.endpointHost .~ T.encodeUtf8 new
   }
 
-presentationPrefix :: Username -> Deckname -> T.Text
-presentationPrefix uname dname =
-    unUsername uname <> "/" <>  sanitizeDeckname dname <> "/"
-
 mkObjectKey :: Username -> Deckname -> [T.Text] -> S3.ObjectKey
 mkObjectKey uname dname components = S3.ObjectKey $
     presentationPrefix uname dname <> T.intercalate "/" components
 
-sanitizeDeckname :: Deckname -> T.Text
-sanitizeDeckname = T.toLower . strip . dropBadChars . unDeckname
-  where
-    strip :: T.Text -> T.Text
-    strip = T.dropAround ( == '-' )
-    dropBadChars :: T.Text -> T.Text
-    dropBadChars = T.concatMap
-      $ \case
-        c | isAscii c && isAlphaNum c -> T.singleton c
-          | c == ' ' -> T.singleton '-'
-          | otherwise -> ""
-
 fileETag :: FilePath -> IO S3.ETag
 fileETag fp =
     -- XXX: The 'show' step is very import, it's what converts the Digest to

infra/lambda.tf

@@ -21,6 +21,7 @@ resource "aws_lambda_function" "api" {
       QUEUE_NAME = "${aws_sqs_queue.presentation_deploy.name}"
       GOOGLE_PUBLIC_KEYS = "google-public-keys.json"
       FIREBASE_PROJECT_ID = "deckdeckgo-studio-beta"
+      DECKGO_PRESENTATIONS_URL = "${aws_route53_record.www_site.fqdn}"
     }
   }
 }