{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-typed-holes #-}

{- |
Module      : Monax.Auth.Servant
Description : Servant helpers for using Monax.Auth
License     : AGPL-3.0-or-later
Maintainer  : monawasensei@gmail.com

This module primarily defines `SessionIdCookie` and `AuthSessionIdCookie` for
identifying and authorizing user sessions for a given operation.

Included are some helper types for form-based authenticate (rather than Basic)
to issue tokens and the `setSessionIdCookie` function for attaching a session token
to an http response so that a user can use the session.
-}
module Monax.Auth.Servant (
  RunAuthRealm (..),
  SessionTokenAndClaims (SessionTokenAndClaims),
  sessionTokenAndClaimsSessionId,
  sessionTokenAndClaimsClaims,
  SessionIdCookie (),
  AuthenticationRedirectURL (..),
  AuthSessionIdCookie (),
  BasicAuthReqBody (..),
  setSessionIdCookie,
) where

import Control.Monad ((<=<))
import Control.Monad.IO.Class (liftIO)
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as B.Char8
import Data.Char (toLower)
import Data.Coerce (coerce)
import Data.Kind (Type)
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy (..))
import Data.String (IsString, fromString)
import Data.Text (Text)
import Data.Text.Encoding qualified as T.E
import GHC.Generics (Generic)
import GHC.TypeLits (KnownSymbol, Symbol)
import Monax.Auth (
  AuthException (NotAuthorized),
  AuthResult (AuthFail, AuthSuccess),
  Claims,
  EncryptedSessionId (EncryptedSessionId),
  RunAuth,
  SessionId,
  Token (Token),
  decryptSessionId,
  lookupSession,
  runAuth,
 )
import Network.Wai (Request (requestHeaders))
import Servant.API (
  AddHeader,
  HasLink (..),
  Link,
  Optional,
  Strict,
  addHeader,
  type (:>),
 )
import Servant.Server (
  Context,
  HasContextEntry (..),
  HasServer (..),
  Server,
  ServerError (errHeaders),
  err303,
  err401,
  err403,
 )
import Servant.Server.Internal.Delayed (Delayed, addHeaderCheck)
import Servant.Server.Internal.DelayedIO (
  DelayedIO,
  delayedFailFatal,
  withRequest,
 )
import Servant.Server.Internal.Router (Router)
import Web.FormUrlEncoded (Form, FromForm (..), lookupUnique)

{- |
RunAuth scoped over a certain authorization realm.
-}
newtype RunAuthRealm (realm :: Symbol) m
  = RunAuthRealm {forall (realm :: Symbol) (m :: * -> *).
RunAuthRealm realm m -> RunAuth m
runAuthRealm :: RunAuth m}

{- |
A `SessionId` and the corresponding `Claims` that that session represents.
-}
data SessionTokenAndClaims = SessionTokenAndClaims' SessionId Claims
  deriving (Int -> SessionTokenAndClaims -> ShowS
[SessionTokenAndClaims] -> ShowS
SessionTokenAndClaims -> String
(Int -> SessionTokenAndClaims -> ShowS)
-> (SessionTokenAndClaims -> String)
-> ([SessionTokenAndClaims] -> ShowS)
-> Show SessionTokenAndClaims
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SessionTokenAndClaims -> ShowS
showsPrec :: Int -> SessionTokenAndClaims -> ShowS
$cshow :: SessionTokenAndClaims -> String
show :: SessionTokenAndClaims -> String
$cshowList :: [SessionTokenAndClaims] -> ShowS
showList :: [SessionTokenAndClaims] -> ShowS
Show, SessionTokenAndClaims -> SessionTokenAndClaims -> Bool
(SessionTokenAndClaims -> SessionTokenAndClaims -> Bool)
-> (SessionTokenAndClaims -> SessionTokenAndClaims -> Bool)
-> Eq SessionTokenAndClaims
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SessionTokenAndClaims -> SessionTokenAndClaims -> Bool
== :: SessionTokenAndClaims -> SessionTokenAndClaims -> Bool
$c/= :: SessionTokenAndClaims -> SessionTokenAndClaims -> Bool
/= :: SessionTokenAndClaims -> SessionTokenAndClaims -> Bool
Eq, (forall x. SessionTokenAndClaims -> Rep SessionTokenAndClaims x)
-> (forall x. Rep SessionTokenAndClaims x -> SessionTokenAndClaims)
-> Generic SessionTokenAndClaims
forall x. Rep SessionTokenAndClaims x -> SessionTokenAndClaims
forall x. SessionTokenAndClaims -> Rep SessionTokenAndClaims x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SessionTokenAndClaims -> Rep SessionTokenAndClaims x
from :: forall x. SessionTokenAndClaims -> Rep SessionTokenAndClaims x
$cto :: forall x. Rep SessionTokenAndClaims x -> SessionTokenAndClaims
to :: forall x. Rep SessionTokenAndClaims x -> SessionTokenAndClaims
Generic)

