{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}

-- | This is a sample application composed of the end-points in "SAML.WebSSO.API" plus a minimum of
-- functionality to make a running web application.  Some parts of this module could be handy to
-- build other apps, but it is more likely to serve as a tutorial.
module SAML2.WebSSO.API.Example where

import Control.Arrow ((&&&))
import Control.Concurrent.MVar
import Control.Lens
import Control.Monad.Except
import Control.Monad.Reader
import Data.EitherR (fmapL)
import Data.Kind (Type)
import Data.Map as Map
import Data.Proxy
import Data.String.Conversions
import Data.UUID as UUID
import Data.Void (Void)
import GHC.Stack
import Network.Wai hiding (Response)
import SAML2.Util
import SAML2.WebSSO
import Servant.API hiding (URI (..))
import Servant.Server
import Text.Hamlet.XML
import Text.XML
import URI.ByteString

----------------------------------------------------------------------
-- a simple concrete monad

newtype SimpleSP a = SimpleSP (ReaderT SimpleSPCtx (ExceptT SimpleError IO) a)
  deriving ((forall a b. (a -> b) -> SimpleSP a -> SimpleSP b)
-> (forall a b. a -> SimpleSP b -> SimpleSP a) -> Functor SimpleSP
forall a b. a -> SimpleSP b -> SimpleSP a
forall a b. (a -> b) -> SimpleSP a -> SimpleSP b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> SimpleSP a -> SimpleSP b
fmap :: forall a b. (a -> b) -> SimpleSP a -> SimpleSP b
$c<$ :: forall a b. a -> SimpleSP b -> SimpleSP a
<$ :: forall a b. a -> SimpleSP b -> SimpleSP a
Functor, Functor SimpleSP
Functor SimpleSP =>
(forall a. a -> SimpleSP a)
-> (forall a b. SimpleSP (a -> b) -> SimpleSP a -> SimpleSP b)
-> (forall a b c.
    (a -> b -> c) -> SimpleSP a -> SimpleSP b -> SimpleSP c)
-> (forall a b. SimpleSP a -> SimpleSP b -> SimpleSP b)
-> (forall a b. SimpleSP a -> SimpleSP b -> SimpleSP a)
-> Applicative SimpleSP
forall a. a -> SimpleSP a
forall a b. SimpleSP a -> SimpleSP b -> SimpleSP a
forall a b. SimpleSP a -> SimpleSP b -> SimpleSP b
forall a b. SimpleSP (a -> b) -> SimpleSP a -> SimpleSP b
forall a b c.
(a -> b -> c) -> SimpleSP a -> SimpleSP b -> SimpleSP c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> SimpleSP a
pure :: forall a. a -> SimpleSP a
$c<*> :: forall a b. SimpleSP (a -> b) -> SimpleSP a -> SimpleSP b
<*> :: forall a b. SimpleSP (a -> b) -> SimpleSP a -> SimpleSP b
$cliftA2 :: forall a b c.
(a -> b -> c) -> SimpleSP a -> SimpleSP b -> SimpleSP c
liftA2 :: forall a b c.
(a -> b -> c) -> SimpleSP a -> SimpleSP b -> SimpleSP c
$c*> :: forall a b. SimpleSP a -> SimpleSP b -> SimpleSP b
*> :: forall a b. SimpleSP a -> SimpleSP b -> SimpleSP b
$c<* :: forall a b. SimpleSP a -> SimpleSP b -> SimpleSP a
<* :: forall a b. SimpleSP a -> SimpleSP b -> SimpleSP a
Applicative, Applicative SimpleSP
Applicative SimpleSP =>
(forall a b. SimpleSP a -> (a -> SimpleSP b) -> SimpleSP b)
-> (forall a b. SimpleSP a -> SimpleSP b -> SimpleSP b)
-> (forall a. a -> SimpleSP a)
-> Monad SimpleSP
forall a. a -> SimpleSP a
forall a b. SimpleSP a -> SimpleSP b -> SimpleSP b
forall a b. SimpleSP a -> (a -> SimpleSP b) -> SimpleSP b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. SimpleSP a -> (a -> SimpleSP b) -> SimpleSP b
>>= :: forall a b. SimpleSP a -> (a -> SimpleSP b) -> SimpleSP b
$c>> :: forall a b. SimpleSP a -> SimpleSP b -> SimpleSP b
>> :: forall a b. SimpleSP a -> SimpleSP b -> SimpleSP b
$creturn :: forall a. a -> SimpleSP a
return :: forall a. a -> SimpleSP a
Monad, Monad SimpleSP
Monad SimpleSP =>
(forall a. IO a -> SimpleSP a) -> MonadIO SimpleSP
forall a. IO a -> SimpleSP a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> SimpleSP a
liftIO :: forall a. IO a -> SimpleSP a
MonadIO, MonadReader SimpleSPCtx, MonadError SimpleError)

data SimpleSPCtx = SimpleSPCtx
  { SimpleSPCtx -> Config
_spctxConfig :: Config,
    SimpleSPCtx -> [IdPConfig_]
_spctxIdP :: [IdPConfig_],
    SimpleSPCtx -> MVar RequestStore
_spctxReq :: MVar RequestStore,
    SimpleSPCtx -> MVar AssertionStore
_spctxAss :: MVar AssertionStore
  }

type RequestStore = Map.Map (ID AuthnRequest) Time

type AssertionStore = Map.Map (ID Assertion) Time

makeLenses ''SimpleSPCtx

type MonadApp m = (GetAllIdPs SimpleError m, SPHandler SimpleError m)

-- | If you read the 'Config' initially in 'IO' and then pass it into the monad via 'Reader', you
-- safe disk load and redundant debug logs.
instance SPHandler SimpleError SimpleSP where
  type NTCTX SimpleSP = SimpleSPCtx
  nt :: forall x. NTCTX SimpleSP -> SimpleSP x -> Handler x
