deckgo · nmattia · Jul 3, 2019 · Jun 12, 2019 · Jun 13, 2019 · Jun 18, 2019
diff --git a/infra/google-public-keys.json b/infra/google-public-keys.json
@@ -1,4 +1,4 @@
 {
-  "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",
-  "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"
+  "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",
+  "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"
 }
diff --git a/infra/handler/app/Test.hs b/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 "patrick@foo.com" }
+      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 "patrick@foo.com" }
-      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 ()

diff --git a/infra/handler/package.yaml b/infra/handler/package.yaml
@@ -29,6 +29,7 @@ dependencies:
     - servant-swagger
     - servant-swagger-ui
     - swagger2
+    - tagsoup
     - text
     - unliftio
     - temporary

diff --git a/infra/handler/src/DeckGo/Handler.hs b/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 -> ""
+
diff --git a/infra/handler/src/DeckGo/Presenter.hs b/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,69 @@ 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 [] deckBackgroundTags (deckDeckbackground deck))
+  t -> [t]
+
+deckBackgroundTags :: Deckbackground -> [Tag]
+deckBackgroundTags (unDeckbackground -> bg) =
+    [ TagSoup.TagOpen "div" (HMS.toList $ HMS.singleton "slot" "background")
+    ] <> TagSoup.parseTags bg <>
+    [ TagSoup.TagClose "div"
+    ]
+
+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 +176,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 +249,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