pattern SessionTokenAndClaims :: SessionId -> Claims -> SessionTokenAndClaims
pattern $mSessionTokenAndClaims :: forall {r}.
SessionTokenAndClaims
-> (SessionId -> Claims -> r) -> ((# #) -> r) -> r
SessionTokenAndClaims s c <- SessionTokenAndClaims' s c

-- | Get `SessionId`
sessionTokenAndClaimsSessionId :: SessionTokenAndClaims -> SessionId
sessionTokenAndClaimsSessionId :: SessionTokenAndClaims -> SessionId
sessionTokenAndClaimsSessionId (SessionTokenAndClaims' SessionId
s Claims
_) = SessionId
s

-- | Get `Claims`
sessionTokenAndClaimsClaims :: SessionTokenAndClaims -> Claims
sessionTokenAndClaimsClaims :: SessionTokenAndClaims -> Claims
sessionTokenAndClaimsClaims (SessionTokenAndClaims' SessionId
_ Claims
c) = Claims
c

data SessionTokenAndClaimsResult
  = NoSessionTokenCookie
  | CouldNotDecrypt EncryptedSessionId
  | DidNotFindSessionId SessionId
  | FoundSessionId SessionTokenAndClaims

attemptToGetClaimsFromCookieHeader ::
  RunAuth IO ->
  Request ->
  DelayedIO SessionTokenAndClaimsResult
attemptToGetClaimsFromCookieHeader :: RunAuth IO -> Request -> DelayedIO SessionTokenAndClaimsResult
attemptToGetClaimsFromCookieHeader RunAuth IO
unlift Request
r =
  case ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
forall a. IsString a => a
sessionTokenCookieName
    ([(ByteString, ByteString)] -> Maybe ByteString)
-> (Request -> [(ByteString, ByteString)])
-> Request
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString) -> (ByteString, ByteString))
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
x, ByteString
y) -> ((Char -> Char) -> ByteString -> ByteString
B.Char8.map Char -> Char
toLower ByteString
x, ByteString
y))
    ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> (Request -> [(ByteString, ByteString)])
-> Request
-> [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [(ByteString, ByteString)]
requestCookies
    (Request -> Maybe ByteString) -> Request -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request
r of
    Maybe ByteString
Nothing -> SessionTokenAndClaimsResult
-> DelayedIO SessionTokenAndClaimsResult
forall a. a -> DelayedIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SessionTokenAndClaimsResult
NoSessionTokenCookie
    Just ByteString
ms -> do
      dr <-
        IO (AuthResult SessionTokenAndClaimsResult)
-> DelayedIO (AuthResult SessionTokenAndClaimsResult)
forall a. IO a -> DelayedIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
          (IO (AuthResult SessionTokenAndClaimsResult)
 -> DelayedIO (AuthResult SessionTokenAndClaimsResult))
-> (Auth SessionTokenAndClaimsResult
    -> IO (AuthResult SessionTokenAndClaimsResult))
-> Auth SessionTokenAndClaimsResult
-> DelayedIO (AuthResult SessionTokenAndClaimsResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunAuth IO -> forall x. Auth x -> IO (AuthResult x)
forall (m :: * -> *).
RunAuth m -> forall x. Auth x -> m (AuthResult x)
runAuth
            RunAuth IO
unlift
          (Auth SessionTokenAndClaimsResult
 -> DelayedIO (AuthResult SessionTokenAndClaimsResult))
-> Auth SessionTokenAndClaimsResult
-> DelayedIO (AuthResult SessionTokenAndClaimsResult)
forall a b. (a -> b) -> a -> b
$ do
            let enc :: EncryptedSessionId
enc = ByteString -> EncryptedSessionId
EncryptedSessionId ByteString
ms
            d <- EncryptedSessionId -> Auth (Maybe SessionId)
decryptSessionId EncryptedSessionId
enc
            case d of
              Maybe SessionId
Nothing -> SessionTokenAndClaimsResult -> Auth SessionTokenAndClaimsResult
forall a. a -> Auth a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SessionTokenAndClaimsResult -> Auth SessionTokenAndClaimsResult)
-> (EncryptedSessionId -> SessionTokenAndClaimsResult)
-> EncryptedSessionId
-> Auth SessionTokenAndClaimsResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EncryptedSessionId -> SessionTokenAndClaimsResult
CouldNotDecrypt (EncryptedSessionId -> Auth SessionTokenAndClaimsResult)
-> EncryptedSessionId -> Auth SessionTokenAndClaimsResult
forall a b. (a -> b) -> a -> b
$ EncryptedSessionId
enc
              Just SessionId
d' -> do
                mc <- SessionId -> Auth (Maybe Claims)
lookupSession SessionId
d'
                case mc of
                  Maybe Claims
Nothing -> SessionTokenAndClaimsResult -> Auth SessionTokenAndClaimsResult
forall a. a -> Auth a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SessionTokenAndClaimsResult -> Auth SessionTokenAndClaimsResult)
-> (SessionId -> SessionTokenAndClaimsResult)
-> SessionId
-> Auth SessionTokenAndClaimsResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionId -> SessionTokenAndClaimsResult
DidNotFindSessionId (SessionId -> Auth SessionTokenAndClaimsResult)
-> SessionId -> Auth SessionTokenAndClaimsResult
forall a b. (a -> b) -> a -> b
$ SessionId
d'
                  Just Claims