nt NTCTX SimpleSP
ctx (SimpleSP ReaderT SimpleSPCtx (ExceptT SimpleError IO) x
m) = ExceptT ServerError IO x -> Handler x
forall a. ExceptT ServerError IO a -> Handler a
Handler (ExceptT ServerError IO x -> Handler x)
-> (ExceptT SimpleError IO x -> ExceptT ServerError IO x)
-> ExceptT SimpleError IO x
-> Handler x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either ServerError x) -> ExceptT ServerError IO x
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ServerError x) -> ExceptT ServerError IO x)
-> (ExceptT SimpleError IO x -> IO (Either ServerError x))
-> ExceptT SimpleError IO x
-> ExceptT ServerError IO x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either SimpleError x -> Either ServerError x)
-> IO (Either SimpleError x) -> IO (Either ServerError x)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SimpleError -> ServerError)
-> Either SimpleError x -> Either ServerError x
forall a b r. (a -> b) -> Either a r -> Either b r
fmapL SimpleError -> ServerError
toServerError) (IO (Either SimpleError x) -> IO (Either ServerError x))
-> (ExceptT SimpleError IO x -> IO (Either SimpleError x))
-> ExceptT SimpleError IO x
-> IO (Either ServerError x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT SimpleError IO x -> IO (Either SimpleError x)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT SimpleError IO x -> Handler x)
-> ExceptT SimpleError IO x -> Handler x
forall a b. (a -> b) -> a -> b
$ ReaderT SimpleSPCtx (ExceptT SimpleError IO) x
m ReaderT SimpleSPCtx (ExceptT SimpleError IO) x
-> SimpleSPCtx -> ExceptT SimpleError IO x
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` NTCTX SimpleSP
SimpleSPCtx
ctx

runSimpleSP :: SimpleSPCtx -> SimpleSP a -> IO (Either SimpleError a)
runSimpleSP :: forall a. SimpleSPCtx -> SimpleSP a -> IO (Either SimpleError a)
runSimpleSP SimpleSPCtx
ctx (SimpleSP ReaderT SimpleSPCtx (ExceptT SimpleError IO) a
action) = ExceptT SimpleError IO a -> IO (Either SimpleError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT SimpleError IO a -> IO (Either SimpleError a))
-> ExceptT SimpleError IO a -> IO (Either SimpleError a)
forall a b. (a -> b) -> a -> b
$ ReaderT SimpleSPCtx (ExceptT SimpleError IO) a
action ReaderT SimpleSPCtx (ExceptT SimpleError IO) a
-> SimpleSPCtx -> ExceptT SimpleError IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` SimpleSPCtx
ctx

mkSimpleSPCtx :: Config -> [IdPConfig_] -> IO SimpleSPCtx
mkSimpleSPCtx :: Config -> [IdPConfig_] -> IO SimpleSPCtx
mkSimpleSPCtx Config
cfg [IdPConfig_]
idps = Config
-> [IdPConfig_]
-> MVar RequestStore
-> MVar AssertionStore
-> SimpleSPCtx
SimpleSPCtx Config
cfg [IdPConfig_]
idps (MVar RequestStore -> MVar AssertionStore -> SimpleSPCtx)
-> IO (MVar RequestStore)
-> IO (MVar AssertionStore -> SimpleSPCtx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RequestStore -> IO (MVar RequestStore)
forall a. a -> IO (MVar a)
newMVar RequestStore
forall a. Monoid a => a
mempty IO (MVar AssertionStore -> SimpleSPCtx)
-> IO (MVar AssertionStore) -> IO SimpleSPCtx
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AssertionStore -> IO (MVar AssertionStore)
forall a. a -> IO (MVar a)
newMVar AssertionStore
forall a. Monoid a => a
mempty

instance HasLogger SimpleSP where
  logger :: Level -> String -> SimpleSP ()
logger Level
level String
msg = SimpleSP Config
forall (m :: * -> *). HasConfig m => m Config
getConfig SimpleSP Config -> (Config -> SimpleSP ()) -> SimpleSP ()
forall a b. SimpleSP a -> (a -> SimpleSP b) -> SimpleSP b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Config
cfg -> ReaderT SimpleSPCtx (ExceptT SimpleError IO) () -> SimpleSP ()
forall a.
ReaderT SimpleSPCtx (ExceptT SimpleError IO) a -> SimpleSP a
SimpleSP (Level
-> Level
-> String
-> ReaderT SimpleSPCtx (ExceptT SimpleError IO) ()
forall (m :: * -> *). MonadIO m => Level -> Level -> String -> m ()
loggerIO (Config
cfg Config -> Getting Level Config Level -> Level
forall s a. s -> Getting a s a -> a
^. Getting Level Config Level
Lens' Config Level
cfgLogLevel) Level
level String
msg)

instance HasCreateUUID SimpleSP where
  createUUID :: SimpleSP UUID
createUUID = ReaderT SimpleSPCtx (ExceptT SimpleError IO) UUID -> SimpleSP UUID
forall a.
ReaderT SimpleSPCtx (ExceptT SimpleError IO) a -> SimpleSP a
SimpleSP (ReaderT SimpleSPCtx (ExceptT SimpleError IO) UUID
 -> SimpleSP UUID)
-> ReaderT SimpleSPCtx (ExceptT SimpleError IO) UUID
-> SimpleSP UUID
forall a b. (a -> b) -> a -> b
$ ReaderT SimpleSPCtx (ExceptT SimpleError IO) UUID
forall (m :: * -> *). MonadIO m => m UUID
createUUIDIO

instance HasNow SimpleSP where
  getNow :: SimpleSP Time
getNow = ReaderT SimpleSPCtx (ExceptT SimpleError IO) Time -> SimpleSP Time
forall a.
ReaderT SimpleSPCtx (ExceptT SimpleError IO) a -> SimpleSP a
SimpleSP (ReaderT SimpleSPCtx (ExceptT SimpleError IO) Time
 -> SimpleSP Time)
-> ReaderT SimpleSPCtx (ExceptT SimpleError IO) Time
-> SimpleSP Time
forall a b. (a -> b) -> a -> b
$ ReaderT SimpleSPCtx (ExceptT SimpleError IO) Time
forall (m :: * -> *). MonadIO m => m Time
getNowIO

simpleStoreID ::
  (MonadIO m, MonadReader ctx m) =>
  Lens' ctx (MVar (Map (ID a) Time)) ->
  ID a ->
  Time ->
  m ()
simpleStoreID :: forall {k} (m :: * -> *) ctx (a :: k).
(MonadIO m, MonadReader ctx m) =>
Lens' ctx (MVar (Map (ID a) Time)) -> ID a -> Time -> m ()
simpleStoreID Lens' ctx (MVar (Map (ID a) Time))
sel ID a
item Time
endOfLife = do
  MVar (Map (ID a) Time)
store <- (ctx -> MVar (Map (ID a) Time)) -> m (MVar (Map (ID a) Time))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ctx
-> Getting (MVar (Map (ID a) Time)) ctx (MVar (Map (ID a) Time))
-> MVar (Map (ID a) Time)
forall s a. s -> Getting a s a -> a
^. Getting (MVar (Map (ID a) Time)) ctx (MVar (Map (ID a) Time))
Lens' ctx (MVar (Map (ID a) Time))
sel)
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar (Map (ID a) Time)
-> (Map (ID a) Time -> IO (Map (ID a) Time)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map (ID a) Time)
store (Map (ID a) Time -> IO (Map (ID a) Time)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map (ID a) Time -> IO (Map (ID a) Time))
-> (Map (ID a) Time -> Map (ID a) Time)
-> Map (ID a) Time
-> IO (Map (ID a) Time)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ID a -> Time -> Map (ID a) Time -> Map (ID a) Time
forall {k} (a :: k).
ID a -> Time -> Map (ID a) Time -> Map (ID a) Time
simpleStoreID' ID a
item Time
endOfLife)

