module Web.LTI13 (
Role(..)
, LisClaim(..)
, ContextClaim(..)
, UncheckedLtiTokenClaims(..)
, LtiTokenClaims(..)
, AnonymizedLtiTokenClaims(..)
, anonymizeLtiTokenForLogging
, validateLtiToken
, LTI13Exception(..)
, PlatformInfo(..)
, Issuer
, ClientId
, SessionStore(..)
, AuthFlowConfig(..)
, RequestParams
, initiate
, handleAuthResponse
) where
import Control.Exception.Safe (Exception, MonadCatch,
MonadThrow,
catch, throw, throwM)
import Control.Monad (when, (>=>))
import qualified Control.Monad.Fail as Fail
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson (FromJSON (parseJSON),
Object,
ToJSON (toEncoding, toJSON),
eitherDecode, object,
pairs, withObject,
withText, (.:), (.:?),
(.=))
import qualified Data.Aeson as A
import Data.Aeson.Types (Parser)
import qualified Data.Map.Strict as Map
import Data.String (IsString)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Jose.Jwa (JwsAlg (RS256))
import qualified Jose.Jwk as Jwk
import Network.HTTP.Client (HttpException, Manager,
httpLbs, parseRequest,
responseBody)
import qualified Network.HTTP.Types.URI as URI
import Prelude
import qualified Web.OIDC.Client.Discovery.Provider as P
import Web.OIDC.Client.IdTokenFlow (getValidIdTokenClaims)
import qualified Web.OIDC.Client.Settings as O
import Web.OIDC.Client.Tokens (IdTokenClaims, aud, iss,
nonce, otherClaims)
import Web.OIDC.Client.Types (Nonce, SessionStore (..))
parseFixed :: (FromJSON a, Eq a, Show a) => Object -> A.Key -> a -> Parser a
parseFixed :: forall a.
(FromJSON a, Eq a, Show a) =>
Object -> Key -> a -> Parser a
parseFixed Object
obj Key
field a
fixedVal =
Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
field forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
v ->
if a
v forall a. Eq a => a -> a -> Bool
== a
fixedVal then
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
else
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Key
field forall a. [a] -> [a] -> [a]
++ [Char]
" was not the required value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
fixedVal
data Role = Administrator
| ContentDeveloper
| Instructor
| Learner
| Mentor
| Other Text
deriving stock (Int -> Role -> ShowS
[Role] -> ShowS
Role -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Role] -> ShowS
$cshowList :: [Role] -> ShowS
show :: Role -> [Char]
$cshow :: Role -> [Char]
showsPrec :: Int -> Role -> ShowS
$cshowsPrec :: Int -> Role -> ShowS
Show, Role -> Role -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Role -> Role -> Bool
$c/= :: Role -> Role -> Bool
== :: Role -> Role -> Bool
$c== :: Role -> Role -> Bool
Eq)
roleFromString :: Text -> Role
roleFromString :: Text -> Role
roleFromString Text
"http://purl.imsglobal.org/vocab/lis/v2/membership#Administrator"
= Role
Administrator
roleFromString Text
"http://purl.imsglobal.org/vocab/lis/v2/membership#ContentDeveloper"
= Role
ContentDeveloper
roleFromString Text
"http://purl.imsglobal.org/vocab/lis/v2/membership#Instructor"
= Role
Instructor
roleFromString Text
"http://purl.imsglobal.org/vocab/lis/v2/membership#Learner"
= Role
Learner
roleFromString Text
"http://purl.imsglobal.org/vocab/lis/v2/membership#Mentor"
= Role
Mentor
roleFromString Text
s = Text -> Role
Other Text
s
roleToString :: Role -> Text
roleToString :: Role -> Text
roleToString Role
Administrator = Text
"http://purl.imsglobal.org/vocab/lis/v2/membership#Administrator"
roleToString Role
ContentDeveloper = Text
"http://purl.imsglobal.org/vocab/lis/v2/membership#ContentDeveloper"
roleToString Role
Instructor = Text
"http://purl.imsglobal.org/vocab/lis/v2/membership#Instructor"
roleToString Role
Learner = Text
"http://purl.imsglobal.org/vocab/lis/v2/membership#Learner"
roleToString Role
Mentor = Text
"http://purl.imsglobal.org/vocab/lis/v2/membership#Mentor"
roleToString (Other Text
s) = Text
s
instance FromJSON Role where
parseJSON :: Value -> Parser Role
parseJSON = forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"Role" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Role
roleFromString
instance ToJSON Role where
toJSON :: Role -> Value
toJSON = Text -> Value
A.String forall b c a. (b -> c) -> (a -> b) -> a -> c
. Role -> Text
roleToString
data LisClaim = LisClaim
{ LisClaim -> Maybe Text
personSourcedId :: Maybe Text
, LisClaim -> Maybe Text
outcomeServiceUrl :: Maybe Text
, LisClaim -> Maybe Text
courseOfferingSourcedId :: Maybe Text
, LisClaim -> Maybe Text
courseSectionSourcedId :: Maybe Text
, LisClaim -> Maybe Text
resultSourcedId :: Maybe Text
} deriving stock (Int -> LisClaim -> ShowS
[LisClaim] -> ShowS
LisClaim -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [LisClaim] -> ShowS
$cshowList :: [LisClaim] -> ShowS
show :: LisClaim -> [Char]
$cshow :: LisClaim -> [Char]
showsPrec :: Int -> LisClaim -> ShowS
$cshowsPrec :: Int -> LisClaim -> ShowS
Show, LisClaim -> LisClaim -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LisClaim -> LisClaim -> Bool
$c/= :: LisClaim -> LisClaim -> Bool
== :: LisClaim -> LisClaim -> Bool
$c== :: LisClaim -> LisClaim -> Bool
Eq)
instance FromJSON LisClaim where
parseJSON :: Value -> Parser LisClaim
parseJSON = forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"LisClaim" forall a b. (a -> b) -> a -> b
$ \Object
v ->
Maybe Text
-> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> LisClaim
LisClaim
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"person_sourcedid"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"outcome_service_url"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"course_offering_sourcedid"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"course_section_sourcedid"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"result_sourcedid"
instance ToJSON LisClaim where
toJSON :: LisClaim -> Value
toJSON LisClaim {Maybe Text
personSourcedId :: Maybe Text
personSourcedId :: LisClaim -> Maybe Text
personSourcedId, Maybe Text
outcomeServiceUrl :: Maybe Text
outcomeServiceUrl :: LisClaim -> Maybe Text
outcomeServiceUrl,
Maybe Text
courseOfferingSourcedId :: Maybe Text
courseOfferingSourcedId :: LisClaim -> Maybe Text
courseOfferingSourcedId, Maybe Text
courseSectionSourcedId :: Maybe Text
courseSectionSourcedId :: LisClaim -> Maybe Text
courseSectionSourcedId,
Maybe Text
resultSourcedId :: Maybe Text
resultSourcedId :: LisClaim -> Maybe Text
resultSourcedId} =
[Pair] -> Value
object [
Key
"person_sourcedid" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
personSourcedId
, Key
"outcome_service_url" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
outcomeServiceUrl
, Key
"course_offering_sourcedid" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
courseOfferingSourcedId
, Key
"course_section_sourcedid" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
courseSectionSourcedId
, Key
"result_sourcedid" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
resultSourcedId
]
toEncoding :: LisClaim -> Encoding
toEncoding LisClaim {Maybe Text
personSourcedId :: Maybe Text
personSourcedId :: LisClaim -> Maybe Text
personSourcedId, Maybe Text
outcomeServiceUrl :: Maybe Text
outcomeServiceUrl :: LisClaim -> Maybe Text
outcomeServiceUrl,
Maybe Text
courseOfferingSourcedId :: Maybe Text
courseOfferingSourcedId :: LisClaim -> Maybe Text
courseOfferingSourcedId, Maybe Text
courseSectionSourcedId :: Maybe Text
courseSectionSourcedId :: LisClaim -> Maybe Text
courseSectionSourcedId,
Maybe Text
resultSourcedId :: Maybe Text
resultSourcedId :: LisClaim -> Maybe Text
resultSourcedId} =
Series -> Encoding
pairs (
Key
"person_sourcedid" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
personSourcedId forall a. Semigroup a => a -> a -> a
<>
Key
"outcome_service_url" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
outcomeServiceUrl forall a. Semigroup a => a -> a -> a
<>
Key
"course_offering_sourcedid" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
courseOfferingSourcedId forall a. Semigroup a => a -> a -> a
<>
Key
"course_section_sourcedid" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
courseSectionSourcedId forall a. Semigroup a => a -> a -> a
<>
Key
"result_sourcedid" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
resultSourcedId
)
data ContextClaim = ContextClaim
{ ContextClaim -> Text
contextId :: Text
, ContextClaim -> Maybe Text
contextLabel :: Maybe Text
, ContextClaim -> Maybe Text
contextTitle :: Maybe Text
}
deriving stock (Int -> ContextClaim -> ShowS
[ContextClaim] -> ShowS
ContextClaim -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ContextClaim] -> ShowS
$cshowList :: [ContextClaim] -> ShowS
show :: ContextClaim -> [Char]
$cshow :: ContextClaim -> [Char]
showsPrec :: Int -> ContextClaim -> ShowS
$cshowsPrec :: Int -> ContextClaim -> ShowS
Show, ContextClaim -> ContextClaim -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContextClaim -> ContextClaim -> Bool
$c/= :: ContextClaim -> ContextClaim -> Bool
== :: ContextClaim -> ContextClaim -> Bool
$c== :: ContextClaim -> ContextClaim -> Bool
Eq)
instance FromJSON ContextClaim where
parseJSON :: Value -> Parser ContextClaim
parseJSON = forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"ContextClaim" forall a b. (a -> b) -> a -> b
$ \Object
v ->
Text -> Maybe Text -> Maybe Text -> ContextClaim
ContextClaim
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadFail m => Int -> Text -> m Text
limitLength Int
255)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"label"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"title"
instance ToJSON ContextClaim where
toJSON :: ContextClaim -> Value
toJSON ContextClaim {Text
contextId :: Text
contextId :: ContextClaim -> Text
contextId, Maybe Text
contextLabel :: Maybe Text
contextLabel :: ContextClaim -> Maybe Text
contextLabel, Maybe Text
contextTitle :: Maybe Text
contextTitle :: ContextClaim -> Maybe Text
contextTitle} =
[Pair] -> Value
object [
Key
"id" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
contextId
, Key
"label" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
contextLabel
, Key
"title" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
contextTitle
]
toEncoding :: ContextClaim -> Encoding
toEncoding ContextClaim {Text
contextId :: Text
contextId :: ContextClaim -> Text
contextId, Maybe Text
contextLabel :: Maybe Text
contextLabel :: ContextClaim -> Maybe Text
contextLabel, Maybe Text
contextTitle :: Maybe Text
contextTitle :: ContextClaim -> Maybe Text
contextTitle} =
Series -> Encoding
pairs (
Key
"id" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
contextId forall a. Semigroup a => a -> a -> a
<>
Key
"label" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
contextLabel forall a. Semigroup a => a -> a -> a
<>
Key
"title" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
contextTitle
)
data UncheckedLtiTokenClaims = UncheckedLtiTokenClaims
{ UncheckedLtiTokenClaims -> Text
messageType :: Text
, UncheckedLtiTokenClaims -> Text
ltiVersion :: Text
, UncheckedLtiTokenClaims -> Text
deploymentId :: Text
, UncheckedLtiTokenClaims -> Text
targetLinkUri :: Text
, UncheckedLtiTokenClaims -> [Role]
roles :: [Role]
, UncheckedLtiTokenClaims -> Maybe Text
email :: Maybe Text
, UncheckedLtiTokenClaims -> Maybe Text
displayName :: Maybe Text
, UncheckedLtiTokenClaims -> Maybe Text
firstName :: Maybe Text
, UncheckedLtiTokenClaims -> Maybe Text
lastName :: Maybe Text
, UncheckedLtiTokenClaims -> Maybe ContextClaim
context :: Maybe ContextClaim
, UncheckedLtiTokenClaims -> Maybe LisClaim
lis :: Maybe LisClaim
} deriving stock (Int -> UncheckedLtiTokenClaims -> ShowS
[UncheckedLtiTokenClaims] -> ShowS
UncheckedLtiTokenClaims -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [UncheckedLtiTokenClaims] -> ShowS
$cshowList :: [UncheckedLtiTokenClaims] -> ShowS
show :: UncheckedLtiTokenClaims -> [Char]
$cshow :: UncheckedLtiTokenClaims -> [Char]
showsPrec :: Int -> UncheckedLtiTokenClaims -> ShowS
$cshowsPrec :: Int -> UncheckedLtiTokenClaims -> ShowS
Show, UncheckedLtiTokenClaims -> UncheckedLtiTokenClaims -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UncheckedLtiTokenClaims -> UncheckedLtiTokenClaims -> Bool
$c/= :: UncheckedLtiTokenClaims -> UncheckedLtiTokenClaims -> Bool
== :: UncheckedLtiTokenClaims -> UncheckedLtiTokenClaims -> Bool
$c== :: UncheckedLtiTokenClaims -> UncheckedLtiTokenClaims -> Bool
Eq)
newtype LtiTokenClaims = LtiTokenClaims { LtiTokenClaims -> UncheckedLtiTokenClaims
unLtiTokenClaims :: UncheckedLtiTokenClaims }
deriving stock (Int -> LtiTokenClaims -> ShowS
[LtiTokenClaims] -> ShowS
LtiTokenClaims -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [LtiTokenClaims] -> ShowS
$cshowList :: [LtiTokenClaims] -> ShowS
show :: LtiTokenClaims -> [Char]
$cshow :: LtiTokenClaims -> [Char]
showsPrec :: Int -> LtiTokenClaims -> ShowS
$cshowsPrec :: Int -> LtiTokenClaims -> ShowS
Show, LtiTokenClaims -> LtiTokenClaims -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LtiTokenClaims -> LtiTokenClaims -> Bool
$c/= :: LtiTokenClaims -> LtiTokenClaims -> Bool
== :: LtiTokenClaims -> LtiTokenClaims -> Bool
$c== :: LtiTokenClaims -> LtiTokenClaims -> Bool
Eq)
newtype AnonymizedLtiTokenClaims = AnonymizedLtiTokenClaims UncheckedLtiTokenClaims
deriving stock (Int -> AnonymizedLtiTokenClaims -> ShowS
[AnonymizedLtiTokenClaims] -> ShowS
AnonymizedLtiTokenClaims -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [AnonymizedLtiTokenClaims] -> ShowS
$cshowList :: [AnonymizedLtiTokenClaims] -> ShowS
show :: AnonymizedLtiTokenClaims -> [Char]
$cshow :: AnonymizedLtiTokenClaims -> [Char]
showsPrec :: Int -> AnonymizedLtiTokenClaims -> ShowS
$cshowsPrec :: Int -> AnonymizedLtiTokenClaims -> ShowS
Show, AnonymizedLtiTokenClaims -> AnonymizedLtiTokenClaims -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AnonymizedLtiTokenClaims -> AnonymizedLtiTokenClaims -> Bool
$c/= :: AnonymizedLtiTokenClaims -> AnonymizedLtiTokenClaims -> Bool
== :: AnonymizedLtiTokenClaims -> AnonymizedLtiTokenClaims -> Bool
$c== :: AnonymizedLtiTokenClaims -> AnonymizedLtiTokenClaims -> Bool
Eq)
limitLength :: (Fail.MonadFail m) => Int -> Text -> m Text
limitLength :: forall (m :: * -> *). MonadFail m => Int -> Text -> m Text
limitLength Int
len Text
string
| Text -> Int
T.length Text
string forall a. Ord a => a -> a -> Bool
<= Int
len
= forall (m :: * -> *) a. Monad m => a -> m a
return Text
string
limitLength Int
_ Text
_ = forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"String is too long"
claimMessageType :: IsString t => t
claimMessageType :: forall t. IsString t => t
claimMessageType = t
"https://purl.imsglobal.org/spec/lti/claim/message_type"
claimVersion :: IsString t => t
claimVersion :: forall t. IsString t => t
claimVersion = t
"https://purl.imsglobal.org/spec/lti/claim/version"
claimDeploymentId :: IsString t => t
claimDeploymentId :: forall t. IsString t => t
claimDeploymentId = t
"https://purl.imsglobal.org/spec/lti/claim/deployment_id"
claimTargetLinkUri :: IsString t => t
claimTargetLinkUri :: forall t. IsString t => t
claimTargetLinkUri = t
"https://purl.imsglobal.org/spec/lti/claim/target_link_uri"
claimRoles :: IsString t => t
claimRoles :: forall t. IsString t => t
claimRoles = t
"https://purl.imsglobal.org/spec/lti/claim/roles"
claimContext :: IsString t => t
claimContext :: forall t. IsString t => t
claimContext = t
"https://purl.imsglobal.org/spec/lti/claim/context"
claimLis :: IsString t => t
claimLis :: forall t. IsString t => t
claimLis = t
"https://purl.imsglobal.org/spec/lti/claim/lis"
instance FromJSON UncheckedLtiTokenClaims where
parseJSON :: Value -> Parser UncheckedLtiTokenClaims
parseJSON = forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"LtiTokenClaims" forall a b. (a -> b) -> a -> b
$ \Object
v ->
Text
-> Text
-> Text
-> Text
-> [Role]
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe ContextClaim
-> Maybe LisClaim
-> UncheckedLtiTokenClaims
UncheckedLtiTokenClaims
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
(FromJSON a, Eq a, Show a) =>
Object -> Key -> a -> Parser a
parseFixed Object
v forall t. IsString t => t
claimMessageType Text
"LtiResourceLinkRequest"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a.
(FromJSON a, Eq a, Show a) =>
Object -> Key -> a -> Parser a
parseFixed Object
v forall t. IsString t => t
claimVersion Text
"1.3.0"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: forall t. IsString t => t
claimDeploymentId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadFail m => Int -> Text -> m Text
limitLength Int
255)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: forall t. IsString t => t
claimTargetLinkUri
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: forall t. IsString t => t
claimRoles
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"email"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"name"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"given_name"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"family_name"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? forall t. IsString t => t
claimContext
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? forall t. IsString t => t
claimLis
instance ToJSON UncheckedLtiTokenClaims where
toJSON :: UncheckedLtiTokenClaims -> Value
toJSON UncheckedLtiTokenClaims {
Text
messageType :: Text
messageType :: UncheckedLtiTokenClaims -> Text
messageType, Text
ltiVersion :: Text
ltiVersion :: UncheckedLtiTokenClaims -> Text
ltiVersion, Text
deploymentId :: Text
deploymentId :: UncheckedLtiTokenClaims -> Text
deploymentId
, Text
targetLinkUri :: Text
targetLinkUri :: UncheckedLtiTokenClaims -> Text
targetLinkUri, [Role]
roles :: [Role]
roles :: UncheckedLtiTokenClaims -> [Role]
roles, Maybe Text
email :: Maybe Text
email :: UncheckedLtiTokenClaims -> Maybe Text
email, Maybe Text
displayName :: Maybe Text
displayName :: UncheckedLtiTokenClaims -> Maybe Text
displayName
, Maybe Text
firstName :: Maybe Text
firstName :: UncheckedLtiTokenClaims -> Maybe Text
firstName, Maybe Text
lastName :: Maybe Text
lastName :: UncheckedLtiTokenClaims -> Maybe Text
lastName, Maybe ContextClaim
context :: Maybe ContextClaim
context :: UncheckedLtiTokenClaims -> Maybe ContextClaim
context, Maybe LisClaim
lis :: Maybe LisClaim
lis :: UncheckedLtiTokenClaims -> Maybe LisClaim
lis} =
[Pair] -> Value
object [
forall t. IsString t => t
claimMessageType forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
messageType
, forall t. IsString t => t
claimVersion forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
ltiVersion
, forall t. IsString t => t
claimDeploymentId forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
deploymentId
, forall t. IsString t => t
claimTargetLinkUri forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
targetLinkUri
, forall t. IsString t => t
claimRoles forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Role]
roles
, Key
"email" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
email
, Key
"name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
displayName
, Key
"given_name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
firstName
, Key
"family_name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
lastName
, forall t. IsString t => t
claimContext forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe ContextClaim
context
, forall t. IsString t => t
claimLis forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe LisClaim
lis
]
toEncoding :: UncheckedLtiTokenClaims -> Encoding
toEncoding UncheckedLtiTokenClaims {
Text
messageType :: Text
messageType :: UncheckedLtiTokenClaims -> Text
messageType, Text
ltiVersion :: Text
ltiVersion :: UncheckedLtiTokenClaims -> Text
ltiVersion, Text
deploymentId :: Text
deploymentId :: UncheckedLtiTokenClaims -> Text
deploymentId
, Text
targetLinkUri :: Text
targetLinkUri :: UncheckedLtiTokenClaims -> Text
targetLinkUri, [Role]
roles :: [Role]
roles :: UncheckedLtiTokenClaims -> [Role]
roles, Maybe Text
email :: Maybe Text
email :: UncheckedLtiTokenClaims -> Maybe Text
email, Maybe Text
displayName :: Maybe Text
displayName :: UncheckedLtiTokenClaims -> Maybe Text
displayName
, Maybe Text
firstName :: Maybe Text
firstName :: UncheckedLtiTokenClaims -> Maybe Text
firstName, Maybe Text
lastName :: Maybe Text
lastName :: UncheckedLtiTokenClaims -> Maybe Text
lastName, Maybe ContextClaim
context :: Maybe ContextClaim
context :: UncheckedLtiTokenClaims -> Maybe ContextClaim
context, Maybe LisClaim
lis :: Maybe LisClaim
lis :: UncheckedLtiTokenClaims -> Maybe LisClaim
lis} =
Series -> Encoding
pairs (
forall t. IsString t => t
claimMessageType forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
messageType
forall a. Semigroup a => a -> a -> a
<> forall t. IsString t => t
claimVersion forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
ltiVersion
forall a. Semigroup a => a -> a -> a
<> forall t. IsString t => t
claimDeploymentId forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
deploymentId
forall a. Semigroup a => a -> a -> a
<> forall t. IsString t => t
claimTargetLinkUri forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
targetLinkUri
forall a. Semigroup a => a -> a -> a
<> forall t. IsString t => t
claimRoles forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Role]
roles
forall a. Semigroup a => a -> a -> a
<> Key
"email" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
email
forall a. Semigroup a => a -> a -> a
<> Key
"name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
displayName
forall a. Semigroup a => a -> a -> a
<> Key
"given_name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
firstName
forall a. Semigroup a => a -> a -> a
<> Key
"family_name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
lastName
forall a. Semigroup a => a -> a -> a
<> forall t. IsString t => t
claimContext forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe ContextClaim
context
forall a. Semigroup a => a -> a -> a
<> forall t. IsString t => t
claimLis forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe LisClaim
lis
)
validateLtiToken
:: PlatformInfo
-> IdTokenClaims UncheckedLtiTokenClaims
-> Either Text (IdTokenClaims LtiTokenClaims)
validateLtiToken :: PlatformInfo
-> IdTokenClaims UncheckedLtiTokenClaims
-> Either Text (IdTokenClaims LtiTokenClaims)
validateLtiToken PlatformInfo
pinfo IdTokenClaims UncheckedLtiTokenClaims
claims =
Either Text (IdTokenClaims UncheckedLtiTokenClaims)
-> Either Text (IdTokenClaims LtiTokenClaims)
valid forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(forall {a} {a}.
IsString a =>
IdTokenClaims a -> Either a (IdTokenClaims UncheckedLtiTokenClaims)
issuerMatches
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall {a} {a}.
IsString a =>
IdTokenClaims a -> Either a (IdTokenClaims UncheckedLtiTokenClaims)
audContainsClientId
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall {a} {a}.
IsString a =>
IdTokenClaims a -> Either a (IdTokenClaims UncheckedLtiTokenClaims)
hasNonce) forall a b. (a -> b) -> a -> b
$ IdTokenClaims UncheckedLtiTokenClaims
claims
where
issuerMatches :: IdTokenClaims a -> Either a (IdTokenClaims UncheckedLtiTokenClaims)
issuerMatches IdTokenClaims a
c
| forall a. IdTokenClaims a -> Text
iss IdTokenClaims a
c forall a. Eq a => a -> a -> Bool
== PlatformInfo -> Text
platformIssuer PlatformInfo
pinfo
= forall a b. b -> Either a b
Right IdTokenClaims UncheckedLtiTokenClaims
claims
| Bool
otherwise
= forall a b. a -> Either a b
Left a
"issuer does not match platform issuer"
audContainsClientId :: IdTokenClaims a -> Either a (IdTokenClaims UncheckedLtiTokenClaims)
audContainsClientId IdTokenClaims a
c
| forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. IdTokenClaims a -> [Text]
aud IdTokenClaims a
c) forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& PlatformInfo -> Text
platformClientId PlatformInfo
pinfo forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a. IdTokenClaims a -> [Text]
aud IdTokenClaims a
c
= forall a b. b -> Either a b
Right IdTokenClaims UncheckedLtiTokenClaims
claims
| Bool
otherwise
= forall a b. a -> Either a b
Left a
"aud is invalid"
hasNonce :: IdTokenClaims a -> Either a (IdTokenClaims UncheckedLtiTokenClaims)
hasNonce IdTokenClaims a
c =
case forall a. IdTokenClaims a -> Maybe ByteString
nonce IdTokenClaims a
c of
Just ByteString
_ -> forall a b. b -> Either a b
Right IdTokenClaims UncheckedLtiTokenClaims
claims
Maybe ByteString
Nothing -> forall a b. a -> Either a b
Left a
"nonce missing"
valid :: Either Text (IdTokenClaims UncheckedLtiTokenClaims) -> Either Text (IdTokenClaims LtiTokenClaims)
valid :: Either Text (IdTokenClaims UncheckedLtiTokenClaims)
-> Either Text (IdTokenClaims LtiTokenClaims)
valid (Left Text
e) = forall a b. a -> Either a b
Left Text
e
valid (Right IdTokenClaims UncheckedLtiTokenClaims
tok) =
forall a b. b -> Either a b
Right IdTokenClaims UncheckedLtiTokenClaims
tok { otherClaims :: LtiTokenClaims
otherClaims = UncheckedLtiTokenClaims -> LtiTokenClaims
LtiTokenClaims forall a b. (a -> b) -> a -> b
$ forall a. IdTokenClaims a -> a
otherClaims IdTokenClaims UncheckedLtiTokenClaims
tok }
data LTI13Exception
= InvalidHandshake Text
| DiscoveryException Text
| GotHttpException HttpException
| InvalidLtiToken Text
deriving stock (Int -> LTI13Exception -> ShowS
[LTI13Exception] -> ShowS
LTI13Exception -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [LTI13Exception] -> ShowS
$cshowList :: [LTI13Exception] -> ShowS
show :: LTI13Exception -> [Char]
$cshow :: LTI13Exception -> [Char]
showsPrec :: Int -> LTI13Exception -> ShowS
$cshowsPrec :: Int -> LTI13Exception -> ShowS
Show)
instance Exception LTI13Exception
type ClientId = Text
data PlatformInfo = PlatformInfo
{
PlatformInfo -> Text
platformIssuer :: Issuer
, PlatformInfo -> Text
platformClientId :: ClientId
, PlatformInfo -> Text
platformOidcAuthEndpoint :: Text
, PlatformInfo -> [Char]
jwksUrl :: String
}
type Issuer = Text
data AuthFlowConfig m = AuthFlowConfig
{ forall (m :: * -> *).
AuthFlowConfig m -> (Text, Maybe Text) -> m PlatformInfo
getPlatformInfo :: (Issuer, Maybe ClientId) -> m PlatformInfo
, forall (m :: * -> *). AuthFlowConfig m -> ByteString -> m Bool
haveSeenNonce :: Nonce -> m Bool
, forall (m :: * -> *). AuthFlowConfig m -> Text
myRedirectUri :: Text
, forall (m :: * -> *). AuthFlowConfig m -> SessionStore m
sessionStore :: SessionStore m
}
rethrow :: (MonadCatch m) => HttpException -> m a
rethrow :: forall (m :: * -> *) a. MonadCatch m => HttpException -> m a
rethrow = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> LTI13Exception
GotHttpException
getJwkSet
:: Manager
-> String
-> IO [Jwk.Jwk]
getJwkSet :: Manager -> [Char] -> IO [Jwk]
getJwkSet Manager
manager [Char]
fromUrl = do
ByteString
json <- [Char] -> IO ByteString
getJwkSetJson [Char]
fromUrl forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` forall (m :: * -> *) a. MonadCatch m => HttpException -> m a
rethrow
case ByteString -> Either [Char] [Jwk]
jwks ByteString
json of
Right [Jwk]
keys -> forall (m :: * -> *) a. Monad m => a -> m a
return [Jwk]
keys
Left [Char]
err -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Text -> LTI13Exception
DiscoveryException (Text
"Failed to decode JwkSet: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
err)
where
getJwkSetJson :: [Char] -> IO ByteString
getJwkSetJson [Char]
url = do
Request
req <- forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseRequest [Char]
url
Response ByteString
res <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
manager
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall body. Response body -> body
responseBody Response ByteString
res
jwks :: ByteString -> Either [Char] [Jwk]
jwks ByteString
j = JwkSet -> [Jwk]
Jwk.keys forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecode ByteString
j
lookupOrThrow :: (MonadThrow m) => Text -> Map.Map Text Text -> m Text
lookupOrThrow :: forall (m :: * -> *).
MonadThrow m =>
Text -> Map Text Text -> m Text
lookupOrThrow Text
name Map Text Text
map_ =
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text Text
map_ of
Maybe Text
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw forall a b. (a -> b) -> a -> b
$ Text -> LTI13Exception
InvalidHandshake forall a b. (a -> b) -> a -> b
$ Text
"Missing `" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"`"
Just Text
a -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
a
type RequestParams = Map.Map Text Text
initiate :: (MonadIO m) => AuthFlowConfig m -> RequestParams -> m (Issuer, ClientId, Text)
initiate :: forall (m :: * -> *).
MonadIO m =>
AuthFlowConfig m -> Map Text Text -> m (Text, Text, Text)
initiate AuthFlowConfig m
cfg Map Text Text
params = do
Text
iss <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadThrow m =>
Text -> Map Text Text -> m Text
lookupOrThrow Text
"iss" Map Text Text
params
Text
loginHint <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadThrow m =>
Text -> Map Text Text -> m Text
lookupOrThrow Text
"login_hint" Map Text Text
params
Text
_targetLinkUri <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadThrow m =>
Text -> Map Text Text -> m Text
lookupOrThrow Text
"target_link_uri" Map Text Text
params
let messageHint :: Maybe Text
messageHint = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"lti_message_hint" Map Text Text
params
let gotCid :: Maybe Text
gotCid = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"client_id" Map Text Text
params
PlatformInfo
{ platformOidcAuthEndpoint :: PlatformInfo -> Text
platformOidcAuthEndpoint = Text
endpoint
, platformClientId :: PlatformInfo -> Text
platformClientId = Text
clientId } <- forall (m :: * -> *).
AuthFlowConfig m -> (Text, Maybe Text) -> m PlatformInfo
getPlatformInfo AuthFlowConfig m
cfg (Text
iss, Maybe Text
gotCid)
let ss :: SessionStore m
ss = forall (m :: * -> *). AuthFlowConfig m -> SessionStore m
sessionStore AuthFlowConfig m
cfg
ByteString
nonce <- forall (m :: * -> *). SessionStore m -> m ByteString
sessionStoreGenerate SessionStore m
ss
ByteString
state <- forall (m :: * -> *). SessionStore m -> m ByteString
sessionStoreGenerate SessionStore m
ss
forall (m :: * -> *).
SessionStore m -> ByteString -> ByteString -> m ()
sessionStoreSave SessionStore m
ss ByteString
state ByteString
nonce
let query :: Query
query = SimpleQuery -> Query
URI.simpleQueryToQuery forall a b. (a -> b) -> a -> b
$
[ (ByteString
"scope", ByteString
"openid")
, (ByteString
"response_type", ByteString
"id_token")
, (ByteString
"client_id", Text -> ByteString
encodeUtf8 Text
clientId)
, (ByteString
"redirect_uri", Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). AuthFlowConfig m -> Text
myRedirectUri AuthFlowConfig m
cfg)
, (ByteString
"login_hint", Text -> ByteString
encodeUtf8 Text
loginHint)
, (ByteString
"state", ByteString
state)
, (ByteString
"response_mode", ByteString
"form_post")
, (ByteString
"nonce", ByteString
nonce)
, (ByteString
"prompt", ByteString
"none")
] forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
mh -> [(ByteString
"lti_message_hint", Text -> ByteString
encodeUtf8 Text
mh)]) Maybe Text
messageHint
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
iss, Text
clientId, Text
endpoint forall a. Semigroup a => a -> a -> a
<> (ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Query -> ByteString
URI.renderQuery Bool
True) Query
query)
fakeOidc :: [Jwk.Jwk] -> O.OIDC
fakeOidc :: [Jwk] -> OIDC
fakeOidc [Jwk]
jset = O.OIDC
{ oidcProvider :: Provider
O.oidcProvider = P.Provider
{ configuration :: Configuration
P.configuration = P.Configuration
{ idTokenSigningAlgValuesSupported :: [JwsAlgJson]
P.idTokenSigningAlgValuesSupported = [ JwsAlg -> JwsAlgJson
P.JwsAlgJson JwsAlg
RS256 ]
, issuer :: Text
P.issuer = forall a. HasCallStack => a
undefined
, authorizationEndpoint :: Text
P.authorizationEndpoint = forall a. HasCallStack => a
undefined
, tokenEndpoint :: Text
P.tokenEndpoint = forall a. HasCallStack => a
undefined
, userinfoEndpoint :: Maybe Text
P.userinfoEndpoint = forall a. HasCallStack => a
undefined
, revocationEndpoint :: Maybe Text
P.revocationEndpoint = forall a. HasCallStack => a
undefined
, jwksUri :: Text
P.jwksUri = forall a. HasCallStack => a
undefined
, responseTypesSupported :: [Text]
P.responseTypesSupported = forall a. HasCallStack => a
undefined
, subjectTypesSupported :: [Text]
P.subjectTypesSupported = forall a. HasCallStack => a
undefined
, scopesSupported :: Maybe [Text]
P.scopesSupported = forall a. HasCallStack => a
undefined
, tokenEndpointAuthMethodsSupported :: Maybe [Text]
P.tokenEndpointAuthMethodsSupported = forall a. HasCallStack => a
undefined
, claimsSupported :: Maybe [Text]
P.claimsSupported = forall a. HasCallStack => a
undefined
}
, jwkSet :: [Jwk]
P.jwkSet = [Jwk]
jset
}
, oidcAuthorizationServerUrl :: Text
O.oidcAuthorizationServerUrl = forall a. HasCallStack => a
undefined
, oidcTokenEndpoint :: Text
O.oidcTokenEndpoint = forall a. HasCallStack => a
undefined
, oidcClientId :: ByteString
O.oidcClientId = forall a. HasCallStack => a
undefined
, oidcClientSecret :: ByteString
O.oidcClientSecret = forall a. HasCallStack => a
undefined
, oidcRedirectUri :: ByteString
O.oidcRedirectUri = forall a. HasCallStack => a
undefined
}
handleAuthResponse :: (MonadIO m)
=> Manager
-> AuthFlowConfig m
-> RequestParams
-> PlatformInfo
-> m (Text, IdTokenClaims LtiTokenClaims)
handleAuthResponse :: forall (m :: * -> *).
MonadIO m =>
Manager
-> AuthFlowConfig m
-> Map Text Text
-> PlatformInfo
-> m (Text, IdTokenClaims LtiTokenClaims)
handleAuthResponse Manager
mgr AuthFlowConfig m
cfg Map Text Text
params PlatformInfo
pinfo = do
Text
state <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadThrow m =>
Text -> Map Text Text -> m Text
lookupOrThrow Text
"state" Map Text Text
params
Text
idToken <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadThrow m =>
Text -> Map Text Text -> m Text
lookupOrThrow Text
"id_token" Map Text Text
params
let PlatformInfo { [Char]
jwksUrl :: [Char]
jwksUrl :: PlatformInfo -> [Char]
jwksUrl } = PlatformInfo
pinfo
[Jwk]
jwkSet <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Manager -> [Char] -> IO [Jwk]
getJwkSet Manager
mgr [Char]
jwksUrl
let ss :: SessionStore m
ss = forall (m :: * -> *). AuthFlowConfig m -> SessionStore m
sessionStore AuthFlowConfig m
cfg
oidc :: OIDC
oidc = [Jwk] -> OIDC
fakeOidc [Jwk]
jwkSet
IdTokenClaims UncheckedLtiTokenClaims
toCheck <- forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
SessionStore m
-> OIDC -> ByteString -> m ByteString -> m (IdTokenClaims a)
getValidIdTokenClaims SessionStore m
ss OIDC
oidc (Text -> ByteString
encodeUtf8 Text
state) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
idToken)
Bool
nonceSeen <- case forall a. IdTokenClaims a -> Maybe ByteString
nonce IdTokenClaims UncheckedLtiTokenClaims
toCheck of
Just ByteString
n -> forall (m :: * -> *). AuthFlowConfig m -> ByteString -> m Bool
haveSeenNonce AuthFlowConfig m
cfg ByteString
n
Maybe ByteString
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw forall a b. (a -> b) -> a -> b
$ Text -> LTI13Exception
InvalidLtiToken Text
"missing nonce"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
nonceSeen (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw forall a b. (a -> b) -> a -> b
$ Text -> LTI13Exception
InvalidLtiToken Text
"nonce seen before")
case PlatformInfo
-> IdTokenClaims UncheckedLtiTokenClaims
-> Either Text (IdTokenClaims LtiTokenClaims)
validateLtiToken PlatformInfo
pinfo IdTokenClaims UncheckedLtiTokenClaims
toCheck of
Left Text
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw forall a b. (a -> b) -> a -> b
$ Text -> LTI13Exception
InvalidLtiToken Text
err
Right IdTokenClaims LtiTokenClaims
tok -> forall (m :: * -> *) a. Monad m => a -> m a
return (Text
state, IdTokenClaims LtiTokenClaims
tok)
anonymizeLtiTokenForLogging :: UncheckedLtiTokenClaims -> AnonymizedLtiTokenClaims
anonymizeLtiTokenForLogging :: UncheckedLtiTokenClaims -> AnonymizedLtiTokenClaims
anonymizeLtiTokenForLogging UncheckedLtiTokenClaims {[Role]
Maybe Text
Maybe ContextClaim
Maybe LisClaim
Text
lis :: Maybe LisClaim
context :: Maybe ContextClaim
lastName :: Maybe Text
firstName :: Maybe Text
displayName :: Maybe Text
email :: Maybe Text
roles :: [Role]
targetLinkUri :: Text
deploymentId :: Text
ltiVersion :: Text
messageType :: Text
lis :: UncheckedLtiTokenClaims -> Maybe LisClaim
context :: UncheckedLtiTokenClaims -> Maybe ContextClaim
lastName :: UncheckedLtiTokenClaims -> Maybe Text
firstName :: UncheckedLtiTokenClaims -> Maybe Text
displayName :: UncheckedLtiTokenClaims -> Maybe Text
email :: UncheckedLtiTokenClaims -> Maybe Text
roles :: UncheckedLtiTokenClaims -> [Role]
targetLinkUri :: UncheckedLtiTokenClaims -> Text
deploymentId :: UncheckedLtiTokenClaims -> Text
ltiVersion :: UncheckedLtiTokenClaims -> Text
messageType :: UncheckedLtiTokenClaims -> Text
..} =
UncheckedLtiTokenClaims -> AnonymizedLtiTokenClaims
AnonymizedLtiTokenClaims forall a b. (a -> b) -> a -> b
$ UncheckedLtiTokenClaims
{ Text
messageType :: Text
messageType :: Text
messageType
, Text
ltiVersion :: Text
ltiVersion :: Text
ltiVersion
, Text
deploymentId :: Text
deploymentId :: Text
deploymentId
, Text
targetLinkUri :: Text
targetLinkUri :: Text
targetLinkUri
, [Role]
roles :: [Role]
roles :: [Role]
roles
, displayName :: Maybe Text
displayName = forall {a} {p}. IsString a => p -> a
anonymized forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
displayName
, firstName :: Maybe Text
firstName = forall {a} {p}. IsString a => p -> a
anonymized forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
firstName
, lastName :: Maybe Text
lastName = forall {a} {p}. IsString a => p -> a
anonymized forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
lastName
, Maybe ContextClaim
context :: Maybe ContextClaim
context :: Maybe ContextClaim
context
, email :: Maybe Text
email = forall {a} {p}. IsString a => p -> a
anonymized forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
email
, lis :: Maybe LisClaim
lis = LisClaim -> LisClaim
anonymizedLis forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe LisClaim
lis
}
where
anonymized :: p -> a
anonymized p
_ = a
"**"
anonymizedLis :: LisClaim -> LisClaim
anonymizedLis LisClaim {Maybe Text
resultSourcedId :: Maybe Text
courseSectionSourcedId :: Maybe Text
courseOfferingSourcedId :: Maybe Text
outcomeServiceUrl :: Maybe Text
personSourcedId :: Maybe Text
resultSourcedId :: LisClaim -> Maybe Text
courseSectionSourcedId :: LisClaim -> Maybe Text
courseOfferingSourcedId :: LisClaim -> Maybe Text
outcomeServiceUrl :: LisClaim -> Maybe Text
personSourcedId :: LisClaim -> Maybe Text
..} = LisClaim
{ personSourcedId :: Maybe Text
personSourcedId = forall {a} {p}. IsString a => p -> a
anonymized forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
personSourcedId
, Maybe Text
outcomeServiceUrl :: Maybe Text
outcomeServiceUrl :: Maybe Text
outcomeServiceUrl
, Maybe Text
courseOfferingSourcedId :: Maybe Text
courseOfferingSourcedId :: Maybe Text
courseOfferingSourcedId
, Maybe Text
courseSectionSourcedId :: Maybe Text
courseSectionSourcedId :: Maybe Text
courseSectionSourcedId
, resultSourcedId :: Maybe Text
resultSourcedId = forall {a} {p}. IsString a => p -> a
anonymized forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
resultSourcedId
}