    {-# LANGUAGE 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 qualified Data.ByteString.Char8 as BS
    import qualified Data.ByteString.Lazy as BSL
    import Network.HTTP.Conduit
    import Network.HTTP.Client.TLS
    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 Prelude

    loginGithubUser :: OAuth2 -> Handler
    loginGithubUser githubKey = do
      state <- liftIO $ fmap toString nextRandom
      key <- newSession (sessionDataGithubState state)
      cfg <- getConfig
      addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show key))
      let usingOrg = isJust $ org $ githubAuth cfg
      let scopes = "user:email" ++ if usingOrg then ",read:org" else ""
      let url = authorizationUrl githubKey `appendQueryParam` [("state", BS.pack state), ("scope", BS.pack scopes)]
      seeOther (BS.unpack url) $ toResponse ("redirecting to github" :: String)

    data GithubLoginError = GithubLoginError { ghUserMessage :: String
                                             , 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 ghConfig githubCallbackPars githubState =
           withManagerSettings tlsManagerSettings getUserInternal
        where
        getUserInternal mgr =
            liftIO $ do
                let (Just state) = rState githubCallbackPars
                if state == githubState
                  then do
                    let (Just code) = rCode githubCallbackPars
                    ifSuccess
                       "No access token found yet"
                       (fetchAccessToken mgr (oAuth2 ghConfig) (sToBS code))
                       (\at -> ifSuccess
                               "User Authentication failed"
                               (userInfo mgr at)
                               (\githubUser -> ifSuccess
                                ("No email for user " ++ unpack (gLogin githubUser) ++ " returned by Github")
                                (mailInfo mgr at)
                                (\githubUserMail -> do
                                           let gitLogin = gLogin githubUser
                                           user <- mkUser (unpack gitLogin)
                                                       (unpack $ email $ head (filter primary githubUserMail))
                                                       "none"
                                           let mbOrg = org ghConfig
                                           case mbOrg of
                                                 Nothing -> return $ Right user
                                                 Just githuborg -> ifSuccess
                                                          ("Membership check failed: the user " ++ unpack gitLogin ++  " is required to be a member of the organization "  ++ unpack githuborg ++ ".")
                                                          (orgInfo gitLogin githuborg mgr at)
                                                          (\_ -> return $ Right user))))
                  else
                    return $ Left $
                           GithubLoginError ("The state sent to github is not the same as the state received: " ++ state ++ ", but expected sent state: " ++  githubState)
                                            Nothing
        ifSuccess errMsg failableAction successAction  = E.catch
                                                     (do Right outcome <- failableAction
                                                         successAction outcome)
                                                     (\exception -> liftIO $ return $ Left $
                                                                    GithubLoginError errMsg
                                                                                     (Just $ show (exception :: E.SomeException)))

    data GithubCallbackPars = GithubCallbackPars { rCode :: Maybe String
                                                 , rState :: Maybe String }
                              deriving Show

    instance FromData GithubCallbackPars where
        fromData = do
             vCode <- liftM Just (look "code") `mplus` return Nothing
             vState <- liftM Just (look "state") `mplus` return Nothing
             return GithubCallbackPars {rCode = vCode, rState = vState}

    userInfo :: Manager -> AccessToken -> IO (OAuth2Result GithubUser)
    userInfo mgr token = authGetJSON mgr token "https://api.github.com/user"

    mailInfo :: Manager -> AccessToken -> IO (OAuth2Result [GithubUserMail])
    mailInfo mgr token = authGetJSON mgr token "https://api.github.com/user/emails"

    orgInfo  :: Text -> Text -> Manager -> AccessToken -> IO (OAuth2Result BSL.ByteString)
    orgInfo gitLogin githubOrg mgr token = do
      let url  = "https://api.github.com/orgs/" `BS.append` encodeUtf8 githubOrg `BS.append` "/members/" `BS.append` encodeUtf8 gitLogin
      authGetBS mgr token url

    data GithubUser = GithubUser { gLogin :: Text
                                 } deriving (Show, Eq)

    instance FromJSON GithubUser where
        parseJSON (Object o) = GithubUser
                               <$> o .: "login"
        parseJSON _ = mzero

    data GithubUserMail = GithubUserMail { email :: Text
                                         , primary :: Bool
                                 } deriving (Show, Eq)

    instance FromJSON GithubUserMail where
        parseJSON (Object o) = GithubUserMail
                               <$> o .: "email"
                               <*> o .: "primary"
        parseJSON _ = mzero

    sToBS :: String -> BS.ByteString
    sToBS = encodeUtf8 . pack