c -> SessionTokenAndClaimsResult -> Auth SessionTokenAndClaimsResult
forall a. a -> Auth a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SessionTokenAndClaimsResult -> Auth SessionTokenAndClaimsResult)
-> (SessionTokenAndClaims -> SessionTokenAndClaimsResult)
-> SessionTokenAndClaims
-> Auth SessionTokenAndClaimsResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionTokenAndClaims -> SessionTokenAndClaimsResult
FoundSessionId (SessionTokenAndClaims -> Auth SessionTokenAndClaimsResult)
-> SessionTokenAndClaims -> Auth SessionTokenAndClaimsResult
forall a b. (a -> b) -> a -> b
$ SessionId -> Claims -> SessionTokenAndClaims
SessionTokenAndClaims' SessionId
d' Claims
c
      case dr of
        AuthFail AuthException
e -> ServerError -> DelayedIO SessionTokenAndClaimsResult
forall a. ServerError -> DelayedIO a
delayedFailFatal (ServerError -> DelayedIO SessionTokenAndClaimsResult)
-> ServerError -> DelayedIO SessionTokenAndClaimsResult
forall a b. (a -> b) -> a -> b
$ case AuthException
e of
          AuthException
NotAuthorized -> ServerError
err403
          AuthException
_ -> ServerError
err401
        AuthSuccess SessionTokenAndClaimsResult
a -> SessionTokenAndClaimsResult
-> DelayedIO SessionTokenAndClaimsResult
forall a. a -> DelayedIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SessionTokenAndClaimsResult
a

{- |
Retrieve a `SessionTokenAndClaims` from a cookie sent in the request.
-}
data SessionIdCookie (realm :: Symbol)

instance
  ( HasServer api context
  , HasContextEntry context (RunAuthRealm realm IO)
  ) =>
  HasServer (SessionIdCookie realm :> api :: Type) context
  where
  type
    ServerT (SessionIdCookie realm :> api) m =
      Maybe SessionTokenAndClaims -> ServerT api m
  route ::
    ( HasServer api context
    , HasContextEntry context (RunAuthRealm realm IO)
    ) =>
    Proxy (SessionIdCookie realm :> api) ->
    Context context ->
    Delayed env (Server (SessionIdCookie realm :> api)) ->
    Router env
  route :: forall env.
(HasServer api context,
 HasContextEntry context (RunAuthRealm realm IO)) =>
Proxy (SessionIdCookie realm :> api)
-> Context context
-> Delayed env (Server (SessionIdCookie realm :> api))
-> Router env
route Proxy (SessionIdCookie realm :> api)
Proxy Context context
context Delayed env (Server (SessionIdCookie realm :> api))
subserver =
    Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route
      (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api)
      Context context
