{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables #-}

module Network.Gitit.Authentication.Github ( loginGithubUser
                                           , getGithubUser
                                           , GithubCallbackPars
                                           , GithubLoginError
                                           , ghUserMessage
                                           , ghDetails) where

import Network.Gitit.Types
import Network.Gitit.Server
import Network.Gitit.State
import Network.Gitit.Util
import Network.Gitit.Framework
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BSL
import qualified URI.ByteString as URI
import Network.HTTP.Conduit
import Network.OAuth.OAuth2
import Control.Monad (liftM, mplus, mzero)
import Data.Maybe
import Data.Aeson
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding (encodeUtf8)
import Control.Applicative
import Control.Monad ((>=>))
import Control.Monad.Trans (liftIO)
import Data.UUID (toString)
import Data.UUID.V4 (nextRandom)
import qualified Control.Exception as E
import Control.Monad.Except
import Prelude

loginGithubUser :: OAuth2 -> Params -> Handler
loginGithubUser :: OAuth2 -> Params -> Handler
loginGithubUser OAuth2
githubKey Params
params = do
  [Char]
state <- IO [Char] -> ServerPartT (ReaderT WikiState IO) [Char]
forall a. IO a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> ServerPartT (ReaderT WikiState IO) [Char])
-> IO [Char] -> ServerPartT (ReaderT WikiState IO) [Char]
forall a b. (a -> b) -> a -> b
$ (UUID -> [Char]) -> IO UUID -> IO [Char]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UUID -> [Char]
toString IO UUID
nextRandom
  [Char]
base' <- ServerPartT (ReaderT WikiState IO) [Char]
forall (m :: * -> *). ServerMonad m => m [Char]
getWikiBase
  let destination :: [Char]
destination = Params -> [Char]
pDestination Params
params [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
`orIfNull` ([Char]
base' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/")
  SessionKey
key <- SessionData -> ServerPartT (ReaderT WikiState IO) SessionKey
forall (m :: * -> *). MonadIO m => SessionData -> m SessionKey
newSession (SessionData -> ServerPartT (ReaderT WikiState IO) SessionKey)
-> SessionData -> ServerPartT (ReaderT WikiState IO) SessionKey
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> SessionData
sessionDataGithubStateUrl [Char]
state [Char]
destination
  Config
cfg <- GititServerPart Config
getConfig
  CookieLife -> Cookie -> ServerPartT (ReaderT WikiState IO) ()
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
CookieLife -> Cookie -> m ()
addCookie (Int -> CookieLife
MaxAge (Int -> CookieLife) -> Int -> CookieLife
forall a b. (a -> b) -> a -> b
$ Config -> Int
sessionTimeout Config
cfg) (SessionKey -> Cookie
mkSessionCookie SessionKey
key)
  let usingOrg :: Bool
usingOrg = Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Text -> Bool) -> Maybe Text -> Bool
forall a b. (a -> b) -> a -> b
$ GithubConfig -> Maybe Text
org (GithubConfig -> Maybe Text) -> GithubConfig -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Config -> GithubConfig
githubAuth Config
cfg
  let scopes :: [Char]
scopes = [Char]
"user:email" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ if Bool
usingOrg then [Char]
",read:org" else [Char]
""
  let url :: URIRef Absolute
url = [(ByteString, ByteString)] -> URIRef Absolute -> URIRef Absolute
forall a. [(ByteString, ByteString)] -> URIRef a -> URIRef a
appendQueryParams [(ByteString
"state", [Char] -> ByteString
BS.pack [Char]
state), (ByteString
"scope", [Char] -> ByteString
BS.pack [Char]
scopes)] (URIRef Absolute -> URIRef Absolute)
-> URIRef Absolute -> URIRef Absolute
forall a b. (a -> b) -> a -> b
$ OAuth2 -> URIRef Absolute
authorizationUrl OAuth2
githubKey
  [Char] -> Response -> Handler
forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (ByteString -> [Char]
BS.unpack (URIRef Absolute -> ByteString
forall a. URIRef a -> ByteString
URI.serializeURIRef' URIRef Absolute
url)) (Response -> Handler) -> Response -> Handler
forall a b. (a -> b) -> a -> b
$ [Char] -> Response
forall a. ToMessage a => a -> Response
toResponse ([Char]
"redirecting to github" :: String)

data GithubLoginError = GithubLoginError { GithubLoginError -> [Char]
ghUserMessage :: String
                                         , GithubLoginError -> Maybe [Char]
ghDetails :: Maybe String
                                         }

getGithubUser :: GithubConfig            -- ^ Oauth2 configuration (client secret)
              -> GithubCallbackPars      -- ^ Authentication code gained after authorization
              -> String                  -- ^ Github state, we expect the state we sent in loginGithubUser
              -> GititServerPart (Either GithubLoginError User) -- ^ user email and name (password 'none')
getGithubUser :: GithubConfig
-> GithubCallbackPars
-> [Char]
-> GititServerPart (Either GithubLoginError User)
getGithubUser GithubConfig
ghConfig GithubCallbackPars
githubCallbackPars [Char]
githubState = IO (Either GithubLoginError User)
-> GititServerPart (Either GithubLoginError User)
forall a. IO a -> ServerPartT (ReaderT WikiState IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either GithubLoginError User)
 -> GititServerPart (Either GithubLoginError User))
