{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeFamilies      #-}


-- | A Yesod authentication module for LTI 1.3
--   See @example/Main.hs@ for a sample implementation.
--
--   Configuration:
--
--       * Login initiation URL: http://localhost:3000/auth/page/lti13/initiate
--
--       * JWKs URL: http://localhost:3000/auth/page/lti13/jwks
--
--       * Tool link URL: http://localhost:3000
module Yesod.Auth.LTI13 (
    -- * Integration with your site
      authLTI13
    , authLTI13WithWidget
    , YesodAuthLTI13(..)

    -- * @credsExtra@ getters
    , getLtiIss
    , getLtiSub
    , getLtiToken

    -- * Data model
    -- ** Token data
    , LtiTokenClaims(..)
    , UncheckedLtiTokenClaims(..)
    , ContextClaim(..)
    , LisClaim(..)
    , Role(..)

    -- *** Anonymization
    , anonymizeLtiTokenForLogging
    , AnonymizedLtiTokenClaims(..)

    -- ** Auth
    , PlatformInfo(..)
    , Issuer
    , ClientId
    , Nonce
    ) where

import           Control.Exception.Safe     (Exception, throwIO)
import           Control.Monad.IO.Class     (MonadIO (liftIO))
import qualified Crypto.PubKey.RSA          as RSA
import           Crypto.Random              (getRandomBytes)
import qualified Data.Aeson                 as A
import qualified Data.ByteString            as BS
import qualified Data.ByteString.Base64.URL as B64
import           Data.ByteString.Builder    (toLazyByteString)
import qualified Data.ByteString.Lazy       as LBS
import qualified Data.Map.Strict            as Map
import           Data.Text                  (Text)
import qualified Data.Text.Encoding         as E
import           Data.Time                  (getCurrentTime)
import           Jose.Jwa                   (Alg (Signed), JwsAlg (RS256))
import           Jose.Jwk                   (Jwk (..), JwkSet (..),
                                             KeyUse (Sig), generateRsaKeyPair)
import           Jose.Jwt                   (KeyId (UTCKeyId))
import           Web.LTI13
import           Web.OIDC.Client            (Nonce)
import           Web.OIDC.Client.Tokens     (IdTokenClaims (..))
import           Yesod.Auth                 (Auth, AuthHandler, AuthPlugin (..),
                                             Creds (..), Route (PluginR),
                                             YesodAuth, authHttpManager,
                                             setCredsRedirect)
import           Yesod.Core                 (MonadHandler,
                                             YesodRequest (reqGetParams),
                                             deleteSession, getRequest,
                                             getUrlRender, lookupSession,
                                             lookupSessionBS, notFound,
                                             permissionDenied, redirect,
                                             runRequestBody, setSession,
                                             setSessionBS, toTypedContent)
import           Yesod.Core.Handler         (getRouteToParent)
import           Yesod.Core.Types           (TypedContent)
import           Yesod.Core.Widget

data YesodAuthLTI13Exception
    = LTIException Text LTI13Exception
    -- ^ Issue with the token
    --   Plugin name and the original exception
    | BadRequest Text Text
    -- ^ Issue with the request
    --   Plugin name and an error message
    | CorruptJwks Text Text
    -- ^ The jwks stored in the database are corrupt. Wat.
    deriving (Int -> YesodAuthLTI13Exception -> ShowS
[YesodAuthLTI13Exception] -> ShowS
YesodAuthLTI13Exception -> String
(Int -> YesodAuthLTI13Exception -> ShowS)
-> (YesodAuthLTI13Exception -> String)
-> ([YesodAuthLTI13Exception] -> ShowS)
-> Show YesodAuthLTI13Exception
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [YesodAuthLTI13Exception] -> ShowS
$cshowList :: [YesodAuthLTI13Exception] -> ShowS
show :: YesodAuthLTI13Exception -> String
$cshow :: YesodAuthLTI13Exception -> String
showsPrec :: Int -> YesodAuthLTI13Exception -> ShowS
$cshowsPrec :: Int -> YesodAuthLTI13Exception -> ShowS
Show)

instance Exception YesodAuthLTI13Exception

dispatchAuthRequest
    :: YesodAuthLTI13 master
    => PluginName
    -- ^ Name of the auth provider
    -> Text
    -- ^ Method
    -> [Text]
    -- ^ Path parts
    -> AuthHandler master TypedContent
dispatchAuthRequest :: PluginName
-> PluginName -> [PluginName] -> AuthHandler master TypedContent
dispatchAuthRequest PluginName
name PluginName
"GET" [PluginName
"initiate"] =
    Method -> m RequestParams
forall (m :: * -> *). MonadHandler m => Method -> m RequestParams
unifyParams Method
GET  m RequestParams
-> (RequestParams -> m TypedContent) -> m TypedContent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PluginName -> RequestParams -> AuthHandler master TypedContent
forall master.
YesodAuthLTI13 master =>
PluginName -> RequestParams -> AuthHandler master TypedContent
dispatchInitiate PluginName
name
dispatchAuthRequest PluginName
name PluginName
"POST" [PluginName
"initiate"] =
    Method -> m RequestParams
forall (m :: * -> *). MonadHandler m => Method -> m RequestParams
unifyParams Method
POST m RequestParams
-> (RequestParams -> m TypedContent) -> m TypedContent
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PluginName -> RequestParams -> AuthHandler master TypedContent
forall master.
YesodAuthLTI13 master =>
PluginName -> RequestParams -> AuthHandler master TypedContent
dispatchInitiate PluginName
name
dispatchAuthRequest PluginName
name PluginName
"POST" [PluginName
"authenticate"] =
    PluginName -> AuthHandler master TypedContent
forall m.
YesodAuthLTI13 m =>
PluginName -> AuthHandler m TypedContent
dispatchAuthenticate PluginName
name
dispatchAuthRequest PluginName
name PluginName
"GET" [PluginName
"jwks"] =
    PluginName -> AuthHandler master TypedContent
forall m.
YesodAuthLTI13 m =>
PluginName -> AuthHandler m TypedContent
dispatchJwks PluginName
name
dispatchAuthRequest PluginName
_ PluginName
_ [PluginName]
_ = m TypedContent
forall (m :: * -> *) a. MonadHandler m => m a
notFound

-- | HTTP method for @unifyParams@
data Method = GET
            | POST

-- | Turns parameters from their respective request type to a simple map.
unifyParams
    :: MonadHandler m
    => Method
    -> m RequestParams
unifyParams :: Method -> m RequestParams
unifyParams Method
GET = do
    [(PluginName, PluginName)] -> RequestParams
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PluginName, PluginName)] -> RequestParams)
-> (YesodRequest -> [(PluginName, PluginName)])
-> YesodRequest
-> RequestParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. YesodRequest -> [(PluginName, PluginName)]
reqGetParams (YesodRequest -> RequestParams)
-> m YesodRequest -> m RequestParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
unifyParams Method
POST = do
    ([(PluginName, PluginName)]
params, [(PluginName, FileInfo)]
_) <- m ([(PluginName, PluginName)], [(PluginName, FileInfo)])
forall (m :: * -> *).
MonadHandler m =>
m ([(PluginName, PluginName)], [(PluginName, FileInfo)])
runRequestBody
    RequestParams -> m RequestParams
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestParams -> m RequestParams)
-> RequestParams -> m RequestParams
forall a b. (a -> b) -> a -> b
$ [(PluginName, PluginName)] -> RequestParams
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PluginName, PluginName)]
params

