diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index f138a2a4e..176f7d6ed 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -6,7 +6,7 @@ workflow: default: image: - name: fpco/stack-build:lts-16.31 + name: fpco/stack-build:lts-17.15 variables: STACK_ROOT: "${CI_PROJECT_DIR}/.stack" @@ -125,6 +125,9 @@ yesod:build:dev: - install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list - apt-get update -y - apt-get install -y --no-install-recommends locales-all openssh-client git-restore-mtime + - wget http://newmirror.rz.ifi.lmu.de/ubuntu/archive/pool/main/libs/libsodium/libsodium-dev_1.0.18-1_amd64.deb http://newmirror.rz.ifi.lmu.de/ubuntu/archive/pool/main/libs/libsodium/libsodium23_1.0.18-1_amd64.deb + - apt install ./libsodium23_1.0.18-1_amd64.deb ./libsodium-dev_1.0.18-1_amd64.deb + - rm -v libsodium23_1.0.18-1_amd64.deb libsodium-dev_1.0.18-1_amd64.deb - install -v -m 0700 -d ~/.ssh - install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts - install -v -T -m 0400 ${SSH_DEPLOY_KEY} ~/.ssh/deploy && echo "IdentityFile ~/.ssh/deploy" >> ~/.ssh/config; diff --git a/.hlint.yaml b/.hlint.yaml index 24e2d327e..9352cd5f6 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -13,6 +13,7 @@ - ignore: { name: "Redundant void" } - ignore: { name: "Too strict maybe" } - ignore: { name: "Use Just" } + - ignore: { name: "Use const" } - arguments: - -XQuasiQuotes diff --git a/config/settings.yml b/config/settings.yml index 441096909..7cefd42f4 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -194,6 +194,7 @@ session-token-encoding: HS256 session-token-clock-leniency-start: 5 bearer-token-clock-leniency-start: 5 +upload-token-clock-leniency-start: 5 cookies: SESSION: diff --git a/flake.lock b/flake.lock index b486ac53f..f5c74561b 100644 --- a/flake.lock +++ b/flake.lock @@ -2,11 +2,11 @@ "nodes": { "flake-utils": { "locked": { - "lastModified": 1619345332, - "narHash": "sha256-qHnQkEp1uklKTpx3MvKtY6xzgcqXDsz5nLilbbuL+3A=", + "lastModified": 1623875721, + "narHash": "sha256-A8BU7bjS5GirpAUv4QA+QnJ4CceLHkcXdRp4xITDB0s=", "owner": "numtide", "repo": "flake-utils", - "rev": "2ebf2558e5bf978c7fb8ea927dfaed8fefab2e28", + "rev": "f7e004a55b120c02ecb6219596820fcd32ca8772", "type": "github" }, "original": { @@ -18,11 +18,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1620323686, - "narHash": "sha256-+gfcE3YTGl+Osc8HzOUXSFO8/0PAK4J8ZxCXZ4hjXHI=", + "lastModified": 1624788075, + "narHash": "sha256-xzO2aL5gGejNvey2jKGnbnFXbo99pdytlY5FF/IhvAE=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "dfacb8329b2236688b9a1e705116203a213b283a", + "rev": "4ba70da807359ed01d662763a96c7b442762e5ef", "type": "github" }, "original": { diff --git a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg index 158a13a18..a38672835 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg @@ -105,6 +105,7 @@ BreadcrumbGlobalWorkflowInstanceList: Systemweite Workflows BreadcrumbTopWorkflowInstanceList !ident-ok: Workflows BreadcrumbTopWorkflowWorkflowList: Laufende Workflows BreadcrumbError: Fehler +BreadcrumbUpload !ident-ok: Upload BreadcrumbUserAdd: Benutzer:in anlegen BreadcrumbUserNotifications: Benachrichtigungs-Einstellungen BreadcrumbUserPassword: Passwort diff --git a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg index ecc66292b..f7fd04c97 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg @@ -105,6 +105,7 @@ BreadcrumbGlobalWorkflowInstanceList: System-wide workflows BreadcrumbTopWorkflowInstanceList: Workflows BreadcrumbTopWorkflowWorkflowList: Running workflows BreadcrumbError: Error +BreadcrumbUpload: Upload BreadcrumbUserAdd: Add user BreadcrumbUserNotifications: Notification settings BreadcrumbUserPassword: Password diff --git a/models/allocations.model b/models/allocations.model index cb275f2a2..de16d91da 100644 --- a/models/allocations.model +++ b/models/allocations.model @@ -53,7 +53,7 @@ AllocationUser AllocationDeregister -- self-inflicted user-deregistrations from an allocated course user UserId - course CourseId Maybe + course CourseId Maybe OnDeleteSetNull OnUpdateCascade time UTCTime reason Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button) deriving Eq Ord Show Generic diff --git a/models/courses.model b/models/courses.model index 581704aa5..6ea7c5a40 100644 --- a/models/courses.model +++ b/models/courses.model @@ -1,5 +1,5 @@ DegreeCourse json -- for which degree programmes this course is appropriate for - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade degree StudyDegreeId terms StudyTermsId UniqueDegreeCourse course degree terms @@ -31,7 +31,7 @@ Course -- Information about a single course; contained info is always visible deriving Generic CourseEvent type (CI Text) - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade room RoomReference Maybe roomHidden Bool default=false time Occurrences @@ -40,7 +40,7 @@ CourseEvent deriving Generic CourseAppInstructionFile - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade title FilePath content FileContentReference Maybe modified UTCTime @@ -50,11 +50,11 @@ CourseAppInstructionFile CourseEdit -- who edited when a row in table "Course", kept indefinitely (might be replaced by generic Audit Table; like all ...-Edit tables) user UserId time UTCTime - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade deriving Generic Lecturer -- course ownership user UserId - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade type LecturerType default='"lecturer"'::jsonb UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table deriving Generic diff --git a/models/courses/applications.model b/models/courses/applications.model index b5c342198..9cebe6855 100644 --- a/models/courses/applications.model +++ b/models/courses/applications.model @@ -13,7 +13,7 @@ CourseApplication deriving Generic CourseApplicationFile - application CourseApplicationId + application CourseApplicationId OnDeleteCascade OnUpdateCascade title FilePath content FileContentReference Maybe modified UTCTime diff --git a/models/courses/favourite.model b/models/courses/favourite.model index f42f5f6c4..8570b6051 100644 --- a/models/courses/favourite.model +++ b/models/courses/favourite.model @@ -1,12 +1,12 @@ CourseFavourite -- which user accessed which course when, only displayed to user for convenience; user UserId - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade reason FavouriteReason lastVisit UTCTime UniqueCourseFavourite user course deriving Generic CourseNoFavourite user UserId - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade UniqueCourseNoFavourite user course deriving Generic \ No newline at end of file diff --git a/models/courses/materials.model b/models/courses/materials.model index d020271bc..86355db83 100644 --- a/models/courses/materials.model +++ b/models/courses/materials.model @@ -1,5 +1,5 @@ Material -- course material for disemination to course participants - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade name (CI Text) type (CI Text) Maybe description StoredMarkup Maybe @@ -8,7 +8,7 @@ Material -- course material for disemination to course participants UniqueMaterial course name deriving Generic MaterialFile -- a file that is part of a material distribution - material MaterialId + material MaterialId OnDeleteCascade OnUpdateCascade title FilePath content FileContentReference Maybe modified UTCTime diff --git a/models/courses/news.model b/models/courses/news.model index c12bbe5d7..9f5390ceb 100644 --- a/models/courses/news.model +++ b/models/courses/news.model @@ -1,5 +1,5 @@ CourseNews - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade visibleFrom UTCTime Maybe participantsOnly Bool title Text Maybe @@ -8,7 +8,7 @@ CourseNews lastEdit UTCTime deriving Generic CourseNewsFile - news CourseNewsId + news CourseNewsId OnDeleteCascade OnUpdateCascade title FilePath content FileContentReference Maybe modified UTCTime diff --git a/models/files.model b/models/files.model index eb0c3ebf3..4d2b7506a 100644 --- a/models/files.model +++ b/models/files.model @@ -1,7 +1,7 @@ FileContentEntry hash FileContentReference ix Word64 - chunkHash FileContentChunkId + chunkHash FileContentChunkReference UniqueFileContentEntry hash ix deriving Generic diff --git a/models/sheets.model b/models/sheets.model index 92845f112..57213ec7b 100644 --- a/models/sheets.model +++ b/models/sheets.model @@ -1,5 +1,5 @@ Sheet -- exercise sheet for a given course - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade name (CI Text) description StoredMarkup Maybe type (SheetType SqlBackendKey) -- ExamPartId; Does it count towards overall course grade? @@ -20,14 +20,14 @@ Sheet -- exercise sheet for a given course SheetEdit -- who edited when a row in table "Course", kept indefinitely user UserId time UTCTime - sheet SheetId + sheet SheetId OnDeleteCascade OnUpdateCascade deriving Generic -- For anonoymous external submissions (i.e. paper submission tracked in uni2work) -- Map pseudonyms to users injectively in the context of a single sheet; for the next sheet all-new pseudonyms need to be created -- Chosen uniformly at random when the submitting user presses a button on the view of a sheet SheetPseudonym - sheet SheetId + sheet SheetId OnDeleteCascade OnUpdateCascade pseudonym Pseudonym -- 24-bit number that should be attached to external submission (i.e. written on the submitted paper); encoded as two english words akin to PGP-Wordlist user UserId UniqueSheetPseudonym sheet pseudonym @@ -35,13 +35,13 @@ SheetPseudonym deriving Generic SheetCorrector -- grant corrector role to user for a sheet user UserId - sheet SheetId + sheet SheetId OnDeleteCascade OnUpdateCascade load Load -- portion of work that will be assigned to this corrector state CorrectorState default='CorrectorNormal' -- whether a corrector is assigned his load this time (e.g. in case of sickness) UniqueSheetCorrector user sheet deriving Show Eq Ord Generic SheetFile -- a file that is part of an exercise sheet - sheet SheetId + sheet SheetId OnDeleteCascade OnUpdateCascade type SheetFileType -- excercise, marking, hint or solution title FilePath content FileContentReference Maybe @@ -49,7 +49,7 @@ SheetFile -- a file that is part of an exercise sheet UniqueSheetFile sheet type title deriving Generic PersonalisedSheetFile - sheet SheetId + sheet SheetId OnDeleteCascade OnUpdateCascade user UserId type SheetFileType title FilePath @@ -59,7 +59,7 @@ PersonalisedSheetFile deriving Eq Ord Read Show Typeable Generic FallbackPersonalisedSheetFilesKey - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade index Word24 secret ByteString generated UTCTime diff --git a/models/submissions.model b/models/submissions.model index 9b9b500fb..6a86bd854 100644 --- a/models/submissions.model +++ b/models/submissions.model @@ -9,10 +9,10 @@ Submission -- submission for marking by a CourseParticipa SubmissionEdit -- user uploads new version of their submission user UserId Maybe -- track id, important for group submissions time UTCTime - submission SubmissionId + submission SubmissionId OnDeleteCascade OnUpdateCascade deriving Generic SubmissionFile json -- files that are part of a submission - submission SubmissionId + submission SubmissionId OnDeleteCascade OnUpdateCascade title FilePath content FileContentReference Maybe modified UTCTime @@ -22,11 +22,11 @@ SubmissionFile json -- files that are part of a submission deriving Eq Ord Read Show Generic SubmissionUser -- which submission belongs to whom user UserId - submission SubmissionId + submission SubmissionId OnDeleteCascade OnUpdateCascade UniqueSubmissionUser user submission -- multiple users may share same submission, in case of (ad-hoc) submission groups deriving Generic SubmissionGroup -- pre-defined submission groups; some courses only allow pre-defined submission groups - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade name SubmissionGroupName UniqueSubmissionGroup course name deriving Generic diff --git a/models/system-messages.model b/models/system-messages.model index 5ba6b3c53..d7e3fd852 100644 --- a/models/system-messages.model +++ b/models/system-messages.model @@ -16,7 +16,7 @@ SystemMessage deriving Generic SystemMessageTranslation -- Translation of a @SystemMessage@ into another language; which language to choose is determined by user-sent HTTP-headers - message SystemMessageId + message SystemMessageId OnDeleteCascade OnUpdateCascade language Lang content StoredMarkup summary StoredMarkup Maybe @@ -24,7 +24,7 @@ SystemMessageTranslation -- Translation of a @SystemMessage@ into another langua deriving Generic SystemMessageHidden - message SystemMessageId + message SystemMessageId OnDeleteCascade OnUpdateCascade user UserId time UTCTime UniqueSystemMessageHidden user message diff --git a/models/tutorials.model b/models/tutorials.model index a364c203c..707d37ea8 100644 --- a/models/tutorials.model +++ b/models/tutorials.model @@ -1,6 +1,6 @@ Tutorial json name TutorialName - course CourseId + course CourseId OnDeleteCascade OnUpdateCascade type (CI Text) -- "Tutorium", "Zentralübung", ... capacity Int Maybe -- limit for enrolment in this tutorial room RoomReference Maybe @@ -15,12 +15,12 @@ Tutorial json UniqueTutorial course name deriving Generic Tutor - tutorial TutorialId + tutorial TutorialId OnDeleteCascade OnUpdateCascade user UserId UniqueTutor tutorial user deriving Generic TutorialParticipant - tutorial TutorialId + tutorial TutorialId OnDeleteCascade OnUpdateCascade user UserId UniqueTutorialParticipant tutorial user deriving Eq Ord Show diff --git a/models/workflows.model b/models/workflows.model index d68a91cee..d20d4e040 100644 --- a/models/workflows.model +++ b/models/workflows.model @@ -13,7 +13,7 @@ WorkflowDefinition deriving Generic WorkflowDefinitionDescription - definition WorkflowDefinitionId + definition WorkflowDefinitionId OnDeleteCascade OnUpdateCascade language Lang title Text description StoredMarkup Maybe @@ -21,7 +21,7 @@ WorkflowDefinitionDescription deriving Generic WorkflowDefinitionInstanceDescription - definition WorkflowDefinitionId + definition WorkflowDefinitionId OnDeleteCascade OnUpdateCascade language Lang title Text description StoredMarkup Maybe @@ -29,7 +29,7 @@ WorkflowDefinitionInstanceDescription deriving Generic WorkflowInstance - definition WorkflowDefinitionId Maybe + definition WorkflowDefinitionId Maybe OnDeleteSetNull OnUpdateCascade graph SharedWorkflowGraphId scope (WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) -- TermId, SchoolId, CourseId name WorkflowInstanceName diff --git a/package.yaml b/package.yaml index 612f2556d..d0306488d 100644 --- a/package.yaml +++ b/package.yaml @@ -318,6 +318,7 @@ tests: - uniworx - hspec >=2.0.0 - QuickCheck + - splitmix - HUnit - yesod-test - conduit-extra diff --git a/routes b/routes index 584f6a225..c9b45f88c 100644 --- a/routes +++ b/routes @@ -286,7 +286,11 @@ /msg/#{CryptoUUIDSystemMessage} MessageR GET POST !timeANDreadANDauthentication /msg/#{CryptoUUIDSystemMessage}/hide MessageHideR POST !timeANDauthentication + +/upload UploadR PUT !free + + !/#UUID CryptoUUIDDispatchR GET !free -- just redirect -- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists -!/*WellKnownFileName WellKnownR GET !free +!/*WellKnownFileName WellKnownR GET !free \ No newline at end of file diff --git a/src/Application.hs b/src/Application.hs index bcaf1edda..0c0fcbbd5 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -17,9 +17,10 @@ module Application ) where import Control.Monad.Logger (liftLoc, LoggingT(..), MonadLoggerIO(..)) -import Database.Persist.Postgresql ( openSimpleConn, pgConnStr, connClose, pgPoolIdleTimeout +import Database.Persist.Postgresql ( openSimpleConn, pgConnStr, pgPoolIdleTimeout , pgPoolSize ) +import Database.Persist.SqlBackend.Internal ( connClose ) import qualified Database.PostgreSQL.Simple as PG import Import hiding (cancel, respond) import Language.Haskell.TH.Syntax (qLocation) @@ -142,6 +143,7 @@ import Handler.Participants import Handler.StorageKey import Handler.Workflow import Handler.Error +import Handler.Upload -- This line actually creates our YesodDispatch instance. It is the second half diff --git a/src/Crypto/Random/Instances.hs b/src/Crypto/Random/Instances.hs index 3c840da89..687972e55 100644 --- a/src/Crypto/Random/Instances.hs +++ b/src/Crypto/Random/Instances.hs @@ -23,7 +23,8 @@ import qualified Data.ByteString as BS instance RandomGen ChaChaDRG where - next g = withRandomBytes g (finiteBitSize (maxBound :: Int) `div` 8) (foldr (\x acc -> acc `shiftL` 8 .|. fromIntegral x) zeroBits . BA.unpack @BA.Bytes) + genWord64 g = withRandomBytes g (finiteBitSize (maxBound :: Word64) `div` 8) (foldr (\x acc -> acc `shiftL` 8 .|. fromIntegral x) zeroBits . BA.unpack @BA.Bytes) + genWord32 g = withRandomBytes g (finiteBitSize (maxBound :: Word32) `div` 8) (foldr (\x acc -> acc `shiftL` 8 .|. fromIntegral x) zeroBits . BA.unpack @BA.Bytes) split g = withDRG g drgNew instance Binary Seed where diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index cdde140f5..bc5a483bd 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -22,7 +22,7 @@ import Language.Haskell.TH.Syntax (Lift(..)) import Data.Aeson (ToJSONKey(..), FromJSONKey(..), ToJSONKeyFunction(..)) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import Web.HttpApiData diff --git a/src/Database/Esqueleto/Instances.hs b/src/Database/Esqueleto/Instances.hs index c4dabfe41..5ead79af7 100644 --- a/src/Database/Esqueleto/Instances.hs +++ b/src/Database/Esqueleto/Instances.hs @@ -6,7 +6,7 @@ module Database.Esqueleto.Instances import ClassyPrelude.Yesod -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import Data.Binary (Binary) import qualified Data.Binary as B diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 3daa8b813..757f491d9 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -43,7 +43,7 @@ import Data.Universe import qualified Data.Set as Set import qualified Data.List as List import qualified Data.Foldable as F -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Internal.Internal as E import Database.Esqueleto.Utils.TH @@ -126,40 +126,24 @@ substring :: ( E.SqlString str -> E.SqlExpr (E.Value from) -> E.SqlExpr (E.Value for) -> E.SqlExpr (E.Value str) -substring (E.ERaw p1 f1) (E.ERaw p2 f2) (E.ERaw p3 f3) - = E.ERaw E.Never $ \info -> - let (strTLB, strVals) = f1 info - (fromiTLB, fromiVals) = f2 info - (foriTLB, foriVals) = f3 info - in ( "SUBSTRING" <> E.parens (E.parensM p1 strTLB <> " FROM " <> E.parensM p2 fromiTLB <> " FOR " <> E.parensM p3 foriTLB) +substring (E.ERaw _m1 f1) (E.ERaw _m2 f2) (E.ERaw _m3 f3) + = E.ERaw E.noMeta $ \_nParens info -> + let (strTLB, strVals) = f1 E.Parens info + (fromiTLB, fromiVals) = f2 E.Parens info + (foriTLB, foriVals) = f3 E.Parens info + in ( "SUBSTRING" <> E.parens (E.parens strTLB <> " FROM " <> E.parens fromiTLB <> " FOR " <> E.parens foriTLB) , strVals <> fromiVals <> foriVals ) -substring a b c = substring (construct a) (construct b) (construct c) explicitUnsafeCoerceSqlExprValue :: forall b a. Text -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b) -explicitUnsafeCoerceSqlExprValue typ (E.ERaw p1 f1) = E.ERaw E.Parens $ \info -> - let (valTLB, valVals) = f1 info - in ( E.parensM p1 valTLB <> " :: " <> Text.Builder.fromText typ +explicitUnsafeCoerceSqlExprValue typ (E.ERaw _m1 f1) = E.ERaw E.noMeta $ \_nParens info -> + let (valTLB, valVals) = f1 E.Parens info + in ( E.parens valTLB <> " :: " <> Text.Builder.fromText typ , valVals ) -explicitUnsafeCoerceSqlExprValue typ val = explicitUnsafeCoerceSqlExprValue typ $ construct val - -construct :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -construct (E.ERaw p f) = E.ERaw E.Parens $ \info -> - let (b1, vals) = f info - build ("?", [E.PersistList vals']) = - (E.uncommas $ replicate (length vals') "?", vals') - build expr = expr - in build (E.parensM p b1, vals) -construct (E.ECompositeKey f) = - E.ERaw E.Parens $ \info -> (E.uncommas $ f info, mempty) -construct (E.EAliasedValue i _) = - E.ERaw E.Never $ E.aliasedValueIdentToRawSql i -construct (E.EValueReference i i') = - E.ERaw E.Never $ E.valueReferenceToRawSql i i' and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) and = F.foldr (E.&&.) true @@ -485,12 +469,11 @@ diffTimes :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value UTCTime) -> E.Sql diffTimes a b = unsafeExtract "EPOCH" $ a E.-. b unsafeExtract :: String -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b) -unsafeExtract extr (E.ERaw vP vF) = E.ERaw E.Never $ \info -> - let (vTLB, vVals) = vF info - in ( "EXTRACT" <> E.parens (fromString extr <> " FROM " <> E.parensM vP vTLB) +unsafeExtract extr (E.ERaw _mF vF) = E.ERaw E.noMeta $ \_nParens info -> + let (vTLB, vVals) = vF E.Parens info + in ( "EXTRACT" <> E.parens (fromString extr <> " FROM " <> E.parens vTLB) , vVals ) -unsafeExtract extr v = unsafeExtract extr $ construct v class ExprLift e a | e -> a where diff --git a/src/Database/Esqueleto/Utils/TH.hs b/src/Database/Esqueleto/Utils/TH.hs index 3c21ce597..ff2fefef5 100644 --- a/src/Database/Esqueleto/Utils/TH.hs +++ b/src/Database/Esqueleto/Utils/TH.hs @@ -9,7 +9,7 @@ module Database.Esqueleto.Utils.TH import ClassyPrelude -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect) import Database.Persist (PersistField) diff --git a/src/Database/Persist/Class/Instances.hs b/src/Database/Persist/Class/Instances.hs index 24eb0902c..02401e3af 100644 --- a/src/Database/Persist/Class/Instances.hs +++ b/src/Database/Persist/Class/Instances.hs @@ -31,8 +31,8 @@ instance PersistEntity record => Binary (Key record) where get = either (fail . unpack) return . fromPersistValue =<< Binary.get -uniqueToMap :: PersistEntity record => Unique record -> Map (HaskellName, DBName) PersistValue -uniqueToMap = fmap Map.fromList $ zip <$> persistUniqueToFieldNames <*> persistUniqueToValues +uniqueToMap :: PersistEntity record => Unique record -> Map (FieldNameHS, FieldNameDB) PersistValue +uniqueToMap = fmap Map.fromList $ zip <$> fmap toList persistUniqueToFieldNames <*> persistUniqueToValues instance PersistEntity record => Eq (Unique record) where (==) = (==) `on` uniqueToMap diff --git a/src/Database/Persist/Types/Instances.hs b/src/Database/Persist/Types/Instances.hs index 3c79521d1..852538b93 100644 --- a/src/Database/Persist/Types/Instances.hs +++ b/src/Database/Persist/Types/Instances.hs @@ -17,6 +17,14 @@ import Data.Binary.Instances.Time as Import () import Data.Binary (Binary) +deriving instance Generic LiteralType +deriving instance Typeable LiteralType + +instance Hashable LiteralType +instance Binary LiteralType +instance NFData LiteralType + + deriving instance Generic PersistValue deriving instance Typeable PersistValue diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 912007db1..5d3f9a697 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -48,7 +48,7 @@ import qualified Data.Text as Text import Data.List (findIndex, inits) import Data.Semigroup (Last(..)) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Control.Monad.Error.Class (MonadError(..)) diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index 730d0ad29..16cc1143d 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -48,7 +48,7 @@ import qualified Data.Binary as Binary import qualified Data.CaseInsensitive as CI -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E -- Please see the documentation for the Yesod typeclass. There are a number diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index e97320722..5be9cbd42 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -30,7 +30,7 @@ import Handler.Utils.ExamOffice.Course import Utils.Sheet import qualified Data.CaseInsensitive as CI -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Control.Monad.Trans.State (execStateT) @@ -79,6 +79,7 @@ breadcrumb (StaticR _) = i18nCrumb MsgBreadcrumbStatic Nothing breadcrumb (WellKnownR _) = i18nCrumb MsgBreadcrumbWellKnown Nothing breadcrumb MetricsR = i18nCrumb MsgBreadcrumbMetrics Nothing breadcrumb ErrorR = i18nCrumb MsgBreadcrumbError Nothing +breadcrumb UploadR = i18nCrumb MsgBreadcrumbUpload Nothing breadcrumb NewsR = i18nCrumb MsgMenuNews Nothing breadcrumb UsersR = i18nCrumb MsgMenuUsers $ Just AdminR diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index c8e2955db..b8e1751c5 100644 --- a/src/Foundation/SiteLayout.hs +++ b/src/Foundation/SiteLayout.hs @@ -30,7 +30,7 @@ import qualified Data.Text as Text import qualified Data.Set as Set import qualified Data.HashMap.Strict as HashMap -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Conduit.Combinators as C diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index b4e72497e..8460462e9 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -39,7 +39,7 @@ import Data.ByteArray (convert) import Crypto.Hash (SHAKE128) import qualified Data.Binary as Binary -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Crypto.Hash.Conduit (sinkHash) diff --git a/src/Foundation/Yesod/Persist.hs b/src/Foundation/Yesod/Persist.hs index 6c7bccae4..67007f420 100644 --- a/src/Foundation/Yesod/Persist.hs +++ b/src/Foundation/Yesod/Persist.hs @@ -14,6 +14,7 @@ import Foundation.Authorization import Database.Persist.Sql (transactionUndo) import qualified Database.Persist.Sql as SQL +import qualified Database.Persist.SqlBackend.Internal as SQL import qualified Utils.Pool as Custom diff --git a/src/Handler/Admin/StudyFeatures.hs b/src/Handler/Admin/StudyFeatures.hs index d75e14e58..ef6b7f051 100644 --- a/src/Handler/Admin/StudyFeatures.hs +++ b/src/Handler/Admin/StudyFeatures.hs @@ -12,7 +12,7 @@ import qualified Data.Text as Text import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter) import qualified Handler.Utils.TermCandidates as Candidates diff --git a/src/Handler/Admin/Test/Download.hs b/src/Handler/Admin/Test/Download.hs index 9bf85419d..c27e512d2 100644 --- a/src/Handler/Admin/Test/Download.hs +++ b/src/Handler/Admin/Test/Download.hs @@ -18,7 +18,7 @@ import Data.Binary.Builder (Builder) import Control.Monad.Random.Lazy (evalRandT, liftRandT) -import qualified Database.Esqueleto as E hiding (random_) +import qualified Database.Esqueleto.Legacy as E hiding (random_) import qualified Database.Esqueleto.PostgreSQL as E diff --git a/src/Handler/Admin/Tokens.hs b/src/Handler/Admin/Tokens.hs index 0d29853a6..a684392c2 100644 --- a/src/Handler/Admin/Tokens.hs +++ b/src/Handler/Admin/Tokens.hs @@ -16,7 +16,7 @@ import Data.Map ((!), (!?)) import qualified Data.Text as Text -import qualified Database.Esqueleto as E hiding (random_) +import qualified Database.Esqueleto.Legacy as E hiding (random_) import qualified Database.Esqueleto.PostgreSQL as E import qualified Data.Conduit.Combinators as C diff --git a/src/Handler/Allocation/Accept.hs b/src/Handler/Allocation/Accept.hs index b148122ea..39d909ee6 100644 --- a/src/Handler/Allocation/Accept.hs +++ b/src/Handler/Allocation/Accept.hs @@ -13,7 +13,7 @@ import Data.Map ((!?)) import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Control.Monad.State.Class as State import Data.Sequence (Seq((:|>))) diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index 8084da1be..5170fcc7b 100644 --- a/src/Handler/Allocation/Application.hs +++ b/src/Handler/Allocation/Application.hs @@ -14,7 +14,7 @@ import Handler.Utils import qualified Data.Text as Text import qualified Data.Set as Set -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Conduit.List as C @@ -348,7 +348,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do , allowAction afAction , Just appId <- mAppId -> runDB $ do - deleteCascade appId + delete appId audit $ TransactionCourseApplicationDeleted cid uid appId addMessageI Success $ MsgCourseApplicationDeleted courseShorthand | otherwise diff --git a/src/Handler/Allocation/Compute.hs b/src/Handler/Allocation/Compute.hs index 3f92a055d..161289e2e 100644 --- a/src/Handler/Allocation/Compute.hs +++ b/src/Handler/Allocation/Compute.hs @@ -12,7 +12,7 @@ import Handler.Allocation.Accept (SessionDataAllocationResults(..)) import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Control.Monad.State.Class as State diff --git a/src/Handler/Allocation/EditUser.hs b/src/Handler/Allocation/EditUser.hs index a11230c14..c6086b0cb 100644 --- a/src/Handler/Allocation/EditUser.hs +++ b/src/Handler/Allocation/EditUser.hs @@ -16,7 +16,7 @@ import qualified Data.Conduit.Combinators as C import Handler.Utils.Delete -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Handler.Course.Register (deregisterParticipant) diff --git a/src/Handler/Allocation/Form.hs b/src/Handler/Allocation/Form.hs index afe192155..8b3ba800e 100644 --- a/src/Handler/Allocation/Form.hs +++ b/src/Handler/Allocation/Form.hs @@ -7,7 +7,7 @@ import Import import Handler.Utils -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Map.Strict as Map import qualified Data.Set as Set diff --git a/src/Handler/Allocation/List.hs b/src/Handler/Allocation/List.hs index a70a39d56..20b28e0fc 100644 --- a/src/Handler/Allocation/List.hs +++ b/src/Handler/Allocation/List.hs @@ -8,7 +8,7 @@ import Import import Utils.Course (mayViewCourse) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Handler.Utils.Table.Columns import Handler.Utils.Table.Pagination diff --git a/src/Handler/Allocation/Prios.hs b/src/Handler/Allocation/Prios.hs index 092aed617..6bc84ac33 100644 --- a/src/Handler/Allocation/Prios.hs +++ b/src/Handler/Allocation/Prios.hs @@ -8,7 +8,7 @@ import Handler.Utils import Handler.Utils.Csv import Handler.Utils.Allocation -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Conduit.List as C diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index 881bb2b4b..eb348e266 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -12,7 +12,7 @@ import Handler.Utils.Allocation (allocationNotifyNewCourses) import Handler.Allocation.Register import Handler.Allocation.Application -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E diff --git a/src/Handler/Allocation/UserForm.hs b/src/Handler/Allocation/UserForm.hs index 48ca7ca7d..931643a36 100644 --- a/src/Handler/Allocation/UserForm.hs +++ b/src/Handler/Allocation/UserForm.hs @@ -12,7 +12,7 @@ import Handler.Allocation.Application import Handler.Utils -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.PostgreSQL as E import qualified Data.Map.Strict as Map diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs index ca3026047..5fca740ec 100644 --- a/src/Handler/Allocation/Users.hs +++ b/src/Handler/Allocation/Users.hs @@ -12,7 +12,7 @@ import Handler.Utils import Handler.Utils.Allocation import Handler.Utils.StudyFeatures -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Csv as Csv diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 0247f13b8..aaff28b89 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -4,7 +4,7 @@ module Handler.Course import Import -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Persist as P import Handler.Course.Communication as Handler.Course diff --git a/src/Handler/Course/Application/Files.hs b/src/Handler/Course/Application/Files.hs index 9daf7e0df..323ef9d69 100644 --- a/src/Handler/Course/Application/Files.hs +++ b/src/Handler/Course/Application/Files.hs @@ -10,7 +10,7 @@ import Handler.Utils import qualified Data.Conduit.List as C -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.CaseInsensitive as CI diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 390c912f3..7b86b1a61 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -9,7 +9,7 @@ import Import import Handler.Utils -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH diff --git a/src/Handler/Course/Communication.hs b/src/Handler/Course/Communication.hs index 005aca3ae..eac35ee83 100644 --- a/src/Handler/Course/Communication.hs +++ b/src/Handler/Course/Communication.hs @@ -9,7 +9,7 @@ import Handler.Utils.Communication import qualified Data.Map as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 3ebbd2c73..5973c7043 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -18,7 +18,7 @@ import qualified Data.Map as Map import qualified Control.Monad.State.Class as State -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Jobs.Queue diff --git a/src/Handler/Course/Events/Form.hs b/src/Handler/Course/Events/Form.hs index 1f3eb88bc..d9ef4ffeb 100644 --- a/src/Handler/Course/Events/Form.hs +++ b/src/Handler/Course/Events/Form.hs @@ -8,7 +8,7 @@ import Import import Handler.Utils import Handler.Utils.Form.Occurrences -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E data CourseEventForm = CourseEventForm diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index edc5f6ad7..02c5f7b43 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -17,7 +17,7 @@ import Utils.Form -- import Utils.DB import Handler.Utils hiding (colSchoolShort) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.CaseInsensitive as CI diff --git a/src/Handler/Course/News/Download.hs b/src/Handler/Course/News/Download.hs index 3d1ea1b0f..9032acd97 100644 --- a/src/Handler/Course/News/Download.hs +++ b/src/Handler/Course/News/Download.hs @@ -6,7 +6,7 @@ module Handler.Course.News.Download import Import import Handler.Utils -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Conduit.List as C diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index cc210739f..aaba24cf7 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -18,7 +18,7 @@ import qualified Data.Text as Text import qualified Data.Conduit.List as C import Database.Persist.Sql (transactionUndo) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 647be20d3..fab484c0b 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -15,7 +15,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Map as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 0d63369f3..30ef678c2 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -9,7 +9,7 @@ import Handler.Utils import Handler.Utils.SheetType import Database.Esqueleto.Utils.TH -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Persist.Sql (deleteWhereCount) diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index e6a771428..e9d2eb811 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -23,7 +23,7 @@ import qualified Data.Map as Map import qualified Data.Text as Text import qualified Data.Vector as Vector -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Csv as Csv diff --git a/src/Handler/Exam/AutoOccurrence.hs b/src/Handler/Exam/AutoOccurrence.hs index df036163b..e4422ba6e 100644 --- a/src/Handler/Exam/AutoOccurrence.hs +++ b/src/Handler/Exam/AutoOccurrence.hs @@ -12,7 +12,7 @@ import Handler.Utils.Exam import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import Database.Persist.Sql (updateWhereCount) newtype ExamAutoOccurrenceCalculateForm = ExamAutoOccurrenceCalculateForm diff --git a/src/Handler/Exam/Correct.hs b/src/Handler/Exam/Correct.hs index cc373b0bd..f22e9d3c6 100644 --- a/src/Handler/Exam/Correct.hs +++ b/src/Handler/Exam/Correct.hs @@ -7,7 +7,7 @@ import Import import qualified Data.Set as Set import qualified Data.CaseInsensitive as CI -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Persist.Sql (transactionUndo) diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index 909e571f7..5ecffe1f0 100644 --- a/src/Handler/Exam/Edit.hs +++ b/src/Handler/Exam/Edit.hs @@ -14,7 +14,7 @@ import Handler.Utils.Invitations import Jobs.Queue -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 98bc2be9a..9801ab658 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -18,7 +18,7 @@ import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Control.Monad.State.Class as State diff --git a/src/Handler/Exam/List.hs b/src/Handler/Exam/List.hs index d9d37fdc7..20535552f 100644 --- a/src/Handler/Exam/List.hs +++ b/src/Handler/Exam/List.hs @@ -9,7 +9,7 @@ import Handler.Utils import qualified Data.Map as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index 63d235e81..392c56337 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -12,7 +12,7 @@ import Handler.ExamOffice.Exam (examCloseWidget, examFinishWidget) import Data.Map ((!?)) import qualified Data.Map as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.CaseInsensitive as CI diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 8a13664c6..5d20a3587 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -16,7 +16,7 @@ import Handler.Exam.AutoOccurrence (examAutoOccurrenceCalculateWidget) import Handler.ExamOffice.Exam (examCloseWidget, examFinishWidget) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH diff --git a/src/Handler/ExamOffice/Course.hs b/src/Handler/ExamOffice/Course.hs index 651ede248..9ad0cf949 100644 --- a/src/Handler/ExamOffice/Course.hs +++ b/src/Handler/ExamOffice/Course.hs @@ -6,7 +6,7 @@ import Import import qualified Data.Set as Set -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Handler.Utils.ExamOffice.Course diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index 264fbd5bc..cc631665f 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -11,7 +11,7 @@ import Handler.Utils.Exam import Handler.Utils.Csv import qualified Handler.Utils.ExamOffice.Exam as Exam -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Csv as Csv diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index 1e3bafe42..f98eac37f 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -10,7 +10,7 @@ import Handler.Utils import qualified Handler.Utils.ExamOffice.Exam as Exam import qualified Handler.Utils.ExamOffice.ExternalExam as ExternalExam -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Colonnade diff --git a/src/Handler/ExamOffice/Fields.hs b/src/Handler/ExamOffice/Fields.hs index bd69d7b5d..48f2c02fd 100644 --- a/src/Handler/ExamOffice/Fields.hs +++ b/src/Handler/ExamOffice/Fields.hs @@ -6,7 +6,7 @@ module Handler.ExamOffice.Fields import Import import Utils.Form -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Set as Set import qualified Data.Map as Map diff --git a/src/Handler/ExamOffice/Users.hs b/src/Handler/ExamOffice/Users.hs index c12090101..79e6da3a4 100644 --- a/src/Handler/ExamOffice/Users.hs +++ b/src/Handler/ExamOffice/Users.hs @@ -13,7 +13,7 @@ import Handler.Utils.Invitations import Data.Aeson hiding (Result(..)) import Jobs.Queue -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Set as Set import qualified Data.Map as Map diff --git a/src/Handler/ExternalExam/Correct.hs b/src/Handler/ExternalExam/Correct.hs index c4d359ec6..cb13183b4 100644 --- a/src/Handler/ExternalExam/Correct.hs +++ b/src/Handler/ExternalExam/Correct.hs @@ -7,7 +7,7 @@ import Import import qualified Data.Set as Set import qualified Data.List.NonEmpty as NonEmpty (toList) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E --import qualified Database.Esqueleto.Utils as E import Database.Persist.Sql (transactionUndo) diff --git a/src/Handler/ExternalExam/Form.hs b/src/Handler/ExternalExam/Form.hs index e62ac2f68..5c278e3ad 100644 --- a/src/Handler/ExternalExam/Form.hs +++ b/src/Handler/ExternalExam/Form.hs @@ -13,7 +13,7 @@ import Data.Map ((!)) import qualified Control.Monad.State.Class as State -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E data ExternalExamForm = ExternalExamForm diff --git a/src/Handler/ExternalExam/List.hs b/src/Handler/ExternalExam/List.hs index 0dafaafc4..2a65080ec 100644 --- a/src/Handler/ExternalExam/List.hs +++ b/src/Handler/ExternalExam/List.hs @@ -6,7 +6,7 @@ import Import import Handler.Utils -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Map as Map diff --git a/src/Handler/ExternalExam/Show.hs b/src/Handler/ExternalExam/Show.hs index 5f9d3fdb4..49f3a85ac 100644 --- a/src/Handler/ExternalExam/Show.hs +++ b/src/Handler/ExternalExam/Show.hs @@ -11,7 +11,7 @@ import Handler.ExternalExam.StaffInvite () import qualified Data.CaseInsensitive as CI import qualified Data.Map as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E getEEShowR :: TermId -> SchoolId -> CourseName -> ExamName -> Handler Html diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs index 095eadb52..eac3e22dc 100644 --- a/src/Handler/Info.hs +++ b/src/Handler/Info.hs @@ -9,7 +9,7 @@ import Data.Map ((!)) import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Development.GitRev diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 6b4781c3e..2e0e961b5 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -17,7 +17,7 @@ import qualified Data.Conduit.List as C import qualified Data.CaseInsensitive as CI -- import qualified Data.Text.Encoding as Text -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import Utils.Form import Handler.Utils diff --git a/src/Handler/News.hs b/src/Handler/News.hs index 7ec2aeb1a..c696006f9 100644 --- a/src/Handler/News.hs +++ b/src/Handler/News.hs @@ -11,7 +11,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Database.Esqueleto.Utils.TH -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Conduit.List as C (consume, mapMaybeM) diff --git a/src/Handler/Participants.hs b/src/Handler/Participants.hs index cbeb69ab2..0d1b9eb1b 100644 --- a/src/Handler/Participants.hs +++ b/src/Handler/Participants.hs @@ -8,7 +8,7 @@ module Handler.Participants import Import import Handler.Utils -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Map as Map diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index d057e02fb..9b7dc1ee0 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -18,7 +18,7 @@ import Handler.Utils.Profile import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Set as Set -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E -- import Database.Esqueleto ((^.)) import qualified Data.Text as Text diff --git a/src/Handler/School.hs b/src/Handler/School.hs index 14e028d10..c6373ae23 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -3,7 +3,7 @@ module Handler.School where import Import import Handler.Utils -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Set as Set import qualified Data.CaseInsensitive as CI diff --git a/src/Handler/Sheet/Delete.hs b/src/Handler/Sheet/Delete.hs index 1658e6c81..5a4ede7cb 100644 --- a/src/Handler/Sheet/Delete.hs +++ b/src/Handler/Sheet/Delete.hs @@ -7,7 +7,7 @@ import Import import Handler.Utils.Delete import Handler.Utils.Sheet -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Set as Set diff --git a/src/Handler/Sheet/Download.hs b/src/Handler/Sheet/Download.hs index 75a0cbf44..3c2ff51ad 100644 --- a/src/Handler/Sheet/Download.hs +++ b/src/Handler/Sheet/Download.hs @@ -9,7 +9,7 @@ import Handler.Utils import qualified Data.Conduit.Combinators as C -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs index 353b3d11a..4cd5ba324 100644 --- a/src/Handler/Sheet/Form.hs +++ b/src/Handler/Sheet/Form.hs @@ -9,7 +9,7 @@ import Import import Handler.Utils import Handler.Utils.Invitations -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Set as Set import qualified Data.Map as Map diff --git a/src/Handler/Sheet/List.hs b/src/Handler/Sheet/List.hs index 4593fb9f0..de27c8d3b 100644 --- a/src/Handler/Sheet/List.hs +++ b/src/Handler/Sheet/List.hs @@ -8,7 +8,7 @@ import Utils.Sheet import Handler.Utils import Handler.Utils.SheetType -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Map as Map diff --git a/src/Handler/Sheet/New.hs b/src/Handler/Sheet/New.hs index 922659140..8d8bd1c2b 100644 --- a/src/Handler/Sheet/New.hs +++ b/src/Handler/Sheet/New.hs @@ -6,7 +6,7 @@ import Import import Handler.Utils -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Map as Map diff --git a/src/Handler/Sheet/PersonalisedFiles.hs b/src/Handler/Sheet/PersonalisedFiles.hs index 5d19b0e51..f1276f124 100644 --- a/src/Handler/Sheet/PersonalisedFiles.hs +++ b/src/Handler/Sheet/PersonalisedFiles.hs @@ -32,7 +32,7 @@ import Language.Haskell.TH (nameBase) import qualified Data.CryptoID.ByteString as CryptoID import qualified Data.CryptoID.Class.ImplicitNamespace as I -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Map as Map import qualified Data.Set as Set diff --git a/src/Handler/Sheet/PersonalisedFiles/Meta.hs b/src/Handler/Sheet/PersonalisedFiles/Meta.hs index dbbf5f7b2..e95993ae8 100644 --- a/src/Handler/Sheet/PersonalisedFiles/Meta.hs +++ b/src/Handler/Sheet/PersonalisedFiles/Meta.hs @@ -18,7 +18,7 @@ import qualified Data.YAML.Token as YAML (Encoding(..)) import Control.Monad.Trans.State.Lazy (evalState) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.CaseInsensitive as CI diff --git a/src/Handler/Sheet/Show.hs b/src/Handler/Sheet/Show.hs index 05c1b78cb..045d8d631 100644 --- a/src/Handler/Sheet/Show.hs +++ b/src/Handler/Sheet/Show.hs @@ -6,7 +6,7 @@ import Import hiding (link) import Handler.Utils -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Map as Map diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 0c409bdc1..db3beb8a6 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -30,7 +30,7 @@ import Handler.Utils import Import -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html diff --git a/src/Handler/Submission/Assign.hs b/src/Handler/Submission/Assign.hs index e39c3445f..30470c0ed 100644 --- a/src/Handler/Submission/Assign.hs +++ b/src/Handler/Submission/Assign.hs @@ -18,7 +18,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import Data.List.NonEmpty (unzip) diff --git a/src/Handler/Submission/Correction.hs b/src/Handler/Submission/Correction.hs index fa69877d1..5cc2154cd 100644 --- a/src/Handler/Submission/Correction.hs +++ b/src/Handler/Submission/Correction.hs @@ -14,7 +14,7 @@ import qualified Data.Text as Text import qualified Control.Monad.State.Class as State -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E diff --git a/src/Handler/Submission/Create.hs b/src/Handler/Submission/Create.hs index 0aefb0f03..9eb2bdfd1 100644 --- a/src/Handler/Submission/Create.hs +++ b/src/Handler/Submission/Create.hs @@ -16,7 +16,7 @@ import qualified Data.Text as Text import qualified Control.Monad.State.Class as State -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import Data.List (genericLength) diff --git a/src/Handler/Submission/Download.hs b/src/Handler/Submission/Download.hs index 897fcf7d1..454e361dc 100644 --- a/src/Handler/Submission/Download.hs +++ b/src/Handler/Submission/Download.hs @@ -11,7 +11,7 @@ import Handler.Utils.Submission import qualified Data.Set as Set -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Conduit.Combinators as Conduit diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index 048e1713f..c0c003dc3 100644 --- a/src/Handler/Submission/Helper.hs +++ b/src/Handler/Submission/Helper.hs @@ -14,7 +14,7 @@ import Handler.Utils.Invitations import Data.Maybe (fromJust) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Internal as E (unsafeSqlFunction) diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index c5296a64a..72ef9192a 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -26,7 +26,7 @@ import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI import Database.Esqueleto.Utils.TH -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Internal as IE (From) diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 87c19fd96..f472d932c 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -17,7 +17,7 @@ import qualified Data.List.NonEmpty as NonEmpty import Handler.Utils import Handler.Utils.News -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E -- htmlField' moved to Handler.Utils.Form/Fields @@ -257,7 +257,7 @@ postMessageListR = do FormSuccess (SMDDelete, selection) | not $ null selection -> do selection' <- traverse decrypt $ Set.toList selection - runDB $ deleteCascadeWhere [ SystemMessageId <-. selection' ] + runDB $ deleteWhere [ SystemMessageId <-. selection' ] $(addMessageFile Success "templates/messages/systemMessagesDeleted.hamlet") redirect MessageListR FormSuccess (SMDActivate ts, selection) diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 322992b61..015f14bdc 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -13,7 +13,7 @@ import Handler.Utils import qualified Data.Map.Strict as Map import Data.Map.Strict ((!)) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Set as Set diff --git a/src/Handler/Tutorial/Communication.hs b/src/Handler/Tutorial/Communication.hs index 70ca14d52..c01464eec 100644 --- a/src/Handler/Tutorial/Communication.hs +++ b/src/Handler/Tutorial/Communication.hs @@ -7,7 +7,7 @@ import Handler.Utils import Handler.Utils.Tutorial import Handler.Utils.Communication -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Map as Map diff --git a/src/Handler/Tutorial/Delete.hs b/src/Handler/Tutorial/Delete.hs index 524daebe1..ed82c7fc5 100644 --- a/src/Handler/Tutorial/Delete.hs +++ b/src/Handler/Tutorial/Delete.hs @@ -7,7 +7,7 @@ import Handler.Utils import Handler.Utils.Tutorial import Handler.Utils.Delete -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Set as Set diff --git a/src/Handler/Tutorial/Edit.hs b/src/Handler/Tutorial/Edit.hs index c8a9ce789..fd783a5a9 100644 --- a/src/Handler/Tutorial/Edit.hs +++ b/src/Handler/Tutorial/Edit.hs @@ -8,7 +8,7 @@ import Handler.Utils.Tutorial import Handler.Utils.Invitations import Jobs.Queue -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.Map as Map import qualified Data.Set as Set diff --git a/src/Handler/Tutorial/Form.hs b/src/Handler/Tutorial/Form.hs index 04a0d1a69..178b43cba 100644 --- a/src/Handler/Tutorial/Form.hs +++ b/src/Handler/Tutorial/Form.hs @@ -7,7 +7,7 @@ import Import import Handler.Utils import Handler.Utils.Form.Occurrences -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import Data.Map ((!)) import qualified Data.Set as Set diff --git a/src/Handler/Tutorial/List.hs b/src/Handler/Tutorial/List.hs index e4f929d76..39f67c0e8 100644 --- a/src/Handler/Tutorial/List.hs +++ b/src/Handler/Tutorial/List.hs @@ -6,7 +6,7 @@ import Import import Handler.Utils import Handler.Utils.Tutorial -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 5e91ce386..f8215a0d9 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -15,7 +15,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import Handler.Course.Users diff --git a/src/Handler/Upload.hs b/src/Handler/Upload.hs new file mode 100644 index 000000000..7ca52b802 --- /dev/null +++ b/src/Handler/Upload.hs @@ -0,0 +1,29 @@ +module Handler.Upload + ( putUploadR + ) where + +import Import + + +data UploadResponse + = UploadResponseNoToken + deriving (Eq, Ord, Show, Generic, Typeable) + +deriveJSON defaultOptions + { tagSingleConstructors = True + , allNullaryToStringTag = False + , constructorTagModifier = camelToPathPiece' 2 + } ''UploadResponse + + +putUploadR :: Handler TypedContent +putUploadR = do + resp <- exceptT return return $ do + _uploadToken <- decodeUploadToken <=< maybeExceptT UploadResponseNoToken $ lookupCustomHeader HeaderUploadToken + + error "not implemented" + + selectRep $ do + provideRep . return $ toPrettyJSON resp + provideRep . return $ toJSON resp + provideRep . return $ toYAML resp diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 7d9e97e19..29963c64e 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -19,7 +19,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Handler.Profile (makeProfileData) @@ -503,9 +503,9 @@ deleteUser duid = do groupSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.>. E.val (0::Int64)) singleSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.==. E.val (0::Int64)) - deleteCascade duid + delete duid -- cascade is now defined in models files; therefor does not cascade at all currently (2021-06-27); not even SubmissionUser... forM_ singleSubmissions $ \(E.Value submissionId) -> do - deleteCascade submissionId + delete submissionId -- ditto deletedSubmissionGroups <- deleteSingleSubmissionGroups return ((length singleSubmissions, length groupSubmissions),deletedSubmissionGroups) diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs index 6902abdfb..785d69392 100644 --- a/src/Handler/Utils/Allocation.hs +++ b/src/Handler/Utils/Allocation.hs @@ -13,7 +13,7 @@ import Import import qualified Data.Map.Strict as Map -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Control.Monad.Trans.State (execStateT) diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 27a8e31a0..1377ab621 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -13,7 +13,7 @@ import Handler.Utils import Jobs.Queue -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Data.CaseInsensitive as CI import Data.Map ((!), (!?)) import qualified Data.Map as Map diff --git a/src/Handler/Utils/Course.hs b/src/Handler/Utils/Course.hs index 34b671b7d..0951152bd 100644 --- a/src/Handler/Utils/Course.hs +++ b/src/Handler/Utils/Course.hs @@ -4,7 +4,7 @@ import Import import Handler.Utils.Delete import Handler.Utils.Memcached -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Data.Set as Set diff --git a/src/Handler/Utils/Database.hs b/src/Handler/Utils/Database.hs index bd6e81250..c869b4bbb 100644 --- a/src/Handler/Utils/Database.hs +++ b/src/Handler/Utils/Database.hs @@ -11,7 +11,7 @@ import Data.Map as Map -- import Data.CaseInsensitive (CI) -- import qualified Data.CaseInsensitive as CI -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E makeSchoolDictionaryDB :: DB (Map.Map SchoolId SchoolName) makeSchoolDictionaryDB = makeSchoolDictionary <$> selectList [] [Asc SchoolShorthand] diff --git a/src/Handler/Utils/Delete.hs b/src/Handler/Utils/Delete.hs index 658007730..6df29c670 100644 --- a/src/Handler/Utils/Delete.hs +++ b/src/Handler/Utils/Delete.hs @@ -25,7 +25,7 @@ import qualified Data.CaseInsensitive as CI import Data.Char (isAlphaNum) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect) import Jobs.Queue @@ -76,7 +76,7 @@ confirmForm' drRecords confirmString mmsg = identifyForm FIDDelete . addDeleteTa over _2 (mappend $ fvInput fvTargets) <$> form csrf -postDeleteR :: ( DeleteCascade record SqlBackend ) +postDeleteR :: (PersistEntity record, PersistEntityBackend record ~ SqlBackend) => (Set (Key record) -> DeleteRoute record) -- ^ Construct `DeleteRoute` based on incoming record keys -> Handler () -- | Perform deletion @@ -85,10 +85,12 @@ postDeleteR mkRoute = do traverse_ deleteR' drResult -getDeleteR :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler a +getDeleteR :: (PersistEntity record, PersistEntityBackend record ~ SqlBackend) + => DeleteRoute record -> Handler a getDeleteR = deleteR' -deleteR' :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler a +deleteR' :: (PersistEntity record, PersistEntityBackend record ~ SqlBackend) + => DeleteRoute record -> Handler a deleteR' DeleteRoute{..} = do (targets, confirmString, message) <- runDB $ do infos <- E.select . E.from $ \t -> do @@ -106,7 +108,7 @@ deleteR' DeleteRoute{..} = do formResult confirmRes $ \case True -> do runDBJobs $ do - forM_ drRecords $ \k -> drDelete k $ deleteCascade k + forM_ drRecords $ \k -> drDelete k $ delete k addMessageI Success drSuccessMessage redirect drSuccess False -> @@ -124,7 +126,8 @@ deleteR' DeleteRoute{..} = do -deleteR :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler Html +deleteR :: (PersistEntity record, PersistEntityBackend record ~ SqlBackend) + => DeleteRoute record -> Handler Html deleteR dr = do postDeleteR $ \drRecords -> dr {drRecords} getDeleteR dr diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 4416b7fa6..2453e7dd6 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -21,7 +21,7 @@ module Handler.Utils.Exam import Import import Database.Persist.Sql (SqlBackendCanRead) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Internal as E import Database.Esqueleto.Utils.TH @@ -851,10 +851,11 @@ examRequiredEquipmentPresetWidget preset = $(i18nWidgetFile "exam-mode/requiredE evalExamModeDNF :: ExamModeDNF -> ExamMode -> Bool evalExamModeDNF (ExamModeDNF PredDNF{..}) ExamMode{..} = dnfTerms - & map (Set.toList . toNullable) . Set.toList + & Set.toList & map ( maybe True (ofoldr1 (&&)) . fromNullable . map (\pl -> bool id not (is _PLNegated pl) . evalPred $ plVar pl) + . Set.toList . toNullable ) & maybe False (ofoldr1 (||)) . fromNullable where diff --git a/src/Handler/Utils/ExamOffice/Course.hs b/src/Handler/Utils/ExamOffice/Course.hs index bd3a3a5c2..ca7482a34 100644 --- a/src/Handler/Utils/ExamOffice/Course.hs +++ b/src/Handler/Utils/ExamOffice/Course.hs @@ -4,7 +4,7 @@ module Handler.Utils.ExamOffice.Course import Import.NoFoundation -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E diff --git a/src/Handler/Utils/ExamOffice/Exam.hs b/src/Handler/Utils/ExamOffice/Exam.hs index be3ab8fda..424c8b948 100644 --- a/src/Handler/Utils/ExamOffice/Exam.hs +++ b/src/Handler/Utils/ExamOffice/Exam.hs @@ -7,7 +7,7 @@ import Import.NoFoundation import Handler.Utils.StudyFeatures -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E resultIsSynced :: E.SqlExpr (E.Value UserId) -- ^ office diff --git a/src/Handler/Utils/ExamOffice/ExternalExam.hs b/src/Handler/Utils/ExamOffice/ExternalExam.hs index 1c9d74310..b557e6cf6 100644 --- a/src/Handler/Utils/ExamOffice/ExternalExam.hs +++ b/src/Handler/Utils/ExamOffice/ExternalExam.hs @@ -6,7 +6,7 @@ module Handler.Utils.ExamOffice.ExternalExam import Import.NoFoundation import Handler.Utils.StudyFeatures -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs index c5712cb96..70a20fec6 100644 --- a/src/Handler/Utils/ExternalExam/Users.hs +++ b/src/Handler/Utils/ExternalExam/Users.hs @@ -14,7 +14,7 @@ import qualified Data.List.NonEmpty as NonEmpty (head) import qualified Colonnade -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Data.Csv ((.:)) diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs index d37e3bac0..83b5f7552 100644 --- a/src/Handler/Utils/Files.hs +++ b/src/Handler/Utils/Files.hs @@ -2,7 +2,7 @@ module Handler.Utils.Files ( sourceFile, sourceFile' , sourceFiles, sourceFiles' , SourceFilesException(..), _SourceFilesMismatchedHashes, _SourceFilesContentUnavailable - , sourceFileDB, sourceFileDBChunks, sourceFileMinio + , sourceFileDB, sourceFileChunks, sourceFileMinio , acceptFile , respondFileConditional ) where @@ -19,7 +19,7 @@ import qualified Data.Conduit.List as C (unfoldM) import Handler.Utils.Minio import qualified Network.Minio as Minio -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import System.FilePath (normalise, makeValid) @@ -42,12 +42,18 @@ fileChunkARC :: ( MonadHandler m ) => Maybe Int -> (FileContentChunkReference, (Int, Int)) - -> m (Maybe ByteString) + -> m (Maybe (ByteString, Maybe FileChunkStorage)) -> m (Maybe ByteString) fileChunkARC altSize k@(ref, (s, l)) getChunkDB' = do prewarm <- getsYesod appFileSourcePrewarm let getChunkDB = case prewarm of - Nothing -> getChunkDB' + Nothing -> do + chunk' <- getChunkDB' + for chunk' $ \(chunk, mStorage) -> chunk <$ do + $logDebugS "fileChunkARC" "No prewarm" + for_ mStorage $ \storage -> + let w = length chunk + in liftIO $ observeSourcedChunk storage w Just lh -> do chunkRes <- lookupLRUHandle lh k case chunkRes of @@ -56,10 +62,11 @@ fileChunkARC altSize k@(ref, (s, l)) getChunkDB' = do liftIO $ observeSourcedChunk StoragePrewarm w Nothing -> do chunk' <- getChunkDB' - for chunk' $ \chunk -> chunk <$ do - let w = length chunk + for chunk' $ \(chunk, mStorage) -> chunk <$ do $logDebugS "fileChunkARC" "Prewarm miss" - liftIO $ observeSourcedChunk StorageDB w + for_ mStorage $ \storage -> + let w = length chunk + in liftIO $ observeSourcedChunk storage w arc <- getsYesod appFileSourceARC case arc of @@ -85,50 +92,54 @@ fileChunkARC altSize k@(ref, (s, l)) getChunkDB' = do sourceFileDB :: forall m. - (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) + (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m) => FileContentReference -> ConduitT () ByteString (SqlPersistT m) () sourceFileDB fileReference = chunkHashes - .| awaitForever (sourceFileDBChunks (const id) . unFileContentChunkKey . E.unValue) + .| awaitForever (sourceFileChunks (const $ over (mapped . mapped . _2) Just) . E.unValue) .| C.map (view _1) where - chunkHashes :: ConduitT () (E.Value FileContentChunkId) (SqlPersistT m) () + chunkHashes :: ConduitT () (E.Value FileContentChunkReference) (SqlPersistT m) () chunkHashes = E.selectSource . E.from $ \fileContentEntry -> do E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileReference E.orderBy [ E.asc $ fileContentEntry E.^. FileContentEntryIx ] return $ fileContentEntry E.^. FileContentEntryChunkHash -sourceFileDBChunks :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend) - => ((Int, Int) -> ReaderT SqlReadBackend m (Maybe ByteString) -> ReaderT SqlReadBackend m (Maybe ByteString)) -> FileContentChunkReference -> ConduitT i (ByteString, (Int, Int)) (ReaderT backend m) () -sourceFileDBChunks cont chunkHash = transPipe (withReaderT $ projectBackend @SqlReadBackend) $ do +sourceFileChunks :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, MonadUnliftIO m) + => ((Int, Int) -> ReaderT SqlReadBackend m (Maybe (ByteString, FileChunkStorage)) -> ReaderT SqlReadBackend m (Maybe (ByteString, Maybe FileChunkStorage))) -> FileContentChunkReference -> ConduitT i (ByteString, (Int, Int)) (ReaderT backend m) () +sourceFileChunks cont chunkHash = transPipe (withReaderT $ projectBackend @SqlReadBackend) $ do dbChunksize <- getsYesod $ view _appFileUploadDBChunksize - -- mRunner <- getMinioRunner - let retrieveChunk = \case + let dbRetrieveChunk = \case Nothing -> return Nothing Just start -> do - let getChunkDB = cont (start, dbChunksize) . fmap (fmap E.unValue) . E.selectMaybe . E.from $ \fileContentChunk -> do - E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash - return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val dbChunksize) + let getChunkDB = cont (start, dbChunksize) . runMaybeT $ + let getChunkDB' = MaybeT . fmap (fmap $ (, StorageDB) . E.unValue) . E.selectMaybe . E.from $ \fileContentChunk -> do + E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash + return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val dbChunksize) + getChunkMinio = fmap (, StorageMinio) . catchIfMaybeT (is _SourceFilesContentUnavailable) . runConduit $ sourceMinio (Left chunkHash) (Just $ ByteRangeFromTo (fromIntegral $ pred start) (fromIntegral . pred $ pred start + dbChunksize)) .| C.fold + in getChunkDB' <|> getChunkMinio chunk <- fileChunkARC Nothing (chunkHash, (start, dbChunksize)) getChunkDB case chunk of + Just c | olength c <= 0 -> return Nothing Just c -> do return . Just . ((c, (start, dbChunksize)), ) $ if | olength c >= dbChunksize -> Just $ start + dbChunksize | otherwise -> Nothing - -- Nothing | Just MinioRunner{..} <- mRunner -> do Nothing -> throwM SourceFilesContentUnavailable - C.unfoldM retrieveChunk $ Just (1 :: Int) + C.unfoldM dbRetrieveChunk $ Just (1 :: Int) -sourceFileMinio :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m) - => FileContentReference -> ConduitT () ByteString m () -sourceFileMinio fileReference = do +sourceMinio :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m) + => Either FileContentChunkReference FileContentReference + -> Maybe ByteRange + -> ConduitT i ByteString m () +sourceMinio fileReference mRange = do chunkVar <- newEmptyTMVarIO minioAsync <- lift . allocateLinkedAsync $ maybeT (throwM SourceFilesContentUnavailable) $ do - let uploadName = minioFileReference # fileReference + let uploadName = either (review minioFileChunkReference) (review minioFileReference) fileReference uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket hoistMaybe <=< runAppMinio . runMaybeT $ do - objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket uploadName Minio.defaultGetObjectOptions + objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket uploadName Minio.defaultGetObjectOptions{ Minio.gooRange = mRange } lift . runConduit $ Minio.gorObjectStream objRes .| C.mapM_ (atomically . putTMVar chunkVar) let go = do mChunk <- atomically $ Right <$> takeTMVar chunkVar @@ -142,6 +153,9 @@ sourceFileMinio fileReference = do Left (Left exc) -> throwM exc in go +sourceFileMinio :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m) + => FileContentReference -> ConduitT () ByteString m () +sourceFileMinio fileContent = sourceMinio (Right fileContent) Nothing sourceFiles :: (Monad m, YesodPersistBackend UniWorX ~ SqlBackend) => ConduitT FileReference DBFile m () sourceFiles = C.map sourceFile @@ -178,10 +192,10 @@ respondFileConditional representationLastModified cType FileReference{..} = do -> return . respondSourceConditional @ByteRangesSpecifier condInfo cType . Left $ (return () :: ConduitT () ByteString _ ()) | Just fileContent <- fileReferenceContent -> do dbManifest <- fmap fromNullable . E.select . E.from $ \(fileContentEntry `E.LeftOuterJoin` fileContentChunk) -> do - E.on $ E.just (fileContentEntry E.^. FileContentEntryChunkHash) E.==. fileContentChunk E.?. FileContentChunkId + E.on $ E.just (fileContentEntry E.^. FileContentEntryChunkHash) E.==. fileContentChunk E.?. FileContentChunkHash E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileContent E.orderBy [E.asc $ fileContentEntry E.^. FileContentEntryIx ] - return ( fileContentChunk E.?. FileContentChunkHash + return ( fileContentEntry E.^. FileContentEntryChunkHash , E.maybe E.nothing (E.just . E.length_) $ fileContentChunk E.?. FileContentChunkContent ) case dbManifest of @@ -192,79 +206,57 @@ respondFileConditional representationLastModified cType FileReference{..} = do catchIfMaybeT minioIsDoesNotExist $ Minio.statObject uploadBucket uploadName Minio.defaultGetObjectOptions let iLength = fromIntegral $ Minio.oiSize statRes respondSourceConditional condInfo cType . Right $ \byteRange -> - let byteRange' = case byteRange of - ByteRangeSpecification f Nothing -> ByteRangeFrom (fromIntegral $ min (pred iLength) f) - ByteRangeSpecification f (Just t) -> ByteRangeFromTo (fromIntegral $ min iLength f) (fromIntegral $ min (pred iLength) t) - ByteRangeSuffixSpecification s -> ByteRangeSuffix (fromIntegral $ min iLength s) - respRange = case byteRange of - ByteRangeSpecification f Nothing -> ByteRangeResponseSpecification (min (pred iLength) f) (pred iLength) - ByteRangeSpecification f (Just t) -> ByteRangeResponseSpecification (min (pred iLength) f) (min (pred iLength) t) - ByteRangeSuffixSpecification s -> ByteRangeResponseSpecification (iLength - min (pred iLength) s) (pred iLength) - in ( do - chunkVar <- newEmptyTMVarIO - minioAsync <- lift . allocateLinkedAsync $ - maybeT (throwM SourceFilesContentUnavailable) . (hoistMaybe <=< runAppMinio) . runMaybeT $ do - objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket uploadName Minio.defaultGetObjectOptions{ Minio.gooRange = Just byteRange' } - lift . runConduit $ Minio.gorObjectStream objRes .| C.mapM_ (atomically . putTMVar chunkVar) - let go = do - mChunk <- atomically $ Right <$> takeTMVar chunkVar - <|> Left <$> waitCatchSTM minioAsync - case mChunk of - Right chunk -> do - observeSourcedChunk StorageMinio $ olength chunk - yield chunk - go - Left (Right ()) -> return () - Left (Left exc) -> throwM exc - in go + let (byteRange', respRange) = byteRangeSpecificationToMinio iLength byteRange + in ( sourceMinio (Right fileContent) $ Just byteRange' , ByteContentRangeSpecification (Just respRange) (Just iLength) ) - Just (toNullable -> dbManifest') - | Just dbManifest'' <- forM dbManifest' $ \(E.Value chunkHash, E.Value chunkLength) -> (,) <$> chunkHash <*> chunkLength - -> do - let iLength = sumOf (folded . _2) dbManifest'' - respondSourceDBConditional condInfo cType . Right $ \byteRange -> - let (byteFrom, byteTo) = case byteRange of - ByteRangeSpecification f Nothing -> (min (pred iLength) f, pred iLength) - ByteRangeSpecification f (Just t) -> (min (pred iLength) f, min (pred iLength) t) - ByteRangeSuffixSpecification s -> (iLength - min (pred iLength) s, pred iLength) - relevantChunks = view _2 $ foldl' go (0, []) dbManifest'' - where go :: (Word64, [(FileContentChunkReference, Word64, Word64)]) - -> (FileContentChunkReference, Word64) - -> (Word64, [(FileContentChunkReference, Word64, Word64)]) - go (lengthBefore, acc) (cChunk, cLength) - = ( lengthBefore + cLength - , if - | byteFrom < lengthBefore + cLength, byteTo >= lengthBefore - -> let cChunk' = ( cChunk - , bool 0 (byteFrom - lengthBefore) $ byteFrom >= lengthBefore - , bool cLength (cLength - pred (lengthBefore + cLength - byteTo)) $ byteTo < lengthBefore + cLength - ) - in acc ++ pure cChunk' - | otherwise - -> acc - ) - in ( do - dbChunksize <- getsYesod $ views _appFileUploadDBChunksize fromIntegral - forM_ relevantChunks $ \(chunkHash, offset, cLength) - -> let retrieveChunk = \case - Just (start, cLength') | cLength' > 0 -> do - let getChunkDB = fmap (fmap E.unValue) . E.selectMaybe . E.from $ \fileContentChunk -> do - E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash - return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val $ min cLength' dbChunksize) - chunk <- fileChunkARC (Just $ fromIntegral dbChunksize) (chunkHash, (fromIntegral start, fromIntegral $ min cLength' dbChunksize)) getChunkDB - case chunk of - Nothing -> throwM SourceFilesContentUnavailable - Just c -> do - return . Just . (c, ) $ if - | fromIntegral (olength c) >= min cLength' dbChunksize - -> Just (start + dbChunksize, cLength' - fromIntegral (olength c)) - | otherwise - -> Nothing - _other -> return Nothing - in C.unfoldM retrieveChunk . Just $ (succ offset, cLength) - , ByteContentRangeSpecification (Just $ ByteRangeResponseSpecification byteFrom byteTo) (Just iLength) - ) + Just (toNullable -> dbManifest') -> do + dbManifest'' <- forM dbManifest' $ \(E.Value chunkHash, E.Value mChunkLength) -> case mChunkLength of + Just chunkLength -> return (chunkHash, chunkLength) + Nothing -> throwM SourceFilesContentUnavailable + let iLength = sumOf (folded . _2) dbManifest'' + respondSourceDBConditional condInfo cType . Right $ \byteRange -> + let (byteFrom, byteTo) = case byteRange of + ByteRangeSpecification f Nothing -> (min (pred iLength) f, pred iLength) + ByteRangeSpecification f (Just t) -> (min (pred iLength) f, min (pred iLength) t) + ByteRangeSuffixSpecification s -> (iLength - min (pred iLength) s, pred iLength) + relevantChunks = view _2 $ foldl' go (0, []) dbManifest'' + where go :: (Word64, [(FileContentChunkReference, Word64, Word64)]) + -> (FileContentChunkReference, Word64) + -> (Word64, [(FileContentChunkReference, Word64, Word64)]) + go (lengthBefore, acc) (cChunk, cLength) + = ( lengthBefore + cLength + , if + | byteFrom < lengthBefore + cLength, byteTo >= lengthBefore + -> let cChunk' = ( cChunk + , bool 0 (byteFrom - lengthBefore) $ byteFrom >= lengthBefore + , bool cLength (cLength - pred (lengthBefore + cLength - byteTo)) $ byteTo < lengthBefore + cLength + ) + in acc ++ pure cChunk' + | otherwise + -> acc + ) + in ( do + dbChunksize <- getsYesod $ views _appFileUploadDBChunksize fromIntegral + forM_ relevantChunks $ \(chunkHash, offset, cLength) + -> let retrieveChunk = \case + Just (start, cLength') | cLength' > 0 -> do + let getChunkDB = fmap (fmap $ (, Just StorageDB) . E.unValue) . E.selectMaybe . E.from $ \fileContentChunk -> do + E.where_ $ fileContentChunk E.^. FileContentChunkHash E.==. E.val chunkHash + return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val $ min cLength' dbChunksize) + chunk <- fileChunkARC (Just $ fromIntegral dbChunksize) (chunkHash, (fromIntegral start, fromIntegral $ min cLength' dbChunksize)) getChunkDB + case chunk of + Nothing -> throwM SourceFilesContentUnavailable + Just c -> do + return . Just . (c, ) $ if + | fromIntegral (olength c) >= min cLength' dbChunksize + -> Just (start + dbChunksize, cLength' - fromIntegral (olength c)) + | otherwise + -> Nothing + _other -> return Nothing + in C.unfoldM retrieveChunk . Just $ (succ offset, cLength) + , ByteContentRangeSpecification (Just $ ByteRangeResponseSpecification byteFrom byteTo) (Just iLength) + ) | otherwise -> throwM SourceFilesContentUnavailable | otherwise @@ -277,6 +269,17 @@ respondFileConditional representationLastModified cType FileReference{..} = do , requestedActionAlreadySucceeded = Nothing } +byteRangeSpecificationToMinio :: Word64 -> ByteRangeSpecification -> (ByteRange, ByteRangeResponseSpecification) +byteRangeSpecificationToMinio iLength byteRange = (byteRange', respRange) + where + byteRange' = case byteRange of + ByteRangeSpecification f Nothing -> ByteRangeFrom (fromIntegral $ min (pred iLength) f) + ByteRangeSpecification f (Just t) -> ByteRangeFromTo (fromIntegral $ min iLength f) (fromIntegral $ min (pred iLength) t) + ByteRangeSuffixSpecification s -> ByteRangeSuffix (fromIntegral $ min iLength s) + respRange = case byteRange of + ByteRangeSpecification f Nothing -> ByteRangeResponseSpecification (min (pred iLength) f) (pred iLength) + ByteRangeSpecification f (Just t) -> ByteRangeResponseSpecification (min (pred iLength) f) (min (pred iLength) t) + ByteRangeSuffixSpecification s -> ByteRangeResponseSpecification (iLength - min (pred iLength) s) (pred iLength) acceptFile :: (MonadResource m, MonadResource m') => FileInfo -> m (File m') diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index a111d58de..a43dd4403 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -38,7 +38,7 @@ import Handler.Utils.Zip import qualified Data.Conduit.Combinators as C import qualified Data.Conduit.List as C (mapMaybe, mapMaybeM) -import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect) @@ -416,9 +416,9 @@ explainOptionList :: forall a. -> (a -> MaybeT Handler Widget) -> Handler ([(Option a, Maybe Widget)], Text -> Maybe a) explainOptionList ol mkExplanation = do - OptionList{..} <- ol - olOptions' <- forM olOptions $ \opt@Option{..} -> (opt, ) <$> runMaybeT (mkExplanation optionInternalValue) - return (olOptions', olReadExternal) + (options, readExternal) <- ((,) <$> toListOf _olOptions <*> view _olReadExternal) <$> ol -- TODO: support grouped? + olOptions' <- forM options $ \opt@Option{..} -> (opt, ) <$> runMaybeT (mkExplanation optionInternalValue) + return (olOptions', readExternal) explainedMultiAction' :: forall action a. Ord action @@ -1850,21 +1850,21 @@ examResultField :: forall m res. examResultField optMsg mkOl = Field { fieldEnctype = UrlEncoded -- breaks if mkOl contains options with other enctype , fieldParse = \ts fs -> do - ol@OptionList{..} <- liftHandler mkOl + (options, readExternal) <- ((,) <$> toListOf _olOptions <*> view _olReadExternal) <$> liftHandler mkOl -- TODO: support grouped? if | res : _ <- mapMaybe (assertM ((||) <$> is _ExamNoShow <*> is _ExamVoided) . fromPathPiece) ts -> return . Right $ Just res | any null ts -> return $ Right Nothing - | (optPred, innerField) : _ <- mapMaybe olReadExternal ts - -> fmap (fmap ExamAttended) <$> fieldParse innerField (filter (`notElem` outerOptions ol) $ filter (optPred . Left) ts) fs + | (optPred, innerField) : _ <- mapMaybe readExternal ts + -> fmap (fmap ExamAttended) <$> fieldParse innerField (filter (`notElem` outerOptions options) $ filter (optPred . Left) ts) fs | [] <- ts -> return $ Right Nothing | t : _ <- ts -> return . Left . SomeMessage $ MsgInvalidEntry t , fieldView = \theId name attrs val isReq -> do innerId <- newIdent - OptionList{..} <- liftHandler mkOl + options <- toListOf _olOptions <$> liftHandler mkOl let innerVal :: Either Text res innerVal = val >>= maybe (Left "") return . preview _ExamAttended @@ -1877,14 +1877,14 @@ examResultField optMsg mkOl = Field $maybe optMsg' <- guardOnM (not isReq) optMsg