simpleStoreID' :: ID a -> Time -> Map (ID a) Time -> Map (ID a) Time
simpleStoreID' :: forall {k} (a :: k).
ID a -> Time -> Map (ID a) Time -> Map (ID a) Time
simpleStoreID' = ID a -> Time -> Map (ID a) Time -> Map (ID a) Time
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert

simpleUnStoreID ::
  (MonadIO m, MonadReader ctx m) =>
  Lens' ctx (MVar (Map (ID a) Time)) ->
  (ID a) ->
  m ()
simpleUnStoreID :: forall {k} (m :: * -> *) ctx (a :: k).
(MonadIO m, MonadReader ctx m) =>
Lens' ctx (MVar (Map (ID a) Time)) -> ID a -> m ()
simpleUnStoreID Lens' ctx (MVar (Map (ID a) Time))
sel ID a
item = do
  MVar (Map (ID a) Time)
store <- (ctx -> MVar (Map (ID a) Time)) -> m (MVar (Map (ID a) Time))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ctx
-> Getting (MVar (Map (ID a) Time)) ctx (MVar (Map (ID a) Time))
-> MVar (Map (ID a) Time)
forall s a. s -> Getting a s a -> a
^. Getting (MVar (Map (ID a) Time)) ctx (MVar (Map (ID a) Time))
Lens' ctx (MVar (Map (ID a) Time))
sel)
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar (Map (ID a) Time)
-> (Map (ID a) Time -> IO (Map (ID a) Time)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map (ID a) Time)
store (Map (ID a) Time -> IO (Map (ID a) Time)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map (ID a) Time -> IO (Map (ID a) Time))
-> (Map (ID a) Time -> Map (ID a) Time)
-> Map (ID a) Time
-> IO (Map (ID a) Time)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ID a -> Map (ID a) Time -> Map (ID a) Time
forall {k} (a :: k). ID a -> Map (ID a) Time -> Map (ID a) Time
simpleUnStoreID' ID a
item)

simpleUnStoreID' :: ID a -> Map (ID a) Time -> Map (ID a) Time
simpleUnStoreID' :: forall {k} (a :: k). ID a -> Map (ID a) Time -> Map (ID a) Time
simpleUnStoreID' = ID a -> Map (ID a) Time -> Map (ID a) Time
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete

simpleIsAliveID ::
  (MonadIO m, MonadReader ctx m, SP m) =>
  Lens' ctx (MVar (Map (ID a) Time)) ->
  ID a ->
  m Bool
simpleIsAliveID :: forall {k} (m :: * -> *) ctx (a :: k).
(MonadIO m, MonadReader ctx m, SP m) =>
Lens' ctx (MVar (Map (ID a) Time)) -> ID a -> m Bool
simpleIsAliveID Lens' ctx (MVar (Map (ID a) Time))
sel ID a
item = do
  Time
now <- m Time
forall (m :: * -> *). HasNow m => m Time
getNow
  MVar (Map (ID a) Time)
store <- (ctx -> MVar (Map (ID a) Time)) -> m (MVar (Map (ID a) Time))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ctx
-> Getting (MVar (Map (ID a) Time)) ctx (MVar (Map (ID a) Time))
-> MVar (Map (ID a) Time)
forall s a. s -> Getting a s a -> a
^. Getting (MVar (Map (ID a) Time)) ctx (MVar (Map (ID a) Time))
Lens' ctx (MVar (Map (ID a) Time))
sel)
  Map (ID a) Time
items <- IO (Map (ID a) Time) -> m (Map (ID a) Time)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map (ID a) Time) -> m (Map (ID a) Time))
-> IO (Map (ID a) Time) -> m (Map (ID a) Time)
forall a b. (a -> b) -> a -> b
$ MVar (Map (ID a) Time) -> IO (Map (ID a) Time)
forall a. MVar a -> IO a
readMVar MVar (Map (ID a) Time)
store
  Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Time -> ID a -> Map (ID a) Time -> Bool
forall {k} (a :: k). Time -> ID a -> Map (ID a) Time -> Bool
simpleIsAliveID' Time
now ID a
item Map (ID a) Time
items

simpleIsAliveID' :: Time -> ID a -> Map (ID a) Time -> Bool
simpleIsAliveID' :: forall {k} (a :: k). Time -> ID a -> Map (ID a) Time -> Bool
simpleIsAliveID' Time
now ID a
item Map (ID a) Time
items = Bool -> (Time -> Bool) -> Maybe Time -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
now) (ID a -> Map (ID a) Time -> Maybe Time
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ID a
item Map (ID a) Time
items)

