{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

-- | A basic 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, Typeable,
                                                     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.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 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 -> Text -> a -> Parser a
parseFixed :: Object -> Text -> a -> Parser a
parseFixed Object
obj Text
field a
fixedVal =
    Object
obj Object -> Text -> Parser a
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
field Parser a -> (a -> Parser a) -> Parser a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
v ->
        if a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
fixedVal then
            a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
        else
            String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ String
"field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
field String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" was not the required value " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
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 (Int -> Role -> String -> String
[Role] -> String -> String
Role -> String
(Int -> Role -> String -> String)
-> (Role -> String) -> ([Role] -> String -> String) -> Show Role
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Role] -> String -> String
$cshowList :: [Role] -> String -> String
show :: Role -> String
$cshow :: Role -> String
showsPrec :: Int -> Role -> String -> String
$cshowsPrec :: Int -> Role -> String -> String
Show, Role -> Role -> Bool
(Role -> Role -> Bool) -> (Role -> Role -> Bool) -> Eq Role
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 = String -> (Text -> Parser Role) -> Value -> Parser Role
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Role" ((Text -> Parser Role) -> Value -> Parser Role)
-> (Text -> Parser Role) -> Value -> Parser Role
forall a b. (a -> b) -> a -> b
$ Role -> Parser Role
forall (m :: * -> *) a. Monad m => a -> m a
return (Role -> Parser Role) -> (Text -> Role) -> Text -> Parser Role
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 (Text -> Value) -> (Role -> Text) -> Role -> Value
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 (Int -> LisClaim -> String -> String
[LisClaim] -> String -> String
LisClaim -> String
(Int -> LisClaim -> String -> String)
-> (LisClaim -> String)
-> ([LisClaim] -> String -> String)
-> Show LisClaim
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [LisClaim] -> String -> String
$cshowList :: [LisClaim] -> String -> String
show :: LisClaim -> String
$cshow :: LisClaim -> String
showsPrec :: Int -> LisClaim -> String -> String
$cshowsPrec :: Int -> LisClaim -> String -> String
Show, LisClaim -> LisClaim -> Bool
(LisClaim -> LisClaim -> Bool)
-> (LisClaim -> LisClaim -> Bool) -> Eq LisClaim
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 = String -> (Object -> Parser LisClaim) -> Value -> Parser LisClaim
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"LisClaim" ((Object -> Parser LisClaim) -> Value -> Parser LisClaim)
-> (Object -> Parser LisClaim) -> Value -> Parser LisClaim
forall a b. (a -> b) -> a -> b
$ \Object
v ->
        Maybe Text
-> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> LisClaim
LisClaim
            (Maybe Text
 -> Maybe Text
 -> Maybe Text
 -> Maybe Text
 -> Maybe Text
 -> LisClaim)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> LisClaim)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"person_sourcedid"
            Parser
  (Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> LisClaim)
-> Parser (Maybe Text)
-> Parser (Maybe Text -> Maybe Text -> Maybe Text -> LisClaim)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"outcome_service_url"
            Parser (Maybe Text -> Maybe Text -> Maybe Text -> LisClaim)
-> Parser (Maybe Text)
-> Parser (Maybe Text -> Maybe Text -> LisClaim)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"course_offering_sourcedid"
            Parser (Maybe Text -> Maybe Text -> LisClaim)
-> Parser (Maybe Text) -> Parser (Maybe Text -> LisClaim)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"course_section_sourcedid"
            Parser (Maybe Text -> LisClaim)
-> Parser (Maybe Text) -> Parser LisClaim
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"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 [
            Text
"person_sourcedid" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
personSourcedId
          , Text
"outcome_service_url" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
outcomeServiceUrl
          , Text
"course_offering_sourcedid" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
courseOfferingSourcedId
          , Text
"course_section_sourcedid" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
courseSectionSourcedId
          , Text
"result_sourcedid" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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 (
            Text
"person_sourcedid" Text -> Maybe Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
personSourcedId Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<>
            Text
"outcome_service_url" Text -> Maybe Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
outcomeServiceUrl Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<>
            Text
"course_offering_sourcedid" Text -> Maybe Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
courseOfferingSourcedId Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<>
            Text
"course_section_sourcedid" Text -> Maybe Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
courseSectionSourcedId Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<>
            Text
"result_sourcedid" Text -> Maybe Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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 (Int -> ContextClaim -> String -> String
[ContextClaim] -> String -> String
ContextClaim -> String
(Int -> ContextClaim -> String -> String)
-> (ContextClaim -> String)
-> ([ContextClaim] -> String -> String)
-> Show ContextClaim
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ContextClaim] -> String -> String
$cshowList :: [ContextClaim] -> String -> String
show :: ContextClaim -> String
$cshow :: ContextClaim -> String
showsPrec :: Int -> ContextClaim -> String -> String
$cshowsPrec :: Int -> ContextClaim -> String -> String
Show, ContextClaim -> ContextClaim -> Bool
(ContextClaim -> ContextClaim -> Bool)
-> (ContextClaim -> ContextClaim -> Bool) -> Eq ContextClaim
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 = String
-> (Object -> Parser ContextClaim) -> Value -> Parser ContextClaim
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ContextClaim" ((Object -> Parser ContextClaim) -> Value -> Parser ContextClaim)
-> (Object -> Parser ContextClaim) -> Value -> Parser ContextClaim
forall a b. (a -> b) -> a -> b
$ \Object
v ->
        Text -> Maybe Text -> Maybe Text -> ContextClaim
ContextClaim
            (Text -> Maybe Text -> Maybe Text -> ContextClaim)
-> Parser Text -> Parser (Maybe Text -> Maybe Text -> ContextClaim)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"id" Parser Text -> (Text -> Parser Text) -> Parser Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Text -> Parser Text
forall (m :: * -> *). MonadFail m => Int -> Text -> m Text
limitLength Int
255)
            Parser (Maybe Text -> Maybe Text -> ContextClaim)
-> Parser (Maybe Text) -> Parser (Maybe Text -> ContextClaim)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"label"
            Parser (Maybe Text -> ContextClaim)
-> Parser (Maybe Text) -> Parser ContextClaim
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"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 [
            Text
"id" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
contextId
          , Text
"label" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
contextLabel
          , Text
"title" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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 (
            Text
"id" Text -> Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
contextId Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<>
            Text
"label" Text -> Maybe Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
contextLabel Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<>
            Text
"title" Text -> Maybe Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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 (Int -> UncheckedLtiTokenClaims -> String -> String
[UncheckedLtiTokenClaims] -> String -> String
UncheckedLtiTokenClaims -> String
(Int -> UncheckedLtiTokenClaims -> String -> String)
-> (UncheckedLtiTokenClaims -> String)
-> ([UncheckedLtiTokenClaims] -> String -> String)
-> Show UncheckedLtiTokenClaims
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [UncheckedLtiTokenClaims] -> String -> String
$cshowList :: [UncheckedLtiTokenClaims] -> String -> String
show :: UncheckedLtiTokenClaims -> String
$cshow :: UncheckedLtiTokenClaims -> String
showsPrec :: Int -> UncheckedLtiTokenClaims -> String -> String
$cshowsPrec :: Int -> UncheckedLtiTokenClaims -> String -> String
Show, UncheckedLtiTokenClaims -> UncheckedLtiTokenClaims -> Bool
(UncheckedLtiTokenClaims -> UncheckedLtiTokenClaims -> Bool)
-> (UncheckedLtiTokenClaims -> UncheckedLtiTokenClaims -> Bool)
-> Eq UncheckedLtiTokenClaims
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 (Int -> LtiTokenClaims -> String -> String
[LtiTokenClaims] -> String -> String
LtiTokenClaims -> String
(Int -> LtiTokenClaims -> String -> String)
-> (LtiTokenClaims -> String)
-> ([LtiTokenClaims] -> String -> String)
-> Show LtiTokenClaims
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [LtiTokenClaims] -> String -> String
$cshowList :: [LtiTokenClaims] -> String -> String
show :: LtiTokenClaims -> String
$cshow :: LtiTokenClaims -> String
showsPrec :: Int -> LtiTokenClaims -> String -> String
$cshowsPrec :: Int -> LtiTokenClaims -> String -> String
Show, LtiTokenClaims -> LtiTokenClaims -> Bool
(LtiTokenClaims -> LtiTokenClaims -> Bool)
-> (LtiTokenClaims -> LtiTokenClaims -> Bool) -> Eq LtiTokenClaims
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 (Int -> AnonymizedLtiTokenClaims -> String -> String
[AnonymizedLtiTokenClaims] -> String -> String
AnonymizedLtiTokenClaims -> String
(Int -> AnonymizedLtiTokenClaims -> String -> String)
-> (AnonymizedLtiTokenClaims -> String)
-> ([AnonymizedLtiTokenClaims] -> String -> String)
-> Show AnonymizedLtiTokenClaims
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [AnonymizedLtiTokenClaims] -> String -> String
$cshowList :: [AnonymizedLtiTokenClaims] -> String -> String
show :: AnonymizedLtiTokenClaims -> String
$cshow :: AnonymizedLtiTokenClaims -> String
showsPrec :: Int -> AnonymizedLtiTokenClaims -> String -> String
$cshowsPrec :: Int -> AnonymizedLtiTokenClaims -> String -> String
Show, AnonymizedLtiTokenClaims -> AnonymizedLtiTokenClaims -> Bool
(AnonymizedLtiTokenClaims -> AnonymizedLtiTokenClaims -> Bool)
-> (AnonymizedLtiTokenClaims -> AnonymizedLtiTokenClaims -> Bool)
-> Eq AnonymizedLtiTokenClaims
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 :: Int -> Text -> m Text
limitLength Int
len Text
string
    | Text -> Int
T.length Text
string Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
len
    = Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
string
limitLength Int
_ Text
_ = String -> m Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"String is too long"

claimMessageType :: Text
claimMessageType :: Text
claimMessageType = Text
"https://purl.imsglobal.org/spec/lti/claim/message_type"
claimVersion :: Text
claimVersion :: Text
claimVersion = Text
"https://purl.imsglobal.org/spec/lti/claim/version"
claimDeploymentId :: Text
claimDeploymentId :: Text
claimDeploymentId = Text
"https://purl.imsglobal.org/spec/lti/claim/deployment_id"
claimTargetLinkUri :: Text
claimTargetLinkUri :: Text
claimTargetLinkUri = Text
"https://purl.imsglobal.org/spec/lti/claim/target_link_uri"
claimRoles :: Text
claimRoles :: Text
claimRoles = Text
"https://purl.imsglobal.org/spec/lti/claim/roles"
claimContext :: Text
claimContext :: Text
claimContext = Text
"https://purl.imsglobal.org/spec/lti/claim/context"
claimLis :: Text
claimLis :: Text
claimLis = Text
"https://purl.imsglobal.org/spec/lti/claim/lis"

instance FromJSON UncheckedLtiTokenClaims where
    parseJSON :: Value -> Parser UncheckedLtiTokenClaims
parseJSON = String
-> (Object -> Parser UncheckedLtiTokenClaims)
-> Value
-> Parser UncheckedLtiTokenClaims
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"LtiTokenClaims" ((Object -> Parser UncheckedLtiTokenClaims)
 -> Value -> Parser UncheckedLtiTokenClaims)
-> (Object -> Parser UncheckedLtiTokenClaims)
-> Value
-> Parser UncheckedLtiTokenClaims
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
            (Text
 -> Text
 -> Text
 -> Text
 -> [Role]
 -> Maybe Text
 -> Maybe Text
 -> Maybe Text
 -> Maybe Text
 -> Maybe ContextClaim
 -> Maybe LisClaim
 -> UncheckedLtiTokenClaims)
-> Parser Text
-> Parser
     (Text
      -> Text
      -> Text
      -> [Role]
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe ContextClaim
      -> Maybe LisClaim
      -> UncheckedLtiTokenClaims)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Text -> Text -> Parser Text
forall a.
(FromJSON a, Eq a, Show a) =>
Object -> Text -> a -> Parser a
parseFixed Object
v Text
claimMessageType Text
"LtiResourceLinkRequest"
            Parser
  (Text
   -> Text
   -> Text
   -> [Role]
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe ContextClaim
   -> Maybe LisClaim
   -> UncheckedLtiTokenClaims)
-> Parser Text
-> Parser
     (Text
      -> Text
      -> [Role]
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe ContextClaim
      -> Maybe LisClaim
      -> UncheckedLtiTokenClaims)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Text -> Text -> Parser Text
forall a.
(FromJSON a, Eq a, Show a) =>
Object -> Text -> a -> Parser a
parseFixed Object
v Text
claimVersion Text
"1.3.0"
            Parser
  (Text
   -> Text
   -> [Role]
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe ContextClaim
   -> Maybe LisClaim
   -> UncheckedLtiTokenClaims)
-> Parser Text
-> Parser
     (Text
      -> [Role]
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe ContextClaim
      -> Maybe LisClaim
      -> UncheckedLtiTokenClaims)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
claimDeploymentId Parser Text -> (Text -> Parser Text) -> Parser Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Text -> Parser Text
forall (m :: * -> *). MonadFail m => Int -> Text -> m Text
limitLength Int
255)
            Parser
  (Text
   -> [Role]
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe ContextClaim
   -> Maybe LisClaim
   -> UncheckedLtiTokenClaims)
-> Parser Text
-> Parser
     ([Role]
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe ContextClaim
      -> Maybe LisClaim
      -> UncheckedLtiTokenClaims)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
claimTargetLinkUri
            Parser
  ([Role]
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe ContextClaim
   -> Maybe LisClaim
   -> UncheckedLtiTokenClaims)
-> Parser [Role]
-> Parser
     (Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe ContextClaim
      -> Maybe LisClaim
      -> UncheckedLtiTokenClaims)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser [Role]
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
claimRoles
            Parser
  (Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe ContextClaim
   -> Maybe LisClaim
   -> UncheckedLtiTokenClaims)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe ContextClaim
      -> Maybe LisClaim
      -> UncheckedLtiTokenClaims)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"email"
            Parser
  (Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe ContextClaim
   -> Maybe LisClaim
   -> UncheckedLtiTokenClaims)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text
      -> Maybe Text
      -> Maybe ContextClaim
      -> Maybe LisClaim
      -> UncheckedLtiTokenClaims)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"name"
            Parser
  (Maybe Text
   -> Maybe Text
   -> Maybe ContextClaim
   -> Maybe LisClaim
   -> UncheckedLtiTokenClaims)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text
      -> Maybe ContextClaim -> Maybe LisClaim -> UncheckedLtiTokenClaims)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"given_name"
            Parser
  (Maybe Text
   -> Maybe ContextClaim -> Maybe LisClaim -> UncheckedLtiTokenClaims)
-> Parser (Maybe Text)
-> Parser
     (Maybe ContextClaim -> Maybe LisClaim -> UncheckedLtiTokenClaims)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"family_name"
            Parser
  (Maybe ContextClaim -> Maybe LisClaim -> UncheckedLtiTokenClaims)
-> Parser (Maybe ContextClaim)
-> Parser (Maybe LisClaim -> UncheckedLtiTokenClaims)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe ContextClaim)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
claimContext
            Parser (Maybe LisClaim -> UncheckedLtiTokenClaims)