context
      ( Delayed env (Server (SessionIdCookie realm :> api))
Delayed env (Maybe SessionTokenAndClaims -> Server api)
subserver
          Delayed env (Maybe SessionTokenAndClaims -> Server api)
-> DelayedIO (Maybe SessionTokenAndClaims)
-> Delayed env (Server api)
forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
`addHeaderCheck` (Request -> DelayedIO (Maybe SessionTokenAndClaims))
-> DelayedIO (Maybe SessionTokenAndClaims)
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest
            ( \Request
r ->
                RunAuth IO -> Request -> DelayedIO SessionTokenAndClaimsResult
attemptToGetClaimsFromCookieHeader
                  (forall (realm :: Symbol) (m :: * -> *).
RunAuthRealm realm m -> RunAuth m
runAuthRealm @realm (RunAuthRealm realm IO -> RunAuth IO)
-> (Context context -> RunAuthRealm realm IO)
-> Context context
-> RunAuth IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context context -> RunAuthRealm realm IO
forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (Context context -> RunAuth IO) -> Context context -> RunAuth IO
forall a b. (a -> b) -> a -> b
$ Context context
context)
                  Request
r
                  DelayedIO SessionTokenAndClaimsResult
-> (SessionTokenAndClaimsResult
    -> DelayedIO (Maybe SessionTokenAndClaims))
-> DelayedIO (Maybe SessionTokenAndClaims)
forall a b. DelayedIO a -> (a -> DelayedIO b) -> DelayedIO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    FoundSessionId SessionTokenAndClaims
c -> Maybe SessionTokenAndClaims
-> DelayedIO (Maybe SessionTokenAndClaims)
forall a. a -> DelayedIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe SessionTokenAndClaims
 -> DelayedIO (Maybe SessionTokenAndClaims))
-> (SessionTokenAndClaims -> Maybe SessionTokenAndClaims)
-> SessionTokenAndClaims
-> DelayedIO (Maybe SessionTokenAndClaims)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionTokenAndClaims -> Maybe SessionTokenAndClaims
forall a. a -> Maybe a
Just (SessionTokenAndClaims -> DelayedIO (Maybe SessionTokenAndClaims))
-> SessionTokenAndClaims -> DelayedIO (Maybe SessionTokenAndClaims)
forall a b. (a -> b) -> a -> b
$ SessionTokenAndClaims
c
                    SessionTokenAndClaimsResult
_ -> Maybe SessionTokenAndClaims
-> DelayedIO (Maybe SessionTokenAndClaims)
forall a. a -> DelayedIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SessionTokenAndClaims
forall a. Maybe a
Nothing
            )
      )

  hoistServerWithContext ::
    ( HasServer api context
    , HasContextEntry context (RunAuthRealm realm IO)
    ) =>
    Proxy (SessionIdCookie realm :> api) ->
    Proxy context ->
    (forall x. m x -> n x) ->
    ServerT (SessionIdCookie realm :> api) m ->
    ServerT (SessionIdCookie realm :> api) n
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
(HasServer api context,
 HasContextEntry context (RunAuthRealm realm IO)) =>
