From 769fcc380d9f6c7e98ed82ac409ce1e406311c93 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Fri, 10 May 2019 13:56:51 +0200 Subject: [PATCH 01/10] feat: import cleanup --- infra/handler/src/DeckGo/Handler.hs | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index 51e2140b8..029afb34c 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -27,34 +27,31 @@ module DeckGo.Handler where -- TODO: enforce uniqueness on deck_name (per user) -- TODO: return 500 on all DB errors -import Data.List (find) import Control.Lens hiding ((.=)) -import Data.Int --- import Data.Functor.Contravariant --- import Hasql.Session (Session) -import Hasql.Statement (Statement(..)) -import qualified Hasql.Session as HS -import qualified Hasql.Decoders as HD -import qualified Hasql.Encoders as HE -import qualified Hasql.Connection as HC --- import Control.Lens hiding ((.=)) import Control.Monad -import Data.Maybe import Control.Monad.Except import Data.Aeson ((.=), (.:), (.!=), (.:?)) -import qualified Data.ByteString.Char8 as BS8 +import Data.Int +import Data.List (find) +import Data.Maybe import Data.Proxy import Data.Swagger import GHC.Generics +import Hasql.Statement (Statement(..)) import Servant (Context ((:.))) import Servant.API import Servant.Auth.Firebase (Protected) import UnliftIO import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson +import qualified Data.ByteString.Char8 as BS8 import qualified Data.HashMap.Strict as HMS import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Hasql.Connection as HC +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.Wai as Wai From 3a77ebfa7c435760fb3f7e6a8a0da855127da207 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Fri, 10 May 2019 16:00:51 +0200 Subject: [PATCH 02/10] feat: unique usernames --- infra/handler/app/Test.hs | 14 +++- infra/handler/src/DeckGo/Handler.hs | 100 +++++++++++++++++++++++----- 2 files changed, 97 insertions(+), 17 deletions(-) diff --git a/infra/handler/app/Test.hs b/infra/handler/app/Test.hs index 8f4656540..c1ccfc0da 100644 --- a/infra/handler/app/Test.hs +++ b/infra/handler/app/Test.hs @@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} +module Main where + import Network.HTTP.Client (newManager, defaultManagerSettings) import Network.HTTP.Types as HTTP import Servant.API @@ -32,7 +34,7 @@ main = do runClientM usersGet' clientEnv >>= \case Left err -> error $ "Expected users, got error: " <> show err Right [] -> pure () - Right decks -> error $ "Expected 0 users, got: " <> show decks + Right users -> error $ "Expected 0 users, got: " <> show users runClientM (decksGet' b (Just someUserId)) clientEnv >>= \case Left err -> error $ "Expected decks, got error: " <> show err @@ -93,13 +95,21 @@ main = do Right decks -> if decks == [] then pure () else (error $ "Expected no decks, got: " <> show decks) - let someUser = User { userFirebaseId = someFirebaseId, userAnonymous = False } + let someUser = User + { userFirebaseId = someFirebaseId + , userUsername = Just (Username "patrick") } runClientM (usersPost' b someUser) clientEnv >>= \case Left err -> error $ "Expected user, got error: " <> show err Right (Item userId user) -> if user == someUser && userId == someUserId then pure () else (error $ "Expected same user, got: " <> show user) + -- runClientM usersGet' clientEnv >>= \case + -- Left err -> error $ "Expected users, got error: " <> show err + -- Right [(Item userId user)] -> + -- if user == someUser && userId == someUserId then pure () else (error $ "Expected same user, got: " <> show user) + -- Right users -> error $ "Expected 1 user, got: " <> show users + runClientM (usersPost' b someUser) clientEnv >>= \case Left (FailureResponse resp) -> if HTTP.statusCode (responseStatusCode resp) == 409 then pure () else diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index 029afb34c..c93a36fa2 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -27,6 +27,7 @@ module DeckGo.Handler where -- TODO: enforce uniqueness on deck_name (per user) -- TODO: return 500 on all DB errors +import Control.Applicative import Control.Lens hiding ((.=)) import Control.Monad import Control.Monad.Except @@ -104,7 +105,7 @@ newtype Username = Username { unUsername :: T.Text } data User = User { userFirebaseId :: FirebaseId - , userAnonymous :: Bool + , userUsername :: Maybe Username } deriving (Show, Eq) newtype UserId = UserId { unUserId :: FirebaseId } @@ -134,14 +135,23 @@ newtype FirebaseId = FirebaseId { unFirebaseId :: T.Text } instance FromJSONObject User where parseJSONObject = \obj -> User - -- potentially return "error exists" + user object <$> obj .: "firebase_uid" - <*> obj .: "anonymous" + <*> ( + (do + True <- obj .: "anonymous" + (Nothing :: Maybe Username) <- obj .: "username" + pure Nothing + ) <|> (do + False <- obj .: "anonymous" + obj .: "username" + ) + ) instance ToJSONObject User where toJSONObject user = HMS.fromList [ "firebase_uid" .= userFirebaseId user - , "anonymous" .= userAnonymous user + , "anonymous" .= isNothing (userUsername user) + , "username" .= userUsername user ] instance Aeson.FromJSON User where @@ -363,7 +373,7 @@ usersGetStatement = Statement sql encoder decoder True ((UserId . FirebaseId) <$> HD.column HD.text) <*> ( User <$> (FirebaseId <$> HD.column HD.text) <*> - HD.column HD.bool + HD.nullableColumn (Username <$> HD.text) ) usersGetUserId :: HC.Connection -> UserId -> Servant.Handler (Item UserId User) @@ -389,7 +399,7 @@ usersGetUserIdStatement = Statement sql encoder decoder True ((UserId . FirebaseId) <$> HD.column HD.text) <*> ( User <$> (FirebaseId <$> HD.column HD.text) <*> - HD.column HD.bool + HD.nullableColumn (Username <$> HD.text) ) usersPost :: HC.Connection -> Firebase.UserId -> User -> Servant.Handler (Item UserId User) @@ -409,13 +419,30 @@ usersPost conn fuid user = do usersPostSession :: UserId -> User -> HS.Session (Either () ()) usersPostSession uid u = do + HS.sql "BEGIN" liftIO $ putStrLn "Creating user in DB" HS.statement (uid,u) usersPostStatement >>= \case 1 -> do liftIO $ putStrLn "User was created" - pure $ Right () + case userUsername u of + Just uname -> do + liftIO $ putStrLn "Creating username" + HS.statement (uname, uid) usersPostStatement' >>= \case + 1 -> do + liftIO $ putStrLn "User created successfully" + HS.sql "COMMIT" + pure $ Right () + _ -> do + liftIO $ putStrLn "Couldn't create username" + HS.sql "ROLLBACK" + pure $ Left () + Nothing -> do + liftIO $ putStrLn "No username" + HS.sql "COMMIT" + pure $ Right () _ -> do liftIO $ putStrLn "Couldn't create exactly one user" + HS.sql "ROLLBACK" pure $ Left () usersPostStatement :: Statement (UserId, User) Int64 @@ -423,16 +450,33 @@ usersPostStatement = Statement sql encoder decoder True where sql = BS8.unwords [ "INSERT INTO account" - , "(id, firebase_id, anonymous)" - , "VALUES ($1, $2, $3)" + , "(id, firebase_id)" + , "VALUES ($1, $2)" , "ON CONFLICT DO NOTHING" ] encoder = contramap (unFirebaseId . unUserId . view _1) (HE.param HE.text) <> - contramap (unFirebaseId . userFirebaseId . view _2) (HE.param HE.text) <> - contramap (userAnonymous . view _2) (HE.param HE.bool) + contramap (unFirebaseId . userFirebaseId . view _2) (HE.param HE.text) + decoder = HD.rowsAffected + +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" + ] + encoder = + contramap + (unUsername . view _1) + (HE.param HE.text) <> + contramap + (unFirebaseId . unUserId . view _2) + (HE.param HE.text) decoder = HD.rowsAffected usersPut :: HC.Connection -> Firebase.UserId -> UserId -> User -> Servant.Handler (Item UserId User) @@ -455,8 +499,6 @@ usersPut conn fuid userId user = do liftIO $ print e Servant.throwError Servant.err500 - -- pure $ Item userId user - usersPutSession :: UserId -> User -> HS.Session () usersPutSession uid u = do HS.statement (uid,u) usersPutStatement @@ -464,14 +506,13 @@ usersPutSession uid u = do usersPutStatement :: Statement (UserId, User) () usersPutStatement = Statement sql encoder decoder True where - -- TODO: make sure firebase_id is unique sql = "UPDATE account SET firebase_id = $2, anonymous = $3 WHERE id = $1" encoder = contramap (unFirebaseId . unUserId . view _1) (HE.param HE.text) <> contramap (unFirebaseId . userFirebaseId . view _2) (HE.param HE.text) <> - contramap (userAnonymous . view _2) (HE.param HE.bool) + contramap (fmap unUsername . userUsername . view _2) (HE.nullableParam HE.text) decoder = HD.unit -- TODO: affected rows usersDelete :: HC.Connection -> Firebase.UserId -> UserId -> Servant.Handler () @@ -1038,6 +1079,7 @@ data DbInterface = DbInterface data DbVersion = DbVersion0 + | DbVersion1 deriving stock (Enum, Bounded, Ord, Eq) -- | Migrates from ver to latest @@ -1062,6 +1104,33 @@ migrateFrom = \ver -> forM_ [ver .. maxBound] migrateTo [ "INSERT INTO db_meta (key, value) VALUES ('version', $1)" ] ) (HE.param HE.text) HD.unit True + ver@DbVersion1 -> do + HS.statement () $ Statement + (BS8.unwords + [ "DROP TABLE IF EXISTS account" + ] + ) HE.unit HD.unit True + HS.statement () $ Statement + (BS8.unwords + [ "CREATE TABLE account (" + , "id TEXT UNIQUE NOT NULL," + , "firebase_id TEXT UNIQUE NOT NULL" + , ");" + ] + ) HE.unit HD.unit True + HS.statement () $ Statement + (BS8.unwords + [ "CREATE TABLE username (" + , "id TEXT UNIQUE NOT NULL," + , "account TEXT REFERENCES account (id) ON DELETE CASCADE UNIQUE NOT NULL" + , ");" + ] + ) HE.unit HD.unit True + HS.statement (dbVersionToText ver) $ Statement + (BS8.unwords + [ "UPDATE db_meta SET value = $1 WHERE key = 'version'" + ] + ) (HE.param HE.text) HD.unit True readDbVersion :: HS.Session (Either String (Maybe DbVersion)) readDbVersion = do @@ -1103,6 +1172,7 @@ latestDbVersion = maxBound dbVersionToText :: DbVersion -> T.Text dbVersionToText = \case DbVersion0 -> "0" + DbVersion1 -> "1" dbVersionFromText :: T.Text -> Maybe DbVersion dbVersionFromText t = From 2d3976b1b62b913b344a315c88ffc48f84f0096b Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Fri, 10 May 2019 17:02:33 +0200 Subject: [PATCH 03/10] feat: spawn test server from test suite --- infra/default.nix | 13 +---- infra/handler/app/Server.hs | 5 +- infra/handler/app/Test.hs | 97 ++++++++++++++++++++++++++++++++++--- infra/handler/package.yaml | 6 +++ infra/nix/default.nix | 3 +- infra/nix/sources.json | 6 +++ 6 files changed, 110 insertions(+), 20 deletions(-) diff --git a/infra/default.nix b/infra/default.nix index be9dd6043..9f85decd5 100644 --- a/infra/default.nix +++ b/infra/default.nix @@ -97,21 +97,12 @@ rec ${pgutil.start_pg} - # Start server with fs redirect for getProtocolByName + echo "Running tests" NIX_REDIRECTS=/etc/protocols=${pkgs.iana-etc}/etc/protocols \ LD_PRELOAD="${pkgs.libredirect}/lib/libredirect.so" \ GOOGLE_PUBLIC_KEYS="${pkgs.writeText "google-x509" (builtins.toJSON googleResp)}" \ FIREBASE_PROJECT_ID="my-project-id" \ - ${handler}/bin/server & - - while ! nc -z 127.0.0.1 8080; do - echo waiting for server - sleep 1 - done - - echo "Running tests" - ${handler}/bin/test ${./token} - + TEST_TOKEN_PATH=${./token} ${handler}/bin/test echo "Tests were run" touch $out diff --git a/infra/handler/app/Server.hs b/infra/handler/app/Server.hs index 4c39f6b55..713afeb96 100644 --- a/infra/handler/app/Server.hs +++ b/infra/handler/app/Server.hs @@ -27,8 +27,11 @@ main = do } conn <- getPostgresqlConnection env <- Aws.newEnv Aws.Discover <&> Aws.envManager .~ mgr + + (port, socket) <- Warp.openFreePort + let warpSettings = Warp.setPort port $ Warp.defaultSettings settings <- getFirebaseSettings - Warp.run 8080 $ DeckGo.Handler.application settings env conn + Warp.runSettingsSocket warpSettings socket $ DeckGo.Handler.application settings env conn getFirebaseSettings :: IO Firebase.FirebaseLoginSettings getFirebaseSettings = do diff --git a/infra/handler/app/Test.hs b/infra/handler/app/Test.hs index c1ccfc0da..f0980057d 100644 --- a/infra/handler/app/Test.hs +++ b/infra/handler/app/Test.hs @@ -3,25 +3,67 @@ module Main where +import Control.Lens +import DeckGo.Handler import Network.HTTP.Client (newManager, defaultManagerSettings) import Network.HTTP.Types as HTTP import Servant.API import Servant.Client -import DeckGo.Handler +import System.Environment +import System.Environment (getEnv) +import UnliftIO +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.HashMap.Strict as HMS import qualified Data.Text as T import qualified Data.Text.IO as T -import qualified Data.HashMap.Strict as HMS -import System.Environment (getArgs) +import qualified Hasql.Connection as Hasql +import qualified Network.AWS as Aws +import qualified Network.HTTP.Client as HTTPClient +import qualified Network.HTTP.Client.TLS as HTTPClient +import qualified Network.Socket.Wait as Socket +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 + +withServer :: (Warp.Port -> IO a) -> IO a +withServer act = do + mgr <- HTTPClient.newManager HTTPClient.tlsManagerSettings + { HTTPClient.managerModifyRequest = + pure . rerouteDynamoDB + } + conn <- getPostgresqlConnection + env <- Aws.newEnv Aws.Discover <&> Aws.envManager .~ mgr + + (port, socket) <- Warp.openFreePort + let warpSettings = Warp.setPort port $ Warp.defaultSettings + settings <- getFirebaseSettings + race + (Warp.runSettingsSocket warpSettings socket $ DeckGo.Handler.application settings env conn) + (do + Socket.wait "localhost" port + act port + ) >>= \case + Left () -> error "Server returned" + Right a -> pure a main :: IO () -main = do - [p] <- getArgs +main = Tasty.defaultMain $ Tasty.testCase "foo" main' + +getTokenPath :: IO FilePath +getTokenPath = + lookupEnv "TEST_TOKEN_PATH" >>= \case + Just tpath -> pure tpath + Nothing -> pure "./token" - b <- T.readFile p +main' :: IO () +main' = withServer $ \port -> do + b <- T.readFile =<< getTokenPath manager' <- newManager defaultManagerSettings - let clientEnv = mkClientEnv manager' (BaseUrl Http "localhost" 8080 "") + let clientEnv = mkClientEnv manager' (BaseUrl Http "localhost" port "") let someFirebaseId = FirebaseId "the-uid" -- from ./token let someUserId = UserId someFirebaseId let someDeck = Deck @@ -158,3 +200,44 @@ slidesDelete' :: T.Text -> DeckId -> SlideId -> ClientM () slidesDelete' ) ) = 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 = 8000 -- TODO: read from Env + , HTTPClient.secure = False + } + _ -> req + +getFirebaseSettings :: IO Firebase.FirebaseLoginSettings +getFirebaseSettings = do + pkeys <- getEnv "GOOGLE_PUBLIC_KEYS" + pid <- getEnv "FIREBASE_PROJECT_ID" + keyMap <- Aeson.decodeFileStrict pkeys >>= \case + Nothing -> error "Could not decode key file" + Just keyMap -> pure keyMap + pure Firebase.FirebaseLoginSettings + { Firebase.firebaseLoginProjectId = Firebase.ProjectId (T.pack pid) + , Firebase.firebaseLoginGetKeys = pure keyMap + } + +getPostgresqlConnection :: IO Hasql.Connection +getPostgresqlConnection = do + user <- getEnv "PGUSER" + password <- getEnv "PGPASSWORD" + host <- getEnv "PGHOST" + db <- getEnv "PGDATABASE" + port <- getEnv "PGPORT" + Hasql.acquire ( + Hasql.settings + (BS8.pack host) + (read port) + (BS8.pack user) + (BS8.pack password) + (BS8.pack db) + ) >>= \case + Left e -> error (show e) + Right c -> pure c diff --git a/infra/handler/package.yaml b/infra/handler/package.yaml index 7e8112c2a..701caf4e6 100644 --- a/infra/handler/package.yaml +++ b/infra/handler/package.yaml @@ -68,4 +68,10 @@ executables: dependencies: - deckdeckgo-handler - http-client + - http-client-tls + - lens + - port-utils - servant-client + - tasty + - tasty-hunit + - warp diff --git a/infra/nix/default.nix b/infra/nix/default.nix index f0ebadfb6..29f34f546 100644 --- a/infra/nix/default.nix +++ b/infra/nix/default.nix @@ -56,7 +56,8 @@ with rec mkPackage "deckdeckgo-handler" ../handler // ( mkPackage "wai-lambda" wai-lambda.wai-lambda-source ) // ( mkPackage "firebase-login" ../firebase-login ) // - { jose = super.callCabal2nix "jose" sources.hs-jose {}; } ; + { jose = super.callCabal2nix "jose" sources.hs-jose {}; } // + { port-utils = super.callCabal2nix "port-utils" sources.port-utils {}; } ; }; normalHaskellPackages = pkgsStatic.pkgsMusl.haskellPackages.override (haskellOverride true); diff --git a/infra/nix/sources.json b/infra/nix/sources.json index 868480f8c..8136e7807 100644 --- a/infra/nix/sources.json +++ b/infra/nix/sources.json @@ -20,6 +20,12 @@ "description": "Nixpkgs/NixOS branches that track the Nixpkgs/NixOS channels", "rev": "88ae8f7d55efa457c95187011eb410d097108445" }, + "port-utils": { + "url": "http://hackage.haskell.org/package/port-utils-0.2.1.0/port-utils-0.2.1.0.tar.gz", + "url_template": "http://hackage.haskell.org/package/port-utils-0.2.1.0/port-utils-0.2.1.0.tar.gz", + "type": "tarball", + "sha256": "1vfmm8mmkmfffgza64h6qz4ibniibqdr8mj452ikp1xmvv6m8qm9" + }, "dynamodb": { "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", From d5e0d655a92ba74ae57c3f929f99e418736b6ea1 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Fri, 10 May 2019 18:29:28 +0200 Subject: [PATCH 04/10] fix: get users and usernames --- infra/handler/app/Server.hs | 75 ------------------ infra/handler/app/Test.hs | 117 ++++++++++++++++++++++------ infra/handler/package.yaml | 9 --- infra/handler/src/DeckGo/Handler.hs | 17 +++- 4 files changed, 106 insertions(+), 112 deletions(-) delete mode 100644 infra/handler/app/Server.hs diff --git a/infra/handler/app/Server.hs b/infra/handler/app/Server.hs deleted file mode 100644 index 713afeb96..000000000 --- a/infra/handler/app/Server.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} - -module Main where - -import UnliftIO -import Control.Lens -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Char8 as BS8 -import qualified Network.HTTP.Client as HTTPClient -import qualified Network.HTTP.Client.TLS as HTTPClient -import qualified Network.AWS as Aws -import qualified DeckGo.Handler -import qualified Network.Wai.Handler.Warp as Warp -import qualified Hasql.Connection as Hasql -import qualified Servant.Auth.Firebase as Firebase -import qualified Data.Text as T -import System.Environment (getEnv) - -main :: IO () -main = do - hSetBuffering stdin LineBuffering - hSetBuffering stdout LineBuffering - mgr <- HTTPClient.newManager HTTPClient.tlsManagerSettings - { HTTPClient.managerModifyRequest = - pure . rerouteDynamoDB - } - conn <- getPostgresqlConnection - env <- Aws.newEnv Aws.Discover <&> Aws.envManager .~ mgr - - (port, socket) <- Warp.openFreePort - let warpSettings = Warp.setPort port $ Warp.defaultSettings - settings <- getFirebaseSettings - Warp.runSettingsSocket warpSettings socket $ DeckGo.Handler.application settings env conn - -getFirebaseSettings :: IO Firebase.FirebaseLoginSettings -getFirebaseSettings = do - pkeys <- getEnv "GOOGLE_PUBLIC_KEYS" - pid <- getEnv "FIREBASE_PROJECT_ID" - keyMap <- Aeson.decodeFileStrict pkeys >>= \case - Nothing -> error "Could not decode key file" - Just keyMap -> pure keyMap - pure Firebase.FirebaseLoginSettings - { Firebase.firebaseLoginProjectId = Firebase.ProjectId (T.pack pid) - , Firebase.firebaseLoginGetKeys = pure keyMap - } - -getPostgresqlConnection :: IO Hasql.Connection -getPostgresqlConnection = do - user <- getEnv "PGUSER" - password <- getEnv "PGPASSWORD" - host <- getEnv "PGHOST" - db <- getEnv "PGDATABASE" - port <- getEnv "PGPORT" - Hasql.acquire ( - Hasql.settings - (BS8.pack host) - (read port) - (BS8.pack user) - (BS8.pack password) - (BS8.pack db) - ) >>= \case - Left e -> error (show e) - Right c -> pure c - -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 = 8000 - , HTTPClient.secure = False - } - _ -> req diff --git a/infra/handler/app/Test.hs b/infra/handler/app/Test.hs index f0980057d..3acc71b4d 100644 --- a/infra/handler/app/Test.hs +++ b/infra/handler/app/Test.hs @@ -4,6 +4,7 @@ module Main where import Control.Lens +import Control.Monad import DeckGo.Handler import Network.HTTP.Client (newManager, defaultManagerSettings) import Network.HTTP.Types as HTTP @@ -17,7 +18,8 @@ import qualified Data.ByteString.Char8 as BS8 import qualified Data.HashMap.Strict as HMS import qualified Data.Text as T import qualified Data.Text.IO as T -import qualified Hasql.Connection as Hasql +import qualified Hasql.Connection as HC +import qualified Hasql.Session as HS import qualified Network.AWS as Aws import qualified Network.HTTP.Client as HTTPClient import qualified Network.HTTP.Client.TLS as HTTPClient @@ -33,23 +35,95 @@ withServer act = do { HTTPClient.managerModifyRequest = pure . rerouteDynamoDB } + withPristineDB $ \(conn, _iface) -> do + env <- Aws.newEnv Aws.Discover <&> Aws.envManager .~ mgr + + (port, socket) <- Warp.openFreePort + let warpSettings = Warp.setPort port $ Warp.defaultSettings + settings <- getFirebaseSettings + race + (Warp.runSettingsSocket warpSettings socket $ DeckGo.Handler.application settings env conn) + (do + Socket.wait "localhost" port + act port + ) >>= \case + Left () -> error "Server returned" + Right a -> pure a + +withPristineDB :: ((HC.Connection, DbInterface) -> IO a) -> IO a +withPristineDB act = do conn <- getPostgresqlConnection - env <- Aws.newEnv Aws.Discover <&> Aws.envManager .~ mgr - - (port, socket) <- Warp.openFreePort - let warpSettings = Warp.setPort port $ Warp.defaultSettings - settings <- getFirebaseSettings - race - (Warp.runSettingsSocket warpSettings socket $ DeckGo.Handler.application settings env conn) - (do - Socket.wait "localhost" port - act port - ) >>= \case - Left () -> error "Server returned" - Right a -> pure a + void $ HS.run (HS.sql "DROP TABLE IF EXISTS username") conn + void $ HS.run (HS.sql "DROP TABLE IF EXISTS account") conn + void $ HS.run (HS.sql "DROP TABLE IF EXISTS db_meta") conn + iface <- getDbInterface conn + act (conn, iface) main :: IO () -main = Tasty.defaultMain $ Tasty.testCase "foo" main' +main = do + setEnv "TASTY_NUM_THREADS" "1" + Tasty.defaultMain $ Tasty.testGroup "tests" + [ Tasty.testGroup "db" + [ Tasty.testCase "users get" testUsersGet + , Tasty.testCase "users create" testUsersCreate + , Tasty.testCase "users get by id" testUsersGetByUserId + ] + , Tasty.testCase "foo" main' + ] + +testUsersGet :: IO () +testUsersGet = withPristineDB $ \(_, iface) -> do + dbGetAllUsers iface >>= \case + [] -> pure () + users -> error $ "Expected no users, got: " <> show users + + 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 () + + dbGetAllUsers iface >>= \case + [Item userId user] -> + if userId == someUserId && user == someUser + then pure () + else error "bad user" + users -> error $ "Expected no users, got: " <> show users + +testUsersGetByUserId :: IO () +testUsersGetByUserId = withPristineDB $ \(_, iface) -> 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 () + + dbGetUserById iface someUserId >>= \case + Just (Item userId user) -> + if userId == someUserId && user == someUser + then pure () + else error "bad user" + Nothing -> error "Got no users" + +testUsersCreate :: IO () +testUsersCreate = withPristineDB $ \(_, iface) -> 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 () getTokenPath :: IO FilePath getTokenPath = @@ -146,12 +220,6 @@ main' = withServer $ \port -> do Right (Item userId user) -> if user == someUser && userId == someUserId then pure () else (error $ "Expected same user, got: " <> show user) - -- runClientM usersGet' clientEnv >>= \case - -- Left err -> error $ "Expected users, got error: " <> show err - -- Right [(Item userId user)] -> - -- if user == someUser && userId == someUserId then pure () else (error $ "Expected same user, got: " <> show user) - -- Right users -> error $ "Expected 1 user, got: " <> show users - runClientM (usersPost' b someUser) clientEnv >>= \case Left (FailureResponse resp) -> if HTTP.statusCode (responseStatusCode resp) == 409 then pure () else @@ -159,7 +227,6 @@ main' = withServer $ \port -> do Left err -> error $ "Expected 409, got error: " <> show err Right item -> error $ "Expected failure, got success: " <> show item - -- TODO: test that creating user with token that has different user as sub -- fails @@ -224,15 +291,15 @@ getFirebaseSettings = do , Firebase.firebaseLoginGetKeys = pure keyMap } -getPostgresqlConnection :: IO Hasql.Connection +getPostgresqlConnection :: IO HC.Connection getPostgresqlConnection = do user <- getEnv "PGUSER" password <- getEnv "PGPASSWORD" host <- getEnv "PGHOST" db <- getEnv "PGDATABASE" port <- getEnv "PGPORT" - Hasql.acquire ( - Hasql.settings + HC.acquire ( + HC.settings (BS8.pack host) (read port) (BS8.pack user) diff --git a/infra/handler/package.yaml b/infra/handler/package.yaml index 701caf4e6..3c5c53c51 100644 --- a/infra/handler/package.yaml +++ b/infra/handler/package.yaml @@ -54,15 +54,6 @@ executables: - servant-swagger - servant-swagger-ui - server: - main: app/Server.hs - dependencies: - - deckdeckgo-handler - - warp - - http-client - - http-client-tls - - lens - test: main: app/Test.hs dependencies: diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index c93a36fa2..744384788 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -354,7 +354,7 @@ server env conn = serveUsers :<|> serveDecks :<|> serveSlides -- USERS -usersGet :: HC.Connection -> Servant.Handler [Item UserId User] +usersGet :: MonadIO io => HC.Connection -> io [Item UserId User] usersGet conn = do iface <- liftIO $ getDbInterface conn liftIO $ dbGetAllUsers iface -- TODO: to Servant err500 on error @@ -366,7 +366,12 @@ usersGetSession = do usersGetStatement :: Statement () [Item UserId User] usersGetStatement = Statement sql encoder decoder True where - sql = "SELECT * FROM account" + sql = BS8.unwords + [ "SELECT account.id, account.firebase_id, username.id" + , "FROM account" + , "LEFT JOIN username" + , "ON username.account = account.id" + ] encoder = HE.unit decoder = HD.rowList $ Item <$> @@ -390,7 +395,13 @@ usersGetUserIdSession userId = do usersGetUserIdStatement :: Statement UserId (Maybe (Item UserId User)) usersGetUserIdStatement = Statement sql encoder decoder True where - sql = "SELECT * FROM account WHERE id = $1" + sql = BS8.unwords + [ "SELECT account.id, account.firebase_id, username.id" + , "FROM account" + , "LEFT JOIN username" + , "ON username.account = account.id" + , "WHERE account.id = $1" + ] encoder = contramap (unFirebaseId . unUserId) (HE.param HE.text) From 6a03bf71e92c69f85d8d4f50c35788c9f16eaa0b Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Fri, 10 May 2019 18:35:47 +0200 Subject: [PATCH 05/10] feat: user delete test --- infra/handler/app/Test.hs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/infra/handler/app/Test.hs b/infra/handler/app/Test.hs index 3acc71b4d..c18261a5c 100644 --- a/infra/handler/app/Test.hs +++ b/infra/handler/app/Test.hs @@ -67,6 +67,7 @@ main = do [ Tasty.testCase "users get" testUsersGet , Tasty.testCase "users create" testUsersCreate , Tasty.testCase "users get by id" testUsersGetByUserId + , Tasty.testCase "users delete" testUsersDelete ] , Tasty.testCase "foo" main' ] @@ -113,6 +114,22 @@ testUsersGetByUserId = withPristineDB $ \(_, iface) -> do else error "bad user" Nothing -> error "Got no users" +testUsersDelete :: IO () +testUsersDelete = withPristineDB $ \(_, iface) -> 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 () + + dbDeleteUser iface someUserId >>= \case + Left () -> error "couldn't delete" + Right () -> pure () + testUsersCreate :: IO () testUsersCreate = withPristineDB $ \(_, iface) -> do let someFirebaseId = FirebaseId "foo" From 70688fd64ef7e60f910ebf71fabec49db5fb6271 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Fri, 10 May 2019 19:04:05 +0200 Subject: [PATCH 06/10] fix: correctly handle user updates --- infra/handler/app/Test.hs | 30 ++++++++++++ infra/handler/src/DeckGo/Handler.hs | 72 +++++++++++++++++++++-------- infra/shell.nix | 4 ++ 3 files changed, 87 insertions(+), 19 deletions(-) diff --git a/infra/handler/app/Test.hs b/infra/handler/app/Test.hs index c18261a5c..49fcf6a8f 100644 --- a/infra/handler/app/Test.hs +++ b/infra/handler/app/Test.hs @@ -68,6 +68,7 @@ main = do , Tasty.testCase "users create" testUsersCreate , Tasty.testCase "users get by id" testUsersGetByUserId , Tasty.testCase "users delete" testUsersDelete + , Tasty.testCase "users update" testUsersUpdate ] , Tasty.testCase "foo" main' ] @@ -142,6 +143,35 @@ testUsersCreate = withPristineDB $ \(_, iface) -> do Left () -> error "Encountered error" Right () -> pure () +testUsersUpdate :: IO () +testUsersUpdate = withPristineDB $ \(_, iface) -> 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 someUser' = User + { userFirebaseId = someFirebaseId + , userUsername = Just (Username "joseph") + } + + dbUpdateUser iface someUserId someUser' >>= \case + UserUpdateOk -> pure () + e -> error $ "encountered error:" <> show e + + dbGetUserById iface someUserId >>= \case + Just (Item userId user) -> + if userId == someUserId && user == someUser' + then pure () + else error "bad user" + Nothing -> error "Got no users" + getTokenPath :: IO FilePath getTokenPath = lookupEnv "TEST_TOKEN_PATH" >>= \case diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index 744384788..999f67746 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -490,6 +490,19 @@ usersPostStatement' = Statement sql encoder decoder True (HE.param HE.text) decoder = HD.rowsAffected +usersPostStatement'' :: Statement Username () -- TODO: check was deleted? +usersPostStatement'' = Statement sql encoder decoder True + where + sql = BS8.unwords + [ "DELETE FROM username" + , "WHERE id = $1" + ] + encoder = + contramap + (unUsername) + (HE.param HE.text) + decoder = HD.unit + usersPut :: HC.Connection -> Firebase.UserId -> UserId -> User -> Servant.Handler (Item UserId User) usersPut conn fuid userId user = do @@ -505,26 +518,47 @@ usersPut conn fuid userId user = do iface <- liftIO $ getDbInterface conn liftIO (dbUpdateUser iface userId user) >>= \case - Right () -> pure $ Item userId user -- TODO: check # of affected rows - Left e -> do -- TODO: handle not found et al. + UserUpdateOk -> pure $ Item userId user -- TODO: check # of affected rows + e -> do -- TODO: handle not found et al. liftIO $ print e - Servant.throwError Servant.err500 + Servant.throwError Servant.err400 -usersPutSession :: UserId -> User -> HS.Session () -usersPutSession uid u = do - HS.statement (uid,u) usersPutStatement +data UserUpdateResult + = UserUpdateOk + | UserUpdateNotExist + | UserUpdateClash + deriving Show -usersPutStatement :: Statement (UserId, User) () -usersPutStatement = Statement sql encoder decoder True - where - sql = "UPDATE account SET firebase_id = $2, anonymous = $3 WHERE id = $1" - encoder = - contramap - (unFirebaseId . unUserId . view _1) - (HE.param HE.text) <> - contramap (unFirebaseId . userFirebaseId . view _2) (HE.param HE.text) <> - contramap (fmap unUsername . userUsername . view _2) (HE.nullableParam HE.text) - decoder = HD.unit -- TODO: affected rows +usersPutSession :: UserId -> User -> HS.Session UserUpdateResult +usersPutSession uid u = do + HS.sql "BEGIN" + usersGetUserIdSession uid >>= \case + Nothing -> do + HS.sql "ROLLBACK" + pure UserUpdateNotExist + + -- XXX: no handling of updating firebase id + Just (Item _ oldUser) -> case (userUsername oldUser, userUsername u) of + (Nothing, Nothing) -> do + HS.sql "ROLLBACK" -- doesn't matter if rollback or commit + pure UserUpdateOk + (oldUname, newUname) -> do + case oldUname of + Nothing -> pure () + Just uname -> do + HS.statement uname usersPostStatement'' + case newUname of + Nothing -> do + HS.sql "COMMIT" + pure UserUpdateOk + Just uname -> do + HS.statement (uname, uid) usersPostStatement' >>= \case + 1 -> do + HS.sql "COMMIT" + pure UserUpdateOk + 0 -> do + HS.sql "ROLLBACK" + pure UserUpdateClash usersDelete :: HC.Connection -> Firebase.UserId -> UserId -> Servant.Handler () usersDelete conn fuid userId = do @@ -1084,7 +1118,7 @@ data DbInterface = DbInterface { dbGetAllUsers :: IO [Item UserId User] , dbGetUserById :: UserId -> IO (Maybe (Item UserId User)) , dbCreateUser :: UserId -> User -> IO (Either () ()) - , dbUpdateUser :: UserId -> User -> IO (Either () ()) + , dbUpdateUser :: UserId -> User -> IO UserUpdateResult , dbDeleteUser :: UserId -> IO (Either () ()) } @@ -1209,7 +1243,7 @@ getDbInterface conn = do { dbGetAllUsers = wrap usersGetSession , dbGetUserById = \uid -> wrap (usersGetUserIdSession uid) , dbCreateUser = \uid user -> wrap (usersPostSession uid user) - , dbUpdateUser = \uid user -> Right <$> wrap (usersPutSession uid user) + , dbUpdateUser = \uid user -> wrap (usersPutSession uid user) , dbDeleteUser = \uid -> Right <$> wrap (usersDeleteSession uid) } where diff --git a/infra/shell.nix b/infra/shell.nix index 6ceeb451a..6bccf7550 100644 --- a/infra/shell.nix +++ b/infra/shell.nix @@ -28,5 +28,9 @@ in ${pgutil.stop_pg} } + function repl() { + ghci handler/app/Test.hs handler/src/DeckGo/Handler.hs + } + ''; }) From 2d00578a0a7a54272b8e9f833e456f57befe693b Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Fri, 10 May 2019 19:16:07 +0200 Subject: [PATCH 07/10] fix: don't over migrate --- infra/handler/src/DeckGo/Handler.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index 999f67746..11f802a9f 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -556,7 +556,7 @@ usersPutSession uid u = do 1 -> do HS.sql "COMMIT" pure UserUpdateOk - 0 -> do + _ -> do HS.sql "ROLLBACK" pure UserUpdateClash @@ -1129,7 +1129,12 @@ data DbVersion -- | Migrates from ver to latest migrateFrom :: DbVersion -> HS.Session () -migrateFrom = \ver -> forM_ [ver .. maxBound] migrateTo +migrateFrom = \ver -> + if ver < maxBound + then + let from = succ ver + in forM_ [from .. maxBound] migrateTo + else pure () where -- | Migrates from (ver -1) to ver migrateTo :: DbVersion -> HS.Session () From 0303592e06da0e4ffe9c34033bbd2590d58c4625 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Fri, 10 May 2019 19:28:11 +0200 Subject: [PATCH 08/10] fix: user obj parsing --- infra/handler/src/DeckGo/Handler.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index 11f802a9f..689d72be3 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE MonadFailDesugaring #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} @@ -132,6 +133,7 @@ newtype FirebaseId = FirebaseId { unFirebaseId :: T.Text } deriving stock ( Generic ) +-- XXX !!?!??!?!! pattern match failures are propagated to the client!!! instance FromJSONObject User where parseJSONObject = \obj -> User @@ -139,7 +141,7 @@ instance FromJSONObject User where <*> ( (do True <- obj .: "anonymous" - (Nothing :: Maybe Username) <- obj .: "username" + (Nothing :: Maybe Username) <- obj .:? "username" pure Nothing ) <|> (do False <- obj .: "anonymous" @@ -1132,8 +1134,8 @@ migrateFrom :: DbVersion -> HS.Session () migrateFrom = \ver -> if ver < maxBound then - let from = succ ver - in forM_ [from .. maxBound] migrateTo + let frm = succ ver + in forM_ [frm .. maxBound] migrateTo else pure () where -- | Migrates from (ver -1) to ver @@ -1228,6 +1230,8 @@ dbVersionFromText :: T.Text -> Maybe DbVersion dbVersionFromText t = find (\ver -> dbVersionToText ver == t) [minBound .. maxBound] +-- XXX: this is not quite right, it'll never do the Version1 migration. Not a +-- problem currently since we dump everything at v2 anyway. migrate :: HS.Session () migrate = do readDbVersion >>= \case From 428e3447e3ca85790540068566d3b4b5ef6f9aab Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Sun, 12 May 2019 15:09:53 +0200 Subject: [PATCH 09/10] feat: backend UserInfo --- infra/handler/app/Test.hs | 42 +++++---- infra/handler/src/DeckGo/Handler.hs | 133 ++++++++++++++++++++-------- 2 files changed, 121 insertions(+), 54 deletions(-) diff --git a/infra/handler/app/Test.hs b/infra/handler/app/Test.hs index 49fcf6a8f..852aebed9 100644 --- a/infra/handler/app/Test.hs +++ b/infra/handler/app/Test.hs @@ -35,7 +35,7 @@ withServer act = do { HTTPClient.managerModifyRequest = pure . rerouteDynamoDB } - withPristineDB $ \(conn, _iface) -> do + withPristineDB $ \conn -> do env <- Aws.newEnv Aws.Discover <&> Aws.envManager .~ mgr (port, socket) <- Warp.openFreePort @@ -50,14 +50,16 @@ withServer act = do Left () -> error "Server returned" Right a -> pure a -withPristineDB :: ((HC.Connection, DbInterface) -> IO a) -> IO a +withPristineDB :: (HC.Connection -> IO a) -> IO a withPristineDB act = do conn <- getPostgresqlConnection + putStrLn "DROP TABLE IF EXISTS username" void $ HS.run (HS.sql "DROP TABLE IF EXISTS username") conn - void $ HS.run (HS.sql "DROP TABLE IF EXISTS account") conn + putStrLn "DROP TABLE IF EXISTS account CASCADE" + void $ HS.run (HS.sql "DROP TABLE IF EXISTS account CASCADE") conn + putStrLn "DROP TABLE IF EXISTS db_meta" void $ HS.run (HS.sql "DROP TABLE IF EXISTS db_meta") conn - iface <- getDbInterface conn - act (conn, iface) + act conn main :: IO () main = do @@ -74,7 +76,8 @@ main = do ] testUsersGet :: IO () -testUsersGet = withPristineDB $ \(_, iface) -> do +testUsersGet = withPristineDB $ \conn -> do + iface <- getDbInterface conn dbGetAllUsers iface >>= \case [] -> pure () users -> error $ "Expected no users, got: " <> show users @@ -97,7 +100,8 @@ testUsersGet = withPristineDB $ \(_, iface) -> do users -> error $ "Expected no users, got: " <> show users testUsersGetByUserId :: IO () -testUsersGetByUserId = withPristineDB $ \(_, iface) -> do +testUsersGetByUserId = withPristineDB $ \conn -> do + iface <- getDbInterface conn let someFirebaseId = FirebaseId "foo" someUserId = UserId someFirebaseId someUser = User @@ -116,7 +120,8 @@ testUsersGetByUserId = withPristineDB $ \(_, iface) -> do Nothing -> error "Got no users" testUsersDelete :: IO () -testUsersDelete = withPristineDB $ \(_, iface) -> do +testUsersDelete = withPristineDB $ \conn -> do + iface <- getDbInterface conn let someFirebaseId = FirebaseId "foo" someUserId = UserId someFirebaseId someUser = User @@ -132,7 +137,8 @@ testUsersDelete = withPristineDB $ \(_, iface) -> do Right () -> pure () testUsersCreate :: IO () -testUsersCreate = withPristineDB $ \(_, iface) -> do +testUsersCreate = withPristineDB $ \conn -> do + iface <- getDbInterface conn let someFirebaseId = FirebaseId "foo" someUserId = UserId someFirebaseId someUser = User @@ -144,7 +150,8 @@ testUsersCreate = withPristineDB $ \(_, iface) -> do Right () -> pure () testUsersUpdate :: IO () -testUsersUpdate = withPristineDB $ \(_, iface) -> do +testUsersUpdate = withPristineDB $ \conn -> do + iface <- getDbInterface conn let someFirebaseId = FirebaseId "foo" someUserId = UserId someFirebaseId someUser = User @@ -258,16 +265,17 @@ main' = withServer $ \port -> do Right decks -> if decks == [] then pure () else (error $ "Expected no decks, got: " <> show decks) - let someUser = User - { userFirebaseId = someFirebaseId - , userUsername = Just (Username "patrick") } + let someUserInfo = UserInfo + { userInfoFirebaseId = someFirebaseId + , userInfoEmail = Just "patrick" } + someUser = userInfoToUser someUserInfo - runClientM (usersPost' b someUser) clientEnv >>= \case + runClientM (usersPost' b someUserInfo) clientEnv >>= \case Left err -> error $ "Expected user, got error: " <> show err Right (Item userId user) -> if user == someUser && userId == someUserId then pure () else (error $ "Expected same user, got: " <> show user) - runClientM (usersPost' b someUser) clientEnv >>= \case + runClientM (usersPost' b someUserInfo) clientEnv >>= \case Left (FailureResponse resp) -> if HTTP.statusCode (responseStatusCode resp) == 409 then pure () else error $ "Got unexpected response: " <> show resp @@ -279,8 +287,8 @@ main' = withServer $ \port -> do usersGet' :: ClientM [Item UserId User] _usersGetUserId' :: UserId -> ClientM (Item UserId User) -usersPost' :: T.Text -> User -> ClientM (Item UserId User) -_usersPut' :: T.Text -> UserId -> User -> ClientM (Item UserId User) +usersPost' :: T.Text -> UserInfo -> ClientM (Item UserId User) +_usersPut' :: T.Text -> UserId -> UserInfo -> ClientM (Item UserId User) _usersDelete' :: T.Text -> UserId -> ClientM () decksGet' :: T.Text -> Maybe UserId -> ClientM [Item DeckId Deck] diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index 689d72be3..d310e1cf9 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE MonadFailDesugaring #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveGeneric #-} @@ -93,20 +94,25 @@ type UsersAPI = Get '[JSON] [Item UserId User] :<|> Capture "user_id" UserId :> Get '[JSON] (Item UserId User) :<|> Protected :> - ReqBody '[JSON] User :> + ReqBody '[JSON] UserInfo :> Post '[JSON] (Item UserId User) :<|> Protected :> Capture "user_id" UserId :> - ReqBody '[JSON] User :> Put '[JSON] (Item UserId User) :<|> + ReqBody '[JSON] UserInfo :> Put '[JSON] (Item UserId User) :<|> Protected :> Capture "user_id" UserId :> Delete '[JSON] () newtype Username = Username { unUsername :: T.Text } deriving stock (Show, Eq) deriving newtype (Aeson.FromJSON, Aeson.ToJSON) +data UserInfo = UserInfo + { userInfoFirebaseId :: FirebaseId + , userInfoEmail :: Maybe T.Text + } deriving (Show, Eq) + data User = User { userFirebaseId :: FirebaseId - , userUsername :: Maybe Username + , userUsername :: Maybe Username -- + return anonymous } deriving (Show, Eq) newtype UserId = UserId { unUserId :: FirebaseId } @@ -134,6 +140,21 @@ newtype FirebaseId = FirebaseId { unFirebaseId :: T.Text } ( Generic ) -- XXX !!?!??!?!! pattern match failures are propagated to the client!!! +instance FromJSONObject UserInfo where + parseJSONObject = \obj -> + UserInfo + <$> obj .: "firebase_uid" + <*> ( + (do + True <- obj .: "anonymous" + (Nothing :: Maybe T.Text) <- obj .:? "email" + pure Nothing + ) <|> (do + False <- obj .: "anonymous" + obj .:? "email" + ) + ) + instance FromJSONObject User where parseJSONObject = \obj -> User @@ -145,23 +166,33 @@ instance FromJSONObject User where pure Nothing ) <|> (do False <- obj .: "anonymous" - obj .: "username" + obj .:? "username" ) ) +instance ToJSONObject UserInfo where + toJSONObject uinfo = HMS.fromList + [ "anonymous" .= isNothing (userInfoEmail uinfo) + , "email" .= userInfoEmail uinfo + , "firebase_uid" .= userInfoFirebaseId uinfo + ] + +instance Aeson.FromJSON UserInfo where + parseJSON = Aeson.withObject "UserInfo" parseJSONObject + instance ToJSONObject User where toJSONObject user = HMS.fromList - [ "firebase_uid" .= userFirebaseId user - , "anonymous" .= isNothing (userUsername user) + [ "anonymous" .= isNothing (userUsername user) , "username" .= userUsername user + , "firebase_uid" .= userFirebaseId user ] -instance Aeson.FromJSON User where - parseJSON = Aeson.withObject "User" parseJSONObject - instance Aeson.ToJSON User where toJSON = Aeson.Object . toJSONObject +instance Aeson.ToJSON UserInfo where + toJSON = Aeson.Object . toJSONObject + instance ToSchema (Item UserId User) where declareNamedSchema _ = pure $ NamedSchema (Just "UserWithId") mempty @@ -174,6 +205,18 @@ instance ToParamSchema (Item UserId User) where instance ToParamSchema UserId where toParamSchema _ = mempty +-- instance ToSchema (Item UserId User) where + -- declareNamedSchema _ = pure $ NamedSchema (Just "UserWithId") mempty + +instance ToSchema UserInfo where + declareNamedSchema _ = pure $ NamedSchema (Just "UserInfo") mempty + +instance ToParamSchema (Item UserId UserInfo) where + toParamSchema _ = mempty + +-- instance ToParamSchema UserId where + -- toParamSchema _ = mempty + -- DECKS type DecksAPI = @@ -415,21 +458,34 @@ usersGetUserIdStatement = Statement sql encoder decoder True HD.nullableColumn (Username <$> HD.text) ) -usersPost :: HC.Connection -> Firebase.UserId -> User -> Servant.Handler (Item UserId User) -usersPost conn fuid user = do - let userId = UserId (userFirebaseId user) - liftIO $ putStrLn "POST users" +usersPost + :: HC.Connection + -> Firebase.UserId + -> UserInfo + -> Servant.Handler (Item UserId User) +usersPost conn fuid uinfo = do - when (Firebase.unUserId fuid /= unFirebaseId (userFirebaseId user)) $ do + when (Firebase.unUserId fuid /= unFirebaseId (userInfoFirebaseId uinfo)) $ do Servant.throwError Servant.err403 - liftIO $ putStrLn "auth is ok" iface <- liftIO $ getDbInterface conn liftIO $ putStrLn "got DB interface" + + let userId = UserId (userInfoFirebaseId uinfo) + user = userInfoToUser uinfo liftIO (dbCreateUser iface userId user) >>= \case Left () -> Servant.throwError $ Servant.err409 Right () -> pure $ Item userId user +userInfoToUser :: UserInfo -> User +userInfoToUser uinfo = User + { userFirebaseId = userInfoFirebaseId uinfo + , userUsername = emailToUsername <$> userInfoEmail uinfo + } + +emailToUsername :: T.Text -> Username +emailToUsername = Username + usersPostSession :: UserId -> User -> HS.Session (Either () ()) usersPostSession uid u = do HS.sql "BEGIN" @@ -505,20 +561,26 @@ usersPostStatement'' = Statement sql encoder decoder True (HE.param HE.text) decoder = HD.unit -usersPut :: HC.Connection -> Firebase.UserId -> UserId -> User -> Servant.Handler (Item UserId User) -usersPut conn fuid userId user = do +usersPut + :: HC.Connection + -> Firebase.UserId + -> UserId + -> UserInfo + -> Servant.Handler (Item UserId User) +usersPut conn fuid userId uinfo = do when (Firebase.unUserId fuid /= unFirebaseId (unUserId userId)) $ do liftIO $ putStrLn $ unwords - [ "User is trying to update another user:", show (fuid, userId, user) ] + [ "User is trying to update another uinfo:", show (fuid, userId, uinfo) ] Servant.throwError Servant.err404 - when (Firebase.unUserId fuid /= unFirebaseId (userFirebaseId user)) $ do + when (Firebase.unUserId fuid /= unFirebaseId (userInfoFirebaseId uinfo)) $ do liftIO $ putStrLn $ unwords - [ "Client used the wrong user ID on user", show (fuid, userId, user) ] + [ "Client used the wrong uinfo ID on uinfo", show (fuid, userId, uinfo) ] Servant.throwError Servant.err400 iface <- liftIO $ getDbInterface conn + let user = userInfoToUser uinfo liftIO (dbUpdateUser iface userId user) >>= \case UserUpdateOk -> pure $ Item userId user -- TODO: check # of affected rows e -> do -- TODO: handle not found et al. @@ -1131,12 +1193,9 @@ data DbVersion -- | Migrates from ver to latest migrateFrom :: DbVersion -> HS.Session () -migrateFrom = \ver -> - if ver < maxBound - then - let frm = succ ver - in forM_ [frm .. maxBound] migrateTo - else pure () +migrateFrom = \ver -> do + liftIO $ putStrLn $ "Migration: " <> show (dbVersionToText <$> [ver ..maxBound]) + forM_ [ver .. maxBound] migrateTo where -- | Migrates from (ver -1) to ver migrateTo :: DbVersion -> HS.Session () @@ -1159,7 +1218,7 @@ migrateFrom = \ver -> ver@DbVersion1 -> do HS.statement () $ Statement (BS8.unwords - [ "DROP TABLE IF EXISTS account" + [ "DROP TABLE IF EXISTS account CASCADE" ] ) HE.unit HD.unit True HS.statement () $ Statement @@ -1215,8 +1274,7 @@ readDbVersion = do , ");" ] ) HE.unit HD.unit True - migrateFrom minBound - pure $ Right $ Just maxBound + pure $ Right Nothing latestDbVersion :: DbVersion latestDbVersion = maxBound @@ -1230,17 +1288,18 @@ dbVersionFromText :: T.Text -> Maybe DbVersion dbVersionFromText t = find (\ver -> dbVersionToText ver == t) [minBound .. maxBound] --- XXX: this is not quite right, it'll never do the Version1 migration. Not a --- problem currently since we dump everything at v2 anyway. migrate :: HS.Session () migrate = do readDbVersion >>= \case Left e -> error $ show e - Right Nothing -> migrateFrom minBound + Right Nothing -> do + liftIO $ putStrLn "Migrating from beginning" + migrateFrom minBound Right (Just v) -> - if v >= maxBound - then pure () - else migrateFrom v + if + | v == maxBound -> pure () + | v > maxBound -> error "V greater than maxbound" + | v < maxBound -> migrateFrom (succ v) getDbInterface :: HC.Connection -> IO DbInterface getDbInterface conn = do @@ -1251,8 +1310,8 @@ getDbInterface conn = do pure $ DbInterface { dbGetAllUsers = wrap usersGetSession , dbGetUserById = \uid -> wrap (usersGetUserIdSession uid) - , dbCreateUser = \uid user -> wrap (usersPostSession uid user) - , dbUpdateUser = \uid user -> wrap (usersPutSession uid user) + , dbCreateUser = \uid uinfo -> wrap (usersPostSession uid uinfo) + , dbUpdateUser = \uid uinfo -> wrap (usersPutSession uid uinfo) , dbDeleteUser = \uid -> Right <$> wrap (usersDeleteSession uid) } where From 014bd432eba24f38408b74d58958e99448edd6c9 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Sun, 12 May 2019 16:01:40 +0200 Subject: [PATCH 10/10] feat: generate acceptable usernames --- infra/handler/app/Test.hs | 5 ++-- infra/handler/src/DeckGo/Handler.hs | 42 ++++++++++++++++++++--------- 2 files changed, 32 insertions(+), 15 deletions(-) diff --git a/infra/handler/app/Test.hs b/infra/handler/app/Test.hs index 852aebed9..f1d049ac9 100644 --- a/infra/handler/app/Test.hs +++ b/infra/handler/app/Test.hs @@ -267,8 +267,8 @@ main' = withServer $ \port -> do let someUserInfo = UserInfo { userInfoFirebaseId = someFirebaseId - , userInfoEmail = Just "patrick" } - someUser = userInfoToUser someUserInfo + , userInfoEmail = Just "patrick@foo.com" } + Right someUser = userInfoToUser someUserInfo runClientM (usersPost' b someUserInfo) clientEnv >>= \case Left err -> error $ "Expected user, got error: " <> show err @@ -276,6 +276,7 @@ main' = withServer $ \port -> do 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 diff --git a/infra/handler/src/DeckGo/Handler.hs b/infra/handler/src/DeckGo/Handler.hs index d310e1cf9..f7ca1a458 100644 --- a/infra/handler/src/DeckGo/Handler.hs +++ b/infra/handler/src/DeckGo/Handler.hs @@ -20,6 +20,7 @@ module DeckGo.Handler where -- TODO: created_at, updated_at +-- TODO: nullable slide content -- TODO: improve swagger description -- TODO: feed API @@ -45,9 +46,11 @@ import Servant (Context ((:.))) import Servant.API import Servant.Auth.Firebase (Protected) import UnliftIO +import Data.Char import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BSL import qualified Data.HashMap.Strict as HMS import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -187,9 +190,6 @@ instance ToJSONObject User where , "firebase_uid" .= userFirebaseId user ] -instance Aeson.ToJSON User where - toJSON = Aeson.Object . toJSONObject - instance Aeson.ToJSON UserInfo where toJSON = Aeson.Object . toJSONObject @@ -472,19 +472,32 @@ usersPost conn fuid uinfo = do liftIO $ putStrLn "got DB interface" let userId = UserId (userInfoFirebaseId uinfo) - user = userInfoToUser uinfo + user <- case userInfoToUser uinfo of + Left e -> Servant.throwError Servant.err400 + { Servant.errBody = BSL.fromStrict $ T.encodeUtf8 e } + Right user -> pure user liftIO (dbCreateUser iface userId user) >>= \case Left () -> Servant.throwError $ Servant.err409 + { Servant.errBody = Aeson.encode (Item userId user) } Right () -> pure $ Item userId user -userInfoToUser :: UserInfo -> User -userInfoToUser uinfo = User - { userFirebaseId = userInfoFirebaseId uinfo - , userUsername = emailToUsername <$> userInfoEmail uinfo - } - -emailToUsername :: T.Text -> Username -emailToUsername = Username +userInfoToUser :: UserInfo -> Either T.Text User +userInfoToUser uinfo = User <$> + pure (userInfoFirebaseId uinfo) <*> + (traverse emailToUsername (userInfoEmail uinfo)) + +emailToUsername :: T.Text -> Either T.Text Username +emailToUsername t = case T.breakOn "@" t of + ("", _) -> Left ("Invalid email: " <> t) + (out', _) -> case dropBadChars (T.toLower out') of + "" -> Left ("No valid char found: " <> out') + out -> Right $ Username out + where + dropBadChars :: T.Text -> T.Text + dropBadChars = T.concatMap + $ \case + c | isAscii c && isAlphaNum c -> T.singleton c + | otherwise -> "" usersPostSession :: UserId -> User -> HS.Session (Either () ()) usersPostSession uid u = do @@ -580,7 +593,10 @@ usersPut conn fuid userId uinfo = do Servant.throwError Servant.err400 iface <- liftIO $ getDbInterface conn - let user = userInfoToUser uinfo + user <- case userInfoToUser uinfo of + Left e -> Servant.throwError Servant.err400 + { Servant.errBody = BSL.fromStrict $ T.encodeUtf8 e } + Right user -> pure user liftIO (dbUpdateUser iface userId user) >>= \case UserUpdateOk -> pure $ Item userId user -- TODO: check # of affected rows e -> do -- TODO: handle not found et al.