Merge branch 'master' of github.com:AnonymusRaccoon/Aeris into feat/reddit-worker

api/src/Api/About.hs

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

api/src/Api/Auth.hs

@@ -18,14 +18,18 @@ import Servant (
     Post,
     ReqBody,
     err401,
+    err400,
+    err403,
     throwError,
     type (:<|>) (..),
-    type (:>),
+    type (:>), Capture, QueryParam
  )
 
 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)
@@ -34,10 +38,10 @@ import Servant.Server.Generic (AsServerT)
 import Data.ByteString.Lazy.Char8 ( unpack )
 import Api.OIDC (OauthAPI, oauth)
 import App (AppM)
-import Core.User (User, UserId (UserId))
+import Core.User (User, UserId (UserId), Service)
 import Data.Text (pack)
 import Password (hashPassword'', toPassword, validatePassword')
-import Repository (createUser, getUserByName')
+import Repository (createUser, getUserByName', getUserByToken, updateTokens)
 import Utils (UserAuth, AuthRes)
 
 data LoginUser = LoginUser
@@ -57,15 +61,16 @@ newtype LoginResponse = LoginResponse
     }
     deriving (Eq, Show, Read, Generic)
 
+
+instance ToJSON LoginResponse
+instance FromJSON LoginResponse
+
 instance ToJSON LoginUser
 instance FromJSON LoginUser
 
 instance ToJSON SignupUser
 instance FromJSON SignupUser
 
-instance ToJSON LoginResponse
-instance FromJSON LoginResponse
-
 type Protected =
     "me" :> Get '[JSON] User
 
@@ -80,6 +85,14 @@ type Unprotected =
     :<|> "signup"
         :> ReqBody '[JSON] SignupUser
         :> Post '[JSON] NoContent
+    :<|> Capture "service" Service :> "signin"
+        :> QueryParam "code" String
+        :> Post '[JSON] LoginResponse
+    :<|> Capture "service" Service :> "signup"
+        :> QueryParam "code" String
+        :> ReqBody '[JSON] SignupUser
+        :> Post '[JSON] LoginResponse
+ 
 
 loginHandler ::
     CookieSettings ->
@@ -95,11 +108,35 @@ loginHandler cs jwts (LoginUser username p) = do
             case etoken of
                 Left e -> throwError err401
                 Right v -> return $ LoginResponse $ unpack v
-            {--mApplyCookies <- liftIO $ acceptLogin cs jwts (toUser usr)
-            case mApplyCookies of
-                Nothing -> throwError err401
-                Just applyCookies -> return $ applyCookies NoContent
-        --}else throwError err401
+        else throwError err401
+
+loginOauthHandler :: JWTSettings -> Service -> Maybe String -> AppM LoginResponse
+loginOauthHandler jwts _ Nothing = throwError err400
+loginOauthHandler jwts service (Just code) = do
+    tokens <- liftIO $ runMaybeT $ getOauthTokens service code
+    case tokens of
+        Nothing -> throwError err403 
+        Just t -> do
+            user <- getUserByToken t
+            etoken <- liftIO $ makeJWT (toUser user) jwts Nothing
+            case etoken of
+                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 ->
@@ -111,8 +148,10 @@ signupHandler (SignupUser name p) = do
 
 unprotected :: CookieSettings -> JWTSettings -> ServerT Unprotected AppM
 unprotected cs jwts =
-    loginHandler cs jwts
-        :<|> signupHandler
+         loginHandler cs jwts
+    :<|> signupHandler
+    :<|> loginOauthHandler jwts
+    :<|> signupOauthHandler jwts
 
 data AuthAPI mode = AuthAPI
     { protectedApi :: mode :- UserAuth :> Protected

api/src/Api/OIDC.hs

@@ -11,18 +11,20 @@ import Core.User (ExternalToken (ExternalToken, service), Service (Github, Spoti
 import Data.Text (pack)
 import Core.OIDC ( getOauthTokens )
 import Repository.User (updateTokens, getTokensByUserId, delTokens)
-import Servant (Capture, Get, GetNoContent, JSON, NoContent (NoContent), QueryParam, ServerT, err400, throwError, type (:<|>) ((:<|>)), type (:>), err401, err403, ServerError (errHeaders), err302, Delete)
+import Servant (Capture, Get, GetNoContent, JSON, NoContent (NoContent), QueryParam, ServerT, err400, throwError, type (:<|>) ((:<|>)), type (:>), err401, err403, ServerError (errHeaders), err302, Delete, Post)
 import Servant.API.Generic (type (:-))
 import Servant.Server.Generic (AsServerT)
 import Utils (UserAuth, AuthRes)
 import qualified Data.ByteString.Char8 as B8
-import Servant.Auth.Server (AuthResult(Authenticated))
+import Servant.Auth.Server (AuthResult(Authenticated), makeJWT)
 import System.Environment.MrEnv (envAsString)
+import Control.Monad.Trans.Maybe (MaybeT(runMaybeT))
+import Db.User (toUser)
 
 oauthHandler :: AuthRes -> Service -> Maybe String -> AppM NoContent
 oauthHandler _ _ Nothing = throwError err400
 oauthHandler (Authenticated (User uid _ _)) service (Just code) = do
-    tokens <- liftIO $ getOauthTokens service code
+    tokens <- liftIO $ runMaybeT $ getOauthTokens service code
     case tokens of
         Nothing -> throwError err403 
         Just t -> do
@@ -88,7 +90,7 @@ type OauthAPI = UserAuth :> Capture "service" Service :> QueryParam "code" Strin
             :<|> Capture "service" Service :> "url" :> QueryParam "redirect_uri" String :> Get '[JSON] NoContent
             :<|> UserAuth :> "services" :> Get '[JSON] [String]
             :<|> "redirect" :> QueryParam "code" String :> QueryParam "state" String :> Get '[JSON] NoContent
- 
+
 oauth :: ServerT OauthAPI AppM
 oauth = oauthHandler
     :<|> oauthDelHandler

api/src/Api/Worker.hs

@@ -114,7 +114,7 @@ refreshHandler :: Service -> UserId -> Maybe String -> RefreshBody -> AppM NoCon
 refreshHandler service uid (Just key) (RefreshBody at rt ex) = do
     k <- liftIO $ envAsString "WORKER_API_KEY" ""
     if k == key then do
-        updateTokens uid $ ExternalToken at rt ex service
+        updateTokens uid $ ExternalToken at rt ex service Nothing
         return NoContent 
     else throwError err403  
 refreshHandler _ _ _ _ = throwError err403

api/src/Core/OIDC.hs

@@ -6,13 +6,17 @@ import qualified Data.ByteString.Char8 as B8
 import qualified Data.HashMap.Strict as HM
 
 import App (AppM)
-import Core.User (ExternalToken (ExternalToken, expiresAt), Service (Github, Reddit, Spotify, Google, Twitter, Anilist))
+import Core.User (ExternalToken (ExternalToken, accessToken, providerId, expiresAt), Service (Github, Reddit, Spotify, Google, Twitter, Anilist))
 import Data.Aeson.Types (Object, Value (String))
 import Data.Text (Text, pack, unpack)
-import Network.HTTP.Simple (JSONException, addRequestHeader, getResponseBody, httpJSONEither, parseRequest, setRequestMethod, setRequestQueryString, setRequestBodyURLEncoded)
+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, lookupObjInt)
-import Data.ByteString.Base64
+import Utils (lookupObjString, lookupObjObject, lookupObjInt)
+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 ( encodeBase64 )
 import Data.Time (getCurrentTime, addUTCTime)
 data OAuth2Conf = OAuth2Conf
     { oauthClientId :: String
@@ -33,6 +37,10 @@ tokenEndpoint code oc =
         , code
         ]
 
+liftMaybe :: (MonadPlus m) => Maybe a -> m a
+liftMaybe = maybe mzero return
+
+
 -- GITHUB
 getGithubConfig :: IO OAuth2Conf
 getGithubConfig =
@@ -41,8 +49,8 @@ getGithubConfig =
         <*> envAsString "GITHUB_SECRET" ""
         <*> pure "https://github.com/login/oauth/access_token"
 
-getGithubTokens :: String -> IO (Maybe ExternalToken)
-getGithubTokens code = do
+getGithubTokens :: String -> MaybeT IO ExternalToken
+getGithubTokens code = MaybeT $ do
     gh <- getGithubConfig
     let endpoint = tokenEndpoint code gh
     request' <- parseRequest endpoint
@@ -57,11 +65,30 @@ getGithubTokens code = do
             request'
     response <- httpJSONEither request
     currTime <- getCurrentTime
-    return $ case (getResponseBody response :: Either JSONException Object) of
-        Left _ -> Nothing
-        Right obj -> do
-            access <- lookupObjString obj "access_token"
-            Just $ ExternalToken (pack access) "" currTime Github
+    let (Right obj) = (getResponseBody response :: Either JSONException Object)
+    access <- liftMaybe $ lookupObjString obj "access_token"
+    let t = ExternalToken access "" currTime Github Nothing
+    githubId <- runMaybeT $ getGithubId t
+    return $ Just $ t { providerId = githubId }
+
+rightToMaybe :: Either a b -> Maybe b
+rightToMaybe = either (const Nothing) Just
+
+getGithubId :: ExternalToken -> MaybeT IO Text
+getGithubId t = MaybeT $ do
+    let endpoint = "https://api.github.com/user"
+    request' <- parseRequest endpoint
+    let request =
+            addRequestHeader "Authorization" (B8.pack ("token " ++ unpack (accessToken t))) $
+            addRequestHeader "Accept" "application/json" $
+            addRequestHeader "User-Agent" "aeris-server"
+            request'
+    response <- httpJSONEither request
+    case (getResponseBody response :: Either JSONException Object) of
+        Left err -> return Nothing
+        Right obj -> case lookupObjInt obj "id" of
+            Just githubId -> return $ Just $ pack $ show githubId
+            _ -> return Nothing
 
 -- Reddit
 getRedditConfig :: IO OAuth2Conf
@@ -71,9 +98,10 @@ getRedditConfig =
         <*> envAsString "REDDIT_SECRET" ""
         <*> pure "https://www.reddit.com/api/v1/access_token"
 
-getRedditTokens :: String -> IO (Maybe ExternalToken)
-getRedditTokens code = do
+getRedditTokens :: String -> MaybeT IO ExternalToken
+getRedditTokens code = MaybeT $ do
     cfg <- getRedditConfig
+    backUrl <- envAsString "BACK_URL" ""
     let basicAuth = encodeBase64 $ B8.pack $ oauthClientId cfg ++ ":" ++ oauthClientSecret cfg
     let endpoint = tokenEndpoint code cfg
     request' <- parseRequest endpoint
@@ -84,19 +112,31 @@ getRedditTokens code = do
             addRequestHeader "Authorization" (B8.pack $ "Basic " ++ unpack basicAuth) $
             setRequestBodyURLEncoded
                 [ ("grant_type", "authorization_code")
-                , ("redirect_uri", "http://localhost:8080/auth/redirect")
+                , ("redirect_uri", B8.pack $ backUrl ++ "auth/redirect")
                 ]
             request'
     response <- httpJSONEither request
+    let (Right obj) = (getResponseBody response :: Either JSONException Object)
+    access <- liftMaybe $ lookupObjString obj "access_token"
+    refresh <- liftMaybe $ lookupObjString obj "refresh_token"
     currTime <- getCurrentTime
-    return $ case (getResponseBody response :: Either JSONException Object) of
-        Left _ -> Nothing
-        Right obj -> do
-            access <- lookupObjString obj "access_token"
-            refresh <- lookupObjString obj "refresh_token"
-            expiresIn <- lookupObjInt obj "expires_in"
-            let expiresAt = addUTCTime (fromInteger . fromIntegral $ expiresIn) currTime
-            Just $ ExternalToken (pack access) (pack refresh) expiresAt Reddit
+    expiresIn <- liftMaybe $ lookupObjInt obj "expires_in"
+    let expiresAt = addUTCTime (fromInteger . fromIntegral $ expiresIn) currTime
+    let t = ExternalToken access refresh expiresAt Reddit Nothing
+    id <- runMaybeT $ getRedditId t
+    return $ Just $ t { providerId = id }
+
+getRedditId :: ExternalToken -> MaybeT IO Text
+getRedditId t = MaybeT $ do
+    let endpoint = "https://discord.com/api/users/@me" -- todo fix this
+    request' <- parseRequest endpoint
+    let request =
+            addRequestHeader "Accept" "application/json" $
+            addRequestHeader "Authorization" (B8.pack $ "Bearer " ++ unpack (accessToken t))
+            request'
+    response <- httpJSONEither request
+    let (Right obj) = (getResponseBody response :: Either JSONException Object)
+    return $ lookupObjString obj "id"
 
 -- GOOGLE
 getGoogleConfig :: IO OAuth2Conf
@@ -106,9 +146,10 @@ getGoogleConfig =
         <*> envAsString "GOOGLE_SECRET" ""
         <*> pure "https://oauth2.googleapis.com/token"
 
-getGoogleTokens :: String -> IO (Maybe ExternalToken)
-getGoogleTokens code = do
+getGoogleTokens :: String -> MaybeT IO ExternalToken
+getGoogleTokens code = MaybeT $ do
     cfg <- getGoogleConfig
+    backUrl <- envAsString "BACK_URL" ""
     let endpoint = tokenEndpoint code cfg
     request' <- parseRequest endpoint
     let request =
@@ -119,19 +160,33 @@ getGoogleTokens code = do
                 , ("client_secret", B8.pack . oauthClientSecret $ cfg)
                 , ("code", B8.pack code)
                 , ("grant_type", "authorization_code")
-                , ("redirect_uri", "http://localhost:8080/auth/redirect")
+                , ("redirect_uri", B8.pack $ backUrl ++ "auth/redirect")
                 ]
             request'
     response <- httpJSONEither request
     currTime <- getCurrentTime
-    return $ case (getResponseBody response :: Either JSONException Object) of
-        Left _ -> Nothing
-        Right obj -> do
-            access <- lookupObjString obj "access_token"
-            refresh <- lookupObjString obj "refresh_token"
-            expiresIn <- lookupObjInt obj "expires_in"
-            let expiresAt = addUTCTime (fromInteger . fromIntegral $ expiresIn) currTime
-            Just $ ExternalToken (pack access) (pack refresh) expiresAt Google
+    let (Right obj) = (getResponseBody response :: Either JSONException Object)
+    access <- liftMaybe $ lookupObjString obj "access_token"
+    refresh <- liftMaybe $ lookupObjString obj "refresh_token"
+    expiresIn <- liftMaybe $ lookupObjInt obj "expires_in"
+    let expiresAt = addUTCTime (fromInteger . fromIntegral $ expiresIn) currTime
+    let t = ExternalToken access refresh expiresAt Google Nothing
+    googleId <- runMaybeT $ getGoogleId t
+    return $ Just $ t { providerId = googleId }
+
+getGoogleId :: ExternalToken -> MaybeT IO Text
+getGoogleId t = MaybeT $ do
+    let endpoint = "https://oauth2.googleapis.com/tokeninfo"
+    request' <- parseRequest endpoint
+    let request =
+            addRequestHeader "Accept" "application/json" $
+            setRequestQueryString
+                [ ("access_token", Just . B8.pack . unpack $ accessToken t)
+                ]
+            request'
+    response <- httpJSONEither request
+    let (Right obj) = (getResponseBody response :: Either JSONException Object)
+    return $ lookupObjString obj "sub"
 
 -- SPOTIFY
 getSpotifyConfig :: IO OAuth2Conf
@@ -141,10 +196,10 @@ getSpotifyConfig =
         <*> envAsString "SPOTIFY_SECRET" ""
         <*> pure "https://accounts.spotify.com/api/token"
 
-getSpotifyTokens :: String -> IO (Maybe ExternalToken)
-getSpotifyTokens code = do
+getSpotifyTokens :: String -> MaybeT IO ExternalToken
+getSpotifyTokens code = MaybeT $ do
     cfg <- getSpotifyConfig
-
+    backUrl <- envAsString "BACK_URL" ""
     let basicAuth = encodeBase64 $ B8.pack $ oauthClientId cfg ++ ":" ++ oauthClientSecret cfg
     let endpoint = tokenEndpoint code cfg
     request' <- parseRequest endpoint
@@ -155,19 +210,31 @@ getSpotifyTokens code = do
             setRequestBodyURLEncoded
                 [ ("code", B8.pack code)
                 , ("grant_type", "authorization_code")
-                , ("redirect_uri", "http://localhost:8080/auth/redirect")
+                , ("redirect_uri", B8.pack $ backUrl ++ "auth/redirect")
                 ]
             request'
     response <- httpJSONEither request
     currTime <- getCurrentTime
-    return $ case (getResponseBody response :: Either JSONException Object) of
-        Left _ -> Nothing
-        Right obj -> do
-            access <- lookupObjString obj "access_token"
-            refresh <- lookupObjString obj "refresh_token"
-            expiresIn <- lookupObjInt obj "expires_in"
-            let expiresAt = addUTCTime (fromInteger . fromIntegral $ expiresIn) currTime
-            Just $ ExternalToken (pack access) (pack refresh) expiresAt Spotify
+    let (Right obj) = (getResponseBody response :: Either JSONException Object)
+    access <- liftMaybe $ lookupObjString obj "access_token"
+    refresh <- liftMaybe $ lookupObjString obj "refresh_token"
+    expiresIn <- liftMaybe $ lookupObjInt obj "expires_in"
+    let expiresAt = addUTCTime (fromInteger . fromIntegral $ expiresIn) currTime
+    let t = ExternalToken access refresh expiresAt Spotify Nothing
+    spotifyId <- runMaybeT $ getSpotifyId t
+    return $ Just $ t { providerId = spotifyId }
+
+getSpotifyId :: ExternalToken -> MaybeT IO Text
+getSpotifyId t = MaybeT $ do
+    let endpoint = "https://api.spotify.com/v1/me"
+    request' <- parseRequest endpoint
+    let request =
+            addRequestHeader "Content-Type" "application/json" $
+            addRequestHeader "Authorization" (B8.pack $ "Bearer " ++ unpack (accessToken t))
+            request'
+    response <- httpJSONEither request
+    let (Right obj) = (getResponseBody response :: Either JSONException Object)
+    return $ lookupObjString obj "id"
 
 -- TWITTER
 getTwitterConfig :: IO OAuth2Conf
@@ -177,9 +244,10 @@ getTwitterConfig =
         <*> envAsString "TWITTER_SECRET" ""
         <*> pure "https://api.twitter.com/2/oauth2/token"
 
-getTwitterTokens :: String -> IO (Maybe ExternalToken)
-getTwitterTokens code = do
+getTwitterTokens :: String -> MaybeT IO ExternalToken
+getTwitterTokens code = MaybeT $ do
     cfg <- getTwitterConfig
+    backUrl <- envAsString "BACK_URL" ""
     let basicAuth = encodeBase64 $ B8.pack $ "Basic " ++ oauthClientId cfg ++ ":" ++ oauthClientSecret cfg
     let endpoint = tokenEndpoint code cfg
     request' <- parseRequest endpoint
@@ -190,20 +258,34 @@ getTwitterTokens code = do
             setRequestBodyURLEncoded
                 [ ("code", B8.pack code)
                 , ("grant_type", "authorization_code")
-                , ("redirect_uri", "http://localhost:8080/auth/redirect")
+                , ("redirect_uri", B8.pack $ backUrl ++ "auth/redirect")
                 , ("code_verifier", "challenge")
                 ]
             request'
     response <- httpJSONEither request
     currTime <- getCurrentTime
-    return $ case (getResponseBody response :: Either JSONException Object) of
-        Left _ -> Nothing
-        Right obj -> do
-            access <- lookupObjString obj "access_token"
-            refresh <- lookupObjString obj "refresh_token"
-            expiresIn <- lookupObjInt obj "expires_in"
-            let expiresAt = addUTCTime (fromInteger . fromIntegral $ expiresIn) currTime
-            Just $ ExternalToken (pack access) (pack refresh) expiresAt Twitter
+    let (Right obj) = (getResponseBody response :: Either JSONException Object)
+    access <- liftMaybe $ lookupObjString obj "access_token"
+    refresh <- liftMaybe $ lookupObjString obj "refresh_token"
+    expiresIn <- liftMaybe $ lookupObjInt obj "expires_in"
+    let expiresAt = addUTCTime (fromInteger . fromIntegral $ expiresIn) currTime
+    let t = ExternalToken access refresh expiresAt Twitter Nothing
+    twitterId <- runMaybeT $ getTwitterId t
+    return $ Just $ t { providerId = twitterId }
+
+getTwitterId :: ExternalToken -> MaybeT IO Text
+getTwitterId t = MaybeT $ do
+    let endpoint = "https://api.twitter.com/2/users/me"
+    request' <- parseRequest endpoint
+    let request =
+            addRequestHeader "Content-Type" "application/json" $
+            addRequestHeader "Authorization" (B8.pack $ "Bearer " ++ unpack (accessToken t))
+            request'
+    response <- httpJSONEither request
+    let (Right obj) = (getResponseBody response :: Either JSONException Object)
+    case lookupObjObject obj "data" of
+        Just dataBody -> return $ lookupObjString dataBody "id"
+        _ -> return Nothing
 
 -- ANILIST
 getAnilistConfig :: IO OAuth2Conf
@@ -213,9 +295,10 @@ getAnilistConfig =
         <*> envAsString "ANILIST_SECRET" ""
         <*> pure "https://anilist.co/api/v2/oauth/token"
 
-getAnilistTokens :: String -> IO (Maybe ExternalToken)
-getAnilistTokens code = do
+getAnilistTokens :: String -> MaybeT IO ExternalToken
+getAnilistTokens code = MaybeT $ do
     cfg <- getAnilistConfig
+    backUrl <- envAsString "BACK_URL" ""
     let endpoint = tokenEndpoint code cfg
     request' <- parseRequest endpoint
     let request =
@@ -226,25 +309,45 @@ getAnilistTokens code = do
                 , ("client_secret", B8.pack . oauthClientSecret $ cfg)
                 , ("code", B8.pack code)
                 , ("grant_type", "authorization_code")
-                , ("redirect_uri", "http://localhost:8080/auth/redirect")
+                , ("redirect_uri", B8.pack $ backUrl ++ "auth/redirect")
                 ]
             request'
     response <- httpJSONEither request
     currTime <- getCurrentTime
-    return $ case (getResponseBody response :: Either JSONException Object) of
-        Left _ -> Nothing
-        Right obj -> do
-            access <- lookupObjString obj "access_token"
-            refresh <- lookupObjString obj "refresh_token"
-            expiresIn <- lookupObjInt obj "expires_in"
-            let expiresAt = addUTCTime (fromInteger . fromIntegral $ expiresIn) currTime
-            Just $ ExternalToken (pack access) (pack refresh) expiresAt Anilist
-
-
+    let (Right obj) = (getResponseBody response :: Either JSONException Object)
+    access <- liftMaybe $ lookupObjString obj "access_token"
+    refresh <- liftMaybe $ lookupObjString obj "refresh_token"
+    expiresIn <- liftMaybe $ lookupObjInt obj "expires_in"
+    let expiresAt = addUTCTime (fromInteger . fromIntegral $ expiresIn) currTime
+    let t = ExternalToken access refresh expiresAt Anilist Nothing
+    anilistId <- runMaybeT $ getAnilistId t
+    return $ Just $ t { providerId = anilistId }
 
+getAnilistId :: ExternalToken -> MaybeT IO Text
+getAnilistId t = MaybeT $ do
+    let endpoint = "https://graphql.anilist.co"
+    request' <- parseRequest endpoint
+    let query = (decode "{Viewer {id,}}" :: Maybe Object)
+    let request =
+            addRequestHeader "Content-Type" "application/json" $
+            addRequestHeader "Authorization" (B8.pack $ "Bearer " ++ unpack (accessToken t)) $
+            addRequestHeader "User-Agent" "aeris-server" $
+            setRequestMethod "POST" $
+            setRequestBodyLBS "{\"query\": \"{Viewer {id}}\"}" 
+            request'
+    response <- httpJSONEither request
+    let (Right obj) = (getResponseBody response :: Either JSONException Object)
+    case lookupObjObject obj "data" of
+        Just dataBody -> case liftMaybe $ lookupObjObject dataBody "Viewer" of 
+            Just viewer -> case lookupObjInt viewer "id" of
+                Just anilistId -> return . Just . pack . show $ anilistId
+                _ -> return Nothing 
+            _ -> return Nothing
+        _ -> return Nothing
+        
 
 -- General
-getOauthTokens :: Service -> String -> IO (Maybe ExternalToken)
+getOauthTokens :: Service -> String -> MaybeT IO ExternalToken
 getOauthTokens Github = getGithubTokens
 getOauthTokens Reddit = getRedditTokens
 getOauthTokens Spotify = getSpotifyTokens

api/src/Core/User.hs

@@ -44,6 +44,7 @@ data ExternalToken = ExternalToken
     , refreshToken :: Text
     , expiresAt :: UTCTime
     , service :: Service
+    , providerId :: Maybe Text 
     }
     deriving (Eq, Show, Generic)
     deriving anyclass (ToJSON, FromJSON)

api/src/Repository/User.hs

@@ -1,12 +1,14 @@
 module Repository.User where
 
 import App (AppM)
-import Core.User (ExternalToken, UserId, Service)
+import Core.User (ExternalToken (service, providerId), UserId, Service)
 import Data.Text (Text)
-import Db.User (User', getUserByName, getUserTokensById, insertUser, selectAllUser, updateUserTokens, getUserById, updateDelTokens)
+import Db.User (User', getUserByName, getUserTokensById, insertUser, selectAllUser, updateUserTokens, getUserById, updateDelTokens, UserDB (externalTokens))
 import Rel8 (insert, select, update, limit, lit)
 import Repository.Utils (runQuery)
 import Data.Int (Int64)
+import Data.List (find)
+import Servant (err401, throwError)
 
 users :: AppM [User']
 users = runQuery (select selectAllUser)
@@ -19,8 +21,25 @@ getUserById' uid = do
     res <- runQuery (select $ limit 1 $ getUserById (lit uid))
     return $ head res
 
-createUser :: User' -> AppM [UserId]
-createUser user = runQuery (insert $ insertUser user)
+getUserByToken :: ExternalToken  -> AppM User'
+getUserByToken t = do
+    users' <- users
+    case find findByToken users' of
+        Nothing -> throwError err401
+        Just x -> return x
+    where
+        findByToken :: User' -> Bool
+        findByToken usr = do
+            let userTokens = externalTokens usr
+            case find (\tok -> service tok == service t) userTokens of
+                Nothing -> False
+                Just tok -> providerId tok == providerId t
+
+
+createUser :: User' -> AppM User'
+createUser user = do
+    ids <- runQuery (insert $ insertUser user)
+    getUserById' $ head ids
 
 getTokensByUserId :: UserId -> AppM [ExternalToken] 
 getTokensByUserId uid = do

api/src/Utils.hs

@@ -3,6 +3,7 @@
 {-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}
 {-# LANGUAGE FlexibleInstances #-}
 
+
 module Utils where
 
 import Data.Aeson.Types (Value (String), Object)
@@ -18,16 +19,22 @@ import Db.Pipeline (Pipeline (Pipeline), PipelineId (PipelineId), pipelineLastTr
 import Core.Pipeline (PipelineParams (PipelineParams))
 import Data.Time (UTCTime (UTCTime), fromGregorian, secondsToDiffTime)
 import Data.Default (Default, def)
-import Data.Aeson (Value(Number, Object), decode)
+import Data.Aeson (Value(Number, Object), decode, ToJSON, FromJSON)
 import Data.Int (Int64)
 import Data.Scientific ( toBoundedInteger )
+import GHC.Generics (Generic)
 
 mapInd :: (a -> Int -> b) -> [a] -> [b]
 mapInd f l = zipWith f l [0 ..]
 
-lookupObjString :: Object -> Text -> Maybe String
+lookupObjString :: Object -> Text -> Maybe Text
 lookupObjString obj key = case Data.HashMap.Strict.lookup key obj of
-    Just (String x) -> Just . unpack $ x
+    Just (String x) -> Just x
+    _ -> Nothing
+
+lookupObjObject :: Object -> Text -> Maybe Object
+lookupObjObject obj key = case Data.HashMap.Strict.lookup key obj of
+    Just (Object x) -> Just x
     _ -> Nothing
 
 
@@ -55,4 +62,5 @@ instance Default (Pipeline Identity) where
     }
 
 type UserAuth = Servant.Auth.Server.Auth '[JWT] User
-type AuthRes = Servant.Auth.Server.AuthResult User
+type AuthRes = Servant.Auth.Server.AuthResult User
+