Proxy (SessionIdCookie realm :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (SessionIdCookie realm :> api) m
-> ServerT (SessionIdCookie realm :> api) n
hoistServerWithContext Proxy (SessionIdCookie realm :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (SessionIdCookie realm :> api) m
s =
    Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: * -> *) (n :: * -> *).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (Maybe SessionTokenAndClaims -> ServerT api m)
-> Maybe SessionTokenAndClaims
-> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (SessionIdCookie realm :> api) m
Maybe SessionTokenAndClaims -> ServerT api m
s

instance (HasLink api) => HasLink (SessionIdCookie realm :> api) where
  type MkLink (SessionIdCookie realm :> api) a = MkLink api a
  toLink ::
    (HasLink api) =>
    (Link -> a) ->
    Proxy (SessionIdCookie realm :> api) ->
    Link ->
    MkLink (SessionIdCookie realm :> api) a
  toLink :: forall a.
HasLink api =>
(Link -> a)
-> Proxy (SessionIdCookie realm :> api)
-> Link
-> MkLink (SessionIdCookie realm :> api) a
toLink Link -> a
toA Proxy (SessionIdCookie realm :> api)
_ = (Link -> a) -> Proxy api -> Link -> MkLink api a
forall a. (Link -> a) -> Proxy api -> Link -> MkLink api a
forall {k} (endpoint :: k) a.
HasLink endpoint =>
(Link -> a) -> Proxy endpoint -> Link -> MkLink endpoint a
toLink Link -> a
toA (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api)

-- Ideally, the auth error would contain a path that a user can authenticate to
-- retrieve a valid token at.

{- |
Like `SessionIdCookie` but throws an auth error if
a valid token is not found.
-}
data AuthSessionIdCookie realm

{- |
A link to somewhere a user can authenticate and be issued a session token.
-}
newtype AuthenticationRedirectURL realm = AuthenticationRedirectURL Text
  deriving (Int -> AuthenticationRedirectURL realm -> ShowS
[AuthenticationRedirectURL realm] -> ShowS
AuthenticationRedirectURL realm -> String
(Int -> AuthenticationRedirectURL realm -> ShowS)
-> (AuthenticationRedirectURL realm -> String)
-> ([AuthenticationRedirectURL realm] -> ShowS)
-> Show (AuthenticationRedirectURL realm)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (realm :: k).
Int -> AuthenticationRedirectURL realm -> ShowS
forall k (realm :: k). [AuthenticationRedirectURL realm] -> ShowS
forall k (realm :: k). AuthenticationRedirectURL realm -> String
$cshowsPrec :: forall k (realm :: k).
Int -> AuthenticationRedirectURL realm -> ShowS
showsPrec :: Int -> AuthenticationRedirectURL realm -> ShowS
$cshow :: forall k (realm :: k). AuthenticationRedirectURL realm -> String
show :: AuthenticationRedirectURL realm -> String
$cshowList :: forall k (realm :: k). [AuthenticationRedirectURL realm] -> ShowS
showList :: [AuthenticationRedirectURL realm] -> ShowS
Show, AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm -> Bool
(AuthenticationRedirectURL realm
 -> AuthenticationRedirectURL realm -> Bool)
-> (AuthenticationRedirectURL realm
    -> AuthenticationRedirectURL realm -> Bool)
-> Eq (AuthenticationRedirectURL realm)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (realm :: k).
AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm -> Bool
$c== :: forall k (realm :: k).
AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm -> Bool
== :: AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm -> Bool
$c/= :: forall k (realm :: k).
AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm -> Bool
/= :: AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm -> Bool
Eq, (forall x.
 AuthenticationRedirectURL realm
 -> Rep (AuthenticationRedirectURL realm) x)
-> (forall x.
    Rep (AuthenticationRedirectURL realm) x
    -> AuthenticationRedirectURL realm)
-> Generic (AuthenticationRedirectURL realm)
forall x.
Rep (AuthenticationRedirectURL realm) x
-> AuthenticationRedirectURL realm
forall x.
AuthenticationRedirectURL realm
-> Rep (AuthenticationRedirectURL realm) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (realm :: k) x.
Rep (AuthenticationRedirectURL realm) x
-> AuthenticationRedirectURL realm
forall k (realm :: k) x.
AuthenticationRedirectURL realm
-> Rep (AuthenticationRedirectURL realm) x
$cfrom :: forall k (realm :: k) x.
AuthenticationRedirectURL realm
-> Rep (AuthenticationRedirectURL realm) x
from :: forall x.
AuthenticationRedirectURL realm
-> Rep (AuthenticationRedirectURL realm) x
$cto :: forall k (realm :: k) x.
Rep (AuthenticationRedirectURL realm) x
-> AuthenticationRedirectURL realm
to :: forall x.
Rep (AuthenticationRedirectURL realm) x
-> AuthenticationRedirectURL realm
Generic, NonEmpty (AuthenticationRedirectURL realm)
-> AuthenticationRedirectURL realm
AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
(AuthenticationRedirectURL realm
 -> AuthenticationRedirectURL realm
 -> AuthenticationRedirectURL realm)
-> (NonEmpty (AuthenticationRedirectURL realm)
    -> AuthenticationRedirectURL realm)
-> (forall b.
    Integral b =>
    b
    -> AuthenticationRedirectURL realm
    -> AuthenticationRedirectURL realm)
-> Semigroup (AuthenticationRedirectURL realm)
forall b.
Integral b =>
b
-> AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall k (realm :: k).
NonEmpty (AuthenticationRedirectURL realm)
-> AuthenticationRedirectURL realm
forall k (realm :: k).
AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
forall k (realm :: k) b.
Integral b =>
b
-> AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
$c<> :: forall k (realm :: k).
AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
<> :: AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
$csconcat :: forall k (realm :: k).
NonEmpty (AuthenticationRedirectURL realm)
-> AuthenticationRedirectURL realm
sconcat :: NonEmpty (AuthenticationRedirectURL realm)
-> AuthenticationRedirectURL realm
$cstimes :: forall k (realm :: k) b.
Integral b =>
b
-> AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
stimes :: forall b.
Integral b =>
b
-> AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
Semigroup, Semigroup (AuthenticationRedirectURL realm)
AuthenticationRedirectURL realm
Semigroup (AuthenticationRedirectURL realm) =>
AuthenticationRedirectURL realm
-> (AuthenticationRedirectURL realm
    -> AuthenticationRedirectURL realm
    -> AuthenticationRedirectURL realm)
-> ([AuthenticationRedirectURL realm]
    -> AuthenticationRedirectURL realm)
-> Monoid (AuthenticationRedirectURL realm)
[AuthenticationRedirectURL realm]
-> AuthenticationRedirectURL realm
AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall k (realm :: k). Semigroup (AuthenticationRedirectURL realm)
forall k (realm :: k). AuthenticationRedirectURL realm
forall k (realm :: k).
[AuthenticationRedirectURL realm]
-> AuthenticationRedirectURL realm
forall k (realm :: k).
AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
$cmempty :: forall k (realm :: k). AuthenticationRedirectURL realm
mempty :: AuthenticationRedirectURL realm
$cmappend :: forall k (realm :: k).
AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
mappend :: AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
-> AuthenticationRedirectURL realm
$cmconcat :: forall k (realm :: k).
[AuthenticationRedirectURL realm]
-> AuthenticationRedirectURL realm
mconcat :: [AuthenticationRedirectURL realm]
-> AuthenticationRedirectURL realm
Monoid, String -> AuthenticationRedirectURL realm
(String -> AuthenticationRedirectURL realm)
-> IsString (AuthenticationRedirectURL realm)
forall a. (String -> a) -> IsString a
forall k (realm :: k). String -> AuthenticationRedirectURL realm
$cfromString :: forall k (realm :: k). String -> AuthenticationRedirectURL realm
fromString :: String -> AuthenticationRedirectURL realm
IsString)

instance
  ( HasServer api context
  , KnownSymbol realm
  , HasContextEntry context (RunAuthRealm realm IO)
  , HasContextEntry context (AuthenticationRedirectURL realm)
  ) =>
  HasServer (AuthSessionIdCookie realm :> api :: Type) context
  where
  type ServerT (AuthSessionIdCookie realm :> api) m = SessionTokenAndClaims -> ServerT api m
  route ::
    ( HasServer api context
    , KnownSymbol realm
    , HasContextEntry context (RunAuthRealm realm IO)
    , HasContextEntry context (AuthenticationRedirectURL realm)
    ) =>
    Proxy (AuthSessionIdCookie realm :> api) ->
    Context context ->
    Delayed env (Server (AuthSessionIdCookie realm :> api)) ->
    Router env
  route :: forall env.
(HasServer api context, KnownSymbol realm,
 HasContextEntry context (RunAuthRealm realm IO),
 HasContextEntry context (AuthenticationRedirectURL realm)) =>
Proxy (AuthSessionIdCookie realm :> api)
-> Context context
-> Delayed env (Server (AuthSessionIdCookie realm :> api))
-> Router env
route Proxy (AuthSessionIdCookie realm :> api)
Proxy Context context
context Delayed env (Server (AuthSessionIdCookie realm :> api))
subserver =
    Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route
      (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api)
      Context context
context
      ( Delayed env (Server (AuthSessionIdCookie realm :> api))
Delayed env (SessionTokenAndClaims -> Server api)
subserver
          Delayed env (SessionTokenAndClaims -> Server api)
-> DelayedIO SessionTokenAndClaims -> Delayed env (Server api)
forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
`addHeaderCheck` (Request -> DelayedIO SessionTokenAndClaims)
-> DelayedIO SessionTokenAndClaims
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest
            ( ( \case
                  FoundSessionId SessionTokenAndClaims
x -> SessionTokenAndClaims -> DelayedIO SessionTokenAndClaims
forall a. a -> DelayedIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SessionTokenAndClaims
x
                  SessionTokenAndClaimsResult
_ ->
                    ServerError -> DelayedIO SessionTokenAndClaims
forall a. ServerError -> DelayedIO a
delayedFailFatal
                      ServerError
err303
                        { errHeaders =
                            [
                              ( "Location"
                              , T.E.encodeUtf8
                                  . coerce
                                  . getContextEntry @_ @(AuthenticationRedirectURL realm)
                                  $ context
                              )
                            ]
                        }
              )
                (SessionTokenAndClaimsResult -> DelayedIO SessionTokenAndClaims)
-> (Request -> DelayedIO SessionTokenAndClaimsResult)
-> Request
-> DelayedIO SessionTokenAndClaims
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< RunAuth IO -> Request -> DelayedIO SessionTokenAndClaimsResult
attemptToGetClaimsFromCookieHeader
                  (forall (realm :: Symbol) (m :: * -> *).
RunAuthRealm realm m -> RunAuth m
runAuthRealm @realm (RunAuthRealm realm IO -> RunAuth IO)
-> (Context context -> RunAuthRealm realm IO)
-> Context context
-> RunAuth IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context context -> RunAuthRealm realm IO
forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (Context context -> RunAuth IO) -> Context context -> RunAuth IO
forall a b. (a -> b) -> a -> b
$ Context context
context)
            )
      )
  hoistServerWithContext ::
    ( HasServer api context
    , KnownSymbol realm
    , HasContextEntry context (RunAuthRealm realm IO)
    , HasContextEntry context (AuthenticationRedirectURL realm)
    ) =>
    Proxy (AuthSessionIdCookie realm :> api) ->
    Proxy context ->
    (forall x. m x -> n x) ->
    ServerT (AuthSessionIdCookie realm :> api) m ->
    ServerT (AuthSessionIdCookie realm :> api) n
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
(HasServer api context, KnownSymbol realm,
 HasContextEntry context (RunAuthRealm realm IO),
 HasContextEntry context (AuthenticationRedirectURL realm)) =>
Proxy (AuthSessionIdCookie realm :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (AuthSessionIdCookie realm :> api) m
-> ServerT (AuthSessionIdCookie realm :> api) n
hoistServerWithContext Proxy (AuthSessionIdCookie realm :> api)
_ Proxy context
b forall x. m x -> n x
c ServerT (AuthSessionIdCookie realm :> api) m
d = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: * -> *) (n :: * -> *).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Proxy context
b m x -> n x
forall x. m x -> n x
c (ServerT api m -> ServerT api n)
-> (SessionTokenAndClaims -> ServerT api m)
-> SessionTokenAndClaims
-> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (AuthSessionIdCookie realm :> api) m
SessionTokenAndClaims -> ServerT api m
d

instance (HasLink api) => HasLink (AuthSessionIdCookie realm :> api) where
  type MkLink (AuthSessionIdCookie realm :> api) a = MkLink api a
  toLink :: forall a.
(Link -> a)
-> Proxy (AuthSessionIdCookie realm :> api)
-> Link
-> MkLink (AuthSessionIdCookie realm :> api) a
toLink Link -> a
toA Proxy (AuthSessionIdCookie realm :> api)
_ = (Link -> a) -> Proxy api -> Link -> MkLink api a
forall a. (Link -> a) -> Proxy api -> Link -> MkLink api a
forall {k} (endpoint :: k) a.
HasLink endpoint =>
(Link -> a) -> Proxy endpoint -> Link -> MkLink endpoint a
toLink Link -> a
toA (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api)

{- |
A form with \"username\" and \"password\"
for a user to authenticate with.

Place in front of a POST endpoint.

@
type AuthenticateAndIssueToken =
    ReqBody '[FormUrlEncoded] BasicAuthReqBody
      :> Post '[JSON] (Headers '[Header "Set-Cookie" Text] Token)
@
-}
data BasicAuthReqBody
  = BasicAuthReqBody
  { BasicAuthReqBody -> Text
barbUsername :: Text
  , BasicAuthReqBody -> Text
barbPassword :: Text
  }
  deriving ((forall x. BasicAuthReqBody -> Rep BasicAuthReqBody x)
-> (forall x. Rep BasicAuthReqBody x -> BasicAuthReqBody)
-> Generic BasicAuthReqBody
forall x. Rep BasicAuthReqBody x -> BasicAuthReqBody
forall x. BasicAuthReqBody -> Rep BasicAuthReqBody x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. BasicAuthReqBody -> Rep BasicAuthReqBody x
from :: forall x. BasicAuthReqBody -> Rep BasicAuthReqBody x
$cto :: forall x. Rep BasicAuthReqBody x -> BasicAuthReqBody
to :: forall x. Rep BasicAuthReqBody x -> BasicAuthReqBody
Generic)