-- | Makes a name for a saved session piece
prefixSession :: Text -> Text -> Text
prefixSession :: PluginName -> PluginName -> PluginName
prefixSession PluginName
name PluginName
datum =
    PluginName
"_lti13_" PluginName -> PluginName -> PluginName
forall a. Semigroup a => a -> a -> a
<> PluginName
name PluginName -> PluginName -> PluginName
forall a. Semigroup a => a -> a -> a
<> PluginName
"_" PluginName -> PluginName -> PluginName
forall a. Semigroup a => a -> a -> a
<> PluginName
datum

-- | Makes the name for the @clientId@ cookie
myCid :: Text -> Text
myCid :: PluginName -> PluginName
myCid = (PluginName -> PluginName -> PluginName)
-> PluginName -> PluginName -> PluginName
forall a b c. (a -> b -> c) -> b -> a -> c
flip PluginName -> PluginName -> PluginName
prefixSession PluginName
"clientId"

-- | Makes the name for the @iss@ cookie
myIss :: Text -> Text
myIss :: PluginName -> PluginName
myIss = (PluginName -> PluginName -> PluginName)
-> PluginName -> PluginName -> PluginName
forall a b c. (a -> b -> c) -> b -> a -> c
flip PluginName -> PluginName -> PluginName
prefixSession PluginName
"iss"

