summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjade <>2020-09-15 21:41:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-09-15 21:41:00 (GMT)
commit0780e679a07fe241ada5104c12320c7d9c1397df (patch)
tree1eb30cb04b12fb9740b0b5995e89f0c08e49b5e8
version 0.1.1.00.1.1.0
-rwxr-xr-xCHANGELOG.md9
-rw-r--r--LICENSE165
-rwxr-xr-xREADME.md17
-rw-r--r--Setup.hs2
-rw-r--r--lti13.cabal41
-rw-r--r--src/Web/LTI13.hs421
6 files changed, 655 insertions, 0 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100755
index 0000000..ca53571
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,9 @@
+# Revision history for lti13
+
+## 0.1.0.0 -- 2020-08-13
+
+* Unreleased
+
+## 0.1.1.0 -- 2020-09-15
+
+* Handle Canvas Cloud setting all their issuers the same.
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..0a04128
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,165 @@
+ GNU LESSER GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+
+ This version of the GNU Lesser General Public License incorporates
+the terms and conditions of version 3 of the GNU General Public
+License, supplemented by the additional permissions listed below.
+
+ 0. Additional Definitions.
+
+ As used herein, "this License" refers to version 3 of the GNU Lesser
+General Public License, and the "GNU GPL" refers to version 3 of the GNU
+General Public License.
+
+ "The Library" refers to a covered work governed by this License,
+other than an Application or a Combined Work as defined below.
+
+ An "Application" is any work that makes use of an interface provided
+by the Library, but which is not otherwise based on the Library.
+Defining a subclass of a class defined by the Library is deemed a mode
+of using an interface provided by the Library.
+
+ A "Combined Work" is a work produced by combining or linking an
+Application with the Library. The particular version of the Library
+with which the Combined Work was made is also called the "Linked
+Version".
+
+ The "Minimal Corresponding Source" for a Combined Work means the
+Corresponding Source for the Combined Work, excluding any source code
+for portions of the Combined Work that, considered in isolation, are
+based on the Application, and not on the Linked Version.
+
+ The "Corresponding Application Code" for a Combined Work means the
+object code and/or source code for the Application, including any data
+and utility programs needed for reproducing the Combined Work from the
+Application, but excluding the System Libraries of the Combined Work.
+
+ 1. Exception to Section 3 of the GNU GPL.
+
+ You may convey a covered work under sections 3 and 4 of this License
+without being bound by section 3 of the GNU GPL.
+
+ 2. Conveying Modified Versions.
+
+ If you modify a copy of the Library, and, in your modifications, a
+facility refers to a function or data to be supplied by an Application
+that uses the facility (other than as an argument passed when the
+facility is invoked), then you may convey a copy of the modified
+version:
+
+ a) under this License, provided that you make a good faith effort to
+ ensure that, in the event an Application does not supply the
+ function or data, the facility still operates, and performs
+ whatever part of its purpose remains meaningful, or
+
+ b) under the GNU GPL, with none of the additional permissions of
+ this License applicable to that copy.
+
+ 3. Object Code Incorporating Material from Library Header Files.
+
+ The object code form of an Application may incorporate material from
+a header file that is part of the Library. You may convey such object
+code under terms of your choice, provided that, if the incorporated
+material is not limited to numerical parameters, data structure
+layouts and accessors, or small macros, inline functions and templates
+(ten or fewer lines in length), you do both of the following:
+
+ a) Give prominent notice with each copy of the object code that the
+ Library is used in it and that the Library and its use are
+ covered by this License.
+
+ b) Accompany the object code with a copy of the GNU GPL and this license
+ document.
+
+ 4. Combined Works.
+
+ You may convey a Combined Work under terms of your choice that,
+taken together, effectively do not restrict modification of the
+portions of the Library contained in the Combined Work and reverse
+engineering for debugging such modifications, if you also do each of
+the following:
+
+ a) Give prominent notice with each copy of the Combined Work that
+ the Library is used in it and that the Library and its use are
+ covered by this License.
+
+ b) Accompany the Combined Work with a copy of the GNU GPL and this license
+ document.
+
+ c) For a Combined Work that displays copyright notices during
+ execution, include the copyright notice for the Library among
+ these notices, as well as a reference directing the user to the
+ copies of the GNU GPL and this license document.
+
+ d) Do one of the following:
+
+ 0) Convey the Minimal Corresponding Source under the terms of this
+ License, and the Corresponding Application Code in a form
+ suitable for, and under terms that permit, the user to
+ recombine or relink the Application with a modified version of
+ the Linked Version to produce a modified Combined Work, in the
+ manner specified by section 6 of the GNU GPL for conveying
+ Corresponding Source.
+
+ 1) Use a suitable shared library mechanism for linking with the
+ Library. A suitable mechanism is one that (a) uses at run time
+ a copy of the Library already present on the user's computer
+ system, and (b) will operate properly with a modified version
+ of the Library that is interface-compatible with the Linked
+ Version.
+
+ e) Provide Installation Information, but only if you would otherwise
+ be required to provide such information under section 6 of the
+ GNU GPL, and only to the extent that such information is
+ necessary to install and execute a modified version of the
+ Combined Work produced by recombining or relinking the
+ Application with a modified version of the Linked Version. (If
+ you use option 4d0, the Installation Information must accompany
+ the Minimal Corresponding Source and Corresponding Application
+ Code. If you use option 4d1, you must provide the Installation
+ Information in the manner specified by section 6 of the GNU GPL
+ for conveying Corresponding Source.)
+
+ 5. Combined Libraries.
+
+ You may place library facilities that are a work based on the
+Library side by side in a single library together with other library
+facilities that are not Applications and are not covered by this
+License, and convey such a combined library under terms of your
+choice, if you do both of the following:
+
+ a) Accompany the combined library with a copy of the same work based
+ on the Library, uncombined with any other library facilities,
+ conveyed under the terms of this License.
+
+ b) Give prominent notice with the combined library that part of it
+ is a work based on the Library, and explaining where to find the
+ accompanying uncombined form of the same work.
+
+ 6. Revised Versions of the GNU Lesser General Public License.
+
+ The Free Software Foundation may publish revised and/or new versions
+of the GNU Lesser General Public License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Library as you received it specifies that a certain numbered version
+of the GNU Lesser General Public License "or any later version"
+applies to it, you have the option of following the terms and
+conditions either of that published version or of any later version
+published by the Free Software Foundation. If the Library as you
+received it does not specify a version number of the GNU Lesser
+General Public License, you may choose any version of the GNU Lesser
+General Public License ever published by the Free Software Foundation.
+
+ If the Library as you received it specifies that a proxy can decide
+whether future versions of the GNU Lesser General Public License shall
+apply, that proxy's public statement of acceptance of any version is
+permanent authorization for you to choose that version for the
+Library.
diff --git a/README.md b/README.md
new file mode 100755
index 0000000..0b5a610
--- /dev/null
+++ b/README.md
@@ -0,0 +1,17 @@
+# lti13
+
+This is a minimal implementation of LTI 1.3 authentication for Haskell. It
+supports performing LTI launches and getting most of the interesting fields of
+the [resource link request](http://www.imsglobal.org/spec/lti/v1p3/#examplelinkrequest).
+
+This library is intended to be used in developing integrations with web
+frameworks, although it can be used directly. A sample integration is
+[yesod-auth-lti13](https://hackage.haskell.org/package/yesod-auth-lti13).
+
+## Correct usage
+
+Client code is expected to maintain a CSRF token, the `state` parameter, in
+session storage and check it is the same as the one from `handleAuthResponse`,
+failing authentication if it is not. Future versions of the library may
+introduce a mandatory callback to ensure clients do this. For an example of
+this, see the yesod-auth-lti13 sources.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/lti13.cabal b/lti13.cabal
new file mode 100644
index 0000000..5263b87
--- /dev/null
+++ b/lti13.cabal
@@ -0,0 +1,41 @@
+cabal-version: >=1.10
+
+name: lti13
+version: 0.1.1.0
+synopsis: Core functionality for LTI 1.3.
+description: A library implementing the core
+ <http://www.imsglobal.org/spec/lti/v1p3/ LTI 1.3> authentication protocol,
+ suitable for use in implementing libraries for any web framework. An example
+ use is <https://hackage.haskell.org/package/yesod-auth-lti13>
+bug-reports: https://github.com/lf-/lti13/issues
+license: LGPL-3
+author: Jade
+maintainer: Jade <software at lfcode dot ca>
+-- copyright:
+category: Web
+license-file: LICENSE
+build-type: Simple
+extra-source-files: CHANGELOG.md
+ README.md
+
+library
+ exposed-modules: Web.LTI13
+ -- other-modules:
+ -- other-extensions:
+ hs-source-dirs: src
+ build-depends: aeson >= 1.4.7 && < 1.5
+ , base >= 4.12.0 && < 5
+ , bytestring >= 0.10.10 && < 0.11
+ , containers >= 0.6.2 && < 0.7
+ , text >= 1.2.4 && < 1.3
+ , http-client >= 0.6.4 && < 0.7
+ , http-types >= 0.12.3 && < 0.13
+ , jose-jwt >= 0.8.0 && < 0.9
+ , oidc-client >= 0.5.1 && < 0.6
+ , safe-exceptions >= 0.1.7 && < 0.2
+ default-language: Haskell2010
+ ghc-options: -Wall
+
+source-repository head
+ type: git
+ location: https://github.com/lf-/lti13
diff --git a/src/Web/LTI13.hs b/src/Web/LTI13.hs
new file mode 100644
index 0000000..296ae2f
--- /dev/null
+++ b/src/Web/LTI13.hs
@@ -0,0 +1,421 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+-- | 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.
+module Web.LTI13 (
+ Role(..)
+ , ContextClaim(..)
+ , UncheckedLtiTokenClaims(..)
+ , LtiTokenClaims(..)
+ , validateLtiToken
+ , LTI13Exception(..)
+ , PlatformInfo(..)
+ , Issuer
+ , ClientId
+ , SessionStore(..)
+ , AuthFlowConfig(..)
+ , RequestParams
+ , initiate
+ , handleAuthResponse
+ ) where
+import qualified Web.OIDC.Client.Settings as O
+import qualified Web.OIDC.Client.Discovery.Provider as P
+import Web.OIDC.Client.Tokens (nonce, aud, otherClaims, iss, IdTokenClaims)
+import Web.OIDC.Client.IdTokenFlow (getValidIdTokenClaims)
+import Web.OIDC.Client.Types (Nonce, SessionStore(..))
+import Jose.Jwa (JwsAlg(RS256))
+import qualified Jose.Jwk as Jwk
+import Control.Monad (when, (>=>))
+import Control.Exception.Safe (MonadCatch, catch, throwM, Typeable, Exception, MonadThrow, throw)
+import Control.Monad.IO.Class (liftIO, MonadIO)
+import Data.Aeson (eitherDecode, FromJSON (parseJSON), ToJSON(toJSON, toEncoding), Object,
+ object, pairs, withObject, withText, (.:), (.:?), (.=))
+import qualified Data.Aeson as A
+import Data.Aeson.Types (Parser)
+import Data.Text (Text)
+import qualified Network.HTTP.Types.URI as URI
+import Network.HTTP.Client (responseBody, Manager, HttpException, parseRequest, httpLbs)
+import qualified Data.Map.Strict as Map
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8, decodeUtf8)
+
+-- | 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 obj field fixedVal =
+ obj .: field >>= \v ->
+ if v == fixedVal then
+ return v
+ else
+ fail $ "field " ++ (show field) ++ " was not the required value " ++ (show 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 (Show)
+
+roleFromString :: Text -> Role
+roleFromString "http://purl.imsglobal.org/vocab/lis/v2/membership#Administrator"
+ = Administrator
+roleFromString "http://purl.imsglobal.org/vocab/lis/v2/membership#ContentDeveloper"
+ = ContentDeveloper
+roleFromString "http://purl.imsglobal.org/vocab/lis/v2/membership#Instructor"
+ = Instructor
+roleFromString "http://purl.imsglobal.org/vocab/lis/v2/membership#Learner"
+ = Learner
+roleFromString "http://purl.imsglobal.org/vocab/lis/v2/membership#Mentor"
+ = Mentor
+roleFromString s = Other s
+
+roleToString :: Role -> Text
+roleToString Administrator = "http://purl.imsglobal.org/vocab/lis/v2/membership#Administrator"
+roleToString ContentDeveloper = "http://purl.imsglobal.org/vocab/lis/v2/membership#ContentDeveloper"
+roleToString Instructor = "http://purl.imsglobal.org/vocab/lis/v2/membership#Instructor"
+roleToString Learner = "http://purl.imsglobal.org/vocab/lis/v2/membership#Learner"
+roleToString Mentor = "http://purl.imsglobal.org/vocab/lis/v2/membership#Mentor"
+roleToString (Other s) = s
+
+instance FromJSON Role where
+ parseJSON = withText "Role" $ return . roleFromString
+
+instance ToJSON Role where
+ toJSON = A.String . roleToString
+
+-- | <http://www.imsglobal.org/spec/lti/v1p3/#context-claim LTI spec § 5.4.1> context claim
+data ContextClaim = ContextClaim
+ { contextId :: Text
+ , contextLabel :: Maybe Text
+ , contextTitle :: Maybe Text
+ }
+ deriving (Show)
+
+instance FromJSON ContextClaim where
+ parseJSON = withObject "ContextClaim" $ \v ->
+ ContextClaim
+ <$> (v .: "id" >>= limitLength 255)
+ <*> v .:? "label"
+ <*> v .:? "title"
+
+instance ToJSON ContextClaim where
+ toJSON (ContextClaim {contextId, contextLabel, contextTitle}) =
+ object [
+ "id" .= contextId
+ , "label" .= contextLabel
+ , "title" .= contextTitle
+ ]
+ toEncoding (ContextClaim {contextId, contextLabel, contextTitle}) =
+ pairs (
+ "id" .= contextId <>
+ "label" .= contextLabel <>
+ "title" .= 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
+ { messageType :: Text
+ , ltiVersion :: Text
+ , deploymentId :: Text
+ , targetLinkUri :: Text
+ , roles :: [Role]
+ , email :: Maybe Text
+ , context :: Maybe ContextClaim
+ } deriving (Show)
+
+-- | An object representing in the type system a token whose claims have been
+-- validated.
+newtype LtiTokenClaims = LtiTokenClaims UncheckedLtiTokenClaims
+ deriving (Show)
+
+limitLength :: (MonadFail m) => Int -> Text -> m Text
+limitLength len string
+ | (T.length string) <= len
+ = return string
+limitLength _ _ = fail "String is too long"
+
+claimMessageType :: Text
+claimMessageType = "https://purl.imsglobal.org/spec/lti/claim/message_type"
+claimVersion :: Text
+claimVersion = "https://purl.imsglobal.org/spec/lti/claim/version"
+claimDeploymentId :: Text
+claimDeploymentId = "https://purl.imsglobal.org/spec/lti/claim/deployment_id"
+claimTargetLinkUri :: Text
+claimTargetLinkUri = "https://purl.imsglobal.org/spec/lti/claim/target_link_uri"
+claimRoles :: Text
+claimRoles = "https://purl.imsglobal.org/spec/lti/claim/roles"
+claimContext :: Text
+claimContext = "https://purl.imsglobal.org/spec/lti/claim/context"
+
+instance FromJSON UncheckedLtiTokenClaims where
+ parseJSON = withObject "LtiTokenClaims" $ \v ->
+ UncheckedLtiTokenClaims
+ <$> (parseFixed v claimMessageType "LtiResourceLinkRequest")
+ <*> (parseFixed v claimVersion "1.3.0")
+ <*> (v .: claimDeploymentId >>= limitLength 255)
+ <*> v .: claimTargetLinkUri
+ <*> v .: claimRoles
+ <*> v .:? "email"
+ <*> v .:? claimContext
+
+instance ToJSON UncheckedLtiTokenClaims where
+ toJSON (UncheckedLtiTokenClaims {
+ messageType, ltiVersion, deploymentId
+ , targetLinkUri, roles, email, context}) =
+ object [
+ claimMessageType .= messageType
+ , claimVersion .= ltiVersion
+ , claimDeploymentId .= deploymentId
+ , claimTargetLinkUri .= targetLinkUri
+ , claimRoles .= roles
+ , "email" .= email
+ , claimContext .= context
+ ]
+ toEncoding (UncheckedLtiTokenClaims {
+ messageType, ltiVersion, deploymentId
+ , targetLinkUri, roles, email, context}) =
+ pairs (
+ claimMessageType .= messageType
+ <> claimVersion .= ltiVersion
+ <> claimDeploymentId .= deploymentId
+ <> claimTargetLinkUri .= targetLinkUri
+ <> claimRoles .= roles
+ <> "email" .= email
+ <> claimContext .= context
+ )
+
+-- | 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 pinfo claims =
+ valid .
+ (issuerMatches
+ >=> audContainsClientId
+ >=> hasNonce) $ claims
+ where
+ -- step 1 handled before we are called
+ -- step 2
+ issuerMatches c
+ | iss c == platformIssuer pinfo
+ = Right claims
+ | otherwise
+ = Left "issuer does not match platform issuer"
+ -- step 3
+ audContainsClientId 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.
+ | (length $ aud c) == 1 && (platformClientId pinfo) `elem` (aud c)
+ = Right claims
+ | otherwise
+ = Left "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 c =
+ case nonce c of
+ Just _ -> Right claims
+ Nothing -> Left "nonce missing"
+ valid :: Either Text (IdTokenClaims UncheckedLtiTokenClaims) -> Either Text (IdTokenClaims LtiTokenClaims)
+ -- unwrap a validated token and rewrap it as a valid token
+ valid (Left e) = Left e
+ valid (Right tok) =
+ Right tok { otherClaims = (LtiTokenClaims $ otherClaims 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 (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
+ platformIssuer :: Issuer
+ -- | @client_id@
+ , 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>
+ , platformOidcAuthEndpoint :: Text
+ -- | URL for a JSON object containing the JWK signing keys for the platform
+ , jwksUrl :: String
+ }
+
+-- | Issuer/@iss@ field
+type Issuer = Text
+
+-- | Object you have to provide defining integration points with your app
+data AuthFlowConfig m = AuthFlowConfig
+ { getPlatformInfo :: (Issuer, Maybe ClientId) -> m PlatformInfo
+ -- ^ Access some persistent storage of the configured platforms and return the
+ -- PlatformInfo for a given platform by name
+ , haveSeenNonce :: Nonce -> m Bool
+ , myRedirectUri :: Text
+ , 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 = throwM . GotHttpException
+
+-- | Grab the JWK set from a URL
+getJwkSet
+ :: Manager
+ -> String
+ -> IO [Jwk.Jwk]
+getJwkSet manager fromUrl = do
+ json <- getJwkSetJson fromUrl `catch` rethrow
+ case jwks json of
+ Right keys -> return keys
+ Left err -> throwM $ DiscoveryException ("Failed to decode JwkSet: " <> T.pack err)
+ where
+ getJwkSetJson url = do
+ req <- parseRequest url
+ res <- httpLbs req manager
+ return $ responseBody res
+
+ jwks j = Jwk.keys <$> eitherDecode j
+
+lookupOrThrow :: (MonadThrow m) => Text -> Map.Map Text Text -> m Text
+lookupOrThrow name map_ =
+ case Map.lookup name map_ of
+ Nothing -> throw $ InvalidHandshake $ "Missing `" <> name <> "`"
+ Just a -> return 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 cfg params = do
+ -- we don't care about target link uri since we only support one endpoint
+ res <- liftIO $ mapM (flip lookupOrThrow params) ["iss", "login_hint", "target_link_uri"]
+ -- not actually fallible
+ let [iss, loginHint, _] = res
+ let messageHint = Map.lookup "lti_message_hint" 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 = Map.lookup "client_id" params
+ PlatformInfo
+ { platformOidcAuthEndpoint = endpoint
+ , platformClientId = clientId } <- (getPlatformInfo cfg) (iss, gotCid)
+
+ let ss = sessionStore cfg
+ nonce <- sessionStoreGenerate ss
+ state <- sessionStoreGenerate ss
+ sessionStoreSave ss state nonce
+
+ let query = URI.simpleQueryToQuery $
+ [ ("scope", "openid")
+ , ("response_type", "id_token")
+ , ("client_id", encodeUtf8 clientId)
+ , ("redirect_uri", encodeUtf8 $ myRedirectUri cfg)
+ , ("login_hint", encodeUtf8 loginHint)
+ , ("state", state)
+ , ("response_mode", "form_post")
+ , ("nonce", nonce)
+ , ("prompt", "none")
+ ] ++ maybe [] (\mh -> [("lti_message_hint", encodeUtf8 mh)]) messageHint
+ return $ (iss, clientId, endpoint <> (decodeUtf8 . URI.renderQuery True) query)
+
+-- | Makes a fake OIDC object with the bare minimum attributes to hand to
+-- verification library functions
+fakeOidc :: [Jwk.Jwk] -> O.OIDC
+fakeOidc jset = O.OIDC
+ { O.oidcProvider = P.Provider
+ { P.configuration = P.Configuration
+ { P.idTokenSigningAlgValuesSupported = [ P.JwsAlgJson RS256 ]
+ , P.issuer = undefined
+ , P.authorizationEndpoint = undefined
+ , P.tokenEndpoint = undefined
+ , P.userinfoEndpoint = undefined
+ , P.revocationEndpoint = undefined
+ , P.jwksUri = undefined
+ , P.responseTypesSupported = undefined
+ , P.subjectTypesSupported = undefined
+ , P.scopesSupported = undefined
+ , P.tokenEndpointAuthMethodsSupported = undefined
+ , P.claimsSupported = undefined
+ }
+ , P.jwkSet = jset
+ }
+ , O.oidcAuthorizationServerUrl = undefined
+ , O.oidcTokenEndpoint = undefined
+ , O.oidcClientId = undefined
+ , O.oidcClientSecret = undefined
+ , O.oidcRedirectUri = 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 mgr cfg params pinfo = do
+ params' <- liftIO $ mapM (flip lookupOrThrow params) ["state", "id_token"]
+ let [state, idToken] = params'
+
+ let PlatformInfo { jwksUrl } = pinfo
+ jwkSet <- liftIO $ getJwkSet mgr jwksUrl
+
+ let ss = sessionStore cfg
+ oidc = fakeOidc jwkSet
+ toCheck <- getValidIdTokenClaims ss oidc (encodeUtf8 state) (pure $ encodeUtf8 idToken)
+
+ -- present nonce but seen -> error
+ -- present nonce unseen -> good
+ -- absent nonce -> different error
+ nonceSeen <- case nonce toCheck of
+ Just n -> haveSeenNonce cfg n
+ Nothing -> liftIO $ throw $ InvalidLtiToken "missing nonce"
+ when nonceSeen (liftIO $ throw $ InvalidLtiToken "nonce seen before")
+
+ case validateLtiToken pinfo toCheck of
+ Left err -> liftIO $ throw $ InvalidLtiToken err
+ Right tok -> return (state, tok)