diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 0e71e6f8d..8665aad07 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -1732,3 +1732,8 @@ video .authorship-statement-accept__accept-label grid-area: label font-weight: 600 + +.authorship-statement__id + font-size: .5em + font-family: var(--font-monospace) + color: var(--color-fontsec) diff --git a/messages/uniworx/categories/courses/submission/de-de-formal.msg b/messages/uniworx/categories/courses/submission/de-de-formal.msg index effc3d615..30d8c44a0 100644 --- a/messages/uniworx/categories/courses/submission/de-de-formal.msg +++ b/messages/uniworx/categories/courses/submission/de-de-formal.msg @@ -210,6 +210,19 @@ SubmissionUserMatriculation: Matrikelnummer SubmissionUserEmail: E-Mail SubmissionUserAuthorshipStatementState: Eigenständigkeitserklärung -SubmissionAuthorshipStatementStateOkay: In Ordnung +SubmissionAuthorshipStatementStateExists: Vorhanden SubmissionAuthorshipStatementStateOldStatement: Unpassender Wortlaut -SubmissionAuthorshipStatementStateMissing: Fehlt \ No newline at end of file +SubmissionAuthorshipStatementStateMissing: Fehlt + +SubmissionTitle tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName cID@CryptoFileNameSubmission !ident-ok: #{tid}-#{ssh}-#{csh} #{shn}: #{toPathPiece cID} +SubmissionHeadingEdit tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName cID@CryptoFileNameSubmission: #{tid}-#{ssh}-#{csh} #{shn}: Abgabe #{toPathPiece cID} editieren +SubmissionHeadingShow tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName cID@CryptoFileNameSubmission: #{tid}-#{ssh}-#{csh} #{shn}: Abgabe #{toPathPiece cID} +SubmissionTitleNew tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: #{tid}-#{ssh}-#{csh} #{shn}: Abgabe anlegen +SubmissionHeadingNew tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: #{tid}-#{ssh}-#{csh} #{shn}: Abgabe anlegen + +SubmissionAuthorshipStatementsHeading tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName cID@CryptoFileNameSubmission: #{tid}-#{ssh}-#{csh} #{shn}: Eigenständigkeitserklärungen #{toPathPiece cID} +SubmissionAuthorshipStatementsTitle tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName cID@CryptoFileNameSubmission: #{tid}-#{ssh}-#{csh} #{shn}: Eigenständigkeitserklärungen #{toPathPiece cID} + +SubmissionColumnAuthorshipStatementTime: Zeitstempel +SubmissionColumnAuthorshipStatementWording: Wortlaut +SubmissionFilterAuthorshipStatementCurrent: Aktueller Wortlaut \ No newline at end of file diff --git a/messages/uniworx/categories/courses/submission/en-eu.msg b/messages/uniworx/categories/courses/submission/en-eu.msg index 2e2c5a7d5..61fbab400 100644 --- a/messages/uniworx/categories/courses/submission/en-eu.msg +++ b/messages/uniworx/categories/courses/submission/en-eu.msg @@ -209,6 +209,19 @@ SubmissionUserMatriculation: Matriculation SubmissionUserEmail: Email SubmissionUserAuthorshipStatementState: Statement of Authorship -SubmissionAuthorshipStatementStateOkay: Okay +SubmissionAuthorshipStatementStateExists: Exists SubmissionAuthorshipStatementStateOldStatement: Wrong wording SubmissionAuthorshipStatementStateMissing: Missing + +SubmissionTitle tid ssh csh shn cID !ident-ok: #{tid}-#{ssh}-#{csh} #{shn}: #{toPathPiece cID} +SubmissionHeadingEdit tid ssh csh shn cID: #{tid}-#{ssh}-#{csh} #{shn}: Edit Submission #{toPathPiece cID} +SubmissionHeadingShow tid ssh csh shn cID: #{tid}-#{ssh}-#{csh} #{shn}: Submission #{toPathPiece cID} +SubmissionTitleNew tid ssh csh shn: #{tid}-#{ssh}-#{csh} #{shn}: Create Submission +SubmissionHeadingNew tid ssh csh shn: #{tid}-#{ssh}-#{csh} #{shn}: Create Submission + +SubmissionAuthorshipStatementsHeading tid ssh csh shn cID: #{tid}-#{ssh}-#{csh} #{shn}: Authorship Statements #{toPathPiece cID} +SubmissionAuthorshipStatementsTitle tid ssh csh shn cID: #{tid}-#{ssh}-#{csh} #{shn}: Authorship Statements #{toPathPiece cID} + +SubmissionColumnAuthorshipStatementTime: Timestamp +SubmissionColumnAuthorshipStatementWording: Wording +SubmissionFilterAuthorshipStatementCurrent: Current wording diff --git a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg index 2c7b12fdd..c79919c59 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg @@ -186,4 +186,5 @@ BreadcrumbCorrectionsGrade: Korrekturen eintragen BreadcrumbMessageList: Systemnachrichten BreadcrumbGlossary: Begriffsverzeichnis BreadcrumbLogin !ident-ok: Login -BreadcrumbNews: Aktuell \ No newline at end of file +BreadcrumbNews: Aktuell +BreadcrumbSubmissionAuthorshipStatements: Eigenständigkeitserklärungen \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg index d88d37830..dfb3eb21a 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg @@ -187,3 +187,4 @@ BreadcrumbSheetCurrent: Current exercise sheet BreadcrumbSheetOldUnassigned: Submissions without corrector BreadcrumbLogin: Login BreadcrumbNews: News +BreadcrumbSubmissionAuthorshipStatements: Statements of Authorship diff --git a/routes b/routes index 85106d88f..bedfbaeb1 100644 --- a/routes +++ b/routes @@ -218,6 +218,7 @@ /assign SubAssignR GET POST !lecturerANDtime /correction CorrectionR GET POST !corrector !ownerANDreadANDratedANDexam-time /invite SInviteR GET POST !ownerANDtimeANDuser-submissionsANDsubmission-groupANDexam-registeredANDpersonalised-sheet-files + /authorship-statements SubAuthorshipStatementsR GET !corrector !/#SubmissionFileType SubArchiveR GET !owner !corrector !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector /iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index e4fee5cb2..6d6db7bce 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -204,7 +204,7 @@ campusLogin pool mode = AuthPlugin{..} searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName] case searchResults of [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] - | [principalName] <- nub $ fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ] + | [principalName] <- nubOrd $ fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ] , Right credsIdent <- Text.decodeUtf8' principalName -> handleIf isInvalidCredentials (return . Left) $ do Ldap.bind ldap (Ldap.Dn credsIdent) . Ldap.Password $ Text.encodeUtf8 campusPassword diff --git a/src/Data/Universe/TH.hs b/src/Data/Universe/TH.hs index 7ebc86ea7..0176e3a30 100644 --- a/src/Data/Universe/TH.hs +++ b/src/Data/Universe/TH.hs @@ -14,7 +14,8 @@ import Data.Universe.Helpers (interleave) import Control.Monad (unless) -import Data.List (elemIndex, nub) +import Data.List (elemIndex) +import Data.Containers.ListUtils import Control.Lens hiding (universe) import Data.Generics.Product.Types @@ -81,7 +82,7 @@ deriveUniverse' interleaveExp universeExp mkCxt tName = do usesVar ConstructorInfo{..} n | n `elem` map getTVBName constructorVars = False | otherwise = any (elemOf types n) constructorFields - fieldTypes = nub $ concatMap constructorFields datatypeCons + fieldTypes = nubOrd $ concatMap constructorFields datatypeCons iCxt' <- cxt iCxt diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index c861a7d0e..9dc051554 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -509,18 +509,18 @@ instance RenderMessage UniWorX RouteWorkflowScope where mr = renderMessage foundation ls -unRenderMessage' :: (Eq a, Finite a, RenderMessage master a) => (Text -> Text -> Bool) -> master -> Text -> [a] -unRenderMessage' cmp foundation inp = nub $ do +unRenderMessage' :: (Ord a, Finite a, RenderMessage master a) => (Text -> Text -> Bool) -> master -> Text -> [a] +unRenderMessage' cmp foundation inp = nubOrd $ do l <- appLanguages' x <- universeF guard $ renderMessage foundation (l : filter (/= l) appLanguages') x `cmp` inp return x where appLanguages' = toList appLanguages -unRenderMessage :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a] +unRenderMessage :: (Ord a, Finite a, RenderMessage master a) => master -> Text -> [a] unRenderMessage = unRenderMessage' (==) -unRenderMessageLenient :: forall a master. (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a] +unRenderMessageLenient :: forall a master. (Ord a, Finite a, RenderMessage master a) => master -> Text -> [a] unRenderMessageLenient = unRenderMessage' cmp where cmp = (==) `on` mk . under packed (filter Char.isAlphaNum . concatMap unidecode) diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 541d9ff6d..28303797b 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -325,17 +325,16 @@ breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of SubmissionR cid sRoute' -> case sRoute' of SubShowR -> useRunDB $ do mayList <- hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR - if - | mayList - -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SSubsR - | otherwise - -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SShowR + return ( toPathPiece cid + , Just . CSheetR tid ssh csh shn $ bool SShowR SSubsR mayList + ) CorrectionR -> i18nCrumb MsgMenuCorrection . Just $ CSubmissionR tid ssh csh shn cid SubShowR SubDelR -> i18nCrumb MsgMenuSubmissionDelete . Just $ CSubmissionR tid ssh csh shn cid SubShowR SubAssignR -> i18nCrumb MsgCorrectorAssignTitle . Just $ CSubmissionR tid ssh csh shn cid SubShowR SInviteR -> i18nCrumb MsgBreadcrumbSubmissionUserInvite . Just $ CSubmissionR tid ssh csh shn cid SubShowR SubArchiveR sft -> i18nCrumb sft . Just $ CSubmissionR tid ssh csh shn cid SubShowR SubDownloadR _ _ -> i18nCrumb MsgBreadcrumbSubmissionFile . Just $ CSubmissionR tid ssh csh shn cid SubShowR + SubAuthorshipStatementsR -> i18nCrumb MsgBreadcrumbSubmissionAuthorshipStatements . Just $ CSubmissionR tid ssh csh shn cid SubShowR SArchiveR -> i18nCrumb MsgBreadcrumbSheetArchive . Just $ CSheetR tid ssh csh shn SShowR SIsCorrR -> i18nCrumb MsgBreadcrumbSheetIsCorrector . Just $ CSheetR tid ssh csh shn SShowR SPseudonymR -> i18nCrumb MsgBreadcrumbSheetPseudonym . Just $ CSheetR tid ssh csh shn SShowR diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 8460462e9..29c77c654 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -296,7 +296,7 @@ upsertCampusUser upsertMode ldapData = do Right str <- return $ Text.decodeUtf8' v' return str - termNames = nubBy ((==) `on` CI.mk) $ do + termNames = nubOrdOn CI.mk $ do (k, v) <- ldapData guard $ k == ldapUserFieldName v' <- v @@ -505,7 +505,7 @@ updateUserLanguage (Just lang) = do muid <- maybeAuthId for_ muid $ \uid -> do langs <- languages - update uid [ UserLanguages =. Just (Languages $ lang : nub (filter ((&&) <$> (`elem` appLanguages) <*> (/= lang)) langs)) ] + update uid [ UserLanguages =. Just (Languages $ lang : nubOrd (filter ((&&) <$> (`elem` appLanguages) <*> (/= lang)) langs)) ] setRegisteredCookie CookieLang lang return $ Just lang updateUserLanguage Nothing = runMaybeT $ do diff --git a/src/Handler/Allocation/Accept.hs b/src/Handler/Allocation/Accept.hs index 39d909ee6..8809c034a 100644 --- a/src/Handler/Allocation/Accept.hs +++ b/src/Handler/Allocation/Accept.hs @@ -109,12 +109,12 @@ allocationAcceptForm aId = runMaybeT $ do let showTerms - | [_] <- nubOn (view $ _1 . _2 . _entityVal . _courseTerm) allocationCourses' + | [_] <- nubOrdOn (view $ _1 . _2 . _entityVal . _courseTerm) allocationCourses' = False | otherwise = True showSchools - | [_] <- nubOn (view $ _1 . _2 . _entityVal . _courseSchool) allocationCourses' + | [_] <- nubOrdOn (view $ _1 . _2 . _entityVal . _courseSchool) allocationCourses' = False | otherwise = True diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index eb348e266..f034eccd6 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -118,7 +118,7 @@ postAShowR tid ssh ash = do wouldNotifyNewCourse <- fmap (maybe False E.unValue . join) . for muid $ E.selectMaybe . pure . allocationNotifyNewCourses (E.val aId) . E.val - return (alloc, school, isAnyLecturer, isAdmin, nubOn (view $ resultCourse . _entityKey) courses, registration, wouldNotifyNewCourse) + return (alloc, school, isAnyLecturer, isAdmin, nubOrdOn (view $ resultCourse . _entityKey) courses, registration, wouldNotifyNewCourse) let nextSubstitutesDeadline = minimumOf (folded . resultAllocationCourse . _allocationCourseAcceptSubstitutes . _Just . filtered (>= now)) courses freeCapacity = fmap getSum . getAp . flip foldMap courses $ \cEntry -> Ap . fmap (Sum . max 0) $ subtract (cEntry ^. resultParticipantCount) <$> preview (resultCourse . _entityVal . _courseCapacity . _Just) cEntry diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 7b86b1a61..d637eb50a 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -612,7 +612,7 @@ postCApplicationsR tid ssh csh = do sortedApplications <- unstableSortBy cmp applications let applicants = sortedApplications - & nubOn (view $ _1 . _entityKey) + & nubOrdOn (view $ _1 . _entityKey) & maybe id take openCapacity & setOf (case invMode of AcceptApplicationsDirect -> folded . _1 . _entityKey . to Right diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 519efbb1d..fb426ca94 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -121,7 +121,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools oldSchool <- forM (cfCourseId =<< template) $ fmap courseSchool . getJust return (lecturerSchools, adminSchools, oldSchool) - let userSchools = nub . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools + let userSchools = nubOrd . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools (termsField, userTerms) <- liftHandler $ case template of -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index e9d2eb811..2a12a905c 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -623,7 +623,7 @@ postCUsersR tid ssh csh = do , E.desc $ sheet E.^. SheetActiveFrom ] return $ sheet E.^. SheetName - let exams = nubOn entityKey $ examOccurrencesPerExam ^.. folded . _1 + let exams = nubOrdOn entityKey $ examOccurrencesPerExam ^.. folded . _1 let colChoices = mconcat $ catMaybes [ pure . cap' $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , pure . cap' $ colUserNameLink (CourseR tid ssh csh . CUserR) diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 5f40b4248..927f98bac 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -160,7 +160,7 @@ examForm (Entity _ Course{..}) template csrf = hoist liftHandler $ do (fslI MsgExamAuthorshipStatementContent & setTooltip MsgExamAuthorshipStatementContentForcedTip) contentField ttipReq | not schoolSheetExamAuthorshipStatementAllowOther - = traverse forcedContentField $ authorshipStatementDefinitionContent . entityVal <$> mSchoolAuthorshipStatement + = fmap (fmap authorshipStatementDefinitionContent) . traverse forcedContentField $ entityVal <$> mSchoolAuthorshipStatement | otherwise = Just <$> reqContentField ttipReq in case schoolSheetExamAuthorshipStatementMode of diff --git a/src/Handler/ExamOffice/Users.hs b/src/Handler/ExamOffice/Users.hs index 79e6da3a4..baf745264 100644 --- a/src/Handler/ExamOffice/Users.hs +++ b/src/Handler/ExamOffice/Users.hs @@ -101,7 +101,7 @@ makeExamOfficeUsersForm template = renderWForm FormStandard $ do | null newUsers -> pure oldUsers | otherwise - -> pure . nub $ oldUsers ++ Set.toList newUsers + -> pure . nubOrd $ oldUsers ++ Set.toList newUsers return (res', $(widgetFile "widgets/massinput/examOfficeUsers/add")) miCell' :: Either UserEmail UserId -> Widget miCell' (Left email) = do diff --git a/src/Handler/ExternalExam/Form.hs b/src/Handler/ExternalExam/Form.hs index 5c278e3ad..da5fd6a32 100644 --- a/src/Handler/ExternalExam/Form.hs +++ b/src/Handler/ExternalExam/Form.hs @@ -46,7 +46,7 @@ externalExamForm template = validateForm validateExternalExam $ \html -> do adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools let oldSchool = eefSchool <$> template return (lecturerSchools, adminSchools, oldSchool) - let userSchools = nub . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools + let userSchools = nubOrd . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools templateSchool = eefSchool <$> template <|> case userSchools of [ssh] -> pure ssh _ -> mzero diff --git a/src/Handler/Metrics.hs b/src/Handler/Metrics.hs index 6cadaa2a0..d5af2a26d 100644 --- a/src/Handler/Metrics.hs +++ b/src/Handler/Metrics.hs @@ -44,7 +44,7 @@ getMetricsR = selectRep $ do -> suffix | otherwise = sName - getLabels = nub . concatMap (\(Sample _ lPairs _) -> lPairs ^.. folded . _1) + getLabels = nubOrd . concatMap (\(Sample _ lPairs _) -> lPairs ^.. folded . _1) singleSample base [Sample sName lPairs sValue] | sName == base = Just (lPairs, sValue) singleSample _ _ = Nothing diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs index df5377940..f36195169 100644 --- a/src/Handler/Sheet/Form.hs +++ b/src/Handler/Sheet/Form.hs @@ -139,7 +139,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS if | not schoolSheetAuthorshipStatementAllowOther -> (pure SheetAuthorshipStatementModeEnabled, pure sfAuthorshipStatementExam', ) - <$> fmap sequenceA (traverse forcedContentField $ authorshipStatementDefinitionContent . entityVal <$> mSchoolAuthorshipStatement) + <$> fmap sequenceA (fmap (fmap $ fmap authorshipStatementDefinitionContent) . traverse forcedContentField $ entityVal <$> mSchoolAuthorshipStatement) | otherwise -> do examOpts <- let examFieldQuery = E.from $ \exam -> do diff --git a/src/Handler/Sheet/PersonalisedFiles.hs b/src/Handler/Sheet/PersonalisedFiles.hs index 532181664..6c1ec3048 100644 --- a/src/Handler/Sheet/PersonalisedFiles.hs +++ b/src/Handler/Sheet/PersonalisedFiles.hs @@ -171,7 +171,7 @@ sinkPersonalisedSheetFiles cid sid keep Right nSink -> State.modify . Map.insert redResidual $ Map.insert residual nSink sinks openSinks <- State.get lift . lift . mapM_ closeResumableSink $ openSinks ^.. folded . folded - let (nub -> sinkSheets, nub -> sinkUsers) = unzip $ Map.keys openSinks + let (nubOrd -> sinkSheets, nubOrd -> sinkUsers) = unzip $ Map.keys openSinks unless keep $ lift . lift $ deleteWhere [ PersonalisedSheetFileSheet <-. sinkSheets , PersonalisedSheetFileUser /<-. sinkUsers @@ -227,7 +227,7 @@ sourcePersonalisedSheetFiles cId mbsid mbuids anonMode restrs = do E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cId E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid return $ submissionGroup E.^. SubmissionGroupName - return . nub . sort $ map (filter isAlphaNum . foldMap unidecode . unpack . CI.original . E.unValue) subGroups + return . Set.toList . Set.fromList $ map (filter isAlphaNum . foldMap unidecode . unpack . CI.original . E.unValue) subGroups otherAnon | Just f <- userFeature otherAnon -> do features <- E.select . E.from $ \user -> do diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index db3beb8a6..ca4ff3130 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -11,6 +11,7 @@ module Handler.Submission , module Handler.Submission.Create , module Handler.Submission.Grade , module Handler.Submission.Upload + , module Handler.Submission.AuthorshipStatements ) where import Handler.Submission.New @@ -24,6 +25,7 @@ import Handler.Submission.Correction import Handler.Submission.Create import Handler.Submission.Grade import Handler.Submission.Upload +import Handler.Submission.AuthorshipStatements import Handler.Utils diff --git a/src/Handler/Submission/AuthorshipStatements.hs b/src/Handler/Submission/AuthorshipStatements.hs new file mode 100644 index 000000000..ed22014a2 --- /dev/null +++ b/src/Handler/Submission/AuthorshipStatements.hs @@ -0,0 +1,142 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module Handler.Submission.AuthorshipStatements + ( getSubAuthorshipStatementsR + ) where + +import Import +import Handler.Utils +import qualified Database.Esqueleto.Legacy as E +import qualified Database.Esqueleto.Utils as E + + +type AuthorshipStatementsExpr = E.SqlExpr (Entity AuthorshipStatementSubmission) + `E.InnerJoin` E.SqlExpr (Entity User) + `E.InnerJoin` E.SqlExpr (Entity AuthorshipStatementDefinition) + +queryAuthorshipStatement :: Getter AuthorshipStatementsExpr (E.SqlExpr (Entity AuthorshipStatementSubmission)) +queryAuthorshipStatement = to $(E.sqlIJproj 3 1) + +queryUser :: Getter AuthorshipStatementsExpr (E.SqlExpr (Entity User)) +queryUser = to $(E.sqlIJproj 3 2) + +queryDefinition :: Getter AuthorshipStatementsExpr (E.SqlExpr (Entity AuthorshipStatementDefinition)) +queryDefinition = to $(E.sqlIJproj 3 3) + + +type AuthorshipStatementsData = DBRow ( Entity AuthorshipStatementSubmission + , Entity User + , Entity AuthorshipStatementDefinition + ) + +resultAuthorshipStatement :: Lens' AuthorshipStatementsData (Entity AuthorshipStatementSubmission) +resultAuthorshipStatement = _dbrOutput . _1 + +resultUser :: Lens' AuthorshipStatementsData (Entity User) +resultUser = _dbrOutput . _2 + +resultDefinition :: Lens' AuthorshipStatementsData (Entity AuthorshipStatementDefinition) +resultDefinition = _dbrOutput . _3 + + +getSubAuthorshipStatementsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html +getSubAuthorshipStatementsR tid ssh csh shn cID = do + authorshipStatementTable <- runDB $ do + subId <- decrypt cID + Submission{..} <- get404 subId + isLecturer <- (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SSubsR) True + mASDefinition <- getSheetAuthorshipStatement =<< getEntity404 submissionSheet + + let dbtIdent :: Text + dbtIdent = "authorship-statements" + + dbtSQLQuery = runReaderT $ do + authorshipStatement <- view queryAuthorshipStatement + user <- view queryUser + definition <- view queryDefinition + + lift $ do + E.on $ definition E.^. AuthorshipStatementDefinitionId E.==. authorshipStatement E.^. AuthorshipStatementSubmissionStatement + E.on $ user E.^. UserId E.==. authorshipStatement E.^. AuthorshipStatementSubmissionUser + + E.where_ $ authorshipStatement E.^. AuthorshipStatementSubmissionSubmission E.==. E.val subId + + return (authorshipStatement, user, definition) + dbtRowKey = views queryAuthorshipStatement (E.^. AuthorshipStatementSubmissionId) + + dbtProj = dbtProjId + + dbtColonnade :: Colonnade Sortable AuthorshipStatementsData (DBCell (HandlerFor UniWorX) ()) + dbtColonnade = mconcat $ catMaybes + [ pure . sortable (Just "authorship-statement-time") (i18nCell MsgSubmissionColumnAuthorshipStatementTime) $ views (resultAuthorshipStatement . _entityVal . _authorshipStatementSubmissionTime) dateTimeCell + , pure $ colUserDisplayName (resultUser . _entityVal . $(multifocusG 2) _userDisplayName _userSurname) + , guardOn isLecturer $ colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer) + , pure $ lmap (view $ resultUser . _entityVal) colUserEmail + , pure . sortable Nothing (i18nCell MsgSubmissionColumnAuthorshipStatementWording) $ views resultDefinition definitionCell + ] + where + definitionCell (Entity asdId asd) + = withColor . (cellAttrs %~ addAttrsClass "table__td--center") . modalCell $ authorshipStatementWidget asd + where + withColor c + | Just (Entity currASDId _) <- mASDefinition + = c + & cellAttrs %~ addAttrsClass "heated" + & cellAttrs <>~ pure ("style", [st|--hotness: #{tshow (boolHeat (asdId /= currASDId))}|]) + | otherwise + = c + + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + + dbtSorting = mconcat + [ singletonMap "authorship-statement-time" . SortColumn $ views queryAuthorshipStatement (E.^. AuthorshipStatementSubmissionTime) + , sortUserName' (queryUser . $(multifocusG 2) (to (E.^. UserDisplayName)) (to (E.^. UserSurname))) + , sortUserMatriculation (queryUser . to (E.^. UserMatrikelnummer)) + , uncurry singletonMap $ sortUserEmail (view queryUser) + ] + dbtFilter = mconcat + [ fltrUserName' (queryUser . to (E.^. UserDisplayName)) + , fltrUserMatriculation (queryUser . to (E.^. UserMatrikelnummer)) + , uncurry singletonMap $ fltrUserEmail (view queryUser) + , singletonMap "authorship-statement-current" . FilterColumn $ \(view queryAuthorshipStatement -> subStmt) (Last isCurrent) + -> let isCurrent' + | Just (Entity asdId _) <- mASDefinition + = subStmt E.^. AuthorshipStatementSubmissionStatement E.==. E.val asdId + | otherwise + = E.false + in maybe E.true ((E.==. isCurrent') . E.val) isCurrent + ] + + dbtFilterUI = mconcat $ catMaybes + [ pure fltrUserNameUI' + , guardOn isLecturer fltrUserMatriculationUI + , pure fltrUserEmailUI + , pure . flip (prismAForm $ singletonFilter "authorship-statement-current" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgSubmissionFilterAuthorshipStatementCurrent) + ] + + dbtParams = def + + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + asPSValidator = def + & defaultSorting [SortDescBy "authorship-statement-time"] + & restrictFilter lecturerFilter & restrictSorting lecturerSorting + where + lecturerFilter fk _ + | isLecturer = True + | otherwise = fk /= "user-matriculation" + lecturerSorting sk _ + | isLecturer = True + | otherwise = sk /= "user-matriculation" + in dbTableWidget' asPSValidator DBTable{..} + + let (heading, title) = ( MsgSubmissionAuthorshipStatementsHeading tid ssh csh shn cID + , MsgSubmissionAuthorshipStatementsTitle tid ssh csh shn cID + ) + + siteLayoutMsg heading $ do + setTitleI title + + authorshipStatementTable diff --git a/src/Handler/Submission/Grade.hs b/src/Handler/Submission/Grade.hs index 194ac5c35..88b181f50 100644 --- a/src/Handler/Submission/Grade.hs +++ b/src/Handler/Submission/Grade.hs @@ -49,13 +49,13 @@ postCorrectionsGradeR = do ] courseOptions = runDB $ do courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) - optionsPairs $ map (id &&& id) $ nub $ map (CI.original . courseShorthand . entityVal) courses + optionsPairs . map (id &&& id) . nubOrd $ map (CI.original . courseShorthand . entityVal) courses termOptions = runDB $ do courses <- selectList [] [Asc CourseTerm] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) - optionsPairs $ map (id &&& id) $ nub $ map (termToText . unTermKey . courseTerm . entityVal) courses + optionsPairs . map (id &&& id) . nubOrd $ map (termToText . unTermKey . courseTerm . entityVal) courses schoolOptions = runDB $ do courses <- selectList [] [Asc CourseSchool] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) - optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses + optionsPairs . map (id &&& id) . nubOrd $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses psValidator = def & restrictAnonymous & restrictCorrector diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index 36f28f1e1..d32baf2a4 100644 --- a/src/Handler/Submission/Helper.hs +++ b/src/Handler/Submission/Helper.hs @@ -32,7 +32,7 @@ import qualified Data.Conduit.Combinators as C data AuthorshipStatementSubmissionState - = ASOkay + = ASExists | ASOldStatement | ASMissing deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) @@ -570,7 +570,7 @@ submissionHelper tid ssh csh shn mcid = do , formEncoding = formEnctype } - ((Entity _ Sheet{..}, _, lastEdits, maySubmit, _, _, msubmission, corrector, _), (showCorrection, correctionInvisible), mFileTable, filesCorrected, sheetTypeDesc, multipleSubmissionWarnWidget, subUsers, isLecturer, doAuthorshipStatements) <- runDB $ do + ((Entity _ Sheet{..}, _, lastEdits, maySubmit, _, _, msubmission, corrector, _), (showCorrection, correctionInvisible), mFileTable, filesCorrected, sheetTypeDesc, multipleSubmissionWarnWidget, subUsers, isLecturer, isOwner, doAuthorshipStatements) <- runDB $ do sheetInfo@(Entity shid Sheet{..}, buddies, _, _, isLecturer, isOwner, msubmission, _, mASDefinition) <- getSheetInfo (showCorrection, correctionInvisible) <- fmap (fromMaybe (False, Nothing)) . for ((,) <$> mcid <*> (Entity <$> msmid <*> msubmission)) $ \(cid, subEnt) -> do @@ -621,7 +621,7 @@ submissionHelper tid ssh csh shn mcid = do toPoint (Entity _ AuthorshipStatementSubmission{..}) = Just . Any $ fmap entityKey mASDefinition == Just authorshipStatementSubmissionStatement toRes :: Maybe Any -> AuthorshipStatementSubmissionState toRes = \case - Just (Any True) -> ASOkay + Just (Any True) -> ASExists Just (Any False) -> ASOldStatement Nothing -> ASMissing lift $ buddies @@ -630,12 +630,17 @@ submissionHelper tid ssh csh shn mcid = do & mapMOf (traverse . _Right) (\uid -> (,,) <$> (encrypt uid :: DB CryptoUUIDUser) <*> getJust uid <*> getUserAuthorshipStatement uid) & fmap (sortOn . over _Right $ (,,,) <$> views _2 userSurname <*> views _2 userDisplayName <*> views _2 userEmail <*> view _1) - return (sheetInfo, (showCorrection, correctionInvisible), mFileTable, filesCorrected, sheetTypeDesc, multipleSubmissionWarnWidget, subUsers, isLecturer, is _Just mASDefinition) + return (sheetInfo, (showCorrection, correctionInvisible), mFileTable, filesCorrected, sheetTypeDesc, multipleSubmissionWarnWidget, subUsers, isLecturer, isOwner, is _Just mASDefinition) -- TODO(AuthorshipStatements): discuss whether to display prompt for user to update their authorship statement, if lecturer changed it + + let (title, heading) + | Just cID <- mcid, maySubmit, not isLecturer || isOwner = (MsgSubmissionTitle tid ssh csh shn cID, MsgSubmissionHeadingEdit tid ssh csh shn cID) + | Just cID <- mcid = (MsgSubmissionTitle tid ssh csh shn cID, MsgSubmissionHeadingShow tid ssh csh shn cID) + | otherwise = (MsgSubmissionTitleNew tid ssh csh shn, MsgSubmissionHeadingNew tid ssh csh shn) - defaultLayout $ do - setTitleI $ MsgHeadingSubmissionEditHead tid ssh csh shn + siteLayoutMsg heading $ do + setTitleI title (urlArchive, urlOriginal) <- fmap ((,) <$> preview (_Just . _1) <*> preview (_Just . _2)) . for mcid $ \cID -> let mkUrl sft = toTextUrl . CSubmissionR tid ssh csh shn cID $ SubArchiveR sft in liftHandler . runDB $ (,) <$> mkUrl SubmissionCorrected <*> mkUrl SubmissionOriginal @@ -650,7 +655,8 @@ submissionHelper tid ssh csh shn mcid = do correctionVisibleWarnWidget = guardOnM (is _Just msubmission && is _Just mcid && showCorrection) correctionInvisible asStatusExplain = $(i18nWidgetFiles "authorship-statement-submission-explanation") asStatuses = setOf (folded . _Right . _3) subUsers - & Set.union (Set.fromList [ASOkay, ASMissing]) + & Set.union (Set.fromList [ASExists, ASMissing]) & Set.toList & mapMaybe (\stmt -> (stmt, ) <$> asStatusExplain Map.!? toPathPiece stmt) + asStatusExplainWdgt = $(widgetFile "widgets/authorship-statement-submission-explanation") $(widgetFile "submission") diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index 72ef9192a..345cadd99 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -154,7 +154,7 @@ colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgTableMatr colSGroups :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSGroups = sortable (Just "submittors-group") (i18nCell MsgTableSubmissionGroup) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, _, _, _, users, _, hasAccess) } -> - let protoCell = listCell (nubOn (view _2) . Map.toList $ Map.mapMaybe (view _3) users) $ \(_, sGroup) -> cell $ toWidget sGroup + let protoCell = listCell (nubOrdOn (view _2) . Map.toList $ Map.mapMaybe (view _3) users) $ \(_, sGroup) -> cell $ toWidget sGroup in if | hasAccess , is _RegisteredGroups sheetGrouping -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] @@ -680,13 +680,13 @@ postCorrectionsR = do ] courseOptions = runDB $ do courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) - optionsPairs $ map (id &&& id) $ nub $ map (CI.original . courseShorthand . entityVal) courses + optionsPairs . map (id &&& id) . nubOrd $ map (CI.original . courseShorthand . entityVal) courses termOptions = runDB $ do courses <- selectList [] [Desc CourseTerm] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) - optionsPairs $ map (id &&& id) $ nub $ map (termToText . unTermKey . courseTerm . entityVal) courses + optionsPairs . map (id &&& id) . nubOrd $ map (termToText . unTermKey . courseTerm . entityVal) courses schoolOptions = runDB $ do courses <- selectList [] [Asc CourseSchool] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) - optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses + optionsPairs . map (id &&& id) . nubOrd $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses psValidator = def & restrictCorrector diff --git a/src/Handler/Utils/AuthorshipStatement.hs b/src/Handler/Utils/AuthorshipStatement.hs index 9822ef739..fa09969d9 100644 --- a/src/Handler/Utils/AuthorshipStatement.hs +++ b/src/Handler/Utils/AuthorshipStatement.hs @@ -16,6 +16,9 @@ import Handler.Utils.Form (i18nLangMap, I18nLang(..)) import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E +import qualified Data.ByteString.Base64.URL as Base64 +import qualified Data.ByteArray as BA + insertAuthorshipStatement :: MonadIO m => I18nStoredMarkup -> SqlWriteT m AuthorshipStatementDefinitionId @@ -26,7 +29,7 @@ insertAuthorshipStatement authorshipStatementDefinitionContent = withCompatibleB return $ AuthorshipStatementDefinitionKey authorshipStatementDefinitionHash forcedAuthorshipStatementField :: (MonadHandler handler, HandlerSite handler ~ UniWorX) - => Field handler I18nStoredMarkup + => Field handler AuthorshipStatementDefinition forcedAuthorshipStatementField = Field{..} where fieldParse _ _ = pure . Left $ SomeMessage ("Result of forcedAuthorshipStatementField inspected" :: Text) @@ -38,23 +41,27 @@ forcedAuthorshipStatementField = Field{..} ^{maybe mempty authorshipStatementWidget mVal} |] -authorshipStatementWidget :: I18nStoredMarkup -> Widget -authorshipStatementWidget stmt +authorshipStatementWidget :: AuthorshipStatementDefinition -> Widget +authorshipStatementWidget AuthorshipStatementDefinition{..} = [whamlet| $newline never
- $forall (I18nLang l, t) <- Map.toList (review i18nLangMap stmt) + $forall (I18nLang l, t) <- Map.toList (review i18nLangMap authorshipStatementDefinitionContent)
_{MsgLanguageEndonym l}
#{markupOutput t} + +