-> IO (Either GithubLoginError User)
-> GititServerPart (Either GithubLoginError User)
forall a b. (a -> b) -> a -> b
$
  ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings IO Manager
-> (Manager -> IO (Either GithubLoginError User))
-> IO (Either GithubLoginError User)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Manager -> IO (Either GithubLoginError User)
forall {m :: * -> *}.
MonadIO m =>
Manager -> m (Either GithubLoginError User)
getUserInternal
    where
    getUserInternal :: Manager -> m (Either GithubLoginError User)
getUserInternal Manager
mgr =
        IO (Either GithubLoginError User)
-> m (Either GithubLoginError User)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either GithubLoginError User)
 -> m (Either GithubLoginError User))
-> IO (Either GithubLoginError User)
-> m (Either GithubLoginError User)
forall a b. (a -> b) -> a -> b
$ ExceptT GithubLoginError IO User
-> IO (Either GithubLoginError User)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT GithubLoginError IO User
 -> IO (Either GithubLoginError User))
-> ExceptT GithubLoginError IO User
-> IO (Either GithubLoginError User)
forall a b. (a -> b) -> a -> b
$ do
            let (Just [Char]
state) = GithubCallbackPars -> Maybe [Char]
rState GithubCallbackPars
githubCallbackPars
            if [Char]
state [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
githubState
              then do
                let (Just [Char]
code) = GithubCallbackPars -> Maybe [Char]
rCode GithubCallbackPars
githubCallbackPars
                OAuth2Token
at <- (TokenResponseError -> GithubLoginError)
-> ExceptT TokenResponseError IO OAuth2Token
-> ExceptT GithubLoginError IO OAuth2Token
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ([Char] -> TokenResponseError -> GithubLoginError
forall {a}. Show a => [Char] -> a -> GithubLoginError
oauthToGithubError [Char]
"No access token found yet")
                      (ExceptT TokenResponseError IO OAuth2Token
 -> ExceptT GithubLoginError IO OAuth2Token)
-> ExceptT TokenResponseError IO OAuth2Token
-> ExceptT GithubLoginError IO OAuth2Token
forall a b. (a -> b) -> a -> b
$ Manager
-> OAuth2
-> ExchangeToken
-> ExceptT TokenResponseError IO OAuth2Token
forall (m :: * -> *).
MonadIO m =>
Manager
-> OAuth2
-> ExchangeToken
-> ExceptT TokenResponseError m OAuth2Token
fetchAccessToken Manager
mgr (GithubConfig -> OAuth2
oAuth2 GithubConfig
ghConfig) (Text -> ExchangeToken
ExchangeToken (Text -> ExchangeToken) -> Text -> ExchangeToken
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack [Char]
code)
                IO (Either GithubLoginError User)
-> ExceptT GithubLoginError IO (Either GithubLoginError User)
forall a. IO a -> ExceptT GithubLoginError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either GithubLoginError User)
 -> ExceptT GithubLoginError IO (Either GithubLoginError User))
-> (Either GithubLoginError User
    -> ExceptT GithubLoginError IO User)
-> IO (Either GithubLoginError User)
-> ExceptT GithubLoginError IO User
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Either GithubLoginError User -> ExceptT GithubLoginError IO User
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (IO (Either GithubLoginError User)
 -> ExceptT GithubLoginError IO User)