-- | Makes the name for the @state@ cookie
myState :: Text -> Text
myState :: PluginName -> PluginName
myState = (PluginName -> PluginName -> PluginName)
-> PluginName -> PluginName -> PluginName
forall a b c. (a -> b -> c) -> b -> a -> c
flip PluginName -> PluginName -> PluginName
prefixSession PluginName
"state"

-- | Makes the name for the @nonce@ cookie
myNonce :: Text -> Text
myNonce :: PluginName -> PluginName
myNonce = (PluginName -> PluginName -> PluginName)
-> PluginName -> PluginName -> PluginName
forall a b c. (a -> b -> c) -> b -> a -> c
flip PluginName -> PluginName -> PluginName
prefixSession PluginName
"nonce"

mkSessionStore :: MonadHandler m => Text -> SessionStore m
mkSessionStore :: PluginName -> SessionStore m
mkSessionStore PluginName
name =
    SessionStore :: forall (m :: * -> *).
m ByteString
-> (ByteString -> ByteString -> m ())
-> m (Maybe ByteString, Maybe ByteString)
-> m ()
-> SessionStore m
SessionStore
        { sessionStoreGenerate :: m ByteString
sessionStoreGenerate = m ByteString
gen
        , sessionStoreSave :: ByteString -> ByteString -> m ()
sessionStoreSave     = ByteString -> ByteString -> m ()
sessionSave
        , sessionStoreGet :: m (Maybe ByteString, Maybe ByteString)
sessionStoreGet      = m (Maybe ByteString, Maybe ByteString)
sessionGet
        , sessionStoreDelete :: m ()
sessionStoreDelete   = m ()
sessionDelete
        }
    where
        -- we make only url safe stuff to not cause chaos elsewhere
        gen :: m ByteString
gen = IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ByteString -> ByteString
B64.encode (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO ByteString
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
33)
        sname :: PluginName
sname = PluginName -> PluginName
myState PluginName
name
        nname :: PluginName
nname = PluginName -> PluginName
myNonce PluginName
name
        sessionSave :: ByteString -> ByteString -> m ()
sessionSave ByteString
state ByteString
nonce = do
            PluginName -> ByteString -> m ()
forall (m :: * -> *).
MonadHandler m =>
PluginName -> ByteString -> m ()
setSessionBS PluginName
sname ByteString
state
            PluginName -> ByteString -> m ()
forall (m :: * -> *).
MonadHandler m =>
PluginName -> ByteString -> m ()
setSessionBS PluginName
nname ByteString
nonce
            () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        sessionGet :: m (Maybe ByteString, Maybe ByteString)
sessionGet = do
            Maybe ByteString
state <- PluginName -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
PluginName -> m (Maybe ByteString)
lookupSessionBS PluginName
sname
            Maybe ByteString
nonce <- PluginName -> m (Maybe ByteString)
forall (m :: * -> *).
MonadHandler m =>
PluginName -> m (Maybe ByteString)
lookupSessionBS PluginName
nname
            (Maybe ByteString, Maybe ByteString)
-> m (Maybe ByteString, Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString
state, Maybe ByteString
nonce)
        sessionDelete :: m ()
sessionDelete = do
            PluginName -> m ()
forall (m :: * -> *). MonadHandler m => PluginName -> m ()
deleteSession PluginName
sname
            PluginName -> m ()
forall (m :: * -> *). MonadHandler m => PluginName -> m ()
deleteSession PluginName
nname

type PluginName = Text

makeCfg
    :: MonadHandler m
    => PluginName
    -> ((Issuer, Maybe ClientId) -> m PlatformInfo)
    -> (Nonce -> m Bool)
    -> Text
    -> AuthFlowConfig m
makeCfg :: PluginName
-> ((PluginName, Maybe PluginName) -> m PlatformInfo)
-> (ByteString -> m Bool)
-> PluginName
-> AuthFlowConfig m
makeCfg PluginName
name (PluginName, Maybe PluginName) -> m PlatformInfo
pinfo ByteString -> m Bool
seenNonce PluginName
callback =
    AuthFlowConfig :: forall (m :: * -> *).
