feat: get provider id

Works for every service except anilist
2026-06-03 03:01:46 +00:00 · 2022-03-05 00:45:08 +01:00
parent 0705ca3185
commit 924ec6b425
2 changed files with 152 additions and 55 deletions
@@ -6,13 +6,16 @@ import qualified Data.ByteString.Char8 as B8
 import qualified Data.HashMap.Strict as HM

 import App (AppM)
-import Core.User (ExternalToken (ExternalToken), Service (Github, Discord, Spotify, Google, Twitter, Anilist))
+import Core.User (ExternalToken (ExternalToken, accessToken, providerId), Service (Github, Discord, 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 System.Environment.MrEnv (envAsBool, envAsInt, envAsInteger, envAsString)
-import Utils (lookupObjString)
+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))
 data OAuth2Conf = OAuth2Conf
    { oauthClientId :: String
    , oauthClientSecret :: String
@@ -32,6 +35,10 @@ tokenEndpoint code oc =
        , code
        ]

+liftMaybe :: (MonadPlus m) => Maybe a -> m a
+liftMaybe = maybe mzero return
+
+
 -- GITHUB
 getGithubConfig :: IO OAuth2Conf
 getGithubConfig =
@@ -40,8 +47,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
@@ -55,11 +62,31 @@ getGithubTokens code = do
                ]
            request'
    response <- httpJSONEither request
-    return $ case (getResponseBody response :: Either JSONException Object) of
-        Left _ -> Nothing
-        Right obj -> do
-            access <- lookupObjString obj "access_token"
-            Just $ ExternalToken (pack access) "" 0 Github
+    let (Right obj) = (getResponseBody response :: Either JSONException Object)
+    access <- liftMaybe $ lookupObjString obj "access_token"
+    let t = ExternalToken access "" 0 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
+    print $ accessToken t
+    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

 -- DISCORD
 getDiscordConfig :: IO OAuth2Conf
@@ -69,8 +96,8 @@ getDiscordConfig =
        <*> envAsString "DISCORD_SECRET" ""
        <*> pure "https://discord.com/api/oauth2/token"

-getDiscordTokens :: String -> IO (Maybe ExternalToken)
-getDiscordTokens code = do
+getDiscordTokens :: String -> MaybeT IO ExternalToken
+getDiscordTokens code = MaybeT $ do
    cfg <- getDiscordConfig
    let endpoint = tokenEndpoint code cfg
    request' <- parseRequest endpoint
@@ -86,12 +113,26 @@ getDiscordTokens code = do
                ]
            request'
    response <- httpJSONEither request
-    return $ case (getResponseBody response :: Either JSONException Object) of
-        Left _ -> Nothing
-        Right obj -> do
-            access <- lookupObjString obj "access_token"
-            refresh <- lookupObjString obj "refresh_token"
-            Just $ ExternalToken (pack access) (pack refresh) 0 Discord
+    let (Right obj) = (getResponseBody response :: Either JSONException Object)
+    access <- liftMaybe $ lookupObjString obj "access_token"
+    refresh <- liftMaybe $ lookupObjString obj "refresh_token"
+    let t = ExternalToken access refresh 0 Discord Nothing
+    discordId <- runMaybeT $ getDiscordId t
+    return $ Just $ t { providerId = discordId }
+
+
+getDiscordId :: ExternalToken -> MaybeT IO Text
+getDiscordId t = MaybeT $ do
+    let endpoint = "https://discord.com/api/users/@me"
+    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
@@ -101,8 +142,8 @@ 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
    let endpoint = tokenEndpoint code cfg
    request' <- parseRequest endpoint
@@ -118,12 +159,26 @@ getGoogleTokens code = do
                ]
            request'
    response <- httpJSONEither request
