fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(submissions): display authorship statements

Browse Source
This commit is contained in:
Gregor Kleen 2021-08-12 17:38:59 +02:00
parent cbd6d7d2b0
commit 7749238e55
48 changed files with 299 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
frontend/src/app.sass
View File

@ -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)

17
messages/uniworx/categories/courses/submission/de-de-formal.msg
View File

@ -210,6 +210,19 @@ SubmissionUserMatriculation: Matrikelnummer
SubmissionUserEmail: E-Mail
SubmissionUserAuthorshipStatementState: Eigenständigkeitserklärung
SubmissionAuthorshipStatementStateOkay: In Ordnung
SubmissionAuthorshipStatementStateExists: Vorhanden
SubmissionAuthorshipStatementStateOldStatement: Unpassender Wortlaut
SubmissionAuthorshipStatementStateMissing: Fehlt
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

15
messages/uniworx/categories/courses/submission/en-eu.msg
View File

@ -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

3
messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg
View File

@ -186,4 +186,5 @@ BreadcrumbCorrectionsGrade: Korrekturen eintragen
BreadcrumbMessageList: Systemnachrichten
BreadcrumbGlossary: Begriffsverzeichnis
BreadcrumbLogin !ident-ok: Login
BreadcrumbNews: Aktuell
BreadcrumbNews: Aktuell
BreadcrumbSubmissionAuthorshipStatements: Eigenständigkeitserklärungen

1
messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg
View File

@ -187,3 +187,4 @@ BreadcrumbSheetCurrent: Current exercise sheet
BreadcrumbSheetOldUnassigned: Submissions without corrector
BreadcrumbLogin: Login
BreadcrumbNews: News
BreadcrumbSubmissionAuthorshipStatements: Statements of Authorship

1
routes
View File

@ -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

2
src/Auth/LDAP.hs
View File

@ -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

5
src/Data/Universe/TH.hs
View File

@ -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

8
src/Foundation/I18n.hs
View File

@ -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)

9
src/Foundation/Navigation.hs
View File

@ -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

4
src/Foundation/Yesod/Auth.hs
View File

@ -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

4
src/Handler/Allocation/Accept.hs
View File

@ -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

2
src/Handler/Allocation/Show.hs
View File

@ -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

2
src/Handler/Course/Application/List.hs
View File

@ -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

2
src/Handler/Course/Edit.hs
View File

@ -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

2
src/Handler/Course/Users.hs
View File

@ -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)

2
src/Handler/Exam/Form.hs
View File

@ -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

2
src/Handler/ExamOffice/Users.hs
View File

@ -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

2
src/Handler/ExternalExam/Form.hs
View File

@ -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

2
src/Handler/Metrics.hs
View File

@ -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

2
src/Handler/Sheet/Form.hs
View File

@ -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

4
src/Handler/Sheet/PersonalisedFiles.hs
View File

@ -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

2
src/Handler/Submission.hs
View File

@ -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

142
src/Handler/Submission/AuthorshipStatements.hs Normal file
View File

@ -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

6
src/Handler/Submission/Grade.hs
View File

@ -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

20
src/Handler/Submission/Helper.hs
View File

@ -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")

8
src/Handler/Submission/List.hs
View File

@ -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

17
src/Handler/Utils/AuthorshipStatement.hs
View File

@ -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
<dl .authorship-statement>
$forall (I18nLang l, t) <- Map.toList (review i18nLangMap stmt)
$forall (I18nLang l, t) <- Map.toList (review i18nLangMap authorshipStatementDefinitionContent)
<dt>
_{MsgLanguageEndonym l}
<dd>
#{markupOutput t}
<p .authorship-statement__id>
#{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)

2
src/Handler/Utils/I18n.hs
View File

@ -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

2
src/Handler/Utils/Invitations.hs
View File

@ -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

2
src/Handler/Utils/Submission.hs
View File

@ -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

3
src/Handler/Utils/TermCandidates.hs
View File

@ -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

4
src/Handler/Utils/Widgets.hs
View File

@ -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

2
src/Handler/Utils/Workflow/Workflow.hs
View File

@ -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

2
src/Jobs/Handler/QueueNotification.hs
View File

@ -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{..}

8
src/Jobs/Handler/SendNotification/Allocation.hs
View File

@ -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"

7
src/Settings/StaticFiles/Webpack.hs
View File

@ -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

14
src/Utils.hs
View File

@ -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'

6
src/Utils/Lang.hs
View File

@ -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

3
src/Utils/Lens.hs
View File

