{-# LANGUAGE QuasiQuotes       #-}

-- | 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.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           Prelude
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, sendResponseStatus)
import           Yesod.Core.Types           (TypedContent)
import           Yesod.Core.Widget
import Network.HTTP.Types (unauthorized401, badRequest400)
import qualified Data.Text as T
import UnliftIO.Exception (Exception, throwIO, catch)
import Control.Monad (guard)

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 stock (Int -> YesodAuthLTI13Exception -> ShowS
[YesodAuthLTI13Exception] -> ShowS
YesodAuthLTI13Exception -> String
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 :: forall master.
YesodAuthLTI13 master =>
Text -> Text -> [Text] -> AuthHandler master TypedContent
dispatchAuthRequest Text
name Text
"GET" [Text
"initiate"] =
    forall (m :: * -> *). MonadHandler m => Method -> m RequestParams
unifyParams Method
GET  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall master.
YesodAuthLTI13 master =>
Text -> RequestParams -> AuthHandler master TypedContent
dispatchInitiate Text
name
dispatchAuthRequest Text
name Text
"POST" [Text
"initiate"] =
    forall (m :: * -> *). MonadHandler m => Method -> m RequestParams
unifyParams Method
POST forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall master.
YesodAuthLTI13 master =>
Text -> RequestParams -> AuthHandler master TypedContent
dispatchInitiate Text
name
dispatchAuthRequest Text
name Text
"POST" [Text
"authenticate"] =
    forall m. YesodAuthLTI13 m => Text -> AuthHandler m TypedContent
dispatchAuthenticate Text
name
dispatchAuthRequest Text
name Text
"GET" [Text
"jwks"] =
    forall m. YesodAuthLTI13 m => Text -> AuthHandler m TypedContent
dispatchJwks Text
name
dispatchAuthRequest Text
_ Text
_ [Text]
_ = 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 :: forall (m :: * -> *). MonadHandler m => Method -> m RequestParams
unifyParams Method
GET = do
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. YesodRequest -> [(Text, Text)]
reqGetParams forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
unifyParams Method
POST = do
    ([(Text, Text)]
params, [(Text, FileInfo)]
_) <- forall (m :: * -> *).
MonadHandler m =>
m ([(Text, Text)], [(Text, FileInfo)])
runRequestBody
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Text)]
params

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

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

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

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

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

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

type PluginName = Text

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

createNewJwk :: IO Jwk
createNewJwk :: IO Jwk
createNewJwk = do
    KeyId
kid <- UTCTime -> KeyId
UTCKeyId 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) <- forall (m :: * -> *).
MonadRandom m =>
Int -> KeyId -> KeyUse -> Maybe Alg -> m (Jwk, Jwk)
generateRsaKeyPair Int
256 KeyId
kid KeyUse
use forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Alg
alg
    forall (m :: * -> *) a. Monad m => a -> m a
return Jwk
priv

dispatchJwks
    :: YesodAuthLTI13 master
    => PluginName
    -> AuthHandler master TypedContent
dispatchJwks :: forall m. YesodAuthLTI13 m => Text -> AuthHandler m TypedContent
dispatchJwks Text
name = do
    ByteString
jwks <- forall site.
YesodAuthLTI13 site =>
IO ByteString -> AuthHandler site ByteString
retrieveOrInsertJwks IO ByteString
makeJwks
    JwkSet [Jwk]
privs <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> Text -> YesodAuthLTI13Exception
CorruptJwks Text
name Text
"json decode failed")
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. FromJSON a => ByteString -> Maybe a
A.decodeStrict ByteString
jwks)
    let pubs :: JwkSet
pubs = [Jwk] -> JwkSet
JwkSet forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Jwk -> Jwk
rsaPrivToPub [Jwk]
privs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. ToTypedContent a => a -> TypedContent
toTypedContent forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
A.toJSON JwkSet
pubs
    where makeJwks :: IO ByteString
makeJwks = ByteString -> ByteString
LBS.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
A.encode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO JwkSet
makeJwkSet
          makeJwkSet :: IO JwkSet
makeJwkSet = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Jwk
jwk -> 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
_ = forall a. HasCallStack => String -> a
error String
"rsaPrivToPub called on a Jwk that's not a RsaPrivateJwk"