instance SPStoreID AuthnRequest SimpleSP where
  storeID :: ID AuthnRequest -> Time -> SimpleSP ()
storeID = Lens' SimpleSPCtx (MVar RequestStore)
-> ID AuthnRequest -> Time -> SimpleSP ()
forall {k} (m :: * -> *) ctx (a :: k).
(MonadIO m, MonadReader ctx m) =>
Lens' ctx (MVar (Map (ID a) Time)) -> ID a -> Time -> m ()
simpleStoreID (MVar RequestStore -> f (MVar RequestStore))
-> SimpleSPCtx -> f SimpleSPCtx
Lens' SimpleSPCtx (MVar RequestStore)
spctxReq
  unStoreID :: ID AuthnRequest -> SimpleSP ()
unStoreID = Lens' SimpleSPCtx (MVar RequestStore)
-> ID AuthnRequest -> SimpleSP ()
forall {k} (m :: * -> *) ctx (a :: k).
(MonadIO m, MonadReader ctx m) =>
Lens' ctx (MVar (Map (ID a) Time)) -> ID a -> m ()
simpleUnStoreID (MVar RequestStore -> f (MVar RequestStore))
-> SimpleSPCtx -> f SimpleSPCtx
Lens' SimpleSPCtx (MVar RequestStore)
spctxReq
  isAliveID :: ID AuthnRequest -> SimpleSP Bool
isAliveID = Lens' SimpleSPCtx (MVar RequestStore)
-> ID AuthnRequest -> SimpleSP Bool
forall {k} (m :: * -> *) ctx (a :: k).
(MonadIO m, MonadReader ctx m, SP m) =>
Lens' ctx (MVar (Map (ID a) Time)) -> ID a -> m Bool
simpleIsAliveID (MVar RequestStore -> f (MVar RequestStore))
-> SimpleSPCtx -> f SimpleSPCtx
Lens' SimpleSPCtx (MVar RequestStore)
spctxReq

instance SPStoreID Assertion SimpleSP where
  storeID :: ID Assertion -> Time -> SimpleSP ()
storeID = Lens' SimpleSPCtx (MVar AssertionStore)
-> ID Assertion -> Time -> SimpleSP ()
forall {k} (m :: * -> *) ctx (a :: k).
(MonadIO m, MonadReader ctx m) =>
Lens' ctx (MVar (Map (ID a) Time)) -> ID a -> Time -> m ()
simpleStoreID (MVar AssertionStore -> f (MVar AssertionStore))
-> SimpleSPCtx -> f SimpleSPCtx
Lens' SimpleSPCtx (MVar AssertionStore)
spctxAss
  unStoreID :: ID Assertion -> SimpleSP ()
unStoreID = Lens' SimpleSPCtx (MVar AssertionStore)
-> ID Assertion -> SimpleSP ()
forall {k} (m :: * -> *) ctx (a :: k).
(MonadIO m, MonadReader ctx m) =>
Lens' ctx (MVar (Map (ID a) Time)) -> ID a -> m ()
simpleUnStoreID (MVar AssertionStore -> f (MVar AssertionStore))
-> SimpleSPCtx -> f SimpleSPCtx
Lens' SimpleSPCtx (MVar AssertionStore)
spctxAss
  isAliveID :: ID Assertion -> SimpleSP Bool
isAliveID = Lens' SimpleSPCtx (MVar AssertionStore)
-> ID Assertion -> SimpleSP Bool
forall {k} (m :: * -> *) ctx (a :: k).
(MonadIO m, MonadReader ctx m, SP m) =>
Lens' ctx (MVar (Map (ID a) Time)) -> ID a -> m Bool
simpleIsAliveID (MVar AssertionStore -> f (MVar AssertionStore))
-> SimpleSPCtx -> f SimpleSPCtx
Lens' SimpleSPCtx (MVar AssertionStore)
spctxAss

instance HasConfig SimpleSP where
  getConfig :: SimpleSP Config
getConfig = (SimpleSPCtx -> Getting Config SimpleSPCtx Config -> Config
forall s a. s -> Getting a s a -> a
^. Getting Config SimpleSPCtx Config
Lens' SimpleSPCtx Config
spctxConfig) (SimpleSPCtx -> Config) -> SimpleSP SimpleSPCtx -> SimpleSP Config
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT SimpleSPCtx (ExceptT SimpleError IO) SimpleSPCtx
-> SimpleSP SimpleSPCtx
forall a.
ReaderT SimpleSPCtx (ExceptT SimpleError IO) a -> SimpleSP a
SimpleSP ReaderT SimpleSPCtx (ExceptT SimpleError IO) SimpleSPCtx
forall r (m :: * -> *). MonadReader r m => m r
ask

instance SPStoreIdP SimpleError SimpleSP where
  type IdPConfigExtra SimpleSP = ()
  type IdPConfigSPId SimpleSP = Void
  storeIdPConfig :: IdPConfig (IdPConfigExtra SimpleSP) -> SimpleSP ()
storeIdPConfig IdPConfig (IdPConfigExtra SimpleSP)
_ = String -> SimpleSP ()
forall a. HasCallStack => String -> a
error String
"instance SPStoreIdP SimpleError SimpleSP: storeIdPConfig not implemented."
  getIdPConfig :: IdPId -> SimpleSP (IdPConfig (IdPConfigExtra SimpleSP))
getIdPConfig = SimpleSP [IdPConfig_]
-> (IdPConfig_ -> IdPId) -> IdPId -> SimpleSP IdPConfig_
forall err (m :: * -> *) a.
(MonadError (Error err) m, HasConfig m, Show a, Ord a) =>
m [IdPConfig_] -> (IdPConfig_ -> a) -> a -> m IdPConfig_
simpleGetIdPConfigBy ((SimpleSPCtx -> [IdPConfig_]) -> SimpleSP [IdPConfig_]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (SimpleSPCtx
-> Getting [IdPConfig_] SimpleSPCtx [IdPConfig_] -> [IdPConfig_]
forall s a. s -> Getting a s a -> a
^. Getting [IdPConfig_] SimpleSPCtx [IdPConfig_]
Lens' SimpleSPCtx [IdPConfig_]
spctxIdP)) (IdPConfig_ -> Getting IdPId IdPConfig_ IdPId -> IdPId
forall s a. s -> Getting a s a -> a
^. Getting IdPId IdPConfig_ IdPId
forall extra (f :: * -> *).
Functor f =>
(IdPId -> f IdPId) -> IdPConfig extra -> f (IdPConfig extra)
idpId)
  getIdPConfigByIssuerOptionalSPId :: Issuer
