From 29f4e2853667db251b48857bcb21d22482534f2f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 16 Sep 2019 17:53:45 +0200 Subject: [PATCH 01/28] feat(exams): csv-import of ExamPartResults BREAKING CHANGE: Introduces ExamPartNumbers --- frontend/src/utils/inputs/inputs.scss | 8 +- messages/uniworx/de.msg | 6 + models/exams | 7 +- src/Audit/Types.hs | 9 + src/Database/Persist/Class/Instances.hs | 13 + src/Handler/Exam/Edit.hs | 2 + src/Handler/Exam/Form.hs | 4 + src/Handler/Exam/New.hs | 1 + src/Handler/Exam/Show.hs | 5 +- src/Handler/Exam/Users.hs | 288 +++++++++++++++--- src/Handler/ExamOffice/Exam.hs | 1 + src/Handler/Utils/Csv.hs | 63 +++- src/Handler/Utils/Exam.hs | 56 ++++ src/Handler/Utils/Table/Pagination.hs | 27 +- src/Import/NoModel.hs | 2 +- src/Model.hs | 7 - src/Model/Migration.hs | 30 ++ src/Model/Types/Exam.hs | 84 ++++- src/Utils.hs | 18 ++ src/Utils/DB.hs | 6 + src/Utils/Lens.hs | 2 + templates/exam-show.hamlet | 36 ++- .../widgets/massinput/examParts/form.hamlet | 3 +- .../widgets/massinput/examParts/layout.hamlet | 25 +- .../widgets/massinput/examRooms/layout.hamlet | 23 +- 25 files changed, 612 insertions(+), 114 deletions(-) diff --git a/frontend/src/utils/inputs/inputs.scss b/frontend/src/utils/inputs/inputs.scss index c4cb63373..2d8fb8db5 100644 --- a/frontend/src/utils/inputs/inputs.scss +++ b/frontend/src/utils/inputs/inputs.scss @@ -33,11 +33,14 @@ margin: 7px 0; } -.form-section-title__hint { - margin-top: 7px; +.form-group__hint, .form-section-title__hint { color: var(--color-fontsec); font-size: 0.9rem; font-weight: 600; +} + +.form-section-title__hint { + margin-top: 7px; + .form-group { margin-top: 11px; @@ -58,6 +61,7 @@ .form-group--required .form-group-label__caption::after, .form-group__required-marker::before { content: ' *'; color: var(--color-error); + font-weight: 600; } .form-group--optional { diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index babad5c46..9e433582a 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1387,9 +1387,13 @@ ExamCorrectorAlreadyAdded: Ein Korrektor mit dieser E-Mail ist bereits für dies ExamParts: Teilaufgaben ExamPartWeightNegative: Gewicht aller Teilaufgaben muss größer oder gleich Null sein ExamPartAlreadyExists: Teilaufgabe mit diesem Namen existiert bereits +ExamPartNumber: Nummer +ExamPartNumberTip: Wird als interne Bezeichnung z.B. bei CSV-Export verwendet ExamPartName: Name +ExamPartNameTip: Wird den Studierenden angezeigt ExamPartMaxPoints: Maximalpunktzahl ExamPartWeight: Gewichtung +ExamPartWeightTip: Wird vor Anzeige oder Notenberechnung mit der erreichten Punktzahl und der Maximalpunktzahl multipliziert; Änderungen hier passen auch bestehende Korrekturergebnisse an ExamPartResultPoints: Erreichte Punkte ExamNameTaken exam@ExamName: Es existiert bereits eine Prüfung mit Namen #{exam} @@ -1518,7 +1522,9 @@ ExamUserCsvRegister: Kursteilnehmer zur Prüfung anmelden ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen ExamUserCsvDeregister: Teilnehmer von der Prüfung abmelden ExamUserCsvSetCourseField: Kurs-assoziiertes Studienfach ändern +ExamUserCsvOverrideResult: Ergebnis entgegen automatischer Notenberechnung überschreiben ExamUserCsvSetResult: Ergebnis eintragen +ExamUserCsvSetPartResult: Ergebnis einer Teilaufgabe eintragen ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht diff --git a/models/exams b/models/exams index 694f1a9bc..bcd6703c8 100644 --- a/models/exams +++ b/models/exams @@ -19,10 +19,12 @@ Exam UniqueExam course name ExamPart exam ExamId - name (CI Text) + number ExamPartNumber + name ExamPartName maxPoints Points Maybe weight Rational - UniqueExamPart exam name + UniqueExamPartNumber exam number + UniqueExamPartName exam name ExamOccurrence exam ExamId name ExamOccurrenceName @@ -42,6 +44,7 @@ ExamPartResult examPart ExamPartId user UserId result ExamResultPoints + lastChanged UTCTime default=now() UniqueExamPartResult examPart user ExamResult exam ExamId diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 4d1e77356..994f74357 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -23,6 +23,15 @@ data Transaction { transactionExam :: ExamId , transactionUser :: UserId } + + | TransactionExamPartResultEdit + { transactionExamPart :: ExamPartId + , transactionUser :: UserId + } + | TransactionExamPartResultDeleted + { transactionExamPart :: ExamPartId + , transactionUser :: UserId + } | TransactionExamResultEdit { transactionExam :: ExamId diff --git a/src/Database/Persist/Class/Instances.hs b/src/Database/Persist/Class/Instances.hs index 2dbb2bfb0..8666a2c87 100644 --- a/src/Database/Persist/Class/Instances.hs +++ b/src/Database/Persist/Class/Instances.hs @@ -8,11 +8,14 @@ module Database.Persist.Class.Instances import ClassyPrelude import Database.Persist.Class +import Database.Persist.Types (HaskellName, DBName, PersistValue) import Database.Persist.Types.Instances () import Data.Binary (Binary) import qualified Data.Binary as Binary +import qualified Data.Map as Map + instance PersistEntity record => Hashable (Key record) where hashWithSalt s = hashWithSalt s . toPersistValue @@ -24,3 +27,13 @@ instance PersistEntity record => Binary (Key record) where instance PersistEntity record => NFData (Key record) where rnf = rnf . keyToValues + + +uniqueToMap :: PersistEntity record => Unique record -> Map (HaskellName, DBName) PersistValue +uniqueToMap = fmap Map.fromList $ zip <$> persistUniqueToFieldNames <*> persistUniqueToValues + +instance PersistEntity record => Eq (Unique record) where + (==) = (==) `on` uniqueToMap + +instance PersistEntity record => Show (Unique record) where + showsPrec p = showsPrec p . uniqueToMap diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index fbd0c1acc..52d90559f 100644 --- a/src/Handler/Exam/Edit.hs +++ b/src/Handler/Exam/Edit.hs @@ -85,6 +85,7 @@ postEEditR tid ssh csh examn = do ExamPartForm{ epfId = Nothing, .. } -> insert_ ExamPart { examPartExam = eId + , examPartNumber = epfNumber , examPartName = epfName , examPartMaxPoints = epfMaxPoints , examPartWeight = epfWeight @@ -96,6 +97,7 @@ postEEditR tid ssh csh examn = do guard $ examPartExam oldPart == eId lift $ replace epfId' ExamPart { examPartExam = eId + , examPartNumber = epfNumber , examPartName = epfName , examPartMaxPoints = epfMaxPoints , examPartWeight = epfWeight diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 452b0aa3d..38213c7ed 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -56,6 +56,7 @@ data ExamOccurrenceForm = ExamOccurrenceForm data ExamPartForm = ExamPartForm { epfId :: Maybe CryptoUUIDExamPart + , epfNumber :: ExamPartNumber , epfName :: ExamPartName , epfMaxPoints :: Maybe Points , epfWeight :: Rational @@ -200,12 +201,14 @@ examPartsForm prev = wFormToAForm $ do where examPartForm' nudge mPrev csrf = do (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev) + (epfNumberRes, epfNumberView) <- mpreq (isoField (from _ExamPartNumber) $ textField & cfStrip & cfCI) ("" & addName (nudge "number") & addPlaceholder "1, 6a, 3.1.4, ...") (epfNumber <$> mPrev) (epfNameRes, epfNameView) <- mpreq (textField & cfStrip & cfCI) ("" & addName (nudge "name")) (epfName <$> mPrev) (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev) (epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1) return ( ExamPartForm <$> epfIdRes + <*> epfNumberRes <*> epfNameRes <*> epfMaxPointsRes <*> epfWeightRes @@ -266,6 +269,7 @@ examFormTemplate (Entity eId Exam{..}) = do (Just -> epfId, ExamPart{..}) <- examParts' return ExamPartForm { epfId + , epfNumber = examPartNumber , epfName = examPartName , epfMaxPoints = examPartMaxPoints , epfWeight = examPartWeight diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index 0f863f75b..d4e6582a7 100644 --- a/src/Handler/Exam/New.hs +++ b/src/Handler/Exam/New.hs @@ -50,6 +50,7 @@ postCExamNewR tid ssh csh = do [ ExamPart{..} | ExamPartForm{..} <- Set.toList efExamParts , let examPartExam = examid + examPartNumber = epfNumber examPartName = epfName examPartMaxPoints = epfMaxPoints examPartWeight = epfWeight diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index 72c6058b4..eceeecc1c 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -33,7 +33,7 @@ getEShowR tid ssh csh examn = do let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR - examParts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ] + examParts <- sortOn (view $ _entityVal . _examPartNumber) <$> selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ] resultsRaw <- for mUid $ \uid -> E.select . E.from $ \examPartResult -> do @@ -86,6 +86,9 @@ getEShowR tid ssh csh examn = do | fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|] | otherwise = Nothing + showMaxPoints = any (has $ _entityVal . _examPartMaxPoints . _Just) examParts + showAchievedPoints = not $ null results + let heading = prependCourseTitle tid ssh csh $ CI.original examName siteLayoutMsg heading $ do diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 42a1f12f5..fa087816e 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -4,7 +4,7 @@ module Handler.Exam.Users ( getEUsersR, postEUsersR ) where -import Import +import Import hiding ((<.), (.>)) import Handler.Utils import Handler.Utils.Exam @@ -18,11 +18,13 @@ import Database.Esqueleto.Utils.TH import qualified Data.Csv as Csv -import Data.Map ((!)) +import Data.Map ((!), (!?)) import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.HashMap.Lazy as HashMap import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import qualified Data.Text.Lens as Text import qualified Data.Conduit.List as C @@ -33,9 +35,31 @@ import Numeric.Lens (integral) import Database.Persist.Sql (deleteWhereCount, updateWhereCount) +import Control.Lens.Indexed ((<.), (.>)) -type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) -type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms), Maybe (Entity ExamResult), Maybe (Entity CourseUserNote)) + +type ExamUserTableExpr = ( E.SqlExpr (Entity ExamRegistration) + `E.InnerJoin` E.SqlExpr (Entity User) + ) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) + `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity CourseParticipant)) + `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures)) + `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) + `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)) + ) + ) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) +type ExamUserTableData = DBRow ( Entity ExamRegistration + , Entity User + , Maybe (Entity ExamOccurrence) + , Maybe (Entity StudyFeatures) + , Maybe (Entity StudyDegree) + , Maybe (Entity StudyTerms) + , Maybe (Entity ExamResult) + , Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)) + , Maybe (Entity CourseUserNote) + ) instance HasEntity ExamUserTableData User where hasEntity = _dbrOutput . _2 @@ -91,8 +115,32 @@ resultExamOccurrence = _dbrOutput . _3 . _Just resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult) resultExamResult = _dbrOutput . _7 . _Just +resultExamParts :: IndexedTraversal' ExamPartId ExamUserTableData (ExamPart, Maybe (Entity ExamPartResult)) +resultExamParts = _dbrOutput . _8 . itraversed + +-- resultExamParts' :: Traversal' ExamUserTableData (Entity ExamPart) +-- resultExamParts' = (resultExamParts <. _1) . withIndex . from _Entity + +-- resultExamPartResult :: ExamPartId -> Lens' ExamUserTableData (Maybe (Entity ExamPartResult)) +-- resultExamPartResult epId = _dbrOutput . _8 . unsafeSingular (ix epId) . _2 + +-- resultExamPartResults :: IndexedTraversal' ExamPartId ExamUserTableData (Maybe (Entity ExamPartResult)) +-- resultExamPartResults = resultExamParts <. _2 + resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote) -resultCourseNote = _dbrOutput . _8 . _Just +resultCourseNote = _dbrOutput . _9 . _Just + + +csvExamPartHeader :: Prism' Csv.Name ExamPartNumber +csvExamPartHeader = prism' toHeader fromHeader + where + toHeader pName = encodeUtf8 $ partPrefix <> CI.foldedCase (pName ^. _ExamPartNumber) + fromHeader hdr = do + tHdr <- either (const Nothing) Just $ Text.decodeUtf8' hdr + review _ExamPartNumber . CI.mk <$> stripPrefix partPrefix tHdr + + partPrefix = "part-" + data ExamUserTableCsv = ExamUserTableCsv { csvEUserSurname :: Maybe Text @@ -107,20 +155,38 @@ data ExamUserTableCsv = ExamUserTableCsv , csvEUserExerciseNumPasses :: Maybe Int , csvEUserExercisePointsMax :: Maybe Points , csvEUserExerciseNumPassesMax :: Maybe Int + , csvEUserExamPartResults :: Map ExamPartNumber (Maybe ExamResultPoints) , csvEUserExamResult :: Maybe ExamResultPassedGrade , csvEUserCourseNote :: Maybe Html } deriving (Generic) makeLenses_ ''ExamUserTableCsv -examUserTableCsvOptions :: Csv.Options -examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 } - instance ToNamedRecord ExamUserTableCsv where - toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions + toNamedRecord ExamUserTableCsv{..} = Csv.namedRecord $ + [ "surname" Csv..= csvEUserSurname + , "first-name" Csv..= csvEUserFirstName + , "name" Csv..= csvEUserName + , "matriculation" Csv..= csvEUserMatriculation + , "field" Csv..= csvEUserField + , "degree" Csv..= csvEUserDegree + , "semester" Csv..= csvEUserSemester + , "occurrence" Csv..= csvEUserOccurrence + , "exercise-points" Csv..= csvEUserExercisePoints + , "exercise-num-passes" Csv..= csvEUserExerciseNumPasses + , "exercise-points-max" Csv..= csvEUserExercisePointsMax + , "exercise-num-passes-max" Csv..= csvEUserExerciseNumPassesMax + ] ++ examPartResults ++ + [ "exam-result" Csv..= csvEUserExamResult + , "course-note" Csv..= csvEUserCourseNote + ] + where + examPartResults + = flip ifoldMap csvEUserExamPartResults $ + \pNumber pResult -> pure $ (csvExamPartHeader # pNumber) Csv..= pResult instance FromNamedRecord ExamUserTableCsv where - parseNamedRecord csv -- Manually defined awaiting issue #427 + parseNamedRecord csv = ExamUserTableCsv <$> csv .:?? "surname" <*> csv .:?? "first-name" @@ -134,29 +200,49 @@ instance FromNamedRecord ExamUserTableCsv where <*> csv .:?? "exercise-num-passes" <*> csv .:?? "exercise-points-max" <*> csv .:?? "exercise-num-passes-max" + <*> examPartResults <*> csv .:?? "exam-result" <*> csv .:?? "course-note" - -instance DefaultOrdered ExamUserTableCsv where - headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions + where + examPartResults = fmap fold . sequence . flip HashMap.mapMaybeWithKey csv $ \pNumber' _ -> do + pNumber <- pNumber' ^? csvExamPartHeader + return . fmap (singletonMap pNumber ) $ csv .:?? pNumber' instance CsvColumnsExplained ExamUserTableCsv where - csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList - [ ('csvEUserSurname , MsgCsvColumnExamUserSurname ) - , ('csvEUserFirstName , MsgCsvColumnExamUserFirstName ) - , ('csvEUserName , MsgCsvColumnExamUserName ) - , ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation ) - , ('csvEUserField , MsgCsvColumnExamUserField ) - , ('csvEUserDegree , MsgCsvColumnExamUserDegree ) - , ('csvEUserSemester , MsgCsvColumnExamUserSemester ) - , ('csvEUserOccurrence , MsgCsvColumnExamUserOccurrence ) - , ('csvEUserExercisePoints , MsgCsvColumnExamUserExercisePoints ) - , ('csvEUserExerciseNumPasses , MsgCsvColumnExamUserExercisePasses ) - , ('csvEUserExercisePointsMax , MsgCsvColumnExamUserExercisePointsMax ) - , ('csvEUserExerciseNumPassesMax, MsgCsvColumnExamUserExercisePassesMax ) - , ('csvEUserExamResult , MsgCsvColumnExamUserResult ) - , ('csvEUserCourseNote , MsgCsvColumnExamUserCourseNote ) + csvColumnsExplanations _ = mconcat + [ single "surname" MsgCsvColumnExamUserSurname + , single "first-name" MsgCsvColumnExamUserFirstName + , single "name" MsgCsvColumnExamUserName + , single "matriculation" MsgCsvColumnExamUserMatriculation + , single "field" MsgCsvColumnExamUserField + , single "degree" MsgCsvColumnExamUserDegree + , single "semester" MsgCsvColumnExamUserSemester + , single "occurrence" MsgCsvColumnExamUserOccurrence + , single "exercise-points" MsgCsvColumnExamUserExercisePoints + , single "exercise-num-passes" MsgCsvColumnExamUserExercisePasses + , single "exercise-points-max" MsgCsvColumnExamUserExercisePointsMax + , single "exercise-num-passes-max" MsgCsvColumnExamUserExercisePassesMax + , single "exam-result" MsgCsvColumnExamUserResult + , single "course-note" MsgCsvColumnExamUserCourseNote ] + where + single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget + single k v = singletonMap k [whamlet|_{v}|] + +examUserTableCsvHeader :: ( MonoFoldable mono + , Element mono ~ ExamPartNumber + ) + => mono -> Csv.Header +examUserTableCsvHeader pNames = Csv.header $ + [ "surname", "first-name", "name" + , "matriculation" + , "field", "degree", "semester" + , "course-note" + , "occurrence" + , "exercise-points", "exercise-num-passes", "exercise-points-max", "exercise-num-passes-max" + ] ++ map (review csvExamPartHeader) (sort $ otoList pNames) ++ + [ "exam-result" + ] data ExamUserAction = ExamUserDeregister | ExamUserAssignOccurrence @@ -175,7 +261,9 @@ data ExamUserCsvActionClass | ExamUserCsvRegister | ExamUserCsvAssignOccurrence | ExamUserCsvSetCourseField + | ExamUserCsvSetPartResult | ExamUserCsvSetResult + | ExamUserCsvOverrideResult | ExamUserCsvSetCourseNote | ExamUserCsvDeregister deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) @@ -202,8 +290,14 @@ data ExamUserCsvAction | ExamUserCsvDeregisterData { examUserCsvActRegistration :: ExamRegistrationId } - | ExamUserCsvSetResultData + | ExamUserCsvSetPartResultData { examUserCsvActUser :: UserId + , examUserCsvActExamPart :: ExamPartNumber + , examUserCsvActExamPartResult :: Maybe ExamResultPoints + } + | ExamUserCsvSetResultData + { examUserCsvIsResultOverride :: Bool + , examUserCsvActUser :: UserId , examUserCsvActExamResult :: Maybe ExamResultPassedGrade } | ExamUserCsvSetCourseNoteData @@ -232,6 +326,7 @@ getEUsersR = postEUsersR postEUsersR tid ssh csh examn = do ((registrationResult, examUsersTable), Entity eId _) <- runDB $ do exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn + examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName] bonus <- examBonus exam let @@ -242,6 +337,8 @@ postEUsersR tid ssh csh examn = do resultView :: ExamResultGrade -> ExamResultPassedGrade resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades + examPartNumbers = examParts ^.. folded . _entityVal . _examPartNumber + csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn) let @@ -263,7 +360,25 @@ postEUsersR tid ssh csh examn = do E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult, courseUserNote) dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) - dbtProj = return + dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ + (,,,,,,,,) + <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 + <*> getExamParts + <*> view _8 + where + getExamParts :: ReaderT _ (MaybeT (YesodDB UniWorX)) (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult))) + getExamParts = do + uid <- view $ _2 . _entityKey + rawResults <- lift . lift . E.select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> do + E.on $ examPartResult E.?. ExamPartResultExamPart E.==. E.just (examPart E.^. ExamPartId) + E.&&. examPartResult E.?. ExamPartResultUser E.==. E.just (E.val uid) + E.where_ $ examPart E.^. ExamPartExam E.==. E.val eid + return (examPart, examPartResult) + return $ Map.fromList + [ (epId, (examPart, mbRes)) + | (Entity epId examPart, mbRes) <- rawResults + ] + dbtColonnade = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id $ return . view (resultExamRegistration . _entityKey) , pure $ colUserNameLink (CourseR tid ssh csh . CUserR) @@ -359,21 +474,30 @@ postEUsersR tid ssh csh examn = do } dbtIdent :: Text dbtIdent = "exam-users" - dbtCsvEncode = simpleCsvEncode csvName $ ExamUserTableCsv - <$> view (resultUser . _entityVal . _userSurname . to Just) - <*> view (resultUser . _entityVal . _userFirstName . to Just) - <*> view (resultUser . _entityVal . _userDisplayName . to Just) - <*> view (resultUser . _entityVal . _userMatrikelnummer) - <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just) - <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) - <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) - <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) - <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped) - <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral) - <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) - <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) - <*> preview (resultExamResult . _entityVal . _examResultResult . to resultView) - <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote) + dbtCsvEncode = Just DBTCsvEncode + { dbtCsvExportForm = pure () + , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) + , dbtCsvName = unpack csvName + , dbtCsvNoExportData = Just id + , dbtCsvHeader = const . return . examUserTableCsvHeader $ examParts ^.. folded . _entityVal . _examPartNumber + } + where + doEncode' = ExamUserTableCsv + <$> view (resultUser . _entityVal . _userSurname . to Just) + <*> view (resultUser . _entityVal . _userFirstName . to Just) + <*> view (resultUser . _entityVal . _userDisplayName . to Just) + <*> view (resultUser . _entityVal . _userMatrikelnummer) + <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just) + <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) + <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) + <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) + <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped) + <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral) + <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) + <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) + <*> (Map.fromList . map (over _1 examPartNumber . over (_2 . _Just) (examPartResultResult . entityVal)) <$> asks (toListOf resultExamParts)) + <*> preview (resultExamResult . _entityVal . _examResultResult . to resultView) + <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote) dbtCsvDecode = Just DBTCsvDecode { dbtCsvRowKey = \csv -> do uid <- lift $ view _2 <$> guessUser csv @@ -394,8 +518,13 @@ postEUsersR tid ssh csh examn = do yield $ ExamUserCsvSetCourseFieldData cpId newFeatures | otherwise -> yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew + + iforMOf_ (ifolded <. _Just) (csvEUserExamPartResults dbCsvNew) $ \epNumber epRes -> + when (epNumber `elem` examPartNumbers) $ + yield $ ExamUserCsvSetPartResultData uid epNumber (Just epRes) + when (is _Just $ csvEUserExamResult dbCsvNew) $ - yield . ExamUserCsvSetResultData uid $ csvEUserExamResult dbCsvNew + yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew note <- lift . getBy $ UniqueCourseUserNote uid examCourse when (csvEUserCourseNote dbCsvNew /= note ^? _Just . _entityVal . _courseUserNoteNote) $ @@ -410,8 +539,38 @@ postEUsersR tid ssh csh examn = do Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey yield $ ExamUserCsvSetCourseFieldData cpId newFeatures - when (csvEUserExamResult dbCsvNew /= dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView) $ - yield . ExamUserCsvSetResultData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserExamResult dbCsvNew + let uid = dbCsvOld ^. resultUser . _entityKey + + forM_ examPartNumbers $ \epNumber -> + let oldPartResult = dbCsvOld ^? resultExamParts . filtered (views (_1 . _examPartNumber) (== epNumber)) . _2 . _Just . _entityVal . _examPartResultResult + in whenIsJust (csvEUserExamPartResults dbCsvNew !? epNumber) $ \epRes -> + when (epRes /= oldPartResult) $ + yield $ ExamUserCsvSetPartResultData uid epNumber epRes + + let newResults :: Map ExamPartNumber (Maybe ExamResultPoints) + newResults = csvEUserExamPartResults dbCsvNew + `Map.union` toMapOf (resultExamParts .> ito (over _1 $ examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld + + newGrade :: Maybe ExamResultPassedGrade + newGrade = do + possible <- examBonusPossible uid bonus + achieved <- examBonusAchieved uid bonus + resultView <$> examGrade exam possible achieved (newResults ^.. folded . _Just) + + oldResult = dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView + + case newGrade of + _ | csvEUserExamResult dbCsvNew == oldResult + -> return () + Nothing + -> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew + Just _ + | csvEUserExamResult dbCsvNew /= newGrade + -> yield . ExamUserCsvSetResultData True uid $ csvEUserExamResult dbCsvNew + | oldResult /= newGrade + -> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew + | otherwise + -> return () when (csvEUserCourseNote dbCsvNew /= dbCsvOld ^? resultCourseNote . _entityVal . _courseUserNoteNote) $ yield . ExamUserCsvSetCourseNoteData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserCourseNote dbCsvNew @@ -421,7 +580,10 @@ postEUsersR tid ssh csh examn = do ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField - ExamUserCsvSetResultData{} -> ExamUserCsvSetResult + ExamUserCsvSetPartResultData{} -> ExamUserCsvSetPartResult + ExamUserCsvSetResultData{..} + | examUserCsvIsResultOverride -> ExamUserCsvOverrideResult + | otherwise -> ExamUserCsvSetResult ExamUserCsvSetCourseNoteData{} -> ExamUserCsvSetCourseNote , dbtCsvCoarsenActionClass = \case ExamUserCsvCourseRegister -> DBCsvActionNew @@ -462,6 +624,21 @@ postEUsersR tid ssh csh examn = do update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ] CourseParticipant{..} <- getJust examUserCsvActCourseParticipant audit $ TransactionCourseParticipantEdit examCourse courseParticipantUser + ExamUserCsvSetPartResultData{..} -> do + epid <- getKeyJustBy $ UniqueExamPartNumber eid examUserCsvActExamPart + case examUserCsvActExamPartResult of + Nothing -> do + deleteBy $ UniqueExamPartResult epid examUserCsvActUser + audit $ TransactionExamPartResultDeleted epid examUserCsvActUser + Just res -> do + now <- liftIO getCurrentTime + void $ upsertBy + (UniqueExamPartResult epid examUserCsvActUser) + (ExamPartResult epid examUserCsvActUser res now) + [ ExamPartResultResult =. res + , ExamPartResultLastChanged =. now + ] + audit $ TransactionExamPartResultEdit epid examUserCsvActUser ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of Nothing -> do deleteBy $ UniqueExamResult eid examUserCsvActUser @@ -540,6 +717,19 @@ postEUsersR tid ssh csh examn = do $nothing , _{MsgCourseStudyFeatureNone} |] + ExamUserCsvSetPartResultData{..} -> do + (User{..}, Entity _ ExamPart{..}) <- liftHandlerT . runDB $ + (,) <$> getJust examUserCsvActUser + <*> getJustBy (UniqueExamPartNumber eid examUserCsvActExamPart) + [whamlet| + $newline never + ^{nameWidget userDisplayName userSurname} + , „#{examPartName}“ + $maybe newResult <- examUserCsvActExamPartResult + , _{newResult} + $nothing + , _{MsgExamResultNone} + |] ExamUserCsvSetResultData{..} -> do User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser [whamlet| diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index c44f50ee1..61b6a778d 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -408,6 +408,7 @@ postEGradesR tid ssh csh examn = do (row ^. resultExamResult . _entityVal . _examResultResult . to (fmap $ bool (Left . view passingGrade) Right examShowGrades)) , dbtCsvName = unpack csvName , dbtCsvNoExportData = Nothing + , dbtCsvHeader = const . return $ Csv.headerOrder (error "headerOrder" :: ExamUserTableCsv) } dbtCsvDecode = Nothing diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 0ebbb4cdb..a8e0d7201 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -4,7 +4,9 @@ module Handler.Utils.Csv ( typeCsv, extensionCsv , decodeCsv , encodeCsv + , encodeDefaultOrderedCsv , respondCsv, respondCsvDB + , respondDefaultOrderedCsv, respondDefaultOrderedCsvDB , fileSourceCsv , CsvParseError(..) , ToNamedRecord(..), FromNamedRecord(..) @@ -12,6 +14,7 @@ module Handler.Utils.Csv , ToField(..), FromField(..) , CsvRendered(..) , toCsvRendered + , toDefaultOrderedCsvRendered ) where import Import hiding (Header, mapM_) @@ -111,30 +114,54 @@ decodeCsv = transPipe throwExceptT $ do encodeCsv :: ( ToNamedRecord csv - , DefaultOrdered csv , Monad m ) - => Conduit csv m ByteString + => Header + -> Conduit csv m ByteString -- ^ Encode a stream of records -- -- Currently not streaming -encodeCsv = fmap encodeDefaultOrderedByName (C.foldMap pure) >>= C.sourceLazy +encodeCsv hdr = fmap (encodeByName hdr) (C.foldMap pure) >>= C.sourceLazy + +encodeDefaultOrderedCsv :: forall csv m. + ( ToNamedRecord csv + , DefaultOrdered csv + , Monad m + ) + => Conduit csv m ByteString +encodeDefaultOrderedCsv = encodeCsv $ headerOrder (error "headerOrder" :: csv) -respondCsv :: ( ToNamedRecord csv - , DefaultOrdered csv - ) - => Source (HandlerT site IO) csv +respondCsv :: ToNamedRecord csv + => Header + -> Source (HandlerT site IO) csv -> HandlerT site IO TypedContent -respondCsv src = respondSource typeCsv' $ src .| encodeCsv .| awaitForever sendChunk +respondCsv hdr src = respondSource typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk + +respondDefaultOrderedCsv :: forall csv site. + ( ToNamedRecord csv + , DefaultOrdered csv + ) + => Source (HandlerT site IO) csv + -> HandlerT site IO TypedContent +respondDefaultOrderedCsv = respondCsv $ headerOrder (error "headerOrder" :: csv) respondCsvDB :: ( ToNamedRecord csv - , DefaultOrdered csv , YesodPersistRunner site ) - => Source (YesodDB site) csv + => Header + -> Source (YesodDB site) csv -> HandlerT site IO TypedContent -respondCsvDB src = respondSourceDB typeCsv' $ src .| encodeCsv .| awaitForever sendChunk +respondCsvDB hdr src = respondSourceDB typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk + +respondDefaultOrderedCsvDB :: forall csv site. + ( ToNamedRecord csv + , DefaultOrdered csv + , YesodPersistRunner site + ) + => Source (YesodDB site) csv + -> HandlerT site IO TypedContent +respondDefaultOrderedCsvDB = respondCsvDB $ headerOrder (error "headerOrder" :: csv) fileSourceCsv :: ( FromNamedRecord csv , MonadResource m @@ -166,8 +193,16 @@ toCsvRendered :: forall mono. , DefaultOrdered (Element mono) , MonoFoldable mono ) - => mono -> CsvRendered -toCsvRendered (otoList -> csvs) = CsvRendered{..} + => Header + -> mono -> CsvRendered +toCsvRendered csvRenderedHeader (otoList -> csvs) = CsvRendered{..} where - csvRenderedHeader = headerOrder (error "not forced" :: Element mono) csvRenderedData = map toNamedRecord csvs + +toDefaultOrderedCsvRendered :: forall mono. + ( ToNamedRecord (Element mono) + , DefaultOrdered (Element mono) + , MonoFoldable mono + ) + => mono -> CsvRendered +toDefaultOrderedCsvRendered = toCsvRendered $ headerOrder (error "headerOrder" :: Element mono) diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 5cdd6fd29..11d1fb446 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -2,6 +2,7 @@ module Handler.Utils.Exam ( fetchExamAux , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam , examBonus, examBonusPossible, examBonusAchieved + , examGrade ) where import Import.NoFoundation @@ -81,3 +82,58 @@ examBonus (Entity eId Exam{..}) = runConduit $ examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> Maybe SheetGradeSummary examBonusPossible uid bonusMap = normalSummary <$> Map.lookup uid bonusMap examBonusAchieved uid bonusMap = (mappend <$> normalSummary <*> bonusSummary) <$> Map.lookup uid bonusMap + + +examGrade :: ( MonoFoldable mono + , Element mono ~ ExamResultPoints + ) + => Entity Exam + -> SheetGradeSummary -- ^ `examBonusPossible` + -> SheetGradeSummary -- ^ `examBonusAchieved` + -> mono -- ^ `ExamPartResult`s + -> Maybe ExamResultGrade +examGrade (Entity _ Exam{..}) bonusPossible bonusAchieved (otoList -> results) + | null results + = Nothing + | otherwise + = traverse pointsToGrade achievedPoints' + where + achievedPoints' :: ExamResultPoints + achievedPoints' = withBonus . getSum <$> foldMap (fmap Sum) results + + withBonus :: Points -> Points + withBonus ps + | ExamBonusPoints{..} <- examBonusRule + = if + | not bonusOnlyPassed + || fmap (view passingGrade) (pointsToGrade ps) == Just (_Wrapped # True) + -> ps + roundToPoints (toRational bonusMaxPoints * bonusProp) + | otherwise + -> ps + | otherwise + = ps + where + bonusProp :: Rational + bonusProp = clamp 0 1 $ toRational (getSum (achievedPoints bonusAchieved) + scalePasses (getSum $ achievedPasses bonusAchieved)) + / toRational (getSum (sumSheetsPoints bonusPossible) + scalePasses (getSum $ numSheetsPasses bonusPossible)) + where + scalePasses :: Integer -> Points + -- ^ Rescale passes so count of all sheets with pass is worth as many points as sum of all sheets with points + scalePasses passes = fromInteger passes / (fromInteger . getSum $ numSheetsPasses bonusPossible) * (getSum $ sumSheetsPoints bonusPossible) + + roundToPoints :: forall a. HasResolution a => Rational -> Fixed a + roundToPoints = MkFixed . round . ((*) . toRational $ resolution (Proxy @a)) + + pointsToGrade :: Points -> Maybe ExamGrade + pointsToGrade ps + | ExamGradingKey{..} <- examGradingRule + = Just $ gradeFromKey examGradingKey + | otherwise + = Nothing + where + gradeFromKey :: [Points] -> ExamGrade + gradeFromKey examGradingKey' = maximum $ impureNonNull [ g | (g, b) <- lowerBounds, b <= clampMin 0 ps ] + where + lowerBounds :: [(ExamGrade, Points)] + lowerBounds = zip [Grade50, Grade40 ..] $ 0 : examGradingKey' + diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 99616ae6e..d9823153a 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -111,6 +111,8 @@ import qualified Control.Monad.Catch as Catch import Data.Dynamic +import qualified Data.Csv as Csv + #if MIN_VERSION_base(4,11,0) type Monoid' = Monoid @@ -513,17 +515,18 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter) data DBTCsvEncode r' k' csv = forall exportData. - ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv + ( ToNamedRecord csv, CsvColumnsExplained csv , DBTableKey k' , Typeable exportData ) => DBTCsvEncode { dbtCsvExportForm :: AForm (YesodDB UniWorX) exportData + , dbtCsvHeader :: Maybe exportData -> YesodDB UniWorX Csv.Header -- ^ @exportData@ is @Nothing@, if we're reporting an error , dbtCsvDoEncode :: exportData -> Conduit (k', r') (YesodDB UniWorX) csv , dbtCsvName :: FilePath , dbtCsvNoExportData :: Maybe (AnIso' exportData ()) } data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException. - ( FromNamedRecord csv, ToNamedRecord csv, DefaultOrdered csv + ( FromNamedRecord csv, ToNamedRecord csv , DBTableKey k' , RedirectUrl UniWorX route , Typeable csv @@ -566,7 +569,8 @@ type DBFilterUI = Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map F noCsvEncode :: Maybe (DBTCsvEncode r' k' Void) noCsvEncode = Nothing -simpleCsvEncode :: ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv +simpleCsvEncode :: forall fp r' k' csv. + ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv , DBTableKey k' , Textual fp ) @@ -576,9 +580,11 @@ simpleCsvEncode fName f = Just DBTCsvEncode , dbtCsvDoEncode = \() -> C.map (f . view _2) , dbtCsvName = unpack fName , dbtCsvNoExportData = Just id + , dbtCsvHeader = const . return $ headerOrder (error "headerOrder" :: csv) } -simpleCsvEncodeM :: ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv +simpleCsvEncodeM :: forall fp r' k' csv. + ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv , DBTableKey k' , Textual fp ) @@ -588,6 +594,7 @@ simpleCsvEncodeM fName f = Just DBTCsvEncode , dbtCsvDoEncode = \() -> C.mapM (runReaderT f . view _2) , dbtCsvName = unpack fName , dbtCsvNoExportData = Just id + , dbtCsvHeader = const . return $ headerOrder (error "headerOrder" :: csv) } @@ -964,11 +971,13 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db DBCsvExport{..} | Just DBTCsvEncode{..} <- dbtCsvEncode , Just exportData <- fromDynamic dbCsvExportData -> do + hdr <- dbtCsvHeader $ Just exportData let ensureExtension ext fName = bool (addExtension ext) id (ext `isExtensionOf` fName) fName setContentDisposition' . Just $ ensureExtension (unpack extensionCsv) dbtCsvName - sendResponse <=< liftHandlerT . respondCsvDB $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave + sendResponse <=< liftHandlerT . respondCsvDB hdr $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave DBCsvImport{..} - | Just (DBTCsvDecode{ dbtCsvClassifyAction = dbtCsvClassifyAction :: csvAction -> csvActionClass + | Just DBTCsvEncode{..} <- dbtCsvEncode + , Just (DBTCsvDecode{ dbtCsvClassifyAction = dbtCsvClassifyAction :: csvAction -> csvActionClass , .. } :: DBTCsvDecode r' k' csv) <- dbtCsvDecode -> do let existing = Map.fromList $ zip currentKeys rows @@ -1052,14 +1061,14 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db $(widgetFile "csv-import-confirmation-wrapper") - let defaultHeaderOrder = headerOrder (error "not to be forced" :: csv) + hdr <- dbtCsvHeader Nothing catches importCsv [ Catch.Handler $ \case (DBCsvDuplicateKey{..} :: DBCsvException k') -> liftHandlerT $ sendResponseStatus badRequest400 =<< do mr <- getMessageRender - let offendingCsv = CsvRendered defaultHeaderOrder [ dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB ] + let offendingCsv = CsvRendered hdr [ dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB ] heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvDuplicateKey] siteLayoutMsg heading $ do @@ -1073,7 +1082,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db -> liftHandlerT $ sendResponseStatus badRequest400 =<< do mr <- getMessageRender - let offendingCsv = CsvRendered defaultHeaderOrder [ dbCsvExceptionRow ] + let offendingCsv = CsvRendered hdr [ dbCsvExceptionRow ] heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvException] siteLayoutMsg heading $ do diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 7d8b81322..4f08fbebb 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -141,7 +141,7 @@ import Control.Lens as Import hiding ( (<.>) , universe , cons, uncons, snoc, unsnoc, (<|) - , Index, index, (<.) + , Index, index, (<.), (.>) ) import Control.Lens.Extras as Import (is) import Data.Set.Lens as Import diff --git a/src/Model.hs b/src/Model.hs index d798d98bf..5e049e254 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -33,13 +33,6 @@ import Text.Blaze (ToMarkup(..)) share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'", mkSave "currentModel"] $(persistDirectoryWith lowerCaseSettings "models") --- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only; comments helpful for searching in code -deriving instance Eq (Unique Course) -- instance Eq TermSchoolCourseShort; instance Eq TermSchoolCourseName -deriving instance Eq (Unique Sheet) -- instance Eq CourseSheet -deriving instance Eq (Unique Material) -- instance Eq UniqueMaterial -deriving instance Eq (Unique Tutorial) -- instance Eq Tutorial -deriving instance Eq (Unique Exam) - submissionRatingDone :: Submission -> Bool submissionRatingDone Submission{..} = isJust submissionRatingTime diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index fb64f2129..eab6af88a 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -47,6 +47,9 @@ import qualified Net.IPv6 as IPv6 import Data.Aeson (toJSON) +import qualified Data.Char as Char +import qualified Data.CaseInsensitive as CI + -- Database versions must follow https://pvp.haskell.org: -- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format) -- - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table) @@ -493,6 +496,33 @@ customMigrations = Map.fromListWith (>>) ALTER TABLE "user" ALTER COLUMN "display_email" SET NOT NULL; |] ) + , ( AppliedMigrationKey [migrationVersion|20.0.0|] [version|21.0.0|] + , whenM (tableExists "exam_part") $ do + [executeQQ| + ALTER TABLE "exam_part" ADD COLUMN IF NOT EXISTS "number" citext; + |] + + let getExamEntries = rawQuery [st|SELECT DISTINCT exam FROM exam_part ORDER BY exam;|] [] + renameExamParts [fromPersistValue -> Right (eId :: ExamId)] = do + partNames' <- [sqlQQ|SELECT id, name FROM "exam_part" WHERE exam = #{eId};|] + let + partNames :: [(ExamPartId, ExamPartName)] + partNames = foldMap (\(Single epId, Single pName) -> singletonMap epId pName) partNames' + + partsSorted = partNames + & sortOn ( map (\x -> maybe (Left x) Right (readMay x :: Maybe Integer)) + . groupBy ((==) `on` Char.isDigit) + . CI.foldedCase + . snd + ) + & map fst + forM_ (zip [_ExamPartNumber' # 1..] partsSorted) $ \(num :: ExamPartNumber, pId) -> + [executeQQ| + UPDATE "exam_part" SET "number" = #{num} WHERE "id" = #{pId}; + |] + renameExamParts _ = return () + runConduit $ getExamEntries .| C.mapM_ renameExamParts + ) ] diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index c829532b4..fc92e3f58 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -6,7 +6,20 @@ Module: Model.Types.Exam Description: Types for modeling Exams -} module Model.Types.Exam - ( module Model.Types.Exam + ( ExamResult'(..) + , _ExamAttended, _ExamNoShow, _ExamVoided + , _examResult + , ExamBonusRule(..) + , ExamOccurrenceRule(..) + , ExamGrade(..) + , numberGrade + , ExamGradingRule(..) + , ExamPassed(..) + , passingGrade + , ExamResultPoints, ExamResultGrade, ExamResultPassed + , ExamResultPassedGrade + , ExamPartNumber + , _ExamPartNumber, _ExamPartNumber' ) where import Import.NoModel @@ -20,6 +33,15 @@ import qualified Data.Csv as Csv import Database.Persist.Sql +import qualified Data.CaseInsensitive as CI +import qualified Data.Char as Char + +import Text.Read + +import Text.Blaze (ToMarkup(..)) + +import qualified Data.Foldable + data ExamResult' res = ExamAttended { examResult :: res } | ExamNoShow @@ -56,6 +78,12 @@ instance Applicative ExamResult' where ExamNoShow <*> _ = ExamNoShow ExamVoided <*> _ = ExamVoided +instance Foldable ExamResult' where + foldMap = foldMapOf _examResult + +instance Traversable ExamResult' where + traverse = _examResult + instance Semigroup res => Semigroup (ExamResult' res) where ExamAttended r <> ExamAttended r' = ExamAttended $ r <> r' ExamVoided <> _ = ExamVoided @@ -185,7 +213,7 @@ instance PersistFieldSql ExamGrade where data ExamGradingRule = ExamGradingManual | ExamGradingKey - { examGradingKey :: [Points] -- ^ @[n1, n2, n3, ..., n11]@ means @0 <= p < n1 -> p ~= 5@, @n1 <= p < n2 -> p ~ 4.7@, @n2 <= p < n3 -> p ~ 4.3@, ..., @n11 <= p -> p ~ 1.0@ + { examGradingKey :: [Points] -- ^ @[n1, n2, n3, ..., n11]@ means @0 <= p < n1 -> p ~= 5@, @n1 <= p < n2 -> p ~ 4@, @n2 <= p < n3 -> p ~ 3.7@, ..., @n10 <= p -> p ~ 1.0@ } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions @@ -223,3 +251,55 @@ instance Csv.ToField (Either ExamPassed ExamGrade) where instance Csv.FromField (Either ExamPassed ExamGrade) where parseField x = (Left <$> Csv.parseField x) <|> (Right <$> Csv.parseField x) -- encodings are disjoint + + +newtype ExamPartNumber = ExamPartNumber { examPartNumberFragments :: [Either (CI Text) Natural] } + deriving (Eq, Ord, Generic, Typeable) + +_ExamPartNumber :: Iso' ExamPartNumber (CI Text) +_ExamPartNumber = iso pToText pFromText + where + pToText = foldMap (either id (CI.mk . tshow)) . examPartNumberFragments + pFromText = ExamPartNumber . map (\t -> maybe (Left $ CI.mk t) Right $ readMay t) . Text.groupBy ((==) `on` Char.isDigit) . CI.original + +_ExamPartNumber' :: Integral n => Prism' ExamPartNumber n +_ExamPartNumber' = prism (ExamPartNumber . fromNum) (first ExamPartNumber . toNum . examPartNumberFragments) + where + fromNum (toInteger -> n) + | n < 0 = [Left "-", Right . fromInteger $ abs n] + | otherwise = [Right $ fromInteger n] + + toNum fs + | Just ns <- mapM (preview _Right) fs + = case ns of + [] -> Left [] + [n] -> Right $ fromIntegral n + _ -> Right . fromInteger . read $ concatMap show ns + | otherwise + = Left fs + +instance Show ExamPartNumber where + showsPrec p = showsPrec p . CI.original . view _ExamPartNumber +instance Read ExamPartNumber where + readPrec = review _ExamPartNumber . CI.mk <$> readPrec + +instance PersistField ExamPartNumber where + toPersistValue = toPersistValue . view _ExamPartNumber + fromPersistValue = fmap (review _ExamPartNumber) . fromPersistValue +instance PersistFieldSql ExamPartNumber where + sqlType _ = sqlType (Proxy @(CI Text)) + +instance PathPiece ExamPartNumber where + toPathPiece = toPathPiece . view _ExamPartNumber + fromPathPiece = fmap (review _ExamPartNumber) . fromPathPiece + +instance ToMarkup ExamPartNumber where + toMarkup = toMarkup . view _ExamPartNumber + +pathPieceCsv ''ExamPartNumber +pathPieceJSON ''ExamPartNumber +pathPieceJSONKey ''ExamPartNumber + +instance Enum ExamPartNumber where + toEnum = review _ExamPartNumber' . toEnum + fromEnum = maybe (error "Converting non-numeric ExamPartNumber to Int") fromEnum . preview _ExamPartNumber' diff --git a/src/Utils.hs b/src/Utils.hs index e3201af90..a02ec0a65 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -962,3 +962,21 @@ type DictMaybe constr a = Maybe (Dict constr, a) pattern DictJust :: constr => a -> DictMaybe constr a pattern DictJust a = Just (Dict, a) + +------------- +-- Ord -- +------------- + +clamp :: Ord a + => a -- ^ Minimum + -> a -- ^ Maximum + -> a -- ^ Value + -> a -- ^ Clamped Value +clamp minVal maxVal = clampMin minVal . clampMax maxVal + +clampMin, clampMax :: Ord a + => a -- ^ Boundary + -> a -- ^ Value + -> a -- ^ Clamped Value +clampMin minVal = max minVal +clampMax maxVal = min maxVal diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 412e2527f..95e0c4236 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -26,6 +26,12 @@ emptyOrIn criterion testSet entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty +getJustBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record)) + => Unique record -> ReaderT backend m (Entity record) +getJustBy u = getBy u >>= maybe + (throwM . PersistForeignConstraintUnmet $ tshow u) + return + getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m) => Unique record -> ReaderT backend m (Maybe (Key record)) getKeyBy u = fmap entityKey <$> getBy u -- TODO optimize this, so that DB does not deliver entire record! diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index b7dc95ef0..1da95cd38 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -167,6 +167,8 @@ makeLenses_ ''Invitation makeLenses_ ''ExamBonusRule makeLenses_ ''ExamGradingRule makeLenses_ ''ExamResult +makeLenses_ ''ExamPart +makeLenses_ ''ExamPartResult makeLenses_ ''UTCTime diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index 4602c9184..07d6b0c40 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -138,24 +138,30 @@ $if gradingShown && not (null examParts) + - $forall Entity partId ExamPart{examPartName, examPartWeight, examPartMaxPoints} <- examParts + $forall Entity partId ExamPart{examPartNumber, examPartName, examPartWeight, examPartMaxPoints} <- examParts +
_{MsgExamPartNumber} _{MsgExamPartName} - _{MsgExamPartMaxPoints} - _{MsgExamPartResultPoints} + $if showMaxPoints + _{MsgExamPartMaxPoints} + $if showAchievedPoints + _{MsgExamPartResultPoints}
#{examPartNumber} #{examPartName} - - $maybe mPoints <- examPartMaxPoints - #{showFixed True (fromRational examPartWeight * mPoints)} - - $case fmap (examPartResultResult . entityVal) (results !? partId) - $of Nothing - $of Just (ExamAttended ps) - #{showFixed True ps} - $of Just ExamNoShow - _{MsgExamNoShow} - $of Just ExamVoided - _{MsgExamVoided} + $if showMaxPoints + + $maybe mPoints <- examPartMaxPoints + #{showFixed True (fromRational examPartWeight * mPoints)} + $if showAchievedPoints + + $case fmap (examPartResultResult . entityVal) (results !? partId) + $of Nothing + $of Just (ExamAttended ps) + #{showFixed True ps} + $of Just ExamNoShow + _{MsgExamNoShow} + $of Just ExamVoided + _{MsgExamVoided} $# TODO: Statistics diff --git a/templates/widgets/massinput/examParts/form.hamlet b/templates/widgets/massinput/examParts/form.hamlet index 0ef5c4f7a..5b0b0e9a1 100644 --- a/templates/widgets/massinput/examParts/form.hamlet +++ b/templates/widgets/massinput/examParts/form.hamlet @@ -1,4 +1,5 @@ $newline never -#{csrf}^{fvInput epfIdView}^{fvInput epfNameView} +#{csrf}^{fvInput epfIdView}^{fvInput epfNumberView} +^{fvInput epfNameView} ^{fvInput epfMaxPointsView} ^{fvInput epfWeightView} diff --git a/templates/widgets/massinput/examParts/layout.hamlet b/templates/widgets/massinput/examParts/layout.hamlet index 87ab7fef4..1a89a8a11 100644 --- a/templates/widgets/massinput/examParts/layout.hamlet +++ b/templates/widgets/massinput/examParts/layout.hamlet @@ -1,10 +1,27 @@ $newline never - + + $forall coord <- review liveCoords lLength diff --git a/templates/widgets/massinput/examRooms/layout.hamlet b/templates/widgets/massinput/examRooms/layout.hamlet index c8a4bf270..8bd82ae6e 100644 --- a/templates/widgets/massinput/examRooms/layout.hamlet +++ b/templates/widgets/massinput/examRooms/layout.hamlet @@ -1,13 +1,22 @@ $newline never
_{MsgExamPartName} - _{MsgExamPartMaxPoints} - _{MsgExamPartWeight} - +
+ _{MsgExamPartNumber} # + + + _{MsgExamPartName} # + + _{MsgExamPartMaxPoints} + + _{MsgExamPartWeight} # + + +
+ _{MsgExamPartNumberTip} + + _{MsgExamPartNameTip} + + + _{MsgExamPartWeightTip} +
- + $forall coord <- review liveCoords lLength From 014a17a3be8811586caea5d9f178c5cd318fae29 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 18 Sep 2019 11:45:08 +0200 Subject: [PATCH 02/28] feat(exams): refine exam form --- messages/uniworx/de.msg | 19 ++++++++++++------- models/exams | 6 +++--- src/Handler/Exam/Form.hs | 16 ++++++++-------- src/Handler/Utils/Exam.hs | 4 ++-- src/Handler/Utils/Form.hs | 23 +++++------------------ src/Model/Migration.hs | 14 ++++++++++++++ src/Model/Types/Exam.hs | 30 ++++++++++++++++++------------ templates/exam-show.hamlet | 25 ++++++++++++------------- templates/widgets/bonusRule.hamlet | 2 -- test/Database.hs | 25 +++++++++++++++++++++++++ 10 files changed, 99 insertions(+), 65 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 9e433582a..7a9622a87 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1329,17 +1329,20 @@ ExamClosedTip: Prüfungsämter, die im System Noten einsehen, werden zu diesem Z ExamShowGrades: Klausur ist benotet ExamShowGradesTip: Sollen genaue Noten angezeigt werden, oder sollen Teilnehmer und Prüfungsämter nur informiert werden, ob die Klausur bestanden wurde? ExamPublicStatistics: Statistik veröffentlichen -ExamPublicStatisticsTip: Soll die statistische Auswertung auch den Teilnehmern angezeigt werden, sobald diese ihre Noten einsehen können? +ExamPublicStatisticsTip: Soll die automatisch berechnete statistische Auswertung auch den Teilnehmern angezeigt werden, sobald diese ihre Noten einsehen können? +ExamAutomaticGrading: Automatische Notenberechnung +ExamAutomaticGradingTip: Sollen die Gesamtleistungen der Teilnehmer automatisch aus den in den einzelnen Teilprüfungen erreichten Leistungen berechnet werden? Etwaige Bonuspunkte werden dabei berücksichtigt. Manuelles Überschreiben der Gesamtleistung ist dennoch möglich. ExamGradingRule: Notenberechnung ExamGradingManual': Keine automatische Berechnung ExamGradingKey': Nach Schlüssel ExamGradingKey: Notenschlüssel -ExamGradingKeyTip: Die Grenzen beziehen sich auf die effektive Maximalpunktzahl, nachdem etwaige Bonuspunkte aus dem Übungsbetrieb angerechnet und die Ergebnise der Teilaufgaben mit ihrem Gewicht multipliziert wurden +ExamGradingKeyTip: Die Grenzen beziehen sich auf die effektive Maximalpunktzahl, nachdem etwaige Bonuspunkte aus dem Übungsbetrieb angerechnet und die Ergebnise der Teilprüfungen mit ihrem Gewicht multipliziert wurden Points: Punkte PointsMustBeNonNegative: Punktegrenzen dürfen nicht negativ sein PointsMustBeMonotonic: Punktegrenzen müssen aufsteigend sein GradingFrom: Ab ExamNew: Neue Prüfung +ExamBonus: Bonuspunkte-System ExamBonusRule: Prüfungsbonus aus Übungsbetrieb ExamNoBonus': Kein automatischer Bonus ExamBonusPoints': Umrechnung von Übungspunkten @@ -1350,7 +1353,9 @@ ExamBonusMaxPoints: Maximal erreichbare Prüfungs-Bonuspunkte ExamBonusMaxPointsNonPositive: Maximaler Prüfungsbonus muss positiv und größer null sein ExamBonusOnlyPassed: Bonus nur nach Bestehen anrechnen -ExamOccurrenceRule: Automatische Termin- bzw. Raumzuteilung +ExamAutomaticOccurrenceAssignment: Automatische Termin- bzw. Raumzuteilung +ExamAutomaticOccurrenceAssignmentTip: Sollen Prüfungsteilnehmer zum Zeitpunkt der Bekanntgabe der Raum- bzw. Terminzuteilung automatisch auf die zur Verfügung stehenden Räume bzw. Termine verteilt werden? Manuelle Umverteilung bzw. vorheriges Festlegen von Zuteilungen einzelner Teilnehmer ist trotzdem möglich. +ExamOccurrenceRule: Verfahren ExamOccurrenceRuleParticipant: Termin- bzw. Raumzuteilungsverfahren ExamRoomManual': Keine automatische Zuteilung ExamRoomSurname': Nach Nachname @@ -1384,9 +1389,9 @@ ExamFormParts: Teile ExamCorrectors: Korrektoren ExamCorrectorAlreadyAdded: Ein Korrektor mit dieser E-Mail ist bereits für diese Prüfung eingetragen -ExamParts: Teilaufgaben -ExamPartWeightNegative: Gewicht aller Teilaufgaben muss größer oder gleich Null sein -ExamPartAlreadyExists: Teilaufgabe mit diesem Namen existiert bereits +ExamParts: Teilprüfungen/Aufgaben +ExamPartWeightNegative: Gewicht aller Teilprüfungen muss größer oder gleich Null sein +ExamPartAlreadyExists: Teilprüfunge mit diesem Namen existiert bereits ExamPartNumber: Nummer ExamPartNumberTip: Wird als interne Bezeichnung z.B. bei CSV-Export verwendet ExamPartName: Name @@ -1524,7 +1529,7 @@ ExamUserCsvDeregister: Teilnehmer von der Prüfung abmelden ExamUserCsvSetCourseField: Kurs-assoziiertes Studienfach ändern ExamUserCsvOverrideResult: Ergebnis entgegen automatischer Notenberechnung überschreiben ExamUserCsvSetResult: Ergebnis eintragen -ExamUserCsvSetPartResult: Ergebnis einer Teilaufgabe eintragen +ExamUserCsvSetPartResult: Ergebnis einer Teilprüfung eintragen ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht diff --git a/models/exams b/models/exams index bcd6703c8..22c34cc5b 100644 --- a/models/exams +++ b/models/exams @@ -1,9 +1,9 @@ Exam course CourseId name ExamName - gradingRule ExamGradingRule - bonusRule ExamBonusRule - occurrenceRule ExamOccurrenceRule + gradingRule ExamGradingRule Maybe + bonusRule ExamBonusRule Maybe + occurrenceRule ExamOccurrenceRule Maybe visibleFrom UTCTime Maybe registerFrom UTCTime Maybe registerTo UTCTime Maybe diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 38213c7ed..ba1e2af6a 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -26,6 +26,7 @@ import Text.Blaze.Html.Renderer.String (renderHtml) data ExamForm = ExamForm { efName :: ExamName , efDescription :: Maybe Html + , efShowGrades :: Bool , efStart :: Maybe UTCTime , efEnd :: Maybe UTCTime , efVisibleFrom :: Maybe UTCTime @@ -35,11 +36,10 @@ data ExamForm = ExamForm , efPublishOccurrenceAssignments :: Maybe UTCTime , efFinished :: Maybe UTCTime , efOccurrences :: Set ExamOccurrenceForm - , efShowGrades :: Bool , efPublicStatistics :: Bool - , efGradingRule :: ExamGradingRule - , efBonusRule :: ExamBonusRule - , efOccurrenceRule :: ExamOccurrenceRule + , efGradingRule :: Maybe ExamGradingRule + , efBonusRule :: Maybe ExamBonusRule + , efOccurrenceRule :: Maybe ExamOccurrenceRule , efCorrectors :: Set (Either UserEmail UserId) , efExamParts :: Set ExamPartForm } @@ -80,6 +80,7 @@ examForm template html = do flip (renderAForm FormStandard) html $ ExamForm <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template) <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template)) + <*> apopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (efShowGrades <$> template <|> Just True) <* aformSection MsgExamFormTimes <*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template) <*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template) @@ -92,11 +93,10 @@ examForm template html = do <* aformSection MsgExamFormOccurrences <*> examOccurrenceForm (efOccurrences <$> template) <* aformSection MsgExamFormAutomaticFunctions - <*> apopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (efShowGrades <$> template <|> Just True) <*> apopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (efPublicStatistics <$> template <|> Just True) - <*> examGradingRuleForm (efGradingRule <$> template) - <*> examBonusRuleForm (efBonusRule <$> template) - <*> examOccurrenceRuleForm (efOccurrenceRule <$> template) + <*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template) + <*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template) + <*> optionalActionA (examOccurrenceRuleForm $ efOccurrenceRule =<< template) (fslI MsgExamAutomaticOccurrenceAssignment & setTooltip MsgExamAutomaticOccurrenceAssignmentTip) (is _Just . efOccurrenceRule <$> template) <* aformSection MsgExamFormCorrection <*> examCorrectorsForm (efCorrectors <$> template) <* aformSection MsgExamFormParts diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 11d1fb446..dae79f3eb 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -103,7 +103,7 @@ examGrade (Entity _ Exam{..}) bonusPossible bonusAchieved (otoList -> results) withBonus :: Points -> Points withBonus ps - | ExamBonusPoints{..} <- examBonusRule + | Just ExamBonusPoints{..} <- examBonusRule = if | not bonusOnlyPassed || fmap (view passingGrade) (pointsToGrade ps) == Just (_Wrapped # True) @@ -126,7 +126,7 @@ examGrade (Entity _ Exam{..}) bonusPossible bonusAchieved (otoList -> results) pointsToGrade :: Points -> Maybe ExamGrade pointsToGrade ps - | ExamGradingKey{..} <- examGradingRule + | Just ExamGradingKey{..} <- examGradingRule = Just $ gradeFromKey examGradingKey | otherwise = Nothing diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 20d04f535..ab8ede956 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -518,8 +518,7 @@ submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ c ) ] -data ExamBonusRule' = ExamNoBonus' - | ExamBonusPoints' +data ExamBonusRule' = ExamBonusPoints' deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ExamBonusRule' instance Finite ExamBonusRule' @@ -529,7 +528,6 @@ embedRenderMessage ''UniWorX ''ExamBonusRule' id classifyBonusRule :: ExamBonusRule -> ExamBonusRule' classifyBonusRule = \case - ExamNoBonus -> ExamNoBonus' ExamBonusPoints{} -> ExamBonusPoints' examBonusRuleForm :: Maybe ExamBonusRule -> AForm Handler ExamBonusRule @@ -537,18 +535,14 @@ examBonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classify where actions :: Map ExamBonusRule' (AForm Handler ExamBonusRule) actions = Map.fromList - [ ( ExamNoBonus' - , pure ExamNoBonus - ) - , ( ExamBonusPoints' + [ ( ExamBonusPoints' , ExamBonusPoints <$> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints) (preview _bonusMaxPoints =<< prev) <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev)) ) ] -data ExamOccurrenceRule' = ExamRoomManual' - | ExamRoomSurname' +data ExamOccurrenceRule' = ExamRoomSurname' | ExamRoomMatriculation' | ExamRoomRandom' deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) @@ -560,7 +554,6 @@ embedRenderMessage ''UniWorX ''ExamOccurrenceRule' id classifyExamOccurrenceRule :: ExamOccurrenceRule -> ExamOccurrenceRule' classifyExamOccurrenceRule = \case - ExamRoomManual -> ExamRoomManual' ExamRoomSurname -> ExamRoomSurname' ExamRoomMatriculation -> ExamRoomMatriculation' ExamRoomRandom -> ExamRoomRandom' @@ -569,13 +562,11 @@ examOccurrenceRuleForm :: Maybe ExamOccurrenceRule -> AForm Handler ExamOccurren examOccurrenceRuleForm = fmap reverseClassify . areq (selectField optionsFinite) (fslI MsgExamOccurrenceRule) . fmap classifyExamOccurrenceRule where reverseClassify = \case - ExamRoomManual' -> ExamRoomManual ExamRoomSurname' -> ExamRoomSurname ExamRoomMatriculation' -> ExamRoomMatriculation ExamRoomRandom' -> ExamRoomRandom -data ExamGradingRule' = ExamGradingManual' - | ExamGradingKey' +data ExamGradingRule' = ExamGradingKey' deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ExamGradingRule' instance Finite ExamGradingRule' @@ -585,7 +576,6 @@ embedRenderMessage ''UniWorX ''ExamGradingRule' id classifyExamGradingRule :: ExamGradingRule -> ExamGradingRule' classifyExamGradingRule = \case - ExamGradingManual -> ExamGradingManual' ExamGradingKey{} -> ExamGradingKey' examGradingRuleForm :: Maybe ExamGradingRule -> AForm Handler ExamGradingRule @@ -593,10 +583,7 @@ examGradingRuleForm prev = multiActionA actions (fslI MsgExamGradingRule) $ clas where actions :: Map ExamGradingRule' (AForm Handler ExamGradingRule) actions = Map.fromList - [ ( ExamGradingManual' - , pure ExamGradingManual - ) - , ( ExamGradingKey' + [ ( ExamGradingKey' , ExamGradingKey <$> gradingKeyForm (fslI MsgExamGradingKey & setTooltip MsgExamGradingKeyTip) (preview _examGradingKey =<< prev) ) ] diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index eab6af88a..f0f190a79 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -523,6 +523,20 @@ customMigrations = Map.fromListWith (>>) renameExamParts _ = return () runConduit $ getExamEntries .| C.mapM_ renameExamParts ) + , ( AppliedMigrationKey [migrationVersion|21.0.0|] [version|22.0.0|] + , whenM (tableExists "exam") $ + [executeQQ| + ALTER TABLE "exam" ALTER COLUMN "grading_rule" DROP NOT NULL; + ALTER TABLE "exam" ALTER COLUMN "bonus_rule" DROP NOT NULL; + ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" DROP NOT NULL; + + UPDATE "exam" SET "grading_rule" = NULL WHERE "grading_rule" = '{ "rule": "manual" }'; + UPDATE "exam" SET "bonus_rule" = NULL WHERE "bonus_rule" = '{ "rule": "no-bonus"}'; + UPDATE "exam" SET "occurrence_rule" = NULL WHERE "occurrence_rule" = '"manual"'; + + UPDATE "exam" SET "occurrence_rule" = json_build_object('rule', "occurrence_rule"); + |] + ) ] diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index fc92e3f58..be8e0bf95 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -116,28 +116,32 @@ instance Universe res => Universe (ExamResult' res) where instance Finite res => Finite (ExamResult' res) -data ExamBonusRule = ExamNoBonus - | ExamBonusPoints +data ExamBonusRule = ExamBonusPoints { bonusMaxPoints :: Points , bonusOnlyPassed :: Bool } deriving (Show, Read, Eq, Ord, Generic, Typeable) deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - , fieldLabelModifier = camelToPathPiece' 1 + { fieldLabelModifier = camelToPathPiece' 1 + , constructorTagModifier = camelToPathPiece' 1 + , allNullaryToStringTag = False , sumEncoding = TaggedObject "rule" "settings" + , unwrapUnaryRecords = False + , tagSingleConstructors = True } ''ExamBonusRule derivePersistFieldJSON ''ExamBonusRule -data ExamOccurrenceRule = ExamRoomManual - | ExamRoomSurname +data ExamOccurrenceRule = ExamRoomSurname | ExamRoomMatriculation | ExamRoomRandom deriving (Show, Read, Eq, Ord, Generic, Typeable) deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 2 - , fieldLabelModifier = camelToPathPiece' 1 + { fieldLabelModifier = camelToPathPiece' 1 + , constructorTagModifier = camelToPathPiece' 2 + , allNullaryToStringTag = False , sumEncoding = TaggedObject "rule" "settings" + , unwrapUnaryRecords = False + , tagSingleConstructors = True } ''ExamOccurrenceRule derivePersistFieldJSON ''ExamOccurrenceRule @@ -211,15 +215,17 @@ instance PersistFieldSql ExamGrade where data ExamGradingRule - = ExamGradingManual - | ExamGradingKey + = ExamGradingKey { examGradingKey :: [Points] -- ^ @[n1, n2, n3, ..., n11]@ means @0 <= p < n1 -> p ~= 5@, @n1 <= p < n2 -> p ~ 4@, @n2 <= p < n3 -> p ~ 3.7@, ..., @n10 <= p -> p ~ 1.0@ } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 2 - , fieldLabelModifier = camelToPathPiece' 2 + { fieldLabelModifier = camelToPathPiece' 2 + , constructorTagModifier = camelToPathPiece' 2 + , allNullaryToStringTag = False , sumEncoding = TaggedObject "rule" "settings" + , unwrapUnaryRecords = False + , tagSingleConstructors = True } ''ExamGradingRule derivePersistFieldJSON ''ExamGradingRule diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index 07d6b0c40..f10bdd908 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -59,31 +59,30 @@ $maybe desc <- examDescription
_{MsgExamClosed}
^{formatTimeW SelFormatDateTime closed} $if gradingShown - $if examGradingRule /= ExamGradingManual + $maybe gradingRule <- examGradingRule
_{MsgExamGradingRule} $if not gradingVisible \ ^{isVisible False}
- $case examGradingRule - $of ExamGradingManual - _{MsgExamGradingManual'} + $case gradingRule $of ExamGradingKey{..} ^{gradingKeyW examGradingKey} - $if examBonusRule /= ExamNoBonus + $maybe bonusRule <- examBonusRule
_{MsgExamBonusRule} $if not gradingVisible \ ^{isVisible False}
- ^{examBonusW examBonusRule} - $if occurrenceAssignmentsShown -
- _{MsgExamOccurrenceRuleParticipant} - $if not occurrenceAssignmentsVisible - \ ^{isVisible False} -
- _{classifyExamOccurrenceRule examOccurrenceRule} + ^{examBonusW bonusRule} + $maybe occurrenceRule <- examOccurrenceRule + $if occurrenceAssignmentsShown +
+ _{MsgExamOccurrenceRuleParticipant} + $if not occurrenceAssignmentsVisible + \ ^{isVisible False} +
+ _{classifyExamOccurrenceRule occurrenceRule} $maybe registerWdgt <- registerWidget
_{MsgExamRegistration}
^{registerWdgt} diff --git a/templates/widgets/bonusRule.hamlet b/templates/widgets/bonusRule.hamlet index bf72b1684..9c010d735 100644 --- a/templates/widgets/bonusRule.hamlet +++ b/templates/widgets/bonusRule.hamlet @@ -1,7 +1,5 @@ $newline never $case bonusRule - $of ExamNoBonus - _{MsgExamNoBonus'} $of ExamBonusPoints ps False _{MsgExamBonusPoints ps} $of ExamBonusPoints ps True diff --git a/test/Database.hs b/test/Database.hs index 280bcead3..312dcbbe0 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -467,6 +467,31 @@ fillDb = do ,(tinaTester, Just sfTTc) ] + examFFP <- insert' $ Exam + { examCourse = ffp + , examName = "Klausur" + , examGradingRule = Nothing + , examBonusRule = Nothing + , examOccurrenceRule = Nothing + , examVisibleFrom = Just now + , examRegisterFrom = Just now + , examRegisterTo = Just $ addUTCTime (14 * nominalDay) now + , examDeregisterUntil = Just $ addUTCTime (15 * nominalDay) now + , examPublishOccurrenceAssignments = Just $ addUTCTime (15 * nominalDay) now + , examStart = Just $ addUTCTime (16 * nominalDay) now + , examEnd = Just $ addUTCTime (17 * nominalDay) now + , examFinished = Just $ addUTCTime (21 * nominalDay) now + , examClosed = Nothing + , examPublicStatistics = True + , examShowGrades = True + , examDescription = Nothing + } + void . insertMany $ map (\u -> ExamRegistration examFFP u Nothing now) + [ fhamann + , maxMuster + , tinaTester + ] + -- EIP eip <- insert' Course { courseName = "Einführung in die Programmierung" From 459a773148890b416da717cd8dc50584fa0b3fd1 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 18 Sep 2019 11:45:20 +0200 Subject: [PATCH 03/28] chore: improve clean.sh --- clean.sh | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/clean.sh b/clean.sh index 2b9f5bfc7..02487e8b2 100755 --- a/clean.sh +++ b/clean.sh @@ -10,6 +10,8 @@ case $1 in ;; *) target=".stack-work-${1}" + shift + if [[ ! -d "${target}" ]]; then printf "%s does not exist or is no directory\n" "${target}" >&2 exit 1 @@ -20,7 +22,11 @@ case $1 in fi move-back() { - mv -v .stack-work "${target}" + if [[ -d .stack-work ]]; then + mv -v .stack-work "${target}" + else + mkdir -v "${target}" + fi [[ -d .stack-work-clean ]] && mv -v .stack-work-clean .stack-work } @@ -28,6 +34,9 @@ case $1 in mv -v "${target}" .stack-work trap move-back EXIT - stack clean + ( + set -ex + stack clean $@ + ) ;; esac From fb1e42dc6994e79692f38b93a14eeaaaf9d53578 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 18 Sep 2019 11:46:01 +0200 Subject: [PATCH 04/28] fix: typo --- messages/uniworx/de.msg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 7a9622a87..5a89c8133 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1391,7 +1391,7 @@ ExamCorrectorAlreadyAdded: Ein Korrektor mit dieser E-Mail ist bereits für dies ExamParts: Teilprüfungen/Aufgaben ExamPartWeightNegative: Gewicht aller Teilprüfungen muss größer oder gleich Null sein -ExamPartAlreadyExists: Teilprüfunge mit diesem Namen existiert bereits +ExamPartAlreadyExists: Teilprüfung mit diesem Namen existiert bereits ExamPartNumber: Nummer ExamPartNumberTip: Wird als interne Bezeichnung z.B. bei CSV-Export verwendet ExamPartName: Name From ea5a398bab2ca0a63af06e167129c2656e887c74 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 18 Sep 2019 17:17:18 +0200 Subject: [PATCH 05/28] feat(exams): automatically compute examResults BREAKING CHANGE: examPartName no longer required --- messages/uniworx/de.msg | 9 +- models/exams | 10 +- src/Audit/Types.hs | 9 + src/Handler/Exam/Form.hs | 7 +- src/Handler/Exam/Show.hs | 10 +- src/Handler/Exam/Users.hs | 325 +++++++++++++----- src/Handler/Utils/Exam.hs | 69 ++-- src/Utils.hs | 3 +- src/Utils/Lens.hs | 1 + templates/corrections-overview.hamlet | 9 +- templates/default-layout.lucius | 29 +- templates/exam-show.hamlet | 20 +- .../widgets/massinput/examParts/layout.hamlet | 4 +- 13 files changed, 361 insertions(+), 144 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 5a89c8133..3651476cc 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1347,6 +1347,8 @@ ExamBonusRule: Prüfungsbonus aus Übungsbetrieb ExamNoBonus': Kein automatischer Bonus ExamBonusPoints': Umrechnung von Übungspunkten +ExamBonusAchieved: Bonuspunkte + ExamEditHeading examn@ExamName: #{examn} bearbeiten ExamBonusMaxPoints: Maximal erreichbare Prüfungs-Bonuspunkte @@ -1393,8 +1395,9 @@ ExamParts: Teilprüfungen/Aufgaben ExamPartWeightNegative: Gewicht aller Teilprüfungen muss größer oder gleich Null sein ExamPartAlreadyExists: Teilprüfung mit diesem Namen existiert bereits ExamPartNumber: Nummer +ExamPartNumbered examPartNumber@ExamPartNumber: Teil #{view _ExamPartNumber examPartNumber} ExamPartNumberTip: Wird als interne Bezeichnung z.B. bei CSV-Export verwendet -ExamPartName: Name +ExamPartName: Titel ExamPartNameTip: Wird den Studierenden angezeigt ExamPartMaxPoints: Maximalpunktzahl ExamPartWeight: Gewichtung @@ -1496,6 +1499,7 @@ CsvColumnExamUserExercisePoints: Anzahl von Punkten, die der Teilnehmer im Übun CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb bis zu seinem Prüfungstermin erreichen hätte können CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer bestanden hat CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Prüfungstermin bestehen hätte können +CsvColumnExamUserBonus: Anzurechnende Bonuspunkte CsvColumnExamUserResult: Erreichte Prüfungsleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0") CsvColumnExamUserCourseNote: Notizen zum Teilnehmer @@ -1527,10 +1531,13 @@ ExamUserCsvRegister: Kursteilnehmer zur Prüfung anmelden ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen ExamUserCsvDeregister: Teilnehmer von der Prüfung abmelden ExamUserCsvSetCourseField: Kurs-assoziiertes Studienfach ändern +ExamUserCsvOverrideBonus: Bonuspunkte entgegen Bonusregelung überschreiben ExamUserCsvOverrideResult: Ergebnis entgegen automatischer Notenberechnung überschreiben +ExamUserCsvSetBonus: Bonuspunkte eintragen ExamUserCsvSetResult: Ergebnis eintragen ExamUserCsvSetPartResult: Ergebnis einer Teilprüfung eintragen ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen +ExamBonusNone: Keine Bonuspunkte ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht diff --git a/models/exams b/models/exams index 22c34cc5b..7eff47789 100644 --- a/models/exams +++ b/models/exams @@ -20,11 +20,11 @@ Exam ExamPart exam ExamId number ExamPartNumber - name ExamPartName + name ExamPartName Maybe maxPoints Points Maybe weight Rational UniqueExamPartNumber exam number - UniqueExamPartName exam name + UniqueExamPartName exam name !force ExamOccurrence exam ExamId name ExamOccurrenceName @@ -46,6 +46,12 @@ ExamPartResult result ExamResultPoints lastChanged UTCTime default=now() UniqueExamPartResult examPart user +ExamBonus + exam ExamId + user UserId + bonus Points + lastChanged UTCTime default=now() + UniqueExamBonus exam user ExamResult exam ExamId user UserId diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 994f74357..5b835a722 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -33,6 +33,15 @@ data Transaction , transactionUser :: UserId } + | TransactionExamBonusEdit + { transactionExam :: ExamId + , transactionUser :: UserId + } + | TransactionExamBonusDeleted + { transactionExam :: ExamId + , transactionUser :: UserId + } + | TransactionExamResultEdit { transactionExam :: ExamId , transactionUser :: UserId diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index ba1e2af6a..c0b1c87a1 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -57,7 +57,7 @@ data ExamOccurrenceForm = ExamOccurrenceForm data ExamPartForm = ExamPartForm { epfId :: Maybe CryptoUUIDExamPart , epfNumber :: ExamPartNumber - , epfName :: ExamPartName + , epfName :: Maybe ExamPartName , epfMaxPoints :: Maybe Points , epfWeight :: Rational } deriving (Read, Show, Eq, Ord, Generic, Typeable) @@ -202,7 +202,7 @@ examPartsForm prev = wFormToAForm $ do examPartForm' nudge mPrev csrf = do (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev) (epfNumberRes, epfNumberView) <- mpreq (isoField (from _ExamPartNumber) $ textField & cfStrip & cfCI) ("" & addName (nudge "number") & addPlaceholder "1, 6a, 3.1.4, ...") (epfNumber <$> mPrev) - (epfNameRes, epfNameView) <- mpreq (textField & cfStrip & cfCI) ("" & addName (nudge "name")) (epfName <$> mPrev) + (epfNameRes, epfNameView) <- mopt (textField & cfStrip & cfCI) ("" & addName (nudge "name")) (epfName <$> mPrev) (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev) (epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1) @@ -220,7 +220,8 @@ examPartsForm prev = wFormToAForm $ do (res, formWidget) <- examPartForm' nudge Nothing csrf let addRes = res <&> \newDat (Set.fromList -> oldDat) -> if - | any (((==) `on` epfName) newDat) oldDat -> FormFailure [mr MsgExamPartAlreadyExists] + | any (\old -> fromMaybe False $ (==) <$> epfName newDat <*> epfName old) oldDat + -> FormFailure [mr MsgExamPartAlreadyExists] | otherwise -> FormSuccess $ pure newDat return (addRes, $(widgetFile "widgets/massinput/examParts/add")) miCell' nudge dat = examPartForm' nudge (Just dat) diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index eceeecc1c..5f739d075 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -22,7 +22,7 @@ getEShowR tid ssh csh examn = do cTime <- liftIO getCurrentTime mUid <- maybeAuthId - (Entity _ Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do + (Entity _ Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), lecturerInfoShown) <- runDB $ do exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn let examVisible = NTop (Just cTime) >= NTop examVisibleFrom @@ -62,9 +62,13 @@ getEShowR tid ssh csh examn = do registered <- for mUid $ existsBy . UniqueExamRegistration eId mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True - occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR + lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR - return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) + return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), lecturerInfoShown) + + let occurrenceNamesShown = lecturerInfoShown + partNumbersShown = lecturerInfoShown + examClosedShown = lecturerInfoShown let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences registerWidget diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index fa087816e..ba71c331c 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -48,6 +48,7 @@ type ExamUserTableExpr = ( E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)) ) ) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamBonus)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) type ExamUserTableData = DBRow ( Entity ExamRegistration @@ -56,6 +57,7 @@ type ExamUserTableData = DBRow ( Entity ExamRegistration , Maybe (Entity StudyFeatures) , Maybe (Entity StudyDegree) , Maybe (Entity StudyTerms) + , Maybe (Entity ExamBonus) , Maybe (Entity ExamResult) , Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)) , Maybe (Entity CourseUserNote) @@ -71,28 +73,51 @@ _userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence)) _userTableOccurrence = _dbrOutput . _3 queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 5 1) - -queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) -queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3) +queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 6 1) queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration) -queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 5 1) +queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 6 1) queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence)) -queryExamOccurrence = $(sqlLOJproj 5 2) +queryExamOccurrence = $(sqlLOJproj 6 2) + +queryCourseParticipant :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseParticipant)) +queryCourseParticipant = $(sqlLOJproj 2 1) . $(sqlLOJproj 6 3) + +queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) +queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3) queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) -queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3) +queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3) queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms)) -queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3) +queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3) + +queryExamBonus :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamBonus)) +queryExamBonus = $(sqlLOJproj 6 4) queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult)) -queryExamResult = $(sqlLOJproj 5 4) +queryExamResult = $(sqlLOJproj 6 5) queryCourseNote :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote)) -queryCourseNote = $(sqlLOJproj 5 5) +queryCourseNote = $(sqlLOJproj 6 6) + +queryExamPart :: forall a. + PersistField a + => ExamPartId + -> (E.SqlExpr (Entity ExamPart) -> E.SqlExpr (Maybe (Entity ExamPartResult)) -> E.SqlQuery (E.SqlExpr (E.Value a))) + -> ExamUserTableExpr + -> E.SqlExpr (E.Value a) +queryExamPart epId cont inp = E.sub_select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> flip runReaderT inp $ do + examRegistration <- asks queryExamRegistration + + lift $ do + E.on $ E.just (examPart E.^. ExamPartId) E.==. examPartResult E.?. ExamPartResultExamPart + E.&&. examPartResult E.?. ExamPartResultUser E.==. E.just (examRegistration E.^. ExamRegistrationUser) + E.where_ $ examPart E.^. ExamPartExam E.==. examRegistration E.^. ExamRegistrationExam + E.&&. examPart E.^. ExamPartId E.==. E.val epId + + cont examPart examPartResult resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration) resultExamRegistration = _dbrOutput . _1 @@ -112,23 +137,36 @@ resultStudyField = _dbrOutput . _6 . _Just resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence) resultExamOccurrence = _dbrOutput . _3 . _Just +resultExamBonus :: Traversal' ExamUserTableData (Entity ExamBonus) +resultExamBonus = _dbrOutput . _7 . _Just + resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult) -resultExamResult = _dbrOutput . _7 . _Just +resultExamResult = _dbrOutput . _8 . _Just resultExamParts :: IndexedTraversal' ExamPartId ExamUserTableData (ExamPart, Maybe (Entity ExamPartResult)) -resultExamParts = _dbrOutput . _8 . itraversed +resultExamParts = _dbrOutput . _9 . itraversed -- resultExamParts' :: Traversal' ExamUserTableData (Entity ExamPart) -- resultExamParts' = (resultExamParts <. _1) . withIndex . from _Entity --- resultExamPartResult :: ExamPartId -> Lens' ExamUserTableData (Maybe (Entity ExamPartResult)) --- resultExamPartResult epId = _dbrOutput . _8 . unsafeSingular (ix epId) . _2 +resultExamPartResult :: ExamPartId -> Lens' ExamUserTableData (Maybe (Entity ExamPartResult)) +resultExamPartResult epId = _dbrOutput . _9 . unsafeSingular (ix epId) . _2 --- resultExamPartResults :: IndexedTraversal' ExamPartId ExamUserTableData (Maybe (Entity ExamPartResult)) --- resultExamPartResults = resultExamParts <. _2 +resultExamPartResults :: IndexedTraversal' ExamPartId ExamUserTableData (Maybe (Entity ExamPartResult)) +resultExamPartResults = resultExamParts <. _2 resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote) -resultCourseNote = _dbrOutput . _9 . _Just +resultCourseNote = _dbrOutput . _10 . _Just + + +resultAutomaticExamBonus :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData Points +resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> examResultBonus <$> examBonusRule exam <*> examBonusPossible uid examBonus' <*> examBonusAchieved uid examBonus') + +resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultGrade +resultAutomaticExamResult exam examBonus' = folding . runReader $ do + parts' <- asks $ sequence . toListOf (resultExamPartResults . to (^? _Just . _entityVal . _examPartResultResult)) + bonus <- preview $ resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus exam examBonus' + return $ examGrade exam bonus =<< parts' csvExamPartHeader :: Prism' Csv.Name ExamPartNumber @@ -151,10 +189,11 @@ data ExamUserTableCsv = ExamUserTableCsv , csvEUserDegree :: Maybe Text , csvEUserSemester :: Maybe Int , csvEUserOccurrence :: Maybe (CI Text) - , csvEUserExercisePoints :: Maybe Points - , csvEUserExerciseNumPasses :: Maybe Int - , csvEUserExercisePointsMax :: Maybe Points - , csvEUserExerciseNumPassesMax :: Maybe Int + , csvEUserExercisePoints :: Maybe (Maybe Points) + , csvEUserExerciseNumPasses :: Maybe (Maybe Int) + , csvEUserExercisePointsMax :: Maybe (Maybe Points) + , csvEUserExerciseNumPassesMax :: Maybe (Maybe Int) + , csvEUserBonus :: Maybe (Maybe Points) , csvEUserExamPartResults :: Map ExamPartNumber (Maybe ExamResultPoints) , csvEUserExamResult :: Maybe ExamResultPassedGrade , csvEUserCourseNote :: Maybe Html @@ -172,11 +211,14 @@ instance ToNamedRecord ExamUserTableCsv where , "degree" Csv..= csvEUserDegree , "semester" Csv..= csvEUserSemester , "occurrence" Csv..= csvEUserOccurrence - , "exercise-points" Csv..= csvEUserExercisePoints - , "exercise-num-passes" Csv..= csvEUserExerciseNumPasses - , "exercise-points-max" Csv..= csvEUserExercisePointsMax - , "exercise-num-passes-max" Csv..= csvEUserExerciseNumPassesMax - ] ++ examPartResults ++ + ] ++ catMaybes + [ fmap ("exercise-points" Csv..=) csvEUserExercisePoints + , fmap ("exercise-num-passes" Csv..=) csvEUserExerciseNumPasses + , fmap ("exercise-points-max" Csv..=) csvEUserExercisePointsMax + , fmap ("exercise-num-passes-max" Csv..=) csvEUserExerciseNumPassesMax + , fmap ("bonus" Csv..=) csvEUserBonus + ] + ++ examPartResults ++ [ "exam-result" Csv..= csvEUserExamResult , "course-note" Csv..= csvEUserCourseNote ] @@ -196,10 +238,11 @@ instance FromNamedRecord ExamUserTableCsv where <*> csv .:?? "degree" <*> csv .:?? "semester" <*> csv .:?? "occurrence" - <*> csv .:?? "exercise-points" - <*> csv .:?? "exercise-num-passes" - <*> csv .:?? "exercise-points-max" - <*> csv .:?? "exercise-num-passes-max" + <*> fmap Just (csv .:?? "exercise-points") + <*> fmap Just (csv .:?? "exercise-num-passes") + <*> fmap Just (csv .:?? "exercise-points-max") + <*> fmap Just (csv .:?? "exercise-num-passes-max") + <*> fmap Just (csv .:?? "bonus") <*> examPartResults <*> csv .:?? "exam-result" <*> csv .:?? "course-note" @@ -222,6 +265,7 @@ instance CsvColumnsExplained ExamUserTableCsv where , single "exercise-num-passes" MsgCsvColumnExamUserExercisePasses , single "exercise-points-max" MsgCsvColumnExamUserExercisePointsMax , single "exercise-num-passes-max" MsgCsvColumnExamUserExercisePassesMax + , single "bonus" MsgCsvColumnExamUserBonus , single "exam-result" MsgCsvColumnExamUserResult , single "course-note" MsgCsvColumnExamUserCourseNote ] @@ -232,17 +276,22 @@ instance CsvColumnsExplained ExamUserTableCsv where examUserTableCsvHeader :: ( MonoFoldable mono , Element mono ~ ExamPartNumber ) - => mono -> Csv.Header -examUserTableCsvHeader pNames = Csv.header $ + => SheetGradeSummary -> Bool -> mono -> Csv.Header +examUserTableCsvHeader allBoni doBonus pNames = Csv.header $ [ "surname", "first-name", "name" , "matriculation" , "field", "degree", "semester" , "course-note" , "occurrence" - , "exercise-points", "exercise-num-passes", "exercise-points-max", "exercise-num-passes-max" - ] ++ map (review csvExamPartHeader) (sort $ otoList pNames) ++ + ] ++ bool mempty ["exercise-points", "exercise-points-max"] (doBonus && showPoints) + ++ bool mempty ["exercise-num-passes", "exercise-num-passes-max"] (doBonus && showPasses) + ++ bool mempty ["bonus"] doBonus + ++ map (review csvExamPartHeader) (sort $ otoList pNames) ++ [ "exam-result" ] + where + showPasses = numSheetsPasses allBoni /= 0 + showPoints = getSum (numSheetsPoints allBoni) /= 0 data ExamUserAction = ExamUserDeregister | ExamUserAssignOccurrence @@ -262,6 +311,8 @@ data ExamUserCsvActionClass | ExamUserCsvAssignOccurrence | ExamUserCsvSetCourseField | ExamUserCsvSetPartResult + | ExamUserCsvSetBonus + | ExamUserCsvOverrideBonus | ExamUserCsvSetResult | ExamUserCsvOverrideResult | ExamUserCsvSetCourseNote @@ -295,6 +346,11 @@ data ExamUserCsvAction , examUserCsvActExamPart :: ExamPartNumber , examUserCsvActExamPartResult :: Maybe ExamResultPoints } + | ExamUserCsvSetBonusData + { examUserCsvIsBonusOverride :: Bool + , examUserCsvActUser :: UserId + , examUserCsvActExamBonus :: Maybe Points + } | ExamUserCsvSetResultData { examUserCsvIsResultOverride :: Bool , examUserCsvActUser :: UserId @@ -325,46 +381,88 @@ getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> getEUsersR = postEUsersR postEUsersR tid ssh csh examn = do ((registrationResult, examUsersTable), Entity eId _) <- runDB $ do - exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn + exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName] bonus <- examBonus exam let + allBoni :: SheetGradeSummary allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus - showPasses = numSheetsPasses allBoni /= 0 - showPoints = getSum (numSheetsPoints allBoni) /= 0 + + doBonus = is _Just examGradingRule || is _Just examBonusRule + showPasses = doBonus && numSheetsPasses allBoni /= 0 + showPoints = doBonus && getSum (numSheetsPoints allBoni) /= 0 resultView :: ExamResultGrade -> ExamResultPassedGrade resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades examPartNumbers = examParts ^.. folded . _entityVal . _examPartNumber + resultAutomaticExamBonus' :: Fold ExamUserTableData Points + resultAutomaticExamBonus' = resultAutomaticExamBonus examVal bonus + resultAutomaticExamResult' :: Fold ExamUserTableData ExamResultGrade + resultAutomaticExamResult' = resultAutomaticExamResult examVal bonus + + automaticCell :: forall msg m a r. + ( RenderMessage UniWorX msg + , IsDBTable m a + , Eq msg + ) + => Getting (Endo [Either msg msg]) r (Either msg msg) + -> r + -> DBCell m a + automaticCell l r = case toListOf l r of + [] -> mempty + (Left auto : _) + -> i18nCell auto & cellAttrs <>~ [("class", "table__td--automatic")] + (Right man : others) + | all ((== man) . either id id) others + -> i18nCell man + | otherwise + -> i18nCell man & cellAttrs <>~ [("class", "table__td--overriden")] + csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn) let examUsersDBTable = DBTable{..} where - dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField)) `E.LeftOuterJoin` examResult `E.LeftOuterJoin` courseUserNote) = do - E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId) - E.&&. courseUserNote E.?. CourseUserNoteCourse E.==. E.just (E.val examCourse) - E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId) - E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid) - E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField - E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree - E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) - E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) - E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) - E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) - E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence - E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId - E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid - return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult, courseUserNote) + dbtSQLQuery = runReaderT $ do + examRegistration <- asks queryExamRegistration + user <- asks queryUser + occurrence <- asks queryExamOccurrence + courseParticipant <- asks queryCourseParticipant + studyFeatures <- asks queryStudyFeatures + studyDegree <- asks queryStudyDegree + studyField <- asks queryStudyField + examBonus' <- asks queryExamBonus + examResult <- asks queryExamResult + courseUserNote <- asks queryCourseNote + + lift $ do + E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId) + E.&&. courseUserNote E.?. CourseUserNoteCourse E.==. E.just (E.val examCourse) + E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId) + E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid) + E.on $ examBonus' E.?. ExamBonusUser E.==. E.just (user E.^. UserId) + E.&&. examBonus' E.?. ExamBonusExam E.==. E.just (E.val eid) + E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField + E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree + E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) + E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) + E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) + E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) + E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence + E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId + + E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid + + return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examBonus', examResult, courseUserNote) dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ - (,,,,,,,,) - <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 + (,,,,,,,,,) + <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 <*> view _8 <*> getExamParts - <*> view _8 + <*> view _9 where getExamParts :: ReaderT _ (MaybeT (YesodDB UniWorX)) (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult))) getExamParts = do @@ -395,25 +493,33 @@ postEUsersR tid ssh csh examn = do SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints) - , guardOn examShowGrades $ sortable (Just "result") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult) - , guardOn (not examShowGrades) $ sortable (Just "result-bool") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult . to (over _examResult $ view passingGrade)) + , guardOn doBonus $ sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) . automaticCell $ resultExamBonus . _entityVal . _examBonusBonus . to Right <> resultAutomaticExamBonus' . to Left + , pure $ mconcat + [ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) $ maybe mempty i18nCell . preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult) + | Entity epId ExamPart{..} <- sortOn (examPartNumber . entityVal) examParts + ] + , pure $ sortable (Just $ bool "result-bool" "result" examShowGrades) (i18nCell MsgExamResult) . automaticCell $ (resultExamResult . _entityVal . _examResultResult . to Right <> resultAutomaticExamResult' . to Left) . to (bimap resultView resultView) , pure . sortable (Just "note") (i18nCell MsgCourseUserNote) $ \((,) <$> view (resultUser . _entityKey) <*> has resultCourseNote -> (uid, hasNote)) -> bool mempty (anchorCellM (CourseR tid ssh csh . CUserR <$> encrypt uid) $ hasComment True) hasNote ] - dbtSorting = Map.fromList - [ sortUserNameLink queryUser - , sortUserMatriclenr queryUser - , sortField queryStudyField - , sortDegreeShort queryStudyDegree - , sortFeaturesSemester queryStudyFeatures - , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) - , ("result", SortColumn $ queryExamResult >>> (E.?. ExamResultResult)) - , ("result-bool", SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]) - , ("note", SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date + dbtSorting = mconcat + [ uncurry singletonMap $ sortUserNameLink queryUser + , uncurry singletonMap $ sortUserMatriclenr queryUser + , uncurry singletonMap $ sortField queryStudyField + , uncurry singletonMap $ sortDegreeShort queryStudyDegree + , uncurry singletonMap $ sortFeaturesSemester queryStudyFeatures + , mconcat + [ singletonMap (fromText [st|part-#{toPathPiece examPartNumber}|]) . SortColumn . queryExamPart epId $ \_ examPartResult -> return $ examPartResult E.?. ExamPartResultResult + | Entity epId ExamPart{..} <- examParts + ] + , singletonMap "occurrence" . SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName) + , singletonMap "bonus" . SortColumn $ queryExamBonus >>> (E.?. ExamBonusBonus) + , singletonMap "result" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult) + , singletonMap "result-bool" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50] + , singletonMap "note" . SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date E.sub_select . E.from $ \edit -> do E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote) return . E.max_ $ edit E.^. CourseUserNoteEditTime - ) ] dbtFilter = Map.fromList [ fltrUserNameEmail queryUser @@ -479,7 +585,7 @@ postEUsersR tid ssh csh examn = do , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) , dbtCsvName = unpack csvName , dbtCsvNoExportData = Just id - , dbtCsvHeader = const . return . examUserTableCsvHeader $ examParts ^.. folded . _entityVal . _examPartNumber + , dbtCsvHeader = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber } where doEncode' = ExamUserTableCsv @@ -491,12 +597,13 @@ postEUsersR tid ssh csh examn = do <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) - <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped) - <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral) - <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) - <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) + <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped) (bool (const Nothing) Just showPoints) + <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses) + <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) (bool (const Nothing) Just showPoints) + <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses) + <*> previews (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus') (bool (const Nothing) Just doBonus) <*> (Map.fromList . map (over _1 examPartNumber . over (_2 . _Just) (examPartResultResult . entityVal)) <$> asks (toListOf resultExamParts)) - <*> preview (resultExamResult . _entityVal . _examResultResult . to resultView) + <*> previews (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') resultView <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote) dbtCsvDecode = Just DBTCsvDecode { dbtCsvRowKey = \csv -> do @@ -523,6 +630,9 @@ postEUsersR tid ssh csh examn = do when (epNumber `elem` examPartNumbers) $ yield $ ExamUserCsvSetPartResultData uid epNumber (Just epRes) + when (is _Just . join $ csvEUserBonus dbCsvNew) $ + yield . ExamUserCsvSetBonusData False uid . join $ csvEUserBonus dbCsvNew + when (is _Just $ csvEUserExamResult dbCsvNew) $ yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew @@ -547,27 +657,39 @@ postEUsersR tid ssh csh examn = do when (epRes /= oldPartResult) $ yield $ ExamUserCsvSetPartResultData uid epNumber epRes - let newResults :: Map ExamPartNumber (Maybe ExamResultPoints) - newResults = csvEUserExamPartResults dbCsvNew - `Map.union` toMapOf (resultExamParts .> ito (over _1 $ examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld + let newResults :: Maybe (Map ExamPartNumber ExamResultPoints) + newResults = sequence (csvEUserExamPartResults dbCsvNew) + <|> sequence (toMapOf (resultExamParts .> ito (over _1 $ examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld) - newGrade :: Maybe ExamResultPassedGrade - newGrade = do - possible <- examBonusPossible uid bonus - achieved <- examBonusAchieved uid bonus - resultView <$> examGrade exam possible achieved (newResults ^.. folded . _Just) + newBonus, oldBonus :: Maybe Points + newBonus = join (csvEUserBonus dbCsvNew) + oldBonus = dbCsvOld ^? (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus') - oldResult = dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView + newResult, oldResult :: Maybe ExamResultPassedGrade + newResult = fmap resultView <$> examGrade examVal (newBonus <|> oldBonus) =<< newResults + oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') . to resultView - case newGrade of + case newBonus of + _ | newBonus == oldBonus + -> return () + _ | is _Nothing newBonus + -> return () + Nothing + -> yield $ ExamUserCsvSetBonusData False uid newBonus + Just _ + -> yield $ ExamUserCsvSetBonusData True uid newBonus + + case newResult of _ | csvEUserExamResult dbCsvNew == oldResult -> return () + _ | is _Nothing $ csvEUserExamResult dbCsvNew + -> return () Nothing -> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew Just _ - | csvEUserExamResult dbCsvNew /= newGrade + | csvEUserExamResult dbCsvNew /= newResult -> yield . ExamUserCsvSetResultData True uid $ csvEUserExamResult dbCsvNew - | oldResult /= newGrade + | oldResult /= newResult -> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew | otherwise -> return () @@ -581,6 +703,9 @@ postEUsersR tid ssh csh examn = do ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField ExamUserCsvSetPartResultData{} -> ExamUserCsvSetPartResult + ExamUserCsvSetBonusData{..} + | examUserCsvIsBonusOverride -> ExamUserCsvOverrideBonus + | otherwise -> ExamUserCsvSetBonus ExamUserCsvSetResultData{..} | examUserCsvIsResultOverride -> ExamUserCsvOverrideResult | otherwise -> ExamUserCsvSetResult @@ -639,6 +764,19 @@ postEUsersR tid ssh csh examn = do , ExamPartResultLastChanged =. now ] audit $ TransactionExamPartResultEdit epid examUserCsvActUser + ExamUserCsvSetBonusData{..} -> case examUserCsvActExamBonus of + Nothing -> do + deleteBy $ UniqueExamBonus eid examUserCsvActUser + audit $ TransactionExamBonusDeleted eid examUserCsvActUser + Just res -> do + now <- liftIO getCurrentTime + void $ upsertBy + (UniqueExamBonus eid examUserCsvActUser) + (ExamBonus eid examUserCsvActUser res now) + [ ExamBonusBonus =. res + , ExamBonusLastChanged =. now + ] + audit $ TransactionExamBonusEdit eid examUserCsvActUser ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of Nothing -> do deleteBy $ UniqueExamResult eid examUserCsvActUser @@ -724,12 +862,25 @@ postEUsersR tid ssh csh examn = do [whamlet| $newline never ^{nameWidget userDisplayName userSurname} - , „#{examPartName}“ + $maybe pName <- examPartName + , „#{pName}“ + $nothing + , _{MsgExamPartNumbered examPartNumber} $maybe newResult <- examUserCsvActExamPartResult , _{newResult} $nothing , _{MsgExamResultNone} |] + ExamUserCsvSetBonusData{..} -> do + User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser + [whamlet| + $newline never + ^{nameWidget userDisplayName userSurname} + $maybe newBonus <- examUserCsvActExamBonus + , _{newBonus} + $nothing + , _{MsgExamBonusNone} + |] ExamUserCsvSetResultData{..} -> do User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser [whamlet| diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index dae79f3eb..8398abebd 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -2,7 +2,7 @@ module Handler.Utils.Exam ( fetchExamAux , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam , examBonus, examBonusPossible, examBonusAchieved - , examGrade + , examResultBonus, examGrade ) where import Import.NoFoundation @@ -84,18 +84,42 @@ examBonusPossible uid bonusMap = normalSummary <$> Map.lookup uid bonusMap examBonusAchieved uid bonusMap = (mappend <$> normalSummary <*> bonusSummary) <$> Map.lookup uid bonusMap +examResultBonus :: ExamBonusRule + -> SheetGradeSummary -- ^ `examBonusPossible` + -> SheetGradeSummary -- ^ `examBonusAchieved` + -> Points +examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of + ExamBonusPoints{..} + -> roundToPoints $ toRational bonusMaxPoints * bonusProp + where + bonusProp :: Rational + bonusProp + | possible <= 0 = 1 + | otherwise = achieved / possible + where + achieved = toRational (getSum $ achievedPoints bonusAchieved) + scalePasses (getSum $ achievedPasses bonusAchieved) + possible = toRational (getSum $ sumSheetsPoints bonusPossible) + scalePasses (getSum $ numSheetsPasses bonusPossible) + + scalePasses :: Integer -> Rational + -- ^ Rescale passes so count of all sheets with pass is worth as many points as sum of all sheets with points + scalePasses passes + | passesPossible <= 0 = 0 + | otherwise = fromInteger passes / fromInteger passesPossible * toRational pointsPossible + where + passesPossible = getSum $ numSheetsPasses bonusPossible + pointsPossible = getSum $ sumSheetsPoints bonusPossible + + roundToPoints :: forall a. HasResolution a => Rational -> Fixed a + roundToPoints = MkFixed . round . ((*) . toRational $ resolution (Proxy @a)) + examGrade :: ( MonoFoldable mono , Element mono ~ ExamResultPoints ) - => Entity Exam - -> SheetGradeSummary -- ^ `examBonusPossible` - -> SheetGradeSummary -- ^ `examBonusAchieved` + => Exam + -> Maybe Points -- ^ Bonus -> mono -- ^ `ExamPartResult`s -> Maybe ExamResultGrade -examGrade (Entity _ Exam{..}) bonusPossible bonusAchieved (otoList -> results) - | null results - = Nothing - | otherwise +examGrade Exam{..} mBonus (otoList -> results) = traverse pointsToGrade achievedPoints' where achievedPoints' :: ExamResultPoints @@ -103,37 +127,24 @@ examGrade (Entity _ Exam{..}) bonusPossible bonusAchieved (otoList -> results) withBonus :: Points -> Points withBonus ps - | Just ExamBonusPoints{..} <- examBonusRule + | Just bonusRule <- examBonusRule = if - | not bonusOnlyPassed + | maybe True not (bonusRule ^? _bonusOnlyPassed) || fmap (view passingGrade) (pointsToGrade ps) == Just (_Wrapped # True) - -> ps + roundToPoints (toRational bonusMaxPoints * bonusProp) + -> maybe id (+) mBonus ps | otherwise -> ps | otherwise = ps - where - bonusProp :: Rational - bonusProp = clamp 0 1 $ toRational (getSum (achievedPoints bonusAchieved) + scalePasses (getSum $ achievedPasses bonusAchieved)) - / toRational (getSum (sumSheetsPoints bonusPossible) + scalePasses (getSum $ numSheetsPasses bonusPossible)) - where - scalePasses :: Integer -> Points - -- ^ Rescale passes so count of all sheets with pass is worth as many points as sum of all sheets with points - scalePasses passes = fromInteger passes / (fromInteger . getSum $ numSheetsPasses bonusPossible) * (getSum $ sumSheetsPoints bonusPossible) - - roundToPoints :: forall a. HasResolution a => Rational -> Fixed a - roundToPoints = MkFixed . round . ((*) . toRational $ resolution (Proxy @a)) pointsToGrade :: Points -> Maybe ExamGrade - pointsToGrade ps - | Just ExamGradingKey{..} <- examGradingRule - = Just $ gradeFromKey examGradingKey - | otherwise - = Nothing + pointsToGrade ps = examGradingRule <&> \case + ExamGradingKey{..} + -> gradeFromKey examGradingKey where gradeFromKey :: [Points] -> ExamGrade - gradeFromKey examGradingKey' = maximum $ impureNonNull [ g | (g, b) <- lowerBounds, b <= clampMin 0 ps ] + gradeFromKey examGradingKey' = maximum $ Grade50 `ncons` [ g | (g, b) <- lowerBounds, b <= ps ] where lowerBounds :: [(ExamGrade, Points)] - lowerBounds = zip [Grade50, Grade40 ..] $ 0 : examGradingKey' + lowerBounds = zip [Grade40, Grade37 ..] examGradingKey' diff --git a/src/Utils.hs b/src/Utils.hs index a02ec0a65..f257bc312 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -241,7 +241,8 @@ stepTextCounter text notUsedT :: a -> Text notUsedT = notUsed - +fromText :: (IsString a, Textual t) => t -> a +fromText = fromString . unpack ---------- -- Bool -- diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 1da95cd38..2ccebdbdd 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -167,6 +167,7 @@ makeLenses_ ''Invitation makeLenses_ ''ExamBonusRule makeLenses_ ''ExamGradingRule makeLenses_ ''ExamResult +makeLenses_ ''ExamBonus makeLenses_ ''ExamPart makeLenses_ ''ExamPartResult diff --git a/templates/corrections-overview.hamlet b/templates/corrections-overview.hamlet index 747f99d15..d6f118de5 100644 --- a/templates/corrections-overview.hamlet +++ b/templates/corrections-overview.hamlet @@ -57,9 +57,7 @@ $# Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table $forall shn <- orderedSheetNames
_{MsgExamRoomName} - _{MsgExamRoom} - _{MsgExamRoomCapacity} - _{MsgExamRoomStart} - _{MsgExamRoomEnd} - _{MsgExamRoomDescription} - +
+ _{MsgExamRoomName} # + + + _{MsgExamRoom} # + + + _{MsgExamRoomCapacity} # + + + _{MsgExamRoomStart} # + + _{MsgExamRoomEnd} + _{MsgExamRoomDescription} +
- $# Links currently look ugly in table headers; used an icon as a workaround: - ^{simpleLink (toWidget iconLink) (CSheetR tid ssh csh shn SShowR)} - #{shn} + ^{simpleLink (toWidget shn) (CSheetR tid ssh csh shn SShowR)}
_{MsgNrSubmissionsTotal} _{MsgNrSubmissionsNotCorrected} @@ -140,8 +138,9 @@ $# Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table $forall shn <- orderedSheetNames - #{shn} + + ^{simpleLink (toWidget shn) (CSheetR tid ssh csh shn SShowR)} ^{btnWdgt}
-

_{MsgAssignSubmissionsRandomWarning} \ No newline at end of file +

_{MsgAssignSubmissionsRandomWarning} diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 9cb58b2b0..395b4cd01 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -366,11 +366,20 @@ input[type="button"].btn-info:hover, vertical-align: top; } +.table__td--automatic { + font-style: oblique; + color: var(--color-fontsec); +} + +.table__td--overriden { + font-weight: bold; +} + .table__th { background-color: var(--color-dark); position: relative; font-size: 16px; - color: #fff; + color: white; line-height: 1.4; padding-top: 10px; padding-bottom: 10px; @@ -378,7 +387,20 @@ input[type="button"].btn-info:hover, text-align: left; a { + color: white; text-decoration: none; + font-weight: bold; + + &:hover { + color: inherit; + } + + &::before { + content: "\f0c1"; + font-family: "Font Awesome 5 Free"; + font-weight: 900; + margin-right: 0.25em; + } } } @@ -395,11 +417,10 @@ input[type="button"].btn-info:hover, } .table__th-link { - color: white; font-weight: bold; - &:hover { - color: inherit; + &::before { + display: none; } } diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index f10bdd908..d3509f630 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -55,9 +55,10 @@ $maybe desc <- examDescription $maybe finished <- examFinished

_{MsgExamFinishedParticipant}
^{formatTimeW SelFormatDateTime finished} - $maybe closed <- examClosed -
_{MsgExamClosed} -
^{formatTimeW SelFormatDateTime closed} + $if examClosedShown + $maybe closed <- examClosed +
_{MsgExamClosed} ^{isVisible False} +
^{formatTimeW SelFormatDateTime closed} $if gradingShown $maybe gradingRule <- examGradingRule
@@ -137,7 +138,9 @@ $if gradingShown && not (null examParts) - $forall Entity partId ExamPart{examPartNumber, examPartName, examPartWeight, examPartMaxPoints} <- examParts -
_{MsgExamPartNumber} + $if partNumbersShown + + _{MsgExamPartNumber} ^{isVisible False} _{MsgExamPartName} $if showMaxPoints _{MsgExamPartMaxPoints} @@ -146,8 +149,13 @@ $if gradingShown && not (null examParts)
#{examPartNumber} - #{examPartName} + $if partNumbersShown + #{examPartNumber} + + $maybe pName <- examPartName + #{pName} + $nothing + _{MsgExamPartNumbered examPartNumber} $if showMaxPoints $maybe mPoints <- examPartMaxPoints diff --git a/templates/widgets/massinput/examParts/layout.hamlet b/templates/widgets/massinput/examParts/layout.hamlet index 1a89a8a11..86f968148 100644 --- a/templates/widgets/massinput/examParts/layout.hamlet +++ b/templates/widgets/massinput/examParts/layout.hamlet @@ -5,9 +5,7 @@ $newline never _{MsgExamPartNumber} # - - _{MsgExamPartName} # - + _{MsgExamPartName} _{MsgExamPartMaxPoints} _{MsgExamPartWeight} # From 72342f13936f9e4056e3825ba872a3c5a3726e11 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 18 Sep 2019 18:29:35 +0200 Subject: [PATCH 06/28] feat(exams): accept/reset computed results --- messages/uniworx/de.msg | 5 + src/Handler/Exam/Users.hs | 110 +++++++++++++++--- templates/default-layout.lucius | 10 +- templates/exam-users.hamlet | 2 + .../exam-users/computed-values-tip/de.hamlet | 24 ++++ 5 files changed, 130 insertions(+), 21 deletions(-) create mode 100644 templates/i18n/exam-users/computed-values-tip/de.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 3651476cc..2cdc8cee8 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1449,8 +1449,13 @@ ExamSynchronised: Synchronisiert ExamUsersHeading: Prüfungsteilnehmer ExamUserDeregister: Teilnehmer von Prüfung abmelden ExamUserAssignOccurrence: Termin/Raum zuweisen +ExamUserAcceptComputedResult: Berechnetes Prüfungsergebnis übernehmen +ExamUserResetToComputedResult: Prüfungsergebnis zurücksetzen +ExamUserResetBonus: Auch Bonuspunkte zurücksetzen ExamUsersDeregistered count@Int64: #{show count} Teilnehmer von der Prüfung abgemeldet ExamUsersOccurrenceUpdated count@Int64: Termin/Raum für #{show count} Teilnehmer gesetzt +ExamUsersResultsAccepted count@Int64: Prüfungsergebnis für #{show count} Teilnehmer übernommen +ExamUsersResultsReset count@Int64: Prüfungsergebnis für #{show count} Teilnehmer zurückgesetzt ExamUserSynchronised: Synchronisiert ExamUserSyncOfficeName: Name diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index ba71c331c..3c9d0944f 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -295,6 +295,8 @@ examUserTableCsvHeader allBoni doBonus pNames = Csv.header $ data ExamUserAction = ExamUserDeregister | ExamUserAssignOccurrence + | ExamUserAcceptComputedResult + | ExamUserResetToComputedResult deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe ExamUserAction @@ -304,6 +306,10 @@ embedRenderMessage ''UniWorX ''ExamUserAction id data ExamUserActionData = ExamUserDeregisterData | ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId) + | ExamUserAcceptComputedResultData + | ExamUserResetToComputedResultData + { examUserResetBonus :: Bool + } data ExamUserCsvActionClass = ExamUserCsvCourseRegister @@ -380,7 +386,7 @@ embedRenderMessage ''UniWorX ''ExamUserCsvException id getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEUsersR = postEUsersR postEUsersR tid ssh csh examn = do - ((registrationResult, examUsersTable), Entity eId _) <- runDB $ do + (((Any computedValues, registrationResult), examUsersTable), Entity eId examVal, bonus) <- runDB $ do exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName] bonus <- examBonus exam @@ -403,10 +409,12 @@ postEUsersR tid ssh csh examn = do resultAutomaticExamResult' :: Fold ExamUserTableData ExamResultGrade resultAutomaticExamResult' = resultAutomaticExamResult examVal bonus - automaticCell :: forall msg m a r. + automaticCell :: forall msg m a b r. ( RenderMessage UniWorX msg , IsDBTable m a , Eq msg + , Monoid b + , a ~ (Any, b) ) => Getting (Endo [Either msg msg]) r (Either msg msg) -> r @@ -414,12 +422,12 @@ postEUsersR tid ssh csh examn = do automaticCell l r = case toListOf l r of [] -> mempty (Left auto : _) - -> i18nCell auto & cellAttrs <>~ [("class", "table__td--automatic")] + -> i18nCell auto & cellAttrs <>~ [("class", "table__td--automatic")] & tellCell (Any True, mempty) (Right man : others) | all ((== man) . either id id) others -> i18nCell man | otherwise - -> i18nCell man & cellAttrs <>~ [("class", "table__td--overriden")] + -> i18nCell man & cellAttrs <>~ [("class", "table__td--overriden")] & tellCell (Any True, mempty) csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn) @@ -478,7 +486,7 @@ postEUsersR tid ssh csh examn = do ] dbtColonnade = mconcat $ catMaybes - [ pure $ dbSelect (applying _2) id $ return . view (resultExamRegistration . _entityKey) + [ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey) , pure $ colUserNameLink (CourseR tid ssh csh . CUserR) , pure colUserMatriclenr , pure $ colField resultStudyField @@ -562,20 +570,26 @@ postEUsersR tid ssh csh examn = do , dbParamsFormAdditional = \csrf -> do let actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData) - actionMap = Map.fromList - [ ( ExamUserDeregister - , pure ExamUserDeregisterData - ) - , ( ExamUserAssignOccurrence - , ExamUserAssignOccurrenceData + actionMap = mconcat + [ singletonMap ExamUserDeregister $ + pure ExamUserDeregisterData + , singletonMap ExamUserAssignOccurrence $ + ExamUserAssignOccurrenceData <$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing) - ) + , bool mempty computeActionMap $ is _Just examGradingRule + ] + computeActionMap = mconcat + [ singletonMap ExamUserAcceptComputedResult $ + pure ExamUserAcceptComputedResultData + , singletonMap ExamUserResetToComputedResult $ + ExamUserResetToComputedResultData + <$> bool (pure True) (apopt checkBoxField (fslI MsgExamUserResetBonus) (Just True)) (is _Just examBonusRule) ] (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf let formRes = (, mempty) . First . Just <$> res return (formRes, formWgt) , dbParamsFormEvaluate = liftHandlerT . runFormPost - , dbParamsFormResult = id + , dbParamsFormResult = _2 , dbParamsFormIdent = def } dbtIdent :: Text @@ -992,21 +1006,21 @@ postEUsersR tid ssh csh examn = do examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"] & defaultPagesize PagesizeAll - postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId Bool ExamUserTableData) -> FormResult (ExamUserActionData, Set ExamRegistrationId) + postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId (Bool, ExamUserTableData) ExamUserTableData) -> FormResult (ExamUserActionData, Map ExamRegistrationId ExamUserTableData) postprocess inp = do (First (Just act), regMap) <- inp - let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap - return (act, regSet) - (, exam) . over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable + let regMap' = Map.mapMaybe (uncurry guardOn) $ getDBFormResult (False,) regMap + return (act, regMap') + (, exam, bonus) . over (_1 . _2) postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable formResult registrationResult $ \case - (ExamUserDeregisterData, selectedRegistrations) -> do + (ExamUserDeregisterData, Map.keysSet -> selectedRegistrations) -> do nrDel <- runDB $ deleteWhereCount [ ExamRegistrationId <-. Set.toList selectedRegistrations ] addMessageI Success $ MsgExamUsersDeregistered nrDel redirect $ CExamR tid ssh csh examn EUsersR - (ExamUserAssignOccurrenceData occId, selectedRegistrations) -> do + (ExamUserAssignOccurrenceData occId, Map.keysSet -> selectedRegistrations) -> do nrUpdated <- runDB $ updateWhereCount [ ExamRegistrationId <-. Set.toList selectedRegistrations ] @@ -1014,9 +1028,67 @@ postEUsersR tid ssh csh examn = do ] addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated redirect $ CExamR tid ssh csh examn EUsersR + (ExamUserAcceptComputedResultData, Map.elems -> rows) -> do + nrAccepted <- fmap (getSum . fold) . runDB . forM rows . runReaderT $ do + now <- liftIO getCurrentTime + uid <- view $ resultUser . _entityKey + hasResult <- asks $ has resultExamResult + hasBonus <- asks $ has resultExamBonus + autoResult <- preview $ resultAutomaticExamResult examVal bonus + autoBonus <- preview $ resultAutomaticExamBonus examVal bonus + lift $ if + | not hasResult + , Just examResultResult <- autoResult + -> do + if + | Just examBonusBonus <- autoBonus + , not hasBonus + -> do + insert_ ExamBonus + { examBonusExam = eId + , examBonusUser = uid + , examBonusLastChanged = now + , .. + } + audit $ TransactionExamBonusEdit eId uid + | otherwise + -> return () + + insert_ ExamResult + { examResultExam = eId + , examResultUser = uid + , examResultLastChanged = now + , .. + } + audit $ TransactionExamResultEdit eId uid + return $ Sum 1 + | otherwise + -> return mempty + addMessageI Success $ MsgExamUsersResultsAccepted nrAccepted + redirect $ CExamR tid ssh csh examn EUsersR + (ExamUserResetToComputedResultData{..}, Map.elems -> rows) -> do + nrReset <- fmap (getSum . fold) . runDB . forM rows . runReaderT $ do + uid <- view $ resultUser . _entityKey + lift $ do + when examUserResetBonus $ do + bonusId' <- getKeyBy $ UniqueExamBonus eId uid + whenIsJust bonusId' $ \bonusId -> do + delete bonusId + audit $ TransactionExamBonusDeleted eId uid + + result <- getKeyBy $ UniqueExamResult eId uid + case result of + Just resId -> do + delete resId + audit $ TransactionExamResultDeleted eId uid + return $ Sum 1 + Nothing -> return mempty + addMessageI Success $ MsgExamUsersResultsReset nrReset + redirect $ CExamR tid ssh csh examn EUsersR closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EUsersR) eId siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading + let computedValuesTip = $(i18nWidgetFile "exam-users/computed-values-tip") $(widgetFile "exam-users") diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 395b4cd01..caee80c08 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -596,7 +596,7 @@ section { position: relative; border-radius: 3px; padding: 10px 20px 20px; - margin: 40px 0; + margin: 40px auto; box-shadow: 0 0 4px 2px inset currentColor; padding-left: 100px; min-height: 100px; @@ -608,7 +608,7 @@ section { &::before { font-family: "Font Awesome 5 Free"; - font-weight: 900; + font-weight: 600; position: absolute; display: flex; left: 0; @@ -623,6 +623,12 @@ section { .notification__content { grid-column: 1; align-self: center; + + color: var(--color-font); + } + + &.notification--broad { + max-width: none; } } diff --git a/templates/exam-users.hamlet b/templates/exam-users.hamlet index efa46523c..06e3e489f 100644 --- a/templates/exam-users.hamlet +++ b/templates/exam-users.hamlet @@ -2,4 +2,6 @@ $newline never
^{closeWgt}
+ $if computedValues + ^{computedValuesTip} ^{examUsersTable} diff --git a/templates/i18n/exam-users/computed-values-tip/de.hamlet b/templates/i18n/exam-users/computed-values-tip/de.hamlet new file mode 100644 index 000000000..22f185706 --- /dev/null +++ b/templates/i18n/exam-users/computed-values-tip/de.hamlet @@ -0,0 +1,24 @@ +$newline never +
+
+

+ Die Tabelle enthält Werte, die automatisch berechnet wurden. +

+ Automatisch berechnete Werte (Bonus und Prüfungsergebnis) werden weder dem # + entsprechenden Teilnehmer angezeigt, noch an das Prüfungsamt gemeldet # + bevor sie manuell übernommen wurden.
+ Hierzu können Sie die Aktion „Berechnetes Prüfungsergebnis übernehmen“ # + verwenden. +

+ Sie können die automatisch berechneten Werte auch manuell (via CSV-Import) # + überschreiben.
+ Wenn die so gesetzten Werte nicht den automatisch Berechneten entsprechen # + sind sie inkonsistent. +

+ Automatisch berechnete Werte sind gekennzeichnet wie folgt: + + + + + $maybe mPoints <- fmap (examBonusBonus . entityVal) bonus + $if showMaxPoints + + $if partNumbersShown + + $if partNumbersShown + + $if partNumbersShown + + $if partNumbersShown +
Automatisch berechnet + Normaler Wert + Inkonsistent From 0ebda4d38243d54bf2638e4ce7808bbc084d10dd Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 18 Sep 2019 19:14:19 +0200 Subject: [PATCH 07/28] feat(exams): better display exam-result-information --- src/Handler/Exam/Show.hs | 13 +++++++-- templates/default-layout.lucius | 10 +++++-- templates/exam-show.cassius | 8 +++--- templates/exam-show.hamlet | 48 +++++++++++++++++++++++++++++++++ 4 files changed, 71 insertions(+), 8 deletions(-) diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index 5f739d075..d741948da 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -22,7 +22,7 @@ getEShowR tid ssh csh examn = do cTime <- liftIO getCurrentTime mUid <- maybeAuthId - (Entity _ Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), lecturerInfoShown) <- runDB $ do + (Entity _ Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), lecturerInfoShown) <- runDB $ do exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn let examVisible = NTop (Just cTime) >= NTop examVisibleFrom @@ -43,6 +43,7 @@ getEShowR tid ssh csh examn = do let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw result <- fmap join . for mUid $ getBy . UniqueExamResult eId + bonus <- fmap join . for mUid $ getBy . UniqueExamBonus eId occurrencesRaw <- E.select . E.from $ \examOccurrence -> do E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId @@ -64,12 +65,20 @@ getEShowR tid ssh csh examn = do lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR - return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), lecturerInfoShown) + return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), lecturerInfoShown) let occurrenceNamesShown = lecturerInfoShown partNumbersShown = lecturerInfoShown examClosedShown = lecturerInfoShown + sumMaxPoints = sum [ fromRational examPartWeight * mPoints | Entity _ ExamPart{..} <- examParts, let Just mPoints = examPartMaxPoints ] + sumPoints = getSum <$> foldMap (fmap Sum . examPartResultResult . entityVal) results + + noBonus = fromMaybe False $ do + guardM $ bonusOnlyPassed <$> examBonusRule + return . fromMaybe True $ result ^? _Just . _entityVal . _examResultResult . _examResult . passingGrade . _Wrapped . to not + + let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences registerWidget | Just isRegistered <- registered diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index caee80c08..a6cc039d4 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -319,18 +319,24 @@ input[type="button"].btn-info:hover, .table--striped { - .table__row:not(.no-stripe):nth-child(even) { + .table__row:not(.no-stripe):not(.table__row--sum):nth-child(even) { background-color: rgba(0, 0, 0, 0.03); } } .table--hover { - .table__row:not(.no-hover):not(.table__row--head):hover { + .table__row:not(.no-hover):not(.table__row--sum):not(.table__row--head):hover { background-color: rgba(0, 0, 0, 0.07); } } +.table__row--sum td.table__td::before { + content: 'Σ'; + font-weight: bold; + margin-right: .25em; +} + /* SCROLLTABLE */ .scrolltable { overflow: auto; diff --git a/templates/exam-show.cassius b/templates/exam-show.cassius index b0f051fcb..4588a6011 100644 --- a/templates/exam-show.cassius +++ b/templates/exam-show.cassius @@ -1,6 +1,6 @@ -.occurrence--not-registered - text-decoration: strike-through; +.occurrence--not-registered, .no-bonus + text-decoration: line-through .result - padding-left: 2em; - font-size: 20px; + font-size: 3rem + margin: 30px 30px 0 !important diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index d3509f630..cfe28bcf2 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -170,5 +170,53 @@ $if gradingShown && not (null examParts) _{MsgExamNoShow} $of Just ExamVoided _{MsgExamVoided} +
+ + + #{showFixed True sumMaxPoints} + +
+ + _{MsgExamBonusAchieved} + $if showMaxPoints + + $if showAchievedPoints + + #{showFixed True mPoints} +
+ + $if showMaxPoints + + $if showAchievedPoints + + $case sumPoints + $of ExamAttended ps + #{showFixed True ps} + $of _ + $nothing +
+ + $if showMaxPoints + + #{showFixed True sumMaxPoints} + $if showAchievedPoints + + $case sumPoints + $of ExamAttended ps + #{showFixed True ps} + $of _ + + $# TODO: Statistics From 5eaba7830f052fac42a0ce387619a09cefea48f8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 18 Sep 2019 19:21:56 +0200 Subject: [PATCH 08/28] feat(course): additional crosslinking --- src/Foundation.hs | 18 ++++++++++++++++++ templates/exam-show.hamlet | 3 ++- 2 files changed, 20 insertions(+), 1 deletion(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 3f70dd564..58438298a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -2717,6 +2717,24 @@ pageActions (CExamR tid ssh csh examn EUsersR) = , menuItemModal = True , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuExamGrades + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EGradesR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions (CExamR tid ssh csh examn EGradesR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuExamUsers + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EUsersR + , menuItemModal = False + , menuItemAccessCallback' = return True + } ] pageActions (CSheetR tid ssh csh shn SShowR) = [ MenuItem diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index cfe28bcf2..b05d2c2b6 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -184,7 +184,8 @@ $if gradingShown && not (null examParts) $if partNumbersShown - _{MsgExamBonusAchieved} + + _{MsgExamBonusAchieved} $if showMaxPoints $if showAchievedPoints From d2478a3657a483dccc6852544097709bd3aa1f30 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 19 Sep 2019 09:08:33 +0200 Subject: [PATCH 09/28] fix: fix migration --- src/Model/Migration.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index f0f190a79..e7ad3c9af 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -526,6 +526,9 @@ customMigrations = Map.fromListWith (>>) , ( AppliedMigrationKey [migrationVersion|21.0.0|] [version|22.0.0|] , whenM (tableExists "exam") $ [executeQQ| + ALTER TABLE "exam" DROP COLUMN IF EXISTS "grading_key"; + ALTER TABLE "exam" ADD COLUMN IF NOT EXISTS "grading_rule" jsonb; + ALTER TABLE "exam" ALTER COLUMN "grading_rule" DROP NOT NULL; ALTER TABLE "exam" ALTER COLUMN "bonus_rule" DROP NOT NULL; ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" DROP NOT NULL; From e05ea8ea8ccfa8a5bf0a97cf7d3273ba158938d2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 19 Sep 2019 10:11:25 +0200 Subject: [PATCH 10/28] fix: fix migration & tests --- src/Model/Migration.hs | 36 +++++++++++++++++++++++------------- src/Utils.hs | 4 ++-- test/Model/TypesSpec.hs | 3 +-- 3 files changed, 26 insertions(+), 17 deletions(-) diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index e7ad3c9af..bd957ffe1 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -524,21 +524,31 @@ customMigrations = Map.fromListWith (>>) runConduit $ getExamEntries .| C.mapM_ renameExamParts ) , ( AppliedMigrationKey [migrationVersion|21.0.0|] [version|22.0.0|] - , whenM (tableExists "exam") $ - [executeQQ| - ALTER TABLE "exam" DROP COLUMN IF EXISTS "grading_key"; - ALTER TABLE "exam" ADD COLUMN IF NOT EXISTS "grading_rule" jsonb; + , whenM (tableExists "exam") $ do + oldVersion <- columnExists "exam" "grading_key" + if + | oldVersion -> do + -- Major changes happend to the structure of exams without appropriate + -- migration, try to remedy that here + tableDropEmpty "exam_part_corrector" + tableDropEmpty "exam_corrector" + tableDropEmpty "exam_result" + tableDropEmpty "exam_registration" + tableDropEmpty "exam_occurrence" + tableDropEmpty "exam_part" + tableDropEmpty "exam" + | otherwise -> + [executeQQ| + ALTER TABLE "exam" ALTER COLUMN "grading_rule" DROP NOT NULL; + ALTER TABLE "exam" ALTER COLUMN "bonus_rule" DROP NOT NULL; + ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" DROP NOT NULL; - ALTER TABLE "exam" ALTER COLUMN "grading_rule" DROP NOT NULL; - ALTER TABLE "exam" ALTER COLUMN "bonus_rule" DROP NOT NULL; - ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" DROP NOT NULL; + UPDATE "exam" SET "grading_rule" = NULL WHERE "grading_rule" = '{ "rule": "manual" }'; + UPDATE "exam" SET "bonus_rule" = NULL WHERE "bonus_rule" = '{ "rule": "no-bonus"}'; + UPDATE "exam" SET "occurrence_rule" = NULL WHERE "occurrence_rule" = '"manual"'; - UPDATE "exam" SET "grading_rule" = NULL WHERE "grading_rule" = '{ "rule": "manual" }'; - UPDATE "exam" SET "bonus_rule" = NULL WHERE "bonus_rule" = '{ "rule": "no-bonus"}'; - UPDATE "exam" SET "occurrence_rule" = NULL WHERE "occurrence_rule" = '"manual"'; - - UPDATE "exam" SET "occurrence_rule" = json_build_object('rule', "occurrence_rule"); - |] + UPDATE "exam" SET "occurrence_rule" = json_build_object('rule', "occurrence_rule"); + |] ) ] diff --git a/src/Utils.hs b/src/Utils.hs index f257bc312..ca5330ea6 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -979,5 +979,5 @@ clampMin, clampMax :: Ord a => a -- ^ Boundary -> a -- ^ Value -> a -- ^ Clamped Value -clampMin minVal = max minVal -clampMax maxVal = min maxVal +clampMin = max +clampMax = min diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 49faef34f..c27083034 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -240,8 +240,7 @@ instance Arbitrary ExamGrade where instance Arbitrary ExamGradingRule where arbitrary = oneof - [ pure ExamGradingManual - , ExamGradingKey . reverse . fromOffsets . map getNonNegative <$> replicateM 11 arbitrary + [ ExamGradingKey . reverse . fromOffsets . map getNonNegative <$> replicateM 10 arbitrary ] where fromOffsets [] = [] From e97cd5616bfadb838d3ba279768f38fb536dd4fc Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 19 Sep 2019 11:30:24 +0200 Subject: [PATCH 11/28] feat(exams): implement rounding of exambonus --- messages/uniworx/de.msg | 4 ++++ src/Handler/Utils/Exam.hs | 17 ++++++++++++++--- src/Handler/Utils/Form.hs | 3 ++- src/Model/Migration.hs | 18 +++++++++--------- src/Model/Types/Exam.hs | 1 + templates/widgets/bonusRule.hamlet | 4 ++-- 6 files changed, 32 insertions(+), 15 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 2cdc8cee8..fecc3beb2 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1352,8 +1352,12 @@ ExamBonusAchieved: Bonuspunkte ExamEditHeading examn@ExamName: #{examn} bearbeiten ExamBonusMaxPoints: Maximal erreichbare Prüfungs-Bonuspunkte +ExamBonusMaxPointsTip: Bonuspunkte werden, anhand der erreichten Übungspunkte bzw. der Anzahl von bestandenen Übungsblättern, linear zwischen null und der angegebenen Schranke interpoliert. ExamBonusMaxPointsNonPositive: Maximaler Prüfungsbonus muss positiv und größer null sein ExamBonusOnlyPassed: Bonus nur nach Bestehen anrechnen +ExamBonusRound: Bonus runden auf +ExamBonusRoundNonPositive: Vielfaches, auf das gerundet werden soll, muss positiv und größer null sein +ExamBonusRoundTip: Bonuspunkte werden kaufmännisch auf ein Vielfaches der angegeben Zahl gerundet. ExamAutomaticOccurrenceAssignment: Automatische Termin- bzw. Raumzuteilung ExamAutomaticOccurrenceAssignmentTip: Sollen Prüfungsteilnehmer zum Zeitpunkt der Bekanntgabe der Raum- bzw. Terminzuteilung automatisch auf die zur Verfügung stehenden Räume bzw. Termine verteilt werden? Manuelle Umverteilung bzw. vorheriges Festlegen von Zuteilungen einzelner Teilnehmer ist trotzdem möglich. diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 8398abebd..9f6bbe364 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -17,6 +17,8 @@ import qualified Data.Conduit.List as C import qualified Data.Map as Map +import Data.Fixed (Fixed(..)) + fetchExamAux :: ( SqlBackendCanRead backend , E.SqlSelect b a @@ -90,7 +92,7 @@ examResultBonus :: ExamBonusRule -> Points examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of ExamBonusPoints{..} - -> roundToPoints $ toRational bonusMaxPoints * bonusProp + -> roundToPoints bonusRound $ toRational bonusMaxPoints * bonusProp where bonusProp :: Rational bonusProp @@ -109,8 +111,17 @@ examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of passesPossible = getSum $ numSheetsPasses bonusPossible pointsPossible = getSum $ sumSheetsPoints bonusPossible - roundToPoints :: forall a. HasResolution a => Rational -> Fixed a - roundToPoints = MkFixed . round . ((*) . toRational $ resolution (Proxy @a)) + roundToPoints :: forall a. HasResolution a => Fixed a -> Rational -> Fixed a + -- ^ 'round-to-nearest' whole multiple + roundToPoints (MkFixed mult'@(fromInteger -> mult)) ((* toRational (resolution (Proxy @a))) -> raw) + = MkFixed . (* mult') $ + let (whole, frac) = raw `divMod'` mult + in if | abs frac < abs (mult / 2) + -> whole + | raw >= 0 + -> succ whole + | otherwise + -> pred whole examGrade :: ( MonoFoldable mono , Element mono ~ ExamResultPoints diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index ab8ede956..ff88d91af 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -537,8 +537,9 @@ examBonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classify actions = Map.fromList [ ( ExamBonusPoints' , ExamBonusPoints - <$> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints) (preview _bonusMaxPoints =<< prev) + <$> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints & setTooltip MsgExamBonusMaxPointsTip) (preview _bonusMaxPoints =<< prev) <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev)) + <*> areq (checkBool (> 0) MsgExamBonusRoundNonPositive pointsField) (fslI MsgExamBonusRound & setTooltip MsgExamBonusRoundTip) (preview _bonusRound =<< prev) ) ] diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index bd957ffe1..8cc786739 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -527,15 +527,9 @@ customMigrations = Map.fromListWith (>>) , whenM (tableExists "exam") $ do oldVersion <- columnExists "exam" "grading_key" if - | oldVersion -> do + | oldVersion -> -- Major changes happend to the structure of exams without appropriate -- migration, try to remedy that here - tableDropEmpty "exam_part_corrector" - tableDropEmpty "exam_corrector" - tableDropEmpty "exam_result" - tableDropEmpty "exam_registration" - tableDropEmpty "exam_occurrence" - tableDropEmpty "exam_part" tableDropEmpty "exam" | otherwise -> [executeQQ| @@ -543,13 +537,19 @@ customMigrations = Map.fromListWith (>>) ALTER TABLE "exam" ALTER COLUMN "bonus_rule" DROP NOT NULL; ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" DROP NOT NULL; - UPDATE "exam" SET "grading_rule" = NULL WHERE "grading_rule" = '{ "rule": "manual" }'; - UPDATE "exam" SET "bonus_rule" = NULL WHERE "bonus_rule" = '{ "rule": "no-bonus"}'; + UPDATE "exam" SET "grading_rule" = NULL WHERE "grading_rule"->>'rule' = 'manual'; + UPDATE "exam" SET "bonus_rule" = NULL WHERE "bonus_rule"->>'rule' = 'no-bonus'; UPDATE "exam" SET "occurrence_rule" = NULL WHERE "occurrence_rule" = '"manual"'; UPDATE "exam" SET "occurrence_rule" = json_build_object('rule', "occurrence_rule"); |] ) + , ( AppliedMigrationKey [migrationVersion|22.0.0|] [version|23.0.0|] + , whenM (tableExists "exam") $ + [executeQQ| + UPDATE "exam" SET "bonus_rule" = jsonb_insert("bonus_rule", '{round}' :: text[], '0.01' :: jsonb) WHERE "bonus_rule"->>'rule' = 'bonus-points'; + |] + ) ] diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index be8e0bf95..53d900584 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -119,6 +119,7 @@ instance Finite res => Finite (ExamResult' res) data ExamBonusRule = ExamBonusPoints { bonusMaxPoints :: Points , bonusOnlyPassed :: Bool + , bonusRound :: Points } deriving (Show, Read, Eq, Ord, Generic, Typeable) deriveJSON defaultOptions diff --git a/templates/widgets/bonusRule.hamlet b/templates/widgets/bonusRule.hamlet index 9c010d735..3a5a2c775 100644 --- a/templates/widgets/bonusRule.hamlet +++ b/templates/widgets/bonusRule.hamlet @@ -1,6 +1,6 @@ $newline never $case bonusRule - $of ExamBonusPoints ps False + $of ExamBonusPoints ps False _ _{MsgExamBonusPoints ps} - $of ExamBonusPoints ps True + $of ExamBonusPoints ps True _ _{MsgExamBonusPointsPassed ps} From d79dca6be9a00c5dc1671e4779418f2fdc54aa02 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 19 Sep 2019 17:38:23 +0200 Subject: [PATCH 12/28] =?UTF-8?q?fix(migration):=20drop=20more=20tables=20?= =?UTF-8?q?in=20w.a.=20for=20inconsistent=2021=E2=86=9222?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Model/Migration.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 8cc786739..dd04ba1d7 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -530,6 +530,12 @@ customMigrations = Map.fromListWith (>>) | oldVersion -> -- Major changes happend to the structure of exams without appropriate -- migration, try to remedy that here + tableDropEmpty "exam_part_corrector" + tableDropEmpty "exam_corrector" + tableDropEmpty "exam_result" + tableDropEmpty "exam_registration" + tableDropEmpty "exam_occurrence" + tableDropEmpty "exam_part" tableDropEmpty "exam" | otherwise -> [executeQQ| @@ -570,7 +576,7 @@ tableIsEmpty table = do return $ unSingle rows == (0 :: Int64) tableDropEmpty :: MonadIO m => Text -> ReaderT SqlBackend m () -tableDropEmpty table = do +tableDropEmpty table = whenM (tableExists table) $ do isEmpty <- tableIsEmpty table if | isEmpty -> rawExecute [st|DROP TABLE "#{table}" CASCADE|] [] From 7afd569eaa363487f1775489ab1fe667aee84fe7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 19 Sep 2019 18:26:37 +0200 Subject: [PATCH 13/28] fix: syntax --- src/Model/Migration.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index dd04ba1d7..296b933d0 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -527,7 +527,7 @@ customMigrations = Map.fromListWith (>>) , whenM (tableExists "exam") $ do oldVersion <- columnExists "exam" "grading_key" if - | oldVersion -> + | oldVersion -> do -- Major changes happend to the structure of exams without appropriate -- migration, try to remedy that here tableDropEmpty "exam_part_corrector" From 4383eb1359c7ddb6d2cf9cbcd8d92523522c7d8b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 20 Sep 2019 09:20:52 +0200 Subject: [PATCH 14/28] fix: migration --- models/courses | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/models/courses b/models/courses index 206a6879e..758f6980d 100644 --- a/models/courses +++ b/models/courses @@ -17,11 +17,11 @@ Course -- Information about a single course; contained info is always visible deregisterUntil UTCTime Maybe -- unenrolement may be prohibited from a given date onwards registerSecret Text Maybe -- enrolement maybe protected by a simple common passphrase materialFree Bool -- False: only enrolled users may see course materials not stored in this table - applicationsRequired Bool + applicationsRequired Bool default=false applicationsInstructions Html Maybe - applicationsText Bool - applicationsFiles UploadMode - applicationsRatingsVisible Bool + applicationsText Bool default=false + applicationsFiles UploadMode "default='{ \"mode\": \"no-upload\" }'::jsonb" + applicationsRatingsVisible Bool default=false TermSchoolCourseShort term school shorthand -- shorthand must be unique within school and semester TermSchoolCourseName term school name -- name must be unique within school and semester deriving Generic From ad150fac42091fb9955f67b5b6a3ceb1b35e0844 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 25 Sep 2019 11:22:23 +0200 Subject: [PATCH 15/28] Update README.md --- README.md | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/README.md b/README.md index f61775faa..355dc3a7f 100644 --- a/README.md +++ b/README.md @@ -41,7 +41,7 @@ You'll get a prompt: ```sh Enter name of role to add: uniworx -Shall the new role be a superuser? (y/n) [not exactly sure. Guess not?] +Shall the new role be a superuser? (y/n) y [user must be superuser to create extensions] Password: uniworx ... ``` @@ -89,18 +89,6 @@ $ sudo apt-get install pkg-config $ sudo apt-get install libsodium-dev ``` -Build the app: -```sh -$ stack build -``` - -This might take a few minutes... if not hours... be prepared. - -install yesod: -```sh -$ stack install yesod-bin --install-ghc -``` - ### `Node` & `npm` Node and Npm are needed to compile the frontend. @@ -110,6 +98,18 @@ $ curl -sL https://deb.nodesource.com/setup_12.x | sudo -E bash - $ sudo apt-get install -y nodejs ``` +Build the app: +```sh +$ npm run build +``` + +This might take a few minutes... if not hours... be prepared. + +install yesod: +```sh +$ stack install yesod-bin --install-ghc +``` + ### Add dummy data to the database After building the app you can prepare the database and add some dummy data: ```sh @@ -118,7 +118,7 @@ $ ./db.sh -f ## Run Uni2work ```sh -$ npm start +$ npm run start ``` This will compile both frontend and backend and will start Uni2work in development mode (might take a few minutes the first time). It will keep running and will watch any file changes to automatically re-compile the application if necessary. From 72c7e52071ccec6d8c5b261088d065cd15fc4644 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 25 Sep 2019 12:16:55 +0200 Subject: [PATCH 16/28] Update README.md --- README.md | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/README.md b/README.md index 355dc3a7f..685041baa 100644 --- a/README.md +++ b/README.md @@ -5,6 +5,14 @@ The following description applies to Ubuntu and similar debian based Linux distr ## Prerequisites These are the things you need to do/install before you can get started working on Uni2work. +### Install german locale +You will need to install the german locale at compile time. + +Install: + +- Edit `/etc/locale.gen` as root and uncomment/add the line `de_DE.UTF-8 UTF-8` +- Save the file and run `sudo locale-gen` + ### Clone repository Clone this repository and navigate into it ```sh From 67e3b38834ae079ec601633a60799359853f9b5e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 25 Sep 2019 13:46:10 +0200 Subject: [PATCH 17/28] chore: bump versions BREAKING CHANGE: yesod >=1.6 --- nixpkgs.nix | 4 +- package-lock.json | 12 +- package.json | 2 + package.yaml | 54 +++--- shell.nix | 8 +- src/Application.hs | 25 +-- src/Audit.hs | 5 +- src/Auth/Dummy.hs | 40 ++-- src/Auth/LDAP.hs | 32 ++-- src/Auth/PWHash.hs | 56 ++---- .../Concurrent/Async/Lifted/Safe/Utils.hs | 17 -- src/CryptoID.hs | 8 +- src/Data/CaseInsensitive/Instances.hs | 1 + src/Data/CryptoID/Instances.hs | 2 +- src/Data/List/NonEmpty/Instances.hs | 12 -- src/Database/Esqueleto/Utils.hs | 13 +- src/Foundation.hs | 84 ++++----- src/Handler/Admin.hs | 10 +- src/Handler/Allocation/Application.hs | 12 +- src/Handler/Allocation/List.hs | 2 + src/Handler/Allocation/Show.hs | 4 +- src/Handler/Corrections.hs | 30 +-- src/Handler/Course/Application/Files.hs | 4 +- src/Handler/Course/Application/List.hs | 3 +- src/Handler/Course/Edit.hs | 28 +-- src/Handler/Course/LecturerInvite.hs | 11 +- src/Handler/Course/List.hs | 2 +- src/Handler/Course/ParticipantInvite.hs | 15 +- src/Handler/Course/Register.hs | 8 +- src/Handler/Course/Show.hs | 15 +- src/Handler/Course/User.hs | 2 +- src/Handler/Course/Users.hs | 4 +- src/Handler/Exam/AddUser.hs | 7 +- src/Handler/Exam/CorrectorInvite.hs | 10 +- src/Handler/Exam/Form.hs | 10 +- src/Handler/Exam/RegistrationInvite.hs | 14 +- src/Handler/Exam/Show.hs | 2 +- src/Handler/Exam/Users.hs | 22 +-- src/Handler/ExamOffice/Course.hs | 2 +- src/Handler/ExamOffice/Exam.hs | 9 +- src/Handler/ExamOffice/Exams.hs | 2 + src/Handler/ExamOffice/Fields.hs | 6 +- src/Handler/ExamOffice/Users.hs | 12 +- src/Handler/Health.hs | 2 +- src/Handler/Home.hs | 8 +- src/Handler/Material.hs | 15 +- src/Handler/Profile.hs | 6 +- src/Handler/School.hs | 2 +- src/Handler/Sheet.hs | 35 ++-- src/Handler/Submission.hs | 22 ++- src/Handler/SystemMessage.hs | 8 +- src/Handler/Term.hs | 2 +- src/Handler/Tutorial.hs | 21 ++- src/Handler/Users.hs | 12 +- src/Handler/Utils.hs | 12 +- src/Handler/Utils/Communication.hs | 4 +- src/Handler/Utils/ContentDisposition.hs | 2 +- src/Handler/Utils/Csv.hs | 17 +- src/Handler/Utils/Database.hs | 8 +- src/Handler/Utils/DateTime.hs | 6 +- src/Handler/Utils/Delete.hs | 8 +- src/Handler/Utils/Form.hs | 62 ++++--- src/Handler/Utils/Form/MassInput.hs | 26 +-- src/Handler/Utils/Form/Occurrences.hs | 3 +- src/Handler/Utils/Invitations.hs | 73 +++++--- src/Handler/Utils/Mail.hs | 20 +- src/Handler/Utils/Rating.hs | 10 +- src/Handler/Utils/Sheet.hs | 8 +- src/Handler/Utils/Submission.hs | 35 ++-- src/Handler/Utils/Table.hs | 93 ---------- src/Handler/Utils/Table/Cells.hs | 62 ++----- src/Handler/Utils/Table/Columns.hs | 8 +- src/Handler/Utils/Table/Pagination.hs | 171 +++++++++--------- .../Table/Pagination/CsvColumnExplanations.hs | 3 +- src/Handler/Utils/Table/Pagination/Types.hs | 1 + src/Handler/Utils/Tokens.hs | 24 ++- src/Handler/Utils/Zip.hs | 94 +++++++--- src/Import/NoModel.hs | 13 +- src/Jobs.hs | 51 +++--- src/Jobs/Handler/HelpRequest.hs | 2 +- .../Handler/SendNotification/Allocation.hs | 10 +- .../SendNotification/CorrectionsAssigned.hs | 2 +- .../CorrectionsNotDistributed.hs | 2 +- .../Handler/SendNotification/ExamActive.hs | 6 +- .../Handler/SendNotification/ExamOffice.hs | 4 +- .../Handler/SendNotification/ExamResult.hs | 2 +- .../Handler/SendNotification/SheetActive.hs | 2 +- .../Handler/SendNotification/SheetInactive.hs | 6 +- .../SendNotification/SubmissionRated.hs | 2 +- .../SendNotification/UserAuthModeUpdate.hs | 2 +- .../SendNotification/UserRightsUpdate.hs | 2 +- src/Jobs/Handler/SendNotification/Utils.hs | 2 +- src/Jobs/Handler/SendPasswordReset.hs | 2 +- src/Jobs/Handler/SendTestEmail.hs | 4 +- src/Jobs/Handler/SetLogSettings.hs | 2 +- src/Jobs/Handler/SynchroniseLdap.hs | 4 +- src/Jobs/HealthReport.hs | 6 +- src/Jobs/Queue.hs | 16 +- src/Jobs/Types.hs | 2 +- src/Language/Haskell/TH/Instances.hs | 5 +- src/Ldap/Client/Pool.hs | 26 ++- src/Mail.hs | 63 ++++--- src/Model.hs | 3 + src/Model/Migration.hs | 20 +- src/Model/Types/Mail.hs | 4 +- src/Model/Types/Security.hs | 4 +- src/Net/IP/Instances.hs | 9 - src/Net/IPv6/Instances.hs | 16 -- src/Settings.hs | 32 ++-- src/UnliftIO/Async/Utils.hs | 19 ++ src/Utils.hs | 62 ++----- src/Utils/DB.hs | 9 +- src/Utils/Form.hs | 58 +++--- src/Utils/Frontend/Modal.hs | 20 +- src/Utils/Icon.hs | 3 +- src/Utils/Lens.hs | 4 +- src/Utils/Message.hs | 8 +- src/Utils/Sheet.hs | 11 +- src/Utils/Sql.hs | 41 +++-- src/Utils/TH.hs | 4 +- src/Utils/Tokens.hs | 8 +- src/Yesod/Core/Instances.hs | 2 - src/Yesod/Core/Types/Instances.hs | 22 ++- stack.nix | 2 +- stack.yaml | 43 +++-- stackage.nix | 7 +- templates/table/cell/body.hamlet | 2 +- test/Database.hs | 6 +- test/Handler/Utils/ZipSpec.hs | 2 +- test/Test/QuickCheck/Classes/JSON.hs | 2 +- test/TestImport.hs | 14 +- 131 files changed, 1072 insertions(+), 1107 deletions(-) delete mode 100644 src/Control/Concurrent/Async/Lifted/Safe/Utils.hs delete mode 100644 src/Data/List/NonEmpty/Instances.hs delete mode 100644 src/Net/IPv6/Instances.hs create mode 100644 src/UnliftIO/Async/Utils.hs diff --git a/nixpkgs.nix b/nixpkgs.nix index f21a81350..783ede000 100644 --- a/nixpkgs.nix +++ b/nixpkgs.nix @@ -4,6 +4,6 @@ import ((nixpkgs {}).fetchFromGitHub { owner = "NixOS"; repo = "nixpkgs"; - rev = "19.03"; - sha256 = "0q2m2qhyga9yq29yz90ywgjbn9hdahs7i8wwlq7b55rdbyiwa5dy"; + rev = "10e61bf5be57736035ec7a804cb0bf3d083bf2cf"; + sha256 = "0fplfm2zx4vk7gs8bdcxnvzkdmpx2w0llqwf8475z9dz9cl132rm"; }) diff --git a/package-lock.json b/package-lock.json index 785fdc8b6..67c13819f 100644 --- a/package-lock.json +++ b/package-lock.json @@ -7702,9 +7702,9 @@ "dev": true }, "handlebars": { - "version": "4.1.2", - "resolved": "https://registry.npmjs.org/handlebars/-/handlebars-4.1.2.tgz", - "integrity": "sha512-nvfrjqvt9xQ8Z/w0ijewdD/vvWDTOweBUm96NTr66Wfvo1mJenBLwcYmPs3TIBP5ruzYGD7Hx/DaM9RmhroGPw==", + "version": "4.3.1", + "resolved": "https://registry.npmjs.org/handlebars/-/handlebars-4.3.1.tgz", + "integrity": "sha512-c0HoNHzDiHpBt4Kqe99N8tdLPKAnGCQ73gYMPWtAYM4PwGnf7xl8PBUHJqh9ijlzt2uQKaSRxbXRt+rZ7M2/kA==", "dev": true, "requires": { "neo-async": "^2.6.0", @@ -15623,9 +15623,9 @@ "dev": true }, "uglify-js": { - "version": "3.5.15", - "resolved": "https://registry.npmjs.org/uglify-js/-/uglify-js-3.5.15.tgz", - "integrity": "sha512-fe7aYFotptIddkwcm6YuA0HmknBZ52ZzOsUxZEdhhkSsz7RfjHDX2QDxwKTiv4JQ5t5NhfmpgAK+J7LiDhKSqg==", + "version": "3.6.0", + "resolved": "https://registry.npmjs.org/uglify-js/-/uglify-js-3.6.0.tgz", + "integrity": "sha512-W+jrUHJr3DXKhrsS7NUVxn3zqMOFn0hL/Ei6v0anCIMoKC93TjcflTagwIHLW7SfMFfiQuktQyFVCFHGUE0+yg==", "dev": true, "optional": true, "requires": { diff --git a/package.json b/package.json index a598d4013..14784856d 100644 --- a/package.json +++ b/package.json @@ -14,7 +14,9 @@ "yesod:start": "./start.sh", "yesod:lint": "./hlint.sh", "yesod:test": "./test.sh", + "yesod:test:watch": "./test.sh --file-watch", "yesod:build": "./build.sh", + "yesod:build:watch": "./build.sh --file-watch", "frontend:lint": "eslint frontend/src", "frontend:test": "karma start --conf karma.conf.js", "frontend:test:watch": "karma start --conf karma.conf.js --single-run false", diff --git a/package.yaml b/package.yaml index 067fce361..f7445cd95 100644 --- a/package.yaml +++ b/package.yaml @@ -2,40 +2,38 @@ name: uniworx version: 6.11.1 dependencies: - # Due to a bug in GHC 8.0.1, we block its usage - # See: https://ghc.haskell.org/trac/ghc/ticket/12130 - - base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5 - # version 1.0 had a bug in reexporting Handler, causing trouble - - classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1 - - foreign-store - - yesod >=1.4.3 && <1.5 - - yesod-core >=1.4.30 && <1.5 - - yesod-auth >=1.4.0 && <1.5 - - yesod-static >=1.4.0.3 && <1.6 - - yesod-form >=1.4.0 && <1.5 - - classy-prelude >=0.10.2 - - classy-prelude-conduit >=0.10.2 - - bytestring >=0.9 && <0.11 + - base >=4.9.1.0 && <5 + - yesod >=1.6 && <1.7 + - yesod-core >=1.6 && <1.7 + - yesod-auth >=1.6 && <1.7 + - yesod-static >=1.6 && <1.7 + - yesod-form >=1.6 && <1.7 + - classy-prelude >=1.5 && <1.6 + - classy-prelude-conduit >=1.5 && <1.6 + - classy-prelude-yesod >=1.5 && <1.6 + - bytestring >=0.10 && <0.11 - text >=0.11 && <2.0 - - persistent >=2.7.2 && <2.8 - - persistent-postgresql >=2.1.1 && <2.8 - - persistent-template >=2.0 && <2.8 + - persistent >=2.9 && <2.10 + - persistent-postgresql >=2.9 && <2.10 + - persistent-template >=2.5 && <2.9 + - persistent-qq >=2.9 && <2.10 - template-haskell - shakespeare >=2.0 && <2.1 - hjsmin >=0.1 && <0.3 - monad-control >=0.3 && <1.1 - wai-extra >=3.0 && <3.1 - - yaml >=0.8 && <0.9 - - http-conduit >=2.1 && <2.3 + - yaml >=0.11 && <0.12 + - http-conduit >=2.3 && <2.4 - directory >=1.1 && <1.4 - warp >=3.0 && <3.3 - data-default - - aeson >=0.6 && <1.3 + - aeson >=1.4 && <1.5 - conduit >=1.0 && <2.0 - conduit-combinators - monad-logger >=0.3 && <0.4 - fast-logger >=2.2 && <2.5 - wai-logger >=2.2 && <2.4 + - foreign-store - file-embed - safe - unordered-containers @@ -52,11 +50,12 @@ dependencies: - http-api-data - profunctors - colonnade >=1.1.1 - - yesod-colonnade >=1.1.0 - blaze-markup - zip-stream + - encoding - filepath - transformers + - transformers-base - wl-pprint-text - uuid-types - path-pieces @@ -100,8 +99,10 @@ dependencies: - th-abstraction - HaskellNet - HaskellNet-SSL - - network - - resource-pool + - network >=3 + - network-bsd + - unliftio + - unliftio-pool - mime-mail - hashable - aeson-pretty @@ -116,7 +117,6 @@ dependencies: - pkcs7 - memcached-binary - directory-tree - - lifted-base - lattices - hsass - semigroupoids @@ -126,7 +126,6 @@ dependencies: - mono-traversable - lens-aeson - systemd - - lifted-async - streaming-commons - hourglass - unix @@ -138,6 +137,7 @@ dependencies: - pqueue - deepseq - multiset + - retry other-extensions: - GeneralizedNewtypeDeriving @@ -183,6 +183,7 @@ default-extensions: - DeriveLift - DeriveFunctor - DerivingStrategies + - DerivingVia - DataKinds - BinaryLiterals - PolyKinds @@ -190,9 +191,12 @@ default-extensions: - TypeApplications - RecursiveDo - TypeFamilyDependencies + - QuantifiedConstraints ghc-options: - -Wall + - -Wmissing-home-modules + - -Wredundant-constraints - -fno-warn-type-defaults - -fno-warn-unrecognised-pragmas - -fno-warn-partial-type-signatures diff --git a/shell.nix b/shell.nix index d65bb65a3..1a285b264 100644 --- a/shell.nix +++ b/shell.nix @@ -19,7 +19,7 @@ let ''; override = oldAttrs: { - nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-8_x postgresql pgadmin openldap ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]); + nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-12_x postgresql openldap ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]); shellHook = '' export PROMPT_INFO="${oldAttrs.name}" @@ -47,6 +47,12 @@ let set +xe fi + if [ -n "$ZSH_VERSION" ]; then + autoload -U +X compinit && compinit + autoload -U +X bashcompinit && bashcompinit + fi + eval "$(stack --bash-completion-script stack)" + ${oldAttrs.shellHook} ''; }; diff --git a/src/Application.hs b/src/Application.hs index 7d5fa3c39..ab50d34e6 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -54,7 +54,9 @@ import qualified Data.ByteString.Lazy as LBS import Network.HaskellNet.SSL hiding (Settings) import Network.HaskellNet.SMTP.SSL as SMTP hiding (Settings) -import Data.Pool + +import UnliftIO.Concurrent +import UnliftIO.Pool import Control.Monad.Trans.Resource @@ -70,13 +72,12 @@ import System.Exit import qualified Database.Memcached.Binary.IO as Memcached import qualified System.Systemd.Daemon as Systemd -import Control.Concurrent.Async.Lifted.Safe import System.Environment (lookupEnv) import System.Posix.Process (getProcessID) import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM) import qualified System.Posix.Signals as Signals (Handler(..)) -import Network (socketPort) +import Network.Socket (socketPort) import qualified Network.Socket as Socket (close) import Control.Concurrent.STM.Delay @@ -120,7 +121,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX -- performs initialization and returns a foundation datatype value. This is also -- the place to put your migrate statements to have automatic database -- migrations handled by Yesod. -makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX +makeFoundation :: (MonadResource m, MonadUnliftIO m) => AppSettings -> m UniWorX makeFoundation appSettings'@AppSettings{..} = do -- Some basic initializations: HTTP connection manager, logger, and static -- subsite. @@ -146,7 +147,7 @@ makeFoundation appSettings'@AppSettings{..} = do oldLogger <- atomically . swapTVar tVar =<< mkLogger newSettings rmLoggerSet $ loggerSet oldLogger updateLogger newSettings - (tVar, ) <$> fork (updateLogger initialSettings) + (tVar, ) <$> forkIO (updateLogger initialSettings) appLogger <- over _2 fst <$> allocate mkLogger' (\(tVar, tId) -> killThread tId >> (readTVarIO tVar >>= rmLoggerSet . loggerSet)) let appStatic = embeddedStatic @@ -250,7 +251,7 @@ readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFil instanceId <- UUID.nextRandom LBS.writeFile idFile $ UUID.toByteString instanceId return instanceId - | otherwise = throw e + | otherwise = throwIO e createSmtpPool :: MonadLoggerIO m => SmtpConf -> m SMTPPool createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do @@ -327,7 +328,7 @@ warpSettings foundation = defaultSettings void $ liftIO Systemd.notifyReady if | foundation ^. _appHealthCheckDelayNotify - -> void . fork $ do + -> void . forkIO $ do let activeChecks = Set.fromList universeF & Set.filter (is _Just . (foundation ^. _appHealthCheckInterval)) atomically $ do @@ -369,7 +370,7 @@ develMain = runResourceT $ do liftIO . develMainHelper $ return (wsettings, app) -- | The @main@ function for an executable running this site. -appMain :: MonadResourceBase m => m () +appMain :: MonadUnliftIO m => m () appMain = runResourceT $ do settings <- getAppSettings @@ -445,7 +446,7 @@ appMain = runResourceT $ do _other -> return () go status - in void $ allocate (async notifyWatchdog >>= \a -> a <$ link a) cancel + in void $ allocateLinkedAsync notifyWatchdog _other -> return () let runWarp socket = runSettingsSocket (warpSettings foundation) socket app @@ -461,7 +462,7 @@ appMain = runResourceT $ do foundationStoreNum :: Word32 foundationStoreNum = 2 -getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application) +getApplicationRepl :: (MonadResource m, MonadUnliftIO m) => m (Int, UniWorX, Application) getApplicationRepl = do settings <- getAppDevSettings foundation <- makeFoundation settings @@ -475,7 +476,7 @@ getApplicationRepl = do return (getPort wsettings, foundation, app1) -shutdownApp :: (MonadIO m, MonadBaseControl IO m) => UniWorX -> m () +shutdownApp :: (MonadIO m, MonadUnliftIO m) => UniWorX -> m () shutdownApp app = do stopJobCtl app liftIO $ do @@ -494,7 +495,7 @@ handler :: Handler a -> IO a handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h -- | Run DB queries -db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a +db :: DB a -> IO a db = handler . runDB addPWEntry :: User diff --git a/src/Audit.hs b/src/Audit.hs index 06d3d8767..0b7890b8c 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -22,7 +22,7 @@ import qualified Network.Socket as Wai import qualified Net.IP as IP import qualified Net.IPv6 as IPv6 -import Control.Exception (ErrorCall(..), evaluate) +import Control.Exception (ErrorCall(..)) {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} @@ -79,7 +79,6 @@ instance Exception AuditException audit :: ( AuthId (HandlerSite m) ~ Key User - , AuthEntity (HandlerSite m) ~ User , IsSqlBackend (YesodPersistBackend (HandlerSite m)) , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m)) , HasInstanceID (HandlerSite m) InstanceId @@ -99,7 +98,7 @@ audit (toJSON -> transactionLogInfo) = do transactionLogTime <- liftIO getCurrentTime transactionLogInstance <- getsYesod $ view instanceID - transactionLogInitiator <- liftHandlerT maybeAuthId + transactionLogInitiator <- liftHandler maybeAuthId transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote insert_ TransactionLog{..} diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs index 53a10acde..4bfc09d01 100644 --- a/src/Auth/Dummy.hs +++ b/src/Auth/Dummy.hs @@ -17,41 +17,47 @@ data DummyMessage = MsgDummyIdent deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -dummyForm :: ( RenderMessage site FormMessage - , RenderMessage site DummyMessage - , YesodPersist site - , SqlBackendCanRead (YesodPersistBackend site) - , Button site ButtonSubmit - ) => AForm (HandlerT site IO) (CI Text) +dummyForm :: ( RenderMessage (HandlerSite m) FormMessage + , RenderMessage (HandlerSite m) DummyMessage + , YesodPersist (HandlerSite m) + , SqlBackendCanRead (YesodPersistBackend (HandlerSite m)) + , Button (HandlerSite m) ButtonSubmit + , MonadHandler m + ) => AForm m (CI Text) dummyForm = areq (ciField & addDatalist userList) (fslI MsgDummyIdent & noAutocomplete) Nothing where - userList = fmap mkOptionList . runDB $ map toOption <$> selectList [] [Asc UserIdent] + userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent]) toOption (Entity _ User{..}) = Option userDisplayName userIdent (CI.original userIdent) -dummyLogin :: ( YesodAuth site +dummyLogin :: forall site. + ( YesodAuth site , YesodPersist site , SqlBackendCanRead (YesodPersistBackend site) - , RenderMessage site FormMessage , RenderMessage site AFormMessage , RenderMessage site DummyMessage , Button site ButtonSubmit ) => AuthPlugin site dummyLogin = AuthPlugin{..} where + apName :: Text apName = "dummy" - -- apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent - apDispatch "POST" [] = do - ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard dummyForm + + apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent + apDispatch "POST" [] = liftSubHandler $ do + ((loginRes, _), _) <- runFormPost $ renderAForm FormStandard dummyForm + tp <- getRouteToParent case loginRes of FormFailure errs -> do - lift . forM_ errs $ addMessage Error . toHtml - redirect LoginR + forM_ errs $ addMessage Error . toHtml + redirect $ tp LoginR FormMissing -> do - lift $ addMessageI Warning MsgDummyNoFormData - redirect LoginR + addMessageI Warning MsgDummyNoFormData + redirect $ tp LoginR FormSuccess ident -> - lift . setCredsRedirect $ Creds "dummy" (CI.original ident) [] + setCredsRedirect $ Creds "dummy" (CI.original ident) [] apDispatch _ _ = notFound + + apLogin :: (Route Auth -> Route site) -> WidgetFor site () apLogin toMaster = do (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard dummyForm let loginForm = wrapForm login FormSettings diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 320ab6e27..1ba6af9e7 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -84,7 +84,7 @@ instance Exception CampusUserException makePrisms ''CampusUserException -campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList []) +campusUser :: MonadUnliftIO m => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList []) campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do Ldap.bind ldap ldapDn ldapPassword results <- case lookup "DN" credsExtra of @@ -109,15 +109,15 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ , Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs ] -campusUser' :: (MonadBaseControl IO m, MonadCatch m, MonadIO m) => LdapConf -> LdapPool -> User -> m (Maybe (Ldap.AttrList [])) +campusUser' :: (MonadCatch m, MonadUnliftIO m) => LdapConf -> LdapPool -> User -> m (Maybe (Ldap.AttrList [])) campusUser' conf pool User{userIdent} = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser conf pool (Creds apLdap (CI.original userIdent) []) -campusForm :: ( RenderMessage site FormMessage - , RenderMessage site CampusMessage - , Button site ButtonSubmit - ) => WForm (HandlerT site IO) (FormResult CampusLogin) +campusForm :: ( RenderMessage (HandlerSite m) FormMessage + , RenderMessage (HandlerSite m) CampusMessage + , MonadHandler m + ) => WForm m (FormResult CampusLogin) campusForm = do MsgRenderer mr <- getMsgRenderer @@ -133,24 +133,26 @@ apLdap = "LDAP" campusLogin :: forall site. ( YesodAuth site - , RenderMessage site FormMessage , RenderMessage site CampusMessage , RenderMessage site AFormMessage , Button site ButtonSubmit ) => LdapConf -> LdapPool -> AuthPlugin site campusLogin conf@LdapConf{..} pool = AuthPlugin{..} where + apName :: Text apName = apLdap - apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent - apDispatch "POST" [] = do - ((loginRes, _), _) <- lift . runFormPost $ renderWForm FormStandard campusForm + + apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent + apDispatch "POST" [] = liftSubHandler $ do + ((loginRes, _), _) <- runFormPost $ renderWForm FormStandard campusForm + tp <- getRouteToParent case loginRes of FormFailure errs -> do forM_ errs $ addMessage Error . toHtml - redirect LoginR - FormMissing -> redirect LoginR + redirect $ tp LoginR + FormMissing -> redirect $ tp LoginR FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do - ldapResult <- withLdap pool $ \ldap -> do + ldapResult <- withLdap pool $ \ldap -> liftIO $ do Ldap.bind ldap ldapDn ldapPassword searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName] case searchResults of @@ -169,11 +171,13 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..} $logErrorS "LDAP" $ "Error during login: " <> tshow err loginErrorMessageI LoginR Msg.AuthError Right (Right (userDN, credsIdent)) -> - lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)] + setCredsRedirect $ Creds apName credsIdent [("DN", userDN)] Right (Left searchResults) -> do $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults loginErrorMessageI LoginR Msg.AuthError apDispatch _ _ = notFound + + apLogin :: (Route Auth -> Route site) -> WidgetFor site () apLogin toMaster = do (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormStandard campusForm let loginForm = wrapForm login FormSettings diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs index d6f5bf4e8..b2194bf90 100644 --- a/src/Auth/PWHash.hs +++ b/src/Auth/PWHash.hs @@ -26,68 +26,50 @@ data PWHashMessage = MsgPWHashIdent deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -hashForm :: ( RenderMessage site FormMessage - , RenderMessage site PWHashMessage - , Button site ButtonSubmit - ) => AForm (HandlerT site IO) HashLogin +hashForm :: ( RenderMessage (HandlerSite m) FormMessage + , RenderMessage (HandlerSite m) PWHashMessage + , MonadHandler m + ) => AForm m HashLogin hashForm = HashLogin <$> areq ciField (fslpI MsgPWHashIdent "Identifikation") Nothing <*> areq passwordField (fslpI MsgPWHashPassword "Passwort") Nothing -hashLogin :: ( YesodAuth site +hashLogin :: forall site. + ( YesodAuth site , YesodPersist site , SqlBackendCanRead (YesodPersistBackend site) - , RenderMessage site FormMessage + , PersistRecordBackend User (YesodPersistBackend site) , RenderMessage site PWHashMessage , RenderMessage site AFormMessage , Button site ButtonSubmit ) => PWHashAlgorithm -> AuthPlugin site hashLogin pwHashAlgo = AuthPlugin{..} where + apName :: Text apName = "PWHash" - apDispatch "POST" [] = do - ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard hashForm + + apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent + apDispatch "POST" [] = liftSubHandler $ do + ((loginRes, _), _) <- runFormPost $ renderAForm FormStandard hashForm + tp <- getRouteToParent case loginRes of FormFailure errs -> do forM_ errs $ addMessage Error . toHtml - redirect LoginR - FormMissing -> redirect LoginR + redirect $ tp LoginR + FormMissing -> redirect $ tp LoginR FormSuccess HashLogin{..} -> do - user <- lift . runDB . getBy $ UniqueAuthentication hashIdent + user <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent case user of Just (Entity _ User{ userAuthentication = AuthPWHash{..}, userIdent = CI.original -> userIdent }) | verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 authPWHash) -> -- (2^) is magic. - lift . setCredsRedirect $ Creds apName userIdent [] + setCredsRedirect $ Creds apName userIdent [] other -> do $logDebugS "PWHash" $ tshow other loginErrorMessageI LoginR Msg.InvalidLogin - -- apDispatch "GET" [] = do - -- authData <- lookupBasicAuth - -- pwdata <- liftIO $ Yaml.decodeFileEither fp - - -- addHeader "WWW-Authenticate" [st|Basic realm="uni2work maintenance auth" charset="UTF-8"|] - - -- case pwdata of - -- Left err -> $logDebugS "Auth" $ tshow err - -- Right pws -> $logDebugS "Auth" $ tshow (length pws) <> " pw entries" - - -- case (authData, pwdata) of - -- (Nothing, _) -> do - -- notAuthenticated - -- (Just (usr, (Text.encodeUtf8 -> pw)), Right pwdata') - -- | [ PWEntry{ pwUser = pwUser@(User{..}), pwHash = (Text.encodeUtf8 -> pwHash) } ] - -- <- [ pwe | pwe@PWEntry{..} <- pwdata' - -- , let User{..} = pwUser - -- , userIdent == usr - -- , userPlugin == apName - -- ] - -- , verifyPassword pw pwHash - -- -> lift $ do - -- runDB . void $ insertUnique pwUser - -- setCredsRedirect $ Creds apName userIdent [] - -- _ -> permissionDenied "Invalid auth" apDispatch _ _ = notFound + + apLogin :: (Route Auth -> Route site) -> WidgetFor site () apLogin toMaster = do (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard hashForm let loginForm = wrapForm login FormSettings diff --git a/src/Control/Concurrent/Async/Lifted/Safe/Utils.hs b/src/Control/Concurrent/Async/Lifted/Safe/Utils.hs deleted file mode 100644 index 27dc86127..000000000 --- a/src/Control/Concurrent/Async/Lifted/Safe/Utils.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Control.Concurrent.Async.Lifted.Safe.Utils - ( allocateAsync, allocateLinkedAsync - ) where - -import ClassyPrelude hiding (cancel) -import Control.Lens - -import Control.Concurrent.Async.Lifted.Safe - -import Control.Monad.Trans.Resource - - -allocateLinkedAsync, allocateAsync :: forall m a. - MonadResource m - => IO a -> m (Async a) -allocateAsync = fmap (view _2) . flip allocate cancel . async -allocateLinkedAsync = uncurry (<$) . (id &&& link) <=< allocateAsync diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 9263ca308..0f1296887 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -8,11 +8,12 @@ module CryptoID , module System.FilePath.Cryptographic.ImplicitNamespace ) where -import CryptoID.TH -import ClassyPrelude +import Import.NoModel import Model +import CryptoID.TH + import qualified Data.CryptoID as E import Data.CryptoID.Poly.ImplicitNamespace import Data.UUID.Cryptographic.ImplicitNamespace @@ -20,9 +21,6 @@ import System.FilePath.Cryptographic.ImplicitNamespace import qualified Data.Text as Text --- import Data.UUID.Types -import Web.PathPieces - import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index 937fb2c46..f218308f5 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -1,5 +1,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Data.CaseInsensitive.Instances ( diff --git a/src/Data/CryptoID/Instances.hs b/src/Data/CryptoID/Instances.hs index 0867f60b5..b48c0df70 100644 --- a/src/Data/CryptoID/Instances.hs +++ b/src/Data/CryptoID/Instances.hs @@ -43,5 +43,5 @@ instance Csv.FromField s => Csv.FromField (CID.CryptoID c s) where instance Csv.ToField s => Csv.ToField (CID.CryptoID c s) where toField = Csv.toField . CID.ciphertext -instance {-# OVERLAPS #-} (Csv.ToField s, CI.FoldCase s) => Csv.ToField (CID.CryptoID c (CI s)) where +instance {-# OVERLAPS #-} Csv.ToField s => Csv.ToField (CID.CryptoID c (CI s)) where toField = Csv.toField . CI.foldedCase . CID.ciphertext diff --git a/src/Data/List/NonEmpty/Instances.hs b/src/Data/List/NonEmpty/Instances.hs deleted file mode 100644 index f151b6c18..000000000 --- a/src/Data/List/NonEmpty/Instances.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Data.List.NonEmpty.Instances - ( - ) where - -import Data.List.NonEmpty - -import Language.Haskell.TH.Syntax (Lift(..)) - -instance Lift a => Lift (NonEmpty a) where - lift (toList -> xs) = [e|fromList xs|] diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index a71b0b811..2cdfc69d2 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Database.Esqueleto.Utils ( true, false @@ -61,24 +62,22 @@ false :: E.SqlExpr (E.Value Bool) false = E.val False -- | Negation of `isNothing` which is missing -isJust :: (E.Esqueleto query expr backend, PersistField typ) => expr (E.Value (Maybe typ)) -> expr (E.Value Bool) +isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) isJust = E.not_ . E.isNothing infix 4 `isInfixOf`, `hasInfix` -- | Check if the first string is contained in the text derived from the second argument -isInfixOf :: ( E.Esqueleto query expr backend - , E.SqlString s1 +isInfixOf :: ( E.SqlString s1 , E.SqlString s2 ) - => expr (E.Value s1) -> expr (E.Value s2) -> expr (E.Value Bool) + => E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value Bool) isInfixOf needle strExpr = E.castString strExpr `E.ilike` (E.%) E.++. needle E.++. (E.%) -hasInfix :: ( E.Esqueleto query expr backend - , E.SqlString s1 +hasInfix :: ( E.SqlString s1 , E.SqlString s2 ) - => expr (E.Value s2) -> expr (E.Value s1) -> expr (E.Value Bool) + => E.SqlExpr (E.Value s2) -> E.SqlExpr (E.Value s1) -> E.SqlExpr (E.Value Bool) hasInfix = flip isInfixOf and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) diff --git a/src/Foundation.hs b/src/Foundation.hs index 3f70dd564..5dec194c1 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -5,7 +5,6 @@ module Foundation where import Import.NoFoundation hiding (embedFile) -import qualified ClassyPrelude.Yesod as Yesod (getHttpManager) import Database.Persist.Sql (ConnectionPool, runSqlPool) import Text.Hamlet (hamletFile) @@ -48,9 +47,6 @@ import Data.List (nubBy, (!!), findIndex) import Data.Monoid (Any(..)) -import Data.Pool - -import Data.Conduit (($$)) import Data.Conduit.List (sourceList) import qualified Database.Esqueleto as E @@ -94,6 +90,8 @@ import Data.FileEmbed (embedFile) import qualified Ldap.Client as Ldap +import UnliftIO.Pool + type SMTPPool = Pool SMTPConnection @@ -162,9 +160,9 @@ deriving instance Generic (Route UniWorX) -- | Convenient Type Synonyms: type DB = YesodDB UniWorX -type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget) +type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, Widget) type MsgRenderer = MsgRendererS UniWorX -- see Utils -type MailM a = MailT (HandlerT UniWorX IO) a +type MailM a = MailT (HandlerFor UniWorX) a -- Pattern Synonyms for convenience pattern CSheetR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetR -> Route UniWorX @@ -531,13 +529,13 @@ class (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where evalAccessPred :: AccessPredicate -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where - evalAccessPred aPred aid r w = liftHandlerT $ case aPred of + evalAccessPred aPred aid r w = liftHandler $ case aPred of (APPure p) -> runReader (p aid r w) <$> getMsgRenderer (APHandler p) -> p aid r w (APDB p) -> runDB $ p aid r w instance (MonadHandler m, HandlerSite m ~ UniWorX, backend ~ YesodPersistBackend UniWorX) => MonadAP (ReaderT backend m) where - evalAccessPred aPred aid r w = mapReaderT liftHandlerT $ case aPred of + evalAccessPred aPred aid r w = mapReaderT liftHandler $ case aPred of (APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer (APHandler p) -> lift $ p aid r w (APDB p) -> p aid r w @@ -573,7 +571,6 @@ falseAP = APPure . const . const . const $ falseAR <$> ask -- included for compl askTokenUnsafe :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX - , MonadLogger m , MonadCatch m ) => ExceptT AuthResult m (BearerToken (UniWorX)) @@ -690,7 +687,7 @@ tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do $logWarnS "AccessControl" ("deprecated route: " <> tshow r) addMessageI Error MsgDeprecatedRoute - allow <- view _appAllowDeprecated + allow <- getsYesod $ view _appAllowDeprecated return $ bool (Unauthorized "Deprecated Route") Authorized allow tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do $logWarnS "AccessControl" ("route in development: " <> tshow r) @@ -1107,9 +1104,9 @@ tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case ro tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do cTime <- liftIO getCurrentTime - let authorizedIfExists f = do - [E.Value ok] <- lift . E.select . return . E.exists $ E.from f - whenExceptT ok Authorized + let + authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB () + authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID -- participant is currently registered $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do @@ -1395,42 +1392,42 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnf return result -evalAccessFor :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult +evalAccessFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult evalAccessFor mAuthId route isWrite = do dnf <- either throwM return $ routeAuthTags route fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) dnf mAuthId route isWrite -evalAccessForDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult +evalAccessForDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult evalAccessForDB = evalAccessFor -evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult +evalAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult evalAccess route isWrite = do - mAuthId <- liftHandlerT maybeAuthId + mAuthId <- liftHandler maybeAuthId tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags dnf <- either throwM return $ routeAuthTags route (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf mAuthId route isWrite result <$ tellSessionJson SessionInactiveAuthTags deactivated -evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult +evalAccessDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult evalAccessDB = evalAccess -- | Check whether the current user is authorized by `evalAccess` for the given route -- Convenience function for a commonly used code fragment -hasAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m Bool +hasAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m Bool hasAccessTo route isWrite = (== Authorized) <$> evalAccess route isWrite -- | Check whether the current user is authorized by `evalAccess` to read from the given route -- Convenience function for a commonly used code fragment -hasReadAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool +hasReadAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool hasReadAccessTo = flip hasAccessTo False -- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route -- Convenience function for a commonly used code fragment -hasWriteAccessTo :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool +hasWriteAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool hasWriteAccessTo = flip hasAccessTo True -- | Conditional redirect that hides the URL if the user is not authorized for the route -redirectAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a +redirectAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a redirectAccess url = do -- must hide URL if not authorized access <- evalAccess url False @@ -1439,7 +1436,7 @@ redirectAccess url = do _ -> permissionDeniedI MsgUnauthorizedRedirect -- | Verify that the currently logged in user is lecturer or corrector for at least one sheet for the given course -evalAccessCorrector :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) +evalAccessCorrector :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => TermId -> SchoolId -> CourseShorthand -> m AuthResult evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False @@ -1481,7 +1478,7 @@ instance Yesod UniWorX where $logDebugS "updateFavourites" "Updating favourites" now <- liftIO $ getCurrentTime - uid <- MaybeT $ liftHandlerT maybeAuthId + uid <- MaybeT $ liftHandler maybeAuthId cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh user <- MaybeT $ get uid let courseFavourite = CourseFavourite uid now cid @@ -1533,7 +1530,7 @@ instance Yesod UniWorX where encrypted :: ToJSON a => a -> Widget -> Widget encrypted plaintextJson plaintext = do canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True - shouldEncrypt <- view _appEncryptErrors + shouldEncrypt <- getsYesod $ view _appEncryptErrors if | shouldEncrypt , not canDecrypt -> do @@ -1596,14 +1593,13 @@ instance Yesod UniWorX where . decodeUtf8 . Base64.encode . (convert :: Digest (SHAKE256 144) -> ByteString) - . runIdentity - $ sourceList (Lazy.ByteString.toChunks content) $$ sinkHash + . runConduitPure + $ sourceList (Lazy.ByteString.toChunks content) .| sinkHash fileUpload _site _length = FileUploadMemory lbsBackEnd -- What messages should be logged. The following includes all messages when -- in development, and warnings and errors in production. - shouldLog _ _ _ = error "Must use shouldLogIO" shouldLogIO app _source level = do LogSettings{..} <- readTVarIO $ appLogSettings app return $ logAll || level >= logMinimumLevel @@ -1626,7 +1622,7 @@ siteLayout = siteLayout' . Just siteLayout' :: Maybe Widget -- ^ Optionally override `pageHeading` -> Widget -> Handler Html siteLayout' headingOverride widget = do - AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- view appSettings + AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings isModal <- hasCustomHeader HeaderIsModal @@ -1747,7 +1743,7 @@ siteLayout' headingOverride widget = do applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m () -applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage +applySystemMessages = liftHandler . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage where applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do cID <- encrypt smId @@ -2548,7 +2544,7 @@ pageActions (CourseR tid ssh csh SheetListR) = case muid of Nothing -> return False (Just uid) -> do - [E.Value ok] <- runDB . E.select . return . E.exists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do + ok <- runDB . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) @@ -2726,7 +2722,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR , menuItemModal = True , menuItemAccessCallback' = runDB . maybeT (return False) $ do - uid <- MaybeT $ liftHandlerT maybeAuthId + uid <- MaybeT $ liftHandler maybeAuthId submissions <- lift $ submissionList tid csh shn uid guard $ null submissions return True @@ -2738,7 +2734,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionOwnR , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do - uid <- MaybeT $ liftHandlerT maybeAuthId + uid <- MaybeT $ liftHandler maybeAuthId submissions <- lift $ submissionList tid csh shn uid guard . not $ null submissions return True @@ -2948,7 +2944,7 @@ pageActions (CorrectionsR) = , menuItemRoute = SomeRoute CorrectionsCreateR , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do - uid <- MaybeT $ liftHandlerT maybeAuthId + uid <- MaybeT $ liftHandler maybeAuthId sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse let @@ -2987,7 +2983,7 @@ pageActions (CorrectionsGradeR) = , menuItemRoute = SomeRoute CorrectionsCreateR , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do - uid <- MaybeT $ liftHandlerT maybeAuthId + uid <- MaybeT $ liftHandler maybeAuthId sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse let @@ -3006,7 +3002,7 @@ pageActions _ = [] i18nHeading :: (MonadWidget m, RenderMessage site msg, HandlerSite m ~ site) => msg -> m () -i18nHeading msg = liftWidgetT $ toWidget =<< getMessageRender <*> pure msg +i18nHeading msg = liftWidget $ toWidget =<< getMessageRender <*> pure msg -- | only used in defaultLayout; better use siteLayout instead! pageHeading :: Route UniWorX -> Maybe Widget @@ -3113,7 +3109,7 @@ pageHeading _ = Nothing -routeNormalizers :: [Route UniWorX -> WriterT Any (ReaderT (YesodPersistBackend UniWorX) (HandlerT UniWorX IO)) (Route UniWorX)] +routeNormalizers :: [Route UniWorX -> WriterT Any DB (Route UniWorX)] routeNormalizers = [ normalizeRender , ncSchool @@ -3124,7 +3120,7 @@ routeNormalizers = ] where normalizeRender route = route <$ do - YesodRequest{..} <- liftHandlerT getRequest + YesodRequest{..} <- liftHandler getRequest let original = (W.pathInfo reqWaiRequest, reqGetParams) rendered = renderRoute route if @@ -3320,10 +3316,10 @@ upsertCampusUser ldapData Creds{..} = do . UUID.fromByteString . fromStrict . (convert :: Digest (SHAKE128 128) -> ByteString) - . runIdentity - $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash + . runConduitPure + $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) .| sinkHash - [E.Value candidatesRecorded] <- E.select . return . E.exists . E.from $ \candidate -> + candidatesRecorded <- E.selectExists . E.from $ \candidate -> E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence unless candidatesRecorded $ do @@ -3401,14 +3397,14 @@ instance YesodAuth UniWorX where loginHandler = do toParent <- getRouteToParent - lift . defaultLayout $ do + liftHandler . defaultLayout $ do plugins <- getsYesod authPlugins $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins) setTitleI MsgLoginTitle $(widgetFile "login") - authenticate Creds{..} = runDB $ do + authenticate Creds{..} = liftHandler . runDB $ do now <- liftIO getCurrentTime let @@ -3477,7 +3473,7 @@ instance YesodAuth UniWorX where , dummyLogin <$ guard appAuthDummyLogin ] - authHttpManager = Yesod.getHttpManager + authHttpManager = getsYesod appHttpManager onLogin = addMessageI Success Auth.NowLoggedIn diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 1427533d3..a992d9eb9 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -54,7 +54,7 @@ instance Button UniWorX ButtonCreate where btnClasses CreateInf = [BCIsButton, BCPrimary] -- END Button needed only here -emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext) +emailTestForm :: AForm (HandlerFor UniWorX) (Email, MailContext) emailTestForm = (,) <$> areq emailField (fslI MsgMailTestFormEmail) Nothing <*> ( MailContext @@ -112,7 +112,7 @@ postAdminTestR = do jId <- queueJob $ JobSendTestEmail email ls tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail) return jId - writeJobCtl $ JobCtlPerform jId + runReaderT (writeJobCtl $ JobCtlPerform jId) =<< getYesod addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal` let emailWidget' = wrapForm emailWidget def @@ -189,7 +189,7 @@ postAdminTestR = do -- | How does the shape (`ListLength`) change if a certain cell is deleted? deleteCell :: Map ListPosition Int -- ^ Current shape, including initialisation data -> ListPosition -- ^ Coordinate to delete - -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions + -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions deleteCell = miDeleteList -- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition) allowAdd :: ListPosition -> Natural -> ListLength -> Bool @@ -374,7 +374,7 @@ postAdminFeaturesR = do -> Getter (DBRow r) (Maybe Text) -> Getter (DBRow r) i -> DBRow r - -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult i a (DBRow r))) + -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex) (\row _mkUnique -> (\(res,fieldView) -> (set lensRes . assertM (not . Text.null) <$> res, fvInput fieldView)) <$> mopt textField "" (Just $ row ^. lensDefault) @@ -385,7 +385,7 @@ postAdminFeaturesR = do -> Getter (DBRow r) Bool -> Getter (DBRow r) i -> DBRow r - -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult i a (DBRow r))) + -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex) ( \row _mkUnique -> (\(res, fieldView) -> (set lensRes <$> res, fvInput fieldView)) <$> mpopt checkBoxField "" (Just $ row ^. lensDefault) diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index bc19f3dc2..d9e48239a 100644 --- a/src/Handler/Allocation/Application.hs +++ b/src/Handler/Allocation/Application.hs @@ -52,7 +52,7 @@ data ApplicationForm = ApplicationForm { afPriority :: Maybe Natural , afField :: Maybe StudyFeaturesId , afText :: Maybe Text - , afFiles :: Maybe (Source Handler File) + , afFiles :: Maybe (ConduitT () File Handler ()) , afRatingVeto :: Bool , afRatingPoints :: Maybe ExamGrade , afRatingComment :: Maybe Text @@ -77,11 +77,11 @@ applicationForm :: (Maybe AllocationId) -> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView) applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf = do - (mApp, coursesNum, Course{..}, maxPrio) <- liftHandlerT . runDB $ do + (mApp, coursesNum, Course{..}, maxPrio) <- liftHandler . runDB $ do mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1] coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId]) course <- getJust cid - [E.Value (fromMaybe 0 -> maxPrio)] <- E.select . E.from $ \courseApplication -> do + (fromMaybe 0 -> maxPrio) <- fmap ((>>= E.unValue) . listToMaybe) . E.select . E.from $ \courseApplication -> do E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val uid E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId @@ -146,7 +146,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf -> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' textFs (Just $ mApp >>= courseApplicationText . entityVal) hasFiles <- for mApp $ \(Entity appId _) - -> fmap (not . null) . liftHandlerT . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] + -> fmap (not . null) . liftHandler . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] appCID <- for mApp $ encrypt . entityKey let appFilesInfo = (,) <$> hasFiles <*> appCID @@ -296,7 +296,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do fId <- insert file insert_ $ CourseApplicationFile appId fId forM_ afFiles $ \afFiles' -> - runConduit $ transPipe liftHandlerT afFiles' .| C.mapM_ sinkFile' + runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile' audit $ TransactionCourseApplicationEdit cid uid appId addMessageI Success $ MsgCourseApplicationCreated courseShorthand | is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction @@ -327,7 +327,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do fId <- lift $ insert file lift . insert_ $ CourseApplicationFile appId fId modify $ Set.insert fId - in runConduit $ transPipe liftHandlerT afFiles' .| C.mapM_ sinkFile' + in runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile' deleteCascadeWhere [ FileId <-. Set.toList (oldFiles `Set.intersection` changes) ] return changes | otherwise diff --git a/src/Handler/Allocation/List.hs b/src/Handler/Allocation/List.hs index 016db93a0..d64bd13e7 100644 --- a/src/Handler/Allocation/List.hs +++ b/src/Handler/Allocation/List.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + module Handler.Allocation.List ( getAllocationListR ) where diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index 0029581b7..3d366d129 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -68,10 +68,10 @@ getAShowR tid ssh ash = do let Entity cid Course{..} = cEntry ^. resultCourse hasApplicationTemplate = cEntry ^. resultHasTemplate mApp = cEntry ^? resultCourseApplication - cID <- encrypt cid :: WidgetT UniWorX IO CryptoUUIDCourse + cID <- encrypt cid :: WidgetFor UniWorX CryptoUUIDCourse mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR - mApplyFormView <- liftHandlerT . for muid $ \uid -> generateFormPost . applicationForm (Just aId) cid uid $ ApplicationFormMode True mayApply isLecturer + mApplyFormView <- liftHandler . for muid $ \uid -> generateFormPost . applicationForm (Just aId) cid uid $ ApplicationFormMode True mayApply isLecturer tRoute <- case mApp of Nothing -> return . AllocationR tid ssh ash $ AApplyR cID Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 2074fd3b4..4d2c37aba 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1,6 +1,6 @@ module Handler.Corrections where -import Import +import Import hiding (link) -- import System.FilePath (takeFileName) import Jobs @@ -71,8 +71,8 @@ correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet E.where_ $ whereClause t return $ returnStatement t -lastEditQuery :: Database.Esqueleto.Internal.Language.From query expr backend (expr (Entity SubmissionEdit)) - => expr (Entity Submission) -> expr (E.Value (Maybe UTCTime)) +lastEditQuery :: Database.Esqueleto.Internal.Language.From (E.SqlExpr (Entity SubmissionEdit)) + => E.SqlExpr (Entity Submission) -> E.SqlExpr (E.Value (Maybe UTCTime)) lastEditQuery submission = E.sub_select $ E.from $ \edit -> do E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId return $ E.max_ $ edit E.^. SubmissionEditTime @@ -216,7 +216,7 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for ) colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) -colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (addCellAttrs [("style","width:60%")]) $ formCell id +colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (cellAttrs <>~ [("style","width:60%")]) $ formCell id (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment)) @@ -238,7 +238,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d ) in (submission, sheet, crse, corrector, lastEditQuery submission) ) - dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData + dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerFor UniWorX)) CorrectionTableData dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) -> do submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId) @@ -398,9 +398,9 @@ data ActionCorrectionsData = CorrDownloadData | CorrAutoSetCorrectorData SheetId | CorrDeleteData -correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent +correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do - Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler + currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler postDeleteR $ \drRecords -> (submissionDeleteRoute drRecords) { drAbort = SomeRoute currentRoute @@ -416,7 +416,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do , dbParamsFormAdditional = \frag -> do (actionRes, action) <- multiActionM actions "" Nothing mempty return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) - , dbParamsFormEvaluate = liftHandlerT . runFormPost + , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = _1 , dbParamsFormIdent = def } @@ -466,7 +466,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do ] addMessageI Success $ MsgUpdatedAssignedCorrectorSingle num auditAllSubEdit sIds - (E.Value selfCorrectors:_) <- E.select . E.from $ \(submission `E.InnerJoin` subuser) -> do + selfCorrectors <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe) . E.select . E.from $ \(submission `E.InnerJoin` subuser) -> do E.on $ submission E.^. SubmissionId E.==. subuser E.^. SubmissionUserSubmission E.where_ $ submission E.^. SubmissionId `E.in_` E.valList subs E.&&. submission E.^. SubmissionRatingBy E.==. E.just (subuser E.^. SubmissionUserUser) @@ -537,7 +537,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do where authorizedToAssign :: SubmissionId -> DB Bool authorizedToAssign sId = do - [(E.Value tid, E.Value ssh, E.Value csh, E.Value shn)] <- + (E.Value tid, E.Value ssh, E.Value csh, E.Value shn) <- maybe notFound return . listToMaybe <=< E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission ) -> do E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse @@ -547,7 +547,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do let route = CSubmissionR tid ssh csh shn cID SubAssignR (== Authorized) <$> evalAccessDB route True -type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData) +type ActionCorrections' = (ActionCorrections, AForm (HandlerFor UniWorX) ActionCorrectionsData) downloadAction, deleteAction :: ActionCorrections' downloadAction = ( CorrDownload @@ -560,7 +560,7 @@ deleteAction = ( CorrDelete assignAction :: Either CourseId SheetId -> ActionCorrections' assignAction selId = ( CorrSetCorrector , wFormToAForm $ do - correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do + correctors <- liftHandler . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse @@ -573,7 +573,7 @@ assignAction selId = ( CorrSetCorrector correctors' <- forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (SomeMessage userDisplayName, ) <$> encrypt entityKey - cId <- wopt (selectFieldList correctors' :: Field (HandlerT UniWorX IO) CryptoUUIDUser) (fslI MsgCorrector & setTooltip MsgCorrSetCorrectorTooltip) Nothing + cId <- wopt (selectFieldList correctors' :: Field (HandlerFor UniWorX) CryptoUUIDUser) (fslI MsgCorrector & setTooltip MsgCorrSetCorrectorTooltip) Nothing fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId ) @@ -740,7 +740,7 @@ postCorrectionR tid ssh csh shn cid = do } formResult corrResult $ \(rated, ratingPoints', ratingComment') -> do - uid <- liftHandlerT requireAuthId + uid <- liftHandler requireAuthId now <- liftIO getCurrentTime if @@ -1013,7 +1013,7 @@ postCorrectionsGradeR = do , colCommentField ] -- Continue here psValidator = def - & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData)) + & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData)) unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment) dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _, _) = do cID <- encrypt subId diff --git a/src/Handler/Course/Application/Files.hs b/src/Handler/Course/Application/Files.hs index 31ec53e47..b6d3b77a5 100644 --- a/src/Handler/Course/Application/Files.hs +++ b/src/Handler/Course/Application/Files.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + module Handler.Course.Application.Files ( getCAFilesR , getCAppsFilesR @@ -47,7 +49,7 @@ getCAppsFilesR tid ssh csh = do archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseAllApplicationsArchiveName tid ssh csh let - fsSource :: Source DB File + fsSource :: ConduitT () File DB () fsSource = do apps <- lift . E.select . E.from $ \((course `E.InnerJoin` courseApplication `E.InnerJoin` user) `E.LeftOuterJoin` allocation) -> do E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index d01699a2a..312ff9d02 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Handler.Course.Application.List ( getCApplicationsR, postCApplicationsR @@ -103,7 +104,7 @@ instance Csv.ToField CourseApplicationsTableVeto where instance Csv.FromField CourseApplicationsTableVeto where parseField f = do (CI.map Text.strip -> t :: CI Text) <- Csv.parseField f - return . CourseApplicationsTableVeto $ any (== t) + return . CourseApplicationsTableVeto $ elem t [ "veto", "v", "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ] data CourseApplicationsTableCsv = CourseApplicationsTableCsv diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 6347b1d38..fcb45369e 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -44,7 +44,7 @@ data CourseForm = CourseForm , cfAllocation :: Maybe AllocationCourseForm , cfAppRequired :: Bool , cfAppInstructions :: Maybe Html - , cfAppInstructionFiles :: Maybe (Source Handler (Either FileId File)) + , cfAppInstructionFiles :: Maybe (ConduitT () (Either FileId File) Handler ()) , cfAppText :: Bool , cfAppFiles :: UploadMode , cfAppRatingsVisible :: Bool @@ -101,13 +101,13 @@ allocationCourseToForm (Entity _ AllocationCourse{..}) = AllocationCourseForm makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB validateCourse $ \html -> do - -- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs + -- TODO: Refactor to avoid the four repeated calls to liftHandler and three runDBs -- let editCid = cfCourseId =<< template -- possible start for refactoring MsgRenderer mr <- getMsgRenderer - uid <- liftHandlerT requireAuthId - (lecturerSchools, adminSchools) <- liftHandlerT . runDB $ do + uid <- liftHandler requireAuthId + (lecturerSchools, adminSchools) <- liftHandler . runDB $ do lecturerSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolLecturer]] [] protoAdminSchools <- map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin]] [] adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools @@ -116,7 +116,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB termsField <- case template of -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin - (Just cform) | (Just cid) <- cfCourseId cform -> liftHandlerT $ do -- edit existing course + (Just cform) | (Just cid) <- cfCourseId cform -> liftHandler $ do -- edit existing course _courseOld@Course{..} <- runDB $ get404 cid mayEditTerm <- isAuthorized TermEditR True mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True @@ -128,7 +128,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId)))) miAdd _ _ nudge btn = Just $ \csrf -> do (addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing - addRes' <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk + addRes' <- for addRes $ liftHandler . runDB . getKeyBy . UniqueEmail . CI.mk let addRes'' = case (,) <$> addRes <*> addRes' of FormSuccess (CI.mk -> email, mLid) -> let new = maybe (Left email) Right mLid @@ -143,7 +143,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType) miCell _ (Right lid) defType nudge = \csrf -> do (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType) - User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid + User{userEmail, userDisplayName, userSurname} <- liftHandler . runDB $ get404 lid let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown") return (Just <$> lrwRes,lrwView') miCell _ (Left lEmail) defType nudge = \csrf -> do @@ -153,7 +153,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape -> ListPosition -- ^ Coordinate to delete - -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) + -> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition) miDelete = miDeleteList miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool @@ -194,7 +194,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB (newRegFrom,newRegTo,newDeRegUntil) <- case template of (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing) _allIOtherCases -> do - mbLastTerm <- liftHandlerT $ runDB $ selectFirst [TermActive ==. True] [Desc TermName] + mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName] return ( (Just . toMidnight . termStart . entityVal) <$> mbLastTerm , (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm , (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm ) @@ -202,7 +202,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB let allocationForm :: AForm Handler (Maybe AllocationCourseForm) allocationForm = wFormToAForm $ do - availableAllocations' <- liftHandlerT . runDB . E.select . E.from $ \(allocation `E.InnerJoin` term) -> do + availableAllocations' <- liftHandler . runDB . E.select . E.from $ \(allocation `E.InnerJoin` term) -> do E.on $ allocation E.^. AllocationTerm E.==. term E.^. TermId let alreadyParticipates = flip (maybe E.false) (template >>= cfCourseId) $ \cid -> @@ -226,7 +226,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB activeAllocations = availableAllocations' ^.. folded . filtered ((&&) <$> (not <$> allocationEnabled . view _1) <*> view (_2 . _Value)) . _1 mkAllocationOption :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Allocation -> m (Option AllocationId) - mkAllocationOption (Entity aId Allocation{..}) = liftHandlerT $ do + mkAllocationOption (Entity aId Allocation{..}) = liftHandler $ do cID <- encrypt aId :: Handler CryptoUUIDAllocation return . Option (mr . MsgCourseAllocationOption (mr . ShortTermIdentifier $ unTermKey allocationTerm) $ CI.original allocationName) aId $ toPathPiece cID @@ -295,7 +295,7 @@ validateCourse = do CourseForm{..} <- State.get now <- liftIO getCurrentTime - uid <- liftHandlerT requireAuthId + uid <- liftHandler requireAuthId userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolEditR allocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust @@ -517,7 +517,7 @@ courseEditHandler miButtonAction mbCourseForm = do tell $ Set.singleton fId lift $ void . insertUnique $ CourseAppInstructionFile cid fId - keep <- execWriterT . runConduit $ transPipe liftHandlerT (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert + keep <- execWriterT . runConduit $ transPipe liftHandler (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert acfs <- selectList [ CourseAppInstructionFileCourse ==. cid, CourseAppInstructionFileFile /<-. Set.toList keep ] [] mapM_ deleteCascade $ map (courseAppInstructionFileFile . entityVal) acfs @@ -534,7 +534,7 @@ courseEditHandler miButtonAction mbCourseForm = do , formEncoding = formEnctype } -upsertAllocationCourse :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m () +upsertAllocationCourse :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m () upsertAllocationCourse cid cfAllocation = do now <- liftIO getCurrentTime Course{..} <- getJust cid diff --git a/src/Handler/Course/LecturerInvite.hs b/src/Handler/Course/LecturerInvite.hs index 696ba927b..753bd7c10 100644 --- a/src/Handler/Course/LecturerInvite.hs +++ b/src/Handler/Course/LecturerInvite.hs @@ -57,16 +57,19 @@ lecturerInvitationConfig = InvitationConfig{..} where invitationRoute (Entity _ Course{..}) _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR invitationResolveFor _ = do - Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute - getKeyBy404 $ TermSchoolCourseShort tid csh ssh + cRoute <- getCurrentRoute + case cRoute of + Just (CourseR tid csh ssh CLecInviteR) -> + getKeyBy404 $ TermSchoolCourseShort tid csh ssh + _other -> error "lecturerInvitationConfig called from unsupported route" invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|] invitationTokenConfig _ _ = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized - invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandlerT $ toJunction <$> case mlType of + invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandler $ toJunction <$> case mlType of Nothing -> areq (selectField optionsFinite) lFs Nothing Just lType -> aforced (selectField optionsFinite) lFs lType where diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index 650047327..7e815fba2 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -86,7 +86,7 @@ makeCourseTable whereClause colChoices psValidator = do E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser E.where_ $ cid E.==. lecturer E.^. LecturerCourse E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer return user - dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData + dbtProj :: DBRow _ -> MaybeT DB CourseTableData dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do lecturerList <- lift $ E.select $ E.from $ lecturerQuery $ E.val $ entityKey course courseAlloc <- lift $ getBy (UniqueAllocationCourse $ entityKey course) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index a54af6349..e2962ac0b 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -70,13 +70,17 @@ participantInvitationConfig = InvitationConfig{..} where invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR invitationResolveFor _ = do - Just (CourseR tid csh ssh CInviteR) <- getCurrentRoute - getKeyBy404 $ TermSchoolCourseShort tid csh ssh + cRoute <- getCurrentRoute + case cRoute of + Just (CourseR tid csh ssh CInviteR) -> + getKeyBy404 $ TermSchoolCourseShort tid csh ssh + _other -> + error "participantInvitationConfig called from unsupported route" invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|] invitationTokenConfig _ _ = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do @@ -98,9 +102,12 @@ data AddRecipientsResult = AddRecipientsResult , aurSuccess :: [UserEmail] } deriving (Read, Show, Generic, Typeable) +instance Semigroup AddRecipientsResult where + (<>) = mappenddefault + instance Monoid AddRecipientsResult where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCAddUserR = postCAddUserR diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index d134e31d1..abef977ae 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -41,12 +41,12 @@ instance Button UniWorX ButtonCourseRegister where data CourseRegisterForm = CourseRegisterForm { crfStudyFeatures :: Maybe StudyFeaturesId , crfApplicationText :: Maybe Text - , crfApplicationFiles :: Maybe (Source Handler File) + , crfApplicationFiles :: Maybe (ConduitT () File Handler ()) } courseRegisterForm :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Course -> m (AForm Handler CourseRegisterForm, ButtonCourseRegister) -- ^ `CourseRegisterForm` for current user -courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do +courseRegisterForm (Entity cid Course{..}) = liftHandler $ do muid <- maybeAuthId (registration, application) <- runDB $ do registration <- fmap join . for muid $ getBy . flip UniqueParticipant cid @@ -108,7 +108,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandlerT $ do -> fmap (assertM (not . Text.null) . fmap Text.strip) <$> wopt textField' fs (Just $ application >>= courseApplicationText . entityVal) hasFiles <- for application $ \(Entity appId _) - -> fmap (not . null) . liftHandlerT . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] + -> fmap (not . null) . liftHandler . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] appCID <- for application $ encrypt . entityKey let appFilesInfo = (,) <$> hasFiles <*> appCID filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired @@ -191,7 +191,7 @@ postCRegisterR tid ssh csh = do whenIsJust appRes $ audit . TransactionCourseApplicationEdit cid uid whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do - runConduit $ transPipe liftHandlerT fSource .| C.mapM_ (\f -> insert f >>= insert_ . CourseApplicationFile appId) + runConduit $ transPipe liftHandler fSource .| C.mapM_ (\f -> insert f >>= insert_ . CourseApplicationFile appId) return appRes | otherwise = return $ Just () diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 085cc048a..cdab9b549 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -125,11 +125,12 @@ getCShowR tid ssh csh = do , sortable Nothing (i18nCell MsgTutorialFreeCapacity) $ \DBRow{ dbrOutput = Entity tutid Tutorial{..} } -> case tutorialCapacity of Nothing -> mempty Just tutorialCapacity' -> sqlCell $ do - [E.Value freeCapacity] <- E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do - E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid - return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int)) - in return $ E.val tutorialCapacity' E.-. numParticipants - return . toWidget . tshow $ max 0 freeCapacity + freeCapacity <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe) + . E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do + E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid + return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int)) + in return $ E.val tutorialCapacity' E.-. numParticipants + return . toWidget $ tshow freeCapacity , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True isRegistered <- case mbAid of @@ -137,7 +138,7 @@ getCShowR tid ssh csh = do Just uid -> existsBy $ UniqueTutorialParticipant tutId uid if | mayRegister -> do - (tutRegisterForm, tutRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered + (tutRegisterForm, tutRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered return $ wrapForm tutRegisterForm def { formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TRegisterR , formEncoding = tutRegisterEnctype @@ -198,7 +199,7 @@ getCShowR tid ssh csh = do -- Just uid -> existsBy $ UniqueExamRegistration eId uid -- if -- | mayRegister -> do - -- (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered + -- (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered -- return $ wrapForm examRegisterForm def -- { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR -- , formEncoding = examRegisterEnctype diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 7e8cc7cfd..bd222d966 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -159,7 +159,7 @@ postCUserR tid ssh csh uCId = do addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk redirect currentRoute Nothing -> invalidArgs ["User already registered"] - _other -> fail "Invalid @regButton@" + _other -> error "Invalid @regButton@" mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 7b12d45d0..df0169438 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -139,7 +139,7 @@ makeCourseUserTable :: forall h acts. -> PSValidator (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData)) -> DB (FormResult (Element acts, Set UserId), Widget) makeCourseUserTable cid acts restrict colChoices psValidator = do - Just currentRoute <- liftHandlerT getCurrentRoute + currentRoute <- fromMaybe (error "makeCourseUserTable called from 404-handler") <$> liftHandler getCurrentRoute -- -- psValidator has default sorting and filtering let dbtIdent = "courseUsers" :: Text dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } @@ -210,7 +210,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator = do = renderAForm FormStandard $ (, mempty) . First . Just <$> areq (selectField $ optionsF acts) (fslI MsgAction) Nothing - , dbParamsFormEvaluate = liftHandlerT . runFormPost + , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def } diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs index 7aafb58e2..23203d2f2 100644 --- a/src/Handler/Exam/AddUser.hs +++ b/src/Handler/Exam/AddUser.hs @@ -29,9 +29,12 @@ data AddRecipientsResult = AddRecipientsResult , aurSuccessCourse :: [UserEmail] } deriving (Read, Show, Generic, Typeable) +instance Semigroup AddRecipientsResult where + (<>) = mappenddefault + instance Monoid AddRecipientsResult where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html @@ -40,7 +43,7 @@ postEAddUserR tid ssh csh examn = do eEnt@(Entity eid Exam{..}) <- runDB $ fetchExam tid ssh csh examn ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do now <- liftIO getCurrentTime - occurrences <- liftHandlerT . runDB $ selectList [ExamOccurrenceExam ==. eid] [] + occurrences <- liftHandler . runDB $ selectList [ExamOccurrenceExam ==. eid] [] let localNow = utcToLocalTime now diff --git a/src/Handler/Exam/CorrectorInvite.hs b/src/Handler/Exam/CorrectorInvite.hs index 738c2a3fb..8314a8ca1 100644 --- a/src/Handler/Exam/CorrectorInvite.hs +++ b/src/Handler/Exam/CorrectorInvite.hs @@ -55,15 +55,19 @@ examCorrectorInvitationConfig = InvitationConfig{..} Course{..} <- get404 examCourse return $ CExamR courseTerm courseSchool courseShorthand examName ECInviteR invitationResolveFor _ = do - Just (CExamR tid csh ssh examn ECInviteR) <- getCurrentRoute - fetchExamId tid csh ssh examn + cRoute <- getCurrentRoute + case cRoute of + Just (CExamR tid csh ssh examn ECInviteR) -> + fetchExamId tid csh ssh examn + _other -> + error "examCorrectorInvitationConfig called from unsupported route" invitationSubject (Entity _ Exam{..}) _ = do Course{..} <- get404 examCourse return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|] invitationTokenConfig _ _ = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm _ _ _ = pure (JunctionExamCorrector, ()) diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 452b0aa3d..7c2c4de8b 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -104,8 +104,8 @@ examForm template html = do examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId)) examCorrectorsForm mPrev = wFormToAForm $ do MsgRenderer mr <- getMsgRenderer - Just currentRoute <- getCurrentRoute - uid <- liftHandlerT requireAuthId + currentRoute <- fromMaybe (error "examCorrectorForm called from 404-handler") <$> getCurrentRoute + uid <- liftHandler requireAuthId let miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) @@ -139,7 +139,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do miCell' (Left email) = $(widgetFile "widgets/massinput/examCorrectors/cellInvitation") miCell' (Right userId) = do - User{..} <- liftHandlerT . runDB $ get404 userId + User{..} <- liftHandler . runDB $ get404 userId $(widgetFile "widgets/massinput/examCorrectors/cellKnown") miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) () @@ -149,7 +149,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm) examOccurrenceForm prev = wFormToAForm $ do - Just currentRoute <- getCurrentRoute + currentRoute <- fromMaybe (error "examOccurrenceForm called from 404-handler") <$> getCurrentRoute let miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag @@ -191,7 +191,7 @@ examOccurrenceForm prev = wFormToAForm $ do examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm) examPartsForm prev = wFormToAForm $ do - Just currentRoute <- getCurrentRoute + currentRoute <- fromMaybe (error "examPartsForm called from 404-handler") <$> getCurrentRoute let miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs index 5810d3516..ff707cf04 100644 --- a/src/Handler/Exam/RegistrationInvite.hs +++ b/src/Handler/Exam/RegistrationInvite.hs @@ -63,15 +63,19 @@ examRegistrationInvitationConfig = InvitationConfig{..} Course{..} <- get404 examCourse return $ CExamR courseTerm courseSchool courseShorthand examName EInviteR invitationResolveFor _ = do - Just (CExamR tid csh ssh examn EInviteR) <- getCurrentRoute - fetchExamId tid csh ssh examn + cRoute <- getCurrentRoute + case cRoute of + Just (CExamR tid csh ssh examn EInviteR) -> + fetchExamId tid csh ssh examn + _other -> + error "examRegistrationInvitationConfig called from unsupported route" invitationSubject (Entity _ Exam{..}) _ = do Course{..} <- get404 examCourse return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|] invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId let itExpiresAt = Just $ Just invDBExamRegistrationDeadline itAddAuth | not invDBExamRegistrationCourseRegister @@ -81,8 +85,8 @@ examRegistrationInvitationConfig = InvitationConfig{..} itStartsAt = Nothing return InvitationTokenConfig{..} invitationRestriction _ _ = return Authorized - invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandlerT . wFormToAForm $ do - isRegistered <- fmap (is _Just) . liftHandlerT . runDB . getBy $ UniqueParticipant uid examCourse + invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandler . wFormToAForm $ do + isRegistered <- fmap (is _Just) . liftHandler . runDB . getBy $ UniqueParticipant uid examCourse now <- liftIO getCurrentTime case (isRegistered, invDBExamRegistrationCourseRegister) of diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index 72c6058b4..f30822465 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -70,7 +70,7 @@ getEShowR tid ssh csh examn = do registerWidget | Just isRegistered <- registered , mayRegister = Just $ do - (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered + (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered [whamlet|

$if isRegistered diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 42a1f12f5..f245862ec 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -353,7 +353,7 @@ postEUsersR tid ssh csh examn = do (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf let formRes = (, mempty) . First . Just <$> res return (formRes, formWgt) - , dbParamsFormEvaluate = liftHandlerT . runFormPost + , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def } @@ -382,14 +382,14 @@ postEUsersR tid ssh csh examn = do DBCsvDiffMissing{dbCsvOldKey} -> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey DBCsvDiffNew{dbCsvNewKey = Just _} - -> fail "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys" + -> error "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys" DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do (isPart, uid) <- lift $ guessUser dbCsvNew if | isPart -> do yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew newFeatures <- lift $ lookupStudyFeatures dbCsvNew - Just (Entity cpId CourseParticipant{ courseParticipantField = oldFeatures }) <- lift . getBy $ UniqueParticipant uid examCourse + Entity cpId CourseParticipant{ courseParticipantField = oldFeatures } <- lift . getJustBy $ UniqueParticipant uid examCourse when (newFeatures /= oldFeatures) $ yield $ ExamUserCsvSetCourseFieldData cpId newFeatures | otherwise -> @@ -407,7 +407,7 @@ postEUsersR tid ssh csh examn = do newFeatures <- lift $ lookupStudyFeatures dbCsvNew when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do - Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey + Entity cpId _ <- lift . getJustBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey yield $ ExamUserCsvSetCourseFieldData cpId newFeatures when (csvEUserExamResult dbCsvNew /= dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView) $ @@ -491,13 +491,13 @@ postEUsersR tid ssh csh examn = do delete nid ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Just note, .. } -> do now <- liftIO getCurrentTime - uid <- liftHandlerT requireAuthId + uid <- liftHandler requireAuthId Entity nid _ <- upsert (CourseUserNote examCourse examUserCsvActUser note) [ CourseUserNoteNote =. note ] insert_ $ CourseUserNoteEdit uid now nid return $ CExamR tid ssh csh examn EUsersR , dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case ExamUserCsvCourseRegisterData{..} -> do - (User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust + (User{..}, occ) <- liftHandler . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust [whamlet| $newline never ^{nameWidget userDisplayName userSurname} @@ -511,7 +511,7 @@ postEUsersR tid ssh csh examn = do \ (_{MsgExamNoOccurrence}) |] ExamUserCsvRegisterData{..} -> do - (User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust + (User{..}, occ) <- liftHandler . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust [whamlet| $newline never ^{nameWidget userDisplayName userSurname} @@ -521,7 +521,7 @@ postEUsersR tid ssh csh examn = do \ (_{MsgExamNoOccurrence}) |] ExamUserCsvAssignOccurrenceData{..} -> do - occ <- for examUserCsvActOccurrence $ liftHandlerT . runDB . getJust + occ <- for examUserCsvActOccurrence $ liftHandler . runDB . getJust [whamlet| $newline never ^{registeredUserName' examUserCsvActRegistration} @@ -531,7 +531,7 @@ postEUsersR tid ssh csh examn = do \ (_{MsgExamNoOccurrence}) |] ExamUserCsvSetCourseFieldData{..} -> do - User{..} <- liftHandlerT . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant + User{..} <- liftHandler . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant [whamlet| $newline never ^{nameWidget userDisplayName userSurname} @@ -541,7 +541,7 @@ postEUsersR tid ssh csh examn = do , _{MsgCourseStudyFeatureNone} |] ExamUserCsvSetResultData{..} -> do - User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser + User{..} <- liftHandler . runDB $ getJust examUserCsvActUser [whamlet| $newline never ^{nameWidget userDisplayName userSurname} @@ -551,7 +551,7 @@ postEUsersR tid ssh csh examn = do , _{MsgExamResultNone} |] ExamUserCsvSetCourseNoteData{..} -> do - User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser + User{..} <- liftHandler . runDB $ getJust examUserCsvActUser [whamlet| $newline never ^{nameWidget userDisplayName userSurname} diff --git a/src/Handler/ExamOffice/Course.hs b/src/Handler/ExamOffice/Course.hs index 73ed6e0ba..2db5ecf76 100644 --- a/src/Handler/ExamOffice/Course.hs +++ b/src/Handler/ExamOffice/Course.hs @@ -16,7 +16,7 @@ import Handler.Utils examOfficeOptOutForm :: UserId -> CourseId -> Maybe (Set SchoolId) -> Form (Set SchoolId) -- ^ Deals with sets of _opt outs_ examOfficeOptOutForm uid cid (fromMaybe Set.empty -> template) = renderWForm FormStandard $ do - schools <- liftHandlerT . runDB . E.select $ courseExamOfficeSchools (E.val uid) (E.val cid) + schools <- liftHandler . runDB . E.select $ courseExamOfficeSchools (E.val uid) (E.val cid) res <- fmap sequence . forM schools $ \(Entity ssh School{..}, E.Value isForced) -> fmap (ssh, ) <$> bool wpopt wforcedJust isForced checkBoxField (fslI schoolName) (Just $ ssh `Set.notMember` template) diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index c44f50ee1..d87576dbf 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + module Handler.ExamOffice.Exam ( getEGradesR, postEGradesR , examCloseWidget @@ -84,7 +86,7 @@ type ExamUserTableData = DBRow ( Entity ExamResult ) queryExamRegistration :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity ExamRegistration))) -queryExamRegistration = to $ $(E.sqlLOJproj 4 2) +queryExamRegistration = to $(E.sqlLOJproj 4 2) queryUser :: Getter ExamUserTableExpr (E.SqlExpr (Entity User)) queryUser = to $ $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 4 1) @@ -213,7 +215,7 @@ postEGradesR tid ssh csh examn = do partAnchor :: Widget partAnchor = do let partId = x ^. resultUser . _entityKey - cID <- encrypt partId :: WidgetT UniWorX IO CryptoUUIDUser + cID <- encrypt partId :: WidgetFor UniWorX CryptoUUIDUser [whamlet| $newline never @@ -262,6 +264,7 @@ postEGradesR tid ssh csh examn = do E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) E.&&. occurrence E.?. ExamOccurrenceId E.==. E.joinV (examRegistration E.?. ExamRegistrationOccurrence) E.on $ examRegistration E.?. ExamRegistrationUser E.==. E.just (user E.^. UserId) + E.&&. examRegistration E.?. ExamRegistrationExam E.==. E.just (E.val eid) E.on $ examResult E.^. ExamResultUser E.==. user E.^. UserId E.&&. examResult E.^. ExamResultExam E.==. E.val eid @@ -385,7 +388,7 @@ postEGradesR tid ssh csh examn = do (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf let formRes = (, mempty) . First . Just <$> res return (formRes, formWgt) - , dbParamsFormEvaluate = liftHandlerT . runFormPost + , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def } diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index a5794e701..9fd949692 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + module Handler.ExamOffice.Exams ( getEOExamsR ) where diff --git a/src/Handler/ExamOffice/Fields.hs b/src/Handler/ExamOffice/Fields.hs index 2df3860c2..58f7bc57a 100644 --- a/src/Handler/ExamOffice/Fields.hs +++ b/src/Handler/ExamOffice/Fields.hs @@ -45,7 +45,7 @@ eofModeField = Field{..} makeExamOfficeFieldsForm :: UserId -> Maybe (Map StudyTermsId Bool) -> Form (Map StudyTermsId Bool) makeExamOfficeFieldsForm uid template = renderWForm FormStandard $ do - availableFields <- liftHandlerT . runDB . E.select . E.from $ \(terms `E.InnerJoin` schoolTerms) -> do + availableFields <- liftHandler . runDB . E.select . E.from $ \(terms `E.InnerJoin` schoolTerms) -> do E.on $ terms E.^. StudyTermsId E.==. schoolTerms E.^. SchoolTermsTerms E.where_ . E.exists . E.from $ \userFunction -> E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid @@ -75,7 +75,7 @@ getEOFieldsR = postEOFieldsR postEOFieldsR = do uid <- requireAuthId - oldFields <- liftHandlerT . runDB $ do + oldFields <- runDB $ do fields <- E.select . E.from $ \examOfficeField -> do E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val uid return $ (examOfficeField E.^. ExamOfficeFieldField, examOfficeField E.^. ExamOfficeFieldForced) @@ -84,7 +84,7 @@ postEOFieldsR = do ((fieldsRes, fieldsView), fieldsEnc) <- runFormPost . makeExamOfficeFieldsForm uid $ Just oldFields formResult fieldsRes $ \newFields -> do - liftHandlerT . runDB . forM_ (Map.keysSet newFields `Set.union` Map.keysSet oldFields) $ \fieldId -> if + runDB . forM_ (Map.keysSet newFields `Set.union` Map.keysSet oldFields) $ \fieldId -> if | Just forced <- Map.lookup fieldId newFields , fieldId `Map.member` oldFields -> do updateBy (UniqueExamOfficeField uid fieldId) [ ExamOfficeFieldForced =. forced ] diff --git a/src/Handler/ExamOffice/Users.hs b/src/Handler/ExamOffice/Users.hs index 1ff543437..123238812 100644 --- a/src/Handler/ExamOffice/Users.hs +++ b/src/Handler/ExamOffice/Users.hs @@ -67,7 +67,7 @@ examOfficeUserInvitationConfig = InvitationConfig{..} return . SomeMessage $ MsgExamOfficeUserInviteHeading userDisplayName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamOfficeUserInviteExplanation}|] invitationTokenConfig _ _ = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId let itExpiresAt = Nothing itStartsAt = Nothing itAddAuth = Nothing @@ -85,7 +85,7 @@ examOfficeUserInvitationConfig = InvitationConfig{..} makeExamOfficeUsersForm :: Maybe (Set (Either UserEmail UserId)) -> Form (Set (Either UserEmail UserId)) makeExamOfficeUsersForm template = renderWForm FormStandard $ do - Just cRoute <- getCurrentRoute + cRoute <- fromMaybe (error "makeExamOfficeUsersForm called from 404-handler") <$> getCurrentRoute let miAdd' :: (Text -> Text) @@ -105,7 +105,7 @@ makeExamOfficeUsersForm template = renderWForm FormStandard $ do miCell' :: Either UserEmail UserId -> Widget miCell' (Left email) = $(widgetFile "widgets/massinput/examOfficeUsers/cellInvitation") miCell' (Right uid) = do - User{..} <- liftHandlerT . runDB $ getJust uid + User{..} <- liftHandler . runDB $ getJust uid $(widgetFile "widgets/massinput/examOfficeUsers/cellKnown") miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction' frag = Just . SomeRoute $ cRoute :#: frag @@ -119,7 +119,7 @@ makeExamOfficeUsersForm template = renderWForm FormStandard $ do fRequired :: Bool fRequired = False - template' <- for template $ \uids -> liftHandlerT . runDB $ do + template' <- for template $ \uids -> liftHandler . runDB $ do let (invitations, knownUsers) = partitionEithers $ Set.toList uids knownUsers' <- fmap (map E.unValue) . E.select . E.from $ \user -> do E.where_ $ user E.^. UserId `E.in_` E.valList knownUsers @@ -137,7 +137,7 @@ getEOUsersR = postEOUsersR postEOUsersR = do uid <- requireAuthId - oldUsers <- liftHandlerT . runDB $ do + oldUsers <- liftHandler . runDB $ do users <- E.select . E.from $ \(user `E.InnerJoin` examOfficeUser) -> do E.on $ user E.^. UserId E.==. examOfficeUser E.^. ExamOfficeUserUser E.&&. examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val uid @@ -148,7 +148,7 @@ postEOUsersR = do ((usersRes, usersView), usersEnc) <- runFormPost . makeExamOfficeUsersForm $ Just oldUsers formResult usersRes $ \(setSymmDiff oldUsers -> changes) -> do - liftHandlerT . runDBJobs . forM_ changes $ \change -> if + liftHandler . runDBJobs . forM_ changes $ \change -> if | change `Set.member` oldUsers -> case change of Right change' -> do deleteBy $ UniqueExamOfficeUser uid change' diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index dad7ef747..7cb8aa83b 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -27,7 +27,7 @@ getHealthR = do waitResult <- atomically $ maybe (pure $ Left False) (fmap (const $ Left True) . waitDelay) delay <|> (fmap Right . assertM (not. Set.null) $ readTVar reportStore) case waitResult of Left False -> sendResponseStatus noContent204 () - Left True -> fail "System is not generating HealthReports" + Left True -> sendResponseStatus internalServerError500 ("System is not generating HealthReports" :: Text) Right _ -> redirect HealthR Just healthReports -> do let (Max lastUpdated, Min status) = ofoldMap1 (Max *** Min . healthReportStatus) healthReports diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 4d48043f2..0382fab4a 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -58,7 +58,7 @@ homeUpcomingSheets uid = do , E.Value UTCTime , E.Value (Maybe SubmissionId) )) - (DBCell (HandlerT UniWorX IO) ()) + (DBCell Handler ()) colonnade = mconcat [ -- dbRow -- TOOD: sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } -> @@ -82,7 +82,7 @@ homeUpcomingSheets uid = do (hasTickmark True) ] let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"] - sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable + sheetTable <- liftHandler . runDB $ dbTableWidget' validator DBTable { dbtSQLQuery = tableData , dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId , dbtColonnade = colonnade @@ -127,7 +127,7 @@ homeUpcomingSheets uid = do homeUpcomingExams :: UserId -> Widget homeUpcomingExams uid = do now <- liftIO getCurrentTime - ((Any hasExams, examTable), warningDays) <- liftHandlerT . runDB $ do + ((Any hasExams, examTable), warningDays) <- liftHandler . runDB $ do User {userWarningDays} <- get404 uid let fortnight = addUTCTime userWarningDays now let -- code copied and slightly adapted from Handler.Course.getCShowR: @@ -202,7 +202,7 @@ homeUpcomingExams uid = do isRegistered <- existsBy $ UniqueExamRegistration eId uid if | mayRegister -> do - (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered + (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered return $ wrapForm examRegisterForm def { formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR , formEncoding = examRegisterEnctype diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 85c7ca08d..c9d1e2677 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -28,7 +28,7 @@ data MaterialForm = MaterialForm , mfType :: Maybe (CI Text) , mfDescription :: Maybe Html , mfVisibleFrom :: Maybe UTCTime - , mfFiles :: Maybe (Source Handler (Either FileId File)) + , mfFiles :: Maybe (ConduitT () (Either FileId File) Handler ()) } makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm @@ -40,7 +40,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do | Just source <- template >>= mfFiles = runConduit $ source .| C.foldMap setIds | otherwise = return Set.empty - typeOptions :: HandlerT UniWorX IO (OptionList (CI Text)) + typeOptions :: HandlerFor UniWorX (OptionList (CI Text)) typeOptions = do let defaults = Set.fromList $ map (CI.mk . mr) [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample] previouslyUsed <- runDB $ @@ -77,8 +77,8 @@ getMaterialKeyBy404 tid ssh csh mnm = do getKeyBy404 $ UniqueMaterial cid mnm fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material) -fetchMaterial tid ssh csh mnm = do - [matEnt] <- E.select . E.from $ -- uniqueness guaranteed by DB constraints +fetchMaterial tid ssh csh mnm = + maybe notFound return . listToMaybe <=< E.select . E.from $ -- uniqueness guaranteed by DB constraints \(course `E.InnerJoin` material) -> do E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse E.where_ $ course E.^. CourseTerm E.==. E.val tid @@ -86,7 +86,6 @@ fetchMaterial tid ssh csh mnm = do E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. material E.^. MaterialName E.==. E.val mnm return material - return matEnt getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html @@ -245,7 +244,7 @@ postMEditR tid ssh csh mnm = do E.on $ matFile E.^. MaterialFileFile E.==. file E.^. FileId E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt) return $ file E.^. FileId - return (matEnt, (Left . E.unValue) <$> fileIds) + return (matEnt, Left . E.unValue <$> fileIds) -- let cid = materialCourse let template = Just MaterialForm { mfName = materialName @@ -308,14 +307,14 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do when saveOk $ redirect -- redirect must happen outside of runDB $ CourseR tid ssh csh (MaterialR mfName MShowR) - insertMaterialFile' :: MaterialId -> Source Handler (Either FileId File) -> DB () + insertMaterialFile' :: MaterialId -> ConduitT () (Either FileId File) Handler () -> DB () insertMaterialFile' mid fs = do oldFileIdVals <- E.select . E.from $ \(file `E.InnerJoin` materialFile) -> do E.on $ materialFile E.^. MaterialFileFile E.==. file E.^. FileId E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid return $ file E.^. FileId let oldFileIds = setFromList $ map E.unValue oldFileIdVals - keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert + keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert mapM_ deleteCascade (oldFileIds \\ keep :: Set FileId) where finsert (Left fileId) = tell $ singleton fileId diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index e6999d947..13a0e9c81 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -94,7 +94,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar where schoolsForm' :: WForm Handler (FormResult (Set SchoolId)) schoolsForm' = do - allSchools <- liftHandlerT . runDB $ selectList [] [Asc SchoolName] + allSchools <- liftHandler . runDB $ selectList [] [Asc SchoolName] let schoolForm (Entity ssh School{schoolName}) @@ -116,7 +116,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings notificationForm template = wFormToAForm $ do - mbUid <- liftHandlerT maybeAuthId + mbUid <- liftHandler maybeAuthId isAdmin <- hasReadAccessTo AdminR let @@ -144,7 +144,7 @@ notificationForm template = wFormToAForm $ do | otherwise = return False - ntHidden <- liftHandlerT . runDB + ntHidden <- liftHandler . runDB $ Set.fromList universeF & Map.fromSet sectionIsHidden & sequenceA diff --git a/src/Handler/School.hs b/src/Handler/School.hs index 1f665fb15..fa0ef7fe1 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -70,7 +70,7 @@ mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm <*> areq (textField & cfStrip & cfCI) (fslI MsgSchoolName) (sfName <$> template) <*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip . CI.original) <$> massInputListA (ciField & addDatalist ldapOrgs) (const "") (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (Set.toList . sfOrgUnits <$> template)) where - ldapOrgs :: HandlerT UniWorX IO (OptionList (CI Text)) + ldapOrgs :: HandlerFor UniWorX (OptionList (CI Text)) ldapOrgs = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $ setOf (folded . _entityVal . _schoolLdapOrgUnit) <$> selectList [] [] diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 784afcff1..06d200c2a 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -2,7 +2,7 @@ module Handler.Sheet where -import Import +import Import hiding (link) import Jobs.Queue @@ -69,10 +69,7 @@ data SheetForm = SheetForm , sfActiveTo :: UTCTime , sfHintFrom :: Maybe UTCTime , sfSolutionFrom :: Maybe UTCTime - , sfSheetF :: Maybe (Source Handler (Either FileId File)) - , sfHintF :: Maybe (Source Handler (Either FileId File)) - , sfSolutionF :: Maybe (Source Handler (Either FileId File)) - , sfMarkingF :: Maybe (Source Handler (Either FileId File)) + , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe (ConduitT () (Either FileId File) Handler ()) , sfType :: SheetType , sfGrouping :: SheetGroup , sfSubmissionMode :: SubmissionMode @@ -93,7 +90,7 @@ makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm makeSheetForm msId template = identifyForm FIDsheet $ \html -> do oldFileIds <- (return.) <$> case msId of Nothing -> return $ partitionFileType mempty - (Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId + (Just sId) -> liftHandler $ runDB $ getFtIdMap sId mr <- getMsgRenderer ctime <- ceilingQuarterHour <$> liftIO getCurrentTime (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm @@ -637,20 +634,20 @@ postSDelR tid ssh csh shn = do insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX () insertSheetFile sid ftype finfo = do - runConduit $ (sourceFiles finfo) =$= C.mapM_ finsert + runConduit $ sourceFiles finfo .| C.mapM_ finsert where finsert file = do fid <- insert file void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step -insertSheetFile' :: SheetId -> SheetFileType -> Source Handler (Either FileId File) -> YesodDB UniWorX () +insertSheetFile' :: SheetId -> SheetFileType -> ConduitT () (Either FileId File) Handler () -> YesodDB UniWorX () insertSheetFile' sid ftype fs = do oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype return (file E.^. FileId) - keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert + keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId) where finsert (Left fileId) = tell $ singleton fileId @@ -694,8 +691,8 @@ defaultLoads shid = do correctorForm :: SheetId -> AForm Handler (Set (Either (Invitation' SheetCorrector) SheetCorrector)) correctorForm shid = wFormToAForm $ do - Just currentRoute <- liftHandlerT getCurrentRoute - userId <- liftHandlerT requireAuthId + currentRoute <- fromMaybe (error "correctorForm called from 404-handler") <$> liftHandler getCurrentRoute + userId <- liftHandler requireAuthId MsgRenderer mr <- getMsgRenderer let @@ -703,9 +700,9 @@ correctorForm shid = wFormToAForm $ do currentLoads = Map.union <$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (sheetCorrectorState, sheetCorrectorLoad)) (selectList [ SheetCorrectorSheet ==. shid ] []) <*> fmap (fmap ((,) <$> invDBSheetCorrectorState <*> invDBSheetCorrectorLoad) . Map.mapKeysMonotonic Left) (sourceInvitationsF shid) - (defaultLoads', currentLoads') <- liftHandlerT . runDB $ (,) <$> defaultLoads shid <*> currentLoads + (defaultLoads', currentLoads') <- liftHandler . runDB $ (,) <$> defaultLoads shid <*> currentLoads - isWrite <- liftHandlerT $ isWriteRequest currentRoute + isWrite <- liftHandler $ isWriteRequest currentRoute let applyDefaultLoads = Map.null currentLoads' && not isWrite @@ -766,7 +763,7 @@ correctorForm shid = wFormToAForm $ do identWidget <- case userIdent of Left email -> return . toWidget $ mailtoHtml email Right uid -> do - User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ getJust uid + User{userEmail, userDisplayName, userSurname} <- liftHandler . runDB $ getJust uid return $ nameEmailWidget userEmail userDisplayName userSurname return (res, $(widgetFile "sheetCorrectors/cell")) @@ -894,15 +891,19 @@ correctorInvitationConfig = InvitationConfig{..} Course{..} <- get404 sheetCourse return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR invitationResolveFor _ = do - Just (CSheetR tid csh ssh shn SCorrInviteR) <- getCurrentRoute - fetchSheetId tid csh ssh shn + cRoute <- getCurrentRoute + case cRoute of + Just (CSheetR tid csh ssh shn SCorrInviteR) -> + fetchSheetId tid csh ssh shn + _other -> + error "correctorInvitationConfig called from unsupported route" invitationSubject (Entity _ Sheet{..}) _ = do Course{..} <- get404 sheetCourse return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|] invitationTokenConfig _ _ = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ (JunctionSheetCorrector load state, ()) diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 03fdbe079..d3482dc22 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -89,9 +89,13 @@ submissionUserInvitationConfig = InvitationConfig{..} cID <- encrypt subId return $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SInviteR invitationResolveFor _ = do - Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) <- getCurrentRoute - subId <- decrypt cID - bool notFound (return subId) =<< existsKey subId + cRoute <- getCurrentRoute + case cRoute of + Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) -> do + subId <- decrypt cID + bool notFound (return subId) =<< existsKey subId + _other -> + error "submissionUserInvitationConfig called from unsupported route" invitationSubject (Entity _ Submission{..}) _ = do Sheet{..} <- getJust submissionSheet Course{..} <- getJust sheetCourse @@ -103,7 +107,7 @@ submissionUserInvitationConfig = InvitationConfig{..} invitationTokenConfig (Entity _ Submission{..}) _ = do Sheet{..} <- getJust submissionSheet Course{..} <- getJust sheetCourse - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR) let itExpiresAt = Nothing itStartsAt = Nothing @@ -121,7 +125,7 @@ submissionUserInvitationConfig = InvitationConfig{..} return . SomeRoute $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SubShowR -makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (Source Handler File), Set (Either UserEmail UserId)) +makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (ConduitT () File Handler ()), Set (Either UserEmail UserId)) makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,) <$> fileUploadForm (not isLecturer && is _Nothing msmid) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode <*> wFormToAForm submittorsForm @@ -129,7 +133,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident miCell' :: Markup -> Either UserEmail UserId -> Widget miCell' csrf (Left email) = $(widgetFile "widgets/massinput/submissionUsers/cellInvitation") miCell' csrf (Right uid) = do - User{..} <- liftHandlerT . runDB $ getJust uid + User{..} <- liftHandler . runDB $ getJust uid $(widgetFile "widgets/massinput/submissionUsers/cellKnown") miLayout :: ListLength @@ -191,7 +195,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident | null submittors' -> FormFailure [mr MsgSubmissionUsersEmpty] | otherwise -> FormSuccess $ Set.fromList submittors' | otherwise = do - uid <- liftHandlerT requireAuthId + uid <- liftHandler requireAuthId mRoute <- getCurrentRoute let @@ -275,7 +279,7 @@ submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe submissionHelper tid ssh csh shn mcid = do uid <- requireAuthId msmid <- traverse decrypt mcid - Just actionUrl <- getCurrentRoute + actionUrl <- fromMaybe (error "submissionHelper called from 404-handler") <$> getCurrentRoute (Entity shid Sheet{..}, buddies, lastEdits, maySubmit, isLecturer, isOwner) <- runDB $ do csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn @@ -478,7 +482,7 @@ submissionHelper tid ssh csh shn mcid = do Nothing -> return () -- Maybe construct a table to display uploaded archive files - let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerT UniWorX IO) ()) + let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerFor UniWorX) ()) colonnadeFiles cid = mconcat [ sortable (Just "path") (i18nCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr) diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 5198338bc..c6a3c2214 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -179,7 +179,7 @@ postMessageListR = do { dbrOutput = (smE, smT) , .. } - psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (Last ActionSystemMessageData, DBFormResult CryptoUUIDSystemMessage Bool MessageListData)) + psValidator = def :: PSValidator (MForm Handler) (FormResult (Last ActionSystemMessageData, DBFormResult CryptoUUIDSystemMessage Bool MessageListData)) (tableRes', tableView) <- runDB $ dbTable psValidator DBTable { dbtSQLQuery , dbtRowKey = (E.^. SystemMessageId) @@ -216,7 +216,7 @@ postMessageListR = do ] (actionRes, action) <- multiActionM actions "" (Just SMActivate) mempty return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) - , dbParamsFormEvaluate = liftHandlerT . runFormPost + , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def } @@ -225,8 +225,8 @@ postMessageListR = do , dbtCsvDecode = Nothing } - let tableRes = tableRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False) - & mapped._1 %~ fromMaybe (error "By construction the form should always return an action") . getLast + let tableRes = tableRes' <&> _2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False) + <&> _1 %~ fromMaybe (error "By construction the form should always return an action") . getLast case tableRes of FormMissing -> return () diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 85b81efb9..26c349c83 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -176,7 +176,7 @@ postTermEditExistR tid = do termEditHandler :: TermFormTemplate -> Handler Html termEditHandler term = do - Just eHandler <- getCurrentRoute + eHandler <- fromMaybe (error "termEditHandler called from 404-handler") <$> getCurrentRoute ((result, formWidget), formEnctype) <- runFormPost $ newTermForm term case result of (FormSuccess res) -> do diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 0aa65b045..94a00e645 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -14,6 +14,7 @@ import Handler.Utils.Invitations import Jobs.Queue import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import Data.Map ((!)) @@ -198,7 +199,7 @@ postTCommR tid ssh csh tutn = do ) ] , crRecipientAuth = Just $ \uid -> do - [E.Value isTutorialUser] <- E.select . return . E.exists . E.from $ \tutorialUser -> + isTutorialUser <- E.selectExists . E.from $ \tutorialUser -> E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val uid E.&&. tutorialUser E.^. TutorialParticipantTutorial E.==. E.val tutid @@ -250,15 +251,19 @@ tutorInvitationConfig = InvitationConfig{..} Course{..} <- get404 tutorialCourse return $ CTutorialR courseTerm courseSchool courseShorthand tutorialName TInviteR invitationResolveFor _ = do - Just (CTutorialR tid csh ssh tutn TInviteR) <- getCurrentRoute - fetchTutorialId tid csh ssh tutn + cRoute <- getCurrentRoute + case cRoute of + Just (CTutorialR tid csh ssh tutn TInviteR) -> + fetchTutorialId tid csh ssh tutn + _other -> + error "tutorInvitationConfig called from unsupported route" invitationSubject (Entity _ Tutorial{..}) _ = do Course{..} <- get404 tutorialCourse return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|] invitationTokenConfig _ _ = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm _ _ _ = pure (JunctionTutor, ()) @@ -289,8 +294,8 @@ data TutorialForm = TutorialForm tutorialForm :: CourseId -> Maybe TutorialForm -> Form TutorialForm tutorialForm cid template html = do MsgRenderer mr <- getMsgRenderer - Just cRoute <- getCurrentRoute - uid <- liftHandlerT requireAuthId + cRoute <- fromMaybe (error "tutorialForm called from 404-Handler") <$> getCurrentRoute + uid <- liftHandler requireAuthId let tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' ("tutors" :: Text) (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template) @@ -314,7 +319,7 @@ tutorialForm cid template html = do miCell' (Left email) = $(widgetFile "tutorial/tutorMassInput/cellInvitation") miCell' (Right userId) = do - User{..} <- liftHandlerT . runDB $ get404 userId + User{..} <- liftHandler . runDB $ get404 userId $(widgetFile "tutorial/tutorMassInput/cellKnown") miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) () @@ -338,7 +343,7 @@ tutorialForm cid template html = do ) (tfDeregisterUntil <$> template) <*> tutorForm where - tutTypeDatalist :: HandlerT UniWorX IO (OptionList (CI Text)) + tutTypeDatalist :: HandlerFor UniWorX (OptionList (CI Text)) tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $ fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 55f9260da..af6339dbc 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -74,7 +74,7 @@ postUsersR = do , sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation , flip foldMap universeF $ \function -> sortable Nothing (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do - schools <- liftHandlerT . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do + schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function @@ -92,7 +92,7 @@ postUsersR = do , formCellContents = do cID <- encrypt uid mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True - myUid <- liftHandlerT maybeAuthId + myUid <- liftHandler maybeAuthId if | mayHijack , Just uid /= myUid @@ -191,7 +191,7 @@ postUsersR = do = renderAForm FormStandard $ (, mempty) . First . Just <$> areq (selectField $ optionsF [UserLdapSync]) (fslI MsgAction) Nothing - , dbParamsFormEvaluate = liftHandlerT . runFormPost + , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def } @@ -309,7 +309,7 @@ postAdminUserR uuid = do campusHandler _ = mzero campusResult <- runMaybeT . handle campusHandler $ do (Just pool, Just conf) <- getsYesod $ (,) <$> view _appLdapPool <*> view _appLdapConf - void . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) [] + void . lift . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) [] case campusResult of Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup _other @@ -475,7 +475,7 @@ postUserPasswordR cID = do formResultModal passResult (bool ProfileR (UserPasswordR cID) isAdmin) $ \newPass -> do newHash <- fmap decodeUtf8 . liftIO $ PWStore.makePasswordWith pwHashAlgorithm newPass pwHashStrength - liftHandlerT . runDB $ update tUid [ UserAuthentication =. AuthPWHash newHash ] + liftHandler . runDB $ update tUid [ UserAuthentication =. AuthPWHash newHash ] tell . pure =<< messageI Success MsgPasswordChangedSuccess siteLayout [whamlet|_{MsgUserPasswordHeadingFor} ^{nameEmailWidget userEmail userDisplayName userSurname}|] $ @@ -545,7 +545,7 @@ functionInvitationConfig = InvitationConfig{..} MsgRenderer mr <- getMsgRenderer return [ihamlet|_{SomeMessage $ MsgSchoolFunctionInviteExplanation (mr $ SomeMessage invTokenUserFunctionFunction)}|] invitationTokenConfig _ (InvDBDataUserFunction{..}, _) = do - itAuthority <- liftHandlerT requireAuthId + itAuthority <- liftHandler requireAuthId let itExpiresAt = Just $ Just invDBUserFunctionDeadline itAddAuth = Nothing itStartsAt = Nothing diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 18a94bb9f..40eaadcba 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -2,7 +2,7 @@ module Handler.Utils ( module Handler.Utils ) where -import Import +import Import hiding (link) import qualified Data.Text.Encoding as T import Data.Map ((!)) @@ -38,7 +38,7 @@ sendThisFile File{..} | otherwise = sendResponseStatus noContent204 () -- | Serve a single file, identified through a given DB query -serveOneFile :: Source (YesodDB UniWorX) File -> Handler TypedContent +serveOneFile :: ConduitT () File (YesodDB UniWorX) () -> Handler TypedContent serveOneFile source = do results <- runDB . runConduit $ source .| Conduit.take 2 -- We don't need more than two files to make a decision below case results of @@ -51,7 +51,7 @@ serveOneFile source = do -- | Serve one file directly or a zip-archive of files, identified through a given DB query -- -- Like `serveOneFile`, but sends a zip-archive if multiple results are returned -serveSomeFiles :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent +serveSomeFiles :: FilePath -> ConduitT () File (YesodDB UniWorX) () -> Handler TypedContent serveSomeFiles archiveName source = do results <- runDB . runConduit $ source .| peekN 2 @@ -69,7 +69,7 @@ serveSomeFiles archiveName source = do -- | Serve any number of files as a zip-archive of files, identified through a given DB query -- -- Like `serveSomeFiles`, but always sends a zip-archive, even if a single file is returned -serveZipArchive :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent +serveZipArchive :: FilePath -> ConduitT () File (YesodDB UniWorX) () -> Handler TypedContent serveZipArchive archiveName source = do results <- runDB . runConduit $ source .| peekN 2 @@ -122,7 +122,7 @@ warnTermDays tid timeNames = do -- | return a value only if the current user ist authorized for a given route -guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadLogger h +guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadThrow h , MonadTrans m, MonadPlus (m (ReaderT SqlBackend h))) => Route UniWorX -> a -> m (ReaderT SqlBackend h) a guardAuthorizedFor link val = @@ -138,7 +138,7 @@ runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc studyFeaturesWidget :: StudyFeaturesId -> Widget studyFeaturesWidget featId = do - (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField) + (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandler . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField) [whamlet| $newline never _{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester} diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 2e2ef88c8..933730346 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -71,7 +71,7 @@ instance RenderMessage UniWorX RecipientCategory where data CommunicationRoute = CommunicationRoute { crRecipients :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User))) , crRecipientAuth :: Maybe (UserId -> DB AuthResult) -- ^ Only resolve userids given as GET-Parameter if they fulfil this criterion - , crJobs :: Communication -> Source (YesodDB UniWorX) Job + , crJobs :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crHeading :: SomeMessage UniWorX , crUltDest :: SomeRoute UniWorX } @@ -170,7 +170,7 @@ commR CommunicationRoute{..} = do <*> aopt textField (fslI MsgCommSubject) Nothing <*> areq htmlField (fslpI MsgCommBody "Html") Nothing formResult commRes $ \comm -> do - runDBJobs . runConduit $ hoist (mapReaderT lift) (crJobs comm) .| sinkDBJobs + runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm redirect crUltDest diff --git a/src/Handler/Utils/ContentDisposition.hs b/src/Handler/Utils/ContentDisposition.hs index b353d1bb3..3fa5d579a 100644 --- a/src/Handler/Utils/ContentDisposition.hs +++ b/src/Handler/Utils/ContentDisposition.hs @@ -8,7 +8,7 @@ import Import -- | Check whether the user's preference for files is inline-viewing or downloading downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool downloadFiles = do - mauth <- liftHandlerT maybeAuth + mauth <- liftHandler maybeAuth case mauth of Just (Entity _ User{..}) -> return userDownloadFiles Nothing -> do diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 0ebbb4cdb..7215ae7c8 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -49,7 +49,7 @@ extensionCsv :: Extension extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ] -decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => Conduit ByteString m csv +decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => ConduitT ByteString csv m () decodeCsv = transPipe throwExceptT $ do testBuffer <- accumTestBuffer LBS.empty mapM_ leftover $ LBS.toChunks testBuffer @@ -114,7 +114,7 @@ encodeCsv :: ( ToNamedRecord csv , DefaultOrdered csv , Monad m ) - => Conduit csv m ByteString + => ConduitT csv ByteString m () -- ^ Encode a stream of records -- -- Currently not streaming @@ -124,24 +124,25 @@ encodeCsv = fmap encodeDefaultOrderedByName (C.foldMap pure) >>= C.sourceLazy respondCsv :: ( ToNamedRecord csv , DefaultOrdered csv ) - => Source (HandlerT site IO) csv - -> HandlerT site IO TypedContent + => ConduitT () csv (HandlerFor site) () + -> HandlerFor site TypedContent respondCsv src = respondSource typeCsv' $ src .| encodeCsv .| awaitForever sendChunk respondCsvDB :: ( ToNamedRecord csv , DefaultOrdered csv , YesodPersistRunner site ) - => Source (YesodDB site) csv - -> HandlerT site IO TypedContent + => ConduitT () csv (YesodDB site) () + -> HandlerFor site TypedContent respondCsvDB src = respondSourceDB typeCsv' $ src .| encodeCsv .| awaitForever sendChunk fileSourceCsv :: ( FromNamedRecord csv , MonadResource m , MonadLogger m + , MonadThrow m ) => FileInfo - -> Source m csv + -> ConduitT () csv m () fileSourceCsv = (.| decodeCsv) . fileSource @@ -151,7 +152,7 @@ data CsvRendered = CsvRendered } deriving (Eq, Read, Show, Generic, Typeable) instance ToWidget UniWorX CsvRendered where - toWidget CsvRendered{..} = liftWidgetT $(widgetFile "widgets/csvRendered") + toWidget CsvRendered{..} = liftWidget $(widgetFile "widgets/csvRendered") where csvData = [ [ decodeUtf8 <$> HashMap.lookup columnKey row | columnKey <- Vector.toList csvRenderedHeader diff --git a/src/Handler/Utils/Database.hs b/src/Handler/Utils/Database.hs index 83b299a94..b6f82ced0 100644 --- a/src/Handler/Utils/Database.hs +++ b/src/Handler/Utils/Database.hs @@ -34,10 +34,10 @@ getSchoolsOf uid uschool uuser = fmap (Import.map E.unValue) $ E.select $ E.from -- | Sub-Query to retrieve StudyFeatures with their human-readable names -studyFeaturesQuery :: E.Esqueleto query expr backend - => expr (E.Value StudyFeaturesId) -- ^ query is joined on this @StudyFeaturesId@ - -> expr (Entity StudyFeatures) `E.InnerJoin` expr (Entity StudyDegree) `E.InnerJoin` expr (Entity StudyTerms) - -> query (expr (Entity StudyFeatures), expr (Entity StudyDegree), expr (Entity StudyTerms)) +studyFeaturesQuery + :: E.SqlExpr (E.Value StudyFeaturesId) -- ^ query is joined on this @StudyFeaturesId@ + -> E.SqlExpr (Entity StudyFeatures) `E.InnerJoin` E.SqlExpr (Entity StudyDegree) `E.InnerJoin` E.SqlExpr (Entity StudyTerms) + -> E.SqlQuery (E.SqlExpr (Entity StudyFeatures), E.SqlExpr (Entity StudyDegree), E.SqlExpr (Entity StudyTerms)) studyFeaturesQuery studyFeaturesId (features `E.InnerJoin` degree `E.InnerJoin` terms) = do E.on $ terms E.^. StudyTermsId E.==. features E.^. StudyFeaturesField E.on $ degree E.^. StudyDegreeId E.==. features E.^. StudyFeaturesDegree diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 159ad7779..cf337d3d1 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -75,7 +75,7 @@ instance HasLocalTime UTCTime where instance HasLocalTime TimeOfDay where toLocalTime = LocalTime systemEpochDay -formatTime' :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => String -> t -> m Text +formatTime' :: (HasLocalTime t, MonadHandler m) => String -> t -> m Text formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure (toLocalTime t) -- formatTime :: (FormatTime t, MonadHandler m, HandlerSite m ~ UniWorX, IsString str) => (DateTimeFormat -> String) -> t -> m str @@ -92,12 +92,12 @@ formatTimeW s t = toWidget =<< formatTime s t formatTimeMail :: (MonadMail m, HasLocalTime t) => SelDateTimeFormat -> t -> m Text formatTimeMail sel t = fmap fromString $ Time.formatTime <$> (getTimeLocale' . mailLanguages <$> askMailLanguages) <*> (unDateTimeFormat <$> askMailDateTimeFormat sel) <*> pure (toLocalTime t) -getTimeLocale :: (MonadHandler m, HandlerSite m ~ UniWorX) => m TimeLocale +getTimeLocale :: MonadHandler m => m TimeLocale getTimeLocale = getTimeLocale' <$> languages getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat getDateTimeFormat sel = do - mauth <- liftHandlerT maybeAuth + mauth <- liftHandler maybeAuth UserDefaultConf{..} <- getsYesod $ view _appUserDefaults let fmt diff --git a/src/Handler/Utils/Delete.hs b/src/Handler/Utils/Delete.hs index 65c312fe0..6c5e6a0f2 100644 --- a/src/Handler/Utils/Delete.hs +++ b/src/Handler/Utils/Delete.hs @@ -29,12 +29,12 @@ import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect) import qualified Database.Esqueleto.Internal.Language as E (From) -data DeleteRoute record = forall tables infoExpr info. (E.SqlSelect infoExpr info, E.From E.SqlQuery E.SqlExpr SqlBackend tables) => DeleteRoute +data DeleteRoute record = forall tables infoExpr info. (E.SqlSelect infoExpr info, E.From tables) => DeleteRoute { drRecords :: Set (Key record) -- ^ Records to be deleted , drGetInfo :: tables -> E.SqlQuery infoExpr -- ^ SQL-Query to get necessary information to render identifing information about records to the user (`drRenderRecord`, `drRecordConfirmString`); @tables@ is an arbitrary join, see `E.from`; @infoExpr@ gets converted to @info@ by esqueleto , drUnjoin :: tables -> E.SqlExpr (Entity record) -- ^ `E.SqlExpr` of @Key record@ extracted from @tables@, `deleteR` restricts `drGetInfo` to `drRecords` automatically - , drRenderRecord :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget -- ^ Present a single record, to be deleted, to the user for inspection prior to deletion - , drRecordConfirmString :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Text -- ^ Text for the user to copy to confirm deletion; should probably contain all information from `drRenderRecord` so user gets prompted to think about what they're deleting + , drRenderRecord :: info -> DB Widget -- ^ Present a single record, to be deleted, to the user for inspection prior to deletion + , drRecordConfirmString :: info -> DB Text -- ^ Text for the user to copy to confirm deletion; should probably contain all information from `drRenderRecord` so user gets prompted to think about what they're deleting , drCaption , drSuccessMessage :: SomeMessage UniWorX , drAbort @@ -98,7 +98,7 @@ getDeleteR DeleteRoute{..} = do (deleteFormWdgt, deleteFormEnctype) <- generateFormPost $ confirmForm' drRecords confirmString - Just targetRoute <- getCurrentRoute + targetRoute <- fromMaybe (error "getDeleteR called from 404-handler") <$> getCurrentRoute let deleteForm = wrapForm deleteFormWdgt def { formAction = Just $ SomeRoute targetRoute , formEncoding = deleteFormEnctype diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 20d04f535..716b3a608 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -214,7 +214,7 @@ optionalActionW' minp justAct fs defAction = aFormToWForm $ optionalActionA' min multiAction :: forall action a. - ( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action ) + ( RenderMessage UniWorX action, PathPiece action, Ord action ) => Map action (AForm Handler a) -> FieldSettings UniWorX -> Maybe action @@ -235,22 +235,22 @@ multiAction acts fs@FieldSettings{..} defAction csrf = do return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews) -multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) - => Map action (AForm (HandlerT UniWorX IO) a) +multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action) + => Map action (AForm Handler a) -> FieldSettings UniWorX -> Maybe action -> AForm Handler a multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty -multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) +multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action) => Map action (AForm Handler a) -> FieldSettings UniWorX -> Maybe action -> WForm Handler (FormResult a) multiActionW acts fSettings defAction = aFormToWForm $ multiActionA acts fSettings defAction -multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) - => Map action (AForm (HandlerT UniWorX IO) a) +multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action) + => Map action (AForm Handler a) -> FieldSettings UniWorX -> Maybe action -> (Html -> MForm Handler (FormResult a, Widget)) @@ -279,7 +279,7 @@ routeField :: ( Monad m routeField = checkMMap (return . maybe (Left MsgInvalidRoute) Right . fromPathPiece) toPathPiece textField -- | Variant that simply removes leading and trailing white space -htmlField' :: Field (HandlerT UniWorX IO) Html +htmlField' :: Field Handler Html htmlField' = htmlField { fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis } @@ -444,9 +444,11 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp specificFileForm :: AForm Handler (NonNull (Set UploadSpecificFile)) specificFileForm = wFormToAForm $ do - Just currentRoute <- getCurrentRoute + currentRoute' <- getCurrentRoute let miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) - miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag + miButtonAction frag = do + currentRoute <- currentRoute' + return . SomeRoute $ currentRoute :#: frag miIdent <- ("specific-files--" <>) <$> newIdent postProcess =<< massInputW MassInput{..} (fslI MsgUploadSpecificFiles & setTooltip MsgMassInputTip) True (preProcess <$> prev ^? _Just . _specificFiles) where @@ -659,7 +661,7 @@ pseudonymWordField = checkMMap doCheck id $ ciField & addDatalist (return $ mkOp | otherwise = return . Left $ MsgUnknownPseudonymWord (CI.original w) -specificFileField :: UploadSpecificFile -> Field Handler (Source Handler File) +specificFileField :: UploadSpecificFile -> Field Handler (ConduitT () File Handler ()) specificFileField UploadSpecificFile{..} = Field{..} where fieldEnctype = Multipart @@ -677,7 +679,7 @@ specificFileField UploadSpecificFile{..} = Field{..} zipFileField :: Bool -- ^ Unpack zips? -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions - -> Field Handler (Source Handler File) + -> Field Handler (ConduitT () File Handler ()) zipFileField doUnpack permittedExtensions = Field{..} where fieldEnctype = Multipart @@ -696,7 +698,7 @@ zipFileField doUnpack permittedExtensions = Field{..} fileUploadForm :: Bool -- ^ Required? -> (Bool -> FieldSettings UniWorX) -- ^ given @unpackZips@ generate `FieldSettings` in the case of `UploadAny` - -> UploadMode -> AForm Handler (Maybe (Source Handler File)) + -> UploadMode -> AForm Handler (Maybe (ConduitT () File Handler ())) fileUploadForm isReq mkFs = \case NoUpload -> pure Nothing @@ -705,21 +707,21 @@ fileUploadForm isReq mkFs = \case UploadSpecific{..} -> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles) where - specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (Source Handler File)) + specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (ConduitT () File Handler ())) specificFileForm spec@UploadSpecificFile{..} = bool (\f fs d -> aopt f fs $ fmap Just d) (\f fs d -> Just <$> areq f fs d) specificFileRequired (specificFileField spec) (fsl specificFileLabel) Nothing - mergeFileSources :: [Maybe (Source Handler File)] -> Maybe (Source Handler File) + mergeFileSources :: [Maybe (ConduitT () File Handler ())] -> Maybe (ConduitT () File Handler ()) mergeFileSources (catMaybes -> sources) = case sources of [] -> Nothing fs -> Just $ sequence_ fs -multiFileField' :: Source Handler (Either FileId File) -- ^ Permitted files in same format as produced by `multiFileField` - -> Field Handler (Source Handler (Either FileId File)) +multiFileField' :: ConduitT () (Either FileId File) Handler () -- ^ Permitted files in same format as produced by `multiFileField` + -> Field Handler (ConduitT () (Either FileId File) Handler ()) multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .| C.mapMaybe (preview _Left) .| C.foldMap Set.singleton multiFileField :: Handler (Set FileId) -- ^ Set of files that may be submitted by id-reference - -> Field Handler (Source Handler (Either FileId File)) + -> Field Handler (ConduitT () (Either FileId File) Handler ()) multiFileField permittedFiles' = Field{..} where fieldEnctype = Multipart @@ -735,7 +737,7 @@ multiFileField permittedFiles' = Field{..} .| C.filter (`elem` pVals) .| C.map Left let - handleFile :: FileInfo -> Source Handler File + handleFile :: FileInfo -> ConduitT () File Handler () handleFile | doUnpack = sourceFiles | otherwise = yieldM . acceptFile @@ -899,7 +901,7 @@ utcTimeField = checkMMap (return . localTimeToUTC') utcToLocalTime localTimeFiel langField :: Bool -- ^ Only allow values from `appLanguages` - -> Field (HandlerT UniWorX IO) Lang + -> Field Handler Lang langField False = checkBool langCheck MsgInvalidLangFormat $ textField & addDatalist appLanguagesOpts where langCheck (T.splitOn "-" -> lParts) = all ((&&) <$> not . null <*> T.all Char.isAlpha) lParts @@ -922,7 +924,7 @@ jsonField hide = Field{..} fieldParse [encodeUtf8 -> v] [] = return . bimap (SomeMessage . MsgJSONFieldDecodeFailure) Just $ eitherDecodeStrict' v <|> eitherDecodeStrict' (urlDecode True v) fieldParse [] [] = return $ Right Nothing fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired - fieldView theId name attrs val isReq = liftWidgetT [whamlet| + fieldView theId name attrs val isReq = liftWidget [whamlet| |] fieldEnctype = UrlEncoded @@ -1019,7 +1021,7 @@ fsUniq mkUnique seed = "" { fsName = Just $ mkUnique seed } optionsPersistCryptoId :: forall site backend a msg. ( YesodPersist site , PersistQueryRead backend - , HasCryptoUUID (Key a) (HandlerT site IO) + , HasCryptoUUID (Key a) (HandlerFor site) , RenderMessage site msg , YesodPersistBackend site ~ backend , PersistRecordBackend a backend @@ -1027,7 +1029,7 @@ optionsPersistCryptoId :: forall site backend a msg. => [Filter a] -> [SelectOpt a] -> (a -> msg) - -> HandlerT site IO (OptionList (Entity a)) + -> HandlerFor site (OptionList (Entity a)) optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do mr <- getMessageRender pairs <- runDB $ selectList filts ords @@ -1044,7 +1046,7 @@ examOccurrenceField :: ( MonadHandler m => ExamId -> Field m ExamOccurrenceId examOccurrenceField eid - = hoistField liftHandlerT . selectField . (fmap $ fmap entityKey) + = hoistField liftHandler . selectField . (fmap $ fmap entityKey) $ optionsPersistCryptoId [ ExamOccurrenceExam ==. eid ] [ Asc ExamOccurrenceName ] examOccurrenceName @@ -1080,7 +1082,7 @@ userMatriculationField = Field{..} fieldParse ts _ = runExceptT . fmap Just $ do let ts' = concatMap (Text.splitOn ",") ts forM ts' $ \matr -> do - dbRes <- liftHandlerT . runDB . E.select . E.from $ \user -> do + dbRes <- liftHandler . runDB . E.select . E.from $ \user -> do E.where_ $ E.strip (user E.^. UserMatrikelnummer) `E.ciEq` E.just (E.val $ Text.strip matr) return user case dbRes of @@ -1114,7 +1116,7 @@ multiUserField onlySuggested suggestions = Field{..} rEmails <- case lookupExpr of Nothing -> return [] Just lookupExpr' -> fmap concat . forM uids $ \uid -> do - dbRes <- liftHandlerT . runDB . E.select $ do + dbRes <- liftHandler . runDB . E.select $ do user <- lookupExpr' E.where_ $ user E.^. UserId E.==. E.val uid return $ user E.^. UserEmail @@ -1131,7 +1133,7 @@ multiUserField onlySuggested suggestions = Field{..} |] whenIsJust suggestions $ \suggestions' -> do - suggestedEmails <- fmap (Set.fromList . map E.unValue) . liftHandlerT . runDB . E.select $ do + suggestedEmails <- fmap (Set.fromList . map E.unValue) . liftHandler . runDB . E.select $ do user <- suggestions' return $ user E.^. UserEmail [whamlet| @@ -1147,14 +1149,14 @@ multiUserField onlySuggested suggestions = Field{..} fmap Set.fromList . forM emails $ \(CI.mk -> email) -> case lookupExpr of Nothing -> return $ Left email Just lookupExpr' -> do - dbRes <- liftHandlerT . runDB . E.select $ do + dbRes <- liftHandler . runDB . E.select $ do user <- lookupExpr' E.where_ $ user E.^. UserEmail E.==. E.val email return $ user E.^. UserId case dbRes of [] -> return $ Left email [E.Value uid] -> return $ Right uid - _other -> fail "Ambiguous e-mail addr" + _other -> throwE $ SomeMessage ("Ambiguous e-mail addr" :: Text) examResultField :: forall m res. ( MonadHandler m @@ -1195,11 +1197,11 @@ examGradeField :: forall m. , HandlerSite m ~ UniWorX ) => Field m ExamGrade -examGradeField = hoistField liftHandlerT $ selectField optionsFinite +examGradeField = hoistField liftHandler $ selectField optionsFinite examPassedField :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX ) => Field m ExamPassed -examPassedField = hoistField liftHandlerT $ selectField optionsFinite +examPassedField = hoistField liftHandler $ selectField optionsFinite diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index 87dcc7a85..a0ba3dfb4 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- tupleBoxCoord -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-} module Handler.Utils.Form.MassInput ( MassInput(..), MassInputLayout @@ -271,7 +271,7 @@ massInput :: forall handler cellData cellResult liveliness. ( MonadHandler handler, HandlerSite handler ~ UniWorX , ToJSON cellData, FromJSON cellData , Liveliness liveliness - , MonadLogger handler + , MonadThrow handler ) => MassInput handler liveliness cellData cellResult -> FieldSettings UniWorX @@ -414,7 +414,7 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR MsgRenderer mr <- getMsgRenderer - whenM ((== Just miIdent) <$> lookupCustomHeader HeaderMassInputShortcircuit) . liftHandlerT $ do + whenM ((== Just miIdent) <$> lookupCustomHeader HeaderMassInputShortcircuit) . liftHandler $ do PageContent{..} <- widgetToPageContent $(widgetFile "widgets/massinput/massinput-standalone") ur <- getUrlRenderParams @@ -459,7 +459,7 @@ listMiLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/mas -- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints massInputList :: forall handler cellResult ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX - , MonadLogger handler + , MonadThrow handler , PathPiece ident ) => Field handler cellResult @@ -488,7 +488,7 @@ massInputList field fieldSettings miButtonAction miIdent miSettings miRequired m massInputListA :: forall handler cellResult ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX - , MonadLogger handler + , MonadThrow handler , PathPiece ident ) => Field handler cellResult @@ -505,7 +505,7 @@ massInputListA field fieldSettings miButtonAction miIdent miSettings miRequired -- | Wrapper around `massInput` for the common case, that we just want a list of data with no option to modify it except deletion and addition massInputAccum :: forall handler cellData ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX - , MonadLogger handler + , MonadThrow handler , ToJSON cellData, FromJSON cellData , PathPiece ident ) @@ -544,7 +544,7 @@ massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequire massInputAccumA :: forall handler cellData ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX - , MonadLogger handler + , MonadThrow handler , ToJSON cellData, FromJSON cellData , PathPiece ident ) @@ -562,7 +562,7 @@ massInputAccumA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fReq massInputAccumW :: forall handler cellData ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX - , MonadLogger handler + , MonadThrow handler , ToJSON cellData, FromJSON cellData , PathPiece ident ) @@ -582,7 +582,7 @@ massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fReq -- | Wrapper around `massInput` for the common case, that we just want a list of data with existing data modified the same way as new data is added massInputAccumEdit :: forall handler cellData ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX - , MonadLogger handler + , MonadThrow handler , ToJSON cellData, FromJSON cellData , PathPiece ident ) @@ -621,7 +621,7 @@ massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fReq massInputAccumEditA :: forall handler cellData ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX - , MonadLogger handler + , MonadThrow handler , ToJSON cellData, FromJSON cellData , PathPiece ident ) @@ -639,7 +639,7 @@ massInputAccumEditA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings massInputAccumEditW :: forall handler cellData ident. ( MonadHandler handler, HandlerSite handler ~ UniWorX - , MonadLogger handler + , MonadThrow handler , ToJSON cellData, FromJSON cellData , PathPiece ident ) @@ -660,7 +660,7 @@ massInputA :: forall handler cellData cellResult liveliness. ( MonadHandler handler, HandlerSite handler ~ UniWorX , ToJSON cellData, FromJSON cellData , Liveliness liveliness - , MonadLogger handler + , MonadThrow handler ) => MassInput handler liveliness cellData cellResult -> FieldSettings UniWorX @@ -674,7 +674,7 @@ massInputW :: forall handler cellData cellResult liveliness. ( MonadHandler handler, HandlerSite handler ~ UniWorX , ToJSON cellData, FromJSON cellData , Liveliness liveliness - , MonadLogger handler + , MonadThrow handler ) => MassInput handler liveliness cellData cellResult -> FieldSettings UniWorX diff --git a/src/Handler/Utils/Form/Occurrences.hs b/src/Handler/Utils/Form/Occurrences.hs index ced9c3c0b..1486ff192 100644 --- a/src/Handler/Utils/Form/Occurrences.hs +++ b/src/Handler/Utils/Form/Occurrences.hs @@ -31,9 +31,10 @@ nullaryPathPiece ''OccurrenceExceptionKind $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''OccurrenceExceptionKind id +{-# ANN occurrencesAForm ("HLint: ignore Use const" :: String) #-} occurrencesAForm :: PathPiece ident => ident -> Maybe Occurrences -> AForm Handler Occurrences occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do - Just cRoute <- getCurrentRoute + cRoute <- fromMaybe (error "occurrencesAForm called from 404-handler") <$> getCurrentRoute let scheduled :: AForm Handler (Set OccurrenceSchedule) diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index b1618fc99..c7ea02cb3 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -1,5 +1,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Handler.Utils.Invitations ( -- * Procedure @@ -38,7 +39,7 @@ import qualified Data.Aeson as JSON import Data.Proxy (Proxy(..)) import Data.Typeable -import Database.Persist.Sql (SqlBackendCanWrite, SqlBackendCanRead) +import Database.Persist.Sql (SqlBackendCanWrite) class ( PersistRecordBackend junction (YesodPersistBackend UniWorX) @@ -169,11 +170,13 @@ instance IsInvitableJunction junction => FromJSON (InvitationTokenRestriction ju sinkInvitations :: forall junction m backend. ( IsInvitableJunction junction - , MonadHandler m, SqlBackendCanWrite backend + , MonadHandler m + , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend + , HasPersistBackend backend , HandlerSite m ~ UniWorX ) => InvitationConfig junction - -> Sink (Invitation' junction) (ReaderT backend (WriterT (Set QueuedJobId) m)) () + -> ConduitT (Invitation' junction) Void (ReaderT backend (WriterT (Set QueuedJobId) m)) () -- | Register invitations in the database and send them by email -- -- When an invitation for a certain junction (i.e. an `UserEmail`, `Key @@ -181,9 +184,10 @@ sinkInvitations :: forall junction m backend. -- (because the token-data may have changed) sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations' where - determineExists :: Conduit (Invitation' junction) - (ReaderT backend (WriterT (Set QueuedJobId) m)) - (Invitation' junction) + determineExists :: ConduitT (Invitation' junction) + (Invitation' junction) + (ReaderT backend (WriterT (Set QueuedJobId) m)) + () determineExists | is _Just (ephemeralInvitation @junction) = C.map id @@ -203,10 +207,10 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations' decode invData = case fromJSON invData of JSON.Success dbData -> return dbData - JSON.Error str -> fail $ "Could not decode invitationData: " <> str + JSON.Error str -> throwM . PersistMarshalError . pack $ "Could not decode invitationData: " <> str - sinkInvitations' :: Sink (Invitation' junction) (ReaderT backend (WriterT (Set QueuedJobId) m)) () - sinkInvitations' = transPipe (hoist (hoist liftHandlerT) . withReaderT persistBackend) $ do + sinkInvitations' :: ConduitT (Invitation' junction) Void (ReaderT backend (WriterT (Set QueuedJobId) m)) () + sinkInvitations' = transPipe (hoist (hoist liftHandler) . withReaderT persistBackend) $ do C.mapM_ $ \(jInvitee, fid, dat) -> do app <- getYesod let mr = renderMessage app $ NonEmpty.toList appLanguages @@ -214,15 +218,15 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations' fEnt <- Entity fid <$> get404 fid - jInviter <- liftHandlerT requireAuthId - route <- mapReaderT liftHandlerT $ invitationRoute fEnt dat - InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fEnt dat + jInviter <- liftHandler requireAuthId + route <- mapReaderT liftHandler $ invitationRoute fEnt dat + InvitationTokenConfig{..} <- mapReaderT liftHandler $ invitationTokenConfig fEnt dat protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData) jwt <- encodeToken token jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)]) - jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fEnt dat - jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandlerT (invitationExplanation fEnt dat) + jInvitationSubject <- fmap mr . mapReaderT liftHandler $ invitationSubject fEnt dat + jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandler (invitationExplanation fEnt dat) when (is _Nothing (ephemeralInvitation @junction)) $ insert_ $ Invitation { invitationEmail = jInvitee @@ -237,7 +241,10 @@ sinkInvitationsF :: forall junction mono m backend. ( IsInvitableJunction junction , MonoFoldable mono , Element mono ~ Invitation' junction - , MonadHandler m, SqlBackendCanWrite backend + , MonadHandler m + , MonadThrow m + , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend + , HasPersistBackend backend , HandlerSite m ~ UniWorX ) => InvitationConfig junction @@ -248,7 +255,10 @@ sinkInvitationsF cfg invs = runConduit $ mapM_ yield invs .| sinkInvitations cfg sinkInvitation :: forall junction m backend. ( IsInvitableJunction junction - , MonadHandler m, SqlBackendCanWrite backend + , MonadHandler m + , MonadThrow m + , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend + , HasPersistBackend backend , HandlerSite m ~ UniWorX ) => InvitationConfig junction @@ -260,23 +270,29 @@ sinkInvitation cfg = sinkInvitationsF cfg . Identity sourceInvitations :: forall junction m backend. ( IsInvitableJunction junction - , MonadResource m, SqlBackendCanRead backend + , MonadResource m + , MonadThrow m + , PersistRecordBackend Invitation backend + , HasPersistBackend backend ) => Key (InvitationFor junction) - -> Source (ReaderT backend m) (UserEmail, InvitationDBData junction) + -> ConduitT () (UserEmail, InvitationDBData junction) (ReaderT backend m) () sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode where decode (Entity _ (Invitation{invitationEmail, invitationData})) = case fromJSON invitationData of JSON.Success dbData -> return (invitationEmail, dbData) - JSON.Error str -> fail $ "Could not decode invitationData: " <> str + JSON.Error str -> throwM . PersistMarshalError . pack $ "Could not decode invitationData: " <> str sourceInvitationsF :: forall junction map m backend. ( IsInvitableJunction junction , IsMap map , ContainerKey map ~ UserEmail , MapValue map ~ InvitationDBData junction - , MonadResource m, SqlBackendCanRead backend + , MonadResource m + , MonadThrow m + , PersistRecordBackend Invitation backend + , HasPersistBackend backend ) => Key (InvitationFor junction) -> ReaderT backend m map @@ -291,15 +307,17 @@ sourceInvitationsF forKey = runConduit $ sourceInvitations forKey .| C.foldMap ( -- > runConduit $ yield userEmail .| deleteInvitations @SubmissionUser submissionId deleteInvitations :: forall junction m backend. ( IsInvitableJunction junction - , MonadIO m, SqlBackendCanWrite backend + , MonadIO m + , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend ) => Key (InvitationFor junction) - -> Sink UserEmail (ReaderT backend m) () + -> ConduitT UserEmail Void (ReaderT backend m) () deleteInvitations k = C.foldMap Set.singleton >>= lift . deleteInvitationsF @junction k deleteInvitationsF :: forall junction m mono backend. ( IsInvitableJunction junction - , MonadIO m, SqlBackendCanWrite backend + , MonadIO m + , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend , MonoFoldable mono , Element mono ~ UserEmail ) @@ -312,7 +330,8 @@ deleteInvitationsF invitationFor (otoList -> emailList) deleteInvitation :: forall junction m backend. ( IsInvitableJunction junction - , MonadIO m, SqlBackendCanWrite backend + , MonadIO m + , PersistRecordBackend Invitation backend, SqlBackendCanWrite backend ) => Key (InvitationFor junction) -> UserEmail @@ -344,10 +363,10 @@ invitationR' :: forall junction m. => InvitationConfig junction -> m Html -- | Generic handler for incoming invitations -invitationR' InvitationConfig{..} = liftHandlerT $ do +invitationR' InvitationConfig{..} = liftHandler $ do InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return requireCurrentTokenRestrictions :: Handler (InvitationTokenRestriction junction) invitee <- requireAuthId - Just cRoute <- getCurrentRoute + cRoute <- fromMaybe (error "invitationR' called from 404-handler") <$> getCurrentRoute (tRoute, (dataWidget, dataEnctype), heading, explanation) <- runDB $ do fEnt@(Entity fid _) <- invitationResolveFor itData >>= (\k -> Entity k <$> get404 k) @@ -356,7 +375,7 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do Invitation{..} <- entityVal <$> getBy404 (UniqueInvitation itEmail $ invRef @junction fid) case fromJSON invitationData of JSON.Success dbData -> return dbData - JSON.Error str -> fail $ "Could not decode invitationData: " <> str + JSON.Error str -> throwM . PersistMarshalError $ "Could not decode invitationData: " <> pack str Just (cloneIso -> _DBData) -> return $ view _DBData () let iData :: InvitationData junction diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index e370676d5..726d7c975 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -19,11 +19,10 @@ import Control.Monad.Trans.State (StateT) addRecipientsDB :: ( MonadMail m - , MonadHandler m , HandlerSite m ~ UniWorX ) => [Filter User] -> m () -- ^ @setRecipientId uid@ throws an exception if @uid@ does not refer to an existing user -addRecipientsDB uFilter = runConduit $ transPipe (liftHandlerT . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient +addRecipientsDB uFilter = runConduit $ transPipe (liftHandler . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient where addRecipient (Entity _ User{userEmail, userDisplayName}) = do let addr = Address (Just userDisplayName) $ CI.original userEmail @@ -34,8 +33,8 @@ userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $ userMailT :: ( MonadHandler m , HandlerSite m ~ UniWorX - , MonadBaseControl IO m - , MonadLogger m + , MonadThrow m + , MonadUnliftIO m ) => UserId -> MailT m a -> m a userMailT uid mAct = do user@User @@ -43,7 +42,7 @@ userMailT uid mAct = do , userDateTimeFormat , userDateFormat , userTimeFormat - } <- liftHandlerT . runDB $ getJust uid + } <- liftHandler . runDB $ getJust uid let ctx = MailContext { mcLanguages = userMailLanguages @@ -57,14 +56,13 @@ userMailT uid mAct = do mAct addFileDB :: ( MonadMail m - , MonadHandler m , HandlerSite m ~ UniWorX - ) => FileId -> m MailObjectId -addFileDB fId = do - File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- liftHandlerT . runDB $ getJust fId - addPart $ do + ) => FileId -> m (Maybe MailObjectId) +addFileDB fId = runMaybeT $ do + File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- MaybeT . liftHandler . runDB $ get fId + lift . addPart $ do _partType .= decodeUtf8 (mimeLookup fileName) _partEncoding .= Base64 _partFilename .= Just fileName _partContent .= LBS.fromStrict fileContent - setMailObjectIdCrypto fId :: StateT Part (HandlerT UniWorX IO) MailObjectId + setMailObjectIdCrypto fId :: StateT Part (HandlerFor UniWorX) MailObjectId diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index ecc5af873..2292ccfed 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -133,7 +133,7 @@ ratingFile cID rating@Rating{ ratingValues = Rating'{..}, .. } = do parseRating :: MonadThrow m => File -> m Rating' parseRating File{ fileContent = Just input, .. } = do - inputText <- either (throw . RatingNotUnicode) return $ Text.decodeUtf8' input + inputText <- either (throwM . RatingNotUnicode) return $ Text.decodeUtf8' input let (headerLines', commentLines) = break (commentSep `Text.isInfixOf`) $ Text.lines inputText (reverse -> ratingLines, reverse -> _headerLines) = break (sep' `Text.isInfixOf`) $ reverse headerLines' @@ -143,20 +143,20 @@ parseRating File{ fileContent = Just input, .. } = do rating = "Bewertung:" comment' <- case commentLines of (_:commentLines') -> return . Text.strip $ Text.unlines commentLines' - _ -> throw RatingMissingSeparator + _ -> throwM RatingMissingSeparator let ratingComment | Text.null comment' = Nothing | otherwise = Just comment' ratingLine' <- case ratingLines' of [l] -> return l - _ -> throw RatingMultiple + _ -> throwM RatingMultiple let (_, ratingLine) = Text.breakOnEnd rating ratingLine' ratingStr = Text.unpack $ Text.strip ratingLine ratingPoints <- case () of _ | null ratingStr -> return Nothing - | otherwise -> either (throw . RatingInvalid . pack) return $ Just <$> readEither ratingStr + | otherwise -> either (throwM . RatingInvalid . pack) return $ Just <$> readEither ratingStr return Rating'{ ratingTime = Just fileModified, .. } parseRating _ = throwM RatingFileIsDirectory @@ -166,7 +166,7 @@ type SubmissionContent = Either File (SubmissionId, Rating') extractRatings :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m - ) => Conduit File m SubmissionContent + ) => ConduitT File SubmissionContent m () extractRatings = Conduit.mapM $ \f@File{..} -> do msId <- isRatingFile fileTitle case () of diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs index b3161ac89..58a873228 100644 --- a/src/Handler/Utils/Sheet.hs +++ b/src/Handler/Utils/Sheet.hs @@ -16,13 +16,11 @@ sheetFileTypeDates Sheet{..} = \case SheetMarking -> Nothing -fetchSheetAux :: ( BaseBackend backend ~ SqlBackend - , E.SqlSelect b a - , Typeable a, MonadHandler m, IsPersistBackend backend - , PersistQueryRead backend, PersistUniqueRead backend +fetchSheetAux :: ( E.SqlSelect b a + , Typeable a, MonadHandler m ) => (E.SqlExpr (Entity Sheet) -> E.SqlExpr (Entity Course) -> b) - -> TermId -> SchoolId -> CourseShorthand -> SheetName -> ReaderT backend m a + -> TermId -> SchoolId -> CourseShorthand -> SheetName -> SqlReadT m a fetchSheetAux prj tid ssh csh shn = let cachId = encodeUtf8 $ tshow (tid, ssh, csh, shn) in cachedBy cachId $ do diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index bafc69e84..383e7fe4e 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -252,7 +252,7 @@ planSubmissions sid restriction = do unstableSortBy cmp = fmap concat . mapM Rand.shuffleM . groupBy (\a b -> cmp a b == EQ) . sortBy cmp -submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File) +submissionFileSource :: SubmissionId -> ConduitT () (Entity File) (YesodDB UniWorX) () submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File) @@ -285,7 +285,7 @@ submissionMultiArchive (Set.toList -> ids) = do setContentDisposition' $ Just ((addExtension `on` unpack) archiveName extensionZip) (<* cleanup) . respondSource typeZip . transPipe (runDBRunner dbrunner) $ do let - fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId)) -> Source (YesodDB UniWorX) File + fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId)) -> ConduitT () File (YesodDB UniWorX) () fileEntitySource' (rating, Entity submissionID Submission{..},(shn,csh,ssh,tid)) = do cID <- encrypt submissionID @@ -301,7 +301,7 @@ submissionMultiArchive (Set.toList -> ids) = do | otherwise = submissionDirectory fileEntitySource = do - submissionFileSource submissionID =$= Conduit.map entityVal + submissionFileSource submissionID .| Conduit.map entityVal yieldM (ratingFile cID rating) withinDirectory f@File{..} = f { fileTitle = directoryName fileTitle } @@ -316,9 +316,9 @@ submissionMultiArchive (Set.toList -> ids) = do , fileContent = Nothing } - fileEntitySource =$= mapC withinDirectory + fileEntitySource .| mapC withinDirectory - mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder + mapM_ fileEntitySource' ratedSubmissions .| produceZip def .| Conduit.map toFlushBuilder @@ -331,9 +331,12 @@ data SubmissionSinkState = SubmissionSinkState , sinkFilenames :: Set FilePath } deriving (Show, Eq, Generic, Typeable) +instance Semigroup SubmissionSinkState where + (<>) = mappenddefault + instance Monoid SubmissionSinkState where mempty = memptydefault - mappend = mappenddefault + mappend = (<>) filterSubmission :: MonadLogger m => ConduitM File File m (Set FilePath) -- ^ Removes all `File`s matching `submissionBlacklist`, returning their `fileTitle`s @@ -351,15 +354,13 @@ filterSubmission = do extractRatings :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m - , MonadLogger m ) => ConduitM File SubmissionContent m (Set FilePath) extractRatings = filterSubmission `fuseUpstream` Rating.extractRatings extractRatingsMsg :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m - , MonadLogger m - ) => Conduit File m SubmissionContent + ) => ConduitT File SubmissionContent m () extractRatingsMsg = do ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings let ignoredFiles :: Set (Either CryptoFileNameSubmission FilePath) @@ -385,7 +386,7 @@ msgSubmissionErrors = flip catches sinkSubmission :: UserId -> Either SheetId SubmissionId -> Bool -- ^ Is this a correction - -> Sink SubmissionContent (YesodJobDB UniWorX) SubmissionId + -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) SubmissionId -- ^ Replace the currently saved files for the given submission (either -- corrected files or original ones, depending on arguments) with the supplied -- 'SubmissionContent'. @@ -420,7 +421,7 @@ sinkSubmission userId mExists isUpdate = do where tellSt = modify . mappend - guardFileTitles :: MonadThrow m => SubmissionMode -> Conduit SubmissionContent m SubmissionContent + guardFileTitles :: MonadThrow m => SubmissionMode -> ConduitT SubmissionContent SubmissionContent m () guardFileTitles SubmissionMode{..} | Just UploadAny{..} <- submissionModeUser , not isUpdate @@ -435,7 +436,7 @@ sinkSubmission userId mExists isUpdate = do | otherwise = Conduit.map id sinkSubmission' :: SubmissionId - -> Sink SubmissionContent (YesodJobDB UniWorX) () + -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) () sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case Left file@(File{..}) -> do $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle) @@ -628,7 +629,7 @@ sinkSubmission userId mExists isUpdate = do sinkMultiSubmission :: UserId -> Bool {-^ Are these corrections -} - -> Sink SubmissionContent (YesodJobDB UniWorX) (Set SubmissionId) + -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) (Set SubmissionId) -- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'. -- @@ -666,7 +667,7 @@ sinkMultiSubmission userId isUpdate = do v@(Right (sId, _)) -> do cID <- encrypt sId $logDebugS "sinkMultiSubmission" $ "Feeding rating for " <> toPathPiece cID - lift (feed sId v) `catches` [ E.Handler (throwM . SubmissionSinkException cID Nothing), E.Handler (void . handleHCError (Left cID)) ] + lift (feed sId v `catches` [ E.Handler (throwM . SubmissionSinkException cID Nothing), E.Handler (void . handleHCError (Left cID)) ]) (Left f@File{..}) -> do let acc :: (Maybe SubmissionId, [FilePath]) -> FilePath -> _ (Maybe SubmissionId, [FilePath]) @@ -678,7 +679,7 @@ sinkMultiSubmission userId isUpdate = do sId <- decrypt (cID :: CryptoFileNameSubmission) Just sId <$ get404 sId | otherwise = return Nothing - msId <- lift (lift $ tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ] + msId <- lift (lift (tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ]) return (msId, fp) (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle case msId of @@ -687,8 +688,8 @@ sinkMultiSubmission userId isUpdate = do Just sId -> do $logDebugS "sinkMultiSubmission" $ "Feeding " <> tshow (splitDirectories fileTitle, msId, fileTitle') cID <- encrypt sId - handle (throwM . SubmissionSinkException cID (Just fileTitle)) $ - lift . feed sId $ Left f{ fileTitle = fileTitle' } + lift . handle (throwM . SubmissionSinkException cID (Just fileTitle)) $ + feed sId $ Left f{ fileTitle = fileTitle' } when (not $ null ignoredFiles) $ do mr <- (toHtml .) <$> getMessageRender addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr) diff --git a/src/Handler/Utils/Table.hs b/src/Handler/Utils/Table.hs index 2e204b2cc..bf4ca6f13 100644 --- a/src/Handler/Utils/Table.hs +++ b/src/Handler/Utils/Table.hs @@ -1,100 +1,7 @@ module Handler.Utils.Table ( module Handler.Utils.Table ) where --- General Utilities for Tables - -import Import - -import Control.Monad.Except - -import Text.Blaze as B - -import Colonnade -import Yesod.Colonnade as Yesod - -import Data.List ((!!)) -import Data.Either import Handler.Utils.Table.Pagination as Handler.Utils.Table import Handler.Utils.Table.Columns as Handler.Utils.Table import Handler.Utils.Table.Cells as Handler.Utils.Table - - --- Table design -{-# DEPRECATED tableDefault, tableSortable "Use dbTable" #-} -tableDefault :: Attribute -tableDefault = customAttribute "class" "table table-striped table-hover" - -tableSortable :: Attribute -tableSortable = customAttribute "class" "js-sortable" - --- Colonnade Tools -{-# DEPRECATED numberColonnade, pairColonnade "Use dbTable" #-} -numberColonnade :: (IsString c) => Colonnade Headed Int c -numberColonnade = headed "Nr" (fromString.show) - -pairColonnade :: (Functor h) => Colonnade h a c -> Colonnade h b c -> Colonnade h (a,b) c -pairColonnade a b = mconcat [ lmap fst a, lmap snd b] - - --- Table Modification -{-# DEPRECATED encodeHeadedWidgetTableNumbered, headedRowSelector "Use dbTable" #-} -encodeHeadedWidgetTableNumbered :: Attribute -> Colonnade Headed a (WidgetT site IO ()) -> [a] -> WidgetT site IO () -encodeHeadedWidgetTableNumbered attrs colo tdata = - encodeWidgetTable attrs (mconcat [numberCol, lmap snd colo]) (zip [1..] tdata) - where - numberCol :: Colonnade Headed (Int,a) (WidgetT site IO ()) - numberCol = headed "Nr" (fromString.show.fst) - -headedRowSelector :: ( PathPiece b - , Eq b - ) - => (a -> Handler b) - -> (b -> Handler c) - -> Attribute - -> Colonnade Headed a (Cell UniWorX) - -> [a] - -> MForm Handler (FormResult [c], Widget) -headedRowSelector toExternal fromExternal attrs colonnade tdata = do - externalIds <- mapM (lift . toExternal) tdata - - let - checkbox extId = Field{..} - where - fieldEnctype = UrlEncoded - - fieldParse [] _ = return $ Right Nothing - fieldParse optlist _ = runExceptT $ do - extIds <- maybe (throwError "Error parsing values") return $ mapM fromPathPiece optlist - case () of - _ | extId `elem` extIds - -> Just <$> lift (fromExternal extId) - | otherwise - -> return Nothing - - fieldView theId name attributes val _ = - -- TODO: move this to a *.hamlet file - [whamlet| -

+
^{widget} diff --git a/test/Database.hs b/test/Database.hs index 280bcead3..a4e62b465 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -7,7 +7,7 @@ module Database import "uniworx" Import hiding (Option(..)) import "uniworx" Application (db, getAppDevSettings) -import Data.Pool (destroyAllResources) +import UnliftIO.Pool (destroyAllResources) import Database.Persist.Postgresql import Control.Monad.Logger @@ -25,6 +25,8 @@ import Control.Monad.Random.Class (MonadRandom(..)) import qualified Data.Set as Set +import Database.Persist.Sql.Raw.QQ + data DBAction = DBClear | DBTruncate @@ -48,7 +50,7 @@ main = do DBClear -> runStderrLoggingT $ do -- We don't use `db` here, since we do /not/ want any migrations to run, yet settings <- liftIO getAppDevSettings withPostgresqlConn (pgConnStr $ appDatabaseConf settings) . runSqlConn $ do - rawExecute "drop owned by current_user;" [] + [executeQQ|drop owned by current_user|] :: ReaderT SqlBackend _ () DBTruncate -> db $ do foundation <- getYesod liftIO . destroyAllResources $ appConnPool foundation diff --git a/test/Handler/Utils/ZipSpec.hs b/test/Handler/Utils/ZipSpec.hs index eaa471881..667edad18 100644 --- a/test/Handler/Utils/ZipSpec.hs +++ b/test/Handler/Utils/ZipSpec.hs @@ -19,7 +19,7 @@ spec = describe "Zip file handling" $ do it "has compatible encoding/decoding to/from zip files" . property $ do zipFiles <- listOf $ scale (`div` 2) arbitrary return . property $ do - zipFiles' <- runConduit $ Conduit.sourceList zipFiles =$= produceZip def =$= void consumeZip =$= Conduit.consume + zipFiles' <- runConduit $ Conduit.sourceList zipFiles .| produceZip def .| void consumeZip .| Conduit.consume forM_ (zipFiles `zip` zipFiles') $ \(file, file') -> do let acceptableFilenameChanges = makeValid . dropWhile isPathSeparator . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator (isNothing $ fileContent file) . normalise . makeValid diff --git a/test/Test/QuickCheck/Classes/JSON.hs b/test/Test/QuickCheck/Classes/JSON.hs index 78d586ec3..5d323bbcb 100644 --- a/test/Test/QuickCheck/Classes/JSON.hs +++ b/test/Test/QuickCheck/Classes/JSON.hs @@ -24,7 +24,7 @@ jsonKeyLaws _ = Laws "ToJSONKey/FromJSONKey" ) ] where - partialIsomorphism :: forall a'. (Arbitrary a', FromJSONKey a', ToJSONKey a', Eq a', Show a') => a' -> Property + partialIsomorphism :: forall a'. (FromJSONKey a', ToJSONKey a', Eq a') => a' -> Property partialIsomorphism a = case (toJSONKey, fromJSONKey) of (ToJSONKeyText toVal _, FromJSONKeyCoerce _) -> property $ unsafeCoerce (toVal a) == a diff --git a/test/TestImport.hs b/test/TestImport.hs index 61b96ab43..d14c8ae07 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -4,7 +4,13 @@ module TestImport ) where import Application (makeFoundation, makeLogWare, shutdownApp) -import ClassyPrelude as X hiding (delete, deleteBy, Handler, Index, (<.>), (<|), index, uncons, unsnoc, cons, snoc) +import ClassyPrelude as X + hiding ( delete, deleteBy + , Handler, Index + , (<.>), (<|) + , index, uncons, unsnoc, cons, snoc + , try, catches, handle, catch, bracket, bracketOnError, bracket_, catchJust, finally, handleJust, mask, mask_, onException, tryJust, uninterruptibleMask, uninterruptibleMask_ + ) import Database.Persist as X hiding (get) import Database.Persist.Sql as X (SqlPersistM) import Database.Persist.Sql (runSqlPersistMPool) @@ -42,7 +48,9 @@ import Net.IP as X (IP) import Database (truncateDb) import Database as X (fillDb) -import Control.Monad.Trans.Resource (runResourceT, MonadResourceBase) +import Control.Monad.Catch as X hiding (Handler(..)) + +import Control.Monad.Trans.Resource (runResourceT) import Settings @@ -84,7 +92,7 @@ withApp = around $ \act -> runResourceT $ do -- This function will truncate all of the tables in your database. -- 'withApp' calls it before each test, creating a clean environment for each -- spec to run in. -wipeDB :: (MonadResourceBase m, MonadMask m) => UniWorX -> m () +wipeDB :: MonadUnliftIO m => UniWorX -> m () wipeDB app = runDBWithApp app Database.truncateDb -- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag From fe07a226e9d5ee3195067e45d9c41d730218c7a2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 25 Sep 2019 14:24:19 +0200 Subject: [PATCH 18/28] feat(exam-users): document part-* family of columns --- messages/uniworx/de.msg | 1 + src/Handler/Exam/Users.hs | 1 + 2 files changed, 2 insertions(+) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index fecc3beb2..8a24388d0 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1509,6 +1509,7 @@ CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilneh CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer bestanden hat CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Prüfungstermin bestehen hätte können CsvColumnExamUserBonus: Anzurechnende Bonuspunkte +CsvColumnExamUserParts: Erreichte Punktezahlen in den Teilprüfungen, sofern vorhanden; eine Spalte pro Teilprüfung CsvColumnExamUserResult: Erreichte Prüfungsleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0") CsvColumnExamUserCourseNote: Notizen zum Teilnehmer diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 496bff9d8..a7f4f71e0 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -266,6 +266,7 @@ instance CsvColumnsExplained ExamUserTableCsv where , single "exercise-points-max" MsgCsvColumnExamUserExercisePointsMax , single "exercise-num-passes-max" MsgCsvColumnExamUserExercisePassesMax , single "bonus" MsgCsvColumnExamUserBonus + , single "part-*" MsgCsvColumnExamUserParts , single "exam-result" MsgCsvColumnExamUserResult , single "course-note" MsgCsvColumnExamUserCourseNote ] From 756fa492e3da0ceef7712b01e0290124f20e1245 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 25 Sep 2019 15:01:55 +0200 Subject: [PATCH 19/28] chore: bump process for stack >=2 --- stack.yaml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/stack.yaml b/stack.yaml index 613d3543a..46618df8e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -56,5 +56,7 @@ extra-deps: - persistent-qq-2.9.1 + - process-1.6.5.1 + resolver: lts-13.21 allow-newer: true From 0241cda78a82bb04f15923d5d76a6ec637307a47 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 25 Sep 2019 17:36:18 +0200 Subject: [PATCH 20/28] chore: allow building of specific haddocks --- haddock.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock.sh b/haddock.sh index 13bb626e0..00308065f 100755 --- a/haddock.sh +++ b/haddock.sh @@ -15,4 +15,4 @@ if [[ -d .stack-work-doc ]]; then trap move-back EXIT fi -stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal +stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal ${@} From 7a2b972f9f78817688b344ac269ba99694f0854a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 25 Sep 2019 17:36:48 +0200 Subject: [PATCH 21/28] fix(communication): make communication form more intuitive Fixes #387 --- messages/uniworx/de.msg | 2 + src/Handler/Sheet.hs | 6 +-- src/Handler/Utils/Communication.hs | 10 ++-- src/Handler/Utils/Csv.hs | 41 +---------------- src/Import/NoModel.hs | 4 ++ src/Jobs/Handler/SendCourseCommunication.hs | 12 ++--- src/Mail.hs | 43 +++++++++++++---- src/Network/Mail/Mime/Instances.hs | 12 +++++ src/Settings.hs | 18 +------- src/Settings/Mime.hs | 31 +++++++++++++ src/Utils/Csv.hs | 51 ++++++++++++++++++++- 11 files changed, 151 insertions(+), 79 deletions(-) create mode 100644 src/Settings/Mime.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 8a24388d0..41e50c599 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1135,8 +1135,10 @@ NavigationFavourites: Favoriten CommSubject: Betreff CommBody: Nachricht +CommBodyTip: Das Eingabefeld akzeptiert derzeit ausschließlich Html. U.A. Zeilumbrüche werden dementsprechend ignoriert und müssen manuell mit
eingefügt werden. CommRecipients: Empfänger CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht +CommRecipientsList: Die an Sie selbst verschickte Kopie der Nachricht wird, zu Archivierungszwecken, eine vollständige Liste aller Empfänger enthalten. Die Empfängerliste wird im CSV-Format and die E-Mail angehängt. Andere Empfänger erhalten die Liste nicht. Bitte entfernen Sie dementsprechend den Anhang bevor Sie die E-Mail weiterleiten oder anderweitig mit Dritten teilen. CommDuplicateRecipients n@Int: #{n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert CommSuccess n@Int: Nachricht wurde an #{n} Empfänger versandt diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 06d200c2a..7d521389f 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -686,7 +686,7 @@ defaultLoads shid = do return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState) where toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads - toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton (Right uid) (state, load) + toMap = foldMap $ \(E.Value uid, E.Value cLoad, E.Value cState) -> Map.singleton (Right uid) (cState, cLoad) correctorForm :: SheetId -> AForm Handler (Set (Either (Invitation' SheetCorrector) SheetCorrector)) @@ -809,7 +809,7 @@ correctorForm shid = wFormToAForm $ do postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either (Invitation' SheetCorrector) SheetCorrector postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..} - postProcess' (Left email, (state, load)) = Left (email, shid, (InvDBDataSheetCorrector load state, InvTokenDataSheetCorrector)) + postProcess' (Left email, (cState, load)) = Left (email, shid, (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector)) filledData :: Maybe (Map ListPosition (Either UserEmail UserId, (CorrectorState, Load))) filledData = Just . Map.fromList . zip [0..] $ Map.toList loads -- TODO orderBy Name?! @@ -906,7 +906,7 @@ correctorInvitationConfig = InvitationConfig{..} itAuthority <- liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized - invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ (JunctionSheetCorrector load state, ()) + invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure $ (JunctionSheetCorrector cLoad cState, ()) invitationInsertHook _ _ _ _ = id invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName invitationUltDest (Entity _ Sheet{..}) _ = do diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 933730346..da9ed5a2e 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -150,9 +150,9 @@ commR CommunicationRoute{..} = do -> Map (EnumPosition RecipientCategory, ListPosition) (FieldView UniWorX) -> Map (Natural, (EnumPosition RecipientCategory, ListPosition)) Widget -> Widget - miLayout liveliness state cellWdgts _delButtons addWdgts = do + miLayout liveliness cState cellWdgts _delButtons addWdgts = do checkedIdentBase <- newIdent - let checkedCategories = Set.mapMonotonic (unEnumPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False state) $ Map.keysSet state + let checkedCategories = Set.mapMonotonic (unEnumPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c hasContent c = not (null $ categoryIndices c) || Map.member (1, (EnumPosition c, 0)) addWdgts categoryIndices c = Set.filter ((== c) . unEnumPosition . fst) $ review liveCoords liveliness @@ -165,10 +165,13 @@ commR CommunicationRoute{..} = do postProcess :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId) postProcess = Set.fromList . map fst . filter snd . Map.elems + recipientsListMsg <- messageI Info MsgCommRecipientsList + ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . renderAForm FormStandard $ Communication <$> recipientAForm + <* aformMessage recipientsListMsg <*> aopt textField (fslI MsgCommSubject) Nothing - <*> areq htmlField (fslpI MsgCommBody "Html") Nothing + <*> areq htmlField (fslpI MsgCommBody "Html" & setTooltip MsgCommBodyTip) Nothing formResult commRes $ \comm -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm @@ -183,4 +186,3 @@ commR CommunicationRoute{..} = do siteLayoutMsg crHeading $ do setTitleI crHeading formWdgt - $(i18nWidgetFile "html-input") diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 89e4f1f70..ff84ddfb9 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -1,8 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.Utils.Csv - ( typeCsv, extensionCsv - , decodeCsv + ( decodeCsv , encodeCsv , encodeDefaultOrderedCsv , respondCsv, respondCsvDB @@ -12,9 +11,6 @@ module Handler.Utils.Csv , ToNamedRecord(..), FromNamedRecord(..) , DefaultOrdered(..) , ToField(..), FromField(..) - , CsvRendered(..) - , toCsvRendered - , toDefaultOrderedCsvRendered ) where import Import hiding (Header, mapM_) @@ -40,18 +36,6 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Attoparsec.ByteString.Lazy as A -deriving instance Typeable CsvParseError -instance Exception CsvParseError - - -typeCsv, typeCsv' :: ContentType -typeCsv = simpleContentType typeCsv' -typeCsv' = "text/csv; charset=UTF-8; header=present" - -extensionCsv :: Extension -extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ] - - decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => ConduitT ByteString csv m () decodeCsv = transPipe throwExceptT $ do testBuffer <- accumTestBuffer LBS.empty @@ -173,11 +157,6 @@ fileSourceCsv :: ( FromNamedRecord csv fileSourceCsv = (.| decodeCsv) . fileSource -data CsvRendered = CsvRendered - { csvRenderedHeader :: Header - , csvRenderedData :: [NamedRecord] - } deriving (Eq, Read, Show, Generic, Typeable) - instance ToWidget UniWorX CsvRendered where toWidget CsvRendered{..} = liftWidget $(widgetFile "widgets/csvRendered") where @@ -188,21 +167,3 @@ instance ToWidget UniWorX CsvRendered where ] headers = decodeUtf8 <$> Vector.toList csvRenderedHeader - -toCsvRendered :: forall mono. - ( ToNamedRecord (Element mono) - , MonoFoldable mono - ) - => Header - -> mono -> CsvRendered -toCsvRendered csvRenderedHeader (otoList -> csvs) = CsvRendered{..} - where - csvRenderedData = map toNamedRecord csvs - -toDefaultOrderedCsvRendered :: forall mono. - ( ToNamedRecord (Element mono) - , DefaultOrdered (Element mono) - , MonoFoldable mono - ) - => mono -> CsvRendered -toDefaultOrderedCsvRendered = toCsvRendered $ headerOrder (error "headerOrder" :: Element mono) diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index f6f8e76bc..bbc0f02d9 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -84,6 +84,10 @@ import Control.Monad.Trans.Reader as Import ( reader, Reader, runReader, mapReader, withReader , ReaderT(..), mapReaderT, withReaderT ) +import Control.Monad.Trans.State as Import + ( state, State, runState, mapState, withState + , StateT(..), mapStateT, withStateT + ) import Control.Monad.Base as Import import Control.Monad.Catch as Import hiding (Handler(..)) import Control.Monad.Trans.Control as Import hiding (embed) diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs index 182ed6cbc..7a35229d0 100644 --- a/src/Jobs/Handler/SendCourseCommunication.hs +++ b/src/Jobs/Handler/SendCourseCommunication.hs @@ -6,8 +6,6 @@ import Import import Handler.Utils -import qualified Data.Set as Set - import qualified Data.CaseInsensitive as CI @@ -26,11 +24,11 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do void $ setMailObjectUUID jMailObjectUUID _mailFrom .= userAddress sender - if -- Use `addMailHeader` instead of `_mailCc` to make `mailT` ignore the additional recipients - | jRecipientEmail == Right jSender - -> addMailHeader "Cc" . intercalate ", " . map renderAddress $ Set.toAscList (Set.delete (userAddress sender) jAllRecipientAddresses) - | otherwise - -> addMailHeader "Cc" "Undisclosed Recipients:;" + addMailHeader "Cc" "Undisclosed Recipients:;" addMailHeader "Auto-Submitted" "no" setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage jSubject void $ addPart jMailContent + when (jRecipientEmail == Right jSender) $ + addPart' $ do + partIsAttachment $ "all-recipients" `addExtension` unpack extensionCsv + toMailPart $ toDefaultOrderedCsvRendered jAllRecipientAddresses diff --git a/src/Mail.hs b/src/Mail.hs index 03d14b83d..60baf72b5 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -21,7 +21,7 @@ module Mail , PrioritisedAlternatives , ToMailPart(..) , addAlternatives, provideAlternative, providePreferredAlternative - , addPart + , addPart, addPart', modifyPart, partIsAttachment , MonadHeader(..) , MailHeader , MailObjectId @@ -43,6 +43,8 @@ import Model.Types.TH.JSON import Network.Mail.Mime hiding (addPart, addAttachment) import qualified Network.Mail.Mime as Mime (addPart) +import Settings.Mime + import Data.Monoid (Last(..)) import Control.Monad.Trans.RWS (RWST(..)) import Control.Monad.Trans.State (StateT(..), execStateT, mapStateT) @@ -71,6 +73,10 @@ import qualified Data.ByteString.Lazy as LBS import Utils (MsgRendererS(..), MonadSecretBox(..), maybeT) import Utils.Lens.TH + +import Utils.Csv (CsvRendered(..), typeCsv') +import qualified Data.Csv as Csv + import Control.Lens hiding (from) import Control.Lens.Extras (is) @@ -336,7 +342,7 @@ instance YesodMail site => ToMailPart site (StateT Part (HandlerFor site) a) whe instance YesodMail site => ToMailPart site LT.Text where toMailPart text = do - _partType .= "text/plain; charset=utf-8" + _partType .= decodeUtf8 typePlain _partEncoding .= QuotedPrintableText _partContent .= encodeUtf8 text @@ -348,7 +354,7 @@ instance YesodMail site => ToMailPart site LTB.Builder where instance YesodMail site => ToMailPart site Html where toMailPart html = do - _partType .= "text/html; charset=utf-8" + _partType .= decodeUtf8 typeHtml _partEncoding .= QuotedPrintableText _partContent .= renderMarkup html @@ -372,10 +378,16 @@ instance ToMailPart site a => ToMailPart site (Shakespeare.RenderUrl (Route site instance YesodMail site => ToMailPart site Aeson.Value where toMailPart val = do - _partType .= "application/json; charset=utf-8" + _partType .= decodeUtf8 typeJson _partEncoding .= QuotedPrintableText _partContent .= Aeson.encodePretty val +instance YesodMail site => ToMailPart site CsvRendered where + toMailPart CsvRendered{..} = do + _partType .= decodeUtf8 typeCsv' + _partEncoding .= QuotedPrintableText + _partContent .= Csv.encodeByName csvRenderedHeader csvRenderedData + addAlternatives :: (MonadMail m) => Writer (PrioritisedAlternatives m) () @@ -396,20 +408,35 @@ addPart :: ( MonadMail m , HandlerSite m ~ site , ToMailPart site a ) => a -> m (MailPartReturn site a) -addPart part = do - (ret, part') <- runStateT (toMailPart part) initialPart +addPart = addPart' . toMailPart + +addPart' :: MonadMail m + => StateT Part m a + -> m a +addPart' part = do + (ret, part') <- runStateT part initialPart modify . Mime.addPart $ pure part' return ret initialPart :: Part initialPart = Part - { partType = "text/plain" - , partEncoding = None + { partType = decodeUtf8 defaultMimeType + , partEncoding = Base64 , partFilename = Nothing , partHeaders = [] , partContent = mempty } +modifyPart :: (MonadMail m, HandlerSite m ~ site, YesodMail site) + => StateT Part (HandlerFor site) a + -> StateT Part m a +modifyPart = toMailPart + +partIsAttachment :: (Textual t, MonadMail m, HandlerSite m ~ site, YesodMail site) + => t + -> StateT Part m () +partIsAttachment (repack -> fName) = modifyPart $ _partFilename .= Just fName + class MonadHandler m => MonadHeader m where modifyHeaders :: (Headers -> Headers) -> m () diff --git a/src/Network/Mail/Mime/Instances.hs b/src/Network/Mail/Mime/Instances.hs index 7861f5c3d..83cc59c14 100644 --- a/src/Network/Mail/Mime/Instances.hs +++ b/src/Network/Mail/Mime/Instances.hs @@ -14,6 +14,8 @@ import Data.Aeson.TH import Utils.PathPiece import Utils (assertM) + +import qualified Data.Csv as Csv deriving instance Read Address @@ -32,3 +34,13 @@ instance FromJSON Address where addressName <- assertM (not . null) <$> (obj .:? "name") addressEmail <- obj .: "email" return Address{..} + + +instance Csv.ToNamedRecord Address where + toNamedRecord Address{..} = Csv.namedRecord + [ "name" Csv..= addressName + , "email" Csv..= addressEmail + ] + +instance Csv.DefaultOrdered Address where + headerOrder _ = Csv.header [ "name", "email" ] diff --git a/src/Settings.hs b/src/Settings.hs index df9bce882..48d70d396 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -9,6 +9,7 @@ module Settings ( module Settings , module Settings.Cluster + , module Settings.Mime ) where import Import.NoModel @@ -58,6 +59,7 @@ import qualified Database.Memcached.Binary.Types as Memcached import Model import Settings.Cluster +import Settings.Mime import Control.Monad.Trans.Maybe (MaybeT(..)) @@ -67,10 +69,6 @@ import Jose.Jwt (JwtEncoding(..)) import System.FilePath.Glob import Handler.Utils.Submission.TH -import Network.Mime.TH - -import qualified Data.Map as Map -import qualified Data.Set as Set -- | Runtime settings to configure this application. These settings can be @@ -458,18 +456,6 @@ widgetFileSettings = def submissionBlacklist :: [Pattern] submissionBlacklist = $(patternFile compDefault "config/submission-blacklist") -mimeMap :: MimeMap -mimeMap = $(mimeMapFile "config/mimetypes") - -mimeLookup :: FileName -> MimeType -mimeLookup = mimeByExt mimeMap defaultMimeType - -mimeExtensions :: MimeType -> Set Extension -mimeExtensions needle = Set.fromList [ ext | (ext, typ) <- Map.toList mimeMap, typ == needle ] - -archiveTypes :: Set MimeType -archiveTypes = $(mimeSetFile "config/archive-types") - -- The rest of this file contains settings which rarely need changing by a -- user. diff --git a/src/Settings/Mime.hs b/src/Settings/Mime.hs new file mode 100644 index 000000000..afa03594b --- /dev/null +++ b/src/Settings/Mime.hs @@ -0,0 +1,31 @@ +module Settings.Mime + ( mimeMap + , mimeLookup + , mimeExtensions + , archiveTypes + , module Network.Mime + ) where + +import ClassyPrelude + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Network.Mime + ( FileName, MimeType, MimeMap, Extension + , mimeByExt, defaultMimeType + ) +import Network.Mime.TH + + +mimeMap :: MimeMap +mimeMap = $(mimeMapFile "config/mimetypes") + +mimeLookup :: FileName -> MimeType +mimeLookup = mimeByExt mimeMap defaultMimeType + +mimeExtensions :: MimeType -> Set Extension +mimeExtensions needle = Set.fromList [ ext | (ext, typ) <- Map.toList mimeMap, typ == needle ] + +archiveTypes :: Set MimeType +archiveTypes = $(mimeSetFile "config/archive-types") diff --git a/src/Utils/Csv.hs b/src/Utils/Csv.hs index e864f9e04..0c071f864 100644 --- a/src/Utils/Csv.hs +++ b/src/Utils/Csv.hs @@ -1,14 +1,39 @@ +{-# OPTIONS -fno-warn-orphans #-} + module Utils.Csv - ( pathPieceCsv + ( typeCsv, typeCsv', extensionCsv + , pathPieceCsv , (.:??) + , CsvRendered(..) + , toCsvRendered + , toDefaultOrderedCsvRendered ) where import ClassyPrelude hiding (lookup) +import Settings.Mime + import Data.Csv hiding (Name) +import Data.Csv.Conduit (CsvParseError) import Language.Haskell.TH (Name) import Language.Haskell.TH.Lib +import Yesod.Core.Content (ContentType, simpleContentType) + +import qualified Data.Map as Map + + +deriving instance Typeable CsvParseError +instance Exception CsvParseError + + +typeCsv, typeCsv' :: ContentType +typeCsv = simpleContentType typeCsv' +typeCsv' = "text/csv; charset=UTF-8; header=present" + +extensionCsv :: Extension +extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ] + pathPieceCsv :: Name -> DecsQ pathPieceCsv (conT -> t) = @@ -22,3 +47,27 @@ pathPieceCsv (conT -> t) = (.:??) :: FromField (Maybe a) => NamedRecord -> ByteString -> Parser (Maybe a) m .:?? name = lookup m name <|> return Nothing + + +data CsvRendered = CsvRendered + { csvRenderedHeader :: Header + , csvRenderedData :: [NamedRecord] + } deriving (Eq, Read, Show, Generic, Typeable) + +toCsvRendered :: forall mono. + ( ToNamedRecord (Element mono) + , MonoFoldable mono + ) + => Header + -> mono -> CsvRendered +toCsvRendered csvRenderedHeader (otoList -> csvs) = CsvRendered{..} + where + csvRenderedData = map toNamedRecord csvs + +toDefaultOrderedCsvRendered :: forall mono. + ( ToNamedRecord (Element mono) + , DefaultOrdered (Element mono) + , MonoFoldable mono + ) + => mono -> CsvRendered +toDefaultOrderedCsvRendered = toCsvRendered $ headerOrder (error "headerOrder" :: Element mono) From 977840446e5a9b5836c6f7370c6134b144b8902e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 25 Sep 2019 17:43:23 +0200 Subject: [PATCH 22/28] fix: make migration idempotent again --- models/courses | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/courses b/models/courses index 758f6980d..260c4254f 100644 --- a/models/courses +++ b/models/courses @@ -20,7 +20,7 @@ Course -- Information about a single course; contained info is always visible applicationsRequired Bool default=false applicationsInstructions Html Maybe applicationsText Bool default=false - applicationsFiles UploadMode "default='{ \"mode\": \"no-upload\" }'::jsonb" + applicationsFiles UploadMode "default='{\"mode\": \"no-upload\"}'::jsonb" applicationsRatingsVisible Bool default=false TermSchoolCourseShort term school shorthand -- shorthand must be unique within school and semester TermSchoolCourseName term school name -- name must be unique within school and semester From 39f12957f55256db74960b47be3797e881c525b8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 25 Sep 2019 18:01:20 +0200 Subject: [PATCH 23/28] fix: fix startup on unix-socket --- src/Application.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index ab50d34e6..1181b9a9f 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -77,7 +77,7 @@ import System.Posix.Process (getProcessID) import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM) import qualified System.Posix.Signals as Signals (Handler(..)) -import Network.Socket (socketPort) +import Network.Socket (socketPort, Socket, PortNumber) import qualified Network.Socket as Socket (close) import Control.Concurrent.STM.Delay @@ -370,7 +370,7 @@ develMain = runResourceT $ do liftIO . develMainHelper $ return (wsettings, app) -- | The @main@ function for an executable running this site. -appMain :: MonadUnliftIO m => m () +appMain :: forall m. MonadUnliftIO m => m () appMain = runResourceT $ do settings <- getAppSettings @@ -398,7 +398,7 @@ appMain = runResourceT $ do $logInfoS "bind" [st|Listening on #{tshow host} port #{tshow port} as per configuration|] liftIO $ pure <$> bindPortTCP port host - $logDebugS "bind" . tshow =<< mapM (liftIO . socketPort) sockets + $logDebugS "bind" . tshow =<< mapM (liftIO . try . socketPort :: Socket -> _ (Either SomeException PortNumber)) sockets mainThreadId <- myThreadId liftIO . void . flip (installHandler sigTERM) Nothing . Signals.CatchInfo $ \SignalInfo{..} -> runAppLoggingT foundation $ do From cc7a5289a4ef7965b3464bb826e6a1e32a5d2929 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 25 Sep 2019 18:36:39 +0200 Subject: [PATCH 24/28] fix: improve async behaviour --- app/DevelMain.hs | 5 +---- src/Jobs.hs | 11 ++++++++--- src/Utils/Sql.hs | 17 ++++++++++------- 3 files changed, 19 insertions(+), 14 deletions(-) diff --git a/app/DevelMain.hs b/app/DevelMain.hs index 0a7a89562..ab065aaa2 100644 --- a/app/DevelMain.hs +++ b/app/DevelMain.hs @@ -77,10 +77,7 @@ update = do (port, site, app) <- getApplicationRepl resourceForkIO $ do finally (liftIO $ runSettings (setPort port defaultSettings) app) - -- Note that this implies concurrency - -- between shutdownApp and the next app that is starting. - -- Normally this should be fine - (liftIO $ putMVar done () >> shutdownApp site) + (liftIO $ shutdownApp site >> putMVar done ()) -- | kill the server shutdown :: IO () diff --git a/src/Jobs.hs b/src/Jobs.hs index c65410dc0..39a1d7bac 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -55,8 +55,6 @@ import Data.Time.Zones import Control.Concurrent.STM (retry) import Control.Concurrent.STM.Delay -import UnliftIO.Concurrent (forkIO) - import Jobs.Handler.SendNotification import Jobs.Handler.SendTestEmail @@ -143,6 +141,9 @@ manageJobPool foundation@UniWorX{..} spawnMissingWorkers, reapDeadWorkers, terminateGracefully :: STM (ContT () m ()) spawnMissingWorkers = do + shouldTerminate' <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown + guard $ not shouldTerminate' + oldState <- takeTMVar appJobState let missing = num - Map.size (jobWorkers oldState) guard $ missing > 0 @@ -204,6 +205,10 @@ manageJobPool foundation@UniWorX{..} terminateGracefully = do shouldTerminate <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown guard shouldTerminate + + oldState <- takeTMVar appJobState + guard $ 0 == Map.size (jobWorkers oldState) + return . callCC $ \terminate -> do $logInfoS "JobPoolManager" "Shutting down" terminate () @@ -214,7 +219,7 @@ stopJobCtl UniWorX{appJobState} = do didStop <- atomically $ do jState <- tryReadTMVar appJobState for jState $ \jSt'@JobState{jobShutdown} -> jSt' <$ tryPutTMVar jobShutdown () - whenIsJust didStop $ \jSt' -> void . forkIO . atomically $ do + whenIsJust didStop $ \jSt' -> void . atomically $ do workers <- maybe [] (Map.keys . jobWorkers) <$> tryTakeTMVar appJobState mapM_ (void . waitCatchSTM) $ [ jobPoolManager jSt' diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index 5c2a504f7..9726b5222 100644 --- a/src/Utils/Sql.hs +++ b/src/Utils/Sql.hs @@ -7,6 +7,7 @@ import ClassyPrelude.Yesod import Database.PostgreSQL.Simple (SqlError(SqlError), sqlErrorHint) import Control.Monad.Catch (MonadMask) +import Database.Persist.Sql import Database.Persist.Sql.Raw.QQ import Control.Retry @@ -14,20 +15,22 @@ import Control.Retry import Control.Lens ((&)) -retryTransaction :: forall m a. (MonadLogger m, MonadMask m, MonadIO m) => m a -> m a -retryTransaction = recovering policy [logRetries suggestRetry logRetry] . const +setSerializable :: forall m a. (MonadLogger m, MonadMask m, MonadIO m) => ReaderT SqlBackend m a -> ReaderT SqlBackend m a +setSerializable act = recovering policy [logRetries suggestRetry logRetry] act' where - policy :: RetryPolicyM m + policy :: RetryPolicyM (ReaderT SqlBackend m) policy = fullJitterBackoff 1e3 & limitRetriesByCumulativeDelay 10e6 - suggestRetry :: SqlError -> m Bool + suggestRetry :: SqlError -> ReaderT SqlBackend m Bool suggestRetry SqlError{sqlErrorHint} = return $ "The transaction might succeed if retried." `isInfixOf` sqlErrorHint logRetry :: Bool -- ^ Will retry -> SqlError -> RetryStatus - -> m () + -> ReaderT SqlBackend m () logRetry shouldRetry err status = $logDebugS "Sql" . pack $ defaultLogMsg shouldRetry err status -setSerializable :: (MonadLogger m, MonadMask m, MonadIO m) => ReaderT SqlBackend m a -> ReaderT SqlBackend m a -setSerializable act = retryTransaction $ [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act + act' :: RetryStatus -> ReaderT SqlBackend m a + act' RetryStatus{..} + | rsIterNumber == 0 = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act + | otherwise = transactionUndoWithIsolation Serializable *> act From 5ebcd89e11841fd777f9ab6fbe1c4c46b02313a7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 25 Sep 2019 18:51:54 +0200 Subject: [PATCH 25/28] fix: restore behaviour of waiting asynchronously for job-management --- src/Jobs.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Jobs.hs b/src/Jobs.hs index 39a1d7bac..d2de34d8d 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -55,6 +55,8 @@ import Data.Time.Zones import Control.Concurrent.STM (retry) import Control.Concurrent.STM.Delay +import UnliftIO.Concurrent (forkIO) + import Jobs.Handler.SendNotification import Jobs.Handler.SendTestEmail @@ -219,7 +221,7 @@ stopJobCtl UniWorX{appJobState} = do didStop <- atomically $ do jState <- tryReadTMVar appJobState for jState $ \jSt'@JobState{jobShutdown} -> jSt' <$ tryPutTMVar jobShutdown () - whenIsJust didStop $ \jSt' -> void . atomically $ do + whenIsJust didStop $ \jSt' -> void . forkIO . atomically $ do workers <- maybe [] (Map.keys . jobWorkers) <$> tryTakeTMVar appJobState mapM_ (void . waitCatchSTM) $ [ jobPoolManager jSt' From fb0a237896f13258cd1da811bca876ba73f881c2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 25 Sep 2019 19:10:59 +0200 Subject: [PATCH 26/28] chore(release): 7.0.0 --- CHANGELOG.md | 43 +++++++++++++++++++++++++++++++++++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 46 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c38052ada..70a4feb39 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,49 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [7.0.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.11.1...v7.0.0) (2019-09-25) + + +### Bug Fixes + +* fix startup on unix-socket ([39f1295](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/39f1295)) +* improve async behaviour ([cc7a528](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/cc7a528)) +* make migration idempotent again ([9778404](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9778404)) +* restore behaviour of waiting asynchronously for job-management ([5ebcd89](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/5ebcd89)) +* **communication:** make communication form more intuitive ([7a2b972](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/7a2b972)), closes [#387](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/387) +* fix migration ([d2478a3](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d2478a3)) +* fix migration & tests ([e05ea8e](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e05ea8e)) +* migration ([4383eb1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/4383eb1)) +* syntax ([7afd569](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/7afd569)) +* **migration:** drop more tables in w.a. for inconsistent 21→22 ([d79dca6](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d79dca6)) +* typo ([fb1e42d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/fb1e42d)) + + +### chore + +* bump versions ([67e3b38](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/67e3b38)) + + +### Features + +* **course:** additional crosslinking ([5eaba78](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/5eaba78)) +* **exam-users:** document part-* family of columns ([fe07a22](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/fe07a22)) +* **exams:** accept/reset computed results ([72342f1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/72342f1)) +* **exams:** automatically compute examResults ([ea5a398](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ea5a398)) +* **exams:** better display exam-result-information ([0ebda4d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0ebda4d)) +* **exams:** csv-import of ExamPartResults ([29f4e28](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/29f4e28)) +* **exams:** implement rounding of exambonus ([e97cd56](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e97cd56)) +* **exams:** refine exam form ([014a17a](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/014a17a)) + + +### BREAKING CHANGES + +* yesod >=1.6 +* **exams:** examPartName no longer required +* **exams:** Introduces ExamPartNumbers + + + ### [6.11.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.11.0...v6.11.1) (2019-09-17) diff --git a/package-lock.json b/package-lock.json index 67c13819f..5854e7166 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "6.11.1", + "version": "7.0.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 14784856d..242dc4284 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "6.11.1", + "version": "7.0.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index f7445cd95..1d3882e41 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 6.11.1 +version: 7.0.0 dependencies: - base >=4.9.1.0 && <5 From c553414b388685e747f94495c85ea5f50b97f52a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 26 Sep 2019 11:00:52 +0200 Subject: [PATCH 27/28] chore: reduce number of workers during testing --- app/DevelMain.hs | 4 ++-- config/test-settings.yml | 2 ++ 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/app/DevelMain.hs b/app/DevelMain.hs index ab065aaa2..b850b33b2 100644 --- a/app/DevelMain.hs +++ b/app/DevelMain.hs @@ -67,7 +67,7 @@ update = do restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do killThread tid withStore doneStore takeMVar - readStore doneStore >>= start + withStore doneStore start -- | Start the server in a separate thread. @@ -77,7 +77,7 @@ update = do (port, site, app) <- getApplicationRepl resourceForkIO $ do finally (liftIO $ runSettings (setPort port defaultSettings) app) - (liftIO $ shutdownApp site >> putMVar done ()) + (liftIO $ shutdownApp site `finally` putMVar done ()) -- | kill the server shutdown :: IO () diff --git a/config/test-settings.yml b/config/test-settings.yml index 23f59aed5..5fb61bedf 100644 --- a/config/test-settings.yml +++ b/config/test-settings.yml @@ -8,3 +8,5 @@ log-settings: destination: "test.log" auth-dummy-login: true + +job-workers: 1 From 54e94a667027548056a12139ac96512fc4609911 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 26 Sep 2019 11:01:32 +0200 Subject: [PATCH 28/28] feat(exams): re-introduce ExamBonusManual --- messages/uniworx/de.msg | 2 ++ src/Application.hs | 16 ++++++++-- src/Handler/Exam/Users.hs | 49 +++++++++++++++--------------- src/Handler/Utils/Exam.hs | 10 +++--- src/Handler/Utils/Form.hs | 10 ++++-- src/Model/Types/Exam.hs | 5 ++- templates/widgets/bonusRule.hamlet | 2 ++ 7 files changed, 60 insertions(+), 34 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 41e50c599..bee90fb85 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1348,6 +1348,7 @@ ExamBonus: Bonuspunkte-System ExamBonusRule: Prüfungsbonus aus Übungsbetrieb ExamNoBonus': Kein automatischer Bonus ExamBonusPoints': Umrechnung von Übungspunkten +ExamBonusManual': Manuelle Berechnung ExamBonusAchieved: Bonuspunkte @@ -1417,6 +1418,7 @@ ExamEdited exam@ExamName: #{exam} erfolgreich bearbeitet ExamNoShow: Nicht erschienen ExamVoided: Entwertet +ExamBonusManualParticipants: Von den Kursverwaltern manuell berechnet ExamBonusPoints possible@Points: Maximal #{showFixed True possible} Prüfungspunkte ExamBonusPointsPassed possible@Points: Maximal #{showFixed True possible} Prüfungspunkte, falls die Prüfung auch ohne Bonus bereits bestanden ist diff --git a/src/Application.hs b/src/Application.hs index 1181b9a9f..294e1a206 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -24,7 +24,7 @@ import Language.Haskell.TH.Syntax (qLocation) import Network.Wai (Middleware) import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, - runSettingsSocket, setHost, + runSettings, runSettingsSocket, setHost, setBeforeMainLoop, setOnException, setPort, getPort) import Data.Streaming.Network (bindPortTCP) @@ -74,7 +74,7 @@ import qualified Database.Memcached.Binary.IO as Memcached import qualified System.Systemd.Daemon as Systemd import System.Environment (lookupEnv) import System.Posix.Process (getProcessID) -import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM) +import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM, sigINT) import qualified System.Posix.Signals as Signals (Handler(..)) import Network.Socket (socketPort, Socket, PortNumber) @@ -82,6 +82,7 @@ import qualified Network.Socket as Socket (close) import Control.Concurrent.STM.Delay import Control.Monad.STM (retry) +import Control.Monad.Trans.Cont (runContT, callCC) import qualified Data.Set as Set @@ -366,8 +367,17 @@ develMain = runResourceT $ do wsettings <- liftIO . getDevSettings $ warpSettings foundation app <- makeApplication foundation + let + awaitTermination :: IO () + awaitTermination + = flip runContT return . forever $ do + lift $ threadDelay 100e3 + whenM (lift $ doesFileExist "yesod-devel/devel-terminate") $ + callCC ($ ()) + + void . liftIO $ installHandler sigINT (Signals.Catch $ return ()) Nothing runAppLoggingT foundation $ handleJobs foundation - liftIO . develMainHelper $ return (wsettings, app) + void . liftIO $ awaitTermination `race` runSettings wsettings app -- | The @main@ function for an executable running this site. appMain :: forall m. MonadUnliftIO m => m () diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index a7f4f71e0..121f430ff 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -160,7 +160,7 @@ resultCourseNote = _dbrOutput . _10 . _Just resultAutomaticExamBonus :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData Points -resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> examResultBonus <$> examBonusRule exam <*> examBonusPossible uid examBonus' <*> examBonusAchieved uid examBonus') +resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> examResultBonus <$> examBonusRule exam <*> pure (examBonusPossible uid examBonus') <*> pure (examBonusAchieved uid examBonus')) resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultGrade resultAutomaticExamResult exam examBonus' = folding . runReader $ do @@ -396,7 +396,7 @@ postEUsersR tid ssh csh examn = do allBoni :: SheetGradeSummary allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus - doBonus = is _Just examGradingRule || is _Just examBonusRule + doBonus = is _Just examBonusRule showPasses = doBonus && numSheetsPasses allBoni /= 0 showPoints = doBonus && getSum (numSheetsPoints allBoni) /= 0 @@ -494,14 +494,14 @@ postEUsersR tid ssh csh examn = do , pure $ colDegreeShort resultStudyDegree , pure $ colFeaturesSemester resultStudyFeatures , pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence - , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do - SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus - SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus - return $ propCell (getSum achievedPasses) (getSum numSheetsPasses) - , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do - SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus - SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus - return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints) + , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> + let SheetGradeSummary{achievedPasses} = examBonusAchieved uid bonus + SheetGradeSummary{numSheetsPasses} = examBonusPossible uid bonus + in propCell (getSum achievedPasses) (getSum numSheetsPasses) + , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> + let SheetGradeSummary{achievedPoints} = examBonusAchieved uid bonus + SheetGradeSummary{sumSheetsPoints} = examBonusPossible uid bonus + in propCell (getSum achievedPoints) (getSum sumSheetsPoints) , guardOn doBonus $ sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) . automaticCell $ resultExamBonus . _entityVal . _examBonusBonus . to Right <> resultAutomaticExamBonus' . to Left , pure $ mconcat [ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) $ maybe mempty i18nCell . preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult) @@ -612,10 +612,10 @@ postEUsersR tid ssh csh examn = do <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) - <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped) (bool (const Nothing) Just showPoints) - <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses) - <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) (bool (const Nothing) Just showPoints) - <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses) + <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPoints . _Wrapped) (bool (const Nothing) Just showPoints) + <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses) + <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _sumSheetsPoints . _Wrapped) (bool (const Nothing) Just showPoints) + <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _numSheetsPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses) <*> previews (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus') (bool (const Nothing) Just doBonus) <*> (Map.fromList . map (over _1 examPartNumber . over (_2 . _Just) (examPartResultResult . entityVal)) <$> asks (toListOf resultExamParts)) <*> previews (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') resultView @@ -645,7 +645,7 @@ postEUsersR tid ssh csh examn = do when (epNumber `elem` examPartNumbers) $ yield $ ExamUserCsvSetPartResultData uid epNumber (Just epRes) - when (is _Just . join $ csvEUserBonus dbCsvNew) $ + when (doBonus && is _Just (join $ csvEUserBonus dbCsvNew)) $ yield . ExamUserCsvSetBonusData False uid . join $ csvEUserBonus dbCsvNew when (is _Just $ csvEUserExamResult dbCsvNew) $ @@ -684,15 +684,16 @@ postEUsersR tid ssh csh examn = do newResult = fmap resultView <$> examGrade examVal (newBonus <|> oldBonus) =<< newResults oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') . to resultView - case newBonus of - _ | newBonus == oldBonus - -> return () - _ | is _Nothing newBonus - -> return () - Nothing - -> yield $ ExamUserCsvSetBonusData False uid newBonus - Just _ - -> yield $ ExamUserCsvSetBonusData True uid newBonus + when doBonus $ + case newBonus of + _ | newBonus == oldBonus + -> return () + _ | is _Nothing newBonus + -> return () + Nothing + -> yield $ ExamUserCsvSetBonusData False uid newBonus + Just _ + -> yield $ ExamUserCsvSetBonusData True uid newBonus case newResult of _ | csvEUserExamResult dbCsvNew == oldResult diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 9f6bbe364..ec5d7f5d2 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -78,12 +78,12 @@ examBonus (Entity eId Exam{..}) = runConduit $ ) return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission) accum = C.fold ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub) -> - Map.unionWith mappend acc . Map.singleton uid . sheetTypeSum sheetType . (>>= submissionRatingPoints) $ assertM submissionRatingDone sub + flip (Map.insertWith mappend uid) acc . sheetTypeSum sheetType $ assertM submissionRatingDone sub >>= submissionRatingPoints in rawData .| accum -examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> Maybe SheetGradeSummary -examBonusPossible uid bonusMap = normalSummary <$> Map.lookup uid bonusMap -examBonusAchieved uid bonusMap = (mappend <$> normalSummary <*> bonusSummary) <$> Map.lookup uid bonusMap +examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> SheetGradeSummary +examBonusPossible uid bonusMap = normalSummary $ Map.findWithDefault mempty uid bonusMap +examBonusAchieved uid bonusMap = mappend <$> normalSummary <*> bonusSummary $ Map.findWithDefault mempty uid bonusMap examResultBonus :: ExamBonusRule @@ -91,6 +91,8 @@ examResultBonus :: ExamBonusRule -> SheetGradeSummary -- ^ `examBonusAchieved` -> Points examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of + ExamBonusManual{} + -> 0 ExamBonusPoints{..} -> roundToPoints bonusRound $ toRational bonusMaxPoints * bonusProp where diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 6556d1db7..2f8af499c 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -520,7 +520,8 @@ submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ c ) ] -data ExamBonusRule' = ExamBonusPoints' +data ExamBonusRule' = ExamBonusManual' + | ExamBonusPoints' deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ExamBonusRule' instance Finite ExamBonusRule' @@ -530,6 +531,7 @@ embedRenderMessage ''UniWorX ''ExamBonusRule' id classifyBonusRule :: ExamBonusRule -> ExamBonusRule' classifyBonusRule = \case + ExamBonusManual{} -> ExamBonusManual' ExamBonusPoints{} -> ExamBonusPoints' examBonusRuleForm :: Maybe ExamBonusRule -> AForm Handler ExamBonusRule @@ -537,7 +539,11 @@ examBonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classify where actions :: Map ExamBonusRule' (AForm Handler ExamBonusRule) actions = Map.fromList - [ ( ExamBonusPoints' + [ ( ExamBonusManual' + , ExamBonusManual + <$> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev)) + ) + , ( ExamBonusPoints' , ExamBonusPoints <$> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints & setTooltip MsgExamBonusMaxPointsTip) (preview _bonusMaxPoints =<< prev) <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev)) diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 53d900584..1a3f3ec0d 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -116,7 +116,10 @@ instance Universe res => Universe (ExamResult' res) where instance Finite res => Finite (ExamResult' res) -data ExamBonusRule = ExamBonusPoints +data ExamBonusRule = ExamBonusManual + { bonusOnlyPassed :: Bool + } + | ExamBonusPoints { bonusMaxPoints :: Points , bonusOnlyPassed :: Bool , bonusRound :: Points diff --git a/templates/widgets/bonusRule.hamlet b/templates/widgets/bonusRule.hamlet index 3a5a2c775..1c59049c0 100644 --- a/templates/widgets/bonusRule.hamlet +++ b/templates/widgets/bonusRule.hamlet @@ -1,5 +1,7 @@ $newline never $case bonusRule + $of ExamBonusManual _ + _{MsgExamBonusManualParticipants} $of ExamBonusPoints ps False _ _{MsgExamBonusPoints ps} $of ExamBonusPoints ps True _