-- | A simple LTI 1.3 library.
--   It's intended to be used by implementing routes for 'initiate' and
--   'handleAuthResponse', and work out the associated parameters thereof.
--
--   This is written based on the LTI 1.3 specification
--   <http://www.imsglobal.org/spec/lti/v1p3/ available from the IMS Global
--   website>. Users will probably also find the <https://lti-ri.imsglobal.org/
--   LTI Reference Implementation> helpful.
module Web.LTI13 (
      -- * Token contents/data model
        Role(..)
      , LisClaim(..)
      , ContextClaim(..)
      , UncheckedLtiTokenClaims(..)
      , LtiTokenClaims(..)

      -- * Anonymizing tokens for logging
      , AnonymizedLtiTokenClaims(..)
      , anonymizeLtiTokenForLogging

      -- * Validation and auth
      , 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 (..))

-- | Parses a JSON text field to a fixed expected value, failing otherwise
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

-- | Roles in the target context (≈ course/section); see
--   <http://www.imsglobal.org/spec/lti/v1p3/#lis-vocabulary-for-institution-roles LTI spec § A.2.2>
--   and <http://www.imsglobal.org/spec/lti/v1p3/#roles-claim LTI spec § 5.3.7>
--   for details
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

-- | <http://www.imsglobal.org/spec/lti/v1p3/#lislti LTI spec § D> LIS claim
data LisClaim = LisClaim
    { LisClaim -> Maybe Text
personSourcedId         :: Maybe Text
    -- ^ LIS identifier for the person making the request.
    , LisClaim -> Maybe Text
outcomeServiceUrl       :: Maybe Text
    -- ^ URL for the Basic Outcomes service, unique per-tool.
    , LisClaim -> Maybe Text
courseOfferingSourcedId :: Maybe Text
    -- ^ Identifier for the course
    , LisClaim -> Maybe Text
courseSectionSourcedId  :: Maybe Text
    -- ^ Identifier for the section.
    , LisClaim -> Maybe Text
resultSourcedId         :: Maybe Text
    -- ^ An identifier for the position in the gradebook associated with the
    --   assignment being viewed.
    } 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
        )

-- | <http://www.imsglobal.org/spec/lti/v1p3/#context-claim LTI spec § 5.4.1> context claim
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
        )

-- | LTI specific claims on a token. You should not accept this type, and
--   instead prefer the @newtype@ 'LtiTokenClaims' which has had checking
--   performed on it.
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)

-- | An object representing in the type system a token whose claims have been
--   validated.
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)

-- | LTI token claims from which all student data has been removed. For logging.
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
          )

-- | A direct implementation of <http://www.imsglobal.org/spec/security/v1p0/#authentication-response-validation Security § 5.1.3>
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
        -- step 1 handled before we are called
        -- step 2
        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"
        -- step 3
        audContainsClientId :: IdTokenClaims a -> Either a (IdTokenClaims UncheckedLtiTokenClaims)
audContainsClientId IdTokenClaims a
c
            -- "The Tool MUST reject the ID Token if it does not list the
            -- client_id as a valid audience, or if it contains additional
            -- audiences not trusted by the Tool."
            -- Game on, I don't trust anyone else.
            | 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"
        -- step 4 and 5 elided -> we can ignore azp because we don't accept >1 aud entries
        -- step 6 is performed elsewhere, probably
        -- step 7 elided because it is handled by 'validateClaims'
        -- step 8 optional
        -- step 9 nonce checking "The ID Token MUST contain a nonce Claim."
        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)
        -- unwrap a validated token and rewrap it as a valid token
        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 }


-----------------------------------------------------------
-- Helpers for the endpoints you have to implement
-----------------------------------------------------------

-- | (most of) the exceptions that can arise in LTI 1.3 handling. Some may have
--   been forgotten, and this is a bug that should be fixed.
data LTI13Exception
    = InvalidHandshake Text
    -- ^ Error in the handshake format
    | DiscoveryException Text
    | GotHttpException HttpException
    | InvalidLtiToken Text
    -- ^ Token validation error. Per <http://www.imsglobal.org/spec/security/v1p0/#authentication-response-validation Security § 5.1.3>
    --   if you get this, you should return a 401.
    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