((PluginName, Maybe PluginName) -> m PlatformInfo)
-> (ByteString -> m Bool)
-> PluginName
-> SessionStore m
-> AuthFlowConfig m
AuthFlowConfig
        { getPlatformInfo :: (PluginName, Maybe PluginName) -> m PlatformInfo
getPlatformInfo = (PluginName, Maybe PluginName) -> m PlatformInfo
pinfo
        , haveSeenNonce :: ByteString -> m Bool
haveSeenNonce = ByteString -> m Bool
seenNonce
        , myRedirectUri :: PluginName
myRedirectUri = PluginName
callback
        , sessionStore :: SessionStore m
sessionStore = PluginName -> SessionStore m
forall (m :: * -> *).
MonadHandler m =>
PluginName -> SessionStore m
mkSessionStore PluginName
name
        }

createNewJwk :: IO Jwk
createNewJwk :: IO Jwk
createNewJwk = do
    KeyId
kid <- UTCTime -> KeyId
UTCKeyId (UTCTime -> KeyId) -> IO UTCTime -> IO KeyId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
    let use :: KeyUse
use = KeyUse
Sig
        alg :: Alg
alg = JwsAlg -> Alg
Signed JwsAlg
RS256
    (Jwk
_, Jwk
priv) <- Int -> KeyId -> KeyUse -> Maybe Alg -> IO (Jwk, Jwk)
forall (m :: * -> *).
MonadRandom m =>
Int -> KeyId -> KeyUse -> Maybe Alg -> m (Jwk, Jwk)
generateRsaKeyPair Int
256 KeyId
kid KeyUse
use (Maybe Alg -> IO (Jwk, Jwk)) -> Maybe Alg -> IO (Jwk, Jwk)
forall a b. (a -> b) -> a -> b
$ Alg -> Maybe Alg
forall a. a -> Maybe a
Just Alg
alg
    Jwk -> IO Jwk
forall (m :: * -> *) a. Monad m => a -> m a
return Jwk
priv

dispatchJwks
    :: YesodAuthLTI13 master
    => PluginName
    -> AuthHandler master TypedContent
dispatchJwks :: PluginName -> AuthHandler master TypedContent
dispatchJwks PluginName
name = do
    ByteString
jwks <- IO ByteString -> AuthHandler master ByteString
forall site.
YesodAuthLTI13 site =>
IO ByteString -> AuthHandler site ByteString
retrieveOrInsertJwks IO ByteString
makeJwks
    JwkSet [Jwk]
privs <- m JwkSet -> (JwkSet -> m JwkSet) -> Maybe JwkSet -> m JwkSet
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO JwkSet -> m JwkSet
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JwkSet -> m JwkSet) -> IO JwkSet -> m JwkSet
forall a b. (a -> b) -> a -> b
$ YesodAuthLTI13Exception -> IO JwkSet
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (YesodAuthLTI13Exception -> IO JwkSet)
-> YesodAuthLTI13Exception -> IO JwkSet
forall a b. (a -> b) -> a -> b
$ PluginName -> PluginName -> YesodAuthLTI13Exception
CorruptJwks PluginName
name PluginName
"json decode failed")
                    JwkSet -> m JwkSet
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe JwkSet
forall a. FromJSON a => ByteString -> Maybe a
A.decodeStrict ByteString
jwks)
    let pubs :: JwkSet
pubs = [Jwk] -> JwkSet
JwkSet ([Jwk] -> JwkSet) -> [Jwk] -> JwkSet
forall a b. (a -> b) -> a -> b
$ (Jwk -> Jwk) -> [Jwk] -> [Jwk]
forall a b. (a -> b) -> [a] -> [b]
map Jwk -> Jwk
rsaPrivToPub [Jwk]
privs
    TypedContent -> m TypedContent
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedContent -> m TypedContent) -> TypedContent -> m TypedContent
forall a b. (a -> b) -> a -> b
$ Value -> TypedContent
forall a. ToTypedContent a => a -> TypedContent
toTypedContent (Value -> TypedContent) -> Value -> TypedContent
forall a b. (a -> b) -> a -> b
$ JwkSet -> Value
forall a. ToJSON a => a -> Value
A.toJSON JwkSet
pubs
    where makeJwks :: IO ByteString
makeJwks = ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (JwkSet -> ByteString) -> JwkSet -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JwkSet -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (JwkSet -> ByteString) -> IO JwkSet -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO JwkSet
makeJwkSet
          makeJwkSet :: IO JwkSet
makeJwkSet = (Jwk -> JwkSet) -> IO Jwk -> IO JwkSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Jwk
jwk -> JwkSet :: [Jwk] -> JwkSet
JwkSet {keys :: [Jwk]
keys = [Jwk
jwk]}) IO Jwk
createNewJwk

