{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# 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
-}
module Monax.Auth.Servant (
  KnownSessionRequired (..),
  fromSessionRequirement,
  SessionRequired (..),
  SessionCookie (),
  SessionID (..),
  newSessionID,
  AuthenticationRedirectURL (..),
  BasicAuthReqBody (..),
  makeSetSessionCookie,
) where

import Control.Monad.IO.Class (liftIO)
import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as B.Char8
import Data.ByteString.Lazy qualified as B.L
import Data.Char (toLower)
import Data.Coerce (coerce)
import Data.Hashable (Hashable)
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 Data.UUID (UUID, fromByteString, toByteString)
import Data.UUID.V4 (nextRandom)
import GHC.Generics (Generic)
import Monax.Auth.Cipher (Cipher, decrypt, encrypt)
import Monax.Auth.Session (Sessions, lookupSession)
import Network.Wai (Request (requestHeaders))
import Servant.API (
  AddHeader,
  HasLink (..),
  IsElem,
  IsElem',
  Link,
  Optional,
  Strict,
  addHeader,
  type (:>),
 )
import Servant.Server (
  HasContextEntry (..),
  HasServer (..),
  ServerError (errHeaders),
  Tagged (..),
  err303,
 )
import Servant.Server.Internal.Delayed (addAuthCheck)
import Servant.Server.Internal.DelayedIO (
  delayedFailFatal,
  withRequest,
 )
import Web.FormUrlEncoded (Form, FromForm (..), lookupUnique)

