From 924ec6b4251cb665fe825011a71ac9f4639fd6ce Mon Sep 17 00:00:00 2001 From: GitBluub Date: Sat, 5 Mar 2022 00:45:08 +0100 Subject: [PATCH] feat: get provider id Works for every service except anilist --- api/src/Core/OIDC.hs | 196 +++++++++++++++++++++++++++++++------------ api/src/Utils.hs | 11 ++- 2 files changed, 152 insertions(+), 55 deletions(-) diff --git a/api/src/Core/OIDC.hs b/api/src/Core/OIDC.hs index 15affb2..51222ef 100644 --- a/api/src/Core/OIDC.hs +++ b/api/src/Core/OIDC.hs @@ -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 diff --git a/api/src/Utils.hs b/api/src/Utils.hs index 16a04be..a3565d2 100644 --- a/api/src/Utils.hs +++ b/api/src/Utils.hs @@ -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