+ #{hashText} |] + where hashText = decodeUtf8 . Base64.encodeUnpadded $ BA.convert authorshipStatementDefinitionHash acceptAuthorshipStatementField :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => Entity AuthorshipStatementDefinition -> Field m AuthorshipStatementDefinitionId -acceptAuthorshipStatementField (Entity asdId AuthorshipStatementDefinition{..}) +acceptAuthorshipStatementField (Entity asdId asd) = checkBoxField & _fieldView %~ adjFieldView & checkMap (bool (Left MsgAuthorshipStatementStatementIsRequired) (Right asdId)) (== asdId) diff --git a/src/Handler/Utils/I18n.hs b/src/Handler/Utils/I18n.hs index f6c2d39b4..3718958a0 100644 --- a/src/Handler/Utils/I18n.hs +++ b/src/Handler/Utils/I18n.hs @@ -30,7 +30,7 @@ i18nFile includeFile basename = do -- Construct list of available translations (@de@, @en@, ...) at compile time let i18nDirectory = "templates" "i18n" basename availableFiles <- qRunIO $ listDirectory i18nDirectory - let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . List.nub $ pack . takeBaseName <$> availableFiles + let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . nubOrd $ pack . takeBaseName <$> availableFiles availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations -- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index 9c6436c52..6ec6d7e42 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -323,7 +323,7 @@ deleteInvitationsF :: forall junction m mono backend. -> ReaderT backend m () -- | Non-conduit version of `deleteInvitations` deleteInvitationsF invitationFor (otoList -> emailList) - = deleteWhere [InvitationEmail <-. nub emailList, InvitationFor ==. invRef @junction invitationFor] + = deleteWhere [InvitationEmail <-. nubOrd emailList, InvitationFor ==. invRef @junction invitationFor] deleteInvitation :: forall junction m backend. ( IsInvitableJunction junction diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index c49d6d99a..1d5e5ab7a 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -362,7 +362,7 @@ submissionMultiArchive anonymous sft (Set.toList -> ids) = do E.where_ $ submission E.^. SubmissionId E.==. E.val submissionID E.where_ $ sheet E.^. SheetCourse E.==. submissionGroup E.^. SubmissionGroupCourse return $ submissionGroup E.^. SubmissionGroupName - let asciiGroups = nub . sort $ map (filter isAlphaNum . foldMap unidecode . unpack . CI.original . E.unValue) groups + let asciiGroups = Set.toList . Set.fromList $ map (filter isAlphaNum . foldMap unidecode . unpack . CI.original . E.unValue) groups return . intercalate "_" $ asciiGroups `snoc` fp | Just feature <- userFeature anonymous = do diff --git a/src/Handler/Utils/TermCandidates.hs b/src/Handler/Utils/TermCandidates.hs index 652970c1b..d2b2359b1 100644 --- a/src/Handler/Utils/TermCandidates.hs +++ b/src/Handler/Utils/TermCandidates.hs @@ -18,7 +18,6 @@ import Import -- import Control.Monad.Trans.Writer (mapWriterT) -- import Database.Persist.Sql (fromSqlKey) import qualified Data.Set as Set -import qualified Data.List as List import qualified Data.Map as Map @@ -112,7 +111,7 @@ removeAmbiguousNames = do ) E.having $ E.countRows E.!=. E.val (1 :: Int64) return $ candidate E.^. StudyTermNameCandidateIncidence - let ambiSet = E.unValue <$> List.nub ambiList + let ambiSet = E.unValue <$> nubOrd ambiList -- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps. deleteWhere [StudyTermNameCandidateIncidence <-. ambiSet] return ambiSet diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index a3386447f..96d21ff20 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -104,6 +104,10 @@ editedByW fmt tm usr = do ft <- handlerToWidget $ formatTime fmt tm [whamlet|_{MsgUtilEditedBy usr ft}|] +boolHeat :: Bool -- ^ @isHot@ + -> Milli +boolHeat = bool 0 1 + heat :: ( Real a, Real b ) => a -> b -> Milli -- ^ Distinguishes @full@, zero is mapped to 1, @full@ is mapped to 0 diff --git a/src/Handler/Utils/Workflow/Workflow.hs b/src/Handler/Utils/Workflow/Workflow.hs index 7294810db..383e46377 100644 --- a/src/Handler/Utils/Workflow/Workflow.hs +++ b/src/Handler/Utils/Workflow/Workflow.hs @@ -70,7 +70,7 @@ followAutomaticEdges WorkflowGraph{..} = go [] | otherwise = throwM . WorkflowAutomaticEdgeAmbiguity $ Set.fromList automaticEdgeOptions where cState = wpTo $ last history - automaticEdgeOptions = nub $ do + automaticEdgeOptions = nubOrd $ do (nodeLbl, WGN{..}) <- Map.toList wgNodes (edgeLbl, WorkflowGraphEdgeAutomatic{..}) <- Map.toList wgnEdges guard $ wgeSource == cState diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index adace86d9..aa3247ccd 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -116,7 +116,7 @@ determineNotificationCandidates = awaitForever $ \notif -> do E.where_ $ admin E.^. UserFunctionSchool `E.in_` E.valList (Set.toList newAdminSchools) E.&&. admin E.^. UserFunctionFunction E.==. E.val SchoolAdmin return user - withNotif . yieldMany . nub $ affectedUser <> affectedAdmins + withNotif . yieldMany . nubOrd $ affectedUser <> affectedAdmins NotificationUserSystemFunctionsUpdate{..} -> withNotif $ selectSource [UserId ==. nUser] [] NotificationUserAuthModeUpdate{..} diff --git a/src/Jobs/Handler/SendNotification/Allocation.hs b/src/Jobs/Handler/SendNotification/Allocation.hs index 52e7e0a22..b8b9e9fa9 100644 --- a/src/Jobs/Handler/SendNotification/Allocation.hs +++ b/src/Jobs/Handler/SendNotification/Allocation.hs @@ -56,7 +56,7 @@ dispatchNotificationAllocationRegister (otoList -> nAllocations) jRecipient = us dispatchNotificationAllocationAllocation :: Set AllocationId -> UserId -> Handler () dispatchNotificationAllocationAllocation (otoList -> nAllocations) jRecipient = do - courses <- fmap (nubOn $ views _2 entityKey) . runDB . E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` allocation `E.InnerJoin` lecturer) -> do + courses <- fmap (nubOrdOn $ views _2 entityKey) . runDB . E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` allocation `E.InnerJoin` lecturer) -> do E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId @@ -73,7 +73,7 @@ dispatchNotificationAllocationAllocation (otoList -> nAllocations) jRecipient = return (allocation, course) - let allocations = nubOn entityKey $ courses ^.. folded . _1 + let allocations = nubOrdOn entityKey $ courses ^.. folded . _1 unless (null courses) . userMailT jRecipient $ do now <- liftIO getCurrentTime @@ -95,7 +95,7 @@ dispatchNotificationAllocationAllocation (otoList -> nAllocations) jRecipient = dispatchNotificationAllocationUnratedApplications :: Set AllocationId -> UserId -> Handler () dispatchNotificationAllocationUnratedApplications (otoList -> nAllocations) jRecipient = do - courses <- fmap (nubOn (views _2 entityKey) . over (traverse . _3) (fromIntegral . E.unValue)) . runDB . E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` allocation `E.InnerJoin` lecturer) -> do + courses <- fmap (nubOrdOn (views _2 entityKey) . over (traverse . _3) (fromIntegral . E.unValue)) . runDB . E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` allocation `E.InnerJoin` lecturer) -> do E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId @@ -121,7 +121,7 @@ dispatchNotificationAllocationUnratedApplications (otoList -> nAllocations) jRec return (allocation, course, unratedAppCount) - let allocations = nubOn entityKey $ courses ^.. folded . _1 + let allocations = nubOrdOn entityKey $ courses ^.. folded . _1 unless (null courses) . userMailT jRecipient $ do replaceMailHeader "Auto-Submitted" $ Just "auto-generated" diff --git a/src/Settings/StaticFiles/Webpack.hs b/src/Settings/StaticFiles/Webpack.hs index 999f959ab..3449d1a88 100644 --- a/src/Settings/StaticFiles/Webpack.hs +++ b/src/Settings/StaticFiles/Webpack.hs @@ -23,12 +23,13 @@ import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Trans.Writer.Lazy (execWriterT) import Control.Monad.Catch (MonadThrow(..)) -import Utils (nubOn) - import System.FilePath (makeRelative) import Text.Shakespeare.Text (st) +import Utils () +import Data.Containers.ListUtils + mkWebpackEntrypoints :: FilePath -- ^ Path to YAML-manifest -> [FilePath -> Generator] @@ -62,7 +63,7 @@ mkWebpackEntrypoints manifest mkGen stDir = do sequence [ sigD entryName [t|[(Route EmbeddedStatic, MimeType)]|] , funD entryName - [ clause [] (normalB . listE . map (\(n, mime) -> tupE [varE n, TH.lift mime]) $ nubOn fst entries) [] + [ clause [] (normalB . listE . map (\(n, mime) -> tupE [varE n, TH.lift mime]) $ nubOrdOn fst entries) [] ] , sigD widgetName [t|forall m. (MonadLogger m, MonadWidget m) => (Route EmbeddedStatic -> Route (HandlerSite m)) -> m ()|] , funD widgetName diff --git a/src/Utils.hs b/src/Utils.hs index 0b255f9e1..70cc0d4d0 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,6 +1,6 @@ module Utils ( module Utils - , List.nub, List.nubBy + , module Data.Containers.ListUtils ) where import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch, bracket) @@ -50,7 +50,6 @@ import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight) import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Data.List as List import qualified Data.HashMap.Strict as HashMap import qualified Data.Vector as V @@ -149,6 +148,8 @@ import Data.Ratio ((%)) import Data.UUID (UUID) import qualified Data.UUID as UUID +import Data.Containers.ListUtils + {-# ANN module ("HLint: ignore Use asum" :: String) #-} @@ -252,6 +253,12 @@ selectRep' cMap' needle = asum (needleMain, needleSub) = contentTypeTypes needle noSpaces = CBS.filter (/= ' ') + +addAttrsClass :: Text -> [(Text, Text)] -> [(Text, Text)] +addAttrsClass cl attrs = ("class", cl') : noClAttrs + where + (clAttrs, noClAttrs) = partition (views _1 $ (== "class") . CI.mk) attrs + cl' = Text.intercalate " " . nubOrd . filter (not . null) $ cl : (views _2 (Text.splitOn " ") =<< clAttrs) --------------------- -- Text and String -- @@ -538,9 +545,6 @@ partitionWith f (x:xs) = case f x of nonEmpty' :: Alternative f => [a] -> f (NonEmpty a) nonEmpty' = maybe empty pure . nonEmpty -nubOn :: Eq b => (a -> b) -> [a] -> [a] -nubOn = List.nubBy . ((==) `on`) - dropWhileM :: (IsSequence seq, Monad m) => (Element seq -> m Bool) -> seq -> m seq dropWhileM p xs' | Just (x, xs) <- uncons xs' diff --git a/src/Utils/Lang.hs b/src/Utils/Lang.hs index 4a5f948f6..ad83921c1 100644 --- a/src/Utils/Lang.hs +++ b/src/Utils/Lang.hs @@ -23,6 +23,8 @@ import Control.Monad.Reader.Class (local) import qualified Data.HashMap.Strict as HashMap +import Data.Containers.ListUtils + selectLanguage :: MonadHandler m => NonEmpty Lang -- ^ Available translations, first is default @@ -39,7 +41,7 @@ selectLanguages (defL :| _) [] = defL :| [] selectLanguages avL (l:ls) | not $ null l , Just lParts <- nonEmpty $ matchesFor l - , found <- List.nub + , found <- nubOrd [ l'' | lParts' <- NonEmpty.toList lParts , l' <- NonEmpty.toList avL , l'' <- matchesFor l' @@ -69,7 +71,7 @@ lowPrioRequestedLangs = maybe [] (mapMaybe (either (const Nothing) Just . Text.d languagesMiddleware :: forall site a. NonEmpty Lang -> HandlerFor site a -> HandlerFor site a languagesMiddleware avL act = do - pLangs <- fmap List.nub $ (<>) <$> highPrioRequestedLangs <*> lowPrioRequestedLangs + pLangs <- fmap nubOrd $ (<>) <$> highPrioRequestedLangs <*> lowPrioRequestedLangs let langs = toList $ selectLanguages avL pLangs setLangs hData = hData{ handlerRequest = (handlerRequest hData){ reqLangs = langs } } local setLangs $ ($logDebugS "languages" . tshow . (pLangs,langs,) =<< languages) *> act diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 6e13afc09..59f8266fa 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -281,6 +281,9 @@ makeLenses_ ''RoomReference makePrisms ''SchoolAuthorshipStatementMode makePrisms ''SheetAuthorshipStatementMode +makeLenses_ ''AuthorshipStatementSubmission +makeLenses_ ''AuthorshipStatementDefinition + -------------------------- -- Fields for `UniWorX` -- -------------------------- diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index e1aaa3a9b..3a46b2cff 100644 --- a/src/Utils/PathPiece.hs +++ b/src/Utils/PathPiece.hs @@ -29,7 +29,7 @@ import qualified Data.HashMap.Strict as HashMap import Numeric.Natural -import Data.List (nub, foldl) +import Data.List (foldl) import Data.Aeson.Types import qualified Data.Aeson.Types as Aeson @@ -47,6 +47,8 @@ import Web.HttpApiData import Data.ByteString.Lazy.Base32 import qualified Data.CaseInsensitive as CI +import Data.Containers.ListUtils + mkFiniteFromPathPiece :: Name -> Q ([Dec], Exp) mkFiniteFromPathPiece finiteType = do @@ -178,7 +180,7 @@ derivePathPiece adt mangle joinPP = do usesVar ConstructorInfo{..} n | n `elem` map tvarName constructorVars = False | otherwise = any (elemOf types n) constructorFields - fieldTypes = nub $ concatMap constructorFields datatypeCons + fieldTypes = nubOrd $ concatMap constructorFields datatypeCons tvarName (PlainTV n) = n tvarName (KindedTV n _) = n sequence . (finDecs ++ ) . pure $ diff --git a/templates/i18n/authorship-statement-submission-explanation/okay.de-de-formal.hamlet b/templates/i18n/authorship-statement-submission-explanation/exists.de-de-formal.hamlet similarity index 100% rename from templates/i18n/authorship-statement-submission-explanation/okay.de-de-formal.hamlet rename to templates/i18n/authorship-statement-submission-explanation/exists.de-de-formal.hamlet diff --git a/templates/i18n/authorship-statement-submission-explanation/okay.en-eu.hamlet b/templates/i18n/authorship-statement-submission-explanation/exists.en-eu.hamlet similarity index 100% rename from templates/i18n/authorship-statement-submission-explanation/okay.en-eu.hamlet rename to templates/i18n/authorship-statement-submission-explanation/exists.en-eu.hamlet diff --git a/templates/submission.hamlet b/templates/submission.hamlet index d08823b91..86de7f9ec 100644 --- a/templates/submission.hamlet +++ b/templates/submission.hamlet @@ -1,5 +1,5 @@ $newline never -$if is _Just mcid +$maybe subCId <- mcid $maybe wdgt <- correctionWdgt

