{-# LANGUAGE QuasiQuotes #-}

module Network.Globus.Auth where

import Control.Monad.Catch (MonadCatch, MonadThrow)
import Data.Aeson
import Data.Aeson.Types
import Data.Function ((&))
import Data.List qualified as L
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NE
import Data.Tagged
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding (encodeUtf8)
import Effectful (MonadIO)
import GHC.Generics (Generic)
import Network.Globus.Request as Request
import Network.Globus.Types
import Network.HTTP.Client (Manager, applyBasicAuth)
import Network.HTTP.Types (Header, methodPost)
import Network.URI.Static (uri)


-- | The end user must visit this url
authorizationUrl :: Token ClientId -> Uri Redirect -> NonEmpty Scope -> State -> Uri Authorization
authorizationUrl :: Token 'ClientId
-> Uri 'Redirect -> NonEmpty Scope -> State -> Uri 'Authorization
authorizationUrl (Tagged Text
cid) Uri 'Redirect
red NonEmpty Scope
scopes (State Text
st) =
  -- TODO: does the auth url need the security token?
  Uri 'Authorization
authEndpoint Uri 'Authorization -> String -> Uri 'Authorization
forall {k} (a :: k). Uri a -> String -> Uri a
/: String
"authorize"
    Uri 'Authorization
-> (Uri 'Authorization -> Uri 'Authorization) -> Uri 'Authorization
forall a b. a -> (a -> b) -> b
& Text -> Text -> Uri 'Authorization -> Uri 'Authorization
forall {k} (a :: k). Text -> Text -> Uri a -> Uri a
param Text
"client_id" Text
cid
    Uri 'Authorization
-> (Uri 'Authorization -> Uri 'Authorization) -> Uri 'Authorization
forall a b. a -> (a -> b) -> b
& Text -> Text -> Uri 'Authorization -> Uri 'Authorization
forall {k} (a :: k). Text -> Text -> Uri a -> Uri a
param Text
"response_type" Text
"code"
    Uri 'Authorization
-> (Uri 'Authorization -> Uri 'Authorization) -> Uri 'Authorization
forall a b. a -> (a -> b) -> b
& Text -> Text -> Uri 'Authorization -> Uri 'Authorization
forall {k} (a :: k). Text -> Text -> Uri a -> Uri a
param Text
"scope" (Text -> [Text] -> Text
Text.intercalate Text
" " (Scope -> Text
scopeText (Scope -> Text) -> [Scope] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty Scope -> [Scope]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Scope
scopes))
    Uri 'Authorization
-> (Uri 'Authorization -> Uri 'Authorization) -> Uri 'Authorization
forall a b. a -> (a -> b) -> b
& Text -> Text -> Uri 'Authorization -> Uri 'Authorization
forall {k} (a :: k). Text -> Text -> Uri a -> Uri a
param Text
"state" Text
st
    Uri 'Authorization
-> (Uri 'Authorization -> Uri 'Authorization) -> Uri 'Authorization
forall a b. a -> (a -> b) -> b
& Uri 'Redirect -> Uri 'Authorization -> Uri 'Authorization
forall {k} (a :: k). Uri 'Redirect -> Uri a -> Uri a
redirectUri Uri 'Redirect
red


fetchAccessTokens :: (MonadIO m, MonadThrow m, MonadCatch m) => Manager -> Token ClientId -> Token ClientSecret -> Uri Redirect -> Token Exchange -> m (NonEmpty TokenItem)
fetchAccessTokens :: forall (m :: * -> *).
(MonadIO m, MonadThrow m, MonadCatch m) =>
Manager
-> Token 'ClientId
-> Token 'ClientSecret
-> Uri 'Redirect
-> Token 'Exchange
-> m (NonEmpty TokenItem)
fetchAccessTokens Manager
mgr (Tagged Text
cid) (Tagged Text
sec) Uri 'Redirect
red (Tagged Text
code) = do
  req <- Method -> Uri 'Tokens -> [Header] -> RequestBody -> m Request
forall {k} (m :: * -> *) (a :: k).
(MonadThrow m, MonadCatch m) =>
Method -> Uri a -> [Header] -> RequestBody -> m Request
Request.request Method
methodPost Uri 'Tokens
tokenUri [] RequestBody
""
  TokenResponse toks <- sendJSON mgr (req & applyBasicAuth (encodeUtf8 cid) (encodeUtf8 sec))
  pure toks
 where
  tokenEndpoint :: Uri Tokens
  tokenEndpoint :: Uri 'Tokens
tokenEndpoint = URI -> Uri 'Tokens
forall {k} (s :: k) b. b -> Tagged s b
Tagged (URI -> Uri 'Tokens) -> URI -> Uri 'Tokens
forall a b. (a -> b) -> a -> b
$ [uri|https://auth.globus.org/v2/oauth2/token|]

  tokenUri :: Uri Tokens
  tokenUri :: Uri 'Tokens
tokenUri =
    Uri 'Tokens
tokenEndpoint
      Uri 'Tokens -> (Uri 'Tokens -> Uri 'Tokens) -> Uri 'Tokens
forall a b. a -> (a -> b) -> b
& Text -> Text -> Uri 'Tokens -> Uri 'Tokens
forall {k} (a :: k). Text -> Text -> Uri a -> Uri a
param Text
"grant_type" Text
"authorization_code"
      Uri 'Tokens -> (Uri 'Tokens -> Uri 'Tokens) -> Uri 'Tokens
forall a b. a -> (a -> b) -> b
& Text -> Text -> Uri 'Tokens -> Uri 'Tokens
forall {k} (a :: k). Text -> Text -> Uri a -> Uri a
param Text
"code" Text
code
      Uri 'Tokens -> (Uri 'Tokens -> Uri 'Tokens) -> Uri 'Tokens
forall a b. a -> (a -> b) -> b
& Uri 'Redirect -> Uri 'Tokens -> Uri 'Tokens
forall {k} (a :: k). Uri 'Redirect -> Uri a -> Uri a
redirectUri Uri 'Redirect
red


redirectUri :: Uri Redirect -> Uri a -> Uri a
redirectUri :: forall {k} (a :: k). Uri 'Redirect -> Uri a -> Uri a
redirectUri Uri 'Redirect
red = Text -> Text -> Uri a -> Uri a
forall {k} (a :: k). Text -> Text -> Uri a -> Uri a
param Text
"redirect_uri" (Uri 'Redirect -> Text
forall {k} (a :: k). Uri a -> Text
renderUri Uri 'Redirect
red)


-- | fetchAccessTokens returns a non-empty list matching the scopes
newtype TokenResponse = TokenResponse (NonEmpty TokenItem)
  deriving (Int -> TokenResponse -> ShowS
[TokenResponse] -> ShowS
TokenResponse -> String
(Int -> TokenResponse -> ShowS)
-> (TokenResponse -> String)
-> ([TokenResponse] -> ShowS)
-> Show TokenResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TokenResponse -> ShowS
showsPrec :: Int -> TokenResponse -> ShowS
$cshow :: TokenResponse -> String
show :: TokenResponse -> String
$cshowList :: [TokenResponse] -> ShowS
showList :: [TokenResponse] -> ShowS
Show)


instance FromJSON TokenResponse where
  parseJSON :: Value -> Parser TokenResponse
parseJSON = String
-> (Object -> Parser TokenResponse)
-> Value
-> Parser TokenResponse
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"TokenResponse" ((Object -> Parser TokenResponse) -> Value -> Parser TokenResponse)
-> (Object -> Parser TokenResponse)
-> Value
-> Parser TokenResponse
forall a b. (a -> b) -> a -> b
$ \Object
m -> do
    token <- Value -> Parser TokenItem
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> Parser TokenItem) -> Value -> Parser TokenItem
forall a b. (a -> b) -> a -> b
$ Object -> Value
Object Object
m :: Parser TokenItem
    other <- m .: "other_tokens"
    pure $ TokenResponse $ token :| other


scopeToken :: Scope -> NonEmpty TokenItem -> Maybe (Token Access)
scopeToken :: Scope -> NonEmpty TokenItem -> Maybe (Token 'Access)
scopeToken Scope
s NonEmpty TokenItem
ts = do
  item <- (TokenItem -> Bool) -> [TokenItem] -> Maybe TokenItem
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (\TokenItem
i -> Scopes -> Bool
hasScope TokenItem
i.scope) ([TokenItem] -> Maybe TokenItem) -> [TokenItem] -> Maybe TokenItem
forall a b. (a -> b) -> a -> b
$ NonEmpty TokenItem -> [TokenItem]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty TokenItem
ts
  pure item.access_token
 where
  hasScope :: Scopes -> Bool
hasScope (Scopes NonEmpty Scope
ss) = Scope
s Scope -> NonEmpty Scope -> Bool
forall a. Eq a => a -> NonEmpty a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` NonEmpty Scope
ss


-- | You MUST include the OpenId Scope for this to work
fetchUserInfo :: (MonadIO m, MonadCatch m, MonadThrow m) => Manager -> Token OpenId -> m UserInfoResponse
fetchUserInfo :: forall (m :: * -> *).
(MonadIO m, MonadCatch m, MonadThrow m) =>
Manager -> Token 'OpenId -> m UserInfoResponse
fetchUserInfo Manager
mgr Token 'OpenId
to = do
  req <- Method
-> Uri 'Authorization -> [Header] -> RequestBody -> m Request
forall {k} (m :: * -> *) (a :: k).
(MonadThrow m, MonadCatch m) =>
Method -> Uri a -> [Header] -> RequestBody -> m Request
Request.request Method
methodPost (Uri 'Authorization
authEndpoint Uri 'Authorization -> String -> Uri 'Authorization
forall {k} (a :: k). Uri a -> String -> Uri a
/: String
"userinfo") [Token 'OpenId -> Header
identityAuth Token 'OpenId
to] RequestBody
""
  sendJSON mgr req


authEndpoint :: Uri Authorization
authEndpoint :: Uri 'Authorization
authEndpoint = URI -> Uri 'Authorization
forall {k} (s :: k) b. b -> Tagged s b
Tagged (URI -> Uri 'Authorization) -> URI -> Uri 'Authorization
forall a b. (a -> b) -> a -> b
$ [uri|https://auth.globus.org/v2/oauth2|]


identityAuth :: Token OpenId -> Header
identityAuth :: Token 'OpenId -> Header
identityAuth = Token 'OpenId -> Header
forall {k} (a :: k). Token a -> Header
oAuth2Bearer


--  where
--   tokenEndpoint :: Req.Url 'Https
--   tokenEndpoint = https "auth.globus.org" /: "v2" /: "oauth2" /: "token"
--
data UserInfoResponse = UserInfoResponse
  { UserInfoResponse -> UserInfo
info :: UserInfo
  , UserInfoResponse -> Maybe UserEmail
email :: Maybe UserEmail
  , UserInfoResponse -> Maybe UserProfile
profile :: Maybe UserProfile
  }


instance FromJSON UserInfoResponse where
  parseJSON :: Value -> Parser UserInfoResponse
parseJSON = String
-> (Object -> Parser UserInfoResponse)
-> Value
-> Parser UserInfoResponse
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"UserInfo" ((Object -> Parser UserInfoResponse)
 -> Value -> Parser UserInfoResponse)
-> (Object -> Parser UserInfoResponse)
-> Value
-> Parser UserInfoResponse
forall a b. (a -> b) -> a -> b
$ \Object
m -> do
    info <- Value -> Parser UserInfo
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> Parser UserInfo) -> Value -> Parser UserInfo
forall a b. (a -> b) -> a -> b
$ Object -> Value
Object Object
m
    email <- m .:? "email"
    profile <- parseJSON $ Object m
    pure $ UserInfoResponse{info, email, profile}


data UserInfo = UserInfo
  { UserInfo -> Text
sub :: Text
  , UserInfo -> Int
last_authentication :: Int
  -- , identity_set :: Value
  }
  deriving ((forall x. UserInfo -> Rep UserInfo x)
-> (forall x. Rep UserInfo x -> UserInfo) -> Generic UserInfo
forall x. Rep UserInfo x -> UserInfo
forall x. UserInfo -> Rep UserInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. UserInfo -> Rep UserInfo x
from :: forall x. UserInfo -> Rep UserInfo x
$cto :: forall x. Rep UserInfo x -> UserInfo
to :: forall x. Rep UserInfo x -> UserInfo
Generic, Maybe UserInfo
Value -> Parser [UserInfo]
Value -> Parser UserInfo
(Value -> Parser UserInfo)
-> (Value -> Parser [UserInfo])
-> Maybe UserInfo
-> FromJSON UserInfo
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser UserInfo
parseJSON :: Value -> Parser UserInfo
$cparseJSONList :: Value -> Parser [UserInfo]
parseJSONList :: Value -> Parser [UserInfo]
$comittedField :: Maybe UserInfo
omittedField :: Maybe UserInfo
FromJSON, Int -> UserInfo -> ShowS
[UserInfo] -> ShowS
UserInfo -> String
(Int -> UserInfo -> ShowS)
-> (UserInfo -> String) -> ([UserInfo] -> ShowS) -> Show UserInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserInfo -> ShowS
showsPrec :: Int -> UserInfo -> ShowS
$cshow :: UserInfo -> String
show :: UserInfo -> String
$cshowList :: [UserInfo] -> ShowS
showList :: [UserInfo] -> ShowS
Show)


newtype UserEmail = UserEmail Text
  deriving newtype (Maybe UserEmail
Value -> Parser [UserEmail]
Value -> Parser UserEmail
(Value -> Parser UserEmail)
-> (Value -> Parser [UserEmail])
-> Maybe UserEmail
-> FromJSON UserEmail
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser UserEmail
parseJSON :: Value -> Parser UserEmail
$cparseJSONList :: Value -> Parser [UserEmail]
parseJSONList :: Value -> Parser [UserEmail]
$comittedField :: Maybe UserEmail
omittedField :: Maybe UserEmail
FromJSON, Int -> UserEmail -> ShowS
[UserEmail] -> ShowS
UserEmail -> String
(Int -> UserEmail -> ShowS)
-> (UserEmail -> String)
-> ([UserEmail] -> ShowS)
-> Show UserEmail
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserEmail -> ShowS
showsPrec :: Int -> UserEmail -> ShowS
$cshow :: UserEmail -> String
show :: UserEmail -> String
$cshowList :: [UserEmail] -> ShowS
showList :: [UserEmail] -> ShowS
Show, UserEmail -> UserEmail -> Bool
(UserEmail -> UserEmail -> Bool)
-> (UserEmail -> UserEmail -> Bool) -> Eq UserEmail
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UserEmail -> UserEmail -> Bool
== :: UserEmail -> UserEmail -> Bool
$c/= :: UserEmail -> UserEmail -> Bool
/= :: UserEmail -> UserEmail -> Bool
Eq)


data UserProfile = UserProfile
  { UserProfile -> Text
name :: Text
  , UserProfile -> Text
organization :: Text
  , UserProfile -> Text
preferred_username :: Text
  , UserProfile -> Text
identity_provider :: Text
  , UserProfile -> Text
identity_provider_display_name :: Text
  }
  deriving ((forall x. UserProfile -> Rep UserProfile x)
-> (forall x. Rep UserProfile x -> UserProfile)
-> Generic UserProfile
forall x. Rep UserProfile x -> UserProfile
forall x. UserProfile -> Rep UserProfile x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. UserProfile -> Rep UserProfile x
from :: forall x. UserProfile -> Rep UserProfile x
$cto :: forall x. Rep UserProfile x -> UserProfile
to :: forall x. Rep UserProfile x -> UserProfile
Generic, Maybe UserProfile
Value -> Parser [UserProfile]
Value -> Parser UserProfile
(Value -> Parser UserProfile)
-> (Value -> Parser [UserProfile])
-> Maybe UserProfile
-> FromJSON UserProfile
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser UserProfile
parseJSON :: Value -> Parser UserProfile
$cparseJSONList :: Value -> Parser [UserProfile]
parseJSONList :: Value -> Parser [UserProfile]
$comittedField :: Maybe UserProfile
omittedField :: Maybe UserProfile
FromJSON, Int -> UserProfile -> ShowS
[UserProfile] -> ShowS
UserProfile -> String
(Int -> UserProfile -> ShowS)
-> (UserProfile -> String)
-> ([UserProfile] -> ShowS)
-> Show UserProfile
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserProfile -> ShowS
showsPrec :: Int -> UserProfile -> ShowS
$cshow :: UserProfile -> String
show :: UserProfile -> String
$cshowList :: [UserProfile] -> ShowS
showList :: [UserProfile] -> ShowS
Show)