instance FromForm BasicAuthReqBody where
  fromForm :: Form -> Either Text BasicAuthReqBody
  fromForm :: Form -> Either Text BasicAuthReqBody
fromForm Form
f =
    Text -> Text -> BasicAuthReqBody
BasicAuthReqBody
      (Text -> Text -> BasicAuthReqBody)
-> Either Text Text -> Either Text (Text -> BasicAuthReqBody)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Form -> Either Text Text
lookupUnique Text
"username" Form
f
      Either Text (Text -> BasicAuthReqBody)
-> Either Text Text -> Either Text BasicAuthReqBody
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Form -> Either Text Text
lookupUnique Text
"password" Form
f

{- |
Set the \"session-token\"" cookie value given a `Token`.
Also sets the Path attribute to the given Text. \"/\" is a fine default.
-}
setSessionIdCookie ::
  (AddHeader [Optional, Strict] "Set-Cookie" Text orig new) =>
  Token -> Text -> orig -> new
setSessionIdCookie :: forall orig new.
AddHeader '[Optional, Strict] "Set-Cookie" Text orig new =>
Token -> Text -> orig -> new
setSessionIdCookie
  (Token (EncryptedSessionId ByteString
a) Integer
l Text
_)
  Text
pathLink =
    forall (h :: Symbol) v orig new.
