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

Commit 33f8dda

Browse files
nmattianmattia
authored
Merge pull request #108 from deckgo/nm-username-again
Username
2 parents f740dc5 + 014bd43 commit 33f8dda

File tree

8 files changed

+518
-179
lines changed

8 files changed

+518
-179
lines changed

‎infra/default.nix‎

Lines changed: 2 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -97,21 +97,12 @@ rec
9797
9898
${pgutil.start_pg}
9999
100-
# Start server with fs redirect for getProtocolByName
100+
echo "Running tests"
101101
NIX_REDIRECTS=/etc/protocols=${pkgs.iana-etc}/etc/protocols \
102102
LD_PRELOAD="${pkgs.libredirect}/lib/libredirect.so" \
103103
GOOGLE_PUBLIC_KEYS="${pkgs.writeText "google-x509" (builtins.toJSON googleResp)}" \
104104
FIREBASE_PROJECT_ID="my-project-id" \
105-
${handler}/bin/server &
106-
107-
while ! nc -z 127.0.0.1 8080; do
108-
echo waiting for server
109-
sleep 1
110-
done
111-
112-
echo "Running tests"
113-
${handler}/bin/test ${./token}
114-
105+
TEST_TOKEN_PATH=${./token} ${handler}/bin/test
115106
echo "Tests were run"
116107
117108
touch $out

‎infra/handler/app/Server.hs‎

Lines changed: 0 additions & 72 deletions
This file was deleted.

‎infra/handler/app/Test.hs‎