{- |
Marks an endpoint as requiring a valid session to proceed.
-}
data SessionRequired = NotRequired | Required
  deriving (Int -> SessionRequired -> ShowS
[SessionRequired] -> ShowS
SessionRequired -> String
(Int -> SessionRequired -> ShowS)
-> (SessionRequired -> String)
-> ([SessionRequired] -> ShowS)
-> Show SessionRequired
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SessionRequired -> ShowS
showsPrec :: Int -> SessionRequired -> ShowS
$cshow :: SessionRequired -> String
show :: SessionRequired -> String
$cshowList :: [SessionRequired] -> ShowS
showList :: [SessionRequired] -> ShowS
Show, SessionRequired -> SessionRequired -> Bool
(SessionRequired -> SessionRequired -> Bool)
-> (SessionRequired -> SessionRequired -> Bool)
-> Eq SessionRequired
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SessionRequired -> SessionRequired -> Bool
== :: SessionRequired -> SessionRequired -> Bool
$c/= :: SessionRequired -> SessionRequired -> Bool
/= :: SessionRequired -> SessionRequired -> Bool
Eq, Eq SessionRequired
Eq SessionRequired =>
(SessionRequired -> SessionRequired -> Ordering)
-> (SessionRequired -> SessionRequired -> Bool)
-> (SessionRequired -> SessionRequired -> Bool)
-> (SessionRequired -> SessionRequired -> Bool)
-> (SessionRequired -> SessionRequired -> Bool)
-> (SessionRequired -> SessionRequired -> SessionRequired)
-> (SessionRequired -> SessionRequired -> SessionRequired)
-> Ord SessionRequired
SessionRequired -> SessionRequired -> Bool
SessionRequired -> SessionRequired -> Ordering
SessionRequired -> SessionRequired -> SessionRequired
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SessionRequired -> SessionRequired -> Ordering
compare :: SessionRequired -> SessionRequired -> Ordering
$c< :: SessionRequired -> SessionRequired -> Bool
< :: SessionRequired -> SessionRequired -> Bool
$c<= :: SessionRequired -> SessionRequired -> Bool
<= :: SessionRequired -> SessionRequired -> Bool
$c> :: SessionRequired -> SessionRequired -> Bool
> :: SessionRequired -> SessionRequired -> Bool
$c>= :: SessionRequired -> SessionRequired -> Bool
>= :: SessionRequired -> SessionRequired -> Bool
$cmax :: SessionRequired -> SessionRequired -> SessionRequired
max :: SessionRequired -> SessionRequired -> SessionRequired
$cmin :: SessionRequired -> SessionRequired -> SessionRequired
min :: SessionRequired -> SessionRequired -> SessionRequired
Ord, Int -> SessionRequired
SessionRequired -> Int
SessionRequired -> [SessionRequired]
SessionRequired -> SessionRequired
SessionRequired -> SessionRequired -> [SessionRequired]
SessionRequired
-> SessionRequired -> SessionRequired -> [SessionRequired]
(SessionRequired -> SessionRequired)
-> (SessionRequired -> SessionRequired)
-> (Int -> SessionRequired)
-> (SessionRequired -> Int)
-> (SessionRequired -> [SessionRequired])
-> (SessionRequired -> SessionRequired -> [SessionRequired])
-> (SessionRequired -> SessionRequired -> [SessionRequired])
-> (SessionRequired
    -> SessionRequired -> SessionRequired -> [SessionRequired])
-> Enum SessionRequired
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: SessionRequired -> SessionRequired
succ :: SessionRequired -> SessionRequired
$cpred :: SessionRequired -> SessionRequired
pred :: SessionRequired -> SessionRequired
$ctoEnum :: Int -> SessionRequired
toEnum :: Int -> SessionRequired
$cfromEnum :: SessionRequired -> Int
fromEnum :: SessionRequired -> Int
$cenumFrom :: SessionRequired -> [SessionRequired]
enumFrom :: SessionRequired -> [SessionRequired]
$cenumFromThen :: SessionRequired -> SessionRequired -> [SessionRequired]
enumFromThen :: SessionRequired -> SessionRequired -> [SessionRequired]
$cenumFromTo :: SessionRequired -> SessionRequired -> [SessionRequired]
enumFromTo :: SessionRequired -> SessionRequired -> [SessionRequired]
$cenumFromThenTo :: SessionRequired
-> SessionRequired -> SessionRequired -> [SessionRequired]
enumFromThenTo :: SessionRequired
-> SessionRequired -> SessionRequired -> [SessionRequired]
Enum, SessionRequired
SessionRequired -> SessionRequired -> Bounded SessionRequired
forall a. a -> a -> Bounded a
$cminBound :: SessionRequired
minBound :: SessionRequired
$cmaxBound :: SessionRequired
maxBound :: SessionRequired
Bounded, (forall x. SessionRequired -> Rep SessionRequired x)
-> (forall x. Rep SessionRequired x -> SessionRequired)
-> Generic SessionRequired
forall x. Rep SessionRequired x -> SessionRequired
forall x. SessionRequired -> Rep SessionRequired x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SessionRequired -> Rep SessionRequired x
from :: forall x. SessionRequired -> Rep SessionRequired x
$cto :: forall x. Rep SessionRequired x -> SessionRequired
to :: forall x. Rep SessionRequired x -> SessionRequired
Generic)

{- |
Singleton class for `SessionRequired` for static dispatch of
types like `ServerT (SessionRequired i r a :> api) m`
-}
class KnownSessionRequired (r :: SessionRequired) where
  type FromSessionRequirement r a
  -- | Branch on a known value.
  decideRequirement :: ((r ~ NotRequired) => a) -> ((r ~ Required) => a) -> a

instance KnownSessionRequired NotRequired where
  type FromSessionRequirement NotRequired a = Maybe a
  decideRequirement ::
    ((NotRequired ~ NotRequired) => a) ->
    ((NotRequired ~ Required) => a) ->
    a
  decideRequirement :: forall a.
(('NotRequired ~ 'NotRequired) => a)
-> (('NotRequired ~ 'Required) => a) -> a
decideRequirement ('NotRequired ~ 'NotRequired) => a
a ('NotRequired ~ 'Required) => a
_ = a
('NotRequired ~ 'NotRequired) => a
a

instance KnownSessionRequired Required where
  type FromSessionRequirement Required a = a
  decideRequirement ::
    ((Required ~ NotRequired) => a) ->
    ((Required ~ Required) => a) ->
    a
  decideRequirement :: forall a.
