{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

module Auth
    ( API
    , FrontendAPI
    , server
    , AuthStatus
    , AuthRole
    , Config(..)
    , configJWTSignature
    , configFrontendUrl
    , configGithubCbPath
    , configGithubClientId
    , configGithubClientSecret
    , GithubEndpoints
    , mkGithubEndpoints
    , githubEndpointsAuthLocation
    , githubEndpointsAccessTokenLocation
    , githubEndpointsApiBaseUrl
    , githubEndpointsCallbackUri
    ) where

import Auth.Types (OAuthClientId, OAuthClientSecret, OAuthCode, OAuthToken, Token (Token), TokenProvider (Github),
                   addUserAgent, oAuthTokenAccessToken)
import Control.Lens (_1, _2, makeLenses, view)
import Control.Monad (guard)
import Control.Monad.Except (MonadError)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger (MonadLogger, logDebugN, logErrorN)
import Control.Monad.Now (MonadNow, getCurrentTime, getPOSIXTime)
import Control.Monad.Reader (MonadReader)
import Control.Monad.Trace (attempt, runTrace, withTrace)
import Control.Monad.Web (MonadWeb, doRequest, makeManager)
import Control.Newtype.Generics (Newtype, O, unpack)
import Data.Aeson (FromJSON, ToJSON, Value (String), eitherDecode, parseJSON, withObject, (.:))
import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import Data.ByteString.Lazy qualified as LBS
import Data.Map qualified as Map
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Time (NominalDiffTime, UTCTime, addUTCTime)
import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds)
import GHC.Generics (Generic)
import Gist (Gist, GistId, NewGist)
import Gist qualified
import Network.HTTP.Client.Conduit (getUri)
import Network.HTTP.Conduit (Request, parseRequest, responseBody, responseStatus, setQueryString)
import Network.HTTP.Simple (addRequestHeader)
import Network.HTTP.Types (hAccept, statusIsSuccessful)
import Network.HTTP.Types.Status (status404)
import Servant (Get, Header, Headers, JSON, NoContent (NoContent), QueryParam, ServerError, ServerT, StdMethod (GET),
                ToHttpApiData, Verb, addHeader, err401, err404, err500, errBody, throwError, (:<|>) ((:<|>)), (:>))
import Servant.API.BrowserHeader (BrowserHeader)
import Servant.Client (BaseUrl, ClientError (FailureResponse), ClientM, mkClientEnv, parseBaseUrl, responseStatusCode,
                       runClientM)
import Web.Cookie (SetCookie, defaultSetCookie, parseCookies, setCookieExpires, setCookieHttpOnly, setCookieMaxAge,
                   setCookieName, setCookiePath, setCookieSecure, setCookieValue)
import Web.JWT qualified as JWT

-- | https://gist.github.com/alpmestan/757094ecf9401f85c5ba367ca20b8900
type GetRedirect headers = Verb 'GET 302 '[ JSON] (headers NoContent)

-- | We split out the API here because we don't want the Github
-- Callback to be exported for the frontend to call directly.
type API
     = FrontendAPI
       :<|> CallbackAPI

