{-# options_haddock prune #-}

-- | Combinators for guarding Servant handlers with authentication and authorization
module Polysemy.Account.Api.Server.AuthEndpoint where

import Exon (exon)
import qualified Log
import Servant (ServerError)
import Servant.Auth.Server (AuthResult (Authenticated))

import Polysemy.Account.Api.Effect.Authorize (Authorize, authorize)
import qualified Polysemy.Account.Data.AccountStatus as AccountStatus
import Polysemy.Account.Data.AccountsError (AccountsError (Client, Internal))
import Polysemy.Account.Data.AuthedAccount (AuthedAccount (AuthedAccount))
import qualified Polysemy.Account.Data.Privilege as Privilege
import Polysemy.Account.Data.Privilege (Privilege)
import qualified Polysemy.Account.Effect.Accounts as Accounts
import Polysemy.Account.Effect.Accounts (Accounts)
import Polysemy.Account.Api.Server.Error (unauthorized, internal)

-- | Basic values for describing the requirements of an endpoint for either "any user" or "admin".
class AuthEndpointParam param where
  authEndpointUser :: param
  authEndpointAdmin :: param

instance AuthEndpointParam [Privilege] where
  authEndpointUser :: [Privilege]
authEndpointUser = []
  authEndpointAdmin :: [Privilege]
authEndpointAdmin = [Privilege
Privilege.Admin]

pattern Active :: AuthedAccount i p -> AuthedAccount i p
pattern $mActive :: forall {r} {i} {p}.
AuthedAccount i p -> (AuthedAccount i p -> r) -> ((# #) -> r) -> r
Active acc <- acc@(AuthedAccount _ _ _ AccountStatus.Active _)

insufficient ::
  ∀ i p r a .
  Show (AuthedAccount i p) =>
  Members [Log, Stop ServerError] r =>
  AuthedAccount i p ->
  Text ->
  Sem r a
insufficient :: forall i p (r :: EffectRow) a.
(Show (AuthedAccount i p), Members '[Log, Stop ServerError] r) =>
AuthedAccount i p -> Text -> Sem r a
insufficient AuthedAccount i p
account Text
extra = do
  forall (r :: EffectRow).
(HasCallStack, Member Log r) =>
Text -> Sem r ()
Log.error [exon|auth with insufficient privileges: #{show account}#{extra}|]
  forall e (r :: EffectRow) a. Member (Stop e) r => e -> Sem r a
stop (Text -> ServerError
unauthorized Text
"insufficient privileges")

checkAccount ::
  ∀ i param p r a .
  Show (AuthedAccount i p) =>
  Members [Authorize i param p, Log, Stop ServerError] r =>
  param ->
  (AuthedAccount i p -> Sem r a) ->
  AuthedAccount i p ->
  Sem r a
checkAccount :: forall i param p (r :: EffectRow) a.
(Show (AuthedAccount i p),
 Members '[Authorize i param p, Log, Stop ServerError] r) =>
param
-> (AuthedAccount i p -> Sem r a) -> AuthedAccount i p -> Sem r a
checkAccount param
param AuthedAccount i p -> Sem r a
f (Active AuthedAccount i p
account) =
  forall i param priv (r :: EffectRow).
Member (Authorize i param priv) r =>
param -> AuthedAccount i priv -> Sem r (Maybe Text)
authorize param
param AuthedAccount i p
account forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Text
msg ->
      forall i p (r :: EffectRow) a.
(Show (AuthedAccount i p), Members '[Log, Stop ServerError] r) =>
AuthedAccount i p -> Text -> Sem r a
insufficient AuthedAccount i p
account [exon| (#{msg})|]
    Maybe Text
Nothing ->
      AuthedAccount i p -> Sem r a
f AuthedAccount i p
account
checkAccount param
_ AuthedAccount i p -> Sem r a
_ AuthedAccount i p
account =
  forall i p (r :: EffectRow) a.
(Show (AuthedAccount i p), Members '[Log, Stop ServerError] r) =>
AuthedAccount i p -> Text -> Sem r a
insufficient AuthedAccount i p
account Text
""

type AuthEndpoint i param p r =
  (Members [Authorize i param p, Accounts i p !! AccountsError, Log, Stop ServerError] r, AuthEndpointParam param)

-- | Wrap an authenticated handler function with an authorization check.
--
-- Sends the account information and given endpoint param to the 'Authorize' effect if the authentication material is
-- valid.
authorizeEndpoint ::
  ∀ i param p r a .
  Show (AuthedAccount i p) =>
  AuthEndpoint i param p r =>
  param ->
  (AuthedAccount i p -> Sem r a) ->
  AuthResult (AuthedAccount i p) ->
  Sem r a
authorizeEndpoint :: forall i param p (r :: EffectRow) a.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
param
-> (AuthedAccount i p -> Sem r a)
-> AuthResult (AuthedAccount i p)
-> Sem r a
authorizeEndpoint param
param AuthedAccount i p -> Sem r a
f (Authenticated payload :: AuthedAccount i p
payload@(AuthedAccount i
_ i
authId AccountName
_ AccountStatus
_ p
_)) = do
  AuthedAccount i p
account <- forall i p (r :: EffectRow).
Member (Accounts i p) r =>
i -> Sem r (AuthedAccount i p)
Accounts.authed i
authId forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member (Resumable err eff) r =>
Sem (eff : r) a -> (err -> Sem r a) -> Sem r a
!! \case
    Client AccountsClientError
_ -> forall i p (r :: EffectRow) a.
(Show (AuthedAccount i p), Members '[Log, Stop ServerError] r) =>
AuthedAccount i p -> Text -> Sem r a
insufficient AuthedAccount i p
payload Text
" (token expired)"
    Internal Text
_ -> forall e (r :: EffectRow) a. Member (Stop e) r => e -> Sem r a
stop (Text -> ServerError
internal Text
"Fatal error")
  forall i param p (r :: EffectRow) a.
(Show (AuthedAccount i p),
 Members '[Authorize i param p, Log, Stop ServerError] r) =>
param
-> (AuthedAccount i p -> Sem r a) -> AuthedAccount i p -> Sem r a
checkAccount param
param AuthedAccount i p -> Sem r a
f AuthedAccount i p
account
authorizeEndpoint param
_ AuthedAccount i p -> Sem r a
_ AuthResult (AuthedAccount i p)
_ =
  forall e (r :: EffectRow) a. Member (Stop e) r => e -> Sem r a
stop (Text -> ServerError
unauthorized Text
"no valid auth data")

-- | Require that the authentication material belongs to an active account.
accountOnly ::
  ∀ i param p r a .
  Show (AuthedAccount i p) =>
  AuthEndpoint i param p r =>
  (AuthedAccount i p -> Sem r a) ->
  AuthResult (AuthedAccount i p) ->
  Sem r a
accountOnly :: forall i param p (r :: EffectRow) a.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
(AuthedAccount i p -> Sem r a)
-> AuthResult (AuthedAccount i p) -> Sem r a
accountOnly =
  forall i param p (r :: EffectRow) a.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
param
-> (AuthedAccount i p -> Sem r a)
-> AuthResult (AuthedAccount i p)
-> Sem r a
authorizeEndpoint forall param. AuthEndpointParam param => param
authEndpointUser

-- | Require that the authentication material belongs to an active account.
accountOnly_ ::
  ∀ i param p r a .
  Show (AuthedAccount i p) =>
  AuthEndpoint i param p r =>
  Sem r a ->
  AuthResult (AuthedAccount i p) ->
  Sem r a
accountOnly_ :: forall i param p (r :: EffectRow) a.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
Sem r a -> AuthResult (AuthedAccount i p) -> Sem r a
accountOnly_ Sem r a
f =
  forall i param p (r :: EffectRow) a.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
(AuthedAccount i p -> Sem r a)
-> AuthResult (AuthedAccount i p) -> Sem r a
accountOnly (forall a b. a -> b -> a
const Sem r a
f)

-- | Require that the authentication material belongs to an active account.
accountOnly1 ::
  ∀ i param p r a b .
  Show (AuthedAccount i p) =>
  AuthEndpoint i param p r =>
  (AuthedAccount i p -> a -> Sem r b) ->
  AuthResult (AuthedAccount i p) ->
  a ->
  Sem r b
accountOnly1 :: forall i param p (r :: EffectRow) a b.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
(AuthedAccount i p -> a -> Sem r b)
-> AuthResult (AuthedAccount i p) -> a -> Sem r b
accountOnly1 AuthedAccount i p -> a -> Sem r b
f AuthResult (AuthedAccount i p)
authResult a
a =
  forall i param p (r :: EffectRow) a.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
(AuthedAccount i p -> Sem r a)
-> AuthResult (AuthedAccount i p) -> Sem r a
accountOnly (\ AuthedAccount i p
acc -> AuthedAccount i p -> a -> Sem r b
f AuthedAccount i p
acc a
a) AuthResult (AuthedAccount i p)
authResult

-- | Require that the authentication material belongs to an active account.
accountOnly1_ ::
  ∀ i param p r a b .
  Show (AuthedAccount i p) =>
  AuthEndpoint i param p r =>
  (a -> Sem r b) ->
  AuthResult (AuthedAccount i p) ->
  a ->
  Sem r b
accountOnly1_ :: forall i param p (r :: EffectRow) a b.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
(a -> Sem r b) -> AuthResult (AuthedAccount i p) -> a -> Sem r b
accountOnly1_ a -> Sem r b
f AuthResult (AuthedAccount i p)
authResult a
a =
  forall i param p (r :: EffectRow) a.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
Sem r a -> AuthResult (AuthedAccount i p) -> Sem r a
accountOnly_ (a -> Sem r b
f a
a) AuthResult (AuthedAccount i p)
authResult

-- | Require that the authentication material belongs to an active account.
accountOnly2 ::
  ∀ i param p r a b c .
  Show (AuthedAccount i p) =>
  AuthEndpoint i param p r =>
  (AuthedAccount i p -> a -> b -> Sem r c) ->
  AuthResult (AuthedAccount i p) ->
  a ->
  b ->
  Sem r c
accountOnly2 :: forall i param p (r :: EffectRow) a b c.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
(AuthedAccount i p -> a -> b -> Sem r c)
-> AuthResult (AuthedAccount i p) -> a -> b -> Sem r c
accountOnly2 AuthedAccount i p -> a -> b -> Sem r c
f AuthResult (AuthedAccount i p)
authResult a
a b
b =
  forall i param p (r :: EffectRow) a.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
(AuthedAccount i p -> Sem r a)
-> AuthResult (AuthedAccount i p) -> Sem r a
accountOnly (\ AuthedAccount i p
acc -> AuthedAccount i p -> a -> b -> Sem r c
f AuthedAccount i p
acc a
a b
b) AuthResult (AuthedAccount i p)
authResult

-- | Require that the authentication material belongs to an active account.
accountOnly2_ ::
  ∀ i param p r a b c .
  Show (AuthedAccount i p) =>
  AuthEndpoint i param p r =>
  (a -> b -> Sem r c) ->
  AuthResult (AuthedAccount i p) ->
  a ->
  b ->
  Sem r c
accountOnly2_ :: forall i param p (r :: EffectRow) a b c.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
(a -> b -> Sem r c)
-> AuthResult (AuthedAccount i p) -> a -> b -> Sem r c
accountOnly2_ a -> b -> Sem r c
f AuthResult (AuthedAccount i p)
authResult a
a b
b =
  forall i param p (r :: EffectRow) a.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
Sem r a -> AuthResult (AuthedAccount i p) -> Sem r a
accountOnly_ (a -> b -> Sem r c
f a
a b
b) AuthResult (AuthedAccount i p)
authResult

-- | Require that the authentication material belongs to an active admin account.
adminOnly ::
  ∀ i param p r a .
  Show (AuthedAccount i p) =>
  AuthEndpoint i param p r =>
  (AuthedAccount i p -> Sem r a) ->
  AuthResult (AuthedAccount i p) ->
  Sem r a
adminOnly :: forall i param p (r :: EffectRow) a.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
(AuthedAccount i p -> Sem r a)
-> AuthResult (AuthedAccount i p) -> Sem r a
adminOnly =
  forall i param p (r :: EffectRow) a.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
param
-> (AuthedAccount i p -> Sem r a)
-> AuthResult (AuthedAccount i p)
-> Sem r a
authorizeEndpoint forall param. AuthEndpointParam param => param
authEndpointAdmin

-- | Require that the authentication material belongs to an active admin account.
adminOnly_ ::
  ∀ i param p r a .
  Show (AuthedAccount i p) =>
  AuthEndpoint i param p r =>
  Sem r a ->
  AuthResult (AuthedAccount i p) ->
  Sem r a
adminOnly_ :: forall i param p (r :: EffectRow) a.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
Sem r a -> AuthResult (AuthedAccount i p) -> Sem r a
adminOnly_ Sem r a
f =
  forall i param p (r :: EffectRow) a.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
(AuthedAccount i p -> Sem r a)
-> AuthResult (AuthedAccount i p) -> Sem r a
adminOnly (forall a b. a -> b -> a
const Sem r a
f)

-- | Require that the authentication material belongs to an active admin account.
adminOnly1 ::
  ∀ i param p r a b .
  Show (AuthedAccount i p) =>
  AuthEndpoint i param p r =>
  (AuthedAccount i p -> a -> Sem r b) ->
  AuthResult (AuthedAccount i p) ->
  a ->
  Sem r b
adminOnly1 :: forall i param p (r :: EffectRow) a b.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
(AuthedAccount i p -> a -> Sem r b)
-> AuthResult (AuthedAccount i p) -> a -> Sem r b
adminOnly1 AuthedAccount i p -> a -> Sem r b
f AuthResult (AuthedAccount i p)
authResult a
a =
  forall i param p (r :: EffectRow) a.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
(AuthedAccount i p -> Sem r a)
-> AuthResult (AuthedAccount i p) -> Sem r a
adminOnly (\ AuthedAccount i p
acc -> AuthedAccount i p -> a -> Sem r b
f AuthedAccount i p
acc a
a) AuthResult (AuthedAccount i p)
authResult

-- | Require that the authentication material belongs to an active admin account.
adminOnly1_ ::
  ∀ i param p r a b .
  Show (AuthedAccount i p) =>
  AuthEndpoint i param p r =>
  (a -> Sem r b) ->
  AuthResult (AuthedAccount i p) ->
  a ->
  Sem r b
adminOnly1_ :: forall i param p (r :: EffectRow) a b.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
(a -> Sem r b) -> AuthResult (AuthedAccount i p) -> a -> Sem r b
adminOnly1_ a -> Sem r b
f AuthResult (AuthedAccount i p)
authResult a
a =
  forall i param p (r :: EffectRow) a.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
Sem r a -> AuthResult (AuthedAccount i p) -> Sem r a
adminOnly_ (a -> Sem r b
f a
a) AuthResult (AuthedAccount i p)
authResult

-- | Require that the authentication material belongs to an active admin account.
adminOnly2 ::
  ∀ i param p r a b c .
  Show (AuthedAccount i p) =>
  AuthEndpoint i param p r =>
  (AuthedAccount i p -> a -> b -> Sem r c) ->
  AuthResult (AuthedAccount i p) ->
  a ->
  b ->
  Sem r c
adminOnly2 :: forall i param p (r :: EffectRow) a b c.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
(AuthedAccount i p -> a -> b -> Sem r c)
-> AuthResult (AuthedAccount i p) -> a -> b -> Sem r c
adminOnly2 AuthedAccount i p -> a -> b -> Sem r c
f AuthResult (AuthedAccount i p)
authResult a
a b
b =
  forall i param p (r :: EffectRow) a.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
(AuthedAccount i p -> Sem r a)
-> AuthResult (AuthedAccount i p) -> Sem r a
adminOnly (\ AuthedAccount i p
acc -> AuthedAccount i p -> a -> b -> Sem r c
f AuthedAccount i p
acc a
a b
b) AuthResult (AuthedAccount i p)
authResult

-- | Require that the authentication material belongs to an active admin account.
adminOnly2_ ::
  ∀ i param p r a b c .
  Show (AuthedAccount i p) =>
  AuthEndpoint i param p r =>
  (a -> b -> Sem r c) ->
  AuthResult (AuthedAccount i p) ->
  a ->
  b ->
  Sem r c
adminOnly2_ :: forall i param p (r :: EffectRow) a b c.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
(a -> b -> Sem r c)
-> AuthResult (AuthedAccount i p) -> a -> b -> Sem r c
adminOnly2_ a -> b -> Sem r c
f AuthResult (AuthedAccount i p)
authResult a
a b
b =
  forall i param p (r :: EffectRow) a.
(Show (AuthedAccount i p), AuthEndpoint i param p r) =>
Sem r a -> AuthResult (AuthedAccount i p) -> Sem r a
adminOnly_ (a -> b -> Sem r c
f a
a b
b) AuthResult (AuthedAccount i p)
authResult