-> Parser (Maybe LisClaim) -> Parser UncheckedLtiTokenClaims
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe LisClaim)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
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 [
              Text
claimMessageType Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
messageType
            , Text
claimVersion Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
ltiVersion
            , Text
claimDeploymentId Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
deploymentId
            , Text
claimTargetLinkUri Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
targetLinkUri
            , Text
claimRoles Text -> [Role] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Role]
roles
            , Text
"email" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
email
            , Text
"name" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
displayName
            , Text
"given_name" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
firstName
            , Text
"family_name" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
lastName
            , Text
claimContext Text -> Maybe ContextClaim -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe ContextClaim
context
            , Text
claimLis Text -> Maybe LisClaim -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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 (
               Text
claimMessageType Text -> Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
messageType
            Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text
claimVersion Text -> Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
ltiVersion
            Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text
claimDeploymentId Text -> Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
deploymentId
            Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text
claimTargetLinkUri Text -> Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
targetLinkUri
            Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text
claimRoles Text -> [Role] -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Role]
roles
            Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text
"email" Text -> Maybe Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
email
            Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text
"name" Text -> Maybe Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
displayName
            Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text
"given_name" Text -> Maybe Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
firstName
            Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text
"family_name" Text -> Maybe Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
lastName
            Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text
claimContext Text -> Maybe ContextClaim -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe ContextClaim
context
            Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text
