feat: backend UserInfo

Author: nmattia

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]

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