-> IO (Either GithubLoginError User)
-> ExceptT GithubLoginError IO User
forall a b. (a -> b) -> a -> b
$ [Char]
-> IO (Either ByteString GithubUser)
-> (GithubUser -> IO (Either GithubLoginError User))
-> IO (Either GithubLoginError User)
forall {a} {t} {b}.
[Char]
-> IO (Either a t)
-> (t -> IO (Either GithubLoginError b))
-> IO (Either GithubLoginError b)
ifSuccess [Char]
"User Authentication failed"
                           (Manager -> AccessToken -> IO (Either ByteString GithubUser)
userInfo Manager
mgr (OAuth2Token -> AccessToken
accessToken OAuth2Token
at))
                           (\GithubUser
githubUser -> [Char]
-> IO (Either ByteString [GithubUserMail])
-> ([GithubUserMail] -> IO (Either GithubLoginError User))
-> IO (Either GithubLoginError User)
forall {a} {t} {b}.
[Char]
-> IO (Either a t)
-> (t -> IO (Either GithubLoginError b))
-> IO (Either GithubLoginError b)
ifSuccess
                            ([Char]
"No email for user " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack (GithubUser -> Text
gLogin GithubUser
githubUser) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" returned by Github")
                            (Manager -> AccessToken -> IO (Either ByteString [GithubUserMail])
mailInfo Manager
mgr (OAuth2Token -> AccessToken
accessToken OAuth2Token
at))
                            (\[GithubUserMail]
githubUserMail -> do
                                       let gitLogin :: Text
gitLogin = GithubUser -> Text
gLogin GithubUser
githubUser
                                       User
user <- [Char] -> [Char] -> [Char] -> IO User
mkUser (Text -> [Char]
unpack Text
gitLogin)
                                                   (Text -> [Char]
unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ GithubUserMail -> Text
email (GithubUserMail -> Text) -> GithubUserMail -> Text
forall a b. (a -> b) -> a -> b
$ [GithubUserMail] -> GithubUserMail
forall a. HasCallStack => [a] -> a
head ((GithubUserMail -> Bool) -> [GithubUserMail] -> [GithubUserMail]
forall a. (a -> Bool) -> [a] -> [a]
filter GithubUserMail -> Bool
primary [GithubUserMail]
githubUserMail))
                                                   [Char]
"none"
                                       let mbOrg :: Maybe Text
mbOrg = GithubConfig -> Maybe Text
org GithubConfig
ghConfig
                                       case Maybe Text
mbOrg of
                                             Maybe Text
Nothing -> Either GithubLoginError User -> IO (Either GithubLoginError User)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either GithubLoginError User -> IO (Either GithubLoginError User))
-> Either GithubLoginError User
-> IO (Either GithubLoginError User)
forall a b. (a -> b) -> a -> b
$ User -> Either GithubLoginError User
forall a b. b -> Either a b
Right User
user
                                             Just Text
githuborg -> [Char]
-> IO (Either ByteString ByteString)
-> (ByteString -> IO (Either GithubLoginError User))
-> IO (Either GithubLoginError User)
forall {a} {t} {b}.
[Char]
-> IO (Either a t)
-> (t -> IO (Either GithubLoginError b))
-> IO (Either GithubLoginError b)
ifSuccess
                                                      ([Char]
"Membership check failed: the user " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
gitLogin [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++  [Char]
" is required to be a member of the organization "  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
githuborg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".")
                                                      (Text
-> Text
-> Manager
-> AccessToken
-> IO (Either ByteString ByteString)
orgInfo Text
gitLogin Text
githuborg Manager
mgr (OAuth2Token -> AccessToken
accessToken OAuth2Token
at))
                                                      (\ByteString
_ -> Either GithubLoginError User -> IO (Either GithubLoginError User)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either GithubLoginError User -> IO (Either GithubLoginError User))
-> Either GithubLoginError User
-> IO (Either GithubLoginError User)
forall a b. (a -> b) -> a -> b
$ User -> Either GithubLoginError User
forall a b. b -> Either a b
Right User
user)))
              else
                GithubLoginError -> ExceptT GithubLoginError IO User
forall a. GithubLoginError -> ExceptT GithubLoginError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GithubLoginError -> ExceptT GithubLoginError IO User)
-> GithubLoginError -> ExceptT GithubLoginError IO User
forall a b. (a -> b) -> a -> b
$
                       [Char] -> Maybe [Char] -> GithubLoginError