lti13ExceptionToYesod :: (MonadHandler m) => LTI13Exception -> m a
lti13ExceptionToYesod :: forall (m :: * -> *) a. MonadHandler m => LTI13Exception -> m a
lti13ExceptionToYesod e :: LTI13Exception
e@(InvalidHandshake Text
_) = forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
Status -> c -> m a
sendResponseStatus Status
badRequest400 (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ LTI13Exception
e)
lti13ExceptionToYesod e :: LTI13Exception
e@(InvalidLtiToken Text
_) = forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
Status -> c -> m a
sendResponseStatus Status
unauthorized401 (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ LTI13Exception
e)
-- These ones should be handled as internal server errors so they get into a
-- log
lti13ExceptionToYesod e :: LTI13Exception
e@(DiscoveryException Text
_) = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO LTI13Exception
e
lti13ExceptionToYesod e :: LTI13Exception
e@(GotHttpException HttpException
_) = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO LTI13Exception
e

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

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

type State = Text

checkCSRFToken :: MonadHandler m => State -> Maybe State -> m ()
checkCSRFToken :: forall (m :: * -> *). MonadHandler m => Text -> Maybe Text -> m ()
checkCSRFToken Text
state Maybe Text
state' =
    if Maybe Text
state' forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Text
state then do
        forall (m :: * -> *) a. MonadHandler m => Text -> m a
permissionDenied Text
"Bad CSRF token"
    else
        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 :: Text -> Text -> Text
makeUserId Text
iss Text
name = Text
name forall a. Semigroup a => a -> a -> a
<> Text
"@@" forall a. Semigroup a => a -> a -> a
<> Text
iss

dispatchAuthenticate :: YesodAuthLTI13 m => PluginName -> AuthHandler m TypedContent
dispatchAuthenticate :: forall m. YesodAuthLTI13 m => Text -> AuthHandler m TypedContent
dispatchAuthenticate Text
name = do
    Manager
mgr <- 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 Text
maybeIss <- forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession forall a b. (a -> b) -> a -> b
$ Text -> Text
myIss Text
name
    Text
iss <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> Text -> YesodAuthLTI13Exception
BadRequest Text
name Text
"missing `iss` cookie")
                 forall (f :: * -> *) a. Applicative f => a -> f a
pure
                 Maybe Text
maybeIss
    Maybe Text
cid <- forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession forall a b. (a -> b) -> a -> b
$ Text -> Text
myCid Text
name
    forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession forall a b. (a -> b) -> a -> b
$ Text -> Text
myIss Text
name
    forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession forall a b. (a -> b) -> a -> b
$ Text -> Text
myCid Text
name

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

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

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

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

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

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

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

type CredsExtra = [(Text, Text)]

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

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

-- | Gets and decodes the extra token claims with the full LTI launch
--   information from a @credsExtra@
getLtiToken :: CredsExtra -> Maybe LtiTokenClaims
getLtiToken :: [(Text, Text)] -> Maybe LtiTokenClaims
getLtiToken [(Text, Text)]
crExtra =
    -- note: the claims have been checked before they got into the credsExtra.
    UncheckedLtiTokenClaims -> LtiTokenClaims
LtiTokenClaims forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"ltiToken" [(Text, Text)]
crExtra forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe UncheckedLtiTokenClaims
intoClaims)
    where
        intoClaims :: Text -> Maybe UncheckedLtiTokenClaims
        intoClaims :: Text -> Maybe UncheckedLtiTokenClaims
intoClaims = forall a. FromJSON a => ByteString -> Maybe a
A.decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> 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 :: forall m. YesodAuthLTI13 m => AuthPlugin m
authLTI13 = forall m.
YesodAuthLTI13 m =>
((Route Auth -> Route m) -> WidgetFor m ()) -> AuthPlugin m
authLTI13WithWidget 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 :: forall m.
YesodAuthLTI13 m =>
((Route Auth -> Route m) -> WidgetFor m ()) -> AuthPlugin m
authLTI13WithWidget (Route Auth -> Route m) -> WidgetFor m ()
login =
    forall master.
Text
-> (Text -> [Text] -> AuthHandler master TypedContent)
-> ((Route Auth -> Route master) -> WidgetFor master ())
-> AuthPlugin master
AuthPlugin Text
name (forall master.
YesodAuthLTI13 master =>
Text -> Text -> [Text] -> AuthHandler master TypedContent
dispatchAuthRequest Text
name) (Route Auth -> Route m) -> WidgetFor m ()
login
    where
        name :: Text
name = Text
"lti13"