(('Required ~ 'NotRequired) => a)
-> (('Required ~ 'Required) => a) -> a
decideRequirement ('Required ~ 'NotRequired) => a
_ ('Required ~ 'Required) => a
a = a
('Required ~ 'Required) => a
a

{- |
Case analysis using a static type of kind `SessionRequired`.
-}
fromSessionRequirement ::
  forall r a b.
  (KnownSessionRequired r) =>
  Proxy a ->
  ((r ~ NotRequired) => FromSessionRequirement r a -> b) ->
  ((r ~ Required) => FromSessionRequirement r a -> b) ->
  FromSessionRequirement r a ->
  b
fromSessionRequirement :: forall (r :: SessionRequired) a b.
KnownSessionRequired r =>
Proxy a
-> ((r ~ 'NotRequired) => FromSessionRequirement r a -> b)
-> ((r ~ 'Required) => FromSessionRequirement r a -> b)
-> FromSessionRequirement r a
-> b
fromSessionRequirement Proxy a
_ (r ~ 'NotRequired) => FromSessionRequirement r a -> b
f (r ~ 'Required) => FromSessionRequirement r a -> b
g FromSessionRequirement r a
x = forall (r :: SessionRequired) a.
KnownSessionRequired r =>
((r ~ 'NotRequired) => a) -> ((r ~ 'Required) => a) -> a
decideRequirement @r ((r ~ 'NotRequired) => FromSessionRequirement r a -> b
FromSessionRequirement r a -> b
f FromSessionRequirement r a
x) ((r ~ 'Required) => FromSessionRequirement r a -> b
FromSessionRequirement r a -> b
g FromSessionRequirement r a
x)

{- |
Reads a session token from the request cookies, and depending on
the `SessionRequired` value, will proceed with an optional or required
value for the user's session state.
-}
data family SessionCookie :: k -> SessionRequired -> Type -> Type

{- |
Unique identifier suitable for sessions.
-}
newtype SessionID = SessionID UUID
  deriving (Int -> SessionID -> ShowS
[SessionID] -> ShowS
SessionID -> String
(Int -> SessionID -> ShowS)
-> (SessionID -> String)
-> ([SessionID] -> ShowS)
-> Show SessionID
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SessionID -> ShowS
showsPrec :: Int -> SessionID -> ShowS
$cshow :: SessionID -> String
show :: SessionID -> String
$cshowList :: [SessionID] -> ShowS
showList :: [SessionID] -> ShowS
Show, SessionID -> SessionID -> Bool
(SessionID -> SessionID -> Bool)
-> (SessionID -> SessionID -> Bool) -> Eq SessionID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SessionID -> SessionID -> Bool
== :: SessionID -> SessionID -> Bool
$c/= :: SessionID -> SessionID -> Bool
/= :: SessionID -> SessionID -> Bool
Eq, (forall x. SessionID -> Rep SessionID x)
-> (forall x. Rep SessionID x -> SessionID) -> Generic SessionID
forall x. Rep SessionID x -> SessionID
forall x. SessionID -> Rep SessionID x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SessionID -> Rep SessionID x
from :: forall x. SessionID -> Rep SessionID x
$cto :: forall x. Rep SessionID x -> SessionID
to :: forall x. Rep SessionID x -> SessionID
Generic, Eq SessionID
Eq SessionID =>
(Int -> SessionID -> Int)
-> (SessionID -> Int) -> Hashable SessionID
Int -> SessionID -> Int
SessionID -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> SessionID -> Int
hashWithSalt :: Int -> SessionID -> Int
$chash :: SessionID -> Int
hash :: SessionID -> Int
Hashable)

{- |
Create a new unique `SessionID`
-}
newSessionID :: IO SessionID
newSessionID :: IO SessionID
newSessionID = UUID -> SessionID
SessionID (UUID -> SessionID) -> IO UUID -> IO SessionID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UUID
nextRandom

instance
  ( KnownSessionRequired r
  , HasContextEntry context (Tagged i (Sessions SessionID a))
  , HasContextEntry context (Tagged i Cipher)
  , HasContextEntry context (Tagged i AuthenticationRedirectURL)
  , HasServer api context
  ) =>
  HasServer (SessionCookie i r a :> api) context
  where
  type
    ServerT (SessionCookie i r a :> api) m =
      FromSessionRequirement r (SessionID, a) -> ServerT api m

  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (SessionCookie i r a :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (SessionCookie i r a :> api) m
-> ServerT (SessionCookie i r a :> api) n
hoistServerWithContext Proxy (SessionCookie i r a :> api)
_ Proxy context
a forall x. m x -> n x
b ServerT (SessionCookie i r a :> api) m
c =
    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
a m x -> n x
forall x. m x -> n x
b (ServerT api m -> ServerT api n)
-> (FromSessionRequirement r (SessionID, a) -> ServerT api m)
-> FromSessionRequirement r (SessionID, a)
-> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (SessionCookie i r a :> api) m
FromSessionRequirement r (SessionID, a) -> ServerT api m
c

  route :: forall env.
Proxy (SessionCookie i r a :> api)
-> Context context
-> Delayed env (Server (SessionCookie i r a :> api))
-> Router env
route Proxy (SessionCookie i r a :> api)
_ Context context
context Delayed env (Server (SessionCookie i r a :> 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 (SessionCookie i r a :> api))
Delayed env (FromSessionRequirement r (SessionID, a) -> Server api)
subserver
          Delayed env (FromSessionRequirement r (SessionID, a) -> Server api)
-> DelayedIO (FromSessionRequirement r (SessionID, a))
-> Delayed env (Server api)
forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
`addAuthCheck` (Request -> DelayedIO (FromSessionRequirement r (SessionID, a)))
-> DelayedIO (FromSessionRequirement r (SessionID, a))
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest
            ( \Request
r ->
                let ss :: Sessions SessionID a
ss = forall (s :: k) b. Tagged s b -> b
forall {k} (s :: k) b. Tagged s b -> b
unTagged @i (Tagged i (Sessions SessionID a) -> Sessions SessionID a)
-> (Context context -> Tagged i (Sessions SessionID a))
-> Context context
-> Sessions SessionID a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context context -> Tagged i (Sessions SessionID a)
forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (Context context -> Sessions SessionID a)
-> Context context -> Sessions SessionID a
forall a b. (a -> b) -> a -> b
$ Context context
context
                    c :: Cipher
c = forall (s :: k) b. Tagged s b -> b
forall {k} (s :: k) b. Tagged s b -> b
unTagged @i (Tagged i Cipher -> Cipher)
-> (Context context -> Tagged i Cipher)
-> Context context
-> Cipher
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context context -> Tagged i Cipher
forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (Context context -> Cipher) -> Context context -> Cipher
forall a b. (a -> b) -> a -> b
$ Context context
context
                 in do
                      x <- IO (GetSessionBranch a) -> DelayedIO (GetSessionBranch a)
forall a. IO a -> DelayedIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a.
Sessions SessionID a
-> Cipher -> Request -> IO (GetSessionBranch a)
tryGetSession @a Sessions SessionID a
ss Cipher
c Request
r)
                      decideRequirement @r
                        ( case x of
                            BranchGotSession (SessionID, a)
x' -> FromSessionRequirement r (SessionID, a)
-> DelayedIO (FromSessionRequirement r (SessionID, a))
forall a. a -> DelayedIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FromSessionRequirement r (SessionID, a)
 -> DelayedIO (FromSessionRequirement r (SessionID, a)))
-> ((SessionID, a) -> FromSessionRequirement r (SessionID, a))
-> (SessionID, a)
-> DelayedIO (FromSessionRequirement r (SessionID, a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SessionID, a) -> Maybe (SessionID, a)
(SessionID, a) -> FromSessionRequirement r (SessionID, a)
forall a. a -> Maybe a
Just ((SessionID, a)
 -> DelayedIO (FromSessionRequirement r (SessionID, a)))
-> (SessionID, a)
-> DelayedIO (FromSessionRequirement r (SessionID, a))
forall a b. (a -> b) -> a -> b
$ (SessionID, a)
x'
                            GetSessionBranch a
_ -> FromSessionRequirement r (SessionID, a)
-> DelayedIO (FromSessionRequirement r (SessionID, a))
forall a. a -> DelayedIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (SessionID, a)
FromSessionRequirement r (SessionID, a)
forall a. Maybe a
Nothing
                        )
                        ( case x of
                            BranchGotSession (SessionID, a)
x' -> FromSessionRequirement r (SessionID, a)
-> DelayedIO (FromSessionRequirement r (SessionID, a))
forall a. a -> DelayedIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SessionID, a)
FromSessionRequirement r (SessionID, a)
x'
                            GetSessionBranch a
_ ->
                              ServerError -> DelayedIO (FromSessionRequirement r (SessionID, a))
forall a. ServerError -> DelayedIO a
delayedFailFatal
                                ServerError
err303
                                  { errHeaders =
                                      [
                                        ( "Location"
                                        , T.E.encodeUtf8
                                            . coerce
                                            . unTagged
                                            . getContextEntry
                                              @_
                                              @(Tagged i AuthenticationRedirectURL)
                                            $ context
                                        )
                                      ]
                                  }
                        )
            )
      )

data GetSessionBranch a
  = BranchNoCookie
  | BranchCouldNotDecrypt ByteString
  | BranchNoSuchSession SessionID
  | BranchGotSession (SessionID, a)

tryGetSession ::
  Sessions SessionID a ->
  Cipher ->
  Request ->
  IO (GetSessionBranch a)
tryGetSession :: forall a.
Sessions SessionID a
-> Cipher -> Request -> IO (GetSessionBranch a)
tryGetSession Sessions SessionID a
ss Cipher
c 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 -> ByteString)
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Char -> Char) -> ByteString -> ByteString
B.Char8.map Char -> Char
toLower))
    ([(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 -> GetSessionBranch a -> IO (GetSessionBranch a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GetSessionBranch a
forall a. GetSessionBranch a
BranchNoCookie
    Just ByteString
encMsg -> do
      mDecMsg <- (ByteString -> Maybe UUID
fromByteString (ByteString -> Maybe UUID)
-> (ByteString -> ByteString) -> ByteString -> Maybe UUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B.L.fromStrict) (ByteString -> Maybe UUID) -> IO ByteString -> IO (Maybe UUID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cipher -> ByteString -> IO ByteString
decrypt Cipher
c ByteString
encMsg
      case mDecMsg of
        Maybe UUID
Nothing -> GetSessionBranch a -> IO (GetSessionBranch a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GetSessionBranch a -> IO (GetSessionBranch a))
-> (ByteString -> GetSessionBranch a)
-> ByteString
-> IO (GetSessionBranch a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> GetSessionBranch a
forall a. ByteString -> GetSessionBranch a
BranchCouldNotDecrypt (ByteString -> IO (GetSessionBranch a))
-> ByteString -> IO (GetSessionBranch a)
forall a b. (a -> b) -> a -> b
$ ByteString
encMsg
        Just UUID
decUUID -> do
          let seshID :: SessionID
seshID = UUID -> SessionID
SessionID UUID
decUUID
          mSesh <- Sessions SessionID a -> SessionID -> IO (Maybe a)
forall k b. Hashable k => Sessions k b -> k -> IO (Maybe b)
lookupSession Sessions SessionID a
ss SessionID
seshID
          case mSesh of
            Maybe a
Nothing -> GetSessionBranch a -> IO (GetSessionBranch a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GetSessionBranch a -> IO (GetSessionBranch a))
-> (SessionID -> GetSessionBranch a)
-> SessionID
-> IO (GetSessionBranch a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionID -> GetSessionBranch a
forall a. SessionID -> GetSessionBranch a
BranchNoSuchSession (SessionID -> IO (GetSessionBranch a))
-> SessionID -> IO (GetSessionBranch a)
forall a b. (a -> b) -> a -> b
$ SessionID
seshID
            Just a
sesh -> GetSessionBranch a -> IO (GetSessionBranch a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GetSessionBranch a -> IO (GetSessionBranch a))
-> ((SessionID, a) -> GetSessionBranch a)
-> (SessionID, a)
-> IO (GetSessionBranch a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SessionID, a) -> GetSessionBranch a
forall a. (SessionID, a) -> GetSessionBranch a
BranchGotSession ((SessionID, a) -> IO (GetSessionBranch a))
-> (SessionID, a) -> IO (GetSessionBranch a)
forall a b. (a -> b) -> a -> b
$ (SessionID
seshID, a
sesh)

type instance IsElem' e (SessionCookie i r b :> api) = IsElem e api

instance (HasLink api) => HasLink (SessionCookie i r b :> api) where
  type MkLink (SessionCookie i r b :> api) a = MkLink api a
  toLink ::
    (HasLink api) =>
    (Link -> a) ->
    Proxy (SessionCookie i r b :> api) ->
    Link ->
    MkLink (SessionCookie i r b :> api) a
  toLink :: forall a.
HasLink api =>
(Link -> a)
-> Proxy (SessionCookie i r b :> api)
-> Link
-> MkLink (SessionCookie i r b :> api) a
toLink Link -> a
toA Proxy (SessionCookie i r b :> 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 link to somewhere a user can authenticate and be issued a session token.
-}
newtype AuthenticationRedirectURL = AuthenticationRedirectURL Text
  deriving (Int -> AuthenticationRedirectURL -> ShowS
[AuthenticationRedirectURL] -> ShowS
AuthenticationRedirectURL -> String
(Int -> AuthenticationRedirectURL -> ShowS)
-> (AuthenticationRedirectURL -> String)
-> ([AuthenticationRedirectURL] -> ShowS)
-> Show AuthenticationRedirectURL
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AuthenticationRedirectURL -> ShowS
showsPrec :: Int -> AuthenticationRedirectURL -> ShowS
$cshow :: AuthenticationRedirectURL -> String
show :: AuthenticationRedirectURL -> String
$cshowList :: [AuthenticationRedirectURL] -> ShowS
showList :: [AuthenticationRedirectURL] -> ShowS
Show, AuthenticationRedirectURL -> AuthenticationRedirectURL -> Bool
(AuthenticationRedirectURL -> AuthenticationRedirectURL -> Bool)
-> (AuthenticationRedirectURL -> AuthenticationRedirectURL -> Bool)
-> Eq AuthenticationRedirectURL
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AuthenticationRedirectURL -> AuthenticationRedirectURL -> Bool
== :: AuthenticationRedirectURL -> AuthenticationRedirectURL -> Bool
$c/= :: AuthenticationRedirectURL -> AuthenticationRedirectURL -> Bool
/= :: AuthenticationRedirectURL -> AuthenticationRedirectURL -> Bool
Eq, (forall x.
 AuthenticationRedirectURL -> Rep AuthenticationRedirectURL x)
-> (forall x.
    Rep AuthenticationRedirectURL x -> AuthenticationRedirectURL)
-> Generic AuthenticationRedirectURL
forall x.
Rep AuthenticationRedirectURL x -> AuthenticationRedirectURL
forall x.
AuthenticationRedirectURL -> Rep AuthenticationRedirectURL x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
AuthenticationRedirectURL -> Rep AuthenticationRedirectURL x
from :: forall x.
AuthenticationRedirectURL -> Rep AuthenticationRedirectURL x
$cto :: forall x.
Rep AuthenticationRedirectURL x -> AuthenticationRedirectURL
to :: forall x.
Rep AuthenticationRedirectURL x -> AuthenticationRedirectURL
Generic, NonEmpty AuthenticationRedirectURL -> AuthenticationRedirectURL
AuthenticationRedirectURL
-> AuthenticationRedirectURL -> AuthenticationRedirectURL
(AuthenticationRedirectURL
 -> AuthenticationRedirectURL -> AuthenticationRedirectURL)
-> (NonEmpty AuthenticationRedirectURL
    -> AuthenticationRedirectURL)
-> (forall b.
    Integral b =>
    b -> AuthenticationRedirectURL -> AuthenticationRedirectURL)
-> Semigroup AuthenticationRedirectURL
forall b.
Integral b =>
b -> AuthenticationRedirectURL -> AuthenticationRedirectURL
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: AuthenticationRedirectURL
-> AuthenticationRedirectURL -> AuthenticationRedirectURL
<> :: AuthenticationRedirectURL
-> AuthenticationRedirectURL -> AuthenticationRedirectURL
$csconcat :: NonEmpty AuthenticationRedirectURL -> AuthenticationRedirectURL
sconcat :: NonEmpty AuthenticationRedirectURL -> AuthenticationRedirectURL
$cstimes :: forall b.
Integral b =>
b -> AuthenticationRedirectURL -> AuthenticationRedirectURL
stimes :: forall b.
Integral b =>
b -> AuthenticationRedirectURL -> AuthenticationRedirectURL
Semigroup, Semigroup AuthenticationRedirectURL
AuthenticationRedirectURL
Semigroup AuthenticationRedirectURL =>
AuthenticationRedirectURL
-> (AuthenticationRedirectURL
    -> AuthenticationRedirectURL -> AuthenticationRedirectURL)
-> ([AuthenticationRedirectURL] -> AuthenticationRedirectURL)
-> Monoid AuthenticationRedirectURL
[AuthenticationRedirectURL] -> AuthenticationRedirectURL
AuthenticationRedirectURL
-> AuthenticationRedirectURL -> AuthenticationRedirectURL
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: AuthenticationRedirectURL
mempty :: AuthenticationRedirectURL
$cmappend :: AuthenticationRedirectURL
-> AuthenticationRedirectURL -> AuthenticationRedirectURL
mappend :: AuthenticationRedirectURL
-> AuthenticationRedirectURL -> AuthenticationRedirectURL
$cmconcat :: [AuthenticationRedirectURL] -> AuthenticationRedirectURL
mconcat :: [AuthenticationRedirectURL] -> AuthenticationRedirectURL
Monoid, String -> AuthenticationRedirectURL
(String -> AuthenticationRedirectURL)
-> IsString AuthenticationRedirectURL
forall a. (String -> a) -> IsString a
$cfromString :: String -> AuthenticationRedirectURL
fromString :: String -> AuthenticationRedirectURL
IsString)

{- |
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] Text)
@
-}
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

{- |
Encrypt a session id and return a function that sets that session id as a cookie
in a response.
-}
makeSetSessionCookie ::
  (AddHeader [Optional, Strict] "Set-Cookie" Text orig new) =>
  Cipher -> SessionID -> Integer -> Text -> IO (orig -> new)
makeSetSessionCookie :: forall orig new.
AddHeader '[Optional, Strict] "Set-Cookie" Text orig new =>
Cipher -> SessionID -> Integer -> Text -> IO (orig -> new)
makeSetSessionCookie
  Cipher
cipher
  (SessionID UUID
seshID)
  (Integer
maxAgeSeconds :: Integer)
  Text
pathLink = do
    encSeshID <- Cipher -> ByteString -> IO ByteString
encrypt Cipher
cipher (ByteString -> IO ByteString)
-> (UUID -> ByteString) -> UUID -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B.L.toStrict (ByteString -> ByteString)
-> (UUID -> ByteString) -> UUID -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> ByteString
toByteString (UUID -> IO ByteString) -> UUID -> IO ByteString
forall a b. (a -> b) -> a -> b
$ UUID
seshID
    pure $
      addHeader @"Set-Cookie"
        ( sessionTokenCookieName
            <> "="
            <> T.E.decodeUtf8 encSeshID
            <> ";Max-Age="
            <> (fromString . show $ maxAgeSeconds)
            <> ";HttpOnly;Path="
            <> 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
';'