GithubLoginError ([Char]
"The state sent to github is not the same as the state received: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
state [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", but expected sent state: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++  [Char]
githubState)
                                        Maybe [Char]
forall a. Maybe a
Nothing
    ifSuccess :: [Char]
-> IO (Either a t)
-> (t -> IO (Either GithubLoginError b))
-> IO (Either GithubLoginError b)
ifSuccess [Char]
errMsg IO (Either a t)
failableAction t -> IO (Either GithubLoginError b)
successAction  = IO (Either GithubLoginError b)
-> (SomeException -> IO (Either GithubLoginError b))
-> IO (Either GithubLoginError b)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch
                                                 (do Right t
outcome <- IO (Either a t)
failableAction
                                                     t -> IO (Either GithubLoginError b)
successAction t
outcome)
                                                 (\SomeException
exception -> IO (Either GithubLoginError b) -> IO (Either GithubLoginError b)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either GithubLoginError b) -> IO (Either GithubLoginError b))
-> IO (Either GithubLoginError b) -> IO (Either GithubLoginError b)
forall a b. (a -> b) -> a -> b
$ Either GithubLoginError b -> IO (Either GithubLoginError b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either GithubLoginError b -> IO (Either GithubLoginError b))
-> Either GithubLoginError b -> IO (Either GithubLoginError b)
forall a b. (a -> b) -> a -> b
$ GithubLoginError -> Either GithubLoginError b
forall a b. a -> Either a b
Left (GithubLoginError -> Either GithubLoginError b)
-> GithubLoginError -> Either GithubLoginError b
forall a b. (a -> b) -> a -> b
$
                                                                [Char] -> Maybe [Char] -> GithubLoginError
GithubLoginError [Char]
errMsg
                                                                                 ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ SomeException -> [Char]
forall a. Show a => a -> [Char]
show (SomeException
exception :: E.SomeException)))
    oauthToGithubError :: [Char] -> a -> GithubLoginError
oauthToGithubError [Char]
errMsg a
e = [Char] -> Maybe [Char] -> GithubLoginError
GithubLoginError [Char]
errMsg ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ a -> [Char]
forall a. Show a => a -> [Char]
show a
e)

data GithubCallbackPars = GithubCallbackPars { GithubCallbackPars -> Maybe [Char]
rCode :: Maybe String
                                             , GithubCallbackPars -> Maybe [Char]
rState :: Maybe String }
                          deriving Int -> GithubCallbackPars -> [Char] -> [Char]
[GithubCallbackPars] -> [Char] -> [Char]
GithubCallbackPars -> [Char]
(Int -> GithubCallbackPars -> [Char] -> [Char])
-> (GithubCallbackPars -> [Char])
-> ([GithubCallbackPars] -> [Char] -> [Char])
-> Show GithubCallbackPars
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> GithubCallbackPars -> [Char] -> [Char]
showsPrec :: Int -> GithubCallbackPars -> [Char] -> [Char]
$cshow :: GithubCallbackPars -> [Char]
show :: GithubCallbackPars -> [Char]
$cshowList :: [GithubCallbackPars] -> [Char] -> [Char]
showList :: [GithubCallbackPars] -> [Char] -> [Char]
Show

instance FromData GithubCallbackPars where
    fromData :: RqData GithubCallbackPars
fromData = do
         Maybe [Char]
vCode <- ([Char] -> Maybe [Char]) -> RqData [Char] -> RqData (Maybe [Char])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> RqData [Char]
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
[Char] -> m [Char]
look [Char]
"code") RqData (Maybe [Char])
-> RqData (Maybe [Char]) -> RqData (Maybe [Char])
forall a. RqData a -> RqData a -> RqData a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe [Char] -> RqData (Maybe [Char])
forall a. a -> RqData a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing
         Maybe [Char]
vState <- ([Char] -> Maybe [Char]) -> RqData [Char] -> RqData (Maybe [Char])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> RqData [Char]
forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
[Char] -> m [Char]
look [Char]
"state") RqData (Maybe [Char])
-> RqData (Maybe [Char]) -> RqData (Maybe [Char])
forall a. RqData a -> RqData a -> RqData a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe [Char] -> RqData (Maybe [Char])
forall a. a -> RqData a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing
         GithubCallbackPars -> RqData GithubCallbackPars
forall a. a -> RqData a
forall (m :: * -> *) a. Monad m => a -> m a
return GithubCallbackPars {rCode :: Maybe [Char]
rCode = Maybe [Char]
vCode, rState :: Maybe [Char]
rState = Maybe [Char]
vState}