claimLis Text -> Maybe LisClaim -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> 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 (Either Text (IdTokenClaims UncheckedLtiTokenClaims)
 -> Either Text (IdTokenClaims LtiTokenClaims))
-> (IdTokenClaims UncheckedLtiTokenClaims
    -> Either Text (IdTokenClaims UncheckedLtiTokenClaims))
-> IdTokenClaims UncheckedLtiTokenClaims
-> Either Text (IdTokenClaims LtiTokenClaims)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        (IdTokenClaims UncheckedLtiTokenClaims
-> Either Text (IdTokenClaims UncheckedLtiTokenClaims)
forall a a.
IsString a =>
IdTokenClaims a -> Either a (IdTokenClaims UncheckedLtiTokenClaims)
issuerMatches
         (IdTokenClaims UncheckedLtiTokenClaims
 -> Either Text (IdTokenClaims UncheckedLtiTokenClaims))
-> (IdTokenClaims UncheckedLtiTokenClaims
    -> Either Text (IdTokenClaims UncheckedLtiTokenClaims))
-> IdTokenClaims UncheckedLtiTokenClaims
-> Either Text (IdTokenClaims UncheckedLtiTokenClaims)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> IdTokenClaims UncheckedLtiTokenClaims
-> Either Text (IdTokenClaims UncheckedLtiTokenClaims)
forall a a.
IsString a =>
IdTokenClaims a -> Either a (IdTokenClaims UncheckedLtiTokenClaims)
audContainsClientId
         (IdTokenClaims UncheckedLtiTokenClaims
 -> Either Text (IdTokenClaims UncheckedLtiTokenClaims))
-> (IdTokenClaims UncheckedLtiTokenClaims
    -> Either Text (IdTokenClaims UncheckedLtiTokenClaims))
-> IdTokenClaims UncheckedLtiTokenClaims
-> Either Text (IdTokenClaims UncheckedLtiTokenClaims)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> IdTokenClaims UncheckedLtiTokenClaims
-> Either Text (IdTokenClaims UncheckedLtiTokenClaims)
forall a a.
IsString a =>
IdTokenClaims a -> Either a (IdTokenClaims UncheckedLtiTokenClaims)
hasNonce) (IdTokenClaims UncheckedLtiTokenClaims
 -> Either Text (IdTokenClaims LtiTokenClaims))