Lines changed: 229 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -1,25 +1,197 @@
11
{-# LANGUAGE OverloadedStrings #-}
22
{-# LANGUAGE LambdaCase #-}
33

4+
module Main where
5+
6+
import Control.Lens
7+
import Control.Monad
8+
import DeckGo.Handler
49
import Network.HTTP.Client (newManager, defaultManagerSettings)
510
import Network.HTTP.Types as HTTP
611
import Servant.API
712
import Servant.Client
8-
import DeckGo.Handler
13+
import System.Environment
14+
import System.Environment (getEnv)
15+
import UnliftIO
16+
import qualified Data.Aeson as Aeson
17+
import qualified Data.ByteString.Char8 as BS8
18+
import qualified Data.HashMap.Strict as HMS
919
import qualified Data.Text as T
1020
import qualified Data.Text.IO as T
11-
import qualified Data.HashMap.Strict as HMS
12-
import System.Environment (getArgs)
21+
import qualified Hasql.Connection as HC
22+
import qualified Hasql.Session as HS
23+
import qualified Network.AWS as Aws
24+
import qualified Network.HTTP.Client as HTTPClient
25+
import qualified Network.HTTP.Client.TLS as HTTPClient
26+
import qualified Network.Socket.Wait as Socket
27+
import qualified Network.Wai.Handler.Warp as Warp
28+
import qualified Servant.Auth.Firebase as Firebase
29+
import qualified Test.Tasty as Tasty
30+
import qualified Test.Tasty.HUnit as Tasty
31+
32+
withServer :: (Warp.Port -> IO a) -> IO a
33+
withServer act = do
34+
mgr <- HTTPClient.newManager HTTPClient.tlsManagerSettings
35+
{ HTTPClient.managerModifyRequest =
36+
pure . rerouteDynamoDB
37+
}
38+
withPristineDB $ \conn -> do
39+
env <- Aws.newEnv Aws.Discover <&> Aws.envManager .~ mgr
40+
41+
(port, socket) <- Warp.openFreePort
42+
let warpSettings = Warp.setPort port $ Warp.defaultSettings
43+
settings <- getFirebaseSettings
44+
race
45+
(Warp.runSettingsSocket warpSettings socket $ DeckGo.Handler.application settings env conn)
46+
(do
47+
Socket.wait "localhost" port
48+
act port
49+
) >>= \case
50+
Left () -> error "Server returned"
51+
Right a -> pure a
52+
53+
withPristineDB :: (HC.Connection -> IO a) -> IO a
54+
withPristineDB act = do
55+
conn <- getPostgresqlConnection
56+
putStrLn "DROP TABLE IF EXISTS username"
57+
void $ HS.run (HS.sql "DROP TABLE IF EXISTS username") conn
58+
putStrLn "DROP TABLE IF EXISTS account CASCADE"
59+
void $ HS.run (HS.sql "DROP TABLE IF EXISTS account CASCADE") conn
60+
putStrLn "DROP TABLE IF EXISTS db_meta"
61+
void $ HS.run (HS.sql "DROP TABLE IF EXISTS db_meta") conn
62+
act conn
1363

1464
main :: IO ()
1565
main = do
16-
[p] <- getArgs
66+
setEnv "TASTY_NUM_THREADS" "1"
67+
Tasty.defaultMain $ Tasty.testGroup "tests"
68+
[ Tasty.testGroup "db"
69+
[ Tasty.testCase "users get" testUsersGet
70+
, Tasty.testCase "users create" testUsersCreate
71+
, Tasty.testCase "users get by id" testUsersGetByUserId
72+
, Tasty.testCase "users delete" testUsersDelete
73+
, Tasty.testCase "users update" testUsersUpdate
74+
]
75+
, Tasty.testCase "foo" main'
76+
]
77+
78+
testUsersGet :: IO ()
79+
testUsersGet = withPristineDB $ \conn -> do
80+
iface <- getDbInterface conn
81+
dbGetAllUsers iface >>= \case
82+
[] -> pure ()
83+
users -> error $ "Expected no users, got: " <> show users
84+
85+
let someFirebaseId = FirebaseId "foo"
86+
someUserId = UserId someFirebaseId
87+
someUser = User
88+
{ userFirebaseId = someFirebaseId
89+
, userUsername = Just (Username "patrick")
90+
}
91+
dbCreateUser iface someUserId someUser >>= \case
92+
Left () -> error "Encountered error"
93+
Right () -> pure ()
94+
95+
dbGetAllUsers iface >>= \case
96+
[Item userId user] ->
97+
if userId == someUserId && user == someUser
98+
then pure ()
99+
else error "bad user"
100+
users -> error $ "Expected no users, got: " <> show users
101+
102+
testUsersGetByUserId :: IO ()
103+
testUsersGetByUserId = withPristineDB $ \conn -> do
104+
iface <- getDbInterface conn
105+
let someFirebaseId = FirebaseId "foo"
106+
someUserId = UserId someFirebaseId
107+
someUser = User
108+
{ userFirebaseId = someFirebaseId
109+
, userUsername = Just (Username "patrick")
110+
}
111+
dbCreateUser iface someUserId someUser >>= \case
112+
Left () -> error "Encountered error"
113+
Right () -> pure ()
114+
115+
dbGetUserById iface someUserId >>= \case
116+
Just (Item userId user) ->
117+
if userId == someUserId && user == someUser
118+
then pure ()
119+
else error "bad user"
120+
Nothing -> error "Got no users"
17121

18-
b <- T.readFile p
122+
testUsersDelete :: IO ()
123+
testUsersDelete = withPristineDB $ \conn -> do
124+
iface <- getDbInterface conn
125+
let someFirebaseId = FirebaseId "foo"
126+
someUserId = UserId someFirebaseId
127+
someUser = User
128+
{ userFirebaseId = someFirebaseId
129+
, userUsername = Just (Username "patrick")
130+
}
131+
dbCreateUser iface someUserId someUser >>= \case
132+
Left () -> error "Encountered error"
133+
Right () -> pure ()
134+
135+
dbDeleteUser iface someUserId >>= \case
136+
Left () -> error "couldn't delete"
137+
Right () -> pure ()
138+
139+
testUsersCreate :: IO ()
140+
testUsersCreate = withPristineDB $ \conn -> do
141+
iface <- getDbInterface conn
142+
let someFirebaseId = FirebaseId "foo"
143+
someUserId = UserId someFirebaseId
144+
someUser = User
145+
{ userFirebaseId = someFirebaseId
146+
, userUsername = Just (Username "patrick")
147+
}
148+
dbCreateUser iface someUserId someUser >>= \case
149+
Left () -> error "Encountered error"
150+
Right () -> pure ()
151+
152+
testUsersUpdate :: IO ()
153+
testUsersUpdate = withPristineDB $ \conn -> do
154+
iface <- getDbInterface conn
155+
let someFirebaseId = FirebaseId "foo"
156+
someUserId = UserId someFirebaseId
157+
someUser = User
158+
{ userFirebaseId = someFirebaseId
159+
, userUsername = Just (Username "patrick")
160+
}
161+
162+
dbCreateUser iface someUserId someUser >>= \case
163+
Left () -> error "Encountered error"
164+
Right () -> pure ()
165+
166+
let someUser' = User
167+
{ userFirebaseId = someFirebaseId
168+
, userUsername = Just (Username "joseph")
169+
}
170+
171+
dbUpdateUser iface someUserId someUser' >>= \case
172+
UserUpdateOk -> pure ()
173+
e -> error $ "encountered error:" <> show e
174+
175+
dbGetUserById iface someUserId >>= \case
176+
Just (Item userId user) ->
177+
if userId == someUserId && user == someUser'
178+
then pure ()
179+
else error "bad user"
180+
Nothing -> error "Got no users"
181+
182+
getTokenPath :: IO FilePath
183+
getTokenPath =
184+
lookupEnv "TEST_TOKEN_PATH" >>= \case
185+
Just tpath -> pure tpath
186+
Nothing -> pure "./token"
187+
188+
main' :: IO ()
189+
main' = withServer $ \port -> do
190+
b <- T.readFile =<< getTokenPath
19191

20192
manager' <- newManager defaultManagerSettings
21193

22-
let clientEnv = mkClientEnv manager' (BaseUrl Http "localhost" 8080 "")
194+
let clientEnv = mkClientEnv manager' (BaseUrl Http "localhost" port "")
23195
let someFirebaseId = FirebaseId "the-uid" -- from ./token
24196
let someUserId = UserId someFirebaseId
25197
let someDeck = Deck
@@ -32,7 +204,7 @@ main = do
32204
runClientM usersGet' clientEnv >>= \case
33205
Left err -> error $ "Expected users, got error: " <> show err
34206
Right [] -> pure ()
35-
Right decks -> error $ "Expected 0 users, got: " <> show decks
207+
Right users -> error $ "Expected 0 users, got: " <> show users
36208

37209
runClientM (decksGet' b (Just someUserId)) clientEnv >>= \case
38210
Left err -> error $ "Expected decks, got error: " <> show err
@@ -93,28 +265,31 @@ main = do
93265
Right decks ->
94266
if decks == [] then pure () else (error $ "Expected no decks, got: " <> show decks)
95267

96-
let someUser = User { userFirebaseId = someFirebaseId, userAnonymous = False }
268+
let someUserInfo = UserInfo
269+
{ userInfoFirebaseId = someFirebaseId
270+
, userInfoEmail = Just "[email protected]" }
271+
Right someUser = userInfoToUser someUserInfo
97272

98-
runClientM (usersPost' b someUser) clientEnv >>= \case
273+
runClientM (usersPost' b someUserInfo) clientEnv >>= \case
99274
Left err -> error $ "Expected user, got error: " <> show err
100275
Right (Item userId user) ->
101276
if user == someUser && userId == someUserId then pure () else (error $ "Expected same user, got: " <> show user)
102277

103-
runClientM (usersPost' b someUser) clientEnv >>= \case
278+
runClientM (usersPost' b someUserInfo) clientEnv >>= \case
279+
-- TODO: test that user is returned here, even on 409
104280
Left (FailureResponse resp) ->
105281
if HTTP.statusCode (responseStatusCode resp) == 409 then pure () else
106282
error $ "Got unexpected response: " <> show resp
107283
Left err -> error $ "Expected 409, got error: " <> show err
108284
Right item -> error $ "Expected failure, got success: " <> show item
109285

110-
111286
-- TODO: test that creating user with token that has different user as sub
112287
-- fails
113288

114289
usersGet' :: ClientM [Item UserId User]
115290
_usersGetUserId' :: UserId -> ClientM (Item UserId User)
116-
usersPost' :: T.Text -> User -> ClientM (Item UserId User)
117-
_usersPut' :: T.Text -> UserId -> User -> ClientM (Item UserId User)
291+
usersPost' :: T.Text -> UserInfo -> ClientM (Item UserId User)
292+
_usersPut' :: T.Text -> UserId -> UserInfo -> ClientM (Item UserId User)
118293
_usersDelete' :: T.Text -> UserId -> ClientM ()
119294

120295
decksGet' :: T.Text -> Maybe UserId -> ClientM [Item DeckId Deck]
@@ -148,3 +323,44 @@ slidesDelete' :: T.Text -> DeckId -> SlideId -> ClientM ()
148323
slidesDelete'
149324
)
150325
) = client api
326+
327+
rerouteDynamoDB :: HTTPClient.Request -> HTTPClient.Request
328+
rerouteDynamoDB req =
329+
case HTTPClient.host req of
330+
"dynamodb.us-east-1.amazonaws.com" ->
331+
req
332+
{ HTTPClient.host = "127.0.0.1"
333+
, HTTPClient.port = 8000 -- TODO: read from Env
334+
, HTTPClient.secure = False
335+
}
336+
_ -> req
337+
338+
getFirebaseSettings :: IO Firebase.FirebaseLoginSettings
339+
getFirebaseSettings = do
340+
pkeys <- getEnv "GOOGLE_PUBLIC_KEYS"
341+
pid <- getEnv "FIREBASE_PROJECT_ID"
342+
keyMap <- Aeson.decodeFileStrict pkeys >>= \case
343+
Nothing -> error "Could not decode key file"
344+
Just keyMap -> pure keyMap
345+
pure Firebase.FirebaseLoginSettings
346+
{ Firebase.firebaseLoginProjectId = Firebase.ProjectId (T.pack pid)
347+
, Firebase.firebaseLoginGetKeys = pure keyMap
348+
}
349+
350+
getPostgresqlConnection :: IO HC.Connection
351+
getPostgresqlConnection = do
352+
user <- getEnv "PGUSER"
353+
password <- getEnv "PGPASSWORD"
354+
host <- getEnv "PGHOST"
355+
db <- getEnv "PGDATABASE"
356+
port <- getEnv "PGPORT"
357+
HC.acquire (
358+
HC.settings
359+
(BS8.pack host)
360+
(read port)
361+
(BS8.pack user)
362+
(BS8.pack password)
363+
(BS8.pack db)
364+
) >>= \case
365+
Left e -> error (show e)
366+
Right c -> pure c

0 commit comments

Comments
 (0)