AddHeader '[Optional, Strict] h v orig new =>
v -> orig -> new
addHeader @"Set-Cookie"
      ( Text
forall a. IsString a => a
sessionTokenCookieName
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"="
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.E.decodeUtf8 ByteString
a
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";Max-Age="
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> (Integer -> String) -> Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show (Integer -> Text) -> Integer -> Text
forall a b. (a -> b) -> a -> b
$ Integer
l)
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";HttpOnly;Path="
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pathLink
      )

{-# SPECIALIZE INLINE sessionTokenCookieName :: ByteString #-}
{-# SPECIALIZE INLINE sessionTokenCookieName :: Text #-}
sessionTokenCookieName :: (IsString a) => a
sessionTokenCookieName :: forall a. IsString a => a
sessionTokenCookieName = a
"session-token"

requestCookies :: Request -> [(ByteString, ByteString)]
requestCookies :: Request -> [(ByteString, ByteString)]
requestCookies =
  ByteString -> [(ByteString, ByteString)]
splitCookieByteString
    (ByteString -> [(ByteString, ByteString)])
-> (Request -> ByteString) -> Request -> [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
forall a. Monoid a => a
mempty
    (Maybe ByteString -> ByteString)
-> (Request -> Maybe ByteString) -> Request -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> [Header] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Cookie"
    ([Header] -> Maybe ByteString)
-> (Request -> [Header]) -> Request -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [Header]
requestHeaders

splitCookieByteString :: ByteString -> [(ByteString, ByteString)]
splitCookieByteString :: ByteString -> [(ByteString, ByteString)]
splitCookieByteString =
  (ByteString -> (ByteString, ByteString))
-> [ByteString] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map
    ( (ByteString -> ByteString)
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall a b. (a -> b) -> (ByteString, a) -> (ByteString, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString
-> ((Char, ByteString) -> ByteString)
-> Maybe (Char, ByteString)
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
forall a. Monoid a => a
mempty (Char, ByteString) -> ByteString
forall a b. (a, b) -> b
snd (Maybe (Char, ByteString) -> ByteString)
-> (ByteString -> Maybe (Char, ByteString))
-> ByteString
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe (Char, ByteString)
B.Char8.uncons)
        ((ByteString, ByteString) -> (ByteString, ByteString))
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> (ByteString, ByteString)
B.Char8.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=')
        (ByteString -> (ByteString, ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B.Char8.strip
    )
    ([ByteString] -> [(ByteString, ByteString)])
-> (ByteString -> [ByteString])
-> ByteString
-> [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString -> [ByteString]
B.Char8.split Char
';'