@ -281,6 +281,9 @@ makeLenses_ ''RoomReference
makePrisms ''SchoolAuthorshipStatementMode
makePrisms ''SheetAuthorshipStatementMode
makeLenses_ ''AuthorshipStatementSubmission
makeLenses_ ''AuthorshipStatementDefinition
--------------------------
-- Fields for `UniWorX` --
--------------------------

6
src/Utils/PathPiece.hs
View File

@ -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 $

0
templates/i18n/authorship-statement-submission-explanation/okay.de-de-formal.hamlet → templates/i18n/authorship-statement-submission-explanation/exists.de-de-formal.hamlet
View File

0
templates/i18n/authorship-statement-submission-explanation/okay.en-eu.hamlet → templates/i18n/authorship-statement-submission-explanation/exists.en-eu.hamlet
View File

27
templates/submission.hamlet
View File

@ -1,5 +1,5 @@
$newline never
$if is _Just mcid
$maybe subCId <- mcid
$maybe wdgt <- correctionWdgt
<section>
<h2>_{MsgTableRating}
@ -30,10 +30,11 @@ $if is _Just mcid
<th .table__th>
<div .table__td-content>
_{MsgSubmissionUserEmail}
$if isLecturer && doAuthorshipStatements
$if doAuthorshipStatements
<th .table__th>
<div .table__td-content>
_{MsgSubmissionUserAuthorshipStatementState}
^{simpleLinkI MsgSubmissionUserAuthorshipStatementState (CSubmissionR tid ssh csh shn subCId SubAuthorshipStatementsR)}
^{iconTooltip asStatusExplainWdgt Nothing True}
<tbody>
$forall subUser <- subUsers
$case subUser
@ -63,24 +64,10 @@ $if is _Just mcid
<a href="mailto:#{userEmail}">
#{userEmail}
$# TODO(AuthorshipStatements): show authorship statements to submittors?
$if isLecturer && doAuthorshipStatements
<td .table__td>
$if doAuthorshipStatements
<td .table__td .heated style="--hotness: #{boolHeat (stmt /= ASExists)}">
<div .table__td-content>
_{stmt}
$if isLecturer && doAuthorshipStatements
<tfoot>
<tr .table__row .table__row--foot .no-stripe .no-hover>
<td>
<td>
<td>
<td .table__td>
<div .table__td-content .explanation>
<dl .deflist>
$forall (stmt, explanation) <- asStatuses
<dt .deflist__dt>
_{stmt}
<dd .deflist__dd>
^{explanation}
<section>
$case sheetSubmissionMode
@ -121,5 +108,5 @@ $if is _Just mcid
<section>
<h2>_{MsgSubmissionReplace}
^{formWidget}
$else
$nothing
^{formWidget}

2
templates/widgets/authorship-statement-accept.hamlet
View File

@ -1,7 +1,7 @@
$newline never
<div *{attrs} .authorship-statement-accept__container>
<div .authorship-statement-accept__statement>
^{authorshipStatementWidget authorshipStatementDefinitionContent}
^{authorshipStatementWidget asd}
<label for=#{checkboxId} .authorship-statement-accept__accept>
<div .authorship-statement-accept__accept-checkbox>

8
templates/widgets/authorship-statement-submission-explanation.hamlet Normal file
View File

@ -0,0 +1,8 @@
$newline never
<div .explanation>
<dl .deflist>
$forall (stmt, explanation) <- asStatuses
<dt .deflist__dt>
_{stmt}
<dd .deflist__dd>
^{explanation}

2
test/Database/Fill.hs
View File

@ -1320,7 +1320,7 @@ fillDb = do
bigAllocShorthands <-
let go xs = let (csh, xs') = List.splitAt 3 xs
in pack csh : go xs'
in take 40 . nub . go <$> getRandomRs ('A', 'Z')
in take 40 . nubOrd . go <$> getRandomRs ('A', 'Z')
bigAllocCourses <- forM (zip [1..] bigAllocShorthands) $ \(n :: Natural, csh) -> do
cap <- getRandomR (10,50)

4
translate.hs
View File

@ -58,6 +58,8 @@ import Data.Ord (Down(..))
import Control.Monad.Catch
import Data.Containers.ListUtils
data Translate
= TranslateMsgs
@ -131,7 +133,7 @@ main = main' =<< run
main' m@TranslateMsgs{..}
| null msgRequiredLangs = main' m{ msgRequiredLangs = ["de-de-formal", "en-eu"] }
| otherwise = do
msgFiles' <- nub . (msgFiles ++) <$> getMissingFiles m
msgFiles' <- nubOrd . (msgFiles ++) <$> getMissingFiles m
let
filePairs :: [(FilePath, FilePath)]