type FrontendAPI
     = ("oauth" :> (BrowserHeader "Cookie" Text :> "status" :> Get '[ JSON] AuthStatus
                    :<|> "github" :> GetRedirect (Headers '[ Header "Location" Text])))
       :<|> (BrowserHeader "Cookie" Text :> "gists" :> Gist.GistAPI)

type CallbackAPI
     = "oauth" :> "github" :> "callback" :> QueryParam "code" OAuthCode :> GetRedirect (Headers '[ Header "Set-Cookie" SetCookie, Header "Location" Text])

------------------------------------------------------------
data AuthRole
    = Anonymous
    | GithubUser
    deriving (Int -> AuthRole -> ShowS
[AuthRole] -> ShowS
AuthRole -> String
(Int -> AuthRole -> ShowS)
-> (AuthRole -> String) -> ([AuthRole] -> ShowS) -> Show AuthRole
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthRole] -> ShowS
$cshowList :: [AuthRole] -> ShowS
show :: AuthRole -> String
$cshow :: AuthRole -> String
showsPrec :: Int -> AuthRole -> ShowS
$cshowsPrec :: Int -> AuthRole -> ShowS
Show, AuthRole -> AuthRole -> Bool
(AuthRole -> AuthRole -> Bool)
-> (AuthRole -> AuthRole -> Bool) -> Eq AuthRole
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuthRole -> AuthRole -> Bool
$c/= :: AuthRole -> AuthRole -> Bool
== :: AuthRole -> AuthRole -> Bool
$c== :: AuthRole -> AuthRole -> Bool
Eq, (forall x. AuthRole -> Rep AuthRole x)
-> (forall x. Rep AuthRole x -> AuthRole) -> Generic AuthRole
forall x. Rep AuthRole x -> AuthRole
forall x. AuthRole -> Rep AuthRole x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AuthRole x -> AuthRole
$cfrom :: forall x. AuthRole -> Rep AuthRole x
Generic, Value -> Parser [AuthRole]
Value -> Parser AuthRole
(Value -> Parser AuthRole)
-> (Value -> Parser [AuthRole]) -> FromJSON AuthRole
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [AuthRole]
$cparseJSONList :: Value -> Parser [AuthRole]
parseJSON :: Value -> Parser AuthRole
$cparseJSON :: Value -> Parser AuthRole
FromJSON, [AuthRole] -> Encoding
[AuthRole] -> Value
AuthRole -> Encoding
AuthRole -> Value
(AuthRole -> Value)
-> (AuthRole -> Encoding)
-> ([AuthRole] -> Value)
-> ([AuthRole] -> Encoding)
-> ToJSON AuthRole
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [AuthRole] -> Encoding
$ctoEncodingList :: [AuthRole] -> Encoding
toJSONList :: [AuthRole] -> Value
$ctoJSONList :: [AuthRole] -> Value
toEncoding :: AuthRole -> Encoding
$ctoEncoding :: AuthRole -> Encoding
toJSON :: AuthRole -> Value
$ctoJSON :: AuthRole -> Value
ToJSON)

newtype AuthStatus =
    AuthStatus
        { AuthStatus -> AuthRole
_authStatusAuthRole :: AuthRole
        }
    deriving (Int -> AuthStatus -> ShowS
[AuthStatus] -> ShowS
AuthStatus -> String
(Int -> AuthStatus -> ShowS)
-> (AuthStatus -> String)
-> ([AuthStatus] -> ShowS)
-> Show AuthStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthStatus] -> ShowS
$cshowList :: [AuthStatus] -> ShowS
show :: AuthStatus -> String
$cshow :: AuthStatus -> String
showsPrec :: Int -> AuthStatus -> ShowS
$cshowsPrec :: Int -> AuthStatus -> ShowS
Show, AuthStatus -> AuthStatus -> Bool
(AuthStatus -> AuthStatus -> Bool)
-> (AuthStatus -> AuthStatus -> Bool) -> Eq AuthStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuthStatus -> AuthStatus -> Bool
$c/= :: AuthStatus -> AuthStatus -> Bool
== :: AuthStatus -> AuthStatus -> Bool
$c== :: AuthStatus -> AuthStatus -> Bool
Eq, (forall x. AuthStatus -> Rep AuthStatus x)
-> (forall x. Rep AuthStatus x -> AuthStatus) -> Generic AuthStatus
forall x. Rep AuthStatus x -> AuthStatus
forall x. AuthStatus -> Rep AuthStatus x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AuthStatus x -> AuthStatus
$cfrom :: forall x. AuthStatus -> Rep AuthStatus x
Generic, Value -> Parser [AuthStatus]
Value -> Parser AuthStatus
(Value -> Parser AuthStatus)
-> (Value -> Parser [AuthStatus]) -> FromJSON AuthStatus
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [AuthStatus]
$cparseJSONList :: Value -> Parser [AuthStatus]
parseJSON :: Value -> Parser AuthStatus
$cparseJSON :: Value -> Parser AuthStatus
FromJSON, [AuthStatus] -> Encoding
[AuthStatus] -> Value
AuthStatus -> Encoding
AuthStatus -> Value
(AuthStatus -> Value)
-> (AuthStatus -> Encoding)
-> ([AuthStatus] -> Value)
-> ([AuthStatus] -> Encoding)
-> ToJSON AuthStatus
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [AuthStatus] -> Encoding
$ctoEncodingList :: [AuthStatus] -> Encoding
toJSONList :: [AuthStatus] -> Value
$ctoJSONList :: [AuthStatus] -> Value
toEncoding :: AuthStatus -> Encoding
$ctoEncoding :: AuthStatus -> Encoding
toJSON :: AuthStatus -> Value
$ctoJSON :: AuthStatus -> Value
ToJSON)

data GithubEndpoints =
    GithubEndpoints
        { GithubEndpoints -> Request
_githubEndpointsAuthLocation        :: !Request
        , GithubEndpoints -> Request
_githubEndpointsAccessTokenLocation :: !Request
        , GithubEndpoints -> BaseUrl
_githubEndpointsApiBaseUrl          :: !BaseUrl
        , GithubEndpoints -> Text
_githubEndpointsCallbackUri         :: !Text
        }

makeLenses 'GithubEndpoints

-- | Config determined by Github.
mkGithubEndpoints :: IO GithubEndpoints
mkGithubEndpoints :: IO GithubEndpoints
mkGithubEndpoints = do
    Request
_githubEndpointsAuthLocation <-
        String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
"GET https://github.com/login/oauth/authorize"
    Request
_githubEndpointsAccessTokenLocation <-
        String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
"POST https://github.com/login/oauth/access_token"
    BaseUrl
_githubEndpointsApiBaseUrl <- String -> IO BaseUrl
forall (m :: * -> *). MonadThrow m => String -> m BaseUrl
parseBaseUrl String
"https://api.github.com"
    let _githubEndpointsCallbackUri :: Text
_githubEndpointsCallbackUri = Text
"/api/oauth/github/callback"
    GithubEndpoints -> IO GithubEndpoints
forall (f :: * -> *) a. Applicative f => a -> f a
pure GithubEndpoints :: Request -> Request -> BaseUrl -> Text -> GithubEndpoints
GithubEndpoints {Text
Request
BaseUrl
_githubEndpointsCallbackUri :: Text
_githubEndpointsApiBaseUrl :: BaseUrl
_githubEndpointsAccessTokenLocation :: Request
_githubEndpointsAuthLocation :: Request
_githubEndpointsCallbackUri :: Text
_githubEndpointsApiBaseUrl :: BaseUrl
_githubEndpointsAccessTokenLocation :: Request
_githubEndpointsAuthLocation :: Request
..}

-- | Config supplied at runtime.
data Config =
    Config
        { Config -> EncodeSigner
_configJWTSignature       :: !JWT.EncodeSigner
        , Config -> Text
_configFrontendUrl        :: !Text
        , Config -> Text
_configGithubCbPath       :: !Text
        , Config -> OAuthClientId
_configGithubClientId     :: !OAuthClientId
        , Config -> OAuthClientSecret
_configGithubClientSecret :: !OAuthClientSecret
        }

makeLenses 'Config

instance FromJSON Config where
    parseJSON :: Value -> Parser Config
parseJSON =
        String -> (Object -> Parser Config) -> Value -> Parser Config
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"config" ((Object -> Parser Config) -> Value -> Parser Config)
-> (Object -> Parser Config) -> Value -> Parser Config
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
            OAuthClientId
_configGithubClientId <- Object
o Object -> Key -> Parser OAuthClientId
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"github-client-id"
            OAuthClientSecret
_configGithubClientSecret <- Object
o Object -> Key -> Parser OAuthClientSecret
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"github-client-secret"
            EncodeSigner
_configJWTSignature <- Text -> EncodeSigner
JWT.hmacSecret (Text -> EncodeSigner) -> Parser Text -> Parser EncodeSigner
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
"jwt-signature"
            Text
_configFrontendUrl <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"frontend-url"
            Text
_configGithubCbPath <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"github-cb-path"
            Config -> Parser Config
forall (f :: * -> *) a. Applicative f => a -> f a
pure Config :: EncodeSigner
-> Text -> Text -> OAuthClientId -> OAuthClientSecret -> Config
Config {Text
EncodeSigner
OAuthClientSecret
OAuthClientId
_configGithubCbPath :: Text
_configFrontendUrl :: Text
_configJWTSignature :: EncodeSigner
_configGithubClientSecret :: OAuthClientSecret
_configGithubClientId :: OAuthClientId
_configGithubClientSecret :: OAuthClientSecret
_configGithubClientId :: OAuthClientId
_configGithubCbPath :: Text
_configFrontendUrl :: Text
_configJWTSignature :: EncodeSigner
..}

type Env = (GithubEndpoints, Config)

------------------------------------------------------------
hSessionIdCookie :: Text
hSessionIdCookie :: Text
hSessionIdCookie = Text
"sessionId"

-- | The JWT key we can lookup for the Github token's value.
githubTokenClaim :: Text
githubTokenClaim :: Text
githubTokenClaim = Text
"github-token"

------------------------------------------------------------
redirect ::
       ToHttpApiData loc
    => loc -- ^ what to put in the 'Location' header
    -> Headers '[ Header "Location" loc] NoContent
redirect :: loc -> Headers '[Header "Location" loc] NoContent
redirect loc
a = loc -> NoContent -> Headers '[Header "Location" loc] NoContent
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader loc
a NoContent
NoContent

githubRedirect ::
       (MonadLogger m, MonadReader Env m)
    => m (Headers '[ Header "Location" Text] NoContent)
githubRedirect :: m (Headers '[Header "Location" Text] NoContent)
githubRedirect = do
    Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN Text
"Processing github redirect."
    Text
_configFrontendUrl <- Getting Text Env Text -> m Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Config -> Const Text Config) -> Env -> Const Text Env
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((Config -> Const Text Config) -> Env -> Const Text Env)
-> ((Text -> Const Text Text) -> Config -> Const Text Config)
-> Getting Text Env Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text) -> Config -> Const Text Config
Lens' Config Text
configFrontendUrl)
    Text
_githubEndpointsCallbackUri <- Getting Text Env Text -> m Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((GithubEndpoints -> Const Text GithubEndpoints)
-> Env -> Const Text Env
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((GithubEndpoints -> Const Text GithubEndpoints)
 -> Env -> Const Text Env)
-> ((Text -> Const Text Text)
    -> GithubEndpoints -> Const Text GithubEndpoints)
-> Getting Text Env Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text)
-> GithubEndpoints -> Const Text GithubEndpoints
Lens' GithubEndpoints Text
githubEndpointsCallbackUri)
    OAuthClientId
