diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -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) diff --git a/src/Yesod/Auth/LTI13.hs b/src/Yesod/Auth/LTI13.hs --- a/src/Yesod/Auth/LTI13.hs +++ b/src/Yesod/Auth/LTI13.hs @@ -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 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 #-} diff --git a/tests/Yesod/Auth/LTI13Spec.hs b/tests/Yesod/Auth/LTI13Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Yesod/Auth/LTI13Spec.hs @@ -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"], [])) diff --git a/yesod-auth-lti13.cabal b/yesod-auth-lti13.cabal --- a/yesod-auth-lti13.cabal +++ b/yesod-auth-lti13.cabal @@ -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 - 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 --- 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 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 +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