rsaPrivToPub :: Jwk -> Jwk
rsaPrivToPub :: Jwk -> Jwk
rsaPrivToPub (RsaPrivateJwk PrivateKey
privKey Maybe KeyId
mId Maybe KeyUse
mUse Maybe Alg
mAlg) =
    PublicKey -> Maybe KeyId -> Maybe KeyUse -> Maybe Alg -> Jwk
RsaPublicJwk (PrivateKey -> PublicKey
RSA.private_pub PrivateKey
privKey) Maybe KeyId
mId Maybe KeyUse
mUse Maybe Alg
mAlg
rsaPrivToPub Jwk
_ = String -> Jwk
forall a. HasCallStack => String -> a
error String
"rsaPrivToPub called on a Jwk that's not a RsaPrivateJwk"

dispatchInitiate
    :: YesodAuthLTI13 master
    => PluginName
    -- ^ Name of the provider
    -> RequestParams
    -- ^ Request parameters
    -> AuthHandler master TypedContent
dispatchInitiate :: PluginName -> RequestParams -> AuthHandler master TypedContent
dispatchInitiate PluginName
name RequestParams
params = do
    -- TODO: this should be refactored into a function but I don't know how
    let url :: Route Auth
url = PluginName -> [PluginName] -> Route Auth
PluginR PluginName
name [PluginName
"authenticate"]
    Route Auth -> Route master
tm <- m (Route Auth -> Route master)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
    Route master -> PluginName
render <- m (Route master -> PluginName)
forall (m :: * -> *).
MonadHandler m =>
m (Route (HandlerSite m) -> PluginName)
getUrlRender
    let authUrl :: PluginName
authUrl = Route master -> PluginName
render (Route master -> PluginName) -> Route master -> PluginName
forall a b. (a -> b) -> a -> b
$ Route Auth -> Route master
tm Route Auth
url

    let cfg :: AuthFlowConfig m
cfg = PluginName
-> ((PluginName, Maybe PluginName) -> m PlatformInfo)
-> (ByteString -> m Bool)
-> PluginName
-> AuthFlowConfig m
forall (m :: * -> *).
MonadHandler m =>
PluginName
-> ((PluginName, Maybe PluginName) -> m PlatformInfo)
-> (ByteString -> m Bool)
-> PluginName
-> AuthFlowConfig m
makeCfg PluginName
name (PluginName, Maybe PluginName) -> m PlatformInfo
forall site.
YesodAuthLTI13 site =>
(PluginName, Maybe PluginName) -> AuthHandler site PlatformInfo
retrievePlatformInfo ByteString -> m Bool
forall site.
YesodAuthLTI13 site =>
ByteString -> AuthHandler site Bool
checkSeenNonce PluginName
authUrl
    (PluginName
iss, PluginName
cid, PluginName
redir) <- AuthFlowConfig m
-> RequestParams -> m (PluginName, PluginName, PluginName)
forall (m :: * -> *).
MonadIO m =>
AuthFlowConfig m
-> RequestParams -> m (PluginName, PluginName, PluginName)
initiate AuthFlowConfig m
cfg RequestParams
params
    PluginName -> PluginName -> m ()
forall (m :: * -> *).
MonadHandler m =>
PluginName -> PluginName -> m ()
setSession (PluginName -> PluginName
myIss PluginName
name) PluginName
iss
    PluginName -> PluginName -> m ()
forall (m :: * -> *).
MonadHandler m =>
PluginName -> PluginName -> m ()
setSession (PluginName -> PluginName
myCid PluginName
name) PluginName
cid
    PluginName -> m TypedContent
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect PluginName
redir

type State = Text

checkCSRFToken :: MonadHandler m => State -> Maybe State -> m ()
checkCSRFToken :: PluginName -> Maybe PluginName -> m ()
checkCSRFToken PluginName
state Maybe PluginName
state' =
    if Maybe PluginName
state' Maybe PluginName -> Maybe PluginName -> Bool
forall a. Eq a => a -> a -> Bool
/= PluginName -> Maybe PluginName
forall a. a -> Maybe a
Just PluginName
state then do
        PluginName -> m ()