_configGithubClientId <- Getting OAuthClientId Env OAuthClientId -> m OAuthClientId
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Config -> Const OAuthClientId Config)
-> Env -> Const OAuthClientId Env
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((Config -> Const OAuthClientId Config)
 -> Env -> Const OAuthClientId Env)
-> ((OAuthClientId -> Const OAuthClientId OAuthClientId)
    -> Config -> Const OAuthClientId Config)
-> Getting OAuthClientId Env OAuthClientId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OAuthClientId -> Const OAuthClientId OAuthClientId)
-> Config -> Const OAuthClientId Config
Lens' Config OAuthClientId
configGithubClientId)
    Request
_githubEndpointsAuthLocation <- Getting Request Env Request -> m Request
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((GithubEndpoints -> Const Request GithubEndpoints)
-> Env -> Const Request Env
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((GithubEndpoints -> Const Request GithubEndpoints)
 -> Env -> Const Request Env)
-> ((Request -> Const Request Request)
    -> GithubEndpoints -> Const Request GithubEndpoints)
-> Getting Request Env Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Request -> Const Request Request)
-> GithubEndpoints -> Const Request GithubEndpoints
Lens' GithubEndpoints Request
githubEndpointsAuthLocation)
    let githubRedirectUrl :: Text
githubRedirectUrl =
            URI -> Text
forall a. Show a => a -> Text
showText (URI -> Text) -> (Request -> URI) -> Request -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            Request -> URI
getUri (Request -> URI) -> (Request -> Request) -> Request -> URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            [(ByteString, Maybe ByteString)] -> Request -> Request
setQueryString
                [ ByteString -> Text -> (ByteString, Maybe ByteString)
forall a. a -> Text -> (a, Maybe ByteString)
param ByteString
"redirect_uri" (Text -> (ByteString, Maybe ByteString))
-> Text -> (ByteString, Maybe ByteString)
forall a b. (a -> b) -> a -> b
$
                  Text
_configFrontendUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
_githubEndpointsCallbackUri
                , ByteString -> Text -> (ByteString, Maybe ByteString)
forall a. a -> Text -> (a, Maybe ByteString)
param ByteString
"scope" Text
oauthScopes
                , ByteString -> Text -> (ByteString, Maybe ByteString)
forall a. a -> Text -> (a, Maybe ByteString)
param ByteString
"client_id" (OAuthClientId -> O OAuthClientId
forall n. Newtype n => n -> O n
unpack OAuthClientId
_configGithubClientId)
                ] (Request -> Text) -> Request -> Text
forall a b. (a -> b) -> a -> b
$
            Request
_githubEndpointsAuthLocation
    Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Redirecting to: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
showText Text
githubRedirectUrl
    Headers '[Header "Location" Text] NoContent
-> m (Headers '[Header "Location" Text] NoContent)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Headers '[Header "Location" Text] NoContent
 -> m (Headers '[Header "Location" Text] NoContent))
-> Headers '[Header "Location" Text] NoContent
-> m (Headers '[Header "Location" Text] NoContent)
forall a b. (a -> b) -> a -> b
$ Text -> Headers '[Header "Location" Text] NoContent
forall loc.
ToHttpApiData loc =>
loc -> Headers '[Header "Location" loc] NoContent
redirect Text
githubRedirectUrl
  where
    oauthScopes :: Text
oauthScopes = Text
"gist"
    param :: a -> Text -> (a, Maybe ByteString)
param a
key Text
value = (a
key, ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
value)

twoWeeks :: NominalDiffTime
twoWeeks :: NominalDiffTime
twoWeeks = NominalDiffTime
60 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
60 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
24 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
7 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
2

expiryDuration :: NominalDiffTime
expiryDuration :: NominalDiffTime
expiryDuration = NominalDiffTime
twoWeeks

authStatus ::
       (MonadNow m, MonadLogger m, MonadReader Env m)
    => Maybe Text
    -> m AuthStatus
authStatus :: Maybe Text -> m AuthStatus
authStatus Maybe Text
cookieHeader = do
    EncodeSigner
jwtSignature <- Getting EncodeSigner Env EncodeSigner -> m EncodeSigner
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Config -> Const EncodeSigner Config)
-> Env -> Const EncodeSigner Env
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((Config -> Const EncodeSigner Config)
 -> Env -> Const EncodeSigner Env)
-> ((EncodeSigner -> Const EncodeSigner EncodeSigner)
    -> Config -> Const EncodeSigner Config)
-> Getting EncodeSigner Env EncodeSigner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EncodeSigner -> Const EncodeSigner EncodeSigner)
-> Config -> Const EncodeSigner Config
Lens' Config EncodeSigner
configJWTSignature)
    NominalDiffTime
now <- m NominalDiffTime
forall (m :: * -> *). MonadNow m => m NominalDiffTime
getPOSIXTime
    AuthRole
_authStatusAuthRole <-
        case EncodeSigner