-> IdTokenClaims UncheckedLtiTokenClaims
-> Either Text (IdTokenClaims LtiTokenClaims)
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
            | IdTokenClaims a -> Text
forall a. IdTokenClaims a -> Text
iss IdTokenClaims a
c Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== PlatformInfo -> Text
platformIssuer PlatformInfo
pinfo
                = IdTokenClaims UncheckedLtiTokenClaims
-> Either a (IdTokenClaims UncheckedLtiTokenClaims)
forall a b. b -> Either a b
Right IdTokenClaims UncheckedLtiTokenClaims
claims
            | Bool
otherwise
                = a -> Either a (IdTokenClaims UncheckedLtiTokenClaims)
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.
            | [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length  (IdTokenClaims a -> [Text]
forall a. IdTokenClaims a -> [Text]
aud IdTokenClaims a
c) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& PlatformInfo -> Text
platformClientId PlatformInfo
pinfo Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` IdTokenClaims a -> [Text]
forall a. IdTokenClaims a -> [Text]
aud IdTokenClaims a
c
                = IdTokenClaims UncheckedLtiTokenClaims
-> Either a (IdTokenClaims UncheckedLtiTokenClaims)
forall a b. b -> Either a b
Right IdTokenClaims UncheckedLtiTokenClaims
claims
            | Bool
otherwise
                = a -> Either a (IdTokenClaims UncheckedLtiTokenClaims)
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 IdTokenClaims a -> Maybe ByteString
forall a. IdTokenClaims a -> Maybe ByteString
nonce IdTokenClaims a
c of
                Just ByteString
_  -> IdTokenClaims UncheckedLtiTokenClaims
-> Either a (IdTokenClaims UncheckedLtiTokenClaims)
forall a b. b -> Either a b
Right IdTokenClaims UncheckedLtiTokenClaims
claims
                Maybe ByteString
Nothing -> a -> Either a (IdTokenClaims UncheckedLtiTokenClaims)
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) = Text -> Either Text (IdTokenClaims LtiTokenClaims)
forall a b. a -> Either a b
Left Text
e
        valid (Right IdTokenClaims UncheckedLtiTokenClaims
tok) =
            IdTokenClaims LtiTokenClaims
-> Either Text (IdTokenClaims LtiTokenClaims)
forall a b. b -> Either a b
Right IdTokenClaims UncheckedLtiTokenClaims
tok { otherClaims :: LtiTokenClaims
otherClaims = UncheckedLtiTokenClaims -> LtiTokenClaims
LtiTokenClaims (UncheckedLtiTokenClaims -> LtiTokenClaims)
-> UncheckedLtiTokenClaims -> LtiTokenClaims
forall a b. (a -> b) -> a -> b
$ IdTokenClaims UncheckedLtiTokenClaims -> UncheckedLtiTokenClaims
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 (Int -> LTI13Exception -> String -> String
[LTI13Exception] -> String -> String
LTI13Exception -> String
(Int -> LTI13Exception -> String -> String)
-> (LTI13Exception -> String)
-> ([LTI13Exception] -> String -> String)
-> Show LTI13Exception
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [LTI13Exception] -> String -> String
$cshowList :: [LTI13Exception] -> String -> String
show :: LTI13Exception -> String
$cshow :: LTI13Exception -> String
showsPrec :: Int -> LTI13Exception -> String -> String
$cshowsPrec :: Int -> LTI13Exception -> String -> String
Show, Typeable)
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 -> String
jwksUrl                  :: String
    }

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

-- | Structure you have to provide defining integration points with your app
data AuthFlowConfig m = AuthFlowConfig
    { 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
    , AuthFlowConfig m -> ByteString -> m Bool
haveSeenNonce   :: Nonce -> m Bool
    , AuthFlowConfig m -> Text
myRedirectUri   :: Text
    , 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 :: HttpException -> m a
rethrow = LTI13Exception -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (LTI13Exception -> m a)
-> (HttpException -> LTI13Exception) -> HttpException -> m a
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 -> String -> IO [Jwk]
getJwkSet Manager
manager String
fromUrl = do
    ByteString
json <- String -> IO ByteString
getJwkSetJson String
fromUrl IO ByteString -> (HttpException -> IO ByteString) -> IO ByteString
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` HttpException -> IO ByteString
forall (m :: * -> *) a. MonadCatch m => HttpException -> m a
rethrow
    case ByteString -> Either String [Jwk]
jwks ByteString
json of
        Right [Jwk]
keys -> [Jwk] -> IO [Jwk]
forall (m :: * -> *) a. Monad m => a -> m a
return [Jwk]
keys
        Left  String
err  -> LTI13Exception -> IO [Jwk]
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (LTI13Exception -> IO [Jwk]) -> LTI13Exception -> IO [Jwk]
forall a b. (a -> b) -> a -> b
$ Text -> LTI13Exception
DiscoveryException (Text
"Failed to decode JwkSet: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err)
  where
    getJwkSetJson :: String -> IO ByteString
getJwkSetJson String
url = do
        Request
req <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url
        Response ByteString
res <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
manager
        ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
res

    jwks :: ByteString -> Either String [Jwk]
jwks ByteString
j = JwkSet -> [Jwk]
Jwk.keys (JwkSet -> [Jwk]) -> Either String JwkSet -> Either String [Jwk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String JwkSet
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
j

lookupOrThrow :: (MonadThrow m) => Text -> Map.Map Text Text -> m Text
lookupOrThrow :: Text -> Map Text Text -> m Text
lookupOrThrow Text
name Map Text Text
map_ =
    case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text Text
map_ of
        Maybe Text
Nothing -> LTI13Exception -> m Text
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (LTI13Exception -> m Text) -> LTI13Exception -> m Text
forall a b. (a -> b) -> a -> b
$ Text -> LTI13Exception
InvalidHandshake (Text -> LTI13Exception) -> Text -> LTI13Exception
forall a b. (a -> b) -> a -> b
$ Text
"Missing `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"`"
        Just Text
a  -> Text -> m Text
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 :: 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]
res <- IO [Text] -> m [Text]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Text] -> m [Text]) -> IO [Text] -> m [Text]
forall a b. (a -> b) -> a -> b
$ (Text -> IO Text) -> [Text] -> IO [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Text -> Map Text Text -> IO Text
forall (m :: * -> *).
MonadThrow m =>
Text -> Map Text Text -> m Text
`lookupOrThrow` Map Text Text
params) [Text
"iss", Text
"login_hint", Text
"target_link_uri"]
    -- not actually fallible
    let [Text
iss, Text
loginHint, Text
_] = [Text]
res
    let messageHint :: Maybe Text
messageHint = Text -> Map Text Text -> Maybe Text
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 = Text -> Map Text Text -> Maybe Text
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 } <- AuthFlowConfig m -> (Text, Maybe Text) -> m PlatformInfo
forall (m :: * -> *).
AuthFlowConfig m -> (Text, Maybe Text) -> m PlatformInfo
getPlatformInfo AuthFlowConfig m
cfg (Text
iss, Maybe Text
gotCid)

    let ss :: SessionStore m
ss = AuthFlowConfig m -> SessionStore m
forall (m :: * -> *). AuthFlowConfig m -> SessionStore m
sessionStore AuthFlowConfig m
cfg
    ByteString
nonce <- SessionStore m -> m ByteString
forall (m :: * -> *). SessionStore m -> m ByteString
sessionStoreGenerate SessionStore m
ss
    ByteString
state <- SessionStore m -> m ByteString
forall (m :: * -> *). SessionStore m -> m ByteString
sessionStoreGenerate SessionStore m
ss
    SessionStore m -> ByteString -> ByteString -> m ()
forall (m :: * -> *).
SessionStore m -> ByteString -> ByteString -> m ()
sessionStoreSave SessionStore m
ss ByteString
state ByteString
nonce

    let query :: Query
query = SimpleQuery -> Query
URI.simpleQueryToQuery (SimpleQuery -> Query) -> SimpleQuery -> Query
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 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ AuthFlowConfig m -> Text
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")
                ] SimpleQuery -> SimpleQuery -> SimpleQuery
forall a. [a] -> [a] -> [a]
++ SimpleQuery -> (Text -> SimpleQuery) -> Maybe Text -> SimpleQuery
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
mh -> [(ByteString
"lti_message_hint", Text -> ByteString
encodeUtf8 Text
mh)]) Maybe Text
messageHint
    (Text, Text, Text) -> m (Text, Text, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
iss, Text
clientId, Text
endpoint Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (ByteString -> Text
decodeUtf8 (ByteString -> Text) -> (Query -> ByteString) -> Query -> Text
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 = OIDC :: Text
-> Text
-> ByteString
-> ByteString
-> ByteString
-> Provider
-> OIDC
O.OIDC
        { oidcProvider :: Provider
O.oidcProvider = Provider :: Configuration -> [Jwk] -> Provider
P.Provider
                { configuration :: Configuration
P.configuration = Configuration :: Text
-> Text
-> Text
-> Maybe Text
-> Maybe Text
-> Text
-> [Text]
-> [Text]
-> [JwsAlgJson]
-> Maybe [Text]
-> Maybe [Text]
-> Maybe [Text]
-> Configuration
P.Configuration
                    { idTokenSigningAlgValuesSupported :: [JwsAlgJson]
P.idTokenSigningAlgValuesSupported = [ JwsAlg -> JwsAlgJson
P.JwsAlgJson JwsAlg
RS256 ]
                    , issuer :: Text
P.issuer = Text
forall a. HasCallStack => a
undefined
                    , authorizationEndpoint :: Text
P.authorizationEndpoint = Text
forall a. HasCallStack => a
undefined
                    , tokenEndpoint :: Text
P.tokenEndpoint = Text
forall a. HasCallStack => a
undefined
                    , userinfoEndpoint :: Maybe Text
P.userinfoEndpoint = Maybe Text
forall a. HasCallStack => a
undefined
                    , revocationEndpoint :: Maybe Text
P.revocationEndpoint = Maybe Text
forall a. HasCallStack => a
undefined
                    , jwksUri :: Text
P.jwksUri = Text
forall a. HasCallStack => a
undefined
                    , responseTypesSupported :: [Text]
P.responseTypesSupported = [Text]
forall a. HasCallStack => a
undefined
                    , subjectTypesSupported :: [Text]
P.subjectTypesSupported = [Text]
forall a. HasCallStack => a
undefined
                    , scopesSupported :: Maybe [Text]
P.scopesSupported = Maybe [Text]
forall a. HasCallStack => a
undefined
                    , tokenEndpointAuthMethodsSupported :: Maybe [Text]
P.tokenEndpointAuthMethodsSupported = Maybe [Text]
forall a. HasCallStack => a
undefined
                    , claimsSupported :: Maybe [Text]
P.claimsSupported = Maybe [Text]
forall a. HasCallStack => a
undefined
                    }
                , jwkSet :: [Jwk]
P.jwkSet = [Jwk]
jset
                }
        , oidcAuthorizationServerUrl :: Text
O.oidcAuthorizationServerUrl = Text
forall a. HasCallStack => a
undefined
        , oidcTokenEndpoint :: Text
O.oidcTokenEndpoint = Text
forall a. HasCallStack => a
undefined
        , oidcClientId :: ByteString
O.oidcClientId = ByteString
forall a. HasCallStack => a
undefined
        , oidcClientSecret :: ByteString
O.oidcClientSecret = ByteString
forall a. HasCallStack => a
undefined
        , oidcRedirectUri :: ByteString
O.oidcRedirectUri = ByteString
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 :: 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]
params' <- IO [Text] -> m [Text]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Text] -> m [Text]) -> IO [Text] -> m [Text]
forall a b. (a -> b) -> a -> b
$ (Text -> IO Text) -> [Text] -> IO [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Text -> Map Text Text -> IO Text
forall (m :: * -> *).
MonadThrow m =>
Text -> Map Text Text -> m Text
`lookupOrThrow` Map Text Text
params) [Text
"state", Text
"id_token"]
    let [Text
state, Text
idToken] = [Text]
params'

    let PlatformInfo { String
jwksUrl :: String
jwksUrl :: PlatformInfo -> String
jwksUrl } = PlatformInfo
pinfo
    [Jwk]
jwkSet <- IO [Jwk] -> m [Jwk]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Jwk] -> m [Jwk]) -> IO [Jwk] -> m [Jwk]
forall a b. (a -> b) -> a -> b
$ Manager -> String -> IO [Jwk]
getJwkSet Manager
mgr String
jwksUrl

    let ss :: SessionStore m
ss = AuthFlowConfig m -> SessionStore m
forall (m :: * -> *). AuthFlowConfig m -> SessionStore m
sessionStore AuthFlowConfig m
cfg
        oidc :: OIDC
oidc = [Jwk] -> OIDC
fakeOidc [Jwk]
jwkSet
    IdTokenClaims UncheckedLtiTokenClaims
toCheck <- SessionStore m
-> OIDC
-> ByteString
-> m ByteString
-> m (IdTokenClaims UncheckedLtiTokenClaims)
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) (ByteString -> m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> m ByteString) -> ByteString -> m ByteString
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 IdTokenClaims UncheckedLtiTokenClaims -> Maybe ByteString
forall a. IdTokenClaims a -> Maybe ByteString
nonce IdTokenClaims UncheckedLtiTokenClaims
toCheck of
        Just ByteString
n  -> AuthFlowConfig m -> ByteString -> m Bool
forall (m :: * -> *). AuthFlowConfig m -> ByteString -> m Bool
haveSeenNonce AuthFlowConfig m
cfg ByteString
n
        Maybe ByteString
Nothing -> IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ LTI13Exception -> IO Bool
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (LTI13Exception -> IO Bool) -> LTI13Exception -> IO Bool
forall a b. (a -> b) -> a -> b
$ Text -> LTI13Exception
InvalidLtiToken Text
"missing nonce"
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
nonceSeen (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ LTI13Exception -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (LTI13Exception -> IO ()) -> LTI13Exception -> IO ()
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  -> IO (Text, IdTokenClaims LtiTokenClaims)
-> m (Text, IdTokenClaims LtiTokenClaims)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Text, IdTokenClaims LtiTokenClaims)
 -> m (Text, IdTokenClaims LtiTokenClaims))
-> IO (Text, IdTokenClaims LtiTokenClaims)
-> m (Text, IdTokenClaims LtiTokenClaims)
forall a b. (a -> b) -> a -> b
$ LTI13Exception -> IO (Text, IdTokenClaims LtiTokenClaims)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (LTI13Exception -> IO (Text, IdTokenClaims LtiTokenClaims))
-> LTI13Exception -> IO (Text, IdTokenClaims LtiTokenClaims)
forall a b. (a -> b) -> a -> b
$ Text -> LTI13Exception
InvalidLtiToken Text
err
        Right IdTokenClaims LtiTokenClaims
tok -> (Text, IdTokenClaims LtiTokenClaims)
-> m (Text, IdTokenClaims LtiTokenClaims)
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 (UncheckedLtiTokenClaims -> AnonymizedLtiTokenClaims)
-> UncheckedLtiTokenClaims -> AnonymizedLtiTokenClaims
forall a b. (a -> b) -> a -> b
$ UncheckedLtiTokenClaims :: Text
-> Text
-> Text
-> Text
-> [Role]
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe ContextClaim
-> Maybe LisClaim
-> UncheckedLtiTokenClaims
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 = Text -> Text
forall p p. IsString p => p -> p
anonymized (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
displayName
        , firstName :: Maybe Text
firstName = Text -> Text
forall p p. IsString p => p -> p
anonymized (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
firstName
        , lastName :: Maybe Text
lastName = Text -> Text
forall p p. IsString p => p -> p
anonymized (Text -> Text) -> Maybe Text -> Maybe Text
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 = Text -> Text
forall p p. IsString p => p -> p
anonymized (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
email
        , lis :: Maybe LisClaim
lis = LisClaim -> LisClaim
anonymizedLis (LisClaim -> LisClaim) -> Maybe LisClaim -> Maybe LisClaim
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe LisClaim
lis
        }
    where
        anonymized :: p -> p
anonymized p
_ = p
"**"
        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 :: Maybe Text
-> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> LisClaim
LisClaim
            -- we really don't know what they will put in this; it might be
            -- student specific
            { personSourcedId :: Maybe Text
personSourcedId = Text -> Text
forall p p. IsString p => p -> p
anonymized (Text -> Text) -> Maybe Text -> Maybe Text
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 = Text -> Text
forall p p. IsString p => p -> p
anonymized (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
resultSourcedId
            }