diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -19,3 +19,8 @@ ## 0.1.2.2 -- 2020-09-19 * We now parse the name fields + +## 0.2.0.0 -- 2021-01-09 + +* We parse the LIS claim +* Unit tests added diff --git a/lti13.cabal b/lti13.cabal --- a/lti13.cabal +++ b/lti13.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.10 name: lti13 -version: 0.1.2.2 +version: 0.2.0.0 synopsis: Core functionality for LTI 1.3. description: A library implementing the core authentication protocol, @@ -17,6 +17,22 @@ build-type: Simple extra-source-files: CHANGELOG.md README.md + +test-suite spec + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: tests + ghc-options: -Wall + main-is: Spec.hs + build-depends: base + , hspec + , QuickCheck + , file-embed + , th-utilities + , text + , bytestring + , aeson + , lti13 library exposed-modules: Web.LTI13 diff --git a/src/Web/LTI13.hs b/src/Web/LTI13.hs --- a/src/Web/LTI13.hs +++ b/src/Web/LTI13.hs @@ -4,8 +4,14 @@ -- | 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 +-- . Users will probably also find the helpful. module Web.LTI13 ( Role(..) + , LisClaim(..) , ContextClaim(..) , UncheckedLtiTokenClaims(..) , LtiTokenClaims(..) @@ -61,7 +67,7 @@ | Learner | Mentor | Other (Text) - deriving (Show) + deriving (Show, Eq) roleFromString :: Text -> Role roleFromString "http://purl.imsglobal.org/vocab/lis/v2/membership#Administrator" @@ -90,13 +96,59 @@ instance ToJSON Role where toJSON = A.String . roleToString +-- | LIS claim +data LisClaim = LisClaim + { personSourcedId :: Maybe Text + -- ^ LIS identifier for the person making the request. + , outcomeServiceUrl :: Maybe Text + -- ^ URL for the Basic Outcomes service, unique per-tool. + , courseOfferingSourcedId :: Maybe Text + -- ^ Identifier for the course + , courseSectionSourcedId :: Maybe Text + -- ^ Identifier for the section. + , resultSourcedId :: Maybe Text + -- ^ An identifier for the position in the gradebook associated with the + -- assignment being viewed. + } deriving (Show, Eq) + +instance FromJSON LisClaim where + parseJSON = withObject "LisClaim" $ \v -> + LisClaim + <$> v .:? "person_sourcedid" + <*> v .:? "outcome_service_url" + <*> v .:? "course_offering_sourcedid" + <*> v .:? "course_section_sourcedid" + <*> v .:? "result_sourcedid" + +instance ToJSON LisClaim where + toJSON (LisClaim {personSourcedId, outcomeServiceUrl, + courseOfferingSourcedId, courseSectionSourcedId, + resultSourcedId}) = + object [ + "person_sourcedid" .= personSourcedId + , "outcome_service_url" .= outcomeServiceUrl + , "course_offering_sourcedid" .= courseOfferingSourcedId + , "course_section_sourcedid" .= courseSectionSourcedId + , "result_sourcedid" .= resultSourcedId + ] + toEncoding (LisClaim {personSourcedId, outcomeServiceUrl, + courseOfferingSourcedId, courseSectionSourcedId, + resultSourcedId}) = + pairs ( + "person_sourcedid" .= personSourcedId <> + "outcome_service_url" .= outcomeServiceUrl <> + "course_offering_sourcedid" .= courseOfferingSourcedId <> + "course_section_sourcedid" .= courseSectionSourcedId <> + "result_sourcedid" .= resultSourcedId + ) + -- | context claim data ContextClaim = ContextClaim { contextId :: Text , contextLabel :: Maybe Text , contextTitle :: Maybe Text } - deriving (Show) + deriving (Show, Eq) instance FromJSON ContextClaim where parseJSON = withObject "ContextClaim" $ \v -> @@ -133,12 +185,13 @@ , firstName :: Maybe Text , lastName :: Maybe Text , context :: Maybe ContextClaim - } deriving (Show) + , lis :: Maybe LisClaim + } deriving (Show, Eq) -- | An object representing in the type system a token whose claims have been -- validated. newtype LtiTokenClaims = LtiTokenClaims UncheckedLtiTokenClaims - deriving (Show) + deriving (Show, Eq) limitLength :: (Fail.MonadFail m) => Int -> Text -> m Text limitLength len string @@ -158,6 +211,8 @@ claimRoles = "https://purl.imsglobal.org/spec/lti/claim/roles" claimContext :: Text claimContext = "https://purl.imsglobal.org/spec/lti/claim/context" +claimLis :: Text +claimLis = "https://purl.imsglobal.org/spec/lti/claim/lis" instance FromJSON UncheckedLtiTokenClaims where parseJSON = withObject "LtiTokenClaims" $ \v -> @@ -172,12 +227,13 @@ <*> v .:? "given_name" <*> v .:? "family_name" <*> v .:? claimContext + <*> v .:? claimLis instance ToJSON UncheckedLtiTokenClaims where toJSON (UncheckedLtiTokenClaims { messageType, ltiVersion, deploymentId , targetLinkUri, roles, email, displayName - , firstName, lastName, context}) = + , firstName, lastName, context, lis}) = object [ claimMessageType .= messageType , claimVersion .= ltiVersion @@ -189,11 +245,12 @@ , "given_name" .= firstName , "family_name" .= lastName , claimContext .= context + , claimLis .= lis ] toEncoding (UncheckedLtiTokenClaims { messageType, ltiVersion, deploymentId , targetLinkUri, roles, email, displayName - , firstName, lastName, context}) = + , firstName, lastName, context, lis}) = pairs ( claimMessageType .= messageType <> claimVersion .= ltiVersion @@ -205,6 +262,7 @@ <> "given_name" .= firstName <> "family_name" .= lastName <> claimContext .= context + <> claimLis .= lis ) -- | A direct implementation of diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,2 @@ +-- from https://blog.nikosbaxevanis.com/2015/01/30/quickcheck-setup-in-haskell/ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}