yesod-auth-lti13 0.2.0.3 → 0.3.0.0
raw patch · 6 files changed
+473/−90 lines, 6 filesdep +QuickCheckdep +data-defaultdep +file-embeddep −safe-exceptionsdep ~aesondep ~aeson-prettydep ~basePVP ok
version bump matches the API change (PVP)
Dependencies added: QuickCheck, data-default, file-embed, hspec, http-types, mtl, template-haskell, th-utilities, transformers, unliftio, wai, yesod-test
Dependencies removed: safe-exceptions
Dependency ranges changed: aeson, aeson-pretty, base, base64-bytestring, bytestring, containers, cryptonite, http-client, http-conduit, load-env, lti13, oidc-client, text, time, warp, yesod, yesod-auth
API changes (from Hackage documentation)
Files
- CHANGELOG.md +9/−0
- example/Main.hs +2/−2
- src/Yesod/Auth/LTI13.hs +23/−15
- tests/Spec.hs +2/−0
- tests/Yesod/Auth/LTI13Spec.hs +183/−0
- yesod-auth-lti13.cabal +254/−73
CHANGELOG.md view
@@ -1,5 +1,14 @@ # Revision history for yesod-auth-lti13 +## 0.3.0.0 -- 2022-11-23++* Support newer compilers and dependencies+ * aeson >= 2 now required;+ * oidc-client >= 0.7 now required+ * Support ghc-9.4+* Write what amounts to a test suite, more or less.+* Fix a bug where exceptions were not reported nicely.+ ## 0.2.0.3 -- 2021-08-10 * Loosen version bounds on cryptonite
example/Main.hs view
@@ -119,8 +119,8 @@ retrievePlatformInfo ("aaaaa", Just "abcde") = return $ PlatformInfo { platformIssuer = "aaaaa" , platformClientId = "abcde"- , platformOidcAuthEndpoint = "https://lti-ri.imsglobal.org/platforms/1812/authorizations/new"- , jwksUrl = "https://lti-ri.imsglobal.org/platforms/1812/platform_keys/1732.json"+ , platformOidcAuthEndpoint = "https://lti-ri.imsglobal.org/platforms/3722/authorizations/new"+ , jwksUrl = "https://lti-ri.imsglobal.org/platforms/3722/platform_keys/3413.json" } retrievePlatformInfo (iss, cid) = do $logWarn $ "unknown platform " <> iss <> " with client id " <> (T.pack $ show cid)
src/Yesod/Auth/LTI13.hs view
@@ -1,12 +1,5 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-} - -- | A Yesod authentication module for LTI 1.3 -- See @example/Main.hs@ for a sample implementation. --@@ -47,7 +40,6 @@ , Nonce ) where -import Control.Exception.Safe (Exception, throwIO) import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Crypto.PubKey.RSA as RSA import Crypto.Random (getRandomBytes)@@ -64,6 +56,7 @@ import Jose.Jwk (Jwk (..), JwkSet (..), KeyUse (Sig), generateRsaKeyPair) import Jose.Jwt (KeyId (UTCKeyId))+import Prelude import Web.LTI13 import Web.OIDC.Client (Nonce) import Web.OIDC.Client.Tokens (IdTokenClaims (..))@@ -79,9 +72,13 @@ permissionDenied, redirect, runRequestBody, setSession, setSessionBS, toTypedContent)-import Yesod.Core.Handler (getRouteToParent)+import Yesod.Core.Handler (getRouteToParent, sendResponseStatus) import Yesod.Core.Types (TypedContent) import Yesod.Core.Widget+import Network.HTTP.Types (unauthorized401, badRequest400)+import qualified Data.Text as T+import UnliftIO.Exception (Exception, throwIO, catch)+import Control.Monad (guard) data YesodAuthLTI13Exception = LTIException Text LTI13Exception@@ -92,7 +89,7 @@ -- Plugin name and an error message | CorruptJwks Text Text -- ^ The jwks stored in the database are corrupt. Wat.- deriving (Show)+ deriving stock (Show) instance Exception YesodAuthLTI13Exception @@ -168,10 +165,13 @@ setSessionBS sname state setSessionBS nname nonce return ()- sessionGet = do- state <- lookupSessionBS sname+ sessionGet givenState = do+ state_ <- lookupSessionBS sname nonce <- lookupSessionBS nname- return (state, nonce)+ return do+ state <- state_+ guard $ givenState == state+ nonce sessionDelete = do deleteSession sname deleteSession nname@@ -219,8 +219,16 @@ RsaPublicJwk (RSA.private_pub privKey) mId mUse mAlg rsaPrivToPub _ = error "rsaPrivToPub called on a Jwk that's not a RsaPrivateJwk" +lti13ExceptionToYesod :: (MonadHandler m) => LTI13Exception -> m a+lti13ExceptionToYesod e@(InvalidHandshake _) = sendResponseStatus badRequest400 (T.pack . show $ e)+lti13ExceptionToYesod e@(InvalidLtiToken _) = sendResponseStatus unauthorized401 (T.pack . show $ e)+-- These ones should be handled as internal server errors so they get into a+-- log+lti13ExceptionToYesod e@(DiscoveryException _) = throwIO e+lti13ExceptionToYesod e@(GotHttpException _) = throwIO e+ dispatchInitiate- :: YesodAuthLTI13 master+ :: (YesodAuthLTI13 master) => PluginName -- ^ Name of the provider -> RequestParams@@ -234,7 +242,7 @@ let authUrl = render $ tm url let cfg = makeCfg name retrievePlatformInfo checkSeenNonce authUrl- (iss, cid, redir) <- initiate cfg params+ (iss, cid, redir) <- initiate cfg params `catch` lti13ExceptionToYesod setSession (myIss name) iss setSession (myCid name) cid redirect redir
+ tests/Spec.hs view
@@ -0,0 +1,2 @@+-- from https://blog.nikosbaxevanis.com/2015/01/30/quickcheck-setup-in-haskell/+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ tests/Yesod/Auth/LTI13Spec.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module Yesod.Auth.LTI13Spec (spec) where++import Control.Monad.Reader (ReaderT (runReaderT), asks)+import Data.ByteString+import Data.Default+import Data.IORef+import Data.Maybe (fromJust)+import Data.Set (Set)+import Data.Text+import GHC.Generics (Generic)+import Language.Haskell.TH (Type (..))+import Network.Wai qualified as Wai+import Test.Hspec+import Yesod+import Yesod.Auth+import Yesod.Auth.LTI13+import Yesod.Core.Types+import Yesod.Test qualified as YT+import Prelude++data FakeSchema = FakeSchema+ { seenNonces :: Set Nonce+ , jwks :: Maybe ByteString+ }+ deriving stock (Generic)+ deriving anyclass (Default)++newtype FakeDb = FakeDb {unFakeDb :: IORef FakeSchema}++data App = App+ { appDB :: FakeDb+ , appAuthPlugins :: [AuthPlugin App]+ }++instance PersistCore FakeDb where+ data BackendKey FakeDb = FakeDbKey Int+ deriving stock (Generic, Eq, Show, Read, Ord)++instance PersistField (BackendKey FakeDb) where+ toPersistValue (FakeDbKey a) = toPersistValue a+ fromPersistValue a = FakeDbKey <$> fromPersistValue a++instance FromJSON (BackendKey FakeDb) where+ parseJSON a = FakeDbKey <$> parseJSON a++instance HasPersistBackend FakeDb where+ type BaseBackend FakeDb = FakeDb+ persistBackend = id++instance PersistStoreRead FakeDb where+ get = error "get"++instance PersistStoreWrite FakeDb where+ insert = error "insert"+ insertKey = error "insertKey"+ repsert = error "repsert"+ replace = error "replace"+ delete = error "delete"+ update = error "update"++instance ToJSON (BackendKey FakeDb) where+ toEncoding (FakeDbKey a) = toEncoding a++-- XXX: this is literally just here to make yesod-auth happy+mkPersist+ (mkPersistSettings (ConT ''FakeDb))+ [persistLowerCase|+ User+ Id Text+ name Text+ |]++instance RenderRoute App where+ data Route App = AuthR AuthRoute | RootR+ deriving stock (Show, Eq, Read)+ renderRoute (AuthR authR) = let (parts, params) = renderRoute authR in ("auth" : parts, params)+ renderRoute RootR = ([], [])++instance ParseRoute App where+ parseRoute ("auth" : rest, x) = AuthR <$> parseRoute (rest, x)+ parseRoute ([], _) = Just RootR+ parseRoute _ = Nothing++instance YesodPersist App where+ type YesodPersistBackend App = FakeDb+ runDB :: YesodDB App a -> HandlerFor App a+ runDB act = do+ -- act is a ReaderT (IORef FakeDb) (HandlerFor app a)+ db <- asks (appDB . rheSite . handlerEnv)+ runReaderT act db++instance YesodAuthPersist App where+ type AuthEntity App = User++instance YesodAuth App where+ type AuthId App = UserId+ loginDest _ = RootR+ logoutDest _ = RootR++ authenticate _creds = do+ error "authenticate"++ authPlugins = appAuthPlugins++instance RenderMessage App FormMessage where+ renderMessage _ _ = defaultFormMessage++instance Yesod App++-- FIXME: idk if reimplementing this was actually a good idea rather than just+-- using the template haskell, lmao, however, it was fun!+instance YesodDispatch App where+ yesodDispatch yre req = do+ go $ Wai.pathInfo req+ where+ go [] = yesodRunner (pure . toTypedContent @Text $ "nya") yre (Just RootR) req+ go ("auth" : rest) = yesodSubDispatch ysre (setPathInfo rest req)+ go _ = yesodRunner (notFound @_ @Html) yre Nothing req++ setPathInfo newPathInfo theReq = theReq {Wai.pathInfo = newPathInfo}+ ysre =+ YesodSubRunnerEnv+ { ysreParentRunner = yesodRunner+ , ysreGetSub = getAuth+ , ysreToParentRoute = AuthR+ , ysreParentEnv = yre+ }++instance YesodAuthLTI13 App where+ checkSeenNonce = error "checkSeenNonce"+ retrievePlatformInfo ("https://fakeplatform.example.com", _) =+ pure+ PlatformInfo+ { platformIssuer = issuer+ , platformClientId = "clientId"+ , platformOidcAuthEndpoint = "https://fakeplatform.example.com/oidc"+ , jwksUrl = error "FIXME: needs to have stubs to do this so it will actually work"+ }+ retrievePlatformInfo _ = error "nope"+ retrieveOrInsertJwks = error "retrieveOrInsertJwks"++withApp :: YT.YesodSpec App -> Spec+withApp =+ YT.yesodSpecWithSiteGenerator+ ( do+ appDB <- FakeDb <$> newIORef def+ pure App {appDB, appAuthPlugins = [authLTI13]}+ )++issuer :: Text+issuer = "https://fakeplatform.example.com"+loginHint :: Text+loginHint = "login_hint"+myTargetLinkUri :: Text+myTargetLinkUri = "https://faketool.example.com"++spec :: Spec+spec = withApp $ YT.ydescribe "Auth" do+ YT.ydescribe "initiate" do+ YT.yit "Returns 400 if any of the request parameters are missing" do+ doInitiate [("login_hint", loginHint), ("target_link_uri", myTargetLinkUri)]+ YT.statusIs 400+ doInitiate [("iss", issuer), ("target_link_uri", myTargetLinkUri)]+ YT.statusIs 400+ doInitiate [("iss", issuer), ("login_hint", loginHint)]+ YT.statusIs 400++ YT.yit "Redirects" do+ doInitiate [("iss", issuer), ("login_hint", loginHint), ("target_link_uri", myTargetLinkUri)]+ YT.statusIs 303+ pure ()+ where+ doInitiate params = do+ YT.request do+ YT.setMethod "POST"+ mapM_ (uncurry YT.addPostParam) params+ YT.setUrl $ AuthR (fromJust $ parseRoute @Auth (["page", "lti13", "initiate"], []))
yesod-auth-lti13.cabal view
@@ -1,80 +1,261 @@-cabal-version: >=1.10+cabal-version: 1.12 -name: yesod-auth-lti13-version: 0.2.0.3-synopsis: A yesod-auth plugin for LTI 1.3-description: A plugin using <https://hackage.haskell.org/package/lti13>- to implement IMS Global LTI 1.3 authentication for- yesod-auth.-bug-reports: https://github.com/lf-/lti13/issues-license: LGPL-3-author: Jade-maintainer: Jade <software at lfcode dot ca>--- copyright:-category: Web, Yesod-license-file: LICENSE-build-type: Simple-extra-source-files: CHANGELOG.md- README.md+-- This file has been generated from package.yaml by hpack version 0.34.7.+--+-- see: https://github.com/sol/hpack -library- hs-source-dirs: src/- exposed-modules: Yesod.Auth.LTI13- ghc-options: -Wall- -- other-modules:- -- other-extensions:- build-depends: base >=4.12 && <5- -- these two are always updated in concert with each other- , lti13 == 0.2.0.3- , base64-bytestring >= 1.0.0 && < 1.2- , bytestring >= 0.10.10 && < 0.11- , containers >= 0.6.2 && < 0.7- , cryptonite >= 0.26 && < 0.30- , http-client >= 0.6.4 && < 0.7- , text >= 1.2.4 && < 1.3- , microlens >= 0.4.11 && < 0.5- , oidc-client >= 0.5.1 && < 0.7- , aeson >= 1.4.7 && < 1.6- , safe-exceptions >= 0.1.7 && < 0.2- , yesod-auth >= 1.6.10 && < 1.7- , http-conduit >= 2.3.7 && < 2.4- , yesod-core >= 1.6.18 && < 1.7- , warp >= 3.3.13 && < 3.4- , aeson-pretty >= 0.8.8 && < 0.9- , load-env >= 0.2.1 && < 0.3- , yesod >= 1.6.1 && < 1.7- , jose-jwt >= 0.8.0 && < 0.10.0- , time >= 1.0.0 && < 1.11- -- hs-source-dirs:- default-language: Haskell2010+name: yesod-auth-lti13+version: 0.3.0.0+synopsis: A yesod-auth plugin for LTI 1.3+description: A plugin using <https://hackage.haskell.org/package/lti13> to implement IMS Global LTI 1.3 authentication for yesod-auth.+category: Web, Yesod+homepage: https://github.com/lf-/lti13#readme+bug-reports: https://github.com/lf-/lti13/issues+author: Jade Lovelace+maintainer: Jade Lovelace <software at lfcode dot ca>+license: LGPL-3+license-file: LICENSE+build-type: Simple+tested-with:+ GHC ==8.10.7 || ==9.2.5 || ==9.4.3+extra-source-files:+ CHANGELOG.md+ README.md +source-repository head+ type: git+ location: https://github.com/lf-/lti13+ flag example- description: "Should I build the Yesod example?"- manual: False- default: False+ description: Should I build the Yesod example?+ manual: False+ default: False +library+ exposed-modules:+ Yesod.Auth.LTI13+ other-modules:+ Paths_yesod_auth_lti13+ hs-source-dirs:+ src+ default-extensions:+ AllowAmbiguousTypes+ BlockArguments+ DataKinds+ DeriveAnyClass+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ DerivingVia+ DuplicateRecordFields+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ ImportQualifiedPost+ InstanceSigs+ LambdaCase+ MonoLocalBinds+ MultiWayIf+ NamedFieldPuns+ NoImplicitPrelude+ NumericUnderscores+ OverloadedLabels+ OverloadedStrings+ PartialTypeSignatures+ PatternSynonyms+ PolyKinds+ RankNTypes+ RecordWildCards+ RecursiveDo+ ScopedTypeVariables+ StandaloneDeriving+ StandaloneKindSignatures+ TypeApplications+ TypeFamilies+ ViewPatterns+ ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-export-lists -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-missing-kind-signatures+ build-depends:+ aeson >=2 && <2.2+ , aeson-pretty >=0.8.8 && <0.9+ , base >=4.12 && <5+ , base64-bytestring >=1.0.0 && <1.3+ , bytestring >=0.10.10 && <0.12+ , containers >=0.6.2 && <0.7+ , cryptonite >=0.26 && <0.31+ , http-client >=0.6.4 && <0.8+ , http-conduit >=2.3.7 && <2.4+ , http-types+ , jose-jwt >=0.8.0 && <0.10.0+ , load-env >=0.2.1 && <0.3+ , lti13 ==0.3.0.0+ , microlens >=0.4.11 && <0.5+ , oidc-client ==0.7.*+ , text >=1.2.4 && <1.3 || >=2.0 && <2.1+ , time >=1.0.0 && <1.13+ , unliftio+ , warp >=3.3.13 && <3.4+ , yesod >=1.6.1 && <1.7+ , yesod-auth >=1.6.10 && <1.7+ , yesod-core >=1.6.18 && <1.7+ default-language: Haskell2010+ executable yesod-lti13-example- main-is: Main.hs- hs-source-dirs:- example- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N- build-depends:- aeson- , aeson-pretty- , base >=4.9.0.0 && <5- , bytestring- , containers- , http-conduit- , load-env- , text- , warp- , yesod- , yesod-auth- , yesod-auth-lti13- if !(flag(example))- buildable: False- default-language: Haskell2010+ main-is: Main.hs+ other-modules:+ Paths_yesod_auth_lti13+ hs-source-dirs:+ example+ default-extensions:+ AllowAmbiguousTypes+ BlockArguments+ DataKinds+ DeriveAnyClass+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ DerivingVia+ DuplicateRecordFields+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ ImportQualifiedPost+ InstanceSigs+ LambdaCase+ MonoLocalBinds+ MultiWayIf+ NamedFieldPuns+ NoImplicitPrelude+ NumericUnderscores+ OverloadedLabels+ OverloadedStrings+ PartialTypeSignatures+ PatternSynonyms+ PolyKinds+ RankNTypes+ RecordWildCards+ RecursiveDo+ ScopedTypeVariables+ StandaloneDeriving+ StandaloneKindSignatures+ TypeApplications+ TypeFamilies+ ViewPatterns+ ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-export-lists -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-missing-kind-signatures -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ aeson+ , aeson-pretty+ , base >=4.9.0.0 && <5+ , base64-bytestring >=1.0.0 && <1.3+ , bytestring+ , containers+ , cryptonite >=0.26 && <0.31+ , http-client >=0.6.4 && <0.8+ , http-conduit+ , http-types+ , jose-jwt >=0.8.0 && <0.10.0+ , load-env+ , lti13 ==0.3.0.0+ , microlens >=0.4.11 && <0.5+ , oidc-client ==0.7.*+ , text+ , time >=1.0.0 && <1.13+ , unliftio+ , warp+ , yesod+ , yesod-auth+ , yesod-auth-lti13+ , yesod-core >=1.6.18 && <1.7+ if !(flag(example))+ buildable: False+ default-language: Haskell2010 -source-repository head- type: git- location: https://github.com/lf-/lti13+test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Yesod.Auth.LTI13Spec+ Paths_yesod_auth_lti13+ hs-source-dirs:+ tests+ default-extensions:+ AllowAmbiguousTypes+ BlockArguments+ DataKinds+ DeriveAnyClass+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ DerivingVia+ DuplicateRecordFields+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ ImportQualifiedPost+ InstanceSigs+ LambdaCase+ MonoLocalBinds+ MultiWayIf+ NamedFieldPuns+ NoImplicitPrelude+ NumericUnderscores+ OverloadedLabels+ OverloadedStrings+ PartialTypeSignatures+ PatternSynonyms+ PolyKinds+ RankNTypes+ RecordWildCards+ RecursiveDo+ ScopedTypeVariables+ StandaloneDeriving+ StandaloneKindSignatures+ TypeApplications+ TypeFamilies+ ViewPatterns+ ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-export-lists -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-missing-kind-signatures+ build-tool-depends:+ hspec-discover:hspec-discover+ build-depends:+ QuickCheck+ , aeson+ , aeson-pretty >=0.8.8 && <0.9+ , base >=4.12 && <5+ , base64-bytestring >=1.0.0 && <1.3+ , bytestring >=0.10.10 && <0.12+ , containers >=0.6.2 && <0.7+ , cryptonite >=0.26 && <0.31+ , data-default+ , file-embed+ , hspec+ , http-client >=0.6.4 && <0.8+ , http-conduit >=2.3.7 && <2.4+ , http-types+ , jose-jwt >=0.8.0 && <0.10.0+ , load-env >=0.2.1 && <0.3+ , lti13+ , microlens >=0.4.11 && <0.5+ , mtl+ , oidc-client ==0.7.*+ , template-haskell+ , text >=1.2.4 && <1.3 || >=2.0 && <2.1+ , th-utilities+ , time >=1.0.0 && <1.13+ , transformers+ , unliftio+ , wai+ , warp >=3.3.13 && <3.4+ , yesod >=1.6.1 && <1.7+ , yesod-auth >=1.6.10 && <1.7+ , yesod-auth-lti13+ , yesod-core >=1.6.18 && <1.7+ , yesod-test+ default-language: Haskell2010