{-# 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.Map as Map
import Data.Proxy
import Data.String.Conversions
import Data.Void (Void)
import SAML2.WebSSO
import Servant.API hiding (URI (..))
import Servant.Server
import Text.Hamlet.XML
import Text.XML

----------------------------------------------------------------------
-- 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) (Issuer, 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)

simpleStoreRequest ::
  (MonadIO m, MonadReader ctx m) =>
  Lens' ctx (MVar RequestStore) ->
  ID AuthnRequest ->
  Issuer ->
  Time ->
  m ()
simpleStoreRequest :: forall (m :: * -> *) ctx.
(MonadIO m, MonadReader ctx m) =>
Lens' ctx (MVar RequestStore)
-> ID AuthnRequest -> Issuer -> Time -> m ()
simpleStoreRequest Lens' ctx (MVar RequestStore)
sel ID AuthnRequest
item Issuer
issuer Time
endOfLife = do
  MVar RequestStore
store <- (ctx -> MVar RequestStore) -> m (MVar RequestStore)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ctx
-> Getting (MVar RequestStore) ctx (MVar RequestStore)
-> MVar RequestStore
forall s a. s -> Getting a s a -> a
^. Getting (MVar RequestStore) ctx (MVar RequestStore)
Lens' ctx (MVar RequestStore)
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 RequestStore -> (RequestStore -> IO RequestStore) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar RequestStore
store (RequestStore -> IO RequestStore
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RequestStore -> IO RequestStore)
-> (RequestStore -> RequestStore)
-> RequestStore
-> IO RequestStore
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ID AuthnRequest -> (Issuer, Time) -> RequestStore -> RequestStore
simpleStoreRequest' ID AuthnRequest
item (Issuer
issuer, Time
endOfLife))

simpleStoreRequest' :: ID AuthnRequest -> (Issuer, Time) -> RequestStore -> RequestStore
simpleStoreRequest' :: ID AuthnRequest -> (Issuer, Time) -> RequestStore -> RequestStore
simpleStoreRequest' = ID AuthnRequest -> (Issuer, Time) -> RequestStore -> RequestStore
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert

simpleUnStoreRequest ::
  (MonadIO m, MonadReader ctx m) =>
  Lens' ctx (MVar RequestStore) ->
  (ID AuthnRequest) ->
  m ()
simpleUnStoreRequest :: forall (m :: * -> *) ctx.
(MonadIO m, MonadReader ctx m) =>
Lens' ctx (MVar RequestStore) -> ID AuthnRequest -> m ()
simpleUnStoreRequest Lens' ctx (MVar RequestStore)
sel ID AuthnRequest
item = do
  MVar RequestStore
store <- (ctx -> MVar RequestStore) -> m (MVar RequestStore)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ctx
-> Getting (MVar RequestStore) ctx (MVar RequestStore)
-> MVar RequestStore
forall s a. s -> Getting a s a -> a
^. Getting (MVar RequestStore) ctx (MVar RequestStore)
Lens' ctx (MVar RequestStore)
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 RequestStore -> (RequestStore -> IO RequestStore) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar RequestStore
store (RequestStore -> IO RequestStore
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RequestStore -> IO RequestStore)
-> (RequestStore -> RequestStore)
-> RequestStore
-> IO RequestStore
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ID AuthnRequest -> RequestStore -> RequestStore
simpleUnStoreRequest' ID AuthnRequest
item)

simpleUnStoreRequest' :: ID AuthnRequest -> RequestStore -> RequestStore
simpleUnStoreRequest' :: ID AuthnRequest -> RequestStore -> RequestStore
simpleUnStoreRequest' = ID AuthnRequest -> RequestStore -> RequestStore
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete

simpleGetIdpIssuer ::
  (MonadIO m, MonadReader ctx m, SP m) =>
  Lens' ctx (MVar RequestStore) ->
  ID AuthnRequest ->
  m (Maybe Issuer)
simpleGetIdpIssuer :: forall (m :: * -> *) ctx.
(MonadIO m, MonadReader ctx m, SP m) =>
Lens' ctx (MVar RequestStore)
-> ID AuthnRequest -> m (Maybe Issuer)
simpleGetIdpIssuer Lens' ctx (MVar RequestStore)
sel ID AuthnRequest
item = do
  MVar RequestStore
