{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

module Servant.Server.Experimental.Auth where

import           Control.Monad.Trans
                 (liftIO)
import           Data.Proxy
                 (Proxy (Proxy))
import           Data.Typeable
                 (Typeable)
import           GHC.Generics
                 (Generic)
import           Network.Wai
                 (Request)

import           Servant
                 ((:>))
import           Servant.API.Experimental.Auth
import           Servant.Server.Internal
                 (DelayedIO, Handler, HasContextEntry, HasServer (..),
                 addAuthCheck, delayedFailFatal, getContextEntry, runHandler,
                 withRequest)

-- * General Auth

-- | Specify the type of data returned after we've authenticated a request.
-- quite often this is some `User` datatype.
--
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
type family AuthServerData a :: *

-- | Handlers for AuthProtected resources
--
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
newtype AuthHandler r usr = AuthHandler
  { forall r usr. AuthHandler r usr -> r -> Handler usr
unAuthHandler :: r -> Handler usr }
  deriving (forall a b. a -> AuthHandler r b -> AuthHandler r a
forall a b. (a -> b) -> AuthHandler r a -> AuthHandler r b
forall r a b. a -> AuthHandler r b -> AuthHandler r a
forall r a b. (a -> b) -> AuthHandler r a -> AuthHandler r b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> AuthHandler r b -> AuthHandler r a
$c<$ :: forall r a b. a -> AuthHandler r b -> AuthHandler r a
fmap :: forall a b. (a -> b) -> AuthHandler r a -> AuthHandler r b
$cfmap :: forall r a b. (a -> b) -> AuthHandler r a -> AuthHandler r b
Functor, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall r usr x. Rep (AuthHandler r usr) x -> AuthHandler r usr
forall r usr x. AuthHandler r usr -> Rep (AuthHandler r usr) x
$cto :: forall r usr x. Rep (AuthHandler r usr) x -> AuthHandler r usr
$cfrom :: forall r usr x. AuthHandler r usr -> Rep (AuthHandler r usr) x
Generic, Typeable)

-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr
mkAuthHandler :: forall r usr. (r -> Handler usr) -> AuthHandler r usr
mkAuthHandler = forall r usr. (r -> Handler usr) -> AuthHandler r usr
AuthHandler

-- | Known orphan instance.
instance ( HasServer api context
         , HasContextEntry context (AuthHandler Request (AuthServerData (AuthProtect tag)))
         )
  => HasServer (AuthProtect tag :> api) context where

  type ServerT (AuthProtect tag :> api) m =
    AuthServerData (AuthProtect tag) -> ServerT api m

  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (AuthProtect tag :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (AuthProtect tag :> api) m
-> ServerT (AuthProtect tag :> api) n
hoistServerWithContext Proxy (AuthProtect tag :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (AuthProtect tag :> api) m
s = 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
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (AuthProtect tag :> api) m
s

  route :: forall env.
Proxy (AuthProtect tag :> api)
-> Context context
-> Delayed env (Server (AuthProtect tag :> api))
-> Router env
route Proxy (AuthProtect tag :> api)
Proxy Context context
context Delayed env (Server (AuthProtect tag :> api))
subserver =
    forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (Delayed env (Server (AuthProtect tag :> api))
subserver forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
`addAuthCheck` forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest Request -> DelayedIO (AuthServerData (AuthProtect tag))
authCheck)
      where
        authHandler :: Request -> Handler (AuthServerData (AuthProtect tag))
        authHandler :: Request -> Handler (AuthServerData (AuthProtect tag))
authHandler = forall r usr. AuthHandler r usr -> r -> Handler usr
unAuthHandler (forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry Context context
context)
        authCheck :: Request -> DelayedIO (AuthServerData (AuthProtect tag))
        authCheck :: Request -> DelayedIO (AuthServerData (AuthProtect tag))
authCheck = (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. ServerError -> DelayedIO a
delayedFailFatal forall (m :: * -> *) a. Monad m => a -> m a
return) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Handler a -> IO (Either ServerError a)
runHandler forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Handler (AuthServerData (AuthProtect tag))
authHandler