forall (m :: * -> *) a. MonadHandler m => PluginName -> m a
permissionDenied PluginName
"Bad CSRF token"
    else
        () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Makes a user ID that is not an email address (and should thus be safe from
--   [possible security problem] collisions with email based auth systems)
makeUserId :: Issuer -> Text -> Text
makeUserId :: PluginName -> PluginName -> PluginName
makeUserId PluginName
iss PluginName
name = PluginName
name PluginName -> PluginName -> PluginName
forall a. Semigroup a => a -> a -> a
<> PluginName
"@@" PluginName -> PluginName -> PluginName
forall a. Semigroup a => a -> a -> a
<> PluginName
iss

dispatchAuthenticate :: YesodAuthLTI13 m => PluginName -> AuthHandler m TypedContent
dispatchAuthenticate :: PluginName -> AuthHandler m TypedContent
dispatchAuthenticate PluginName
name = do
    Manager
mgr <- m Manager
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
m Manager
authHttpManager
    -- first, find who the issuer was
    -- this is safe, least of which because Yesod has encrypted session cookies
    Maybe PluginName
maybeIss <- PluginName -> m (Maybe PluginName)
forall (m :: * -> *).
MonadHandler m =>
PluginName -> m (Maybe PluginName)
lookupSession (PluginName -> m (Maybe PluginName))
-> PluginName -> m (Maybe PluginName)
forall a b. (a -> b) -> a -> b
$ PluginName -> PluginName
myIss PluginName
name
    PluginName
iss <- m PluginName
-> (PluginName -> m PluginName) -> Maybe PluginName -> m PluginName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO PluginName -> m PluginName
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PluginName -> m PluginName)
-> (YesodAuthLTI13Exception -> IO PluginName)
-> YesodAuthLTI13Exception
-> m PluginName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. YesodAuthLTI13Exception -> IO PluginName
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (YesodAuthLTI13Exception -> m PluginName)
-> YesodAuthLTI13Exception -> m PluginName
forall a b. (a -> b) -> a -> b
$ PluginName -> PluginName -> YesodAuthLTI13Exception
BadRequest PluginName
name PluginName
"missing `iss` cookie")
                 PluginName -> m PluginName
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                 Maybe PluginName
maybeIss
    Maybe PluginName
cid <- PluginName -> m (Maybe PluginName)
forall (m :: * -> *).
MonadHandler m =>
PluginName -> m (Maybe PluginName)
lookupSession (PluginName -> m (Maybe PluginName))
-> PluginName -> m (Maybe PluginName)
forall a b. (a -> b) -> a -> b
$ PluginName -> PluginName
myCid PluginName
name
    PluginName -> m ()
forall (m :: * -> *). MonadHandler m => PluginName -> m ()
deleteSession (PluginName -> m ()) -> PluginName -> m ()
forall a b. (a -> b) -> a -> b
$ PluginName -> PluginName
myIss PluginName
name
    PluginName -> m ()
forall (m :: * -> *). MonadHandler m => PluginName -> m ()
deleteSession (PluginName -> m ()) -> PluginName -> m ()
forall a b. (a -> b) -> a -> b
$ PluginName -> PluginName
myCid PluginName
name

    Maybe PluginName
state' <- PluginName -> m (Maybe PluginName)
forall (m :: * -> *).
MonadHandler m =>
PluginName -> m (Maybe PluginName)
lookupSession (PluginName -> m (Maybe PluginName))
-> PluginName -> m (Maybe PluginName)
forall a b. (a -> b) -> a -> b
$ PluginName -> PluginName
myState PluginName
name

    PlatformInfo
pinfo <- (PluginName, Maybe PluginName) -> AuthHandler m PlatformInfo
forall site.
YesodAuthLTI13 site =>
(PluginName, Maybe PluginName) -> AuthHandler site PlatformInfo
retrievePlatformInfo (PluginName
iss, Maybe PluginName
cid)

    -- we don't care about having a callback URL here since we *are* the callback
    let cfg :: AuthFlowConfig m
