2016-03-06 22:23:55 +01:00
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
|
|
{-# LANGUAGE DeriveDataTypeable #-}
|
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
|
|
{-# LANGUAGE PolyKinds #-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
|
|
|
|
module Servant.Server.Experimental.Auth where
|
|
|
|
|
2016-04-09 15:42:57 +02:00
|
|
|
import Control.Monad.Trans (liftIO)
|
2016-03-06 22:23:55 +01:00
|
|
|
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 (HasContextEntry,
|
2017-09-08 18:21:16 +02:00
|
|
|
HasServer (..),
|
|
|
|
getContextEntry)
|
2016-04-09 15:42:57 +02:00
|
|
|
import Servant.Server.Internal.RoutingApplication (addAuthCheck,
|
|
|
|
delayedFailFatal,
|
|
|
|
DelayedIO,
|
|
|
|
withRequest)
|
2017-01-16 10:44:25 +01:00
|
|
|
import Servant.Server.Internal.Handler (Handler, runHandler)
|
2016-03-06 22:23:55 +01:00
|
|
|
|
|
|
|
-- * 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
|
2016-04-07 23:34:23 +02:00
|
|
|
{ unAuthHandler :: r -> Handler usr }
|
2016-03-06 22:23:55 +01:00
|
|
|
deriving (Generic, Typeable)
|
|
|
|
|
|
|
|
-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
2016-04-07 23:34:23 +02:00
|
|
|
mkAuthHandler :: (r -> Handler usr) -> AuthHandler r usr
|
2016-03-06 22:23:55 +01:00
|
|
|
mkAuthHandler = 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
|
|
|
|
|
2017-09-08 18:21:16 +02:00
|
|
|
hoistServer _ pc nt s = hoistServer (Proxy :: Proxy api) pc nt . s
|
|
|
|
|
2016-04-09 15:42:57 +02:00
|
|
|
route Proxy context subserver =
|
|
|
|
route (Proxy :: Proxy api) context (subserver `addAuthCheck` withRequest authCheck)
|
2016-03-06 22:23:55 +01:00
|
|
|
where
|
2016-04-09 15:42:57 +02:00
|
|
|
authHandler :: Request -> Handler (AuthServerData (AuthProtect tag))
|
2016-03-06 22:23:55 +01:00
|
|
|
authHandler = unAuthHandler (getContextEntry context)
|
2016-04-09 15:42:57 +02:00
|
|
|
authCheck :: Request -> DelayedIO (AuthServerData (AuthProtect tag))
|
2017-01-16 10:44:25 +01:00
|
|
|
authCheck = (>>= either delayedFailFatal return) . liftIO . runHandler . authHandler
|