_{MsgTableRating} @@ -30,10 +30,11 @@ $if is _Just mcid
_{MsgSubmissionUserEmail} - $if isLecturer && doAuthorshipStatements + $if doAuthorshipStatements
- _{MsgSubmissionUserAuthorshipStatementState} + ^{simpleLinkI MsgSubmissionUserAuthorshipStatementState (CSubmissionR tid ssh csh shn subCId SubAuthorshipStatementsR)} + ^{iconTooltip asStatusExplainWdgt Nothing True} $forall subUser <- subUsers $case subUser @@ -63,24 +64,10 @@ $if is _Just mcid #{userEmail} $# TODO(AuthorshipStatements): show authorship statements to submittors? - $if isLecturer && doAuthorshipStatements - + $if doAuthorshipStatements +
_{stmt} - $if isLecturer && doAuthorshipStatements - - - - - - -
-
- $forall (stmt, explanation) <- asStatuses -
- _{stmt} -
- ^{explanation}
$case sheetSubmissionMode @@ -121,5 +108,5 @@ $if is _Just mcid

_{MsgSubmissionReplace} ^{formWidget} -$else +$nothing ^{formWidget} diff --git a/templates/widgets/authorship-statement-accept.hamlet b/templates/widgets/authorship-statement-accept.hamlet index df9e72615..f5c894bca 100644 --- a/templates/widgets/authorship-statement-accept.hamlet +++ b/templates/widgets/authorship-statement-accept.hamlet @@ -1,7 +1,7 @@ $newline never
- ^{authorshipStatementWidget authorshipStatementDefinitionContent} + ^{authorshipStatementWidget asd}