From 6aca59afea8918641bc550c6f558128315107677 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Fri, 17 Jan 2025 12:43:39 -0500 Subject: [PATCH 1/4] Try to see 255 exit code in isolation --- .github/workflows/hlint-repro.yml | 41 +++++++ hlint/.hlint.yaml | 152 ++++++++++++++++++++++++++ hlint/BadFile.hs | 174 ++++++++++++++++++++++++++++++ 3 files changed, 367 insertions(+) create mode 100644 .github/workflows/hlint-repro.yml create mode 100644 hlint/.hlint.yaml create mode 100644 hlint/BadFile.hs diff --git a/.github/workflows/hlint-repro.yml b/.github/workflows/hlint-repro.yml new file mode 100644 index 00000000..365c4d85 --- /dev/null +++ b/.github/workflows/hlint-repro.yml @@ -0,0 +1,41 @@ +name: HLint Repro + +on: + pull_request: + +jobs: + restyled: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + + - name: "hlint, then same exact refactor command as 2 steps (works)" + working-directory: hlint + run: | + docker run \ + --rm \ + --net=none \ + --cpu-shares=512 \ + --memory=128m \ + --volume "$PWD":/code \ + public.ecr.aws/restyled-io/restyler-hlint:v3.5 sh -c ' + hlint --serialise --no-exit-code ./BadFile.hs > hlint.refact; + exec refactor ./BadFile.hs -v2 -i --refact-file hlint.refact -X TypeFamilies -X TypeApplications -X StandaloneDeriving -X ScopedTypeVariables -X RecordWildCards -X RankNTypes -X QuasiQuotes -X OverloadedStrings -X OverloadedRecordDot -X MultiParamTypeClasses -X LambdaCase -X GeneralizedNewtypeDeriving -X GADTs -X FlexibleInstances -X FlexibleContexts -X DerivingStrategies -X DeriveTraversable -X DeriveLift -X DeriveGeneric -X DeriveFunctor -X DeriveFoldable -X DeriveAnyClass -X DataKinds -X BangPatterns -X Cpp -X OverlappingInstances -X UndecidableInstances -X IncoherentInstances -X UndecidableSuperClasses -X MonoLocalBinds -X DeepSubsumption -X RelaxedPolyRec -X ExtendedDefaultRules -X ForeignFunctionInterface -X UnliftedFFITypes -X InterruptibleFFI -X CApiFFI -X GHCForeignImportPrim -X JavaScriptFFI -X ParallelArrays -X TemplateHaskell -X TemplateHaskellQuotes -X QualifiedDo -X ImplicitParams -X AllowAmbiguousTypes -X UnliftedNewtypes -X UnliftedDatatypes -X TypeFamilyDependencies -X TypeInType -X OverloadedLists -X NumDecimals -X DisambiguateRecordFields -X NamedFieldPuns -X ViewPatterns -X GADTSyntax -X NPlusKPatterns -X DoAndIfThenElse -X BlockArguments -X RebindableSyntax -X ConstraintKinds -X PolyKinds -X InstanceSigs -X ApplicativeDo -X LinearTypes -X DeriveDataTypeable -X AutoDeriveTypeable -X DefaultSignatures -X DerivingVia -X TypeSynonymInstances -X ConstrainedClassMethods -X NullaryTypeClasses -X FunctionalDependencies -X UnicodeSyntax -X ExistentialQuantification -X MagicHash -X EmptyDataDecls -X KindSignatures -X RoleAnnotations -X ParallelListComp -X PostfixOperators -X TupleSections -X PatternGuards -X LiberalTypeSynonyms -X ImpredicativeTypes -X TypeOperators -X ExplicitNamespaces -X PackageImports -X ExplicitForAll -X AlternativeLayoutRuleTransitional -X DatatypeContexts -X NondecreasingIndentation -X RelaxedLayout -X TraditionalRecordSyntax -X MultiWayIf -X BinaryLiterals -X HexFloatLiterals -X DuplicateRecordFields -X OverloadedLabels -X EmptyCase -X PatternSynonyms -X PartialTypeSignatures -X NamedWildCards -X Strict -X StrictData -X EmptyDataDeriving -X NumericUnderscores -X QuantifiedConstraints -X ImportQualifiedPost -X CUSKs -X StandaloneKindSignatures -X FieldSelectors -X NoMonomorphismRestriction -X NoImplicitPrelude + ' + + - name: "hlint --refactor (exits 255)" + working-directory: hlint + run: | + docker run \ + --rm \ + --net=none \ + --cpu-shares=512 \ + --memory=128m \ + --volume "$PWD":/code \ + public.ecr.aws/restyled-io/restyler-hlint:v3.5 \ + hlint \ + --verbose \ + --refactor \ + --refactor-options="-i" \ + -- \ + ./BadFile.hs diff --git a/hlint/.hlint.yaml b/hlint/.hlint.yaml new file mode 100644 index 00000000..1e09829c --- /dev/null +++ b/hlint/.hlint.yaml @@ -0,0 +1,152 @@ +# +# Meanings of hlint severity levels: +# +# error ┃ A rule that is enforced and fails the build. +# ─────────╂───────────────────────────────────────────────────── +# warn ┃ A rule that we intend to enforce soon. +# ┃ +# ┃ Any warning severity should only be *temporary*; +# ┃ once all the violatations are fixed, a warning +# ┃ will escalated to error severity. +# ┃ +# ┃ Place a TODO and date on each warning to indicate +# ┃ when each rule enforcement was disabled so that we +# ┃ can notice neglect. +# ─────────╂───────────────────────────────────────────────────── +# hint ┃ A sujective suggestion that is sometimes useful but +# ┃ not a rule and should not be applied blindly. +# ─────────╂───────────────────────────────────────────────────── +# ignore ┃ Used to suppress hlint defaults that we don't want. +# +# +# If a rule truly does not apply in a particular situation, see +# https://github.com/ndmitchell/hlint/#ignoring-hints +# for ad hoc ways to suppress hlint. + +--- + +# By default, everything is an error +- error: {name: ""} + +# Some things we don't care about at all +- ignore: {name: "Use module export list"} +- ignore: {name: "Redundant bracket due to operator fixities"} +- ignore: {name: "Use explicit module export list"} +- ignore: {name: "Redundant do"} +- ignore: {name: "Eta reduce"} +- ignore: {name: "Use list comprehension"} +- ignore: {name: "Reduce duplication"} +- ignore: {name: "Use fmap"} # we use classy prelude so this would be in error +- ignore: {name: "Avoid restricted function", within: Application} +- ignore: {name: "Use ."} # commonly broken or less readable +- ignore: {name: "Use &&"} # we like "and" at 3+ elements +- ignore: {name: "Use ||"} # we like "or" at 3+ elements +- ignore: {name: "Use join"} # this often leads to cryptic code when do notation is easier to read +- ignore: {name: "Redundant ^."} # confused by esqueleto's (^.) +- ignore: {name: "Fuse on/on"} # confused by esqueleto's on + +# Custom errors +- error: {lhs: mapM, rhs: traverse} +- error: {lhs: mapM_, rhs: traverse_} +- error: {lhs: forM, rhs: for} +- error: {lhs: forM_, rhs: for_} +- error: {lhs: return, rhs: pure} +- error: {lhs: "only (entityKey x)", rhs: "onlyKey x"} + +- error: + name: "Avoid unsafePerformIO" + lhs: "unsafePerformIO" + rhs: "unsafePerformIO" + note: | + Avoid `unsafePerformIO`, which bypasses the type system to perform arbitrary + `IO` effects from pure code + +- warn: # TODO (2023-08-17) escalate to error severity + name: "Avoid error" + lhs: "error" + rhs: "error" + note: | + `error` will not raise until the value is demanded, which can lead to a + confusing debugging experience. Prefer modeling the error in the type + system via `Maybe` or `Either` or `fail` in an appropriate `Monad`. If + that's not possible, throw an actual exception. Lastly, if an error in a + pure context cannot be avoided (e.g. `fromString`), ignore this specific + case via an `ANN` pragma. + +- error: + name: "Avoid fromJust" + lhs: "fromJust" + rhs: "fromJust" + note: | + `fromJust` uses `error` internally, and comes with all the same caveats + (see "Avoid error"). Prefer `fromJustNoteM`. + +- warn: # TODO (2023-08-17) escalate to error severity + name: "Avoid fromJustNote" + lhs: "fromJustNote" + rhs: "fromJustNote" + note: | + `fromJustNote` uses `error` internally, and comes with all the same + caveats (see "Avoid error"). Prefer `fromJustNoteM`. + +# Ignore everything within our generated clients +- ignore: {within: "FreckleCurriculaApi.**.*"} +- ignore: {within: "RenaissanceGUR.**.*"} +- ignore: {within: "PerformanceAnalysisService.**.*"} +- ignore: {within: "BenchmarkService.**.*"} +- ignore: {within: "RecurlyApi.**.*"} + +# Specify additional command line arguments +- arguments: + - -XBangPatterns + - -XDataKinds + - -XDeriveAnyClass + - -XDeriveFoldable + - -XDeriveFunctor + - -XDeriveGeneric + - -XDeriveLift + - -XDeriveTraversable + - -XDerivingStrategies + - -XFlexibleContexts + - -XFlexibleInstances + - -XGADTs + - -XGeneralizedNewtypeDeriving + - -XLambdaCase + - -XMultiParamTypeClasses + - -XNoImplicitPrelude + - -XNoMonomorphismRestriction + - -XOverloadedRecordDot + - -XOverloadedStrings + - -XQuasiQuotes + - -XRankNTypes + - -XRecordWildCards + - -XScopedTypeVariables + - -XStandaloneDeriving + - -XTypeApplications + - -XTypeFamilies + +- modules: + - {name: [Data.Set], as: Set} + - {name: [Data.Map], as: Map} + - {name: [Data.HashSet], as: HashSet} + - {name: [Data.HashMap.Strict], as: HashMap} + - {name: [Data.Text], as: T} + - {name: [Data.Text.Encoding], as: T} + - {name: [Data.Text.IO], as: T} + - {name: [Data.Text.Lazy], as: TL} + - {name: [Data.Text.Lazy.Encoding], as: TL} + - {name: [Data.Text.IO.Lazy], as: TL} + - {name: [Data.ByteString], as: BS} + - {name: [Data.ByteString.Lazy], as: BSL} + - {name: [Data.ByteString.Char8], as: BS8} + - {name: [Data.ByteString.Lazy.Char8], as: BSL8} + - {name: [Data.List.NonEmpty], as: NE} + - {name: [Data.Sequence], as: Seq} + - {name: Database.Esqueleto.Legacy, within: []} + - {name: Freckle.CurriculaApi, as: CurriculaApi} + - name: + - Freckle.App.OpenTelemetry + - OpenTelemetry.Context + - OpenTelemetry.Context.ThreadLocal + - OpenTelemetry.Trace + as: Trace diff --git a/hlint/BadFile.hs b/hlint/BadFile.hs new file mode 100644 index 00000000..cc3f988c --- /dev/null +++ b/hlint/BadFile.hs @@ -0,0 +1,174 @@ +module Freckle.ActivityFeed.Model.StudentActivity.Manipulation + ( combineActivitiesBySession + , combineHighlightActivitiesBySession + ) where + +import Freckle.ActivityFeed.Internal.Prelude +import Prelude qualified as Unsafe (foldr1) + +import Data.HashMap.Strict qualified as HashMap +import Data.List (sortOn) +import Data.Monoid (Any (..), Sum (..)) +import Freckle.ActivityFeed.Model.Accuracy.Calculation +import Freckle.ActivityFeed.Model.Score +import Freckle.ActivityFeed.Model.StudentActivity +import Freckle.ActivityFeed.Model.StudentActivity qualified as StudentActivity +import Freckle.ActivityFeed.Model.StudentHighlightActivity +import Freckle.ActivityFeed.Model.StudentHighlightActivity qualified as StudentHighlightActivity + +combineActivitiesBySession + :: [StudentActivity 'Fragment] -> [StudentActivity 'Final] +combineActivitiesBySession = + sortOn (Down . (.timeCompleted)) + . fmap (finalizeActivity . Unsafe.foldr1 unsafeCombineStudentActivities) + . groupActivities + +combineHighlightActivitiesBySession + :: [StudentHighlightActivity] -> [StudentHighlightActivity] +combineHighlightActivitiesBySession = + sortOn (Down . (.timeCompleted)) + . fmap + ( finalizeHighlightActivity + . Unsafe.foldr1 unsafeCombineStudentHighlightActivities + ) + . groupHighlightActivities + +-- | Finalize a `StudentActivity`s aggregation +-- +-- A fragment of an activity may represent a single session or multiple +-- fragments of a session. A finalized activity represents the session in +-- total. To produce correct downstream aggregates certain metrics must be +-- condensed in the final aggregate. +-- +-- Average must be condensed to have correct weight. Otherwise individual +-- fragment weights would cause odd results +finalizeActivity :: StudentActivity 'Fragment -> StudentActivity 'Final +finalizeActivity activity = + activity + { StudentActivity.score = + maybe activity.score (Just . ScorePercentage . averageDatum) + $ getAverage + =<< activityToAccuracyPercentage activity + } + +finalizeHighlightActivity + :: StudentHighlightActivity -> StudentHighlightActivity +finalizeHighlightActivity activity = + activity + { StudentHighlightActivity.score = + maybe activity.score (Just . ScorePercentage . averageDatum) + $ getAverage + =<< activityToAccuracyPercentage activity + } + +unsafeCombineStudentActivities + :: HasCallStack + => StudentActivity 'Fragment + -> StudentActivity 'Fragment + -> StudentActivity 'Fragment +unsafeCombineStudentActivities x y = unwrap $ combineStudentActivities x y + where + unwrap (Left err) = error err + unwrap (Right a) = a + +combineStudentActivities + :: StudentActivity 'Fragment + -> StudentActivity 'Fragment + -> Either String (StudentActivity 'Fragment) +combineStudentActivities x y = do + when (x.studentId /= y.studentId) + $ Left ("student IDs are not equal: " ++ show (x, y)) + when (x.product /= y.product) + $ Left ("products are not equal: " ++ show (x, y)) + when (x.sessionId /= y.sessionId) + $ Left ("session IDs are not equal" ++ show (x, y)) + when (x.topic /= y.topic) + $ Left ("topics are not equal" ++ show (x, y)) + pure + StudentActivity + { studentId = x.studentId + , gradeLevel = liftA2 max x.gradeLevel y.gradeLevel + , contentLevel = x.contentLevel <|> y.contentLevel + , minutesPracticed = + case (x.minutesPracticed, y.minutesPracticed) of + (Just a, Just b) -> Just $ a + b + (ma, mb) -> ma <|> mb + , numberCorrect = + getSum <$> (Sum <$> x.numberCorrect) <> (Sum <$> y.numberCorrect) + , numberQuestions = + getSum <$> (Sum <$> x.numberQuestions) <> (Sum <$> y.numberQuestions) + , product = x.product + , assignmentId = x.assignmentId + , sessionId = x.sessionId + , score = do + ScorePercentage xScore <- x.score + ScorePercentage yScore <- y.score + pure $ ScorePercentage (xScore <> yScore) + , worth = getSum <$> (Sum <$> x.worth) <> (Sum <$> y.worth) + , timeCompleted = max x.timeCompleted y.timeCompleted + , topic = x.topic + , mathSubSkillPracticed = + getAny + <$> (Any <$> x.mathSubSkillPracticed) + <> (Any <$> y.mathSubSkillPracticed) + , prerequisiteAssignment = + getAny + <$> (Any <$> x.prerequisiteAssignment) + <> (Any <$> y.prerequisiteAssignment) + } + +unsafeCombineStudentHighlightActivities + :: HasCallStack + => StudentHighlightActivity + -> StudentHighlightActivity + -> StudentHighlightActivity +unsafeCombineStudentHighlightActivities x y = unwrap $ combineStudentHighlightActivities x y + where + unwrap (Left err) = error err + unwrap (Right a) = a + +combineStudentHighlightActivities + :: StudentHighlightActivity + -> StudentHighlightActivity + -> Either String StudentHighlightActivity +combineStudentHighlightActivities x y = do + when (x.studentId /= y.studentId) + $ Left ("student IDs are not equal: " ++ show (x, y)) + when (x.product /= y.product) + $ Left ("products are not equal: " ++ show (x, y)) + when (x.sessionId /= y.sessionId) + $ Left ("session IDs are not equal" ++ show (x, y)) + pure + StudentHighlightActivity + { studentId = x.studentId + , minutesPracticed = + case (x.minutesPracticed, y.minutesPracticed) of + (Just a, Just b) -> Just $ a + b + (ma, mb) -> ma <|> mb + , numberCorrect = + getSum <$> (Sum <$> x.numberCorrect) <> (Sum <$> y.numberCorrect) + , numberQuestions = + getSum <$> (Sum <$> x.numberQuestions) <> (Sum <$> y.numberQuestions) + , product = x.product + , assignmentId = x.assignmentId + , sessionId = x.sessionId + , score = do + ScorePercentage xScore <- x.score + ScorePercentage yScore <- y.score + pure $ ScorePercentage (xScore <> yScore) + , timeCompleted = max x.timeCompleted y.timeCompleted + } + +groupHighlightActivities + :: [StudentHighlightActivity] -> [NonEmpty StudentHighlightActivity] +groupHighlightActivities = + HashMap.elems + . HashMap.fromListWith (<>) + . fmap (((.product) &&& (.sessionId)) &&& pure) + +groupActivities + :: [StudentActivity 'Fragment] -> [NonEmpty (StudentActivity 'Fragment)] +groupActivities = + HashMap.elems + . HashMap.fromListWith (<>) + . fmap (((.product) &&& (.sessionId)) &&& pure) From 2ac733b97ed226d8db5bbe29bf57f674300bb6e0 Mon Sep 17 00:00:00 2001 From: "github-actions[bot]" Date: Fri, 17 Jan 2025 17:57:10 +0000 Subject: [PATCH 2/4] Update docs --- _docs/restylers.md | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/_docs/restylers.md b/_docs/restylers.md index 8b2a3aa6..75cf6f7a 100644 --- a/_docs/restylers.md +++ b/_docs/restylers.md @@ -1,11 +1,11 @@ # Restylers -Built from `715cfdecadad1cdd42a3e6b46ff6980278336ea7`. +Built from `4ddd1c5b0ffb3eb25181e7b39aaa3cab9a307e4a`. | Restyler | Language(s) | Version | Runs automatically? | | -------- | ----------- | ------- | ------------------- | | [astyle](#astyle) | C, C++, C#, Java*, Objective-C | `v3.6.2` | Yes | -| [autopep8](#autopep8) | Python | `v2.3.1` | Yes | +| [autopep8](#autopep8) | Python | `v2.3.2` | Yes | | [black](#black) | Python | `v24.10.0` | Yes | | [brittany](#brittany) | Haskell | `v0.14.0.2` | No | | [cabal-fmt](#cabal-fmt) | Haskell | `v0.1.12` | No | @@ -17,7 +17,7 @@ Built from `715cfdecadad1cdd42a3e6b46ff6980278336ea7`. | [dotnet-format](#dotnet-format) | C#, VB.NET | `v5.1.250801` | No | | [elm-format](#elm-format) | Elm | `v0.6.1-alpha-3` | Yes | | [fantomas](#fantomas) | F# | `v3.3.0` | Yes | -| [fourmolu](#fourmolu) | Haskell | `v0.16.2.0` | No | +| [fourmolu](#fourmolu) | Haskell | `v0.17.0.0` | No | | [gn](#gn) | GN | `v2` | Yes | | [gofmt](#gofmt) | Go | `go1.23.0` | Yes | | [google-java-format](#google-java-format) | Java | `v1.9` | No | @@ -34,7 +34,7 @@ Built from `715cfdecadad1cdd42a3e6b46ff6980278336ea7`. | [ormolu](#ormolu) | Haskell | `v0.5.3.0` | No | | [perltidy](#perltidy) | Perl | `v20230701` | Yes | | [pg_format](#pg_format) | PSQL | `v5.3` | Yes | -| [php-cs-fixer](#php-cs-fixer) | PHP | `v3.67.1` | Yes | +| [php-cs-fixer](#php-cs-fixer) | PHP | `v3.68.1` | Yes | | [prettier](#prettier) | JavaScript | `v3.4.2-3` | Yes | | [prettier-json](#prettier-json) | JSON | `v3.4.2-3` | Yes | | [prettier-markdown](#prettier-markdown) | Markdown | `v3.4.2-3` | Yes | @@ -51,7 +51,7 @@ Built from `715cfdecadad1cdd42a3e6b46ff6980278336ea7`. | [shellharden](#shellharden) | POSIX sh, Bash | `v4.1.1-3` | Yes | | [shfmt](#shfmt) | POSIX sh, Bash | `v3.4.3` | Yes | | [sqlformat](#sqlformat) | SQL, PSQL | `0.5.3` | No | -| [standardrb](#standardrb) | Ruby | `v1.43.0` | Yes | +| [standardrb](#standardrb) | Ruby | `v1.44.0` | Yes | | [stylish-haskell](#stylish-haskell) | Haskell | `v0.14.3.0` | Yes | | [taplo](#taplo) | TOML | `0.9.3` | Yes | | [terraform](#terraform) | Terraform | `v0.12.24-2` | Yes | @@ -210,7 +210,7 @@ restylers: command: - autopep8 - --in-place - image: restyled/restyler-autopep8:v2.3.1 + image: public.ecr.aws/restyled-io/restyler-autopep8:v2.3.2 include: - '**/*.py' interpreters: @@ -1314,7 +1314,7 @@ restylers: - fourmolu - --mode - inplace - image: restyled/restyler-fourmolu:v0.16.2.0 + image: public.ecr.aws/restyled-io/restyler-fourmolu:v0.17.0.0 include: - '**/*.hs' interpreters: [] @@ -2892,7 +2892,7 @@ restylers: command: - php-cs-fixer - fix - image: public.ecr.aws/restyled-io/restyler-php-cs-fixer:v3.67.1 + image: public.ecr.aws/restyled-io/restyler-php-cs-fixer:v3.68.1 include: - '**/*.php' interpreters: [] @@ -4346,7 +4346,7 @@ restylers: command: - standardrb - --fix - image: public.ecr.aws/restyled-io/restyler-standardrb:v1.43.0 + image: public.ecr.aws/restyled-io/restyler-standardrb:v1.44.0 include: - '**/*.rb' interpreters: From 4b719b06247c3aeb56ed0111dcd1b36cf2b7ddff Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Fri, 17 Jan 2025 13:09:14 -0500 Subject: [PATCH 3/4] Try a different BadFile --- hlint/BadFile.hs | 2276 ++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 2112 insertions(+), 164 deletions(-) diff --git a/hlint/BadFile.hs b/hlint/BadFile.hs index cc3f988c..fffcb999 100644 --- a/hlint/BadFile.hs +++ b/hlint/BadFile.hs @@ -1,174 +1,2122 @@ -module Freckle.ActivityFeed.Model.StudentActivity.Manipulation - ( combineActivitiesBySession - , combineHighlightActivitiesBySession +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Freckle.Api.Handlers.Auth.RenaissanceSsoSpec + ( spec ) where -import Freckle.ActivityFeed.Internal.Prelude -import Prelude qualified as Unsafe (foldr1) - -import Data.HashMap.Strict qualified as HashMap -import Data.List (sortOn) -import Data.Monoid (Any (..), Sum (..)) -import Freckle.ActivityFeed.Model.Accuracy.Calculation -import Freckle.ActivityFeed.Model.Score -import Freckle.ActivityFeed.Model.StudentActivity -import Freckle.ActivityFeed.Model.StudentActivity qualified as StudentActivity -import Freckle.ActivityFeed.Model.StudentHighlightActivity -import Freckle.ActivityFeed.Model.StudentHighlightActivity qualified as StudentHighlightActivity - -combineActivitiesBySession - :: [StudentActivity 'Fragment] -> [StudentActivity 'Final] -combineActivitiesBySession = - sortOn (Down . (.timeCompleted)) - . fmap (finalizeActivity . Unsafe.foldr1 unsafeCombineStudentActivities) - . groupActivities - -combineHighlightActivitiesBySession - :: [StudentHighlightActivity] -> [StudentHighlightActivity] -combineHighlightActivitiesBySession = - sortOn (Down . (.timeCompleted)) - . fmap - ( finalizeHighlightActivity - . Unsafe.foldr1 unsafeCombineStudentHighlightActivities - ) - . groupHighlightActivities - --- | Finalize a `StudentActivity`s aggregation --- --- A fragment of an activity may represent a single session or multiple --- fragments of a session. A finalized activity represents the session in --- total. To produce correct downstream aggregates certain metrics must be --- condensed in the final aggregate. --- --- Average must be condensed to have correct weight. Otherwise individual --- fragment weights would cause odd results -finalizeActivity :: StudentActivity 'Fragment -> StudentActivity 'Final -finalizeActivity activity = - activity - { StudentActivity.score = - maybe activity.score (Just . ScorePercentage . averageDatum) - $ getAverage - =<< activityToAccuracyPercentage activity +import TestImport + +import Data.Aeson.KeyMap qualified as KeyMap +import Data.BCP47 qualified as BCP47 +import Data.Text qualified as T +import Freckle.Api.Auth.Jwt (ExpiresAt (..), JwtParam (..), encodeJwt) +import Freckle.Api.Auth.RenaissanceSso.AuthPlugin (pluginName) +import Freckle.Api.Dal.Utilities.Persistent +import Freckle.Api.Test.School (setSchoolHeaders) +import Freckle.Core.IdentityProvider (IdentityProvider (RenaissanceIdp)) +import Freckle.Core.JwtCredentials (defaultJwtCredentials) +import Freckle.Entities.Course +import Freckle.Entities.CourseMembership +import Freckle.Entities.District +import Freckle.Entities.License +import Freckle.Entities.RenaissanceSchoolClient +import Freckle.Entities.School +import Freckle.Entities.SchoolAdmin +import Freckle.Entities.SchoolAdminSchoolMembership +import Freckle.Entities.Student +import Freckle.Entities.StudentIdentifier +import Freckle.Entities.Teacher +import Freckle.Renaissance.AppTag (AppTag (AppTagFreckle, AppTagOther)) +import Freckle.Renaissance.AppTags (AppTags (AppTags)) +import Freckle.Renaissance.RPIdentifier (RPIdentifier (..), retagRPIdentifier) +import Freckle.Sis (SisId) +import Test.QuickCheck qualified as QuickCheck +import Yesod.Auth (Route (PluginR)) + +-- See tests/Freckle/Api/Auth/Jwt.hs for testing of generic JWT +-- functionality, e.g. expiration, audience, malformed payload + +spec :: Spec +spec = withApp loadApp $ do + describe "POST /auth/page/renaissance-sso/session" $ do + let route = AuthR $ PluginR pluginName ["session"] + + describe "renaissance-sso student login" $ do + describe "when parsing the student jwt" $ do + it "rejects a student with no classes" $ do + studentId <- liftIO $ QuickCheck.generate arbitrary + + postJwt route =<< mkStudent studentId Nothing (Just "1") [] + + body <- statusIs 401 >> getJsonBody + body `shouldBeMessage` ["Student has no classes"] + + it "rejects a student with no grade" $ do + Ids {..} <- genIds + + postJwt route + =<< mkStudent + studentId1 + Nothing + Nothing + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId1 Nothing + ] + + body <- statusIs 401 >> getJsonBody + body `shouldBeMessage` ["Student has no grade"] + + it "rejects a student with a grade outside the acceptable range" $ do + Ids {..} <- genIds + + postJwt route + =<< mkStudent + studentId1 + Nothing + (Just "13") + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId1 Nothing + ] + + body <- statusIs 401 >> getJsonBody + body + `shouldBeMessage` [ "Could not decode token payload:" + , "Error in $.grade:" + , "Cannot convert \"13\" to SchoolGrade" + ] + + describe "when the student does not exist" $ do + it "rejects the student if none of their schools exist" $ withGraph $ do + Ids {..} <- genIds + + postJwt route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId1 Nothing + ] + + body <- statusIs 401 >> getJsonBody + body + `shouldBeMessage` [ "Login not found: Student " + , getRPIdentifier studentId1 + , " Error: None of the specified schools are known to Freckle." + , " Has the lead teacher for your class validated their email?" + ] + + it "creates the teacher and student if at least one of their schools exist" $ withGraph $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + void + $ node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + + postJwt route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [classFields courseId1 "Class 1" teacherId1 email1 schoolId1 Nothing] + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + void $ fetchJust $ getBy $ RenaissanceStudentsUnique $ Just studentId1 + void $ fetchJust $ getBy $ RenaissanceTeachersUnique $ Just teacherId1 + + it + "accepts the student and creates a new teacher if their only course is associated with a different teacher" + $ withGraph + $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier (Just schoolId1) + + Entity frTeacherId _ <- + node (only $ Just frSchoolId) + $ edit + $ setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + void + $ node (frTeacherId, Just frSchoolId) + $ edit + $ setField CourseRenaissanceRPIdentifier (Just courseId1) + + postJwt route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [ classFields courseId1 "Class 1" teacherId2 email2 schoolId1 Nothing + ] + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + void + $ fetchJust + $ getBy + $ RenaissanceStudentsUnique + $ Just studentId1 + + void + $ fetchJust + $ getBy + $ RenaissanceTeachersUnique + $ Just teacherId1 + + it + "accepts the student if their only teacher is in one school, but their class is in another school in the same district" + $ withGraph + $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier (Just schoolId1) + + void + $ node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier (Just schoolId2) + + Entity frTeacherId _ <- + node (only $ Just frSchoolId) + $ edit + $ setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + void + $ node (frTeacherId, Just frSchoolId) + $ edit + $ setField CourseRenaissanceRPIdentifier (Just courseId1) + + postJwt route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId2 Nothing + ] + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + it + "rejects the student if their only teacher is in one school, but their class is in another school in a different district" + $ withGraph + $ do + Ids {..} <- genIds + + Entity frDistrictId1 _ <- node () mempty + Entity frDistrictId2 _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId1) + $ edit + $ setField SchoolRenaissanceRPIdentifier (Just schoolId1) + + void + $ node (only frDistrictId2) + $ edit + $ setField SchoolRenaissanceRPIdentifier (Just schoolId2) + + Entity frTeacherId _ <- + node (only $ Just frSchoolId) + $ edit + $ setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + void + $ node (frTeacherId, Just frSchoolId) + $ edit + $ setField CourseRenaissanceRPIdentifier (Just courseId1) + + postJwt route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId2 Nothing + ] + + body <- statusIs 401 >> getJsonBody + body + `shouldBeMessage` [ "Login not found: Student" + , getRPIdentifier studentId1 + , " Error: Login token is incoherent. Has the lead teacher for your class validated their email?" + ] + + it "creates the student if any of their courses exist and are coherent" + $ withGraph + $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier (Just schoolId1) + + Entity frTeacherId _ <- + node (only $ Just frSchoolId) + $ edit + $ setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + Entity frCourseId _ <- + node (frTeacherId, Just frSchoolId) + $ edit + $ setField CourseRenaissanceRPIdentifier (Just courseId1) + + postJwt route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId1 Nothing + , classFields courseId2 "Class 2" teacherId2 email2 schoolId1 Nothing + ] + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + Entity frStudentId _ <- + fetchJust + $ getBy + $ RenaissanceStudentsUnique + $ Just + studentId1 + + void + $ fetchJust + $ getBy + $ CourseMembershipsStudentIdCourseIdIdx + frStudentId + frCourseId + + it "updates `courses.rl_assigned_products` for existing courses" $ withGraph $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + + Entity frTeacherId _ <- + node (only $ Just frSchoolId) + $ edit + $ setField TeacherRenaissanceRPIdentifier + $ Just teacherId1 + + Entity _frCourseId _ <- + node (frTeacherId, Just frSchoolId) + $ edit + $ setField CourseRenaissanceRPIdentifier (Just courseId1) + . setField CourseName "Extant Course Name" + . setField CourseRlAssignedProducts Nothing + + let + jwtCourseName = "Class 1" + jwtAppTags = AppTags appTags + appTags = + AppTagOther "APPS_AR" + :| [AppTagOther "APPS_ST", AppTagFreckle Nothing] + + postJwt route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [ classFields + courseId1 + jwtCourseName + teacherId1 + email1 + schoolId1 + (Just jwtAppTags) + ] + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + Entity _courseId course <- + fetchJust + $ getBy + $ RenaissanceCoursesUniqueToTeacher + frTeacherId + (pure courseId1) + + courseRlAssignedProducts course `shouldBe` Just (JSONB jwtAppTags) + courseName course `shouldBe` jwtCourseName + + it + "creates the student and course if any of their teachers exist and are coherent" + $ withGraph + $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier (Just schoolId1) + + Entity frTeacherId _ <- + node (only $ Just frSchoolId) + $ edit + $ setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + postJwt route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId1 Nothing + , classFields courseId2 "Class 2" teacherId2 email2 schoolId1 Nothing + ] + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + Entity frStudentId _ <- + fetchJust + $ getBy + $ RenaissanceStudentsUnique + $ Just studentId1 + + Entity frCourseId _ <- + fetchJust + $ getBy + $ RenaissanceCoursesUniqueToTeacher frTeacherId + $ Just courseId1 + + void + $ fetchJust + $ getBy + $ CourseMembershipsStudentIdCourseIdIdx frStudentId frCourseId + + it + "creates the student and courses if any of their teachers exist even if they share courses" + $ withGraph + $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier (Just schoolId1) + + Entity frTeacherId1 _ <- + node (only $ Just frSchoolId) + $ edit + $ setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + Entity frTeacherId2 _ <- + node (only $ Just frSchoolId) + $ edit + $ setField TeacherRenaissanceRPIdentifier (Just teacherId2) + + postJwt route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId1 Nothing + , classFields courseId1 "Class 1" teacherId2 email2 schoolId1 Nothing + ] + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + Entity frStudentId _ <- + fetchJust + $ getBy + $ RenaissanceStudentsUnique + $ Just studentId1 + + Entity frCourseId1 _ <- + fetchJust + $ getBy + $ RenaissanceCoursesUniqueToTeacher frTeacherId1 + $ Just courseId1 + + Entity frCourseId2 _ <- + fetchJust + $ getBy + $ RenaissanceCoursesUniqueToTeacher frTeacherId2 + $ Just courseId1 + + void + $ fetchJust + $ getBy + $ CourseMembershipsStudentIdCourseIdIdx frStudentId frCourseId1 + + void + $ fetchJust + $ getBy + $ CourseMembershipsStudentIdCourseIdIdx frStudentId frCourseId2 + + it + "creates the student and courses if any of their teachers exist even if they are in different schools" + $ withGraph + $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId1 _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier (Just schoolId1) + + Entity frSchoolId2 _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier (Just schoolId2) + + Entity frTeacherId1 _ <- + node (only $ Just frSchoolId1) + $ edit + $ setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + Entity frTeacherId2 _ <- + node (only $ Just frSchoolId2) + $ edit + $ setField TeacherRenaissanceRPIdentifier (Just teacherId2) + + postJwt route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId1 Nothing + , classFields courseId2 "Class 2" teacherId2 email2 schoolId2 Nothing + ] + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + Entity frStudentId _ <- + fetchJust + $ getBy + $ RenaissanceStudentsUnique + $ Just studentId1 + + Entity frCourseId1 _ <- + fetchJust + $ getBy + $ RenaissanceCoursesUniqueToTeacher frTeacherId1 + $ Just courseId1 + + Entity frCourseId2 _ <- + fetchJust + $ getBy + $ RenaissanceCoursesUniqueToTeacher frTeacherId2 + $ Just courseId2 + + void + $ fetchJust + $ getBy + $ CourseMembershipsStudentIdCourseIdIdx frStudentId frCourseId1 + + void + $ fetchJust + $ getBy + $ CourseMembershipsStudentIdCourseIdIdx frStudentId frCourseId2 + + it + "rejects the student if student district ID does not match JWT district" + $ withGraph + $ do + Ids {..} <- genIds + + Entity frDistrictId1 _ <- node @District () mempty + Entity frDistrictId2 _ <- node @District () mempty + + void + $ node @Student (Only Nothing) + $ edit + $ (persistFieldLens StudentDistrictId ?~ frDistrictId1) + . (persistFieldLens StudentRenaissanceRPIdentifier ?~ studentId1) + + void + $ node @School (Only frDistrictId2) + $ edit + $ persistFieldLens SchoolRenaissanceRPIdentifier + ?~ schoolId1 + + postJwt route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId1 Nothing + ] + + body <- statusIs 401 >> getJsonBody + body + `shouldBeMessage` [ "Login not found: Student " + , getRPIdentifier studentId1 + , " Error: Current student district ID " + , toPathPiece frDistrictId1 + , " differs from JWT district ID " + , toPathPiece frDistrictId2 + ] + it + "rejects the student if any of their teachers exist in different districts" + $ withGraph + $ do + Ids {..} <- genIds + + Entity frDistrictId1 _ <- node () mempty + Entity frDistrictId2 _ <- node () mempty + + Entity frSchoolId1 _ <- + node (only frDistrictId1) + $ edit + $ setField SchoolRenaissanceRPIdentifier (Just schoolId1) + + Entity frSchoolId2 _ <- + node (only frDistrictId2) + $ edit + $ setField SchoolRenaissanceRPIdentifier (Just schoolId2) + + void + $ node (only $ Just frSchoolId1) + $ edit + $ setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + void + $ node (only $ Just frSchoolId2) + $ edit + $ setField TeacherRenaissanceRPIdentifier (Just teacherId2) + + postJwt route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId1 Nothing + , classFields courseId2 "Class 2" teacherId2 email2 schoolId2 Nothing + ] + + body <- statusIs 401 >> getJsonBody + body + `shouldBeMessage` [ "Login not found: Student " + , getRPIdentifier studentId1 + , " Error: Multiple district IDs found in JWT - " + , T.intercalate ", " + $ map + toPathPiece + [frDistrictId1, frDistrictId2] + ] + + it "is idempotent with respect to course[membership] creation" + $ withGraph + $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier (Just schoolId1) + + Entity frTeacherId _ <- + node (only $ Just frSchoolId) + $ edit + $ setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + payload <- + mkStudent + studentId1 + Nothing + (Just "1") + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId1 Nothing + , classFields courseId2 "Class 2" teacherId2 email2 schoolId1 Nothing + ] + + postJwt route payload + body1 <- statusIs 200 >> getJsonBody + body1 `shouldBeMessage` ["Login Successful"] + + Entity frStudentId _ <- + fetchJust + $ getBy + $ RenaissanceStudentsUnique + $ Just studentId1 + + (courseIdsBefore, membershipIdsBefore) <- + fetchSnapshot frTeacherId frStudentId + + postJwt route payload + body2 <- statusIs 200 >> getJsonBody + body2 `shouldBeMessage` ["Login Successful"] + + (courseIdsAfter, membershipIdsAfter) <- + fetchSnapshot frTeacherId frStudentId + + courseIdsBefore `shouldMatchList` courseIdsAfter + membershipIdsBefore `shouldMatchList` membershipIdsAfter + + let genRenStudent renaissanceId frTeacherId edits = do + Entity frStudentId _ <- + node (only $ Just frTeacherId) + $ edit + $ setField StudentRenaissanceRPIdentifier (Just renaissanceId) + . edits + + let (renaissanceIdType, opaqueRenaissanceId) = + untagIdentifier $ TaggedRpIdentifier renaissanceId + void + $ node @StudentIdentifier (only frStudentId) + $ edit + $ setField StudentIdentifierIdentifierType renaissanceIdType + . setField StudentIdentifierIdentifier opaqueRenaissanceId + + pure frStudentId + + describe "when the student does exist" $ do + it + "accepts the student and creates a new teacher if their only course is associated with a different teacher" + $ withGraph + $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + + Entity frTeacherId _ <- + node (only $ Just frSchoolId) + $ edit + $ setField TeacherRenaissanceRPIdentifier + $ Just teacherId1 + + Entity frCourseId _ <- + node (frTeacherId, Just frSchoolId) + $ edit + $ setField + CourseRenaissanceRPIdentifier + (Just courseId1) + + frStudentId <- genRenStudent studentId1 frTeacherId id + + void $ node @CourseMembership (frStudentId, frCourseId) mempty + + postJwt route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [ classFields courseId1 "Class 1" teacherId2 email2 schoolId1 Nothing + ] + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + void + $ fetchJust + $ getBy + $ RenaissanceTeachersUnique + $ Just teacherId1 + + it + "accepts the student if their only teacher is in one school, but their class is in another school in the same district" + $ withGraph + $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + + void + $ node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId2 + + Entity frTeacherId _ <- + node (only $ Just frSchoolId) + $ edit + $ setField TeacherRenaissanceRPIdentifier + $ Just teacherId1 + + Entity frCourseId _ <- + node (frTeacherId, Just frSchoolId) + $ edit + $ setField + CourseRenaissanceRPIdentifier + (Just courseId1) + + frStudentId <- genRenStudent studentId1 frTeacherId id + + void $ node @CourseMembership (frStudentId, frCourseId) mempty + + postJwt route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId2 Nothing + ] + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + it + "allows a student to login if sync fails, but they already had a course from the JWT" + $ withGraph + $ do + -- Specifically, the sync fails here because it would require moving a teacher into + -- another district. However, we can still let the student log into the course + -- that already exists. + Ids {..} <- genIds + + Entity frDistrictId1 _ <- node () mempty + Entity frDistrictId2 _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId1) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + + void + $ node (only frDistrictId2) + $ edit + $ setField SchoolRenaissanceRPIdentifier (Just schoolId2) + + Entity frTeacherId _ <- + node (only $ Just frSchoolId) + $ edit + $ setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + Entity frCourseId _ <- + node (frTeacherId, Just frSchoolId) + $ edit + $ setField CourseRenaissanceRPIdentifier (Just courseId1) + + frStudentId <- genRenStudent studentId1 frTeacherId id + + void $ node @CourseMembership (frStudentId, frCourseId) mempty + + postJwt route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId2 Nothing + ] + + Entity _ updatedCourse <- + fetchJust + $ getBy + $ RenaissanceCoursesUniqueToTeacher frTeacherId + $ Just courseId1 + courseSchoolId updatedCourse `shouldBe` Just frSchoolId + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + it "creates a course if none of their courses exist" $ withGraph $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + + Entity frTeacherId _ <- + node (only $ Just frSchoolId) + $ edit + $ setField TeacherRenaissanceRPIdentifier + $ Just teacherId1 + + frStudentId <- genRenStudent studentId1 frTeacherId id + + postJwt route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId1 Nothing + ] + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + Entity frCourseId _ <- + fetchJust + $ getBy + $ RenaissanceCoursesUniqueToTeacher frTeacherId + $ Just courseId1 + + void + $ fetchJust + $ getBy + $ CourseMembershipsStudentIdCourseIdIdx frStudentId frCourseId + + it "accepts a student if any of their courses exist and are coherent" + $ withGraph + $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + + Entity frTeacherId _ <- + node (only $ Just frSchoolId) + $ edit + $ setField TeacherRenaissanceRPIdentifier + $ Just teacherId1 + + Entity frCourseId _ <- + node (frTeacherId, Just frSchoolId) + $ edit + $ setField + CourseRenaissanceRPIdentifier + (Just courseId2) + + frStudentId <- genRenStudent studentId1 frTeacherId id + + void $ node @CourseMembership (frStudentId, frCourseId) mempty + + postJwt route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId1 Nothing + , classFields courseId2 "Class 2" teacherId1 email1 schoolId1 Nothing + ] + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + it "redirects a student to the student application" $ withGraph $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + + Entity frTeacherId _ <- + node (only $ Just frSchoolId) + $ edit + $ setField TeacherRenaissanceRPIdentifier + $ Just teacherId1 + + Entity frCourseId _ <- + node (frTeacherId, Just frSchoolId) + $ edit + $ setField + CourseRenaissanceRPIdentifier + (Just courseId2) + + frStudentId <- genRenStudent studentId1 frTeacherId id + + void $ node @CourseMembership (frStudentId, frCourseId) mempty + + postJwtAccept "text/html" route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId1 Nothing + , classFields courseId2 "Class 2" teacherId1 email1 schoolId1 Nothing + ] + + statusIs 303 + assertHeaderContains "Location" "student" + + it "provides a redirectUrl when a student logs out" $ withGraph $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + + Entity frTeacherId _ <- + node (only $ Just frSchoolId) + $ edit + $ setField TeacherRenaissanceRPIdentifier + $ Just teacherId1 + + Entity frCourseId _ <- + node (frTeacherId, Just frSchoolId) + $ edit + $ setField + CourseRenaissanceRPIdentifier + (Just courseId2) + + frStudentId <- genRenStudent studentId1 frTeacherId id + + void $ node @CourseMembership (frStudentId, frCourseId) mempty + + postJwtAccept "text/html" route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId1 Nothing + , classFields courseId2 "Class 2" teacherId1 email1 schoolId1 Nothing + ] + + request $ do + addJsonHeaders + setMethod "DELETE" + setUrl $ V2P $ StudentsP StudentsSessionsR + body <- statusIs 200 >> getJsonBody + body + `shouldMatchJson` [aesonQQ|{ + redirectUrl: "https://global-lmb2.renaissance-golabs.com/educatorportal/home/logout" + }|] + + it "exposes the keepalive url to the client" $ withGraph $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + + Entity frTeacherId _ <- + node (only $ Just frSchoolId) + $ edit + $ setField TeacherRenaissanceRPIdentifier + $ Just teacherId1 + + Entity frCourseId _ <- + node (frTeacherId, Just frSchoolId) + $ edit + $ setField + CourseRenaissanceRPIdentifier + (Just courseId2) + + frStudentId <- genRenStudent studentId1 frTeacherId id + + void $ node @CourseMembership (frStudentId, frCourseId) mempty + + postJwtAccept "text/html" route + =<< mkStudent + studentId1 + Nothing + (Just "1") + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId1 Nothing + , classFields courseId2 "Class 2" teacherId1 email1 schoolId1 Nothing + ] + + request $ do + addJsonHeaders + setUrl $ V2P $ StudentsP SelfStudentR + body <- statusIs 200 >> getJsonBody + body + `shouldMatchJson` [aesonQQ|{ + renaissanceKeepalive: { + url: "https://global-lmb2.renaissance-golabs.com/identityservice/sso/ping", + intervalMinutes: 15 + } + }|] + + describe "when a different student with the same SIS Id exists" $ do + it "creates a new student" $ withGraph $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + + Entity frTeacherId _ <- + node (only $ Just frSchoolId) + $ edit + $ setField TeacherRenaissanceRPIdentifier + $ Just teacherId1 + + Entity frCourseId _ <- + node (frTeacherId, Just frSchoolId) + $ edit + $ setField + CourseRenaissanceRPIdentifier + (Just courseId1) + + Entity frStudentId _ <- + node (only $ Just frTeacherId) + $ edit + $ setField StudentRenaissanceRPIdentifier Nothing + . setField StudentFirstName "Joe" + . setField StudentLastName "Bob" + . setField StudentGrade G1 + . setField StudentSisId (Just sisId) + . setField StudentDistrictId (Just frDistrictId) + let (sisIdType, opaqueSisId) = untagIdentifier $ TaggedSisId sisId + void + $ node @StudentIdentifier (Only frStudentId) + $ edit + $ setField StudentIdentifierIdentifierType sisIdType + . setField StudentIdentifierIdentifier opaqueSisId + + void $ node @CourseMembership (frStudentId, frCourseId) mempty + + postJwt route + $ mkStudentNamed + "Joe" + "Bob" + studentId1 + (Just sisId) + (Just "1") + [ classFields courseId1 "Class 1" teacherId1 email1 schoolId1 Nothing + , classFields courseId2 "Class 2" teacherId2 email2 schoolId1 Nothing + ] + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + Entity unmodifiedStudentId _ <- + fetchJust $ getBy $ RenaissanceStudentsUnique $ Just studentId1 + + void + $ fetchJust + $ getBy + $ CourseMembershipsStudentIdCourseIdIdx + unmodifiedStudentId + frCourseId + unmodifiedStudentId `shouldNotBe` frStudentId + + describe "renaissance-sso teacher login" $ do + describe "when parsing the teacher jwt" $ do + it "rejects a teacher with no email" $ do + Ids {..} <- genIds + + postJwt route =<< mkTeacher teacherId1 Nothing [schoolId1] + + body <- statusIs 401 >> getJsonBody + body `shouldBeMessage` ["Teacher has no email address"] + + it "rejects a teacher with no schools" $ do + Ids {..} <- genIds + + postJwt route =<< mkTeacher teacherId1 (Just email1) [] + + body <- statusIs 401 >> getJsonBody + body `shouldBeMessage` ["Teacher has no schools"] + + describe "when the teacher does not exist" $ do + it "rejects the teacher if none of their schools exist" $ do + Ids {..} <- genIds + + postJwt route =<< mkTeacher teacherId1 (Just email1) [schoolId1] + + body <- statusIs 401 >> getJsonBody + body + `shouldBeMessage` [ "Login not found: Teacher" + , getRPIdentifier teacherId1 + , "Error: No schools matching IDs " + , getRPIdentifier schoolId1 + ] + + it "creates the teacher if any of their schools exist" $ withGraph $ do + Ids {..} <- genIds + Entity frDistrictId _ <- node () mempty + + void + $ node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + + postJwt route =<< mkTeacher teacherId1 (Just email1) [schoolId1] + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + describe "when the teacher exists" $ do + it "rejects a teacher associated with a school not in the system" + $ withGraph + $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + + void + $ node (only $ Just frSchoolId) + $ edit + $ setField TeacherEmail email1 + . setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + postJwt route =<< mkTeacher teacherId1 (Just email1) [schoolId2] + + body <- statusIs 401 >> getJsonBody + body + `shouldBeMessage` [ "Login not found: Teacher" + , getRPIdentifier teacherId1 + , "Error: No schools matching IDs " + , getRPIdentifier schoolId2 + ] + + it "updates a teachers email" $ withGraph $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId2 + + void + $ node (only $ Just frSchoolId) + $ edit + $ setField TeacherEmail email1 + . setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + postJwt route + =<< mkTeacher teacherId1 (Just email2) [schoolId1, schoolId2] + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + Entity _ updatedTeacher <- + fetchJust $ getBy $ RenaissanceTeachersUnique $ Just teacherId1 + teacherEmail updatedTeacher `shouldBe` email2 + fetchNothing $ getBy $ TeachersLowerEmailUniqueIdx email1 + + it "associates a previously unaffiliated teacher with a school" + $ withGraph + $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + + void + $ node (only Nothing) + $ edit + $ setField TeacherEmail email1 + . setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + postJwt route =<< mkTeacher teacherId1 (Just email1) [schoolId1] + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + Entity _ updatedTeacher <- + fetchJust + $ getBy + $ RenaissanceTeachersUnique + $ Just + teacherId1 + teacherSchoolId updatedTeacher `shouldBe` Just frSchoolId + teacherEnvironment updatedTeacher `shouldBe` Just UsInSchool + + it "can take over a non-RGP teacher with the same email" + $ withGraph + $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + + void + $ node (only Nothing) + $ edit + $ setField TeacherEmail email1 + . setField TeacherRenaissanceRPIdentifier Nothing + + postJwt route =<< mkTeacher teacherId1 (Just email1) [schoolId1] + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + Entity _ updatedTeacher <- + fetchJust + $ getBy + $ RenaissanceTeachersUnique + $ Just + teacherId1 + teacherSchoolId updatedTeacher `shouldBe` Just frSchoolId + + it "moves a teacher from one school to another in the same district" + $ withGraph + $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId1 _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + + Entity frSchoolId2 _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId2 + + void + $ node (only $ Just frSchoolId1) + $ edit + $ setField TeacherEmail email1 + . setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + postJwt route =<< mkTeacher teacherId1 (Just email1) [schoolId2] + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + Entity _ updatedTeacher <- + fetchJust + $ getBy + $ RenaissanceTeachersUnique + $ Just + teacherId1 + teacherSchoolId updatedTeacher `shouldBe` Just frSchoolId2 + + it + "does not moves a teacher from one school to another in a different district" + $ withGraph + $ do + Ids {..} <- genIds + + Entity frDistrictId1 _ <- node () mempty + Entity frSchoolId1 _ <- + node (only frDistrictId1) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + + Entity frDistrictId2 _ <- node () mempty + Entity frSchoolId2 _ <- + node (only frDistrictId2) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId2 + + Entity frTeacherId _ <- + node (only $ Just frSchoolId1) + $ edit + $ setField TeacherEmail email1 + . setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + postJwt route =<< mkTeacher teacherId1 (Just email1) [schoolId2] + redirectsTo + $ mconcat + [ "https://classroom.localhost.com" + , "/sso-mismatched-school?sso-school-id=" + , toPathPiece frSchoolId2 + , "&freckle-school-id=" + , toPathPiece frSchoolId1 + , "&freckle-teacher-id=" + , toPathPiece frTeacherId + , "&renaissance-teacher-id=" + , getRPIdentifier teacherId1 + ] + + it + "accepts a teacher if they're associated with one of the specified schools" + $ withGraph + $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId2 + + void + $ node (only $ Just frSchoolId) + $ edit + $ setField TeacherEmail email1 + . setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + postJwt route + =<< mkTeacher + teacherId1 + (Just email1) + [schoolId1, schoolId2] + + body <- statusIs 200 >> getJsonBody + body `shouldBeMessage` ["Login Successful"] + + it "redirects a teacher to the classroom application" $ withGraph $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId2 + + void + $ node (only $ Just frSchoolId) + $ edit + $ setField TeacherEmail email1 + . setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + postJwtAccept "text/html" route + =<< mkTeacher teacherId1 (Just email1) [schoolId1, schoolId2] + + statusIs 303 + assertHeaderContains "Location" "classroom" + + it "redirects to the JWT redirect URL" $ withGraph $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId2 + + void + $ node (only $ Just frSchoolId) + $ edit + $ setField TeacherEmail email1 + . setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + let + createTpAssignmentURL = + "https://classroom.freckle.com/courses/1261999/assignments/targeted?numQuestions=10&subType=practice" + redirectObj = object [("redirect", createTpAssignmentURL)] + + postJwtAccept "text/html" route + . (`merge` redirectObj) + =<< mkTeacher teacherId1 (Just email1) [schoolId1, schoolId2] + + statusIs 303 + assertHeaderContains "Location" createTpAssignmentURL + + it "provides a redirectUrl when teacher logs out" $ withGraph $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId2 + + void + $ node (only $ Just frSchoolId) + $ edit + $ setField TeacherEmail email1 + . setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + postJwtAccept "text/html" route + =<< mkTeacher teacherId1 (Just email1) [schoolId1, schoolId2] + request $ do + addJsonHeaders + setMethod "DELETE" + setUrl $ V2P $ TeachersP TeachersSessionsR + body <- statusIs 200 >> getJsonBody + body + `shouldMatchJson` [aesonQQ|{ + redirectUrl: "https://global-lmb2.renaissance-golabs.com/educatorportal/home/logout" + }|] + + it "exposes the keepalive url to the client" $ withGraph $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId2 + + void + $ node (only $ Just frSchoolId) + $ edit + $ setField TeacherEmail email1 + . setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + postJwtAccept "text/html" route + =<< mkTeacher teacherId1 (Just email1) [schoolId1, schoolId2] + request $ do + addJsonHeaders + setUrl $ V2P $ TeachersP $ MeP TeachersMeR + body <- statusIs 200 >> getJsonBody + body + `shouldMatchJson` [aesonQQ|{ + renaissanceKeepalive: { + url: "https://global-lmb2.renaissance-golabs.com/identityservice/sso/ping", + intervalMinutes: 15 + } + }|] + + it "redirects home requests to the JWT url" $ withGraph $ do + Ids {..} <- genIds + + Entity frDistrictId _ <- node () mempty + + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId2 + + void + $ node (only $ Just frSchoolId) + $ edit + $ setField TeacherEmail email1 + . setField TeacherRenaissanceRPIdentifier (Just teacherId1) + + postJwtAccept "text/html" route + =<< mkTeacher teacherId1 (Just email1) [schoolId1, schoolId2] + request $ setUrl $ V3P $ RenaissanceP RenaissanceHomeR + redirectsTo + "https://global-lmb2.renaissance-golabs.com/educatorportal/home" + + describe "renaissance-sso admin login" $ do + describe "when parsing the admin jwt" $ do + it "rejects an admin with no email" $ do + Ids {..} <- genIds + + postJwt route =<< mkAdmin adminId1 Nothing [schoolId1] + + body <- statusIs 401 >> getJsonBody + body `shouldBeMessage` ["Admin has no email address"] + + it "rejects an admin with no schools" $ do + Ids {..} <- genIds + + postJwt route =<< mkAdmin adminId1 (Just email1) [] + + body <- statusIs 401 >> getJsonBody + body `shouldBeMessage` ["Admin has no schools"] + + describe "when the admin does not exist" $ do + it "rejects the admin if none of their schools exist" $ do + Ids {..} <- genIds + + postJwt route =<< mkAdmin adminId1 (Just email1) [schoolId1] + + body <- statusIs 401 >> getJsonBody + body + `shouldBeMessage` [ "Login not found: Admin" + , getRPIdentifier adminId1 + , "Error: No schools matching IDs " + , getRPIdentifier schoolId1 + ] + + it "rejects the admin if none of their schools are licensed" + $ withGraph + $ do + Ids {..} <- genIds + Entity frDistrictId _ <- node () mempty + + void + $ node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + + postJwt route =<< mkAdmin adminId1 (Just email1) [schoolId1] + + body <- statusIs 401 >> getJsonBody + body + `shouldBeMessage` [ "Login not found: Admin " + , getRPIdentifier adminId1 + , "Error: No licensed schools" + ] + + it "creates the admin if any of their schools are licensed" + $ withGraph + $ do + Ids {..} <- genIds + Entity frDistrictId _ <- node () mempty + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + licenseSchool frSchoolId + + postJwt route =<< mkAdmin adminId1 (Just email1) [schoolId1] + redirectsTo "https://school.localhost.com/app-selection" + + describe "when the admin exists" $ do + it "can take over a non-RGP admin with the same email" $ withGraph $ do + Ids {..} <- genIds + Entity frDistrictId _ <- node () mempty + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId2 + licenseSchool frSchoolId + + Entity frAdminId _ <- + node @SchoolAdmin (Only BCP47.en) + $ edit + $ setField SchoolAdminEmail email1 + . setField SchoolAdminVerified True + + void + $ node @SchoolAdminSchoolMembership (frAdminId, frSchoolId) mempty + + postJwt route + =<< mkAdmin adminId1 (Just email1) [schoolId1, schoolId2] + redirectsTo "https://school.localhost.com/app-selection" + + byEmail <- + fmap entityKey . fetchJust $ getBy $ SchoolAdminsEmailKey email1 + byAdminId <- + fmap entityKey + . fetchJust + $ getBy + $ RenaissanceSchoolAdminsUnique + $ Just adminId1 + byEmail `shouldBe` byAdminId + + it "associates a previously unaffiliated admin with a school" + $ withGraph + $ do + Ids {..} <- genIds + Entity frDistrictId _ <- node () mempty + Entity frSchoolId1 _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + + Entity frSchoolId2 _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId2 + + licenseSchool frSchoolId1 + + Entity frAdminId _ <- + node @SchoolAdmin (Only BCP47.en) + $ edit + $ setField SchoolAdminEmail email1 + . setField SchoolAdminVerified True + . setField SchoolAdminRenaissanceRPIdentifier (Just adminId1) + + void + $ node @SchoolAdminSchoolMembership + (frAdminId, frSchoolId1) + mempty + + postJwt route + =<< mkAdmin adminId1 (Just email1) [schoolId1, schoolId2] + redirectsTo "https://school.localhost.com/app-selection" + + void + $ fetchJust + $ getBy + $ SchoolAdminSchoolMembershipsSchoolAdminIdSchoolIdKey + frAdminId + frSchoolId1 + void + $ fetchJust + $ getBy + $ SchoolAdminSchoolMembershipsSchoolAdminIdSchoolIdKey + frAdminId + frSchoolId2 + + it "provides a redirectUrl when admin logs out" $ withGraph $ do + Ids {..} <- genIds + Entity frDistrictId _ <- node () mempty + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + licenseSchool frSchoolId + + postJwtAccept "text/html" route + =<< mkAdmin adminId1 (Just email1) [schoolId1] + request $ do + addJsonHeaders + setMethod "DELETE" + setUrl $ V2P $ SchoolAdminsP SchoolAdminsSessionsR + body <- statusIs 200 >> getJsonBody + body + `shouldMatchJson` [aesonQQ|{ + redirectUrl: "https://global-lmb2.renaissance-golabs.com/educatorportal/home/logout" + }|] + + it "exposes the keepalive url to the client" $ withGraph $ do + Ids {..} <- genIds + Entity frDistrictId _ <- node () mempty + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier (Just schoolId1) + . setField SchoolActiveIdp (Just RenaissanceIdp) + . setField SchoolSyncIdp True + licenseSchool frSchoolId + + postJwtAccept "text/html" route + =<< mkAdmin adminId1 (Just email1) [schoolId1] + request $ do + setUrl $ V2P $ SchoolAdminsP $ SchoolAdminsMeP SchoolAdminsMeR + setSchoolHeaders + body <- statusIs 200 >> getJsonBody + body + `shouldMatchJson` [aesonQQ|{ + renaissanceKeepalive: { + url: "https://global-lmb2.renaissance-golabs.com/identityservice/sso/ping", + intervalMinutes: 15 + }, + sharedRosteringEnabled: true, + renaissanceRPIdentifier: #{adminId1} + }|] + + it "redirects home requests to the JWT url" $ withGraph $ do + Ids {..} <- genIds + Entity frDistrictId _ <- node () mempty + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + licenseSchool frSchoolId + + postJwtAccept "text/html" route + =<< mkAdmin adminId1 (Just email1) [schoolId1] + request $ do + setUrl $ V3P $ RenaissanceP RenaissanceHomeR + setSchoolHeaders + redirectsTo + "https://global-lmb2.renaissance-golabs.com/educatorportal/home" + + describe "when a teacher is also an admin" $ do + it + "allows an admin with courses to relogin as a teacher after being redirected to the app selection page" + $ withGraph + $ do + Ids {..} <- genIds + Entity frDistrictId _ <- node () mempty + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier (Just schoolId1) + . setField SchoolActiveIdp (Just RenaissanceIdp) + . setField SchoolSyncIdp True + licenseSchool frSchoolId + + -- Login admin + admin <- mkAdmin adminId1 (Just email1) [schoolId1] + postJwt route + $ admin + `merge` object + [ "classes" + .= [ classFields + courseId1 + "Class 1" + adminId1 + email1 + schoolId1 + Nothing + ] + ] + redirectsTo "https://school.localhost.com/app-selection" + + -- Choose the classroom dashboard on the app selection page + request $ do + setSchoolHeaders + setUrl $ V2P $ SchoolAdminsP SchoolAdminsTeacherSessionsR + setMethod "POST" + setRequestBody $ encode Empty + + body1 <- statusIs 200 >> getJsonBody + body1 + `shouldMatchJson` [aesonQQ|{ + redirectUrl: "https://classroom.localhost.com" + }|] + + -- Verify that we're logged in as a teacher and our RL keepalive + -- data still remains + request $ do + addJsonHeaders + setUrl $ V2P $ TeachersP $ MeP TeachersMeR + body2 <- statusIs 200 >> getJsonBody + body2 + `shouldMatchJson` [aesonQQ|{ + renaissanceKeepalive: { + url: "https://global-lmb2.renaissance-golabs.com/identityservice/sso/ping", + intervalMinutes: 15 + }, + renaissanceRPIdentifier: #{adminId1} + }|] + + it + "redirects back to school if the teacher id becomes invalid between roundtrips" + $ withGraph + $ do + Ids {..} <- genIds + Entity frDistrictId _ <- node () mempty + Entity frSchoolId _ <- + node (only frDistrictId) + $ edit + $ setField SchoolRenaissanceRPIdentifier + $ Just schoolId1 + licenseSchool frSchoolId + + -- Login admin + admin <- mkAdmin adminId1 (Just email1) [schoolId1] + postJwt route + $ admin + `merge` object + [ "classes" + .= [ classFields + courseId1 + "Class 1" + adminId1 + email1 + schoolId1 + Nothing + ] + ] + redirectsTo "https://school.localhost.com/app-selection" + + -- Move the teacher out of RL + runSqlTx + $ updateWhere + [ TeacherRenaissanceRPIdentifier + ==. Just (retagRPIdentifier adminId1) + ] + [TeacherRenaissanceRPIdentifier =. Nothing] + + -- Choose the classroom dashboard on the app selection page + request $ do + setSchoolHeaders + setUrl $ V2P $ SchoolAdminsP SchoolAdminsTeacherSessionsR + setMethod "POST" + setRequestBody $ encode Empty + + body1 <- statusIs 200 >> getJsonBody + body1 + `shouldMatchJson` [aesonQQ|{ + redirectUrl: "https://school.localhost.com" + }|] + +mkStudent + :: MonadIO m + => RPIdentifier Student + -> Maybe (SisId Student) + -> Maybe Text + -> [Value] + -> m Value +mkStudent studentId sisId grade classes = do + f <- liftIO $ QuickCheck.generate $ mkStudentNamed <$> arbitrary <*> arbitrary + pure $ f studentId sisId grade classes + +mkStudentNamed + :: NameComponent + -> NameComponent + -> RPIdentifier Student + -> Maybe (SisId Student) + -> Maybe Text + -> [Value] + -> Value +mkStudentNamed firstName lastName studentId sisId grade classes = + commonFields firstName lastName + `merge` studentFields studentId sisId grade classes + +mkTeacher + :: MonadIO m + => RPIdentifier Teacher + -> Maybe EmailAddress + -> [RPIdentifier School] + -> m Value +mkTeacher teacherId email schoolIds = do + common <- + liftIO $ QuickCheck.generate $ commonFields <$> arbitrary <*> arbitrary + pure $ common `merge` teacherFields teacherId email schoolIds + +mkAdmin + :: MonadIO m + => RPIdentifier SchoolAdmin + -> Maybe EmailAddress + -> [RPIdentifier School] + -> m Value +mkAdmin adminId email schoolIds = do + common <- + liftIO $ QuickCheck.generate $ commonFields <$> arbitrary <*> arbitrary + pure $ common `merge` adminFields adminId email schoolIds + +classFields + :: RPIdentifier Course + -> Text + -> RPIdentifier owner + -> EmailAddress + -> RPIdentifier School + -> Maybe AppTags + -> Value +classFields classId name ownerId email schoolId apptags = + [aesonQQ| + { classid: #{classId} + , classname: #{name} + , teacherid: #{ownerId} + , schoolid: #{schoolId} + , apptags: #{apptags} + , teacher: + { given_name: "Teacher" + , family_name: #{ownerId} + , email: #{email} + } + } + |] + +studentFields + :: RPIdentifier Student + -> Maybe (SisId Student) + -> Maybe Text + -> [Value] + -> Value +studentFields studentId sisId grade classes = + [aesonQQ| + { roleid: "student" + , rid: #{studentId} + , sisid: #{sisId} + , grade: #{grade} + , classes: #{classes} + } + |] + +teacherFields + :: RPIdentifier Teacher + -> Maybe EmailAddress + -> [RPIdentifier School] + -> Value +teacherFields teacherId email schoolIds = + [aesonQQ| + { roleid: "teacher" + , rid: #{teacherId} + , email: #{email} + , schools: #{schoolIds} + } + |] + +adminFields + :: RPIdentifier SchoolAdmin + -> Maybe EmailAddress + -> [RPIdentifier School] + -> Value +adminFields adminId email schoolIds = + [aesonQQ| + { roleid: "schooladmin" + , rid: #{adminId} + , email: #{email} + , schools: #{schoolIds} } + |] -finalizeHighlightActivity - :: StudentHighlightActivity -> StudentHighlightActivity -finalizeHighlightActivity activity = - activity - { StudentHighlightActivity.score = - maybe activity.score (Just . ScorePercentage . averageDatum) - $ getAverage - =<< activityToAccuracyPercentage activity +commonFields :: NameComponent -> NameComponent -> Value +commonFields firstName lastName = + [aesonQQ| + { given_name: #{firstName} + , family_name: #{lastName} + , jti: "d75f47a1-b9cc-4dd1-ab3c-72845aae2b8b" + , rpid: "RP-17234488" + , clientid: "lmb2rd2" + , homeuri: "https://global-lmb2.renaissance-golabs.com/educatorportal/home" + , logouturi: "https://global-lmb2.renaissance-golabs.com/educatorportal/home/logout" + , keepaliveuri: "https://global-lmb2.renaissance-golabs.com/identityservice/sso/ping" + , timeoutminutes: 30 + , timetorespondminutes: 5 + , keepaliveintervalminutes: 15 } + |] + +postJwt + :: (MonadYesodExample site m, RedirectUrl site url) => url -> Value -> m () +postJwt = postJwtAccept "application/json" + +postJwtAccept + :: (MonadYesodExample site m, RedirectUrl site url) + => ByteString + -> url + -> Value + -> m () +postJwtAccept accept route value = do + now <- getCurrentTime + let + later = now `addDays` 1 + Right jwt = encodeJwt (ExpiresAt later) defaultJwtCredentials value + request $ do + setUrl route + addRequestHeader (hAccept, accept) + addPostParam "jwt" $ toPathPiece $ JwtParam jwt + setMethod "POST" -unsafeCombineStudentActivities - :: HasCallStack - => StudentActivity 'Fragment - -> StudentActivity 'Fragment - -> StudentActivity 'Fragment -unsafeCombineStudentActivities x y = unwrap $ combineStudentActivities x y +shouldBeMessage :: (HasCallStack, MonadIO m) => Value -> [Text] -> m () +shouldBeMessage body message = + normalize body + `shouldMatchJson` normalize [aesonQQ|{message: #{T.unwords message}}|] where - unwrap (Left err) = error err - unwrap (Right a) = a - -combineStudentActivities - :: StudentActivity 'Fragment - -> StudentActivity 'Fragment - -> Either String (StudentActivity 'Fragment) -combineStudentActivities x y = do - when (x.studentId /= y.studentId) - $ Left ("student IDs are not equal: " ++ show (x, y)) - when (x.product /= y.product) - $ Left ("products are not equal: " ++ show (x, y)) - when (x.sessionId /= y.sessionId) - $ Left ("session IDs are not equal" ++ show (x, y)) - when (x.topic /= y.topic) - $ Left ("topics are not equal" ++ show (x, y)) - pure - StudentActivity - { studentId = x.studentId - , gradeLevel = liftA2 max x.gradeLevel y.gradeLevel - , contentLevel = x.contentLevel <|> y.contentLevel - , minutesPracticed = - case (x.minutesPracticed, y.minutesPracticed) of - (Just a, Just b) -> Just $ a + b - (ma, mb) -> ma <|> mb - , numberCorrect = - getSum <$> (Sum <$> x.numberCorrect) <> (Sum <$> y.numberCorrect) - , numberQuestions = - getSum <$> (Sum <$> x.numberQuestions) <> (Sum <$> y.numberQuestions) - , product = x.product - , assignmentId = x.assignmentId - , sessionId = x.sessionId - , score = do - ScorePercentage xScore <- x.score - ScorePercentage yScore <- y.score - pure $ ScorePercentage (xScore <> yScore) - , worth = getSum <$> (Sum <$> x.worth) <> (Sum <$> y.worth) - , timeCompleted = max x.timeCompleted y.timeCompleted - , topic = x.topic - , mathSubSkillPracticed = - getAny - <$> (Any <$> x.mathSubSkillPracticed) - <> (Any <$> y.mathSubSkillPracticed) - , prerequisiteAssignment = - getAny - <$> (Any <$> x.prerequisiteAssignment) - <> (Any <$> y.prerequisiteAssignment) - } + normalize = \case + Object obj -> Object $ normalize <$> obj + Array as -> Array $ normalize <$> as + String text -> String $ T.unwords $ T.words text + other -> other -unsafeCombineStudentHighlightActivities - :: HasCallStack - => StudentHighlightActivity - -> StudentHighlightActivity - -> StudentHighlightActivity -unsafeCombineStudentHighlightActivities x y = unwrap $ combineStudentHighlightActivities x y +merge :: Value -> Value -> Value +merge (Object lhs) (Object rhs) = Object $ KeyMap.unionWithKey explode lhs rhs where - unwrap (Left err) = error err - unwrap (Right a) = a - -combineStudentHighlightActivities - :: StudentHighlightActivity - -> StudentHighlightActivity - -> Either String StudentHighlightActivity -combineStudentHighlightActivities x y = do - when (x.studentId /= y.studentId) - $ Left ("student IDs are not equal: " ++ show (x, y)) - when (x.product /= y.product) - $ Left ("products are not equal: " ++ show (x, y)) - when (x.sessionId /= y.sessionId) - $ Left ("session IDs are not equal" ++ show (x, y)) - pure - StudentHighlightActivity - { studentId = x.studentId - , minutesPracticed = - case (x.minutesPracticed, y.minutesPracticed) of - (Just a, Just b) -> Just $ a + b - (ma, mb) -> ma <|> mb - , numberCorrect = - getSum <$> (Sum <$> x.numberCorrect) <> (Sum <$> y.numberCorrect) - , numberQuestions = - getSum <$> (Sum <$> x.numberQuestions) <> (Sum <$> y.numberQuestions) - , product = x.product - , assignmentId = x.assignmentId - , sessionId = x.sessionId - , score = do - ScorePercentage xScore <- x.score - ScorePercentage yScore <- y.score - pure $ ScorePercentage (xScore <> yScore) - , timeCompleted = max x.timeCompleted y.timeCompleted - } + explode key _ _ = error $ "Duplicate values for key " <> show key +merge _ _ = error "Can only merge objects" + +fetchJust :: (MonadSqlTx db m, Show a) => db (Maybe a) -> m a +fetchJust body = do + mEntity <- runSqlTx body + mEntity `shouldSatisfy` isJust + let Just entity = mEntity + pure entity + +fetchNothing + :: (MonadSqlTx db m, Show a) + => db (Maybe a) + -> m () +fetchNothing body = (`shouldSatisfy` isNothing) =<< runSqlTx body + +licenseSchool + :: GraphulaContext m '[License, RenaissanceSchoolClient] => SchoolId -> m () +licenseSchool schoolId = do + now <- getCurrentTime + void + $ node @License (only schoolId) + $ edit + $ setField LicenseStartsAt (now `subtractDays` 7) + . setField LicenseExpiresAt (now `addDays` 7) + . setField LicenseSubject SubjectMath + void $ node @RenaissanceSchoolClient (only schoolId) mempty + +data Ids = Ids + { studentId1 :: RPIdentifier Student + , studentId2 :: RPIdentifier Student + , courseId1 :: RPIdentifier Course + , courseId2 :: RPIdentifier Course + , teacherId1 :: RPIdentifier Teacher + , teacherId2 :: RPIdentifier Teacher + , adminId1 :: RPIdentifier SchoolAdmin + , adminId2 :: RPIdentifier SchoolAdmin + , schoolId1 :: RPIdentifier School + , schoolId2 :: RPIdentifier School + , email1 :: EmailAddress + , email2 :: EmailAddress + , sisId :: SisId Student + } + +genIds :: MonadIO m => m Ids +genIds = + liftIO + $ QuickCheck.generate + $ Ids + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +fetchSnapshot + :: MonadSqlTx db m + => TeacherId + -> StudentId + -> m ([CourseId], [CourseMembershipId]) +fetchSnapshot teacherId studentId = + runSqlTx $ do + courses <- + selectKeysList [CourseTeacherId ==. teacherId] [Asc CourseTeacherId] + memberships <- + selectKeysList + [CourseMembershipStudentId ==. studentId] + [Asc CourseMembershipStudentId] + pure (courses, memberships) -groupHighlightActivities - :: [StudentHighlightActivity] -> [NonEmpty StudentHighlightActivity] -groupHighlightActivities = - HashMap.elems - . HashMap.fromListWith (<>) - . fmap (((.product) &&& (.sessionId)) &&& pure) - -groupActivities - :: [StudentActivity 'Fragment] -> [NonEmpty (StudentActivity 'Fragment)] -groupActivities = - HashMap.elems - . HashMap.fromListWith (<>) - . fmap (((.product) &&& (.sessionId)) &&& pure) +redirectsTo :: MonadYesodExample site m => Text -> m () +redirectsTo expected = do + statusIs 303 + destination <- followRedirect + destination `shouldBe` Right expected From 8271b8c980d0cd57ce64d29dd5f2987e6a5c9894 Mon Sep 17 00:00:00 2001 From: "github-actions[bot]" Date: Fri, 17 Jan 2025 18:22:23 +0000 Subject: [PATCH 4/4] Update docs --- _docs/restylers.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/_docs/restylers.md b/_docs/restylers.md index 75cf6f7a..47465fb2 100644 --- a/_docs/restylers.md +++ b/_docs/restylers.md @@ -1,6 +1,6 @@ # Restylers -Built from `4ddd1c5b0ffb3eb25181e7b39aaa3cab9a307e4a`. +Built from `0324e2ee61ab295d8eeaa927501d4e09445b9d48`. | Restyler | Language(s) | Version | Runs automatically? | | -------- | ----------- | ------- | ------------------- |