-> Maybe (IdPConfigSPId SimpleSP)
-> SimpleSP (IdPConfig (IdPConfigExtra SimpleSP))
getIdPConfigByIssuerOptionalSPId Issuer
issuer Maybe (IdPConfigSPId SimpleSP)
_ = SimpleSP [IdPConfig_]
-> (IdPConfig_ -> Issuer) -> Issuer -> SimpleSP IdPConfig_
forall err (m :: * -> *) a.
(MonadError (Error err) m, HasConfig m, Show a, Ord a) =>
m [IdPConfig_] -> (IdPConfig_ -> a) -> a -> m IdPConfig_
simpleGetIdPConfigBy ((SimpleSPCtx -> [IdPConfig_]) -> SimpleSP [IdPConfig_]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (SimpleSPCtx
-> Getting [IdPConfig_] SimpleSPCtx [IdPConfig_] -> [IdPConfig_]
forall s a. s -> Getting a s a -> a
^. Getting [IdPConfig_] SimpleSPCtx [IdPConfig_]
Lens' SimpleSPCtx [IdPConfig_]
spctxIdP)) (IdPConfig_ -> Getting Issuer IdPConfig_ Issuer -> Issuer
forall s a. s -> Getting a s a -> a
^. (IdPMetadata -> Const Issuer IdPMetadata)
-> IdPConfig_ -> Const Issuer IdPConfig_
forall extra (f :: * -> *).
Functor f =>
(IdPMetadata -> f IdPMetadata)
-> IdPConfig extra -> f (IdPConfig extra)
idpMetadata ((IdPMetadata -> Const Issuer IdPMetadata)
 -> IdPConfig_ -> Const Issuer IdPConfig_)
-> ((Issuer -> Const Issuer Issuer)
    -> IdPMetadata -> Const Issuer IdPMetadata)
-> Getting Issuer IdPConfig_ Issuer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Issuer -> Const Issuer Issuer)
-> IdPMetadata -> Const Issuer IdPMetadata
Lens' IdPMetadata Issuer
edIssuer) Issuer
issuer

simpleGetIdPConfigBy ::
  (MonadError (Error err) m, HasConfig m, Show a, Ord a) =>
  m [IdPConfig_] ->
  (IdPConfig_ -> a) ->
  a ->
  m IdPConfig_
simpleGetIdPConfigBy :: forall err (m :: * -> *) a.
(MonadError (Error err) m, HasConfig m, Show a, Ord a) =>
m [IdPConfig_] -> (IdPConfig_ -> a) -> a -> m IdPConfig_
simpleGetIdPConfigBy m [IdPConfig_]
getIdps IdPConfig_ -> a
mkkey a
idpname = do
  [IdPConfig_]
idps <- m [IdPConfig_]
getIdps
  m IdPConfig_
-> (IdPConfig_ -> m IdPConfig_) -> Maybe IdPConfig_ -> m IdPConfig_
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m IdPConfig_
crash' IdPConfig_ -> m IdPConfig_
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe IdPConfig_ -> m IdPConfig_)
-> (Map a IdPConfig_ -> Maybe IdPConfig_)
-> Map a IdPConfig_
-> m IdPConfig_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Map a IdPConfig_ -> Maybe IdPConfig_
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
idpname (Map a IdPConfig_ -> m IdPConfig_)
-> Map a IdPConfig_ -> m IdPConfig_
forall a b. (a -> b) -> a -> b
$ [IdPConfig_] -> Map a IdPConfig_
mkmap [IdPConfig_]
idps
  where
    crash' :: m IdPConfig_
crash' = Error err -> m IdPConfig_
forall a. Error err -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LT -> Error err
forall err. LT -> Error err
UnknownIdP (LT -> Error err) -> (a -> LT) -> a -> Error err
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> LT
forall a b. ConvertibleStrings a b => a -> b
cs (String -> LT) -> (a -> String) -> a -> LT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show (a -> Error err) -> a -> Error err
forall a b. (a -> b) -> a -> b
$ a
idpname)
    mkmap :: [IdPConfig_] -> Map a IdPConfig_
mkmap = [(a, IdPConfig_)] -> Map a IdPConfig_
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(a, IdPConfig_)] -> Map a IdPConfig_)
-> ([IdPConfig_] -> [(a, IdPConfig_)])
-> [IdPConfig_]
-> Map a IdPConfig_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IdPConfig_ -> (a, IdPConfig_))
-> [IdPConfig_] -> [(a, IdPConfig_)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IdPConfig_ -> a
mkkey (IdPConfig_ -> a)
-> (IdPConfig_ -> IdPConfig_) -> IdPConfig_ -> (a, IdPConfig_)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& IdPConfig_ -> IdPConfig_
forall a. a -> a
id)

class SPStoreIdP err m => GetAllIdPs err m where
  getAllIdPs :: m [IdPConfig (IdPConfigExtra m)]

instance GetAllIdPs SimpleError SimpleSP where
  getAllIdPs :: SimpleSP [IdPConfig (IdPConfigExtra SimpleSP)]
getAllIdPs = (SimpleSPCtx -> [IdPConfig_]) -> SimpleSP [IdPConfig_]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (SimpleSPCtx
-> Getting [IdPConfig_] SimpleSPCtx [IdPConfig_] -> [IdPConfig_]
forall s a. s -> Getting a s a -> a
^. Getting [IdPConfig_] SimpleSPCtx [IdPConfig_]
Lens' SimpleSPCtx [IdPConfig_]
spctxIdP)

