diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /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 --- /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. + 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 100644 --- /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 --- /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 --- /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 + authentication protocol, + suitable for use in implementing libraries for any web framework. An example + use is +bug-reports: https://github.com/lf-/lti13/issues +license: LGPL-3 +author: Jade +maintainer: Jade +-- 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 --- /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 +-- +-- and +-- 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 + +-- | 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 +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 + -- if you get this, you should return a 401. + deriving (Show, Typeable) +instance Exception LTI13Exception + +-- | @client_id@, one or more per platform; +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 . + -- See also + , 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 +-- 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 +-- 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)