diff --git a/infra/default.nix b/infra/default.nix index 9eb67f76c..a674bbb33 100644 --- a/infra/default.nix +++ b/infra/default.nix @@ -113,16 +113,6 @@ rec function start_services() { load_pg ${pgutil.start_pg} || echo "PG start failed" - if [ ! -f .dynamodb.pid ]; then - echo "Starting dynamodb" - java \ - -Djava.library.path=${dynamoJar}/DynamoDBLocal_lib \ - -jar ${dynamoJar}/DynamoDBLocal.jar \ - -sharedDb -port 8123 & - echo $! > .dynamodb.pid - else - echo "Looks like dynamo is already running" - fi if [ ! -f .sqs.pid ]; then echo "Starting SQS" java \ @@ -148,13 +138,6 @@ rec function stop_services() { ${pgutil.stop_pg} - if [ -f .dynamodb.pid ]; then - echo "Killing dynamodb" - kill $(cat .dynamodb.pid) - rm .dynamodb.pid - else - echo "Looks like dynamodb is not running" - fi if [ -f .sqs.pid ]; then echo "Killing SQS" kill $(cat .sqs.pid) @@ -203,13 +186,6 @@ rec googleKeyUpdater = pkgs.haskellPackages.google-key-updater; - dynamoJar = pkgs.runCommand "dynamodb-jar" { buildInputs = [ pkgs.gnutar ]; } - '' - mkdir -p $out - cd $out - tar -xvf ${pkgs.sources.dynamodb} - ''; - publicKey = builtins.readFile ./public.cer; swaggerUi = pkgs.runCommand "swagger-ui" {} @@ -237,12 +213,6 @@ rec export AWS_ACCESS_KEY_ID=dummy export AWS_SECRET_ACCESS_KEY=dummy_key - # Set up DynamoDB - java \ - -Djava.library.path=${dynamoJar}/DynamoDBLocal_lib \ - -jar ${dynamoJar}/DynamoDBLocal.jar \ - -sharedDb -port 8123 & - java \ -jar ${pkgs.sources.elasticmq} & @@ -250,11 +220,6 @@ rec MINIO_SECRET_KEY=dummy_key \ minio server --address localhost:9000 $(mktemp -d) & - while ! nc -z 127.0.0.1 8123; do - echo waiting for DynamoDB - sleep 1 - done - while ! nc -z 127.0.0.1 9324; do echo waiting for SQS sleep 1 diff --git a/infra/handler/app/Test.hs b/infra/handler/app/Test.hs index 951ea5d1e..f7eca7190 100644 --- a/infra/handler/app/Test.hs +++ b/infra/handler/app/Test.hs @@ -4,14 +4,12 @@ module Main (main) where -import Control.Concurrent import Control.Lens import Control.Lens.Extras (is) import Control.Monad +import Data.List (sortOn) import Data.Monoid (First) -import Data.List.NonEmpty import DeckGo.Handler -import DeckGo.Prelude import DeckGo.Presenter import Network.HTTP.Client (newManager, defaultManagerSettings) import Network.HTTP.Types as HTTP @@ -28,7 +26,7 @@ import qualified Data.Text.IO as T import qualified Hasql.Connection as HC import qualified Hasql.Session as HS import qualified Network.AWS.Extended as AWS -import qualified Network.AWS.DynamoDB as DynamoDB +import qualified Network.AWS.S3 as S3 import qualified Network.AWS.SQS as SQS import qualified Network.HTTP.Client as HTTPClient import qualified Network.HTTP.Client.TLS as HTTPClient @@ -37,20 +35,19 @@ import qualified Network.Wai.Handler.Warp as Warp import qualified Servant.Auth.Firebase as Firebase import qualified Test.Tasty as Tasty import qualified Test.Tasty.HUnit as Tasty -import qualified Network.AWS.S3 as S3 withEnv :: (AWS.Env -> IO a) -> IO a withEnv act = do mgr <- HTTPClient.newManager HTTPClient.tlsManagerSettings { HTTPClient.managerModifyRequest = - pure . rerouteDynamoDB . rerouteSQS . rerouteS3 + pure . rerouteSQS . rerouteS3 } env <- AWS.newEnv <&> AWS.envManager .~ mgr act env withServer :: (Warp.Port -> IO a) -> IO a withServer act = - withPresURL $ withEnv $ \env -> withS3 env $ withSQS env $ withDynamoDB env $ + withPresURL $ withEnv $ \env -> withS3 env $ withSQS env $ withPristineDB $ \conn -> do putStrLn "Server environment loaded, finding port" (port, socket) <- Warp.openFreePort @@ -79,48 +76,6 @@ is' -> Bool is' prsm v = is _Just $ v ^? prsm -withDynamoDB :: AWS.Env -> IO a -> IO a -withDynamoDB env act = do - putStrLn "Deleting old DynamoDB table (if exists)" - runAWS env (AWS.send $ DynamoDB.deleteTable "Decks") >>= \case - Left e - | is' DynamoDB._ResourceNotFoundException e -> pure () - | otherwise -> error $ "Could not delete table: " <> show e - Right {} -> xif (100 * 1000) $ \f delay -> do - runAWS env (AWS.send $ DynamoDB.describeTable "Decks") >>= \case - Left e - | is' DynamoDB._TableNotFoundException e -> pure () - | is' DynamoDB._ResourceNotFoundException e -> pure () - | otherwise -> error $ "Could not describeTable: " <> show e - Right {} -> do - threadDelay delay - f (delay * 2) - putStrLn "Creating DynamoDB table" - runAWS env (AWS.send $ - DynamoDB.createTable - "Decks" - (DynamoDB.keySchemaElement "DeckId" DynamoDB.Hash :| []) - (DynamoDB.provisionedThroughput 1 1) & - DynamoDB.ctAttributeDefinitions .~ - [DynamoDB.attributeDefinition "DeckId" DynamoDB.S] - ) >>= \case - Left e -> error $ show e - Right {} -> xif (100 * 1000) $ \f delay -> do - runAWS env (AWS.send $ DynamoDB.describeTable "Decks") >>= \case - Left e -> error $ show e - Right r -> do - tst <- pure $ do - tb <- r ^. DynamoDB.drsTable - tst <- tb ^. DynamoDB.tdTableStatus - pure tst - case tst of - Just DynamoDB.TSCreating -> do - threadDelay delay - f (delay * 2) - Just DynamoDB.TSActive -> pure () - _ -> error $ "Unexpected table: " <> show r - act - withSQS :: AWS.Env -> IO a -> IO a withSQS env act = withQueueName $ do runAWS env (AWS.send $ SQS.getQueueURL ttestQueueName) >>= \case @@ -130,7 +85,6 @@ withSQS env act = withQueueName $ do Left e -> error $ "Could not delete queue: " <> show e Right {} -> pure () Left e - | is' DynamoDB._ResourceNotFoundException e -> pure () | is' SQS._QueueDoesNotExist e -> pure () | otherwise -> error $ "Could not get queue URL: " <> show e @@ -183,6 +137,8 @@ withPristineDB act = do void $ HS.run (HS.sql "DROP TABLE IF EXISTS account CASCADE") conn putStrLn "DROP TABLE IF EXISTS slide" void $ HS.run (HS.sql "DROP TABLE IF EXISTS slide") conn + putStrLn "DROP TABLE IF EXISTS deck" + void $ HS.run (HS.sql "DROP TABLE IF EXISTS deck") conn putStrLn "DROP TABLE IF EXISTS db_meta" void $ HS.run (HS.sql "DROP TABLE IF EXISTS db_meta") conn act conn @@ -199,6 +155,12 @@ main = do , Tasty.testCase "delete" testUsersDelete , Tasty.testCase "update" testUsersUpdate ] + , Tasty.testGroup "decks" + [ Tasty.testCase "create" testDecksCreate + , Tasty.testCase "update" testDecksUpdate + , Tasty.testCase "get by id" testDecksGetById + , Tasty.testCase "get all" testDecksGetAll + ] , Tasty.testGroup "slides" [ Tasty.testCase "get" testSlidesGet , Tasty.testCase "create" testSlidesCreate @@ -338,51 +300,158 @@ testUsersUpdate = withPristineDB $ \conn -> do else error "bad user" Nothing -> error "Got no users" +withDeck + :: DbInterface + -> (DeckId -> Deck -> IO ()) + -> IO () +withDeck iface act = do + let someFirebaseId = FirebaseId "foo" + someUserId = UserId someFirebaseId + someUser = User + { userFirebaseId = someFirebaseId + , userUsername = Just (Username "patrick") + } + dbCreateUser iface someUserId someUser >>= \case + Left () -> error "Encountered error" + Right () -> pure () + + let someDeckId = DeckId "bar" + someDeck = Deck + { deckSlides = [] + , deckDeckname = Deckname "Some deck!!" + , deckDeckbackground = Nothing + , deckOwnerId = someUserId + , deckAttributes = HMS.singleton "foo" "bar" + } + dbCreateDeck iface someDeckId someDeck + act someDeckId someDeck + +testDecksGetAll :: IO () +testDecksGetAll = withPristineDB $ \conn -> do + iface <- getDbInterface conn + let someFirebaseId = FirebaseId "foo" + someUserId = UserId someFirebaseId + someUser = User + { userFirebaseId = someFirebaseId + , userUsername = Just (Username "patrick") + } + dbCreateUser iface someUserId someUser >>= \case + Left () -> error "Encountered error" + Right () -> pure () + + someDecks <- forM [(0 :: Int) .. 10] $ \i -> do + let someDeckId = DeckId $ "bar-" <> tshow i + someDeck = Deck + { deckSlides = [] + , deckDeckname = Deckname $ "Some deck!! - " <> tshow i + , deckDeckbackground = Nothing + , deckOwnerId = someUserId + , deckAttributes = HMS.singleton "foo" "bar" + } + dbCreateDeck iface someDeckId someDeck + pure someDeckId + + dbGetAllDecks iface >>= \case + decks -> unless + (sortOn unDeckId (itemId <$> decks) == sortOn unDeckId someDecks) $ + error "Bad decks" + +testDecksCreate :: IO () +testDecksCreate = withPristineDB $ \conn -> do + iface <- getDbInterface conn + withDeck iface $ \someDeckId someDeck -> do + dbGetDeckById iface someDeckId >>= \case + Nothing -> error "couldn't find deck" + Just deck -> unless (deck == someDeck) $ error "Bad deck" + +testDecksGetById :: IO () +testDecksGetById = withPristineDB $ \conn -> do + iface <- getDbInterface conn + withDeck iface $ \someDeckId someDeck -> do + slides <- forM [(0 :: Int)..10] $ \i -> do + let someSlideId = SlideId $ "foo-" <> tshow i + someSlide = Slide + { slideContent = Nothing + , slideTemplate = "The template" + , slideAttributes = HMS.singleton "foo" "bar" + } + dbCreateSlide iface someSlideId someDeckId someSlide + pure someSlideId + let someDeck' = someDeck { deckSlides = slides } + dbUpdateDeck iface someDeckId someDeck' + dbGetDeckById iface someDeckId >>= \case + Nothing -> error "couldn't find deck" + Just deck -> unless (deck == someDeck') $ error $ unlines + [ "Bad deck\n" + , show someDeck' + , show deck + ] + +testDecksUpdate :: IO () +testDecksUpdate = withPristineDB $ \conn -> do + iface <- getDbInterface conn + withDeck iface $ \someDeckId someDeck -> do + let someSlideId = SlideId "foo" + someSlide = Slide + { slideContent = Nothing + , slideTemplate = "The template" + , slideAttributes = HMS.singleton "foo" "bar" + } + dbCreateSlide iface someSlideId someDeckId someSlide + + let someDeck' = someDeck { deckSlides = [ someSlideId ] } + + dbUpdateDeck iface someDeckId someDeck' + testSlidesGet :: IO () testSlidesGet = withPristineDB $ \conn -> do iface <- getDbInterface conn - let someSlideId = SlideId "foo" - someSlide = Slide - { slideContent = Nothing - , slideTemplate = "The template" - , slideAttributes = HMS.singleton "foo" "bar" - } - dbCreateSlide iface someSlideId someSlide - dbGetSlideById iface someSlideId >>= \case - Nothing -> error "couldn't find slide" - Just slide -> unless (slide == someSlide) $ error "Bad slide" + withDeck iface $ \someDeckId _someDeck -> do + let someSlideId = SlideId "foo" + someSlide = Slide + { slideContent = Nothing + , slideTemplate = "The template" + , slideAttributes = HMS.singleton "foo" "bar" + } + dbCreateSlide iface someSlideId someDeckId someSlide + dbGetSlideById iface someSlideId >>= \case + Nothing -> error "couldn't find slide" + Just slide -> unless (slide == someSlide) $ error "Bad slide" testSlidesCreate :: IO () testSlidesCreate = withPristineDB $ \conn -> do iface <- getDbInterface conn - let someSlideId = SlideId "foo" - someSlide = Slide - { slideContent = Nothing - , slideTemplate = "The template" - , slideAttributes = HMS.singleton "foo" "bar" - } - dbCreateSlide iface someSlideId someSlide + withDeck iface $ \someDeckId _someDeck -> do + let someSlideId = SlideId "foo" + someSlide = Slide + { slideContent = Nothing + , slideTemplate = "The template" + , slideAttributes = HMS.singleton "foo" "bar" + } + dbCreateSlide iface someSlideId someDeckId someSlide testSlidesUpdate :: IO () testSlidesUpdate = withPristineDB $ \conn -> do iface <- getDbInterface conn - let someSlideId = SlideId "foo" - someSlide = Slide - { slideContent = Nothing - , slideTemplate = "The template" - , slideAttributes = HMS.singleton "foo" "bar" - } - dbCreateSlide iface someSlideId someSlide - - let someOtherSlide = Slide - { slideContent = Just "Some content" - , slideTemplate = "The template" - , slideAttributes = HMS.singleton "foo" "baz" - } + withDeck iface $ \someDeckId _someDeck -> do + let someSlideId = SlideId "foo" + someSlide = Slide + { slideContent = Nothing + , slideTemplate = "The template" + , slideAttributes = HMS.singleton "foo" "bar" + } + dbCreateSlide iface someSlideId someDeckId someSlide - dbUpdateSlide iface someSlideId someOtherSlide + let someOtherSlide = Slide + { slideContent = Just "Some content" + , slideTemplate = "The template" + , slideAttributes = HMS.singleton "foo" "baz" + } - -- TODO: test result of "GET" + dbUpdateSlide iface someSlideId someOtherSlide + dbGetSlideById iface someSlideId >>= \case + Nothing -> error "couldn't find slide" + Just slide -> unless (slide == someOtherSlide) $ error "Bad slide" getTokenPath :: IO FilePath getTokenPath = @@ -418,7 +487,6 @@ testServer = withServer $ \port -> do Right [] -> pure () Right decks -> error $ "Expected 0 decks, got: " <> show decks - let someUserInfo = UserInfo { userInfoFirebaseId = someFirebaseId , userInfoEmail = Just "patrick@foo.com" } @@ -471,7 +539,7 @@ testServer = withServer $ \port -> do runClientM (decksGetDeckId' b deckId) clientEnv >>= \case Left e -> error $ "Expected decks, got error: " <> show e Right deck -> - if deck == (Item deckId newDeck) then pure () else (error $ "Expected get deck, got: " <> show deck) + if deck == newDeck then pure () else (error $ "Expected get deck, got: " <> show deck) let updatedSlide = Slide Nothing "quux" HMS.empty @@ -511,7 +579,7 @@ _usersPut' :: T.Text -> UserId -> UserInfo -> ClientM (Item UserId User) _usersDelete' :: T.Text -> UserId -> ClientM () decksGet' :: T.Text -> Maybe UserId -> ClientM [Item DeckId Deck] -decksGetDeckId' :: T.Text -> DeckId -> ClientM (Item DeckId Deck) +decksGetDeckId' :: T.Text -> DeckId -> ClientM Deck decksPostPublish' :: T.Text -> DeckId -> ClientM PresResponse decksPost' :: T.Text -> Deck -> ClientM (Item DeckId Deck) decksPut' :: T.Text -> DeckId -> Deck -> ClientM (Item DeckId Deck) @@ -544,17 +612,6 @@ slidesDelete' :: T.Text -> DeckId -> SlideId -> ClientM () ) ) = client api -rerouteDynamoDB :: HTTPClient.Request -> HTTPClient.Request -rerouteDynamoDB req = - case HTTPClient.host req of - "dynamodb.us-east-1.amazonaws.com" -> - req - { HTTPClient.host = "127.0.0.1" - , HTTPClient.port = 8123 -- TODO: read from Env - , HTTPClient.secure = False - } - _ -> req - rerouteSQS :: HTTPClient.Request -> HTTPClient.Request rerouteSQS req = case HTTPClient.host req of diff --git a/infra/handler/package.yaml b/infra/handler/package.yaml index 7d3a835c8..7664ae5ac 100644 --- a/infra/handler/package.yaml +++ b/infra/handler/package.yaml @@ -8,7 +8,6 @@ dependencies: - amazonka - amazonka-cloudfront - amazonka-core - - amazonka-dynamodb - amazonka-s3 - amazonka-sqs - base diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index 89a4360a8..0c8346ce4 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -25,7 +25,6 @@ module DeckGo.Handler where -- TODO: improve swagger description -- TODO: feed API --- TODO: double check what is returned on 200 from DynamoDB -- TODO: check permissions -- TODO: TTL on anonymous users -- TODO: enforce uniqueness on deck_name (per user) @@ -62,7 +61,6 @@ import qualified Hasql.Decoders as HD import qualified Hasql.Encoders as HE import qualified Hasql.Session as HS import qualified Network.AWS as AWS -import qualified Network.AWS.DynamoDB as DynamoDB import qualified Network.AWS.SQS as SQS import qualified Network.Wai as Wai import qualified Servant as Servant @@ -224,7 +222,7 @@ type DecksAPI = Protected :> QueryParam "owner_id" UserId :> Get '[JSON] [Item DeckId Deck] :<|> Protected :> Capture "deck_id" DeckId :> - Get '[JSON] (Item DeckId Deck) :<|> + Get '[JSON] Deck :<|> Protected :> Capture "deck_id" DeckId :> "publish" :> @@ -385,17 +383,17 @@ server env conn = serveUsers :<|> serveDecks :<|> serveSlides usersPut conn :<|> usersDelete conn serveDecks = - decksGet env :<|> - decksGetDeckId env :<|> + decksGet conn :<|> + decksGetDeckId conn :<|> decksPostPublish env conn :<|> - decksPost env :<|> - decksPut env :<|> - decksDelete env + decksPost conn :<|> + decksPut conn :<|> + decksDelete conn serveSlides = - slidesGetSlideId env conn :<|> - slidesPost env conn :<|> - slidesPut env conn :<|> - slidesDelete env conn + slidesGetSlideId conn :<|> + slidesPost conn :<|> + slidesPut conn :<|> + slidesDelete conn -- USERS @@ -412,10 +410,8 @@ usersGetStatement :: Statement () [Item UserId User] usersGetStatement = Statement sql encoder decoder True where sql = BS8.unwords - [ "SELECT account.id, account.firebase_id, username.id" + [ "SELECT account.id, account.firebase_id, account.username" , "FROM account" - , "LEFT JOIN username" - , "ON username.account = account.id" ] encoder = HE.unit decoder = HD.rowList $ @@ -441,10 +437,8 @@ usersGetUserIdStatement :: Statement UserId (Maybe (Item UserId User)) usersGetUserIdStatement = Statement sql encoder decoder True where sql = BS8.unwords - [ "SELECT account.id, account.firebase_id, username.id" + [ "SELECT account.id, account.firebase_id, account.username" , "FROM account" - , "LEFT JOIN username" - , "ON username.account = account.id" , "WHERE account.id = $1" ] encoder = contramap @@ -532,8 +526,8 @@ usersPostStatement = Statement sql encoder decoder True where sql = BS8.unwords [ "INSERT INTO account" - , "(id, firebase_id)" - , "VALUES ($1, $2)" + , "(id, firebase_id, username)" + , "VALUES ($1, $2, NULL)" , "ON CONFLICT DO NOTHING" ] encoder = @@ -543,15 +537,12 @@ usersPostStatement = Statement sql encoder decoder True contramap (unFirebaseId . userFirebaseId . view _2) (HE.param HE.text) decoder = HD.rowsAffected +-- TODO: deal with conflict error usersPostStatement' :: Statement (Username, UserId) Int64 usersPostStatement' = Statement sql encoder decoder True where sql = BS8.unwords - [ "INSERT INTO username" - , "(id, account)" - , "VALUES ($1, $2)" - , "ON CONFLICT (id) DO NOTHING" - ] + [ "UPDATE account SET username = $1 WHERE id = $2" ] encoder = contramap (unUsername . view _1) @@ -565,8 +556,7 @@ usersPostStatement'' :: Statement Username () -- TODO: check was deleted? usersPostStatement'' = Statement sql encoder decoder True where sql = BS8.unwords - [ "DELETE FROM username" - , "WHERE id = $1" + [ "UPDATE account SET username = NULL WHERE id = $1" ] encoder = contramap @@ -667,8 +657,138 @@ usersDeleteStatement = Statement sql encoder decoder True -- DECKS -decksGet :: AWS.Env -> Firebase.UserId -> Maybe UserId -> Servant.Handler [Item DeckId Deck] -decksGet env fuid mUserId = do +decksGetSession :: HS.Session [Item DeckId Deck] +decksGetSession = do + HS.statement () decksGetStatement + +decksGetStatement :: Statement () [Item DeckId Deck] +decksGetStatement = Statement sql encoder decoder True + where + sql = BS8.unwords + [ "SELECT" + , "id," + , "array(SELECT id FROM slide WHERE deck = deck.id ORDER BY index)," + , "name," + , "background," + , "owner," + , "attributes" + , "FROM deck" + ] + encoder = HE.unit + decoder = HD.rowList $ Item <$> + (DeckId <$> HD.column HD.text) <*> + ( Deck <$> + (let listArray = (HD.array . HD.dimension replicateM . HD.element) + in HD.column (listArray (SlideId <$> HD.text))) <*> + (Deckname <$> (HD.column HD.text)) <*> + ((fmap Deckbackground) <$> (HD.nullableColumn HD.text)) <*> + ((UserId . FirebaseId) <$> HD.column HD.text) <*> + HD.column (HD.jsonBytes (\bs -> + first T.pack (Aeson.eitherDecode $ BL.fromStrict bs) + )) + ) + +decksPostSession :: DeckId -> Deck -> HS.Session () +decksPostSession did d = do + liftIO $ putStrLn "Creating deck in DB" + HS.sql "BEGIN" + HS.statement (did, d) decksPostStatement + unless (deckSlides d == []) $ + error "A fresh deck cannot have slides" + HS.sql "COMMIT" + +decksPostStatement :: Statement (DeckId, Deck) () +decksPostStatement = Statement sql encoder decoder True + where + sql = BS8.unwords + [ "INSERT INTO deck" + , "(id, name, background, owner, attributes)" + , "VALUES ($1, $2, $3, $4, $5)" + ] + encoder = + contramap (unDeckId . view _1) (HE.param HE.text) <> + contramap (unDeckname . deckDeckname . view _2) (HE.param HE.text) <> + contramap + (fmap unDeckbackground . deckDeckbackground . view _2) + (HE.nullableParam HE.text) <> + contramap + (unFirebaseId . unUserId . deckOwnerId . view _2) + (HE.param HE.text) <> + contramap (Aeson.toJSON . deckAttributes . view _2) (HE.param HE.json) + decoder = HD.unit + +decksPutSession :: DeckId -> Deck -> HS.Session () +decksPutSession did d = do + liftIO $ putStrLn "Creating deck in DB" + HS.sql "BEGIN" + HS.statement (did, d) decksPutStatement + forM_ (zip (deckSlides d) [0..]) $ \(sid, idx) -> + HS.statement (sid, idx) slideReindexStatement + HS.sql "COMMIT" + +decksPutStatement :: Statement (DeckId, Deck) () +decksPutStatement = Statement sql encoder decoder True + where + sql = BS8.unwords + [ "UPDATE deck" + , "SET name = $2, background = $3, owner = $4, attributes = $5" + , "WHERE id = $1" + ] + encoder = + contramap (unDeckId . view _1) (HE.param HE.text) <> + contramap (unDeckname . deckDeckname . view _2) (HE.param HE.text) <> + contramap + (fmap unDeckbackground . deckDeckbackground . view _2) + (HE.nullableParam HE.text) <> + contramap + (unFirebaseId . unUserId . deckOwnerId . view _2) + (HE.param HE.text) <> + contramap (Aeson.toJSON . deckAttributes . view _2) (HE.param HE.json) + decoder = HD.unit + +slideReindexStatement :: Statement (SlideId, Int16 {- the slide index -}) () +slideReindexStatement = Statement sql encoder decoder True + where + sql = BS8.unwords + [ "UPDATE slide" + , "SET index = $2" + , "WHERE id = $1" + ] + encoder = + contramap (unSlideId . view _1) (HE.param HE.text) <> + contramap (view _2) (HE.param HE.int2) + decoder = HD.unit + +decksGetByIdSession :: DeckId -> HS.Session (Maybe Deck) +decksGetByIdSession did = do + liftIO $ putStrLn $ "Getting deck by id" + HS.statement did decksGetByIdStatement + +decksGetByIdStatement :: Statement DeckId (Maybe Deck) +decksGetByIdStatement = Statement sql encoder decoder True + where + sql = BS8.unwords + [ "SELECT" + , "array(SELECT id FROM slide WHERE deck = $1 ORDER BY index)," + , "name," + , "background," + , "owner," + , "attributes" + , "FROM deck WHERE id = $1" + ] + encoder = contramap unDeckId (HE.param HE.text) + decoder = HD.rowMaybe $ Deck <$> + (let listArray = (HD.array . HD.dimension replicateM . HD.element) + in HD.column (listArray (SlideId <$> HD.text))) <*> + (Deckname <$> (HD.column HD.text)) <*> + ((fmap Deckbackground) <$> (HD.nullableColumn HD.text)) <*> + ((UserId . FirebaseId) <$> HD.column HD.text) <*> + HD.column (HD.jsonBytes (\bs -> + first T.pack (Aeson.eitherDecode $ BL.fromStrict bs) + )) + +decksGet :: HC.Connection -> Firebase.UserId -> Maybe UserId -> Servant.Handler [Item DeckId Deck] +decksGet conn fuid mUserId = do userId <- case mUserId of Nothing -> do @@ -681,79 +801,26 @@ decksGet env fuid mUserId = do liftIO $ putStrLn $ unwords [ "Client asking for decks as another user", show (fuid, userId) ] Servant.throwError Servant.err403 + iface <- liftIO $ getDbInterface conn - res <- runAWS env $ AWS.send $ DynamoDB.scan "Decks" & - DynamoDB.sFilterExpression .~ Just "DeckOwnerId = :o" & - DynamoDB.sExpressionAttributeValues .~ HMS.singleton ":o" (userIdToAttributeValue userId) - - case res of - Right scanResponse -> - case sequence $ scanResponse ^. DynamoDB.srsItems <&> itemToDeck of - Nothing -> do - liftIO $ putStrLn $ "Could not parse response: " <> show scanResponse - Servant.throwError Servant.err500 - Just ids -> pure ids - Left e -> do - liftIO $ print e - Servant.throwError Servant.err500 + liftIO $ dbGetAllDecks iface --- | TODO: better errors + merge with decksGetDeckId -deckGetDeckIdDB :: AWS.Env -> DeckId -> IO (Maybe Deck) -deckGetDeckIdDB env deckId = do - res <- runAWS env $ AWS.send $ DynamoDB.getItem "Decks" & - DynamoDB.giKey .~ HMS.singleton "DeckId" (deckIdToAttributeValue deckId) - - fmap itemContent <$> case res of - Right getItemResponse -> - case getItemResponse ^. DynamoDB.girsResponseStatus of - 200 -> - case itemToDeck (getItemResponse ^. DynamoDB.girsItem) of - Nothing -> do - liftIO $ putStrLn $ "Could not parse response: " <> show getItemResponse - error "Could not parse" - Just deck -> pure (Just deck) - - 404 -> do - liftIO $ putStrLn $ "Item not found: " <> show getItemResponse - pure Nothing - s -> do - liftIO $ - putStrLn $ "Unkown response status: " <> show s <> - " in response " <> show getItemResponse - error "Unknown response status" - Left e -> do - liftIO $ print e - error "Some error" - -decksGetDeckId :: AWS.Env -> Firebase.UserId -> DeckId -> Servant.Handler (Item DeckId Deck) -decksGetDeckId env fuid deckId = do - - res <- runAWS env $ AWS.send $ DynamoDB.getItem "Decks" & - DynamoDB.giKey .~ HMS.singleton "DeckId" (deckIdToAttributeValue deckId) - - deck@Item{itemContent} <- case res of - Right getItemResponse -> do - case getItemResponse ^. DynamoDB.girsResponseStatus of - 200 -> pure () - 404 -> do - liftIO $ putStrLn $ "Item not found: " <> show getItemResponse - Servant.throwError Servant.err404 - s -> do - liftIO $ - putStrLn $ "Unkown response status: " <> show s <> - " in response " <> show getItemResponse - Servant.throwError Servant.err500 +-- TODO: auth? +decksGetDeckId + :: HC.Connection + -> Firebase.UserId + -> DeckId + -> Servant.Handler Deck +decksGetDeckId conn fuid deckId = do - case itemToDeck (getItemResponse ^. DynamoDB.girsItem) of - Nothing -> do - liftIO $ putStrLn $ "Could not parse response: " <> show getItemResponse - Servant.throwError Servant.err500 - Just deck -> pure deck - Left e -> do - liftIO $ print e - Servant.throwError Servant.err500 + iface <- liftIO $ getDbInterface conn + deck <- liftIO (dbGetDeckById iface deckId) >>= \case + Nothing -> do + liftIO $ putStrLn $ "Deck not found: " <> show deckId + Servant.throwError Servant.err404 + Just d -> pure d - let ownerId = deckOwnerId itemContent + let ownerId = deckOwnerId deck when (Firebase.unUserId fuid /= unFirebaseId (unUserId ownerId)) $ do liftIO $ putStrLn $ unwords $ @@ -762,6 +829,21 @@ decksGetDeckId env fuid deckId = do pure deck +decksDeleteSession :: DeckId -> HS.Session () +decksDeleteSession did = do + liftIO $ putStrLn $ "Deleting deck by id" + HS.statement did decksDeleteStatement + +decksDeleteStatement :: Statement DeckId () +decksDeleteStatement = Statement sql encoder decoder True + where + sql = BS8.unwords + [ "DELETE FROM deck" + , "WHERE id = $1" + ] + encoder = contramap unDeckId (HE.param HE.text) + decoder = HD.unit + data PresResponse = PresResponse T.Text instance Aeson.ToJSON PresResponse where @@ -807,11 +889,11 @@ decksPostPublish env conn _ deckId = do Servant.throwError Servant.err500 presUrl <- liftIO (getEnv "DECKGO_PRESENTATIONS_URL") - liftIO (deckGetDeckIdDB env deckId) >>= \case + iface <- liftIO $ getDbInterface conn + liftIO (dbGetDeckById iface 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" @@ -827,8 +909,12 @@ decksPostPublish env conn _ deckId = do "/" <> presentationPrefix uname dname -decksPost :: AWS.Env -> Firebase.UserId -> Deck -> Servant.Handler (Item DeckId Deck) -decksPost env fuid deck = do +decksPost + :: HC.Connection + -> Firebase.UserId + -> Deck + -> Servant.Handler (Item DeckId Deck) +decksPost conn fuid deck = do let ownerId = deckOwnerId deck @@ -839,21 +925,21 @@ decksPost env fuid deck = do deckId <- liftIO $ DeckId <$> newId - res <- runAWS env $ AWS.send $ DynamoDB.putItem "Decks" & - DynamoDB.piItem .~ deckToItem deckId deck + iface <- liftIO $ getDbInterface conn - case res of - Right {} -> pure () - Left e -> do - liftIO $ print e - Servant.throwError Servant.err500 + liftIO $ dbCreateDeck iface deckId deck pure $ Item deckId deck -decksPut :: AWS.Env -> Firebase.UserId -> DeckId -> Deck -> Servant.Handler (Item DeckId Deck) -decksPut env fuid deckId deck = do +decksPut + :: HC.Connection + -> Firebase.UserId + -> DeckId + -> Deck + -> Servant.Handler (Item DeckId Deck) +decksPut conn fuid deckId deck = do - getDeck env deckId >>= \case + getDeck conn deckId >>= \case Nothing -> do liftIO $ putStrLn $ unwords [ "Trying to PUT", show deckId, "but deck doesn't exist." ] @@ -864,34 +950,16 @@ decksPut env fuid deckId deck = do [ "Deck was PUTed", show deck, "but requester is not the owner", show fuid ] Servant.throwError Servant.err404 - res <- runAWS env $ AWS.send $ DynamoDB.updateItem "Decks" & - DynamoDB.uiUpdateExpression .~ Just - (dynamoSet $ - (if isJust (deckDeckbackground deck) - then [ Set "DeckBackground" ":b" ] - else [ Remove "DeckBackground" ]) <> - [ Set "DeckSlides" ":s" - , Set "DeckName" ":n" - , Set "DeckOwnerId" ":o" - , Set "DeckAttributes" ":a" - ]) & - DynamoDB.uiExpressionAttributeValues .~ deckToItem' deck & - DynamoDB.uiReturnValues .~ Just DynamoDB.UpdatedNew & - DynamoDB.uiKey .~ HMS.singleton "DeckId" - (deckIdToAttributeValue deckId) + iface <- liftIO $ getDbInterface conn - case res of - Right {} -> pure () - Left e -> do - liftIO $ print e - Servant.throwError Servant.err500 + liftIO $ dbUpdateDeck iface deckId deck pure $ Item deckId deck -decksDelete :: AWS.Env -> Firebase.UserId -> DeckId -> Servant.Handler () -decksDelete env fuid deckId = do +decksDelete :: HC.Connection -> Firebase.UserId -> DeckId -> Servant.Handler () +decksDelete conn fuid deckId = do - getDeck env deckId >>= \case + getDeck conn deckId >>= \case Nothing -> do liftIO $ putStrLn $ unwords [ "Trying to DELETE", show deckId, "but deck doesn't exist." ] @@ -902,74 +970,39 @@ decksDelete env fuid deckId = do [ "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" - (deckIdToAttributeValue deckId) + iface <- liftIO $ getDbInterface conn - case res of - Right {} -> pure () - Left e -> do - liftIO $ print e - Servant.throwError Servant.err500 + liftIO $ dbDeleteDeck iface deckId -- | Reads a Deck from the database. --- --- If the deck is not found, returns Nothing --- If the deck can't be parsed, throws a 500. --- If the response status is not 200, throws a 500. -getDeck :: AWS.Env -> DeckId -> Servant.Handler (Maybe Deck) -getDeck env deckId = do +getDeck :: HC.Connection -> DeckId -> Servant.Handler (Maybe Deck) +getDeck conn deckId = do - res <- runAWS env $ AWS.send $ DynamoDB.getItem "Decks" & - DynamoDB.giKey .~ HMS.singleton "DeckId" (deckIdToAttributeValue deckId) - - mItem <- case res of - Right r -> do - case - ( r ^. DynamoDB.girsResponseStatus - , itemToDeck (r ^. DynamoDB.girsItem )) of - (200, Just deck) -> pure $ Just deck - (200, Nothing) -> do - liftIO $ putStrLn $ "Could not parse response: " <> show r - Servant.throwError Servant.err500 - (404, _) -> pure Nothing - s -> do - liftIO $ - putStrLn $ "Unkown response status: " <> show s <> - " in response " <> show r - Servant.throwError Servant.err500 - Left e -> do - liftIO $ print e - Servant.throwError Servant.err500 + iface <- liftIO $ getDbInterface conn - case mItem of - Just Item{itemId = deckId', itemContent = deck} -> do - when (deckId' /= deckId) $ do - liftIO $ putStrLn $ "Mismatched deck IDs " <> show (deckId, deckId') - Servant.throwError Servant.err500 - pure $ Just deck - Nothing -> pure Nothing + liftIO $ dbGetDeckById iface deckId -- SLIDES -slidesPostSession :: SlideId -> Slide -> HS.Session () -slidesPostSession sid s = do +slidesPostSession :: SlideId -> DeckId -> Slide -> HS.Session () +slidesPostSession sid did s = do liftIO $ putStrLn "Creating slide in DB" - HS.statement (sid, s) slidesPostStatement + HS.statement (sid, did, s) slidesPostStatement -slidesPostStatement :: Statement (SlideId, Slide) () +slidesPostStatement :: Statement (SlideId, DeckId, Slide) () slidesPostStatement = Statement sql encoder decoder True where sql = BS8.unwords [ "INSERT INTO slide" - , "(id, content, template, attributes)" - , "VALUES ($1, $2, $3, $4)" + , "(id, deck, content, template, attributes)" + , "VALUES ($1, $2, $3, $4, $5)" ] encoder = contramap (unSlideId . view _1) (HE.param HE.text) <> - contramap (slideContent . view _2) (HE.nullableParam HE.text) <> - contramap (slideTemplate . view _2) (HE.param HE.text) <> - contramap (Aeson.toJSON . slideAttributes . view _2) (HE.param HE.json) + contramap (unDeckId . view _2) (HE.param HE.text) <> + contramap (slideContent . view _3) (HE.nullableParam HE.text) <> + contramap (slideTemplate . view _3) (HE.param HE.text) <> + contramap (Aeson.toJSON . slideAttributes . view _3) (HE.param HE.json) decoder = HD.unit slidesPutSession :: SlideId -> Slide -> HS.Session () @@ -993,15 +1026,14 @@ slidesPutStatement = Statement sql encoder decoder True decoder = HD.unit slidesGetSlideId - :: AWS.Env - -> HC.Connection + :: HC.Connection -> Firebase.UserId -> DeckId -> SlideId -> Servant.Handler (Item SlideId Slide) -slidesGetSlideId env conn fuid deckId slideId = do +slidesGetSlideId conn fuid deckId slideId = do - getDeck env deckId >>= \case + getDeck conn deckId >>= \case Nothing -> do liftIO $ putStrLn $ unwords [ "Trying to GET slide", show slideId, "of deck", show deckId @@ -1063,16 +1095,15 @@ slidesDeleteStatement = Statement sql encoder decoder True decoder = HD.unit slidesPost - :: AWS.Env - -> HC.Connection + :: HC.Connection -> Firebase.UserId -> DeckId - -> Slide + -> Slide -- TODO: slide index -> Servant.Handler (Item SlideId Slide) -slidesPost env conn fuid deckId slide = do +slidesPost conn fuid deckId slide = do iface <- liftIO $ getDbInterface conn - getDeck env deckId >>= \case + getDeck conn deckId >>= \case Nothing -> do liftIO $ putStrLn $ unwords [ "Trying to POST slide", show slide, "of deck", show deckId @@ -1087,23 +1118,22 @@ slidesPost env conn fuid deckId slide = do slideId <- liftIO $ SlideId <$> newId - liftIO (dbCreateSlide iface slideId slide) + liftIO (dbCreateSlide iface slideId deckId slide) pure $ Item slideId slide slidesPut - :: AWS.Env - -> HC.Connection + :: HC.Connection -> Firebase.UserId -> DeckId -> SlideId -> Slide -> Servant.Handler (Item SlideId Slide) -slidesPut env conn fuid deckId slideId slide = do +slidesPut conn fuid deckId slideId slide = do iface <- liftIO $ getDbInterface conn - getDeck env deckId >>= \case + getDeck conn deckId >>= \case Nothing -> do liftIO $ putStrLn $ unwords [ "Trying to PUT slide", show slideId, "of deck", show deckId @@ -1126,10 +1156,10 @@ slidesPut env conn fuid deckId slideId slide = do pure $ Item slideId slide -slidesDelete :: AWS.Env -> HC.Connection -> Firebase.UserId -> DeckId -> SlideId -> Servant.Handler () -slidesDelete env conn fuid deckId slideId = do +slidesDelete :: HC.Connection -> Firebase.UserId -> DeckId -> SlideId -> Servant.Handler () +slidesDelete conn fuid deckId slideId = do - getDeck env deckId >>= \case + getDeck conn deckId >>= \case Nothing -> do liftIO $ putStrLn $ unwords [ "Trying to DELETE slide", show slideId, "of deck", show deckId @@ -1151,137 +1181,6 @@ slidesDelete env conn fuid deckId slideId = do iface <- liftIO $ getDbInterface conn liftIO $ dbDeleteSlide iface slideId -------------------------------------------------------------------------------- --- DYNAMODB -------------------------------------------------------------------------------- - --- USER ATTRIBUTES - -userIdToAttributeValue :: UserId -> DynamoDB.AttributeValue -userIdToAttributeValue (UserId (FirebaseId userId)) = - DynamoDB.attributeValue & DynamoDB.avS .~ Just userId - --- DECKS - -deckToItem :: DeckId -> Deck -> HMS.HashMap T.Text DynamoDB.AttributeValue -deckToItem - deckId - Deck{deckSlides, deckDeckname, deckDeckbackground, deckOwnerId, deckAttributes} = - HMS.singleton "DeckId" (deckIdToAttributeValue deckId) <> - HMS.singleton "DeckSlides" (deckSlidesToAttributeValue deckSlides) <> - HMS.singleton "DeckName" (deckNameToAttributeValue deckDeckname) <> - (maybe - HMS.empty - (\content -> HMS.singleton "DeckBackground" - (deckBackgroundToAttributeValue content)) - deckDeckbackground) <> - HMS.singleton "DeckOwnerId" (deckOwnerIdToAttributeValue deckOwnerId) <> - HMS.singleton "DeckAttributes" - (deckAttributesToAttributeValue deckAttributes) - -deckToItem' :: Deck -> HMS.HashMap T.Text DynamoDB.AttributeValue -deckToItem' Deck{deckSlides, deckDeckname, deckDeckbackground, deckOwnerId, deckAttributes} = - HMS.singleton ":s" (deckSlidesToAttributeValue deckSlides) <> - HMS.singleton ":n" (deckNameToAttributeValue deckDeckname) <> - (maybe - HMS.empty - (HMS.singleton ":b" . deckBackgroundToAttributeValue) - deckDeckbackground) <> - HMS.singleton ":o" (deckOwnerIdToAttributeValue deckOwnerId) <> - HMS.singleton ":a" (deckAttributesToAttributeValue deckAttributes) - -itemToDeck - :: HMS.HashMap T.Text DynamoDB.AttributeValue - -> Maybe (Item DeckId Deck) -itemToDeck item = do - deckId <- HMS.lookup "DeckId" item >>= deckIdFromAttributeValue - deckSlides <- HMS.lookup "DeckSlides" item >>= deckSlidesFromAttributeValue - deckDeckname <- HMS.lookup "DeckName" item >>= deckNameFromAttributeValue - - deckDeckbackground <- case HMS.lookup "DeckBackground" item of - Nothing -> Just Nothing - Just c -> Just <$> deckBackgroundFromAttributeValue c - - deckOwnerId <- HMS.lookup "DeckOwnerId" item >>= - deckOwnerIdFromAttributeValue - deckAttributes <- HMS.lookup "DeckAttributes" item >>= - deckAttributesFromAttributeValue - pure $ Item deckId Deck{..} - --- DECK ATTRIBUTES - -deckIdToAttributeValue :: DeckId -> DynamoDB.AttributeValue -deckIdToAttributeValue (DeckId deckId) = - DynamoDB.attributeValue & DynamoDB.avS .~ Just deckId - -deckIdFromAttributeValue :: DynamoDB.AttributeValue -> Maybe DeckId -deckIdFromAttributeValue attr = DeckId <$> attr ^. DynamoDB.avS - -deckNameToAttributeValue :: Deckname -> DynamoDB.AttributeValue -deckNameToAttributeValue (Deckname deckname) = - DynamoDB.attributeValue & DynamoDB.avS .~ Just deckname - -deckNameFromAttributeValue :: DynamoDB.AttributeValue -> Maybe Deckname -deckNameFromAttributeValue attr = Deckname <$> attr ^. DynamoDB.avS - -deckBackgroundToAttributeValue :: Deckbackground -> DynamoDB.AttributeValue -deckBackgroundToAttributeValue (Deckbackground bg) = - DynamoDB.attributeValue & DynamoDB.avB .~ Just (T.encodeUtf8 bg) - -deckBackgroundFromAttributeValue :: DynamoDB.AttributeValue -> Maybe Deckbackground -deckBackgroundFromAttributeValue attr = toDeckbackground <$> attr ^. DynamoDB.avB - where - toDeckbackground = Deckbackground . T.decodeUtf8 - -deckSlidesToAttributeValue :: [SlideId] -> DynamoDB.AttributeValue -deckSlidesToAttributeValue deckSlides = - DynamoDB.attributeValue & DynamoDB.avL .~ - (slideIdToAttributeValue <$> deckSlides) - -deckSlidesFromAttributeValue :: DynamoDB.AttributeValue -> Maybe [SlideId] -deckSlidesFromAttributeValue attr = - traverse slideIdFromAttributeValue (attr ^. DynamoDB.avL) - -deckOwnerIdToAttributeValue :: UserId -> DynamoDB.AttributeValue -deckOwnerIdToAttributeValue (UserId (FirebaseId deckOwnerId)) = - DynamoDB.attributeValue & DynamoDB.avS .~ Just deckOwnerId - -deckOwnerIdFromAttributeValue :: DynamoDB.AttributeValue -> Maybe UserId -deckOwnerIdFromAttributeValue attr = - (UserId . FirebaseId) <$> attr ^. DynamoDB.avS - -deckAttributesToAttributeValue - :: HMS.HashMap T.Text T.Text - -> DynamoDB.AttributeValue -deckAttributesToAttributeValue attributes = - DynamoDB.attributeValue & DynamoDB.avM .~ - HMS.map attributeValueToAttributeValue attributes - where - attributeValueToAttributeValue :: T.Text -> DynamoDB.AttributeValue - attributeValueToAttributeValue attrValue = - DynamoDB.attributeValue & DynamoDB.avB .~ Just (T.encodeUtf8 attrValue) - -deckAttributesFromAttributeValue - :: DynamoDB.AttributeValue - -> Maybe (HMS.HashMap T.Text T.Text) -deckAttributesFromAttributeValue attr = - traverse attributeValueFromAttributeValue (attr ^. DynamoDB.avM) - where - attributeValueFromAttributeValue :: DynamoDB.AttributeValue -> Maybe T.Text - attributeValueFromAttributeValue attrValue = - T.decodeUtf8 <$> attrValue ^. DynamoDB.avB - --- SLIDES - --- SLIDE ATTRIBUTES - -slideIdToAttributeValue :: SlideId -> DynamoDB.AttributeValue -slideIdToAttributeValue (SlideId slideId) = - DynamoDB.attributeValue & DynamoDB.avS .~ Just slideId - -slideIdFromAttributeValue :: DynamoDB.AttributeValue -> Maybe SlideId -slideIdFromAttributeValue attr = SlideId <$> attr ^. DynamoDB.avS - ------------------------------------------------------------------------------- -- DATABASE ------------------------------------------------------------------------------- @@ -1292,8 +1191,15 @@ data DbInterface = DbInterface , dbCreateUser :: UserId -> User -> IO (Either () ()) , dbUpdateUser :: UserId -> User -> IO UserUpdateResult , dbDeleteUser :: UserId -> IO (Either () ()) + + , dbGetAllDecks :: IO [Item DeckId Deck] + , dbCreateDeck :: DeckId -> Deck -> IO () + , dbUpdateDeck :: DeckId -> Deck -> IO () + , dbGetDeckById :: DeckId -> IO (Maybe Deck) + , dbDeleteDeck :: DeckId -> IO () -- TODO: either () () for not found + , dbGetSlideById :: SlideId -> IO (Maybe Slide) - , dbCreateSlide :: SlideId -> Slide -> IO () + , dbCreateSlide :: SlideId -> DeckId -> Slide -> IO () , dbUpdateSlide :: SlideId -> Slide -> IO () , dbDeleteSlide :: SlideId -> IO () -- TODO: either () () for not found } @@ -1302,6 +1208,7 @@ data DbVersion = DbVersion0 | DbVersion1 | DbVersion2 + | DbVersion3 deriving stock (Enum, Bounded, Ord, Eq) -- | Migrates from ver to latest @@ -1309,6 +1216,7 @@ migrateFrom :: DbVersion -> HS.Session () migrateFrom = \frm -> do liftIO $ putStrLn $ "Migration: " <> show (dbVersionToText <$> [frm ..maxBound]) + HS.sql "BEGIN" forM_ [frm .. maxBound] $ \ver -> do migrateTo ver HS.statement (dbVersionToText ver) $ Statement @@ -1317,6 +1225,7 @@ migrateFrom = \frm -> do , "ON CONFLICT (key) DO UPDATE SET value = $1" ] ) (HE.param HE.text) HD.unit True + HS.sql "COMMIT" where -- | Migrates from (ver -1) to ver migrateTo :: DbVersion -> HS.Session () @@ -1364,6 +1273,42 @@ migrateFrom = \frm -> do , ");" ] ) HE.unit HD.unit True + DbVersion3 -> do + HS.sql "DROP TABLE IF EXISTS username" + HS.sql "DROP TABLE IF EXISTS account CASCADE" + HS.sql "DROP TABLE IF EXISTS slide" + HS.statement () $ Statement + (BS8.unwords + [ "CREATE TABLE account (" + , "id TEXT PRIMARY KEY," + , "firebase_id TEXT UNIQUE," + , "username TEXT UNIQUE NULL" + , ");" + ] + ) HE.unit HD.unit True + HS.statement () $ Statement + (BS8.unwords + [ "CREATE TABLE deck (" + , "id TEXT PRIMARY KEY," + , "name TEXT NOT NULL," + , "background TEXT NULL," + , "owner TEXT NOT NULL REFERENCES account (id)," + , "attributes JSON" + , ");" + ] + ) HE.unit HD.unit True + HS.statement () $ Statement + (BS8.unwords + [ "CREATE TABLE slide (" + , "id TEXT PRIMARY KEY," + , "deck TEXT NOT NULL REFERENCES deck (id) ON DELETE CASCADE," + , "index INT2 NULL," + , "content TEXT," -- TODO: is any of this nullable? + , "template TEXT," + , "attributes JSON" + , ");" + ] + ) HE.unit HD.unit True readDbVersion :: HS.Session (Either String (Maybe DbVersion)) readDbVersion = do @@ -1406,6 +1351,7 @@ dbVersionToText = \case DbVersion0 -> "0" DbVersion1 -> "1" DbVersion2 -> "2" + DbVersion3 -> "3" dbVersionFromText :: T.Text -> Maybe DbVersion dbVersionFromText t = @@ -1444,8 +1390,14 @@ getDbInterface conn = do -- TODO: proper return type on delete , dbDeleteUser = \uid -> Right <$> wrap (usersDeleteSession uid) + , dbGetAllDecks = wrap decksGetSession + , dbCreateDeck = \did d -> wrap (decksPostSession did d) + , dbUpdateDeck = \did d -> wrap (decksPutSession did d) + , dbGetDeckById = \did -> wrap (decksGetByIdSession did) + , dbDeleteDeck = \did -> wrap (decksDeleteSession did) + , dbGetSlideById = \sid -> wrap (slidesGetByIdSession sid) - , dbCreateSlide = \sid s -> wrap (slidesPostSession sid s) + , dbCreateSlide = \sid did s -> wrap (slidesPostSession sid did s) , dbUpdateSlide = \sid s -> wrap (slidesPutSession sid s) , dbDeleteSlide = \sid -> wrap (slidesDeleteSession sid) } @@ -1480,22 +1432,6 @@ newId = randomText 32 (['0' .. '9'] <> ['a' .. 'z']) tshow :: Show a => a -> T.Text tshow = T.pack . show -data DynamoUpdateExpr - = Set T.Text T.Text - | Remove T.Text - -dynamoSet :: [DynamoUpdateExpr] -> T.Text -dynamoSet exprs = T.unwords exprs' - where - exprs' = catMaybes [setExpr, removeExpr] - setExpr = if length sts == 0 then Nothing else Just $ - "SET " <> T.intercalate "," sts - removeExpr = if length removes == 0 then Nothing else Just $ - "REMOVE " <> T.intercalate "," removes - (sts, removes) = foldr f ([], []) exprs - f (Set l r) (ls, rs) = (ls <> [l <> " = " <> r], rs) - f (Remove t ) (ls, rs) = (ls, rs <> [t]) - -- TODO: what happens when the deckname is "-" ? presentationPrefix :: Username -> Deckname -> T.Text presentationPrefix uname dname = diff --git a/infra/handler/src/DeckGo/Presenter.hs b/infra/handler/src/DeckGo/Presenter.hs index fe39dbe6a..10d9bee84 100644 --- a/infra/handler/src/DeckGo/Presenter.hs +++ b/infra/handler/src/DeckGo/Presenter.hs @@ -17,7 +17,6 @@ import Data.Function import Data.List (foldl') import Data.Maybe import Data.String --- import Data.Time.Clock (getCurrentTime) import DeckGo.Handler import DeckGo.Prelude import System.Environment @@ -35,7 +34,6 @@ import qualified Hasql.Connection as HC import qualified Network.AWS as AWS import qualified Network.AWS.Data.Body as Body import qualified Network.AWS.S3 as S3 --- import qualified Network.AWS.CloudFront as CloudFront import qualified Network.Mime as Mime import qualified System.Directory as Dir import qualified System.IO.Temp as Temp @@ -171,10 +169,10 @@ deleteObjects' env bname okeys = -- TODO: sanitize deck name deployDeck :: AWS.Env -> HC.Connection -> DeckId -> IO () deployDeck env conn deckId = do - deckGetDeckIdDB env deckId >>= \case + iface <- liftIO $ getDbInterface conn + dbGetDeckById iface deckId >>= \case Nothing -> pure () -- TODO Just deck -> do - iface <- liftIO $ getDbInterface conn liftIO (fmap itemContent <$> dbGetUserById iface (deckOwnerId deck)) >>= \case Nothing -> pure () -- TODO Just user -> case userUsername user of diff --git a/infra/nix/sources.json b/infra/nix/sources.json index 5742db407..9021c6da1 100644 --- a/infra/nix/sources.json +++ b/infra/nix/sources.json @@ -11,12 +11,6 @@ "url": "https://github.com/deckgo/deckdeckgo-starter/archive/b52b2f0dcb4213492f37afe1d962ba6d13fd3f97.tar.gz", "url_template": "https://github.com///archive/.tar.gz" }, - "dynamodb": { - "sha256": "0hrwxg4igyll40y7l1s0icg55g247fl8cjs4rrcpjf8d7m0bb09j", - "type": "file", - "url": "https://s3.eu-central-1.amazonaws.com/dynamodb-local-frankfurt/dynamodb_local_2019-02-07.tar.gz", - "url_template": "https://github.com///archive/.tar.gz" - }, "elasticmq": { "sha256": "1cp2pmkc6gx7gr6109jlcphlky5rr6s1wj528r6hyhzdc01sjhhz", "type": "file",