----------------------------------------------------------------------
-- the app

-- | The most straight-forward 'Application' that can be constructed from 'api', 'API'.
app :: Config -> [IdPConfig_] -> IO Application
app :: Config -> [IdPConfig_] -> IO Application
app Config
cfg [IdPConfig_]
idps = Proxy SimpleSP -> NTCTX SimpleSP -> IO Application
forall (m :: * -> *).
(SP m, MonadApp m) =>
Proxy m -> NTCTX m -> IO Application
app' (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @SimpleSP) (SimpleSPCtx -> IO Application) -> IO SimpleSPCtx -> IO Application
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Config -> [IdPConfig_] -> IO SimpleSPCtx
mkSimpleSPCtx Config
cfg [IdPConfig_]
idps

app' ::
  forall (m :: Type -> Type).
  (SP m, MonadApp m) =>
  Proxy m ->
  NTCTX m ->
  IO Application
app' :: forall (m :: * -> *).
(SP m, MonadApp m) =>
Proxy m -> NTCTX m -> IO Application
app' Proxy m
Proxy NTCTX m
ctx = do
  let served :: Application
      served :: Application
served =
        Proxy APPAPI -> Server APPAPI -> Application
forall {k} (api :: k).
HasServer api '[] =>
Proxy api -> Server api -> Application
serve
          (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @APPAPI)
          (Proxy APPAPI
-> (forall x. m x -> Handler x)
-> ServerT APPAPI m
-> Server APPAPI
forall {k} (api :: k) (m :: * -> *) (n :: * -> *).
HasServer api '[] =>
Proxy api
-> (forall x. m x -> n x) -> ServerT api m -> ServerT api n
hoistServer (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @APPAPI) (forall err (m :: * -> *) x.
SPHandler err m =>
NTCTX m -> m x -> Handler x
nt @SimpleError @m NTCTX m
ctx) ServerT APPAPI m
forall (m :: * -> *). MonadApp m => ServerT APPAPI m
appapi :: Server APPAPI)
  Application -> IO Application
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Application -> IO Application)
-> (Application -> Application) -> Application -> IO Application
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Application -> Application
setHttpCachePolicy (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$ Application
served

type SPAPI =
  Header "Cookie" Cky :> Get '[HTML] LoginStatus
    :<|> "logout" :> "local" :> GetRedir '[HTML] (WithCookieAndLocation ST)
    :<|> "logout" :> "single" :> GetRedir '[HTML] (WithCookieAndLocation ST)

type APPAPI =
  "sp" :> SPAPI
    :<|> "sso" :> API

spapi :: (MonadApp m) => ServerT SPAPI m
spapi :: forall (m :: * -> *). MonadApp m => ServerT SPAPI m
spapi = Maybe Cky -> m LoginStatus
forall err (m :: * -> *).
(GetAllIdPs err m, SP m) =>
Maybe Cky -> m LoginStatus
loginStatus (Maybe Cky -> m LoginStatus)
-> (m (WithCookieAndLocation ST) :<|> m (WithCookieAndLocation ST))
-> (Maybe Cky -> m LoginStatus)
   :<|> (m (WithCookieAndLocation ST)
         :<|> m (WithCookieAndLocation ST))
forall a b. a -> b -> a :<|> b
:<|> m (WithCookieAndLocation ST)
forall (m :: * -> *).
SPHandler SimpleError m =>
m (WithCookieAndLocation ST)
localLogout m (WithCookieAndLocation ST)
-> m (WithCookieAndLocation ST)
-> m (WithCookieAndLocation ST) :<|> m (WithCookieAndLocation ST)
forall a b. a -> b -> a :<|> b
:<|> m (WithCookieAndLocation ST)
forall (m :: * -> *).
(HasCallStack, SP m) =>
m (WithCookieAndLocation ST)
singleLogout

appapi :: (MonadApp m) => ServerT APPAPI m
appapi :: forall (m :: * -> *). MonadApp m => ServerT APPAPI m
appapi = (Maybe Cky -> m LoginStatus)
:<|> (m (WithCookieAndLocation ST)
      :<|> m (WithCookieAndLocation ST))
ServerT SPAPI m
forall (m :: * -> *). MonadApp m => ServerT SPAPI m
spapi ((Maybe Cky -> m LoginStatus)
 :<|> (m (WithCookieAndLocation ST)
       :<|> m (WithCookieAndLocation ST)))
-> (m SPMetadata
    :<|> ((IdPId -> m (FormRedirect AuthnRequest))
          :<|> (AuthnResponseBody -> m (WithCookieAndLocation ST))))
-> ((Maybe Cky -> m LoginStatus)
    :<|> (m (WithCookieAndLocation ST)
          :<|> m (WithCookieAndLocation ST)))
   :<|> (m SPMetadata
         :<|> ((IdPId -> m (FormRedirect AuthnRequest))
               :<|> (AuthnResponseBody -> m (WithCookieAndLocation ST))))
forall a b. a -> b -> a :<|> b
:<|> ST -> HandleVerdict m -> ServerT API m
forall err (m :: * -> *).
SPHandler (Error err) m =>
ST -> HandleVerdict m -> ServerT API m
api ST
"toy-sp" (OnSuccessRedirect m -> HandleVerdict m
forall (m :: * -> *). OnSuccessRedirect m -> HandleVerdict m
HandleVerdictRedirect (SubjectFoldCase -> OnSuccessRedirect m
forall (m :: * -> *).
(Monad m, SP m) =>
SubjectFoldCase -> OnSuccessRedirect m
simpleOnSuccess SubjectFoldCase
SubjectFoldCase))

loginStatus :: (GetAllIdPs err m, SP m) => Maybe Cky -> m LoginStatus
loginStatus :: forall err (m :: * -> *).
(GetAllIdPs err m, SP m) =>
Maybe Cky -> m LoginStatus
loginStatus Maybe Cky
cookie = do
  [IdPConfig (IdPConfigExtra m)]
idpids <- m [IdPConfig (IdPConfigExtra m)]
forall err (m :: * -> *).
GetAllIdPs err m =>
m [IdPConfig (IdPConfigExtra m)]
getAllIdPs
  [(ST, ST)]
loginOpts <- IdPConfig (IdPConfigExtra m) -> m (ST, ST)
forall (m :: * -> *) a.
(Monad m, SP m) =>
IdPConfig a -> m (ST, ST)
mkLoginOption (IdPConfig (IdPConfigExtra m) -> m (ST, ST))
-> [IdPConfig (IdPConfigExtra m)] -> m [(ST, ST)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` [IdPConfig (IdPConfigExtra m)]
idpids
  ST
logoutPath <- Path -> m ST
forall (m :: * -> *). (Monad m, HasConfig m) => Path -> m ST
getPath' Path
SpPathLocalLogout
  LoginStatus -> m LoginStatus
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoginStatus -> m LoginStatus) -> LoginStatus -> m LoginStatus
forall a b. (a -> b) -> a -> b
$ LoginStatus -> (Cky -> LoginStatus) -> Maybe Cky -> LoginStatus
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([(ST, ST)] -> LoginStatus
NotLoggedIn [(ST, ST)]
loginOpts) (ST -> ST -> LoginStatus
LoggedInAs ST
logoutPath (ST -> LoginStatus) -> (Cky -> ST) -> Cky -> LoginStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SBS -> ST
forall a b. ConvertibleStrings a b => a -> b
cs (SBS -> ST) -> (Cky -> SBS) -> Cky -> ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cky -> SBS
forall {k} (name :: k). SimpleSetCookie name -> SBS
setSimpleCookieValue) Maybe Cky
cookie

mkLoginOption :: (Monad m, SP m) => IdPConfig a -> m (ST, ST)
mkLoginOption :: forall (m :: * -> *) a.
(Monad m, SP m) =>
IdPConfig a -> m (ST, ST)
mkLoginOption IdPConfig a
icfg = (URI -> ST
renderURI (URI -> ST) -> URI -> ST
forall a b. (a -> b) -> a -> b
$ IdPConfig a
icfg IdPConfig a -> Getting URI (IdPConfig a) URI -> URI
forall s a. s -> Getting a s a -> a
^. (IdPMetadata -> Const URI IdPMetadata)
-> IdPConfig a -> Const URI (IdPConfig a)
forall extra (f :: * -> *).
Functor f =>
(IdPMetadata -> f IdPMetadata)
-> IdPConfig extra -> f (IdPConfig extra)
idpMetadata ((IdPMetadata -> Const URI IdPMetadata)
 -> IdPConfig a -> Const URI (IdPConfig a))
-> ((URI -> Const URI URI) -> IdPMetadata -> Const URI IdPMetadata)
-> Getting URI (IdPConfig a) URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Issuer -> Const URI Issuer)
-> IdPMetadata -> Const URI IdPMetadata
Lens' IdPMetadata Issuer
edIssuer ((Issuer -> Const URI Issuer)
 -> IdPMetadata -> Const URI IdPMetadata)
-> ((URI -> Const URI URI) -> Issuer -> Const URI Issuer)
-> (URI -> Const URI URI)
-> IdPMetadata
-> Const URI IdPMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (URI -> Const URI URI) -> Issuer -> Const URI Issuer
Iso' Issuer URI
fromIssuer,) (ST -> (ST, ST)) -> m ST -> m (ST, ST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path -> m ST
forall (m :: * -> *). (Monad m, HasConfig m) => Path -> m ST
getPath' (IdPId -> Path
SsoPathAuthnReq (IdPConfig a
icfg IdPConfig a -> Getting IdPId (IdPConfig a) IdPId -> IdPId
forall s a. s -> Getting a s a -> a
^. Getting IdPId (IdPConfig a) IdPId
forall extra (f :: * -> *).
Functor f =>
(IdPId -> f IdPId) -> IdPConfig extra -> f (IdPConfig extra)
idpId))

-- | only logout on this SP.
localLogout :: SPHandler SimpleError m => m (WithCookieAndLocation ST)
localLogout :: forall (m :: * -> *).
SPHandler SimpleError m =>
m (WithCookieAndLocation ST)
localLogout = do
  URI
uri <- Path -> m URI
forall (m :: * -> *). (Monad m, HasConfig m) => Path -> m URI
getPath Path
SpPathHome
  Cky
cky <- SBS -> Maybe (ST, NominalDiffTime) -> m Cky
forall (name :: Symbol) (m :: * -> *).
(Applicative m, SP m, KnownSymbol name) =>
SBS -> Maybe (ST, NominalDiffTime) -> m (SimpleSetCookie name)
toggleCookie SBS
"/" Maybe (ST, NominalDiffTime)
forall a. Maybe a
Nothing
  WithCookieAndLocation ST -> m (WithCookieAndLocation ST)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WithCookieAndLocation ST -> m (WithCookieAndLocation ST))
-> (ST -> WithCookieAndLocation ST)
-> ST
-> m (WithCookieAndLocation ST)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cky
-> Headers '[Header "Location" URI] ST -> WithCookieAndLocation ST
forall (h :: Symbol) v orig new.
AddHeader '[Optional, Strict] h v orig new =>
v -> orig -> new
addHeader Cky
cky (Headers '[Header "Location" URI] ST -> WithCookieAndLocation ST)
-> (ST -> Headers '[Header "Location" URI] ST)
-> ST
-> WithCookieAndLocation ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> ST -> Headers '[Header "Location" URI] ST
forall (h :: Symbol) v orig new.
AddHeader '[Optional, Strict] h v orig new =>
v -> orig -> new
addHeader URI
uri (ST -> m (WithCookieAndLocation ST))
-> ST -> m (WithCookieAndLocation ST)
forall a b. (a -> b) -> a -> b
$ ST
"Logged out locally, redirecting to " ST -> ST -> ST
forall a. Semigroup a => a -> a -> a
<> URI -> ST
renderURI URI
uri

-- | as in [3/4.4]
singleLogout :: (HasCallStack, SP m) => m (WithCookieAndLocation ST)
singleLogout :: forall (m :: * -> *).
(HasCallStack, SP m) =>
m (WithCookieAndLocation ST)
singleLogout = String -> m (WithCookieAndLocation ST)
forall a. HasCallStack => String -> a
error String
"not implemented."

data LoginStatus
  = NotLoggedIn [(ST {- issuer -}, ST {- authreq path -})]
  | LoggedInAs ST ST
  deriving (LoginStatus -> LoginStatus -> Bool
(LoginStatus -> LoginStatus -> Bool)
-> (LoginStatus -> LoginStatus -> Bool) -> Eq LoginStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LoginStatus -> LoginStatus -> Bool
== :: LoginStatus -> LoginStatus -> Bool
$c/= :: LoginStatus -> LoginStatus -> Bool
/= :: LoginStatus -> LoginStatus -> Bool
Eq, Int -> LoginStatus -> ShowS
[LoginStatus] -> ShowS
LoginStatus -> String
(Int -> LoginStatus -> ShowS)
-> (LoginStatus -> String)
-> ([LoginStatus] -> ShowS)
-> Show LoginStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LoginStatus -> ShowS
showsPrec :: Int -> LoginStatus -> ShowS
$cshow :: LoginStatus -> String
show :: LoginStatus -> String
$cshowList :: [LoginStatus] -> ShowS
showList :: [LoginStatus] -> ShowS
Show)

instance MimeRender HTML LoginStatus where
  mimeRender :: Proxy HTML -> LoginStatus -> ByteString
mimeRender Proxy HTML
Proxy (NotLoggedIn [(ST, ST)]
loginOpts) =
    [Node] -> ByteString
mkHtml
      [xml|
        <body>
          [not logged in]
          $forall loginOpt <- loginOpts
            ^{mkform loginOpt}
      |]
    where
      mkform :: (ST, ST) -> [Node]
      mkform :: (ST, ST) -> [Node]
mkform (ST
issuer, ST
path) =
        [xml|
            <form action=#{path} method="get">
              <input type="submit" value="log in via #{issuer}">
          |]
  mimeRender Proxy HTML
Proxy (LoggedInAs ST
logoutPath ST
name) =
    [Node] -> ByteString
mkHtml
      [xml|
        <body>
        [logged in as #{name}]
          <form action=#{logoutPath} method="get">
            <input type="submit" value="logout">
          <p>
            (this is local logout; logout via IdP is not implemented.)
      |]

----------------------------------------------------------------------
-- uri paths

data Path
  = SpPathHome
  | SpPathLocalLogout
  | SpPathSingleLogout
  | SsoPathMeta IdPId
  | SsoPathAuthnReq IdPId
  | SsoPathAuthnResp IdPId
  deriving (Path -> Path -> Bool
(Path -> Path -> Bool) -> (Path -> Path -> Bool) -> Eq Path
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Path -> Path -> Bool
== :: Path -> Path -> Bool
$c/= :: Path -> Path -> Bool
/= :: Path -> Path -> Bool
Eq, Int -> Path -> ShowS
[Path] -> ShowS
Path -> String
(Int -> Path -> ShowS)
-> (Path -> String) -> ([Path] -> ShowS) -> Show Path
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Path -> ShowS
showsPrec :: Int -> Path -> ShowS
$cshow :: Path -> String
show :: Path -> String
$cshowList :: [Path] -> ShowS
showList :: [Path] -> ShowS
Show)

getPath' :: forall m. (Monad m, HasConfig m) => Path -> m ST
getPath' :: forall (m :: * -> *). (Monad m, HasConfig m) => Path -> m ST
getPath' = (URI -> ST) -> m URI -> m ST
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap URI -> ST
renderURI (m URI -> m ST) -> (Path -> m URI) -> Path -> m ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> m URI
forall (m :: * -> *). (Monad m, HasConfig m) => Path -> m URI
getPath

getPath :: forall m. (Monad m, HasConfig m) => Path -> m URI
getPath :: forall (m :: * -> *). (Monad m, HasConfig m) => Path -> m URI
getPath Path
path = do
  Config
cfg <- m Config
forall (m :: * -> *). HasConfig m => m Config
getConfig
  let sp, sso :: ST -> URI
      sp :: ST -> URI
sp = ((Config
cfg Config -> Getting URI Config URI -> URI
forall s a. s -> Getting a s a -> a
^. Getting URI Config URI
Lens' Config URI
cfgSPAppURI) HasCallStack => URI -> ST -> URI
URI -> ST -> URI
=/)
      sso :: ST -> URI
sso = ((Config
cfg Config -> Getting URI Config URI -> URI
forall s a. s -> Getting a s a -> a
^. Getting URI Config URI
Lens' Config URI
cfgSPSsoURI) HasCallStack => URI -> ST -> URI
URI -> ST -> URI
=/)
      withidp :: IdPId -> URI -> URI
      withidp :: IdPId -> URI -> URI
withidp (IdPId UUID
uuid) = (HasCallStack => URI -> ST -> URI
URI -> ST -> URI
=/ UUID -> ST
UUID.toText UUID
uuid)
  URI -> m URI
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (URI -> m URI) -> URI -> m URI
forall a b. (a -> b) -> a -> b
$ case Path
path of
    Path
SpPathHome -> ST -> URI
sp ST
""
    Path
SpPathLocalLogout -> ST -> URI
sp ST
"/logout/local"
    Path
SpPathSingleLogout -> ST -> URI
sp ST
"/logout/single"
    SsoPathMeta IdPId
ip -> IdPId -> URI -> URI
withidp IdPId
ip (URI -> URI) -> URI -> URI
forall a b. (a -> b) -> a -> b
$ ST -> URI
sso ST
"/meta"
    SsoPathAuthnReq IdPId
ip -> IdPId -> URI -> URI
withidp IdPId
ip (URI -> URI) -> URI -> URI
forall a b. (a -> b) -> a -> b
$ ST -> URI
sso ST
"/authreq"
    SsoPathAuthnResp IdPId
ip -> IdPId -> URI -> URI
withidp IdPId
ip (URI -> URI) -> URI -> URI
forall a b. (a -> b) -> a -> b
$ ST -> URI
sso ST
"/authresp"