feat: signup back route oauth

api/src/Api/About.hs

@@ -44,8 +44,8 @@ $(deriveJSON defaultOptions ''ServerAbout)
 $(deriveJSON defaultOptions ''About)
 
 servicesDir :: [(FilePath, S.ByteString)]
-servicesDir = $(embedDir "./services/")
---servicesDir = undefined
+--servicesDir = $(embedDir "./services/")
+servicesDir = undefined
 
 about :: SockAddr -> AppM About
 about host = do

api/src/Api/Auth.hs

@@ -29,7 +29,7 @@ import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Maybe (MaybeT(runMaybeT))
 import Core.OIDC ( getOauthTokens )
 import Data.Aeson (FromJSON, ToJSON)
-import Db.User (User', UserDB (UserDB), password, toUser)
+import Db.User (User', UserDB (UserDB, userDBId), password, toUser)
 import GHC.Generics (Generic)
 import Servant.API.Generic (ToServantApi, (:-))
 import Servant.Auth.Server (CookieSettings, JWT, JWTSettings, SetCookie, ThrowAll (throwAll), acceptLogin, AuthResult (Authenticated), makeJWT)
@@ -41,7 +41,7 @@ import App (AppM)
 import Core.User (User, UserId (UserId), Service)
 import Data.Text (pack)
 import Password (hashPassword'', toPassword, validatePassword')
-import Repository (createUser, getUserByName', getUserByToken)
+import Repository (createUser, getUserByName', getUserByToken, updateTokens)
 import Utils (UserAuth, AuthRes)
 
 data LoginUser = LoginUser
@@ -88,6 +88,10 @@ type Unprotected =
     :<|> Capture "service" Service :> "signin"
         :> QueryParam "code" String
         :> Post '[JSON] LoginResponse
+    :<|> Capture "service" Service :> "signup"
+        :> QueryParam "code" String
+        :> ReqBody '[JSON] SignupUser
+        :> Post '[JSON] LoginResponse
  
 
 loginHandler ::
@@ -106,7 +110,6 @@ loginHandler cs jwts (LoginUser username p) = do
                 Right v -> return $ LoginResponse $ unpack v
         else throwError err401
 
-
 loginOauthHandler :: JWTSettings -> Service -> Maybe String -> AppM LoginResponse
 loginOauthHandler jwts _ Nothing = throwError err400
 loginOauthHandler jwts service (Just code) = do
@@ -120,7 +123,20 @@ loginOauthHandler jwts service (Just code) = do
                 Left e -> throwError err401
                 Right v -> return $ LoginResponse $ unpack v
 
-
+signupOauthHandler :: JWTSettings -> Service -> Maybe String -> SignupUser -> AppM LoginResponse 
+signupOauthHandler jwts service (Just code) (SignupUser name p) = do
+    hashed <- hashPassword'' $ toPassword $ pack p
+    user <- createUser $ UserDB (UserId 1) (pack name) hashed (pack name) []
+    tokens <- liftIO $ runMaybeT $ getOauthTokens service code
+    case tokens of
+        Nothing -> throwError err403 
+        Just t -> do
+            updateTokens (userDBId user) t
+            etoken <- liftIO $ makeJWT (toUser user) jwts Nothing
+            case etoken of
+                Left e -> throwError err401
+                Right v -> return $ LoginResponse $ unpack v
+signupOauthHandler _ _ _ _ = throwError err400 
 
 signupHandler ::
     SignupUser ->
@@ -135,6 +151,7 @@ unprotected cs jwts =
          loginHandler cs jwts
     :<|> signupHandler
     :<|> loginOauthHandler jwts
+    :<|> signupOauthHandler jwts
 
 data AuthAPI mode = AuthAPI
     { protectedApi :: mode :- UserAuth :> Protected

api/src/Core/OIDC.hs

@@ -12,12 +12,11 @@ import Data.Text (Text, pack, unpack)
 import Network.HTTP.Simple (JSONException, addRequestHeader, getResponseBody, httpJSONEither, parseRequest, setRequestMethod, setRequestQueryString, setRequestBodyURLEncoded, setRequestBodyJSON, setRequestBodyLBS)
 import System.Environment.MrEnv (envAsBool, envAsInt, envAsInteger, envAsString)
 import Utils (lookupObjString, lookupObjObject, lookupObjInt)
-import Data.ByteString.Base64
 import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT))
 import Control.Monad.IO.Class (MonadIO(liftIO))
 import Control.Monad (MonadPlus (mzero))
 import Data.Aeson (decode)
-import Data.ByteString.Base64
+import Data.ByteString.Base64 ( encodeBase64 )
 import Data.Time (getCurrentTime, addUTCTime)
 data OAuth2Conf = OAuth2Conf
     { oauthClientId :: String

api/src/Repository/User.hs

@@ -36,8 +36,10 @@ getUserByToken t = do
                 Just tok -> providerId tok == providerId t
 
 
-createUser :: User' -> AppM [UserId]
-createUser user = runQuery (insert $ insertUser user)
+createUser :: User' -> AppM User'
+createUser user = do
+    ids <- runQuery (insert $ insertUser user)
+    getUserById' $ head ids
 
 getTokensByUserId :: UserId -> AppM [ExternalToken] 
 getTokensByUserId uid = do