-- | @client_id@, one or more per platform; <https://www.imsglobal.org/spec/lti/v1p3/#tool-deployment LTI spec § 3.1.3>
type ClientId = Text

-- | Preregistered information about a learning platform
data PlatformInfo = PlatformInfo
    {
    -- | Issuer value
      PlatformInfo -> Text
platformIssuer           :: Issuer
    -- | @client_id@
    , PlatformInfo -> Text
platformClientId         :: ClientId
    -- | URL the client is redirected to for <http://www.imsglobal.org/spec/security/v1p0/#step-3-authentication-response auth stage 2>.
    --   See also <http://www.imsglobal.org/spec/security/v1p0/#openid_connect_launch_flow Security spec § 5.1.1>
    , PlatformInfo -> Text
platformOidcAuthEndpoint :: Text
    -- | URL for a JSON object containing the JWK signing keys for the platform
    , PlatformInfo -> [Char]
jwksUrl                  :: String
    }

-- | Issuer/@iss@ field
type Issuer = Text

-- | Structure you have to provide defining integration points with your app
data AuthFlowConfig m = AuthFlowConfig
    { forall (m :: * -> *).
AuthFlowConfig m -> (Text, Maybe Text) -> m PlatformInfo
getPlatformInfo :: (Issuer, Maybe ClientId) -> m PlatformInfo
    -- ^ Access some persistent storage of the configured platforms and return the
    --   PlatformInfo for a given platform by name
    , 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
    -- ^ Note that as in the example for haskell-oidc-client, this is intended to
    --   be partially parameterized already with some separate cookie you give
    --   the browser. You should also store the @iss@ from the 'initiate' stage
    --   in the session somewhere for the 'handleAuthResponse' stage.
    }

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

-- | Grab the JWK set from a URL
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

-- | Parameters to a request, either in the URL with a @GET@ or in the body
--   with a @POST@
type RequestParams = Map.Map Text Text

-- | Makes the URL for <http://www.imsglobal.org/spec/security/v1p0/#step-1-third-party-initiated-login IMS Security spec § 5.1.1.2>
--   upon the § 5.1.1.1 request coming in
--
--   Returns @(Issuer, RedirectURL)@.
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
    -- we don't care about target link uri since we only support one endpoint
    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
    -- "This allows for a platform to support multiple registrations from a
    -- single issuer, without relying on the initiate_login_uri as a key."
    --
    -- Canvas puts the same issuer on all their messages (wat)
    -- (https://community.canvaslms.com/thread/36682-lti13-how-to-identify-clientid-and-deploymentid-on-launch)
    -- so we need to be able to distinguish these. Our client code must
    -- therefore key its platform info store by @(Issuer, Maybe ClientId)@
    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)

-- | Makes a fake OIDC object with the bare minimum attributes to hand to
--   verification library functions
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
        }

-- | Handle the <http://www.imsglobal.org/spec/security/v1p0/#step-3-authentication-response § 5.1.1.3 Step 3>
--   response sent to the 'AuthFlowConfig.myRedirectUri'
--
--   Returns @(State, Token)@
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)

    -- present nonce but seen -> error
    -- present nonce unseen -> good
    -- absent nonce -> different error
    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)

-- | Removes PII of the user from the token, retaining only information about
--   the system in general or the context.
--
--   Fields that are 'Maybe' are kept as 'Maybe', with the contents replaced
--   with @"**"@ if they were 'Just' and otherwise kept as 'Nothing'.
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
        -- this should not identify the user; it is at most a class item
        , 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
            -- we really don't know what they will put in this; it might be
            -- student specific
            { 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
            -- spec strongly suggests this be the same across launches ie only
            -- identifies the context
            , 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
            -- likewise with personSourcedId, we don't know what will be put in
            -- here. it's probably a guid but let's be safe
            , 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
            }