#if MIN_VERSION_hoauth2(1, 9, 0)
userInfo :: Manager -> AccessToken -> IO (Either BSL.ByteString GithubUser)
#else
userInfo :: Manager -> AccessToken -> IO (OAuth2Result OA.Errors GithubUser)
#endif
userInfo :: Manager -> AccessToken -> IO (Either ByteString GithubUser)
userInfo Manager
mgr AccessToken
token = ExceptT ByteString IO GithubUser
-> IO (Either ByteString GithubUser)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ByteString IO GithubUser
 -> IO (Either ByteString GithubUser))
-> ExceptT ByteString IO GithubUser
-> IO (Either ByteString GithubUser)
forall a b. (a -> b) -> a -> b
$ Manager
-> AccessToken
-> URIRef Absolute
-> ExceptT ByteString IO GithubUser
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Manager -> AccessToken -> URIRef Absolute -> ExceptT ByteString m a
authGetJSON Manager
mgr AccessToken
token (URIRef Absolute -> ExceptT ByteString IO GithubUser)
-> URIRef Absolute -> ExceptT ByteString IO GithubUser
forall a b. (a -> b) -> a -> b
$ ByteString -> URIRef Absolute
githubUri ByteString
"/user"

#if MIN_VERSION_hoauth2(1, 9, 0)
mailInfo :: Manager -> AccessToken -> IO (Either BSL.ByteString [GithubUserMail])
#else
mailInfo :: Manager -> AccessToken -> IO (OAuth2Result OA.Errors [GithubUserMail])
#endif
mailInfo :: Manager -> AccessToken -> IO (Either ByteString [GithubUserMail])
mailInfo Manager
mgr AccessToken
token = ExceptT ByteString IO [GithubUserMail]
-> IO (Either ByteString [GithubUserMail])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ByteString IO [GithubUserMail]
 -> IO (Either ByteString [GithubUserMail]))
-> ExceptT ByteString IO [GithubUserMail]
-> IO (Either ByteString [GithubUserMail])
forall a b. (a -> b) -> a -> b
$ Manager
-> AccessToken
-> URIRef Absolute
-> ExceptT ByteString IO [GithubUserMail]
forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Manager -> AccessToken -> URIRef Absolute -> ExceptT ByteString m a
authGetJSON Manager
mgr AccessToken
token (URIRef Absolute -> ExceptT ByteString IO [GithubUserMail])
-> URIRef Absolute -> ExceptT ByteString IO [GithubUserMail]
forall a b. (a -> b) -> a -> b
$ ByteString -> URIRef Absolute
githubUri ByteString
"/user/emails"

#if MIN_VERSION_hoauth2(1, 9, 0)
orgInfo  :: Text -> Text -> Manager -> AccessToken -> IO (Either BSL.ByteString BSL.ByteString)
#else
orgInfo  :: Text -> Text -> Manager -> AccessToken -> IO (OAuth2Result OA.Errors BSL.ByteString)
#endif
orgInfo :: Text
-> Text
-> Manager
-> AccessToken
-> IO (Either ByteString ByteString)
orgInfo Text
gitLogin Text
githubOrg Manager
mgr AccessToken
token = do
  let url :: URIRef Absolute
url = ByteString -> URIRef Absolute
githubUri (ByteString -> URIRef Absolute) -> ByteString -> URIRef Absolute
forall a b. (a -> b) -> a -> b
$ ByteString
"/orgs/" ByteString -> ByteString -> ByteString
`BS.append` Text -> ByteString
encodeUtf8 Text
githubOrg ByteString -> ByteString -> ByteString
`BS.append` ByteString
"/members/" ByteString -> ByteString -> ByteString
`BS.append` Text -> ByteString
encodeUtf8 Text
gitLogin
  ExceptT ByteString IO ByteString
-> IO (Either ByteString ByteString)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ByteString IO ByteString
 -> IO (Either ByteString ByteString))
-> ExceptT ByteString IO ByteString
-> IO (Either ByteString ByteString)
forall a b. (a -> b) -> a -> b
$ Manager
-> AccessToken
-> URIRef Absolute
-> ExceptT ByteString IO ByteString
forall (m :: * -> *).
MonadIO m =>
Manager
-> AccessToken
-> URIRef Absolute
-> ExceptT ByteString m ByteString
authGetBS Manager
mgr AccessToken
token URIRef Absolute
url

type UriPath = BS.ByteString