-    return $ case (getResponseBody response :: Either JSONException Object) of
-        Left _ -> Nothing
-        Right obj -> do
-            access <- lookupObjString obj "access_token"
-            refresh <- lookupObjString obj "refresh_token"
-            Just $ ExternalToken (pack access) (pack refresh) 0 Google
+    let (Right obj) = (getResponseBody response :: Either JSONException Object)
+    access <- liftMaybe $ lookupObjString obj "access_token"
+    refresh <- liftMaybe $ lookupObjString obj "refresh_token"
+    let t = ExternalToken access refresh 0 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
@@ -133,10 +188,9 @@ 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
-
    let basicAuth = encodeBase64 $ B8.pack $ oauthClientId cfg ++ ":" ++ oauthClientSecret cfg
    let endpoint = tokenEndpoint code cfg
    request' <- parseRequest endpoint
@@ -151,12 +205,24 @@ getSpotifyTokens code = do
                ]
            request'
    response <- httpJSONEither request
-    return $ case (getResponseBody response :: Either JSONException Object) of
-        Left _ -> Nothing
-        Right obj -> do
-            access <- lookupObjString obj "access_token"
-            refresh <- lookupObjString obj "refresh_token"
-            Just $ ExternalToken (pack access) (pack refresh) 0 Spotify
+    let (Right obj) = (getResponseBody response :: Either JSONException Object)
+    access <- liftMaybe $ lookupObjString obj "access_token"
+    refresh <- liftMaybe $ lookupObjString obj "refresh_token"
+    let t = ExternalToken access refresh 0 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
@@ -166,8 +232,8 @@ 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
    let basicAuth = encodeBase64 $ B8.pack $ "Basic " ++ oauthClientId cfg ++ ":" ++ oauthClientSecret cfg
    let endpoint = tokenEndpoint code cfg
@@ -184,12 +250,26 @@ getTwitterTokens code = do
                ]
            request'
    response <- httpJSONEither request
-    return $ case (getResponseBody response :: Either JSONException Object) of
-        Left _ -> Nothing
-        Right obj -> do
-            access <- lookupObjString obj "access_token"
-            refresh <- lookupObjString obj "refresh_token"
-            Just $ ExternalToken (pack access) (pack refresh) 0 Twitter
+    let (Right obj) = (getResponseBody response :: Either JSONException Object)
+    access <- liftMaybe $ lookupObjString obj "access_token"
+    refresh <- liftMaybe $ lookupObjString obj "refresh_token"
+    let t = ExternalToken access refresh 0 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
@@ -199,8 +279,8 @@ 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
    let endpoint = tokenEndpoint code cfg
    request' <- parseRequest endpoint
@@ -216,18 +296,30 @@ getAnilistTokens code = do
                ]
            request'
    response <- httpJSONEither request
-    return $ case (getResponseBody response :: Either JSONException Object) of
-        Left _ -> Nothing
-        Right obj -> do
-            access <- lookupObjString obj "access_token"
-            refresh <- lookupObjString obj "refresh_token"
-            Just $ ExternalToken (pack access) (pack refresh) 0 Anilist
-
+    let (Right obj) = (getResponseBody response :: Either JSONException Object)
+    access <- liftMaybe $ lookupObjString obj "access_token"
+    refresh <- liftMaybe $ lookupObjString obj "refresh_token"
+    let t = ExternalToken access refresh 0 Anilist Nothing
+    anilistId <- runMaybeT $ getAnilistId t
+    return $ Just $ t { providerId = anilistId }


+getAnilistId :: ExternalToken -> MaybeT IO Text
+getAnilistId 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)
+    dataBody <- liftMaybe $ lookupObjObject obj "data"
+    viewer <- liftMaybe $ lookupObjObject obj "Viewer"
+    return . Just . pack . show $ lookupObjInt viewer "id"

 -- General
-getOauthTokens :: Service -> String -> IO (Maybe ExternalToken)
+getOauthTokens :: Service -> String -> MaybeT IO ExternalToken
 getOauthTokens Github = getGithubTokens
 getOauthTokens Discord = getDiscordTokens
 getOauthTokens Spotify = getSpotifyTokens
@@ -25,15 +25,20 @@ import Data.Scientific ( toBoundedInteger )
 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


 lookupObjInt :: Object -> Text -> Maybe Int64
 lookupObjInt obj key = case Data.HashMap.Strict.lookup key obj of
-    Just (Number x) -> toBoundedInteger $ x
+    Just (Number x) -> toBoundedInteger x
    _ -> Nothing

 uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d