ltiv1p1 (empty) → 1.0
raw patch · 4 files changed
+352/−0 lines, 4 filesdep +authenticate-oauthdep +basedep +blaze-buildersetup-changed
Dependencies added: authenticate-oauth, base, blaze-builder, bytestring, containers, data-default, http-client, http-types, random, text, time, transformers, wai, wai-extra, xml-conduit, xml-hamlet, yesod-core
Files
- LICENSE +7/−0
- Setup.hs +2/−0
- ltiv1p1.cabal +43/−0
- src/Web/LTI.hs +300/−0
+ LICENSE view
@@ -0,0 +1,7 @@+Copyright (c) 2016 Artem M. Chirkin++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ltiv1p1.cabal view
@@ -0,0 +1,43 @@+name: ltiv1p1+version: 1.0+cabal-version: 1.12+build-type: Simple+license: MIT+license-file: LICENSE+copyright: (c) Artem Chirkin+maintainer: Artem Chirkin <chirkin@arch.ethz.ch>+stability: experimental+homepage: http://ia.arch.ethz.ch/+bug-reports: mailto:chirkin@arch.ethz.ch+synopsis: Partial implementation of a service provider for LTI 1.1.+description:+ Service provider implementation for IMS Global Learning Tools Interoperability™ 1.1.+ Mean to be used for LTI components at edX.+category: network+author: Artem Chirkin++library+ exposed-modules:+ Web.LTI+ build-depends:+ base >=4 && <5,+ bytestring >=0.10.6.0,+ xml-hamlet >=0.4.0.11 && <0.5,+ xml-conduit >=1.3.4 && <1.4,+ text >=1.2.2.0 && <1.3,+ authenticate-oauth >=1.6,+ containers >=0.5.6.2 && <0.6,+ http-client >=0.4.27 && <0.4.29,+ http-types >=0.9 && <0.10,+ transformers >=0.4.2.0 && <0.5,+ blaze-builder >=0.4.0.1 && <0.5,+ wai >=3.2.0 && <3.3,+ wai-extra >=3.0.7,+ time >=1.5.0.1 && <1.6,+ random >=1.1 && <1.2,+ data-default >=0.5.3 && <0.6,+ yesod-core >=1.4.19 && <1.5+ default-language: Haskell2010+ hs-source-dirs: src+ ghc-options: -Wall -ferror-spans+
+ src/Web/LTI.hs view
@@ -0,0 +1,300 @@+-----------------------------------------------------------------------------+-- |+-- Module : Web.LTI+-- Copyright : (c) Artem Chirkin+-- License : MIT+--+-- Maintainer : Artem Chirkin <chirkin@arch.ethz.ch>+-- Stability : experimental+--+-- Provide services to LTI 1.1 consumers, such as edX.+--+-----------------------------------------------------------------------------+{-# LANGUAGE TemplateHaskell, OverloadedStrings, QuasiQuotes #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-}++module Web.LTI+ ( -- * Data types+ LTIProvider, ltiOAuth, newLTIProvider+ , LTIException (..)+ -- * simplifiers+ , gradeRequest+ -- * Incoming requests+ , processRequest, processWaiRequest, processYesodRequest+ -- * Outgoing requests+ , replaceResultRequest+ ) where++import Blaze.ByteString.Builder (toByteString)+import Control.Arrow ((***))+import Control.Exception+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Except+import Data.ByteString (ByteString)+import qualified Data.ByteString as SB+import qualified Data.ByteString.Char8 as SBC+import qualified Data.ByteString.Lazy as LB+import Data.Data (Data, Typeable)+import Data.Default+import qualified Data.IORef as I+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Time.Clock.POSIX (getPOSIXTime)+import Web.Authenticate.OAuth (OAuth, OAuthException)+import qualified Web.Authenticate.OAuth as OAuth+import Text.Hamlet.XML+import Text.XML+import qualified Network.HTTP.Client as HTTP+import qualified Network.HTTP.Types as HTTP (renderSimpleQuery, parseSimpleQuery)+import qualified Network.Wai as Wai+import qualified Network.Wai.Request as Wai+import qualified Yesod.Core as Yesod+import System.Random (Random(..))+++-- | LTI 1.1 Service provider+newtype LTIProvider = LTIProvider+ { ltiOAuth :: OAuth -- ^ OAuth credentials of provider+ }++instance Default LTIProvider where+ def = LTIProvider+ { ltiOAuth = def+ { OAuth.oauthServerName = "LTI 1.1 consumer"+ , OAuth.oauthSignatureMethod = OAuth.HMACSHA1+ , OAuth.oauthVersion = OAuth.OAuth10+ }+ }++-- | Create a new default LTIProvider with given provider token and secret+newLTIProvider :: ByteString+ -> ByteString+ -> LTIProvider+newLTIProvider token secret = p+ { ltiOAuth = (ltiOAuth p)+ { OAuth.oauthConsumerKey = token+ , OAuth.oauthConsumerSecret = secret+ }+ } where p = def++-- | Either LTI or OAuth exception+data LTIException+ = LTIOAuthException OAuthException+ | LTIException String+ deriving (Show, Eq, Data, Typeable)++instance Exception LTIException++----------------------------------------------------------------------------------------------------++-- | Get url encoded data from Network.HTTP.Client.Request+processRequest :: MonadIO m+ => LTIProvider+ -> HTTP.Request+ -> ExceptT LTIException m (Map ByteString ByteString)+processRequest prov req = toBS (HTTP.requestBody req)+ >>= processRequest' prov req++-- | Get url encoded data from Network.Wai.Request+processWaiRequest :: MonadIO m+ => LTIProvider+ -> Wai.Request+ -> ExceptT LTIException m (Map ByteString ByteString)+processWaiRequest prov wreq = do+ (req, rbody) <- convert wreq+ processRequest' prov req $ LB.toStrict rbody+ where+ convert wr = do+ body <- liftIO $ Wai.strictRequestBody wr+ return (convertRequest wr $ HTTP.RequestBodyLBS body, body)++-- | Get url encoded data from Network.Wai.Request+processYesodRequest :: (MonadIO m, Yesod.MonadHandler m)+ => LTIProvider+ -> Yesod.YesodRequest+ -> ExceptT LTIException m (Map ByteString ByteString)+processYesodRequest prov yreq = ExceptT $ do+ (req, rbody) <- convert yreq+ runExceptT $ processRequest' prov req rbody+ where+ convert yr = do+ body <- HTTP.renderSimpleQuery False+ . map (Text.encodeUtf8 *** Text.encodeUtf8)+ . fst <$> Yesod.runRequestBody+ return (convertRequest wr $ HTTP.RequestBodyBS body, body)+ where+ wr = Yesod.reqWaiRequest yr++convertRequest :: Wai.Request+ -> HTTP.RequestBody+ -> HTTP.Request+convertRequest wr rbody = def+ { HTTP.method = Wai.requestMethod wr+ , HTTP.secure = Wai.appearsSecure wr+ , HTTP.host = whost+ , HTTP.port = wport+ , HTTP.path = Wai.rawPathInfo wr+ , HTTP.queryString = Wai.rawQueryString wr+ , HTTP.requestBody = rbody+ , HTTP.requestHeaders = Wai.requestHeaders wr+ } where+ (whost,wport) = case SBC.span (':' /=) <$> Wai.requestHeaderHost wr of+ Just (h, "") -> (h, if Wai.appearsSecure wr then 443 else 80)+ Just (h, po) -> (h, read . SBC.unpack $ SB.drop 1 po)+ _ -> ("localhost", 80)++processRequest' :: MonadIO m+ => LTIProvider+ -> HTTP.Request+ -> ByteString+ -> ExceptT LTIException m (Map ByteString ByteString)+processRequest' prov req rbody = Map.fromList (HTTP.parseSimpleQuery rbody) <$+ withExceptT LTIOAuthException+ (OAuth.checkOAuth (ltiOAuth prov) OAuth.emptyCredential req)++----------------------------------------------------------------------------------------------------++-- | Being supplied with processRequest function+-- creates a proper grade response to the service consumer.+gradeRequest :: MonadIO m+ => LTIProvider+ -> (LTIProvider -> request -> ExceptT LTIException m (Map ByteString ByteString))+ -- ^ processRequest or processWaiRequest+ -> request+ -- ^ request value (e.g. from Network.HTTP.Client or Network.Wai)+ -> ExceptT LTIException m+ ( Double -> HTTP.Manager -> m (HTTP.Response LB.ByteString)+ , Map ByteString ByteString+ )+ -- ^ returns a grading function and a request parameter map+gradeRequest prov proc req = do+ pams <- proc prov req+ let murl = SBC.unpack <$> Map.lookup "lis_outcome_service_url" pams+ msid = Text.decodeUtf8 <$> Map.lookup "lis_result_sourcedid" pams+ case (murl,msid) of+ (Nothing, _) -> liftIO . throwIO $ LTIException+ "Client request does not contain lis_outcome_service_url."+ (_, Nothing) -> liftIO . throwIO $ LTIException+ "Client request does not contain lis_result_sourcedid."+ (Just url, Just sid) ->+ return ( \r m -> do+ gr <- replaceResultRequest prov url sid r Nothing+ liftIO $ HTTP.httpLbs gr m+ , pams)+++----------------------------------------------------------------------------------------------------++-- | Create a replaceResult request to send it to an LTI consumer+replaceResultRequest :: MonadIO m+ => LTIProvider+ -> String -- ^ url of service consumer+ -> Text -- ^ sourcedId (student id)+ -> Double -- ^ resultScore (grade between 0.0 and 1.0)+ -> Maybe Text -- ^ resultData (not sure if edX stores it though)+ -> m HTTP.Request+replaceResultRequest prov url sourceId resultScore resultData = do+ ctime <- liftIO $ getPOSIXTime+ crand <- liftIO (randomIO :: IO Word)+ req0 <- liftIO $ HTTP.parseUrl url+ let req = req0 { HTTP.method = "POST"+ , HTTP.requestBody = HTTP.RequestBodyBS rbody+ , HTTP.requestHeaders = [ ("Content-Type", "application/xml")]+ }+ imsxMessageId = Text.pack $ show ctime ++ show crand+ rbody = replaceResultTemplate imsxMessageId sourceId resultScore+ (case resultData of+ Nothing -> ""+ Just da -> da)+ OAuth.signOAuth (ltiOAuth prov) OAuth.emptyCredential req+++----------------------------------------------------------------------------------------------------++encodeTemplate :: [Node] -> ByteString+encodeTemplate (NodeElement el :_) = LB.toStrict+ . renderLBS def{rsPretty = False}+ $ Document (Prologue [] Nothing []) el []+encodeTemplate (_:xs) = encodeTemplate xs+encodeTemplate [] = SB.empty+++replaceResultTemplate :: Text -> Text -> Double -> Text -> ByteString+replaceResultTemplate imsxMessageId sourceId resultScore resultData = encodeTemplate+ [xml|<imsx_POXEnvelopeRequest xmlns="http://www.imsglobal.org/services/ltiv1p1/xsd/imsoms_v1p0">+ <imsx_POXHeader>+ <imsx_POXRequestHeaderInfo>+ <imsx_version>V1.0+ <imsx_messageIdentifier>#{imsxMessageId}+ <imsx_POXBody>+ <replaceResultRequest>+ <resultRecord>+ <sourcedGUID>+ <sourcedId>#{sourceId}+ <result>+ <resultScore>+ <textString>#{Text.pack $ show resultScore}+ <resultData>+ <text>#{resultData}+ |]++-- answer:+-- <imsx_POXHeader>+-- <imsx_POXResponseHeaderInfo>+-- <imsx_version>V1.0</imsx_version>+-- <imsx_messageIdentifier>335349992332</imsx_messageIdentifier>+-- <imsx_statusInfo>+-- <imsx_codeMajor>success</imsx_codeMajor>+-- <imsx_severity>status</imsx_severity>+-- <imsx_description>Score for course-v1%3...c is now 0.7</imsx_description>+-- <imsx_messageRefIdentifier>+-- </imsx_messageRefIdentifier>+-- </imsx_statusInfo>+-- </imsx_POXResponseHeaderInfo>+-- </imsx_POXHeader>+-- <imsx_POXBody><replaceResultResponse/></imsx_POXBody>++--readResultTemplate :: Text -> Text -> ByteString+--readResultTemplate imsxMessageId sourceId = encodeTemplate+-- [xml|<imsx_POXEnvelopeRequest xmlns="http://www.imsglobal.org/services/ltiv1p1/xsd/imsoms_v1p0">+-- <imsx_POXHeader>+-- <imsx_POXRequestHeaderInfo>+-- <imsx_version>V1.0+-- <imsx_messageIdentifier>#{imsxMessageId}+-- <imsx_POXBody>+-- <readResultRequest>+-- <resultRecord>+-- <sourcedGUID>+-- <sourcedId>#{sourceId}+-- |]++----------------------------------------------------------------------------------------------------+-- Copied from Web.Authenticate.OAuth+toBS :: MonadIO m => HTTP.RequestBody -> m ByteString+toBS (HTTP.RequestBodyLBS l) = return $ LB.toStrict l+toBS (HTTP.RequestBodyBS s) = return s+toBS (HTTP.RequestBodyBuilder _ b) = return $ toByteString b+toBS (HTTP.RequestBodyStream _ givesPopper) = toBS' givesPopper+toBS (HTTP.RequestBodyStreamChunked givesPopper) = toBS' givesPopper+#if MIN_VERSION_http_client(0, 4, 28)+toBS (HTTP.RequestBodyIO op) = liftIO op >>= toBS+#else+#endif++toBS' :: MonadIO m => HTTP.GivesPopper () -> m ByteString+toBS' gp = liftIO $ do+ ref <- I.newIORef SB.empty+ gp (go ref)+ I.readIORef ref+ where+ go ref popper =+ loop id+ where+ loop front = do+ bs <- popper+ if SB.null bs+ then I.writeIORef ref $ SB.concat $ front []+ else loop (front . (bs:))