store <- (ctx -> MVar RequestStore) -> m (MVar RequestStore)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (ctx
-> Getting (MVar RequestStore) ctx (MVar RequestStore)
-> MVar RequestStore
forall s a. s -> Getting a s a -> a
^. Getting (MVar RequestStore) ctx (MVar RequestStore)
Lens' ctx (MVar RequestStore)
sel)
  RequestStore
items <- IO RequestStore -> m RequestStore
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RequestStore -> m RequestStore)
-> IO RequestStore -> m RequestStore
forall a b. (a -> b) -> a -> b
$ MVar RequestStore -> IO RequestStore
forall a. MVar a -> IO a
readMVar MVar RequestStore
store
  ID AuthnRequest -> RequestStore -> Time -> Maybe Issuer
simpleGetIdpIssuer' ID AuthnRequest
item RequestStore
items (Time -> Maybe Issuer) -> m Time -> m (Maybe Issuer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Time
forall (m :: * -> *). HasNow m => m Time
getNow

simpleGetIdpIssuer' ::
  ID AuthnRequest ->
  RequestStore ->
  Time ->
  (Maybe Issuer)
simpleGetIdpIssuer' :: ID AuthnRequest -> RequestStore -> Time -> Maybe Issuer
simpleGetIdpIssuer' ID AuthnRequest
item RequestStore
items Time
now = case ID AuthnRequest -> RequestStore -> Maybe (Issuer, Time)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ID AuthnRequest
item RequestStore
items of
  Just (Issuer
issuer, Time
expiresAt) | Time
now Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
expiresAt -> Issuer -> Maybe Issuer
forall a. a -> Maybe a
Just Issuer
issuer
  Maybe (Issuer, Time)
_ -> Maybe Issuer
forall a. Maybe a
Nothing

instance SPStoreRequest AuthnRequest SimpleSP where
  storeRequest :: ID AuthnRequest -> Issuer -> Time -> SimpleSP ()
storeRequest = Lens' SimpleSPCtx (MVar RequestStore)
-> ID AuthnRequest -> Issuer -> Time -> SimpleSP ()
forall (m :: * -> *) ctx.
(MonadIO m, MonadReader ctx m) =>
Lens' ctx (MVar RequestStore)
-> ID AuthnRequest -> Issuer -> Time -> m ()
simpleStoreRequest (MVar RequestStore -> f (MVar RequestStore))
-> SimpleSPCtx -> f SimpleSPCtx
Lens' SimpleSPCtx (MVar RequestStore)
spctxReq
  unStoreRequest :: ID AuthnRequest -> SimpleSP ()
unStoreRequest = Lens' SimpleSPCtx (MVar RequestStore)
-> ID AuthnRequest -> SimpleSP ()
forall (m :: * -> *) ctx.
(MonadIO m, MonadReader ctx m) =>
Lens' ctx (MVar RequestStore) -> ID AuthnRequest -> m ()
simpleUnStoreRequest (MVar RequestStore -> f (MVar RequestStore))
-> SimpleSPCtx -> f SimpleSPCtx
Lens' SimpleSPCtx (MVar RequestStore)
spctxReq
  getIdpIssuer :: ID AuthnRequest -> SimpleSP (Maybe Issuer)
getIdpIssuer = Lens' SimpleSPCtx (MVar RequestStore)
-> ID AuthnRequest -> SimpleSP (Maybe Issuer)
forall (m :: * -> *) ctx.
(MonadIO m, MonadReader ctx m, SP m) =>
Lens' ctx (MVar RequestStore)
-> ID AuthnRequest -> m (Maybe Issuer)
simpleGetIdpIssuer (MVar RequestStore -> f (MVar RequestStore))
-> SimpleSPCtx -> f SimpleSPCtx
Lens' SimpleSPCtx (MVar RequestStore)
spctxReq

instance SPStoreAssertion Assertion SimpleSP where
  storeAssertionInternal :: ID Assertion -> Time -> SimpleSP ()
storeAssertionInternal = 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
  unStoreAssertion :: ID Assertion -> SimpleSP ()
unStoreAssertion = 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
  isAliveAssertion :: ID Assertion -> SimpleSP Bool
isAliveAssertion = 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

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

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)