githubUri :: UriPath -> URI.URI
githubUri :: ByteString -> URIRef Absolute
githubUri ByteString
p = URI.URI { uriScheme :: Scheme
URI.uriScheme    = ByteString -> Scheme
URI.Scheme ByteString
"https"
                      , uriAuthority :: Maybe Authority
URI.uriAuthority = Authority -> Maybe Authority
forall a. a -> Maybe a
Just (Authority -> Maybe Authority) -> Authority -> Maybe Authority
forall a b. (a -> b) -> a -> b
$ Maybe UserInfo -> Host -> Maybe Port -> Authority
URI.Authority Maybe UserInfo
forall a. Maybe a
Nothing (ByteString -> Host
URI.Host ByteString
"api.github.com") Maybe Port
forall a. Maybe a
Nothing
                      , uriPath :: ByteString
URI.uriPath      = ByteString
p
                      , uriQuery :: Query
URI.uriQuery     = [(ByteString, ByteString)] -> Query
URI.Query []
                      , uriFragment :: Maybe ByteString
URI.uriFragment  = Maybe ByteString
forall a. Maybe a
Nothing }

data GithubUser = GithubUser { GithubUser -> Text
gLogin :: Text
                             } deriving (Int -> GithubUser -> [Char] -> [Char]
[GithubUser] -> [Char] -> [Char]
GithubUser -> [Char]
(Int -> GithubUser -> [Char] -> [Char])
-> (GithubUser -> [Char])
-> ([GithubUser] -> [Char] -> [Char])
-> Show GithubUser
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> GithubUser -> [Char] -> [Char]
showsPrec :: Int -> GithubUser -> [Char] -> [Char]
$cshow :: GithubUser -> [Char]
show :: GithubUser -> [Char]
$cshowList :: [GithubUser] -> [Char] -> [Char]
showList :: [GithubUser] -> [Char] -> [Char]
Show, GithubUser -> GithubUser -> Bool
(GithubUser -> GithubUser -> Bool)
-> (GithubUser -> GithubUser -> Bool) -> Eq GithubUser
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GithubUser -> GithubUser -> Bool
== :: GithubUser -> GithubUser -> Bool
$c/= :: GithubUser -> GithubUser -> Bool
/= :: GithubUser -> GithubUser -> Bool
Eq)

instance FromJSON GithubUser where
    parseJSON :: Value -> Parser GithubUser
parseJSON (Object Object
o) = Text -> GithubUser
GithubUser
                           (Text -> GithubUser) -> Parser Text -> Parser GithubUser
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"login"
    parseJSON Value
_ = Parser GithubUser
forall a. Parser a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

data GithubUserMail = GithubUserMail { GithubUserMail -> Text
email :: Text
                                     , GithubUserMail -> Bool
primary :: Bool
                             } deriving (Int -> GithubUserMail -> [Char] -> [Char]
[GithubUserMail] -> [Char] -> [Char]
GithubUserMail -> [Char]
(Int -> GithubUserMail -> [Char] -> [Char])
-> (GithubUserMail -> [Char])
-> ([GithubUserMail] -> [Char] -> [Char])
-> Show GithubUserMail
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> GithubUserMail -> [Char] -> [Char]
showsPrec :: Int -> GithubUserMail -> [Char] -> [Char]
$cshow :: GithubUserMail -> [Char]
show :: GithubUserMail -> [Char]
$cshowList :: [GithubUserMail] -> [Char] -> [Char]
showList :: [GithubUserMail] -> [Char] -> [Char]
Show, GithubUserMail -> GithubUserMail -> Bool
(GithubUserMail -> GithubUserMail -> Bool)
-> (GithubUserMail -> GithubUserMail -> Bool) -> Eq GithubUserMail
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GithubUserMail -> GithubUserMail -> Bool
== :: GithubUserMail -> GithubUserMail -> Bool
$c/= :: GithubUserMail -> GithubUserMail -> Bool
/= :: GithubUserMail -> GithubUserMail -> Bool
Eq)

instance FromJSON GithubUserMail where
    parseJSON :: Value -> Parser GithubUserMail
parseJSON (Object Object
o) = Text -> Bool -> GithubUserMail
GithubUserMail
                           (Text -> Bool -> GithubUserMail)
-> Parser Text -> Parser (Bool -> GithubUserMail)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"email"
                           Parser (Bool -> GithubUserMail)
-> Parser Bool -> Parser GithubUserMail
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Bool
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"primary"
    parseJSON Value
_ = Parser GithubUserMail
forall a. Parser a
forall (m :: * -> *) a. MonadPlus m => m a
mzero