cfg = PluginName
-> ((PluginName, Maybe PluginName) -> m PlatformInfo)
-> (ByteString -> m Bool)
-> PluginName
-> AuthFlowConfig m
forall (m :: * -> *).
MonadHandler m =>
PluginName
-> ((PluginName, Maybe PluginName) -> m PlatformInfo)
-> (ByteString -> m Bool)
-> PluginName
-> AuthFlowConfig m
makeCfg PluginName
name (PluginName, Maybe PluginName) -> m PlatformInfo
forall site.
YesodAuthLTI13 site =>
(PluginName, Maybe PluginName) -> AuthHandler site PlatformInfo
retrievePlatformInfo ByteString -> m Bool
forall site.
YesodAuthLTI13 site =>
ByteString -> AuthHandler site Bool
checkSeenNonce PluginName
forall a. HasCallStack => a
undefined
    ([(PluginName, PluginName)]
params', [(PluginName, FileInfo)]
_) <- m ([(PluginName, PluginName)], [(PluginName, FileInfo)])
forall (m :: * -> *).
MonadHandler m =>
m ([(PluginName, PluginName)], [(PluginName, FileInfo)])
runRequestBody
    let params :: RequestParams
params = [(PluginName, PluginName)] -> RequestParams
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PluginName, PluginName)]
params'
    (PluginName
state, IdTokenClaims LtiTokenClaims
tok) <- Manager
-> AuthFlowConfig m
-> RequestParams
-> PlatformInfo
-> m (PluginName, IdTokenClaims LtiTokenClaims)
forall (m :: * -> *).
MonadIO m =>
Manager
-> AuthFlowConfig m
-> RequestParams
-> PlatformInfo
-> m (PluginName, IdTokenClaims LtiTokenClaims)
handleAuthResponse Manager
mgr AuthFlowConfig m
cfg RequestParams
params PlatformInfo
pinfo

    -- check CSRF token against the state in the request
    PluginName -> Maybe PluginName -> m ()
forall (m :: * -> *).
MonadHandler m =>
PluginName -> Maybe PluginName -> m ()
checkCSRFToken PluginName
state Maybe PluginName
state'

    let LtiTokenClaims UncheckedLtiTokenClaims
ltiClaims = IdTokenClaims LtiTokenClaims -> LtiTokenClaims
forall a. IdTokenClaims a -> a
otherClaims IdTokenClaims LtiTokenClaims
tok
        ltiClaimsJson :: PluginName
ltiClaimsJson = ByteString -> PluginName
E.decodeUtf8 (ByteString -> PluginName) -> ByteString -> PluginName
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ UncheckedLtiTokenClaims -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode UncheckedLtiTokenClaims
ltiClaims

    let IdTokenClaims { PluginName
sub :: forall a. IdTokenClaims a -> PluginName
sub :: PluginName
sub } = IdTokenClaims LtiTokenClaims
tok
        myCreds :: Creds m
myCreds = Creds :: forall master.
PluginName
-> PluginName -> [(PluginName, PluginName)] -> Creds master
Creds {
              credsPlugin :: PluginName
credsPlugin = PluginName
name
            , credsIdent :: PluginName
credsIdent = PluginName -> PluginName -> PluginName
makeUserId PluginName
iss PluginName
sub
            , credsExtra :: [(PluginName, PluginName)]
credsExtra = [(PluginName
"ltiIss", PluginName
iss), (PluginName
"ltiSub", PluginName
sub), (PluginName
"ltiToken", PluginName
ltiClaimsJson)]
        }

    Creds (HandlerSite m) -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect Creds m
Creds (HandlerSite m)
myCreds

type CredsExtra = [(Text, Text)]

-- | Gets the @iss@ for the given @credsExtra@.
getLtiIss :: CredsExtra -> Maybe Issuer
getLtiIss :: [(PluginName, PluginName)] -> Maybe PluginName
getLtiIss = PluginName -> [(PluginName, PluginName)] -> Maybe PluginName
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup PluginName
"ltiIss"

-- | Gets the @sub@ for the given @credsExtra@
getLtiSub :: CredsExtra -> Maybe Issuer
getLtiSub :: [(PluginName, PluginName)] -> Maybe PluginName
getLtiSub = PluginName -> [(PluginName, PluginName)] -> Maybe PluginName
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup PluginName
"ltiSub"

-- | Gets and decodes the extra token claims with the full LTI launch
--   information from a @credsExtra@
getLtiToken :: CredsExtra -> Maybe LtiTokenClaims
getLtiToken :: [(PluginName, PluginName)] -> Maybe LtiTokenClaims
getLtiToken [(PluginName, PluginName)]
crExtra =
    -- note: the claims have been checked before they got into the credsExtra.
    UncheckedLtiTokenClaims -> LtiTokenClaims