-> NominalDiffTime -> Maybe Text -> Either Text (Token 'Github)
extractGithubToken EncodeSigner
jwtSignature NominalDiffTime
now Maybe Text
cookieHeader of
            Right Token 'Github
_ -> do
              AuthRole -> m AuthRole
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthRole
GithubUser
            Left Text
err -> do
                Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                    Text
"Failed to extract github token at step: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
showText Text
err
                AuthRole -> m AuthRole
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthRole
Anonymous
    let authStatusResult :: AuthStatus
authStatusResult = AuthStatus :: AuthRole -> AuthStatus
AuthStatus {AuthRole
_authStatusAuthRole :: AuthRole
_authStatusAuthRole :: AuthRole
..}
    Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Authentication status is: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AuthStatus -> Text
forall a. Show a => a -> Text
showText AuthStatus
authStatusResult
    AuthStatus -> m AuthStatus
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthStatus
authStatusResult

extractGithubToken ::
       JWT.EncodeSigner -> POSIXTime -> Maybe Text -> Either Text (Token 'Github)
extractGithubToken :: EncodeSigner
-> NominalDiffTime -> Maybe Text -> Either Text (Token 'Github)
extractGithubToken EncodeSigner
signer NominalDiffTime
now Maybe Text
cookieHeader =
    Text
-> TraceMaybe Text (Token 'Github) -> Either Text (Token 'Github)
forall e a. e -> TraceMaybe e a -> Either e a
runTrace Text
"Reading cookies." (TraceMaybe Text (Token 'Github) -> Either Text (Token 'Github))
-> TraceMaybe Text (Token 'Github) -> Either Text (Token 'Github)
forall a b. (a -> b) -> a -> b
$ do
        Cookies
cookies <- ByteString -> Cookies
parseCookies (ByteString -> Cookies) -> (Text -> ByteString) -> Text -> Cookies
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> Cookies)
-> MaybeT (Writer (Last Text)) Text
-> MaybeT (Writer (Last Text)) Cookies
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> MaybeT (Writer (Last Text)) Text
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
withTrace Maybe Text
cookieHeader
        Text -> TraceMaybe Text ()
forall a. a -> TraceMaybe a ()
attempt (Text -> TraceMaybe Text ()) -> Text -> TraceMaybe Text ()
forall a b. (a -> b) -> a -> b
$ Text
"Looking for Session ID cookie: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Cookies -> Text
forall a. Show a => a -> Text
showText Cookies
cookies
        ByteString
githubAuth <- Maybe ByteString -> MaybeT (Writer (Last Text)) ByteString
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
withTrace (Maybe ByteString -> MaybeT (Writer (Last Text)) ByteString)
-> Maybe ByteString -> MaybeT (Writer (Last Text)) ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Cookies -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Text -> ByteString
encodeUtf8 Text
hSessionIdCookie) Cookies
cookies
        Text -> TraceMaybe Text ()
forall a. a -> TraceMaybe a ()
attempt (Text -> TraceMaybe Text ()) -> Text -> TraceMaybe Text ()
forall a b. (a -> b) -> a -> b
$ Text
"Reading JWT Cookie: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
decodeUtf8 ByteString
githubAuth
        JWT UnverifiedJWT
unverifiedJwt <- Maybe (JWT UnverifiedJWT)
-> MaybeT (Writer (Last Text)) (JWT UnverifiedJWT)
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
withTrace (Maybe (JWT UnverifiedJWT)
 -> MaybeT (Writer (Last Text)) (JWT UnverifiedJWT))
-> (ByteString -> Maybe (JWT UnverifiedJWT))
-> ByteString
-> MaybeT (Writer (Last Text)) (JWT UnverifiedJWT)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe (JWT UnverifiedJWT)
JWT.decode (Text -> Maybe (JWT UnverifiedJWT))
-> (ByteString -> Text) -> ByteString -> Maybe (JWT UnverifiedJWT)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> MaybeT (Writer (Last Text)) (JWT UnverifiedJWT))
-> ByteString -> MaybeT (Writer (Last Text)) (JWT UnverifiedJWT)
forall a b. (a -> b) -> a -> b
$ ByteString
githubAuth
        Text -> TraceMaybe Text ()
forall a. a -> TraceMaybe a ()
attempt Text
"Verifying JWT Cookie."
        JWT VerifiedJWT
verifiedJwt <- Maybe (JWT VerifiedJWT)
-> MaybeT (Writer (Last Text)) (JWT VerifiedJWT)
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
withTrace (Maybe (JWT VerifiedJWT)
 -> MaybeT (Writer (Last Text)) (JWT VerifiedJWT))
-> Maybe (JWT VerifiedJWT)
-> MaybeT (Writer (Last Text)) (JWT VerifiedJWT)
forall a b. (a -> b) -> a -> b
$ VerifySigner -> JWT UnverifiedJWT -> Maybe (JWT VerifiedJWT)
JWT.verify (EncodeSigner -> VerifySigner
JWT.toVerify EncodeSigner
signer) JWT UnverifiedJWT
unverifiedJwt
        let claims :: JWTClaimsSet
claims = JWT VerifiedJWT -> JWTClaimsSet
forall r. JWT r -> JWTClaimsSet
JWT.claims JWT VerifiedJWT
verifiedJwt
        Text -> TraceMaybe Text ()
forall a. a -> TraceMaybe a ()
attempt Text
"Checking expiry date is set."
        IntDate
expiry <- Maybe IntDate -> MaybeT (Writer (Last Text)) IntDate
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
withTrace (Maybe IntDate -> MaybeT (Writer (Last Text)) IntDate)
-> Maybe IntDate -> MaybeT (Writer (Last Text)) IntDate
forall a b. (a -> b) -> a -> b
$ JWTClaimsSet -> Maybe IntDate
JWT.exp JWTClaimsSet
claims
        Text -> TraceMaybe Text ()
forall a. a -> TraceMaybe a ()
attempt Text
"Checking expiry date is valid."
        Bool -> TraceMaybe Text ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (IntDate -> NominalDiffTime
JWT.secondsSinceEpoch IntDate
expiry NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
now)
        Text -> TraceMaybe Text ()
forall a. a -> TraceMaybe a ()
attempt Text
"Looking for Github token claim."
        Value
json <-
            Maybe Value -> MaybeT (Writer (Last Text)) Value
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
withTrace (Maybe Value -> MaybeT (Writer (Last Text)) Value)
-> (JWTClaimsSet -> Maybe Value)
-> JWTClaimsSet
-> MaybeT (Writer (Last Text)) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            Text -> Map Text Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
githubTokenClaim (Map Text Value -> Maybe Value)
-> (JWTClaimsSet -> Map Text Value) -> JWTClaimsSet -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            ClaimsMap -> Map Text Value
JWT.unClaimsMap (ClaimsMap -> Map Text Value)
-> (JWTClaimsSet -> ClaimsMap) -> JWTClaimsSet -> Map Text Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JWTClaimsSet -> ClaimsMap
JWT.unregisteredClaims (JWTClaimsSet -> MaybeT (Writer (Last Text)) Value)
-> JWTClaimsSet -> MaybeT (Writer (Last Text)) Value
forall a b. (a -> b) -> a -> b
$
            JWTClaimsSet
claims
        Text -> TraceMaybe Text ()
forall a. a -> TraceMaybe a ()
attempt (Text -> TraceMaybe Text ()) -> Text -> TraceMaybe Text ()
forall a b. (a -> b) -> a -> b
$ Text
"Extracting token as a string: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
forall a. Show a => a -> Text
showText Value
json
        Maybe (Token 'Github) -> TraceMaybe Text (Token 'Github)
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
withTrace (Maybe (Token 'Github) -> TraceMaybe Text (Token 'Github))
-> Maybe (Token 'Github) -> TraceMaybe Text (Token 'Github)
forall a b. (a -> b) -> a -> b
$
            case Value
json of
                String Text
token -> Token 'Github -> Maybe (Token 'Github)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Token 'Github -> Maybe (Token 'Github))
-> Token 'Github -> Maybe (Token 'Github)
forall a b. (a -> b) -> a -> b
$ Text -> Token 'Github
forall (a :: TokenProvider). Text -> Token a
Token Text
token
                Value
