{-# 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.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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UUID -> [Char]
toString IO UUID
nextRandom
  [Char]
base' <- forall (m :: * -> *). ServerMonad m => m [Char]
getWikiBase
  let destination :: [Char]
destination = Params -> [Char]
pDestination Params
params forall a. [a] -> [a] -> [a]
`orIfNull` ([Char]
base' forall a. [a] -> [a] -> [a]
++ [Char]
"/")
  SessionKey
key <- forall (m :: * -> *). MonadIO m => SessionData -> m SessionKey
newSession forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> SessionData
sessionDataGithubStateUrl [Char]
state [Char]
destination
  Config
cfg <- GititServerPart Config
getConfig
  forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
CookieLife -> Cookie -> m ()
addCookie (Int -> CookieLife
MaxAge forall a b. (a -> b) -> a -> b
$ Config -> Int
sessionTimeout Config
cfg) (SessionKey -> Cookie
mkSessionCookie SessionKey
key)
  let usingOrg :: Bool
usingOrg = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ GithubConfig -> Maybe Text
org forall a b. (a -> b) -> a -> b
$ Config -> GithubConfig
githubAuth Config
cfg
  let scopes :: [Char]
scopes = [Char]
"user:email" forall a. [a] -> [a] -> [a]
++ if Bool
usingOrg then [Char]
",read:org" else [Char]
""
  let url :: URIRef Absolute
url = 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)] forall a b. (a -> b) -> a -> b
$ OAuth2 -> URIRef Absolute
authorizationUrl OAuth2
githubKey
  forall (m :: * -> *) uri res.
(FilterMonad Response m, ToSURI uri) =>
uri -> res -> m res
seeOther (ByteString -> [Char]
BS.unpack (forall a. URIRef a -> ByteString
URI.serializeURIRef' URIRef Absolute
url)) forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
  ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *}.
MonadIO m =>
Manager -> m (Either GithubLoginError User)
getUserInternal
    where
    getUserInternal :: Manager -> m (Either GithubLoginError User)
getUserInternal Manager
mgr =
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
            let (Just [Char]
state) = GithubCallbackPars -> Maybe [Char]
rState GithubCallbackPars
githubCallbackPars
            if [Char]
state forall a. Eq a => a -> a -> Bool
== [Char]
githubState
              then do
                let (Just [Char]
code) = GithubCallbackPars -> Maybe [Char]
rCode GithubCallbackPars
githubCallbackPars
                OAuth2Token
at <- forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (forall {a}. Show a => [Char] -> a -> GithubLoginError
oauthToGithubError [Char]
"No access token found yet")
                      forall a b. (a -> b) -> a -> b
$ Manager
-> OAuth2
-> ExchangeToken
-> ExceptT (OAuth2Error Errors) IO OAuth2Token
fetchAccessToken Manager
mgr (GithubConfig -> OAuth2
oAuth2 GithubConfig
ghConfig) (Text -> ExchangeToken
ExchangeToken forall a b. (a -> b) -> a -> b
$ [Char] -> Text
pack [Char]
code)
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither forall a b. (a -> b) -> a -> b
$ 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 -> forall {a} {t} {b}.
[Char]
-> IO (Either a t)
-> (t -> IO (Either GithubLoginError b))
-> IO (Either GithubLoginError b)
ifSuccess
                            ([Char]
"No email for user " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack (GithubUser -> Text
gLogin GithubUser
githubUser) 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 forall a b. (a -> b) -> a -> b
$ GithubUserMail -> Text
email forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head (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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right User
user
                                             Just Text
githuborg -> 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 " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
gitLogin forall a. [a] -> [a] -> [a]
++  [Char]
" is required to be a member of the organization "  forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
githuborg 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right User
user)))
              else
                forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError 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: " forall a. [a] -> [a] -> [a]
++ [Char]
state forall a. [a] -> [a] -> [a]
++ [Char]
", but expected sent state: " forall a. [a] -> [a] -> [a]
++  [Char]
githubState)
                                        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  = 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 -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
                                                                [Char] -> Maybe [Char] -> GithubLoginError
GithubLoginError [Char]
errMsg
                                                                                 (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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 (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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 -> ShowS
[GithubCallbackPars] -> ShowS
GithubCallbackPars -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [GithubCallbackPars] -> ShowS
$cshowList :: [GithubCallbackPars] -> ShowS
show :: GithubCallbackPars -> [Char]
$cshow :: GithubCallbackPars -> [Char]
showsPrec :: Int -> GithubCallbackPars -> ShowS
$cshowsPrec :: Int -> GithubCallbackPars -> ShowS
Show

instance FromData GithubCallbackPars where
    fromData :: RqData GithubCallbackPars
fromData = do
         Maybe [Char]
vCode <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just (forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
[Char] -> m [Char]
look [Char]
"code") forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
         Maybe [Char]
vState <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just (forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
[Char] -> m [Char]
look [Char]
"state") forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
         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 = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall b.
FromJSON b =>
Manager
-> AccessToken -> URIRef Absolute -> ExceptT ByteString IO b
authGetJSON Manager
mgr AccessToken
token 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 = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall b.
FromJSON b =>
Manager
-> AccessToken -> URIRef Absolute -> ExceptT ByteString IO b
authGetJSON Manager
mgr AccessToken
token 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 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
  forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ Manager
-> AccessToken
-> URIRef Absolute
-> ExceptT ByteString IO 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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe UserInfo -> Host -> Maybe Port -> Authority
URI.Authority forall a. Maybe a
Nothing (ByteString -> Host
URI.Host ByteString
"api.github.com") 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  = forall a. Maybe a
Nothing }

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

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

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

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