LtiTokenClaims (UncheckedLtiTokenClaims -> LtiTokenClaims)
-> Maybe UncheckedLtiTokenClaims -> Maybe LtiTokenClaims
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PluginName -> [(PluginName, PluginName)] -> Maybe PluginName
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup PluginName
"ltiToken" [(PluginName, PluginName)]
crExtra Maybe PluginName
-> (PluginName -> Maybe UncheckedLtiTokenClaims)
-> Maybe UncheckedLtiTokenClaims
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PluginName -> Maybe UncheckedLtiTokenClaims
intoClaims)
    where
        intoClaims :: Text -> Maybe UncheckedLtiTokenClaims
        intoClaims :: PluginName -> Maybe UncheckedLtiTokenClaims
intoClaims = ByteString -> Maybe UncheckedLtiTokenClaims
forall a. FromJSON a => ByteString -> Maybe a
A.decode (ByteString -> Maybe UncheckedLtiTokenClaims)
-> (PluginName -> ByteString)
-> PluginName
-> Maybe UncheckedLtiTokenClaims
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> (PluginName -> Builder) -> PluginName -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PluginName -> Builder
E.encodeUtf8Builder

-- | Callbacks into your site for LTI 1.3
class (YesodAuth site)
    => YesodAuthLTI13 site where
        -- | Check if a nonce has been seen in the last validity period. It is
        --  expected that nonces given to this function are stored somewhere,
        --  returning False, then when seen again, True should be returned.
        --  See the <http://www.imsglobal.org/spec/security/v1p0/#authentication-response-validation
        --  relevant section of the IMS security specification> for details.
        checkSeenNonce :: Nonce -> AuthHandler site Bool

        -- | Get the configuration for the given platform.
        --
        --   It is possible that the relation between Issuer and ClientId is 1
        --   to n rather than 1 to 1, for instance in the case of cloud hosted
        --   Canvas. You *must* therefore key your 'PlatformInfo' retrieval
        --   with the pair of both and throw an error if there are multiple
        --   'ClientId' for the given 'Issuer' and the 'ClientId' is 'Nothing'.
        retrievePlatformInfo :: (Issuer, Maybe ClientId) -> AuthHandler site PlatformInfo

        -- | Retrieve JWKs list from the database or other store. If not
        --   present, please create a new one by evaluating the given 'IO', store
        --   it, and return it.
        retrieveOrInsertJwks
            :: IO BS.ByteString
            -- ^ an 'IO' which, if evaluated, will make a new 'Jwk' set
            -> AuthHandler site BS.ByteString

-- | Auth plugin. Add this to @appAuthPlugins@ to enable this plugin.
authLTI13 :: YesodAuthLTI13 m => AuthPlugin m
authLTI13 :: AuthPlugin m
authLTI13 = ((Route Auth -> Route m) -> WidgetFor m ()) -> AuthPlugin m
forall m.
YesodAuthLTI13 m =>
((Route Auth -> Route m) -> WidgetFor m ()) -> AuthPlugin m
authLTI13WithWidget (Route Auth -> Route m) -> WidgetFor m ()
forall p site (m :: * -> *). p -> WidgetT site m ()
login
    where
        login :: p -> WidgetT site m ()
login p
_ = [whamlet|<p>Go to your Learning Management System to log in via LTI 1.3|]

-- | Auth plugin. The same as 'authLTI13' but you can provide your own template
--   for the login hint page.
authLTI13WithWidget :: YesodAuthLTI13 m => ((Route Auth -> Route m) -> WidgetFor m ()) -> AuthPlugin m
authLTI13WithWidget :: ((Route Auth -> Route m) -> WidgetFor m ()) -> AuthPlugin m
authLTI13WithWidget (Route Auth -> Route m) -> WidgetFor m ()
login =
    PluginName
-> (PluginName -> [PluginName] -> AuthHandler m TypedContent)
-> ((Route Auth -> Route m) -> WidgetFor m ())
-> AuthPlugin m
forall master.
PluginName
-> (PluginName -> [PluginName] -> AuthHandler master TypedContent)
-> ((Route Auth -> Route master) -> WidgetFor master ())
-> AuthPlugin master
AuthPlugin PluginName
name (PluginName
-> PluginName -> [PluginName] -> AuthHandler m TypedContent
forall master.
YesodAuthLTI13 master =>
PluginName
-> PluginName -> [PluginName] -> AuthHandler master TypedContent
dispatchAuthRequest PluginName
name) (Route Auth -> Route m) -> WidgetFor m ()
login
    where
        name :: PluginName
name = PluginName
"lti13"