_            -> Maybe (Token 'Github)
forall a. Maybe a
Nothing

githubCallback ::
       ( MonadLogger m
       , MonadWeb m
       , MonadError ServerError m
       , MonadNow m
       , MonadReader Env m
       )
    => Maybe OAuthCode
    -> m (Headers '[ Header "Set-Cookie" SetCookie, Header "Location" Text] NoContent)
githubCallback :: Maybe OAuthCode
-> m (Headers
        '[Header "Set-Cookie" SetCookie, Header "Location" Text] NoContent)
githubCallback Maybe OAuthCode
Nothing =
    m (Either
     Text
     (Headers
        '[Header "Set-Cookie" SetCookie, Header "Location" Text]
        NoContent))
-> m (Headers
        '[Header "Set-Cookie" SetCookie, Header "Location" Text] NoContent)
forall (m :: * -> *) b.
(MonadLogger m, MonadError ServerError m) =>
m (Either Text b) -> m b
withErr500 (m (Either
      Text
      (Headers
         '[Header "Set-Cookie" SetCookie, Header "Location" Text]
         NoContent))
 -> m (Headers
         '[Header "Set-Cookie" SetCookie, Header "Location" Text]
         NoContent))
-> (Text
    -> m (Either
            Text
            (Headers
               '[Header "Set-Cookie" SetCookie, Header "Location" Text]
               NoContent)))
-> Text
-> m (Headers
        '[Header "Set-Cookie" SetCookie, Header "Location" Text] NoContent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either
  Text
  (Headers
     '[Header "Set-Cookie" SetCookie, Header "Location" Text] NoContent)
-> m (Either
        Text
        (Headers
           '[Header "Set-Cookie" SetCookie, Header "Location" Text]
           NoContent))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   Text
   (Headers
      '[Header "Set-Cookie" SetCookie, Header "Location" Text] NoContent)
 -> m (Either
         Text
         (Headers
            '[Header "Set-Cookie" SetCookie, Header "Location" Text]
            NoContent)))
-> (Text
    -> Either
         Text
         (Headers
            '[Header "Set-Cookie" SetCookie, Header "Location" Text]
            NoContent))
-> Text
-> m (Either
        Text
        (Headers
           '[Header "Set-Cookie" SetCookie, Header "Location" Text]
           NoContent))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> Either
     Text
     (Headers
        '[Header "Set-Cookie" SetCookie, Header "Location" Text] NoContent)
forall a b. a -> Either a b
Left (Text
 -> m (Headers
         '[Header "Set-Cookie" SetCookie, Header "Location" Text]
         NoContent))
-> Text
-> m (Headers
        '[Header "Set-Cookie" SetCookie, Header "Location" Text] NoContent)
forall a b. (a -> b) -> a -> b
$
    Text
"Expected a response from Github with an authorization code. Didn't get one!"
githubCallback (Just OAuthCode
code) = do
    GithubEndpoints
githubEndpoints <- Getting GithubEndpoints Env GithubEndpoints -> m GithubEndpoints
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting GithubEndpoints Env GithubEndpoints
forall s t a b. Field1 s t a b => Lens s t a b
_1
    config :: Config
config@Config {Text
EncodeSigner
OAuthClientSecret
OAuthClientId
_configGithubClientSecret :: OAuthClientSecret
_configGithubClientId :: OAuthClientId
_configGithubCbPath :: Text
_configFrontendUrl :: Text
_configJWTSignature :: EncodeSigner
_configGithubClientSecret :: Config -> OAuthClientSecret
_configGithubClientId :: Config -> OAuthClientId
_configGithubCbPath :: Config -> Text
_configFrontendUrl :: Config -> Text
_configJWTSignature :: Config -> EncodeSigner
..} <- Getting Config Env Config -> m Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config Env Config
forall s t a b. Field2 s t a b => Lens s t a b
_2
    Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN Text
"OAuth Code received. Swapping for a long-lived token."
    Manager
manager <- m Manager
forall (m :: * -> *). MonadWeb m => m Manager
makeManager
    Response ByteString
response <-
        m (Either Text (Response ByteString)) -> m (Response ByteString)
forall (m :: * -> *) b.
(MonadLogger m, MonadError ServerError m) =>
m (Either Text b) -> m b
withErr500 (m (Either Text (Response ByteString)) -> m (Response ByteString))
-> m (Either Text (Response ByteString)) -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$
        Manager -> Request -> m (Either Text (Response ByteString))
forall (m :: * -> *).
MonadWeb m =>
Manager -> Request -> m (Either Text (Response ByteString))
doRequest Manager
manager (Request -> m (Either Text (Response ByteString)))
-> Request -> m (Either Text (Response ByteString))
forall a b. (a -> b) -> a -> b
$ GithubEndpoints -> Config -> OAuthCode -> Request
makeTokenRequest GithubEndpoints
githubEndpoints Config
config OAuthCode
code
    OAuthToken 'Github
token <-
        m (Either Text (OAuthToken 'Github)) -> m (OAuthToken 'Github)
forall (m :: * -> *) b.
(MonadLogger m, MonadError ServerError m) =>
m (Either Text b) -> m b
withErr500 (m (Either Text (OAuthToken 'Github)) -> m (OAuthToken 'Github))
-> (Either String (OAuthToken 'Github)
    -> m (Either Text (OAuthToken 'Github)))
-> Either String (OAuthToken 'Github)
-> m (OAuthToken 'Github)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text (OAuthToken 'Github)
-> m (Either Text (OAuthToken 'Github))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text (OAuthToken 'Github)
 -> m (Either Text (OAuthToken 'Github)))
-> (Either String (OAuthToken 'Github)
    -> Either Text (OAuthToken 'Github))
-> Either String (OAuthToken 'Github)
-> m (Either Text (OAuthToken 'Github))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Text)
-> Either String (OAuthToken 'Github)
-> Either Text (OAuthToken 'Github)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
Text.pack (Either String (OAuthToken 'Github) -> m (OAuthToken 'Github))
-> Either String (OAuthToken 'Github) -> m (OAuthToken 'Github)
forall a b. (a -> b) -> a -> b
$
        if Status -> Bool
statusIsSuccessful (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
response)
            then ByteString -> Either String (OAuthToken 'Github)
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> Either String (OAuthToken 'Github))
-> ByteString -> Either String (OAuthToken 'Github)
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response
            else String -> Either String (OAuthToken 'Github)
forall a b. a -> Either a b
Left (String -> Either String (OAuthToken 'Github))
-> String -> Either String (OAuthToken 'Github)
forall a b. (a -> b) -> a -> b
$ String
"Response: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Response ByteString -> String
forall a. Show a => a -> String
show Response ByteString
response
    UTCTime
now <- m UTCTime
forall (m :: * -> *). MonadNow m => m UTCTime
getCurrentTime
    let cookie :: SetCookie
cookie = EncodeSigner -> OAuthToken 'Github -> UTCTime -> SetCookie
createSessionCookie EncodeSigner
_configJWTSignature OAuthToken 'Github
token UTCTime
now
    Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN Text
"Sending cookie."
    Headers
  '[Header "Set-Cookie" SetCookie, Header "Location" Text] NoContent
-> m (Headers
        '[Header "Set-Cookie" SetCookie, Header "Location" Text] NoContent)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Headers
   '[Header "Set-Cookie" SetCookie, Header "Location" Text] NoContent
 -> m (Headers
         '[Header "Set-Cookie" SetCookie, Header "Location" Text]
         NoContent))
-> (NoContent
    -> Headers
         '[Header "Set-Cookie" SetCookie, Header "Location" Text] NoContent)
-> NoContent
-> m (Headers
        '[Header "Set-Cookie" SetCookie, Header "Location" Text] NoContent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SetCookie
-> Headers '[Header "Location" Text] NoContent
-> Headers
     '[Header "Set-Cookie" SetCookie, Header "Location" Text] NoContent
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader SetCookie
cookie (Headers '[Header "Location" Text] NoContent
 -> Headers
      '[Header "Set-Cookie" SetCookie, Header "Location" Text] NoContent)
-> (NoContent -> Headers '[Header "Location" Text] NoContent)
-> NoContent
-> Headers
     '[Header "Set-Cookie" SetCookie, Header "Location" Text] NoContent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> NoContent -> Headers '[Header "Location" Text] NoContent
forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader (Text
_configFrontendUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
_configGithubCbPath) (NoContent
 -> m (Headers
         '[Header "Set-Cookie" SetCookie, Header "Location" Text]
         NoContent))
-> NoContent
-> m (Headers
        '[Header "Set-Cookie" SetCookie, Header "Location" Text] NoContent)
forall a b. (a -> b) -> a -> b
$ NoContent
NoContent

withErr ::
       (MonadLogger m, MonadError ServerError m)
    => ServerError
    -> m (Either Text b)
    -> m b
withErr :: ServerError -> m (Either Text b) -> m b
withErr ServerError
servantErr m (Either Text b)
action =
    m (Either Text b)
action m (Either Text b) -> (Either Text b -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left Text
err -> do
            Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logErrorN Text
err
            ServerError -> m b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ServerError -> m b) -> ServerError -> m b
forall a b. (a -> b) -> a -> b
$
                ServerError
servantErr {errBody :: ByteString
errBody = ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text
err}
        Right b
r -> b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
r

withErr500 ::
       (MonadLogger m, MonadError ServerError m) => m (Either Text b) -> m b
withErr500 :: m (Either Text b) -> m b
withErr500 = ServerError -> m (Either Text b) -> m b
forall (m :: * -> *) b.
(MonadLogger m, MonadError ServerError m) =>
ServerError -> m (Either Text b) -> m b
withErr ServerError
err500

makeTokenRequest :: GithubEndpoints -> Config -> OAuthCode -> Request
makeTokenRequest :: GithubEndpoints -> Config -> OAuthCode -> Request
makeTokenRequest GithubEndpoints {Text
Request
BaseUrl
_githubEndpointsCallbackUri :: Text
_githubEndpointsApiBaseUrl :: BaseUrl
_githubEndpointsAccessTokenLocation :: Request
_githubEndpointsAuthLocation :: Request
_githubEndpointsCallbackUri :: GithubEndpoints -> Text
_githubEndpointsApiBaseUrl :: GithubEndpoints -> BaseUrl
_githubEndpointsAccessTokenLocation :: GithubEndpoints -> Request
_githubEndpointsAuthLocation :: GithubEndpoints -> Request
..} Config {Text
EncodeSigner
OAuthClientSecret
OAuthClientId
_configGithubClientSecret :: OAuthClientSecret
_configGithubClientId :: OAuthClientId
_configGithubCbPath :: Text
_configFrontendUrl :: Text
_configJWTSignature :: EncodeSigner
_configGithubClientSecret :: Config -> OAuthClientSecret
_configGithubClientId :: Config -> OAuthClientId
_configGithubCbPath :: Config -> Text
_configFrontendUrl :: Config -> Text
_configJWTSignature :: Config -> EncodeSigner
..} OAuthCode
code =
    [(ByteString, Maybe ByteString)] -> Request -> Request
setQueryString [(ByteString, Maybe ByteString)]
params (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Request -> Request
addUserAgent (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> ByteString -> Request -> Request
addRequestHeader HeaderName
hAccept ByteString
"application/json" (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$
    Request
_githubEndpointsAccessTokenLocation
  where
    params :: [(ByteString, Maybe ByteString)]
params =
        [ (ByteString
"client_id", OAuthClientId -> Maybe ByteString
forall a. (Newtype a, O a ~ Text) => a -> Maybe ByteString
param OAuthClientId
_configGithubClientId)
        , (ByteString
"client_secret", OAuthClientSecret -> Maybe ByteString
forall a. (Newtype a, O a ~ Text) => a -> Maybe ByteString
param OAuthClientSecret
_configGithubClientSecret)
        , (ByteString
"code", OAuthCode -> Maybe ByteString
forall a. (Newtype a, O a ~ Text) => a -> Maybe ByteString
param OAuthCode
code)
        ]
    param ::
           forall a. (Newtype a, O a ~ Text)
        => a
        -> Maybe ByteString
    param :: a -> Maybe ByteString
param = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> (a -> ByteString) -> a -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (a -> Text) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall n. Newtype n => n -> O n
unpack

createSessionCookie :: JWT.EncodeSigner -> OAuthToken 'Github -> UTCTime -> SetCookie
createSessionCookie :: EncodeSigner -> OAuthToken 'Github -> UTCTime -> SetCookie
createSessionCookie EncodeSigner
signer OAuthToken 'Github
token UTCTime
now =
    SetCookie
defaultSetCookie
        { setCookieName :: ByteString
setCookieName = Text -> ByteString
encodeUtf8 Text
hSessionIdCookie
        , setCookieValue :: ByteString
setCookieValue = Text -> ByteString
encodeUtf8 Text
cookieValue
        , setCookiePath :: Maybe ByteString
setCookiePath = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"/"
        , setCookieExpires :: Maybe UTCTime
setCookieExpires = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
expiryDate
        , setCookieMaxAge :: Maybe DiffTime
setCookieMaxAge = DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just (DiffTime -> Maybe DiffTime)
-> (NominalDiffTime -> DiffTime)
-> NominalDiffTime
-> Maybe DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> DiffTime
forall a. Fractional a => Rational -> a
fromRational (Rational -> DiffTime)
-> (NominalDiffTime -> Rational) -> NominalDiffTime -> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Rational
forall a. Real a => a -> Rational
toRational (NominalDiffTime -> Maybe DiffTime)
-> NominalDiffTime -> Maybe DiffTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
expiryDuration
        , setCookieSecure :: Bool
setCookieSecure = Bool
True
        , setCookieHttpOnly :: Bool
setCookieHttpOnly = Bool
True -- Not accessible from JavaScript
        }
  where
    expiryDate :: UTCTime
expiryDate = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
expiryDuration UTCTime
now
    cookieValue :: Text
cookieValue = EncodeSigner -> JOSEHeader -> JWTClaimsSet -> Text
JWT.encodeSigned EncodeSigner
signer JOSEHeader
forall a. Monoid a => a
mempty JWTClaimsSet
jwtClaims
    jwtClaims :: JWTClaimsSet
jwtClaims =
        JWTClaimsSet
forall a. Monoid a => a
mempty
            { exp :: Maybe IntDate
JWT.exp = NominalDiffTime -> Maybe IntDate
JWT.numericDate (NominalDiffTime -> Maybe IntDate)
-> NominalDiffTime -> Maybe IntDate
forall a b. (a -> b) -> a -> b
$ UTCTime -> NominalDiffTime
utcTimeToPOSIXSeconds UTCTime
expiryDate
            , unregisteredClaims :: ClaimsMap
JWT.unregisteredClaims =
                  Map Text Value -> ClaimsMap
JWT.ClaimsMap (Map Text Value -> ClaimsMap) -> Map Text Value -> ClaimsMap
forall a b. (a -> b) -> a -> b
$
                  [(Text, Value)] -> Map Text Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                      [ ( Text
githubTokenClaim
                        , Text -> Value
String (Text -> Value)
-> (Token 'Github -> Text) -> Token 'Github -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token 'Github -> Text
forall n. Newtype n => n -> O n
unpack (Token 'Github -> Value) -> Token 'Github -> Value
forall a b. (a -> b) -> a -> b
$ OAuthToken 'Github -> Token 'Github
forall (a :: TokenProvider). OAuthToken a -> Token a
oAuthTokenAccessToken OAuthToken 'Github
token)
                      ]
            }

getGists ::
       ( MonadNow m
       , MonadLogger m
       , MonadWeb m
       , MonadError ServerError m
       , MonadIO m
       , MonadReader Env m
       )
    => Maybe Text
    -> m [Gist]
getGists :: Maybe Text -> m [Gist]
getGists Maybe Text
header = Maybe Text -> (Token 'Github -> ClientM [Gist]) -> m [Gist]
forall (m :: * -> *) a.
(MonadNow m, MonadLogger m, MonadError ServerError m, MonadWeb m,
 MonadIO m, MonadReader Env m) =>
Maybe Text -> (Token 'Github -> ClientM a) -> m a
withGithubToken Maybe Text
header (\Token 'Github
token -> Maybe (Token 'Github) -> ClientM [Gist]
Gist.getGists (Maybe (Token 'Github) -> ClientM [Gist])
-> Maybe (Token 'Github) -> ClientM [Gist]
forall a b. (a -> b) -> a -> b
$ Token 'Github -> Maybe (Token 'Github)
forall a. a -> Maybe a
Just Token 'Github
token)

createNewGist ::
       ( MonadNow m
       , MonadLogger m
       , MonadWeb m
       , MonadError ServerError m
       , MonadIO m
       , MonadReader Env m
       )
    => Maybe Text
    -> NewGist
    -> m Gist
createNewGist :: Maybe Text -> NewGist -> m Gist
createNewGist Maybe Text
header NewGist
newGist =
    Maybe Text -> (Token 'Github -> ClientM Gist) -> m Gist
forall (m :: * -> *) a.
(MonadNow m, MonadLogger m, MonadError ServerError m, MonadWeb m,
 MonadIO m, MonadReader Env m) =>
Maybe Text -> (Token 'Github -> ClientM a) -> m a
withGithubToken Maybe Text
header (\Token 'Github
token -> Maybe (Token 'Github) -> NewGist -> ClientM Gist
Gist.createNewGist (Token 'Github -> Maybe (Token 'Github)
forall a. a -> Maybe a
Just Token 'Github
token) NewGist
newGist)

getGist ::
       ( MonadNow m
       , MonadLogger m
       , MonadWeb m
       , MonadError ServerError m
       , MonadIO m
       , MonadReader Env m
       )
    => Maybe Text
    -> GistId
    -> m Gist
getGist :: Maybe Text -> GistId -> m Gist
getGist Maybe Text
header GistId
gistId =
    Maybe Text -> (Token 'Github -> ClientM Gist) -> m Gist
forall (m :: * -> *) a.
(MonadNow m, MonadLogger m, MonadError ServerError m, MonadWeb m,
 MonadIO m, MonadReader Env m) =>
Maybe Text -> (Token 'Github -> ClientM a) -> m a
withGithubToken Maybe Text
header (\Token 'Github
token -> Maybe (Token 'Github) -> GistId -> ClientM Gist
Gist.getGist (Token 'Github -> Maybe (Token 'Github)
forall a. a -> Maybe a
Just Token 'Github
token) GistId
gistId)

updateGist ::
       ( MonadNow m
       , MonadLogger m
       , MonadWeb m
       , MonadError ServerError m
       , MonadIO m
       , MonadReader Env m
       )
    => Maybe Text
    -> GistId
    -> NewGist
    -> m Gist
updateGist :: Maybe Text -> GistId -> NewGist -> m Gist
updateGist Maybe Text
header GistId
gistId NewGist
newGist =
    Maybe Text -> (Token 'Github -> ClientM Gist) -> m Gist
forall (m :: * -> *) a.
(MonadNow m, MonadLogger m, MonadError ServerError m, MonadWeb m,
 MonadIO m, MonadReader Env m) =>
Maybe Text -> (Token 'Github -> ClientM a) -> m a
withGithubToken
        Maybe Text
header
        (\Token 'Github
token -> Maybe (Token 'Github) -> GistId -> NewGist -> ClientM Gist
Gist.updateGist (Token 'Github -> Maybe (Token 'Github)
forall a. a -> Maybe a
Just Token 'Github
token) GistId
gistId NewGist
newGist)

withGithubToken ::
       ( MonadNow m
       , MonadLogger m
       , MonadError ServerError m
       , MonadWeb m
       , MonadIO m
       , MonadReader Env m
       )
    => Maybe Text
    -> (Token 'Github -> ClientM a)
    -> m a
withGithubToken :: Maybe Text -> (Token 'Github -> ClientM a) -> m a
withGithubToken Maybe Text
cookieHeader Token 'Github -> ClientM a
action = do
    BaseUrl
baseUrl <- Getting BaseUrl Env BaseUrl -> m BaseUrl
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((GithubEndpoints -> Const BaseUrl GithubEndpoints)
-> Env -> Const BaseUrl Env
forall s t a b. Field1 s t a b => Lens s t a b
_1 ((GithubEndpoints -> Const BaseUrl GithubEndpoints)
 -> Env -> Const BaseUrl Env)
-> ((BaseUrl -> Const BaseUrl BaseUrl)
    -> GithubEndpoints -> Const BaseUrl GithubEndpoints)
-> Getting BaseUrl Env BaseUrl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BaseUrl -> Const BaseUrl BaseUrl)
-> GithubEndpoints -> Const BaseUrl GithubEndpoints
Lens' GithubEndpoints BaseUrl
githubEndpointsApiBaseUrl)
    EncodeSigner
jwtSignature <- Getting EncodeSigner Env EncodeSigner -> m EncodeSigner
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Config -> Const EncodeSigner Config)
-> Env -> Const EncodeSigner Env
forall s t a b. Field2 s t a b => Lens s t a b
_2 ((Config -> Const EncodeSigner Config)
 -> Env -> Const EncodeSigner Env)
-> ((EncodeSigner -> Const EncodeSigner EncodeSigner)
    -> Config -> Const EncodeSigner Config)
-> Getting EncodeSigner Env EncodeSigner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EncodeSigner -> Const EncodeSigner EncodeSigner)
-> Config -> Const EncodeSigner Config
Lens' Config EncodeSigner
configJWTSignature)
    Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN Text
"Initialising connection manager."
    Manager
manager <- m Manager
forall (m :: * -> *). MonadWeb m => m Manager
makeManager
    let clientEnv :: ClientEnv
clientEnv = Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
manager BaseUrl
baseUrl
    NominalDiffTime
now <- m NominalDiffTime
forall (m :: * -> *). MonadNow m => m NominalDiffTime
getPOSIXTime
    Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN Text
"Extracting token."
    case EncodeSigner
-> NominalDiffTime -> Maybe Text -> Either Text (Token 'Github)
extractGithubToken EncodeSigner
jwtSignature NominalDiffTime
now Maybe Text
cookieHeader of
        Left Text
err -> do
            Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logErrorN (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                Text
"Failed to extract github token at step: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
showText Text
err
            ServerError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err401
        Right Token 'Github
token -> do
            Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN Text
"Making github request with token."
            Either ClientError a
response <- IO (Either ClientError a) -> m (Either ClientError a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ClientError a) -> m (Either ClientError a))
-> IO (Either ClientError a) -> m (Either ClientError a)
forall a b. (a -> b) -> a -> b
$ (ClientM a -> ClientEnv -> IO (Either ClientError a))
-> ClientEnv -> ClientM a -> IO (Either ClientError a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ClientM a -> ClientEnv -> IO (Either ClientError a)
forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientEnv
clientEnv (ClientM a -> IO (Either ClientError a))
-> ClientM a -> IO (Either ClientError a)
forall a b. (a -> b) -> a -> b
$ Token 'Github -> ClientM a
action Token 'Github
token
            case Either ClientError a
response of
                Left (FailureResponse RequestF () (BaseUrl, ByteString)
_ Response
failureResponse)
                    | Response -> Status
forall a. ResponseF a -> Status
responseStatusCode Response
failureResponse Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
status404 ->
                        ServerError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err404
                Left ClientError
err -> do
                    Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logErrorN (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
                        Text
"Failed to read github endpoint: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ClientError -> Text
forall a. Show a => a -> Text
showText ClientError
err
                    ServerError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err500
                Right a
result -> do
                  Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN Text
"Github request successful."
                  a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result

server ::
       ( MonadNow m
       , MonadWeb m
       , MonadLogger m
       , MonadError ServerError m
       , MonadIO m
       , MonadReader Env m
       )
    => ServerT API m
server :: ServerT API m
server =
    ((Maybe Text -> m AuthStatus
forall (m :: * -> *).
(MonadNow m, MonadLogger m, MonadReader Env m) =>
Maybe Text -> m AuthStatus
authStatus (Maybe Text -> m AuthStatus)
-> m (Headers '[Header "Location" Text] NoContent)
-> (Maybe Text -> m AuthStatus)
   :<|> m (Headers '[Header "Location" Text] NoContent)
forall a b. a -> b -> a :<|> b
:<|> m (Headers '[Header "Location" Text] NoContent)
forall (m :: * -> *).
(MonadLogger m, MonadReader Env m) =>
m (Headers '[Header "Location" Text] NoContent)
githubRedirect) ((Maybe Text -> m AuthStatus)
 :<|> m (Headers '[Header "Location" Text] NoContent))
-> (Maybe Text
    -> m [Gist]
       :<|> ((NewGist -> m Gist)
             :<|> ((GistId -> m Gist) :<|> (GistId -> NewGist -> m Gist))))
-> ((Maybe Text -> m AuthStatus)
    :<|> m (Headers '[Header "Location" Text] NoContent))
   :<|> (Maybe Text
         -> m [Gist]
            :<|> ((NewGist -> m Gist)
                  :<|> ((GistId -> m Gist) :<|> (GistId -> NewGist -> m Gist))))
forall a b. a -> b -> a :<|> b
:<|>
     (\Maybe Text
header ->
          Maybe Text -> m [Gist]
forall (m :: * -> *).
(MonadNow m, MonadLogger m, MonadWeb m, MonadError ServerError m,
 MonadIO m, MonadReader Env m) =>
Maybe Text -> m [Gist]
getGists Maybe Text
header m [Gist]
-> ((NewGist -> m Gist)
    :<|> ((GistId -> m Gist) :<|> (GistId -> NewGist -> m Gist)))
-> m [Gist]
   :<|> ((NewGist -> m Gist)
         :<|> ((GistId -> m Gist) :<|> (GistId -> NewGist -> m Gist)))
forall a b. a -> b -> a :<|> b
:<|> Maybe Text -> NewGist -> m Gist
forall (m :: * -> *).
(MonadNow m, MonadLogger m, MonadWeb m, MonadError ServerError m,
 MonadIO m, MonadReader Env m) =>
Maybe Text -> NewGist -> m Gist
createNewGist Maybe Text
header (NewGist -> m Gist)
-> ((GistId -> m Gist) :<|> (GistId -> NewGist -> m Gist))
-> (NewGist -> m Gist)
   :<|> ((GistId -> m Gist) :<|> (GistId -> NewGist -> m Gist))
forall a b. a -> b -> a :<|> b
:<|> Maybe Text -> GistId -> m Gist
forall (m :: * -> *).
(MonadNow m, MonadLogger m, MonadWeb m, MonadError ServerError m,
 MonadIO m, MonadReader Env m) =>
Maybe Text -> GistId -> m Gist
getGist Maybe Text
header (GistId -> m Gist)
-> (GistId -> NewGist -> m Gist)
-> (GistId -> m Gist) :<|> (GistId -> NewGist -> m Gist)
forall a b. a -> b -> a :<|> b
:<|>
          Maybe Text -> GistId -> NewGist -> m Gist
forall (m :: * -> *).
(MonadNow m, MonadLogger m, MonadWeb m, MonadError ServerError m,
 MonadIO m, MonadReader Env m) =>
Maybe Text -> GistId -> NewGist -> m Gist
updateGist Maybe Text
header)) (((Maybe Text -> m AuthStatus)
  :<|> m (Headers '[Header "Location" Text] NoContent))
 :<|> (Maybe Text
       -> m [Gist]
          :<|> ((NewGist -> m Gist)
                :<|> ((GistId -> m Gist) :<|> (GistId -> NewGist -> m Gist)))))
-> (Maybe OAuthCode
    -> m (Headers
            '[Header "Set-Cookie" SetCookie, Header "Location" Text]
            NoContent))
-> (((Maybe Text -> m AuthStatus)
     :<|> m (Headers '[Header "Location" Text] NoContent))
    :<|> (Maybe Text
          -> m [Gist]
             :<|> ((NewGist -> m Gist)
                   :<|> ((GistId -> m Gist) :<|> (GistId -> NewGist -> m Gist)))))
   :<|> (Maybe OAuthCode
         -> m (Headers
                 '[Header "Set-Cookie" SetCookie, Header "Location" Text]
                 NoContent))
forall a b. a -> b -> a :<|> b
:<|>
    Maybe OAuthCode
-> m (Headers
        '[Header "Set-Cookie" SetCookie, Header "Location" Text] NoContent)
forall (m :: * -> *).
(MonadLogger m, MonadWeb m, MonadError ServerError m, MonadNow m,
 MonadReader Env m) =>
Maybe OAuthCode
-> m (Headers
        '[Header "Set-Cookie" SetCookie, Header "Location" Text] NoContent)
githubCallback

showText :: Show a => a -> Text
showText :: a -> Text
showText = String -> Text
Text.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show