refactor: be more explicit about ARC strictness

This commit is contained in:
Gregor Kleen 2021-04-09 12:27:04 +02:00
parent 74367275ac
commit 1717785a51
48 changed files with 280 additions and 130 deletions

View File

@ -31,6 +31,7 @@ AllocationMatching
fingerprint AllocationFingerprint fingerprint AllocationFingerprint
time UTCTime time UTCTime
log FileContentReference log FileContentReference
deriving Generic
AllocationCourse AllocationCourse
allocation AllocationId allocation AllocationId
@ -38,6 +39,7 @@ AllocationCourse
minCapacity Int -- if the course would get assigned fewer than this many applicants, restart the assignment process without the course minCapacity Int -- if the course would get assigned fewer than this many applicants, restart the assignment process without the course
acceptSubstitutes UTCTime Maybe acceptSubstitutes UTCTime Maybe
UniqueAllocationCourse course UniqueAllocationCourse course
deriving Generic
AllocationUser AllocationUser
allocation AllocationId allocation AllocationId
@ -45,17 +47,18 @@ AllocationUser
totalCourses Word64 -- number of total allocated courses for this user must be <= than this number totalCourses Word64 -- number of total allocated courses for this user must be <= than this number
priority AllocationPriority Maybe priority AllocationPriority Maybe
UniqueAllocationUser allocation user UniqueAllocationUser allocation user
deriving Eq Ord Show deriving Eq Ord Show Generic
AllocationDeregister -- self-inflicted user-deregistrations from an allocated course AllocationDeregister -- self-inflicted user-deregistrations from an allocated course
user UserId user UserId
course CourseId Maybe course CourseId Maybe
time UTCTime time UTCTime
reason Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button) reason Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button)
deriving Eq Ord Show deriving Eq Ord Show Generic
AllocationNotificationSetting AllocationNotificationSetting
user UserId user UserId
allocation AllocationId allocation AllocationId
isOptOut Bool isOptOut Bool
UniqueAllocationNotificationSetting user allocation UniqueAllocationNotificationSetting user allocation
deriving Generic

View File

@ -5,4 +5,4 @@ TransactionLog
initiator UserId Maybe -- User associated with performing this action initiator UserId Maybe -- User associated with performing this action
remote IP Maybe -- Remote party that triggered this action via HTTP remote IP Maybe -- Remote party that triggered this action via HTTP
info Value -- JSON-encoded `Transaction` info Value -- JSON-encoded `Transaction`
deriving Eq Read Show Generic Typeable deriving Eq Read Show Generic

View File

@ -2,3 +2,4 @@ ChangelogItemFirstSeen
item ChangelogItem item ChangelogItem
firstSeen Day firstSeen Day
Primary item Primary item
deriving Generic

View File

@ -4,3 +4,4 @@ ClusterConfig
setting ClusterSettingsKey -- I.e. Symmetric key for encrypting database-ids for use in URLs, Symmetric key for encrypting user-sessions so they can be saved directly as a browser-cookie, Symmetric key for encrypting error messages which might contain secret information, ... setting ClusterSettingsKey -- I.e. Symmetric key for encrypting database-ids for use in URLs, Symmetric key for encrypting user-sessions so they can be saved directly as a browser-cookie, Symmetric key for encrypting error messages which might contain secret information, ...
value Value -- JSON-encoded value value Value -- JSON-encoded value
Primary setting Primary setting
deriving Generic

View File

@ -3,6 +3,7 @@ DegreeCourse json -- for which degree programmes this course is appropriate fo
degree StudyDegreeId degree StudyDegreeId
terms StudyTermsId terms StudyTermsId
UniqueDegreeCourse course degree terms UniqueDegreeCourse course degree terms
deriving Generic
Course -- Information about a single course; contained info is always visible to all users Course -- Information about a single course; contained info is always visible to all users
name (CI Text) name (CI Text)
description StoredMarkup Maybe -- user-defined large Html, ought to contain module description description StoredMarkup Maybe -- user-defined large Html, ought to contain module description
@ -36,6 +37,7 @@ CourseEvent
time Occurrences time Occurrences
note StoredMarkup Maybe note StoredMarkup Maybe
lastChanged UTCTime default=now() lastChanged UTCTime default=now()
deriving Generic
CourseAppInstructionFile CourseAppInstructionFile
course CourseId course CourseId
@ -43,16 +45,19 @@ CourseAppInstructionFile
content FileContentReference Maybe content FileContentReference Maybe
modified UTCTime modified UTCTime
UniqueCourseAppInstructionFile course title UniqueCourseAppInstructionFile course title
deriving Generic
CourseEdit -- who edited when a row in table "Course", kept indefinitely (might be replaced by generic Audit Table; like all ...-Edit tables) CourseEdit -- who edited when a row in table "Course", kept indefinitely (might be replaced by generic Audit Table; like all ...-Edit tables)
user UserId user UserId
time UTCTime time UTCTime
course CourseId course CourseId
deriving Generic
Lecturer -- course ownership Lecturer -- course ownership
user UserId user UserId
course CourseId course CourseId
type LecturerType default='"lecturer"'::jsonb type LecturerType default='"lecturer"'::jsonb
UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table
deriving Generic
CourseParticipant -- course enrolement CourseParticipant -- course enrolement
course CourseId course CourseId
user UserId user UserId
@ -61,7 +66,7 @@ CourseParticipant -- course enrolement
allocated AllocationId Maybe -- participant was centrally allocated allocated AllocationId Maybe -- participant was centrally allocated
state CourseParticipantState state CourseParticipantState
UniqueParticipant user course UniqueParticipant user course
deriving Eq Ord Show deriving Eq Ord Show Generic
-- Replace the last two by the following, once an audit log is available -- Replace the last two by the following, once an audit log is available
-- CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student -- CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student
-- course CourseId -- course CourseId
@ -75,13 +80,16 @@ CourseUserNote -- lecturers of a specific course may share a tex
user UserId user UserId
note StoredMarkup -- arbitrary user-defined text; visible only to lecturer of this course note StoredMarkup -- arbitrary user-defined text; visible only to lecturer of this course
UniqueCourseUserNote user course UniqueCourseUserNote user course
deriving Generic
CourseUserNoteEdit -- who edited a participants course note when CourseUserNoteEdit -- who edited a participants course note when
user UserId user UserId
time UTCTime time UTCTime
note CourseUserNoteId -- PROBLEM: deleted notes have no modification date any more note CourseUserNoteId -- PROBLEM: deleted notes have no modification date any more
deriving Generic
CourseUserExamOfficeOptOut CourseUserExamOfficeOptOut
course CourseId course CourseId
user UserId user UserId
school SchoolId school SchoolId
UniqueCourseUserExamOfficeOptOut course user school UniqueCourseUserExamOfficeOptOut course user school
deriving Generic

View File

@ -10,6 +10,7 @@ CourseApplication
allocationPriority Word64 Maybe allocationPriority Word64 Maybe
time UTCTime default=now() time UTCTime default=now()
ratingTime UTCTime Maybe ratingTime UTCTime Maybe
deriving Generic
CourseApplicationFile CourseApplicationFile
application CourseApplicationId application CourseApplicationId
@ -17,3 +18,4 @@ CourseApplicationFile
content FileContentReference Maybe content FileContentReference Maybe
modified UTCTime modified UTCTime
UniqueCourseApplicationFile application title UniqueCourseApplicationFile application title
deriving Generic

View File

@ -4,7 +4,9 @@ CourseFavourite -- which user accessed which course when, only display
reason FavouriteReason reason FavouriteReason
lastVisit UTCTime lastVisit UTCTime
UniqueCourseFavourite user course UniqueCourseFavourite user course
deriving Generic
CourseNoFavourite CourseNoFavourite
user UserId user UserId
course CourseId course CourseId
UniqueCourseNoFavourite user course UniqueCourseNoFavourite user course
deriving Generic

View File

@ -13,3 +13,4 @@ MaterialFile -- a file that is part of a material distribution
content FileContentReference Maybe content FileContentReference Maybe
modified UTCTime modified UTCTime
UniqueMaterialFile material title UniqueMaterialFile material title
deriving Generic

View File

@ -6,9 +6,11 @@ CourseNews
content StoredMarkup content StoredMarkup
summary StoredMarkup Maybe summary StoredMarkup Maybe
lastEdit UTCTime lastEdit UTCTime
deriving Generic
CourseNewsFile CourseNewsFile
news CourseNewsId news CourseNewsId
title FilePath title FilePath
content FileContentReference Maybe content FileContentReference Maybe
modified UTCTime modified UTCTime
UniqueCourseNewsFile news title UniqueCourseNewsFile news title
deriving Generic

View File

@ -3,17 +3,21 @@ ExamOfficeField
field StudyTermsId field StudyTermsId
forced Bool forced Bool
UniqueExamOfficeField office field UniqueExamOfficeField office field
deriving Generic
ExamOfficeUser ExamOfficeUser
office UserId office UserId
user UserId user UserId
UniqueExamOfficeUser office user UniqueExamOfficeUser office user
deriving Generic
ExamOfficeResultSynced ExamOfficeResultSynced
school SchoolId Maybe school SchoolId Maybe
office UserId office UserId
result ExamResultId result ExamResultId
time UTCTime time UTCTime
deriving Generic
ExamOfficeExternalResultSynced ExamOfficeExternalResultSynced
school SchoolId Maybe school SchoolId Maybe
office UserId office UserId
result ExternalExamResultId result ExternalExamResultId
time UTCTime time UTCTime
deriving Generic

View File

@ -21,6 +21,7 @@ Exam
staff Text Maybe staff Text Maybe
partsFrom UTCTime Maybe partsFrom UTCTime Maybe
UniqueExam course name UniqueExam course name
deriving Generic
ExamPart ExamPart
exam ExamId exam ExamId
number ExamPartNumber number ExamPartNumber
@ -29,7 +30,7 @@ ExamPart
weight Rational weight Rational
UniqueExamPartNumber exam number UniqueExamPartNumber exam number
UniqueExamPartName exam name !force UniqueExamPartName exam name !force
deriving Read Show Eq Ord Generic Typeable deriving Read Show Eq Ord Generic
ExamOccurrence ExamOccurrence
exam ExamId exam ExamId
name ExamOccurrenceName name ExamOccurrenceName
@ -40,43 +41,47 @@ ExamOccurrence
end UTCTime Maybe end UTCTime Maybe
description StoredMarkup Maybe description StoredMarkup Maybe
UniqueExamOccurrence exam name UniqueExamOccurrence exam name
deriving Generic
ExamRegistration ExamRegistration
exam ExamId exam ExamId
user UserId user UserId
occurrence ExamOccurrenceId Maybe occurrence ExamOccurrenceId Maybe
time UTCTime default=now() time UTCTime default=now()
UniqueExamRegistration exam user UniqueExamRegistration exam user
deriving Eq Ord Show deriving Eq Ord Show Generic
ExamPartResult ExamPartResult
examPart ExamPartId examPart ExamPartId
user UserId user UserId
result ExamResultPoints result ExamResultPoints
lastChanged UTCTime default=now() lastChanged UTCTime default=now()
UniqueExamPartResult examPart user UniqueExamPartResult examPart user
deriving Eq Ord Show deriving Eq Ord Show Generic
ExamBonus ExamBonus
exam ExamId exam ExamId
user UserId user UserId
bonus Points bonus Points
lastChanged UTCTime default=now() lastChanged UTCTime default=now()
UniqueExamBonus exam user UniqueExamBonus exam user
deriving Eq Ord Show deriving Eq Ord Show Generic
ExamResult ExamResult
exam ExamId exam ExamId
user UserId user UserId
result ExamResultPassedGrade result ExamResultPassedGrade
lastChanged UTCTime default=now() lastChanged UTCTime default=now()
UniqueExamResult exam user UniqueExamResult exam user
deriving Eq Ord Show deriving Eq Ord Show Generic
ExamCorrector ExamCorrector
exam ExamId exam ExamId
user UserId user UserId
UniqueExamCorrector exam user UniqueExamCorrector exam user
deriving Generic
ExamPartCorrector ExamPartCorrector
part ExamPartId part ExamPartId
corrector ExamCorrectorId corrector ExamCorrectorId
UniqueExamPartCorrector part corrector UniqueExamPartCorrector part corrector
deriving Generic
ExamOfficeSchool ExamOfficeSchool
school SchoolId school SchoolId
exam ExamId exam ExamId
UniqueExamOfficeSchool exam school UniqueExamOfficeSchool exam school
deriving Generic

View File

@ -6,6 +6,7 @@ ExternalExam
defaultTime UTCTime Maybe defaultTime UTCTime Maybe
gradingMode ExamGradingMode gradingMode ExamGradingMode
UniqueExternalExam term school courseName examName UniqueExternalExam term school courseName examName
deriving Generic
ExternalExamResult ExternalExamResult
user UserId user UserId
exam ExternalExamId exam ExternalExamId
@ -13,12 +14,14 @@ ExternalExamResult
time UTCTime time UTCTime
lastChanged UTCTime lastChanged UTCTime
UniqueExternalExamResult exam user UniqueExternalExamResult exam user
deriving Eq Ord Show deriving Eq Ord Show Generic
ExternalExamStaff ExternalExamStaff
user UserId user UserId
exam ExternalExamId exam ExternalExamId
UniqueExternalExamStaff exam user UniqueExternalExamStaff exam user
deriving Generic
ExternalExamOfficeSchool ExternalExamOfficeSchool
school SchoolId school SchoolId
exam ExternalExamId exam ExternalExamId
UniqueExternalExamOfficeSchool exam school UniqueExternalExamOfficeSchool exam school
deriving Generic

View File

@ -3,28 +3,34 @@ FileContentEntry
ix Word64 ix Word64
chunkHash FileContentChunkId chunkHash FileContentChunkId
UniqueFileContentEntry hash ix UniqueFileContentEntry hash ix
deriving Generic
FileContentChunk FileContentChunk
hash FileContentChunkReference hash FileContentChunkReference
content ByteString content ByteString
contentBased Bool default=false -- For Migration contentBased Bool default=false -- For Migration
Primary hash Primary hash
deriving Generic
FileContentChunkUnreferenced FileContentChunkUnreferenced
hash FileContentChunkId hash FileContentChunkId
since UTCTime since UTCTime
UniqueFileContentChunkUnreferenced hash UniqueFileContentChunkUnreferenced hash
deriving Generic
SessionFile SessionFile
content FileContentReference Maybe content FileContentReference Maybe
touched UTCTime touched UTCTime
deriving Generic
FileLock FileLock
content FileContentReference content FileContentReference
instance InstanceId instance InstanceId
time UTCTime time UTCTime
deriving Generic
FileChunkLock FileChunkLock
hash FileContentChunkReference hash FileContentChunkReference
instance InstanceId instance InstanceId
time UTCTime time UTCTime
deriving Generic

View File

@ -4,3 +4,4 @@ Invitation
data Value data Value
expiresAt UTCTime Maybe expiresAt UTCTime Maybe
UniqueInvitation email for UniqueInvitation email for
deriving Generic

View File

@ -6,7 +6,7 @@ QueuedJob
lockInstance InstanceId Maybe -- instance that has started to execute this job lockInstance InstanceId Maybe -- instance that has started to execute this job
lockTime UTCTime Maybe -- time when execution had begun lockTime UTCTime Maybe -- time when execution had begun
writeLastExec Bool default=false -- record successful execution to CronLastExec writeLastExec Bool default=false -- record successful execution to CronLastExec
deriving Eq Read Show Generic Typeable deriving Eq Read Show Generic
-- Jobs are deleted from @QueuedJob@ after they are executed successfully and recorded in @CronLastExec@ -- Jobs are deleted from @QueuedJob@ after they are executed successfully and recorded in @CronLastExec@
-- There is a Cron-system that, at set intervals, queries the database for work to be done in the background (i.e. if a lecturer has set a sheet's submissions to be automatically distributed and the submission deadline passed since the last check, then queue a new job to actually do the distribution) -- There is a Cron-system that, at set intervals, queries the database for work to be done in the background (i.e. if a lecturer has set a sheet's submissions to be automatically distributed and the submission deadline passed since the last check, then queue a new job to actually do the distribution)
@ -16,9 +16,11 @@ CronLastExec
time UTCTime -- When was the job executed time UTCTime -- When was the job executed
instance InstanceId -- Which uni2work-instance did the work instance InstanceId -- Which uni2work-instance did the work
UniqueCronLastExec job UniqueCronLastExec job
deriving Generic
TokenBucket TokenBucket
ident TokenBucketIdent ident TokenBucketIdent
lastValue Int64 lastValue Int64
lastAccess UTCTime lastAccess UTCTime
Primary ident Primary ident
deriving Generic

View File

@ -6,8 +6,10 @@ SentMail
recipient UserId Maybe recipient UserId Maybe
headers MailHeaders headers MailHeaders
contentRef SentMailContentId contentRef SentMailContentId
deriving Generic
SentMailContent SentMailContent
hash MailContentReference hash MailContentReference
content MailContent content MailContent
Primary hash Primary hash
deriving Generic

View File

@ -16,7 +16,9 @@ SchoolLdap
school SchoolId Maybe school SchoolId Maybe
orgUnit (CI Text) orgUnit (CI Text)
UniqueOrgUnit orgUnit UniqueOrgUnit orgUnit
deriving Generic
SchoolTerms SchoolTerms
school SchoolId school SchoolId
terms StudyTermsId terms StudyTermsId
UniqueSchoolTerms school terms UniqueSchoolTerms school terms
deriving Generic

View File

@ -21,6 +21,7 @@ SheetEdit -- who edited when a row in table "Course", kept i
user UserId user UserId
time UTCTime time UTCTime
sheet SheetId sheet SheetId
deriving Generic
-- For anonoymous external submissions (i.e. paper submission tracked in uni2work) -- For anonoymous external submissions (i.e. paper submission tracked in uni2work)
-- Map pseudonyms to users injectively in the context of a single sheet; for the next sheet all-new pseudonyms need to be created -- Map pseudonyms to users injectively in the context of a single sheet; for the next sheet all-new pseudonyms need to be created
@ -31,13 +32,14 @@ SheetPseudonym
user UserId user UserId
UniqueSheetPseudonym sheet pseudonym UniqueSheetPseudonym sheet pseudonym
UniqueSheetPseudonymUser sheet user UniqueSheetPseudonymUser sheet user
deriving Generic
SheetCorrector -- grant corrector role to user for a sheet SheetCorrector -- grant corrector role to user for a sheet
user UserId user UserId
sheet SheetId sheet SheetId
load Load -- portion of work that will be assigned to this corrector load Load -- portion of work that will be assigned to this corrector
state CorrectorState default='CorrectorNormal' -- whether a corrector is assigned his load this time (e.g. in case of sickness) state CorrectorState default='CorrectorNormal' -- whether a corrector is assigned his load this time (e.g. in case of sickness)
UniqueSheetCorrector user sheet UniqueSheetCorrector user sheet
deriving Show Eq Ord deriving Show Eq Ord Generic
SheetFile -- a file that is part of an exercise sheet SheetFile -- a file that is part of an exercise sheet
sheet SheetId sheet SheetId
type SheetFileType -- excercise, marking, hint or solution type SheetFileType -- excercise, marking, hint or solution
@ -45,6 +47,7 @@ SheetFile -- a file that is part of an exercise sheet
content FileContentReference Maybe content FileContentReference Maybe
modified UTCTime modified UTCTime
UniqueSheetFile sheet type title UniqueSheetFile sheet type title
deriving Generic
PersonalisedSheetFile PersonalisedSheetFile
sheet SheetId sheet SheetId
user UserId user UserId
@ -53,7 +56,7 @@ PersonalisedSheetFile
content FileContentReference Maybe content FileContentReference Maybe
modified UTCTime modified UTCTime
UniquePersonalisedSheetFile sheet user type title UniquePersonalisedSheetFile sheet user type title
deriving Eq Ord Read Show Generic Typeable deriving Eq Ord Read Show Typeable Generic
FallbackPersonalisedSheetFilesKey FallbackPersonalisedSheetFilesKey
course CourseId course CourseId
@ -61,3 +64,4 @@ FallbackPersonalisedSheetFilesKey
secret ByteString secret ByteString
generated UTCTime generated UTCTime
UniqueFallbackPersonalisedSheetFilesKey course index UniqueFallbackPersonalisedSheetFilesKey course index
deriving Generic

View File

@ -10,13 +10,14 @@ StudyFeatures -- multiple entries possible for students pursuing several degree
valid Bool default=true valid Bool default=true
relevanceCached UUID Maybe relevanceCached UUID Maybe
UniqueStudyFeatures user degree field type semester UniqueStudyFeatures user degree field type semester
deriving Eq Show deriving Eq Show Generic
-- UniqueUserSubject ubuser degree field -- There exists a counterexample -- UniqueUserSubject ubuser degree field -- There exists a counterexample
RelevantStudyFeatures RelevantStudyFeatures
term TermId term TermId
studyFeatures StudyFeaturesId studyFeatures StudyFeaturesId
UniqueRelevantStudyFeatures term studyFeatures UniqueRelevantStudyFeatures term studyFeatures
deriving Generic
StudyDegree -- Studienabschluss StudyDegree -- Studienabschluss
key Int -- LMU-internal key key Int -- LMU-internal key
@ -24,7 +25,7 @@ StudyDegree -- Studienabschluss
name Text Maybe -- description given by LDAP name Text Maybe -- description given by LDAP
Primary key -- column key is used as actual DB row key Primary key -- column key is used as actual DB row key
-- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int } -- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int }
deriving Eq Show deriving Eq Show Generic
StudyTerms -- Studiengang StudyTerms -- Studiengang
key Int -- standardised key key Int -- standardised key
shorthand Text Maybe -- admin determined shorthand shorthand Text Maybe -- admin determined shorthand
@ -33,11 +34,12 @@ StudyTerms -- Studiengang
defaultType StudyFieldType Maybe defaultType StudyFieldType Maybe
Primary key -- column key is used as actual DB row key Primary key -- column key is used as actual DB row key
-- newtype Key StudyTerms = StudyTermsKey' { unStudyTermsKey :: Int } -- newtype Key StudyTerms = StudyTermsKey' { unStudyTermsKey :: Int }
deriving Eq Ord Show deriving Eq Ord Show Generic
StudySubTerms StudySubTerms
child StudyTermsId child StudyTermsId
parent StudyTermsId parent StudyTermsId
UniqueStudySubTerms child parent UniqueStudySubTerms child parent
deriving Generic
StudyTermNameCandidate -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms. StudyTermNameCandidate -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms.
-- Each LDAP login provides an unordered set of keys and an unordered set of plain text description with an unknown 1-1 correspondence. -- Each LDAP login provides an unordered set of keys and an unordered set of plain text description with an unknown 1-1 correspondence.
-- This table helps us to infer which key belongs to which plain text by recording possible combinations at login. -- This table helps us to infer which key belongs to which plain text by recording possible combinations at login.
@ -45,14 +47,14 @@ StudyTermNameCandidate -- No one at LMU is willing and able to tell us the me
incidence TermCandidateIncidence -- random id, generated once per login to associate matching pairs incidence TermCandidateIncidence -- random id, generated once per login to associate matching pairs
key Int -- a possible key for the studyTermName or studySubTermName key Int -- a possible key for the studyTermName or studySubTermName
name Text -- studyTermName as plain text from LDAP name Text -- studyTermName as plain text from LDAP
deriving Show Eq Ord deriving Show Eq Ord Generic
StudySubTermParentCandidate StudySubTermParentCandidate
incidence TermCandidateIncidence incidence TermCandidateIncidence
key Int key Int
parent Int parent Int
deriving Show Eq Ord deriving Show Eq Ord Generic
StudyTermStandaloneCandidate StudyTermStandaloneCandidate
incidence TermCandidateIncidence incidence TermCandidateIncidence
key Int key Int
deriving Show Eq Ord deriving Show Eq Ord Generic

View File

@ -10,6 +10,7 @@ SubmissionEdit -- user uploads new version of their submissio
user UserId Maybe -- track id, important for group submissions user UserId Maybe -- track id, important for group submissions
time UTCTime time UTCTime
submission SubmissionId submission SubmissionId
deriving Generic
SubmissionFile json -- files that are part of a submission SubmissionFile json -- files that are part of a submission
submission SubmissionId submission SubmissionId
title FilePath title FilePath
@ -18,17 +19,19 @@ SubmissionFile json -- files that are part of a submission
isUpdate Bool -- is this the file updated by a corrector (original will always be retained) isUpdate Bool -- is this the file updated by a corrector (original will always be retained)
isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector
UniqueSubmissionFile submission title isUpdate UniqueSubmissionFile submission title isUpdate
deriving Eq Ord Read Show deriving Eq Ord Read Show Generic
SubmissionUser -- which submission belongs to whom SubmissionUser -- which submission belongs to whom
user UserId user UserId
submission SubmissionId submission SubmissionId
UniqueSubmissionUser user submission -- multiple users may share same submission, in case of (ad-hoc) submission groups UniqueSubmissionUser user submission -- multiple users may share same submission, in case of (ad-hoc) submission groups
deriving Generic
SubmissionGroup -- pre-defined submission groups; some courses only allow pre-defined submission groups SubmissionGroup -- pre-defined submission groups; some courses only allow pre-defined submission groups
course CourseId course CourseId
name SubmissionGroupName name SubmissionGroupName
UniqueSubmissionGroup course name UniqueSubmissionGroup course name
deriving Generic
SubmissionGroupUser -- Registered submission groups, just for checking upon submission, but independent of actual SubmissionUser SubmissionGroupUser -- Registered submission groups, just for checking upon submission, but independent of actual SubmissionUser
submissionGroup SubmissionGroupId submissionGroup SubmissionGroupId
user UserId user UserId
UniqueSubmissionGroupUser submissionGroup user UniqueSubmissionGroupUser submissionGroup user
deriving Eq Ord Show deriving Eq Ord Show Generic

View File

@ -13,6 +13,7 @@ SystemMessage
defaultLanguage Lang -- Language of @content@ and @summary@ defaultLanguage Lang -- Language of @content@ and @summary@
content StoredMarkup -- Detailed message shown when clicking on the @summary@-popup or when no @summary@ is specified content StoredMarkup -- Detailed message shown when clicking on the @summary@-popup or when no @summary@ is specified
summary StoredMarkup Maybe summary StoredMarkup Maybe
deriving Generic
SystemMessageTranslation -- Translation of a @SystemMessage@ into another language; which language to choose is determined by user-sent HTTP-headers SystemMessageTranslation -- Translation of a @SystemMessage@ into another language; which language to choose is determined by user-sent HTTP-headers
message SystemMessageId message SystemMessageId
@ -20,9 +21,11 @@ SystemMessageTranslation -- Translation of a @SystemMessage@ into another langua
content StoredMarkup content StoredMarkup
summary StoredMarkup Maybe summary StoredMarkup Maybe
UniqueSystemMessageTranslation message language UniqueSystemMessageTranslation message language
deriving Generic
SystemMessageHidden SystemMessageHidden
message SystemMessageId message SystemMessageId
user UserId user UserId
time UTCTime time UTCTime
UniqueSystemMessageHidden user message UniqueSystemMessageHidden user message
deriving Generic

View File

@ -18,8 +18,10 @@ Tutor
tutorial TutorialId tutorial TutorialId
user UserId user UserId
UniqueTutor tutorial user UniqueTutor tutorial user
deriving Generic
TutorialParticipant TutorialParticipant
tutorial TutorialId tutorial TutorialId
user UserId user UserId
UniqueTutorialParticipant tutorial user UniqueTutorialParticipant tutorial user
deriving Eq Ord Show deriving Eq Ord Show
deriving Generic

View File

@ -44,21 +44,25 @@ UserFunction -- Administratively assigned functions (lecturer, admin, evaluation
school SchoolId school SchoolId
function SchoolFunction function SchoolFunction
UniqueUserFunction user school function UniqueUserFunction user school function
deriving Generic
UserSystemFunction UserSystemFunction
user UserId user UserId
function SystemFunction function SystemFunction
manual Bool manual Bool
isOptOut Bool isOptOut Bool
UniqueUserSystemFunction user function UniqueUserSystemFunction user function
deriving Generic
UserExamOffice UserExamOffice
user UserId user UserId
field StudyTermsId field StudyTermsId
UniqueUserExamOffice user field UniqueUserExamOffice user field
deriving Generic
UserSchool -- Managed by users themselves, encodes "schools of interest" UserSchool -- Managed by users themselves, encodes "schools of interest"
user UserId user UserId
school SchoolId school SchoolId
isOptOut Bool -- true if this a marker, that the user manually deleted this entry; it should not be recreated automatically isOptOut Bool -- true if this a marker, that the user manually deleted this entry; it should not be recreated automatically
UniqueUserSchool user school UniqueUserSchool user school
deriving Generic
UserGroupMember UserGroupMember
group UserGroupName group UserGroupName
@ -68,3 +72,5 @@ UserGroupMember
UniquePrimaryUserGroupMember group primary !force UniquePrimaryUserGroupMember group primary !force
UniqueUserGroupMember group user UniqueUserGroupMember group user
deriving Generic

View File

@ -2,6 +2,7 @@ SharedWorkflowGraph
hash WorkflowGraphReference hash WorkflowGraphReference
graph (WorkflowGraph FileReference SqlBackendKey) -- UserId graph (WorkflowGraph FileReference SqlBackendKey) -- UserId
Primary hash Primary hash
deriving Generic
WorkflowDefinition WorkflowDefinition
graph SharedWorkflowGraphId graph SharedWorkflowGraphId
@ -9,6 +10,7 @@ WorkflowDefinition
name WorkflowDefinitionName name WorkflowDefinitionName
instanceCategory WorkflowInstanceCategory Maybe instanceCategory WorkflowInstanceCategory Maybe
UniqueWorkflowDefinition name scope UniqueWorkflowDefinition name scope
deriving Generic
WorkflowDefinitionDescription WorkflowDefinitionDescription
definition WorkflowDefinitionId definition WorkflowDefinitionId
@ -16,6 +18,7 @@ WorkflowDefinitionDescription
title Text title Text
description StoredMarkup Maybe description StoredMarkup Maybe
UniqueWorkflowDefinitionDescription definition language UniqueWorkflowDefinitionDescription definition language
deriving Generic
WorkflowDefinitionInstanceDescription WorkflowDefinitionInstanceDescription
definition WorkflowDefinitionId definition WorkflowDefinitionId
@ -23,6 +26,7 @@ WorkflowDefinitionInstanceDescription
title Text title Text
description StoredMarkup Maybe description StoredMarkup Maybe
UniqueWorkflowDefinitionInstanceDescription definition language UniqueWorkflowDefinitionInstanceDescription definition language
deriving Generic
WorkflowInstance WorkflowInstance
definition WorkflowDefinitionId Maybe definition WorkflowDefinitionId Maybe
@ -31,6 +35,7 @@ WorkflowInstance
name WorkflowInstanceName name WorkflowInstanceName
category WorkflowInstanceCategory Maybe category WorkflowInstanceCategory Maybe
UniqueWorkflowInstance name scope UniqueWorkflowInstance name scope
deriving Generic
WorkflowInstanceDescription WorkflowInstanceDescription
instance WorkflowInstanceId instance WorkflowInstanceId
@ -38,9 +43,11 @@ WorkflowInstanceDescription
title Text title Text
description StoredMarkup Maybe description StoredMarkup Maybe
UniqueWorkflowInstanceDescription instance language UniqueWorkflowInstanceDescription instance language
deriving Generic
WorkflowWorkflow WorkflowWorkflow
instance WorkflowInstanceId Maybe instance WorkflowInstanceId Maybe
scope (WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) -- TermId, SchoolId, CourseId scope (WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) -- TermId, SchoolId, CourseId
graph SharedWorkflowGraphId graph SharedWorkflowGraphId
state (WorkflowState FileReference SqlBackendKey) -- UserId state (WorkflowState FileReference SqlBackendKey) -- UserId
deriving Generic

View File

@ -30,9 +30,6 @@ instance PersistEntity record => Binary (Key record) where
putList = Binary.putList . map toPersistValue putList = Binary.putList . map toPersistValue
get = either (fail . unpack) return . fromPersistValue =<< Binary.get get = either (fail . unpack) return . fromPersistValue =<< Binary.get
instance PersistEntity record => NFData (Key record) where
rnf = rnf . keyToValues
uniqueToMap :: PersistEntity record => Unique record -> Map (HaskellName, DBName) PersistValue uniqueToMap :: PersistEntity record => Unique record -> Map (HaskellName, DBName) PersistValue
uniqueToMap = fmap Map.fromList $ zip <$> persistUniqueToFieldNames <*> persistUniqueToValues uniqueToMap = fmap Map.fromList $ zip <$> persistUniqueToFieldNames <*> persistUniqueToValues

View File

@ -26,3 +26,6 @@ instance NFData PersistValue
instance (NFData record, NFData (Key record)) => NFData (Entity record) where instance (NFData record, NFData (Key record)) => NFData (Entity record) where
rnf Entity{..} = rnf entityKey `seq` rnf entityVal rnf Entity{..} = rnf entityKey `seq` rnf entityVal
deriving instance Generic Checkmark
deriving anyclass instance NFData Checkmark

View File

@ -33,7 +33,7 @@ type SqlBackendKey = BackendKey SqlBackend
-- You can find more information on persistent and how to declare entities -- You can find more information on persistent and how to declare entities
-- at: -- at:
-- http://www.yesodweb.com/book/persistent/ -- http://www.yesodweb.com/book/persistent/
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateUniWorX", mkSave "currentModel"] share [mkPersist sqlSettings{ mpsDeriveInstances = [''NFData] }, mkDeleteCascade sqlSettings, mkMigrate "migrateUniWorX", mkSave "currentModel"]
$(persistDirectoryWith lowerCaseSettings "models") $(persistDirectoryWith lowerCaseSettings "models")
@ -51,8 +51,6 @@ deriving newtype instance FromJSONKey ExamOccurrenceId
deriving instance Show (Unique ExamPart) deriving instance Show (Unique ExamPart)
deriving anyclass instance NFData ExamPart
-- ToMarkup and ToMessage instances for displaying selected database primary keys -- ToMarkup and ToMessage instances for displaying selected database primary keys
instance ToMarkup (Key School) where instance ToMarkup (Key School) where

View File

@ -32,6 +32,7 @@ data AllocationPriority
= AllocationPriorityNumeric { allocationPriorities :: Vector Integer } = AllocationPriorityNumeric { allocationPriorities :: Vector Integer }
| AllocationPriorityOrdinal { allocationOrdinal :: Natural } | AllocationPriorityOrdinal { allocationOrdinal :: Natural }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1 { fieldLabelModifier = camelToPathPiece' 1
, constructorTagModifier = camelToPathPiece' 2 , constructorTagModifier = camelToPathPiece' 2
@ -49,7 +50,9 @@ instance Binary AllocationPriority
data AllocationPriorityNumericRecord = AllocationPriorityNumericRecord data AllocationPriorityNumericRecord = AllocationPriorityNumericRecord
{ apmrMatrikelnummer :: UserMatriculation { apmrMatrikelnummer :: UserMatriculation
, apmrPriority :: Vector Integer , apmrPriority :: Vector Integer
} deriving (Eq, Ord, Read, Show, Generic, Typeable) }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
allocationPriorityNumericMap :: Prism' (Map UserMatriculation AllocationPriority) AllocationPriorityNumericRecord allocationPriorityNumericMap :: Prism' (Map UserMatriculation AllocationPriority) AllocationPriorityNumericRecord
allocationPriorityNumericMap = prism' fromPrioRecord toPrioRecord allocationPriorityNumericMap = prism' fromPrioRecord toPrioRecord
@ -90,6 +93,7 @@ data AllocationPriorityComparison
= AllocationPriorityComparisonNumeric { allocationGradeScale :: Rational } = AllocationPriorityComparisonNumeric { allocationGradeScale :: Rational }
| AllocationPriorityComparisonOrdinal { allocationCloneIndex :: Down Natural, allocationOrdinalScale :: Rational } | AllocationPriorityComparisonOrdinal { allocationCloneIndex :: Down Natural, allocationOrdinalScale :: Rational }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
type AllocationFingerprint = Digest (SHAKE128 128) type AllocationFingerprint = Digest (SHAKE128 128)

View File

@ -16,9 +16,7 @@ import Utils.Lens.TH
data LecturerType = CourseLecturer | CourseAssistant data LecturerType = CourseLecturer | CourseAssistant
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving (Universe, Finite, NFData)
instance Universe LecturerType
instance Finite LecturerType
nullaryPathPiece ''LecturerType $ camelToPathPiece' 1 nullaryPathPiece ''LecturerType $ camelToPathPiece' 1
deriveJSON defaultOptions deriveJSON defaultOptions
@ -33,7 +31,7 @@ data CourseParticipantState
= CourseParticipantActive = CourseParticipantActive
| CourseParticipantInactive { courseParticipantNoShow :: Bool } | CourseParticipantInactive { courseParticipantNoShow :: Bool }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (Hashable) deriving anyclass (NFData, Hashable)
makePrisms ''CourseParticipantState makePrisms ''CourseParticipantState
makeLenses_ ''CourseParticipantState makeLenses_ ''CourseParticipantState

View File

@ -153,6 +153,7 @@ data OccurrenceSchedule = ScheduleWeekly
, scheduleEnd :: TimeOfDay , scheduleEnd :: TimeOfDay
} }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1 { fieldLabelModifier = camelToPathPiece' 1
@ -170,6 +171,7 @@ data OccurrenceException = ExceptOccur
{ exceptTime :: LocalTime { exceptTime :: LocalTime
} }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1 { fieldLabelModifier = camelToPathPiece' 1
@ -180,7 +182,9 @@ deriveJSON defaultOptions
data Occurrences = Occurrences data Occurrences = Occurrences
{ occurrencesScheduled :: Set OccurrenceSchedule { occurrencesScheduled :: Set OccurrenceSchedule
, occurrencesExceptions :: Set OccurrenceException , occurrencesExceptions :: Set OccurrenceException
} deriving (Eq, Ord, Read, Show, Generic, Typeable) }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1 { fieldLabelModifier = camelToPathPiece' 1

View File

@ -78,6 +78,7 @@ data ExamResult' res = ExamAttended { examResult :: res }
| ExamNoShow | ExamNoShow
| ExamVoided | ExamVoided
deriving (Show, Read, Eq, Ord, Functor, Generic, Typeable) deriving (Show, Read, Eq, Ord, Functor, Generic, Typeable)
deriving anyclass (NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1 { constructorTagModifier = camelToPathPiece' 1
, fieldLabelModifier = camelToPathPiece' 1 , fieldLabelModifier = camelToPathPiece' 1
@ -156,6 +157,7 @@ data ExamBonusRule = ExamBonusManual
, bonusRound :: Points , bonusRound :: Points
} }
deriving (Show, Read, Eq, Ord, Generic, Typeable) deriving (Show, Read, Eq, Ord, Generic, Typeable)
deriving anyclass (NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1 { fieldLabelModifier = camelToPathPiece' 1
, constructorTagModifier = camelToPathPiece' 1 , constructorTagModifier = camelToPathPiece' 1
@ -171,7 +173,8 @@ data ExamOccurrenceRule = ExamRoomManual
| ExamRoomSurname | ExamRoomSurname
| ExamRoomMatriculation | ExamRoomMatriculation
| ExamRoomRandom | ExamRoomRandom
deriving (Show, Read, Eq, Ord, Generic, Typeable) deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite, NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1 { fieldLabelModifier = camelToPathPiece' 1
, constructorTagModifier = camelToPathPiece' 2 , constructorTagModifier = camelToPathPiece' 2
@ -195,6 +198,7 @@ data ExamOccurrenceMappingDescription
| ExamOccurrenceMappingSpecial { eaomrSpecial :: [CI Char] } | ExamOccurrenceMappingSpecial { eaomrSpecial :: [CI Char] }
| ExamOccurrenceMappingRandom | ExamOccurrenceMappingRandom
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1 { fieldLabelModifier = camelToPathPiece' 1
, constructorTagModifier = camelToPathPiece' 3 , constructorTagModifier = camelToPathPiece' 3
@ -206,7 +210,9 @@ makePrisms ''ExamOccurrenceMappingDescription
data ExamOccurrenceMapping roomId = ExamOccurrenceMapping data ExamOccurrenceMapping roomId = ExamOccurrenceMapping
{ examOccurrenceMappingRule :: ExamOccurrenceRule { examOccurrenceMappingRule :: ExamOccurrenceRule
, examOccurrenceMappingMapping :: Map roomId (Set ExamOccurrenceMappingDescription) , examOccurrenceMappingMapping :: Map roomId (Set ExamOccurrenceMappingDescription)
} deriving (Eq, Ord, Read, Show, Generic, Typeable) }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
instance ToJSONKey roomId => ToJSON (ExamOccurrenceMapping roomId) where instance ToJSONKey roomId => ToJSON (ExamOccurrenceMapping roomId) where
toJSON = genericToJSON defaultOptions toJSON = genericToJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 3 { fieldLabelModifier = camelToPathPiece' 3
@ -269,8 +275,7 @@ data ExamGrade
| Grade13 | Grade13
| Grade10 | Grade10
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe ExamGrade deriving anyclass (Universe, Finite, NFData)
instance Finite ExamGrade
numberGrade :: Prism' Rational ExamGrade numberGrade :: Prism' Rational ExamGrade
numberGrade = prism toNumberGrade fromNumberGrade numberGrade = prism toNumberGrade fromNumberGrade
@ -344,6 +349,7 @@ data ExamGradingRule
{ examGradingKey :: [Points] -- ^ @[n1, n2, n3, ..., n11]@ means @0 <= p < n1 -> p ~= 5@, @n1 <= p < n2 -> p ~ 4@, @n2 <= p < n3 -> p ~ 3.7@, ..., @n10 <= p -> p ~ 1.0@ { examGradingKey :: [Points] -- ^ @[n1, n2, n3, ..., n11]@ means @0 <= p < n1 -> p ~= 5@, @n1 <= p < n2 -> p ~ 4@, @n2 <= p < n3 -> p ~ 3.7@, ..., @n10 <= p -> p ~ 1.0@
} }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 2 { fieldLabelModifier = camelToPathPiece' 2
, constructorTagModifier = camelToPathPiece' 2 , constructorTagModifier = camelToPathPiece' 2
@ -358,6 +364,7 @@ derivePersistFieldJSON ''ExamGradingRule
newtype ExamPassed = ExamPassed { examPassed :: Bool } newtype ExamPassed = ExamPassed { examPassed :: Bool }
deriving (Read, Show, Generic, Typeable) deriving (Read, Show, Generic, Typeable)
deriving newtype (Eq, Ord, Enum, Bounded, PersistField) deriving newtype (Eq, Ord, Enum, Bounded, PersistField)
deriving anyclass (NFData)
instance PersistFieldSql ExamPassed where instance PersistFieldSql ExamPassed where
sqlType _ = sqlType $ Proxy @Bool sqlType _ = sqlType $ Proxy @Bool
@ -403,8 +410,7 @@ data ExamGradingMode
| ExamGradingGrades | ExamGradingGrades
| ExamGradingMixed | ExamGradingMixed
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe ExamGradingMode deriving anyclass (Universe, Finite, NFData)
instance Finite ExamGradingMode
nullaryPathPiece ''ExamGradingMode $ camelToPathPiece' 2 nullaryPathPiece ''ExamGradingMode $ camelToPathPiece' 2
pathPieceJSON ''ExamGradingMode pathPieceJSON ''ExamGradingMode
@ -478,12 +484,13 @@ data ExamAids
= ExamAidsPreset { examAidsPreset :: ExamAidsPreset } = ExamAidsPreset { examAidsPreset :: ExamAidsPreset }
| ExamAidsCustom { examAidsCustom :: StoredMarkup } | ExamAidsCustom { examAidsCustom :: StoredMarkup }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
data ExamAidsPreset data ExamAidsPreset
= ExamOpenBook = ExamOpenBook
| ExamClosedBook | ExamClosedBook
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite, NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 2 { constructorTagModifier = camelToPathPiece' 2
@ -499,12 +506,13 @@ data ExamOnline
= ExamOnlinePreset { examOnlinePreset :: ExamOnlinePreset } = ExamOnlinePreset { examOnlinePreset :: ExamOnlinePreset }
| ExamOnlineCustom { examOnlineCustom :: StoredMarkup } | ExamOnlineCustom { examOnlineCustom :: StoredMarkup }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
data ExamOnlinePreset data ExamOnlinePreset
= ExamOnline = ExamOnline
| ExamOffline | ExamOffline
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite, NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 2 { constructorTagModifier = camelToPathPiece' 2
@ -520,12 +528,13 @@ data ExamSynchronicity
= ExamSynchronicityPreset { examSynchronicityPreset :: ExamSynchronicityPreset } = ExamSynchronicityPreset { examSynchronicityPreset :: ExamSynchronicityPreset }
| ExamSynchronicityCustom { examSynchronicityCustom :: StoredMarkup } | ExamSynchronicityCustom { examSynchronicityCustom :: StoredMarkup }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
data ExamSynchronicityPreset data ExamSynchronicityPreset
= ExamSynchronous = ExamSynchronous
| ExamAsynchronous | ExamAsynchronous
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite, NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 2 { constructorTagModifier = camelToPathPiece' 2
@ -541,6 +550,7 @@ data ExamRequiredEquipment
= ExamRequiredEquipmentPreset { examRequiredEquipmentPreset :: ExamRequiredEquipmentPreset } = ExamRequiredEquipmentPreset { examRequiredEquipmentPreset :: ExamRequiredEquipmentPreset }
| ExamRequiredEquipmentCustom { examRequiredEquipmentCustom :: StoredMarkup } | ExamRequiredEquipmentCustom { examRequiredEquipmentCustom :: StoredMarkup }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
data ExamRequiredEquipmentPreset data ExamRequiredEquipmentPreset
= ExamRequiredEquipmentNone = ExamRequiredEquipmentNone
@ -551,7 +561,7 @@ data ExamRequiredEquipmentPreset
| ExamRequiredEquipmentWebcamMicrophoneInternet | ExamRequiredEquipmentWebcamMicrophoneInternet
| ExamRequiredEquipmentMicrophoneInternet | ExamRequiredEquipmentMicrophoneInternet
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite, NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 2 { constructorTagModifier = camelToPathPiece' 2
@ -570,6 +580,8 @@ data ExamMode = ExamMode
, examSynchronicity :: Maybe ExamSynchronicity , examSynchronicity :: Maybe ExamSynchronicity
, examRequiredEquipment :: Maybe ExamRequiredEquipment , examRequiredEquipment :: Maybe ExamRequiredEquipment
} }
deriving (Generic, Typeable)
deriving anyclass (NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1 { fieldLabelModifier = camelToPathPiece' 1
, sumEncoding = UntaggedValue , sumEncoding = UntaggedValue
@ -582,6 +594,7 @@ data ExamModePredicate
| ExamModePredSynchronicity ExamSynchronicityPreset | ExamModePredSynchronicity ExamSynchronicityPreset
| ExamModePredRequiredEquipment ExamRequiredEquipmentPreset | ExamModePredRequiredEquipment ExamRequiredEquipmentPreset
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 3 { constructorTagModifier = camelToPathPiece' 3
, sumEncoding = TaggedObject "setting" "preset" , sumEncoding = TaggedObject "setting" "preset"
@ -592,6 +605,7 @@ deriveFinite ''ExamModePredicate
newtype ExamModeDNF = ExamModeDNF { examModeDNF :: PredDNF ExamModePredicate } newtype ExamModeDNF = ExamModeDNF { examModeDNF :: PredDNF ExamModePredicate }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving newtype (ToJSON, FromJSON, PathPiece) deriving newtype (ToJSON, FromJSON, PathPiece)
deriving anyclass (NFData)
derivePersistFieldJSON ''ExamModeDNF derivePersistFieldJSON ''ExamModeDNF
@ -600,7 +614,7 @@ data ExamCloseMode
= ExamCloseSeparate = ExamCloseSeparate
| ExamCloseOnFinished { examCloseOnFinishedHidden :: Bool } | ExamCloseOnFinished { examCloseOnFinishedHidden :: Bool }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (Binary) deriving anyclass (Binary, NFData)
deriveFinite ''ExamCloseMode deriveFinite ''ExamCloseMode
finitePathPiece ''ExamCloseMode ["separate", "on-finished", "on-finished-hidden"] finitePathPiece ''ExamCloseMode ["separate", "on-finished", "on-finished-hidden"]
derivePersistFieldPathPiece ''ExamCloseMode derivePersistFieldPathPiece ''ExamCloseMode

View File

@ -157,7 +157,7 @@ data FileReference = FileReference
, fileReferenceContent :: Maybe FileContentReference , fileReferenceContent :: Maybe FileContentReference
, fileReferenceModified :: UTCTime , fileReferenceModified :: UTCTime
} deriving (Eq, Ord, Read, Show, Generic, Typeable) } deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (Hashable, Binary) deriving anyclass (Hashable, Binary, NFData)
makeLenses_ ''FileReference makeLenses_ ''FileReference
deriveJSON defaultOptions deriveJSON defaultOptions
@ -179,7 +179,7 @@ instance HasFileReference Void where
instance HasFileReference FileReference where instance HasFileReference FileReference where
data FileReferenceResidual FileReference = FileReferenceResidual data FileReferenceResidual FileReference = FileReferenceResidual
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite, NFData)
-- newtype FileReferenceTitleMap FileReference add = FileReferenceFileReferenceTitleMap { unFileReferenceFileReferenceTitleMap :: Map FilePath (FileReferenceTitleMapElem FileReference add) } -- newtype FileReferenceTitleMap FileReference add = FileReferenceFileReferenceTitleMap { unFileReferenceFileReferenceTitleMap :: Map FilePath (FileReferenceTitleMapElem FileReference add) }
-- deriving (Eq, Ord, Read, Show, Generic, Typeable) -- deriving (Eq, Ord, Read, Show, Generic, Typeable)
-- deriving newtype (Semigroup, Monoid) -- deriving newtype (Semigroup, Monoid)
@ -196,6 +196,7 @@ instance HasFileReference PureFile where
newtype FileReferenceResidual PureFile = PureFileResidual { unPureFileResidual :: Maybe ByteString } newtype FileReferenceResidual PureFile = PureFileResidual { unPureFileResidual :: Maybe ByteString }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving newtype (ToJSON, FromJSON) deriving newtype (ToJSON, FromJSON)
deriving anyclass (NFData)
_FileReference = iso toFileReference fromFileReference _FileReference = iso toFileReference fromFileReference
where where
@ -213,6 +214,7 @@ instance HasFileReference PureFile where
instance (HasFileReference a, HasFileReference b) => HasFileReference (Either a b) where instance (HasFileReference a, HasFileReference b) => HasFileReference (Either a b) where
newtype FileReferenceResidual (Either a b) = FileReferenceResidualEither { unFileReferenceResidualEither :: Either (FileReferenceResidual a) (FileReferenceResidual b) } newtype FileReferenceResidual (Either a b) = FileReferenceResidualEither { unFileReferenceResidualEither :: Either (FileReferenceResidual a) (FileReferenceResidual b) }
deriving (Generic, Typeable)
_FileReference = iso doSplit doJoin _FileReference = iso doSplit doJoin
where doSplit (Right r) = over _2 (FileReferenceResidualEither . Right) $ r ^. _FileReference where doSplit (Right r) = over _2 (FileReferenceResidualEither . Right) $ r ^. _FileReference
@ -225,6 +227,7 @@ instance HasFileReference record => HasFileReference (Entity record) where
{ fileReferenceResidualEntityKey :: Key record { fileReferenceResidualEntityKey :: Key record
, fileReferenceResidualEntityResidual :: FileReferenceResidual record , fileReferenceResidualEntityResidual :: FileReferenceResidual record
} }
deriving (Generic, Typeable)
_FileReference = iso doSplit doJoin _FileReference = iso doSplit doJoin
where doSplit Entity{..} = (fRef, FileReferenceResidualEntity entityKey res) where doSplit Entity{..} = (fRef, FileReferenceResidualEntity entityKey res)
@ -243,11 +246,14 @@ newtype instance FileReferenceTitleMap FileReference add = FileReferenceFileRefe
} }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving newtype (Semigroup, Monoid) deriving newtype (Semigroup, Monoid)
deriving anyclass (NFData)
data FileReferenceFileReferenceTitleMapElem add = FileReferenceFileReferenceTitleMapElem data FileReferenceFileReferenceTitleMapElem add = FileReferenceFileReferenceTitleMapElem
{ fRefTitleMapContent :: Maybe FileContentReference { fRefTitleMapContent :: Maybe FileContentReference
, fRefTitleMapModified :: UTCTime , fRefTitleMapModified :: UTCTime
, fRefTitleMapAdditional :: add , fRefTitleMapAdditional :: add
} deriving (Eq, Ord, Read, Show, Generic, Typeable) }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
makePrisms ''FileReferenceFileReferenceTitleMapElem makePrisms ''FileReferenceFileReferenceTitleMapElem
@ -265,7 +271,9 @@ instance FileReferenceTitleMapConvertible add FileReference FileReference where
data FileFieldUserOption a = FileFieldUserOption data FileFieldUserOption a = FileFieldUserOption
{ fieldOptionForce :: Bool { fieldOptionForce :: Bool
, fieldOptionDefault :: a , fieldOptionDefault :: a
} deriving (Eq, Ord, Read, Show, Generic, Typeable) }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 2 { fieldLabelModifier = camelToPathPiece' 2
@ -279,11 +287,13 @@ data FileField fileid = FileField
, fieldMaxFileSize :: Maybe Natural , fieldMaxFileSize :: Maybe Natural
, fieldAdditionalFiles :: FileReferenceTitleMap fileid (FileFieldUserOption Bool) , fieldAdditionalFiles :: FileReferenceTitleMap fileid (FileFieldUserOption Bool)
, fieldAllEmptyOk :: Bool , fieldAllEmptyOk :: Bool
} deriving (Generic, Typeable) }
deriving (Generic, Typeable)
deriving instance Eq (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Eq (FileField fileid) deriving instance Eq (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Eq (FileField fileid)
deriving instance Ord (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Ord (FileField fileid) deriving instance Ord (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Ord (FileField fileid)
deriving instance Read (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Read (FileField fileid) deriving instance Read (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Read (FileField fileid)
deriving instance Show (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Show (FileField fileid) deriving instance Show (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Show (FileField fileid)
deriving anyclass instance NFData (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => NFData (FileField fileid)
instance ToJSON (FileField FileReference) where instance ToJSON (FileField FileReference) where
toJSON FileField{..} = JSON.object $ catMaybes toJSON FileField{..} = JSON.object $ catMaybes

View File

@ -64,11 +64,7 @@ data NotificationTrigger
| NTExamOfficeExamResultsChanged | NTExamOfficeExamResultsChanged
| NTCourseRegistered | NTCourseRegistered
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite, Hashable, NFData)
instance Universe NotificationTrigger
instance Finite NotificationTrigger
instance Hashable NotificationTrigger
nullaryPathPiece ''NotificationTrigger $ camelToPathPiece' 1 nullaryPathPiece ''NotificationTrigger $ camelToPathPiece' 1
pathPieceJSON ''NotificationTrigger pathPieceJSON ''NotificationTrigger
@ -78,6 +74,7 @@ pathPieceJSONKey ''NotificationTrigger
newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool } newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool }
deriving (Generic, Typeable) deriving (Generic, Typeable)
deriving newtype (Eq, Ord, Read, Show) deriving newtype (Eq, Ord, Read, Show)
deriving anyclass (NFData)
instance Default NotificationSettings where instance Default NotificationSettings where
def = NotificationSettings $ not . flip HashSet.member defaultOff def = NotificationSettings $ not . flip HashSet.member defaultOff
@ -117,7 +114,7 @@ instance PathPiece BounceSecret where
newtype MailContent = MailContent [Alternatives] newtype MailContent = MailContent [Alternatives]
deriving (Eq, Show, Generic, Typeable) deriving (Eq, Show, Generic, Typeable)
deriving newtype (ToJSON, FromJSON) deriving newtype (ToJSON, FromJSON)
deriving anyclass (Binary) deriving anyclass (Binary, NFData)
derivePersistFieldJSON ''MailContent derivePersistFieldJSON ''MailContent

View File

@ -30,7 +30,7 @@ data MarkupFormat
| MarkupHtml | MarkupHtml
| MarkupPlaintext | MarkupPlaintext
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite, NFData)
nullaryPathPiece ''MarkupFormat $ camelToPathPiece' 1 nullaryPathPiece ''MarkupFormat $ camelToPathPiece' 1
pathPieceJSON ''MarkupFormat pathPieceJSON ''MarkupFormat
@ -38,7 +38,9 @@ data StoredMarkup = StoredMarkup
{ markupInputFormat :: MarkupFormat { markupInputFormat :: MarkupFormat
, markupInput :: LT.Text , markupInput :: LT.Text
, markupOutput :: Html , markupOutput :: Html
} deriving (Read, Show, Generic, Typeable) }
deriving (Read, Show, Generic, Typeable)
deriving anyclass (NFData)
htmlToStoredMarkup :: Html -> StoredMarkup htmlToStoredMarkup :: Html -> StoredMarkup
htmlToStoredMarkup html = StoredMarkup htmlToStoredMarkup html = StoredMarkup

View File

@ -24,7 +24,7 @@ import Web.HttpApiData
data StudyFieldType = FieldPrimary | FieldSecondary data StudyFieldType = FieldPrimary | FieldSecondary
deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic) deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite, NFData)
derivePersistField "StudyFieldType" derivePersistField "StudyFieldType"
nullaryPathPiece ''StudyFieldType $ camelToPathPiece' 1 nullaryPathPiece ''StudyFieldType $ camelToPathPiece' 1
@ -41,14 +41,12 @@ data Theme
| ThemeMossGreen | ThemeMossGreen
| ThemeSkyLove | ThemeSkyLove
deriving (Eq, Ord, Bounded, Enum, Show, Read, Generic) deriving (Eq, Ord, Bounded, Enum, Show, Read, Generic)
deriving anyclass (Universe, Finite, NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = fromJust . stripPrefix "Theme" { constructorTagModifier = fromJust . stripPrefix "Theme"
} ''Theme } ''Theme
instance Universe Theme
instance Finite Theme
nullaryPathPiece ''Theme $ camelToPathPiece' 1 nullaryPathPiece ''Theme $ camelToPathPiece' 1
$(deriveSimpleWith ''ToMessage 'toMessage (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user $(deriveSimpleWith ''ToMessage 'toMessage (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user
@ -64,8 +62,7 @@ data FavouriteReason
| FavouriteManual | FavouriteManual
| FavouriteCurrent | FavouriteCurrent
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe FavouriteReason deriving anyclass (Universe, Finite, NFData)
instance Finite FavouriteReason
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1 { constructorTagModifier = camelToPathPiece' 1
} ''FavouriteReason } ''FavouriteReason
@ -77,8 +74,7 @@ data Sex
| SexFemale | SexFemale
| SexNotApplicable | SexNotApplicable
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe Sex deriving anyclass (Universe, Finite, NFData)
instance Finite Sex
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1 { constructorTagModifier = camelToPathPiece' 1
} ''Sex } ''Sex
@ -129,7 +125,7 @@ data TokenBucketIdent = TokenBucketInjectFiles | TokenBucketInjectFilesCount
| TokenBucketPruneFiles | TokenBucketPruneFiles
| TokenBucketRechunkFiles | TokenBucketRechunkFiles
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite, Hashable) deriving anyclass (Universe, Finite, Hashable, NFData)
nullaryPathPiece ''TokenBucketIdent $ camelToPathPiece' 2 nullaryPathPiece ''TokenBucketIdent $ camelToPathPiece' 2
pathPieceJSON ''TokenBucketIdent pathPieceJSON ''TokenBucketIdent

View File

@ -16,6 +16,7 @@ data RoomReference
, roomRefInstructions :: Maybe StoredMarkup , roomRefInstructions :: Maybe StoredMarkup
} }
deriving (Eq, Ord, Show, Generic, Typeable) deriving (Eq, Ord, Show, Generic, Typeable)
deriving anyclass (NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 2 { constructorTagModifier = camelToPathPiece' 2

View File

@ -10,10 +10,7 @@ data SchoolFunction
| SchoolExamOffice | SchoolExamOffice
| SchoolAllocation | SchoolAllocation
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe SchoolFunction deriving anyclass (Universe, Finite, Hashable, NFData)
instance Finite SchoolFunction
instance Hashable SchoolFunction
instance NFData SchoolFunction
nullaryPathPiece ''SchoolFunction $ camelToPathPiece' 1 nullaryPathPiece ''SchoolFunction $ camelToPathPiece' 1
pathPieceJSON ''SchoolFunction pathPieceJSON ''SchoolFunction

View File

@ -250,7 +250,7 @@ data UserGroupName
= UserGroupMetrics | UserGroupCrontab = UserGroupMetrics | UserGroupCrontab
| UserGroupCustom { userGroupCustomName :: CI Text } | UserGroupCustom { userGroupCustomName :: CI Text }
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (Hashable) deriving anyclass (Hashable, NFData)
instance PathPiece UserGroupName where instance PathPiece UserGroupName where
toPathPiece UserGroupMetrics = "metrics" toPathPiece UserGroupMetrics = "metrics"

View File

@ -168,7 +168,8 @@ data SheetGroup
= Arbitrary { maxParticipants :: Natural } = Arbitrary { maxParticipants :: Natural }
| RegisteredGroups | RegisteredGroups
| NoGroups | NoGroups
deriving (Show, Read, Eq, Generic) deriving (Show, Read, Eq, Generic, Typeable)
deriving anyclass (NFData)
deriveJSON defaultOptions ''SheetGroup deriveJSON defaultOptions ''SheetGroup
derivePersistFieldJSON ''SheetGroup derivePersistFieldJSON ''SheetGroup
@ -200,7 +201,9 @@ data UploadSpecificFile = UploadSpecificFile
, specificFileRequired :: Bool , specificFileRequired :: Bool
, specificFileEmptyOk :: Bool , specificFileEmptyOk :: Bool
, specificFileMaxSize :: Maybe Natural , specificFileMaxSize :: Maybe Natural
} deriving (Show, Read, Eq, Ord, Generic) }
deriving (Show, Read, Eq, Ord, Generic, Typeable)
deriving anyclass (NFData)
instance ToJSON UploadSpecificFile where instance ToJSON UploadSpecificFile where
toJSON UploadSpecificFile{..} = Aeson.object toJSON UploadSpecificFile{..} = Aeson.object
@ -229,7 +232,8 @@ data UploadMode = NoUpload
| UploadSpecific | UploadSpecific
{ uploadSpecificFiles :: NonNull (Set UploadSpecificFile) { uploadSpecificFiles :: NonNull (Set UploadSpecificFile)
} }
deriving (Show, Read, Eq, Ord, Generic) deriving (Show, Read, Eq, Ord, Generic, Typeable)
deriving anyclass (NFData)
defaultExtensionRestriction :: Maybe (NonNull (Set Extension)) defaultExtensionRestriction :: Maybe (NonNull (Set Extension))
defaultExtensionRestriction = fromNullable $ Set.fromList ["txt", "pdf"] defaultExtensionRestriction = fromNullable $ Set.fromList ["txt", "pdf"]
@ -284,7 +288,8 @@ data SubmissionMode = SubmissionMode
{ submissionModeCorrector :: Bool { submissionModeCorrector :: Bool
, submissionModeUser :: Maybe UploadMode , submissionModeUser :: Maybe UploadMode
} }
deriving (Show, Read, Eq, Ord, Generic) deriving (Show, Read, Eq, Ord, Generic, Typeable)
deriving anyclass (NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 2 { fieldLabelModifier = camelToPathPiece' 2
@ -319,12 +324,11 @@ data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rati
, byProportion :: Rational -- ^ workload proportion of all submission not assigned to tutorial leaders , byProportion :: Rational -- ^ workload proportion of all submission not assigned to tutorial leaders
} }
deriving (Show, Read, Eq, Ord, Generic) deriving (Show, Read, Eq, Ord, Generic)
deriving anyclass (Hashable, NFData)
deriveJSON defaultOptions ''Load deriveJSON defaultOptions ''Load
derivePersistFieldJSON ''Load derivePersistFieldJSON ''Load
instance Hashable Load
instance Semigroup Load where instance Semigroup Load where
(Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop') (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')
where where
@ -346,7 +350,7 @@ instance Monoid Load where
data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
deriving anyclass (Universe, Finite, Hashable) deriving anyclass (Universe, Finite, Hashable, NFData)
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = fromJust . stripPrefix "Corrector" { constructorTagModifier = fromJust . stripPrefix "Corrector"

View File

@ -56,6 +56,7 @@ newtype Pseudonym = Pseudonym Word24
deriving newtype ( Bounded, Enum, Integral, Num, Real, Ix deriving newtype ( Bounded, Enum, Integral, Num, Real, Ix
, PersistField, Random , PersistField, Random
) )
deriving anyclass (NFData)
instance PersistFieldSql Pseudonym where instance PersistFieldSql Pseudonym where
sqlType _ = sqlType $ Proxy @Word24 sqlType _ = sqlType $ Proxy @Word24

View File

@ -78,15 +78,16 @@ newtype WorkflowGraph fileid userid = WorkflowGraph
deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraph fileid userid) deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraph fileid userid)
deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraph fileid userid) deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraph fileid userid)
deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraph fileid userid) deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraph fileid userid)
deriving anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraph fileid userid)
newtype WorkflowGraphReference = WorkflowGraphReference (Digest SHA3_256) newtype WorkflowGraphReference = WorkflowGraphReference (Digest SHA3_256)
deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable) deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
deriving newtype ( PersistField deriving newtype ( PersistField
, PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON , PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
, Hashable, NFData
, ByteArrayAccess , ByteArrayAccess
, Binary , Binary
) )
deriving anyclass (Hashable, NFData)
instance PersistFieldSql WorkflowGraphReference where instance PersistFieldSql WorkflowGraphReference where
sqlType _ = sqlType $ Proxy @(Digest SHA3_256) sqlType _ = sqlType $ Proxy @(Digest SHA3_256)
@ -96,6 +97,7 @@ instance PersistFieldSql WorkflowGraphReference where
newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLabel :: CI Text } newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLabel :: CI Text }
deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable) deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable)
deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary) deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary)
deriving anyclass (NFData)
instance PersistFieldSql WorkflowGraphNodeLabel where instance PersistFieldSql WorkflowGraphNodeLabel where
sqlType _ = sqlType $ Proxy @(CI Text) sqlType _ = sqlType $ Proxy @(CI Text)
@ -112,24 +114,30 @@ data WorkflowGraphNode fileid userid = WGN
deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphNode fileid userid) deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphNode fileid userid)
deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphNode fileid userid) deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphNode fileid userid)
deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphNode fileid userid) deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphNode fileid userid)
deriving anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraphNode fileid userid)
data WorkflowNodeView userid = WorkflowNodeView data WorkflowNodeView userid = WorkflowNodeView
{ wnvViewers :: NonNull (Set (WorkflowRole userid)) { wnvViewers :: NonNull (Set (WorkflowRole userid))
, wnvDisplayLabel :: I18nText , wnvDisplayLabel :: I18nText
} deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) }
deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
deriving anyclass (NFData)
data WorkflowNodeMessage userid = WorkflowNodeMessage data WorkflowNodeMessage userid = WorkflowNodeMessage
{ wnmViewers :: NonNull (Set (WorkflowRole userid)) { wnmViewers :: NonNull (Set (WorkflowRole userid))
, wnmRestriction :: Maybe (PredDNF WorkflowGraphRestriction) , wnmRestriction :: Maybe (PredDNF WorkflowGraphRestriction)
, wnmStatus :: MessageStatus , wnmStatus :: MessageStatus
, wnmContent :: I18nHtml , wnmContent :: I18nHtml
} deriving (Eq, Ord, Read, Show, Generic, Typeable) }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
----- WORKFLOW GRAPH: EDGES ----- ----- WORKFLOW GRAPH: EDGES -----
newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel { unWorkflowGraphEdgeLabel :: CI Text } newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel { unWorkflowGraphEdgeLabel :: CI Text }
deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable) deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable)
deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary) deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary)
deriving anyclass (NFData)
instance PersistFieldSql WorkflowGraphEdgeLabel where instance PersistFieldSql WorkflowGraphEdgeLabel where
sqlType _ = sqlType $ Proxy @(CI Text) sqlType _ = sqlType $ Proxy @(CI Text)
@ -139,6 +147,7 @@ data WorkflowGraphRestriction
| WorkflowGraphRestrictionPreviousNode { wgrPreviousNode :: WorkflowGraphNodeLabel } | WorkflowGraphRestrictionPreviousNode { wgrPreviousNode :: WorkflowGraphNodeLabel }
| WorkflowGraphRestrictionInitial | WorkflowGraphRestrictionInitial
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
data WorkflowGraphEdge fileid userid data WorkflowGraphEdge fileid userid
= WorkflowGraphEdgeManual = WorkflowGraphEdgeManual
@ -165,13 +174,16 @@ data WorkflowGraphEdge fileid userid
deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphEdge fileid userid) deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphEdge fileid userid)
deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphEdge fileid userid) deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphEdge fileid userid)
deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphEdge fileid userid) deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphEdge fileid userid)
deriving anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraphEdge fileid userid)
data WorkflowEdgeMessage userid = WorkflowEdgeMessage data WorkflowEdgeMessage userid = WorkflowEdgeMessage
{ wemViewers :: NonNull (Set (WorkflowRole userid)) { wemViewers :: NonNull (Set (WorkflowRole userid))
, wemRestriction :: Maybe (PredDNF WorkflowGraphRestriction) , wemRestriction :: Maybe (PredDNF WorkflowGraphRestriction)
, wemStatus :: MessageStatus , wemStatus :: MessageStatus
, wemContent :: I18nHtml , wemContent :: I18nHtml
} deriving (Eq, Ord, Read, Show, Generic, Typeable) }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
-- | A wrapped `Scientific` -- | A wrapped `Scientific`
-- --
@ -180,6 +192,7 @@ newtype WorkflowGraphEdgeFormOrder = WorkflowGraphEdgeFormOrder { unWorkflowGrap
deriving (Read, Show, Generic, Typeable) deriving (Read, Show, Generic, Typeable)
deriving (Eq, Ord) via (NTop (Maybe Scientific)) deriving (Eq, Ord) via (NTop (Maybe Scientific))
deriving (Semigroup, Monoid) via (Maybe (Min Scientific)) deriving (Semigroup, Monoid) via (Maybe (Min Scientific))
deriving anyclass (NFData)
newtype WorkflowGraphEdgeForm fileid userid newtype WorkflowGraphEdgeForm fileid userid
= WorkflowGraphEdgeForm = WorkflowGraphEdgeForm
@ -191,11 +204,13 @@ newtype WorkflowGraphEdgeForm fileid userid
-- - optional fields are always considered to be filled -- - optional fields are always considered to be filled
-- --
-- since fields can reference other labels this allows arbitrary requirements to be encoded. -- since fields can reference other labels this allows arbitrary requirements to be encoded.
} deriving (Generic, Typeable) }
deriving (Generic, Typeable)
deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphEdgeForm fileid userid) deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphEdgeForm fileid userid)
deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphEdgeForm fileid userid) deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphEdgeForm fileid userid)
deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphEdgeForm fileid userid) deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphEdgeForm fileid userid)
deriving anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraphEdgeForm fileid userid)
----- WORKFLOW GRAPH: ROLES / ACTORS ----- ----- WORKFLOW GRAPH: ROLES / ACTORS -----
@ -213,16 +228,21 @@ data WorkflowRole userid
data WorkflowPayloadView userid = WorkflowPayloadView data WorkflowPayloadView userid = WorkflowPayloadView
{ wpvViewers :: NonNull (Set (WorkflowRole userid)) { wpvViewers :: NonNull (Set (WorkflowRole userid))
, wpvDisplayLabel :: I18nText , wpvDisplayLabel :: I18nText
} deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) }
deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
deriving anyclass (NFData)
data WorkflowPayloadSpec fileid userid = forall payload. Typeable payload => WorkflowPayloadSpec (WorkflowPayloadField fileid userid payload) data WorkflowPayloadSpec fileid userid = forall payload. Typeable payload => WorkflowPayloadSpec (WorkflowPayloadField fileid userid payload)
deriving (Typeable) deriving (Typeable)
deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowPayloadSpec fileid userid) deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowPayloadSpec fileid userid)
instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowPayloadSpec fileid userid) where
rnf (WorkflowPayloadSpec pField) = rnf pField
data WorkflowPayloadFieldReference data WorkflowPayloadFieldReference
deriving (Typeable) deriving (Typeable)
-- Don't forget to update the NFData instance for every change!
data WorkflowPayloadField fileid userid (payload :: Type) where data WorkflowPayloadField fileid userid (payload :: Type) where
WorkflowPayloadFieldText :: { wpftLabel :: I18nText WorkflowPayloadFieldText :: { wpftLabel :: I18nText
, wpftPlaceholder :: Maybe I18nText , wpftPlaceholder :: Maybe I18nText
@ -325,6 +345,18 @@ instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileFie
(WorkflowPayloadFieldReference{}, _) -> LT (WorkflowPayloadFieldReference{}, _) -> LT
(WorkflowPayloadFieldMultiple{}, _) -> GT (WorkflowPayloadFieldMultiple{}, _) -> GT
instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowPayloadField fileid userid payload) where
rnf = \case
WorkflowPayloadFieldText{..} -> wpftLabel `deepseq` wpftPlaceholder `deepseq` wpftTooltip `deepseq` wpftDefault `deepseq` wpftLarge `deepseq` wpftOptional `deepseq` ()
WorkflowPayloadFieldNumber{..} -> wpfnLabel `deepseq` wpfnPlaceholder `deepseq` wpfnTooltip `deepseq` wpfnDefault `deepseq` wpfnMin `deepseq` wpfnMax `deepseq` wpfnStep `deepseq` wpfnOptional `deepseq` ()
WorkflowPayloadFieldBool{..} -> wpfbLabel `deepseq` wpfbTooltip `deepseq` wpfbDefault `deepseq` wpfbOptional `deepseq` ()
WorkflowPayloadFieldDay{..} -> wpfdLabel `deepseq` wpfdTooltip `deepseq` wpfdDefault `deepseq` wpfdOptional `deepseq` ()
WorkflowPayloadFieldFile{..} -> wpffLabel `deepseq` wpffTooltip `deepseq` wpffConfig `deepseq` wpffOptional `deepseq` ()
WorkflowPayloadFieldUser{..} -> wpfuLabel `deepseq` wpfuTooltip `deepseq` wpfuDefault `deepseq` wpfuOptional `deepseq` ()
WorkflowPayloadFieldCaptureUser -> ()
WorkflowPayloadFieldReference{..} -> wpfrTarget `deepseq` ()
WorkflowPayloadFieldMultiple{..} -> wpfmLabel `deepseq` wpfmTooltip `deepseq` wpfmDefault `deepseq` wpfmSub `deepseq` wpfmMin `deepseq` wpfmRange `deepseq` ()
_WorkflowPayloadSpec :: forall payload fileid userid. _WorkflowPayloadSpec :: forall payload fileid userid.
( Typeable payload, Typeable fileid, Typeable userid ) ( Typeable payload, Typeable fileid, Typeable userid )
=> Prism' (WorkflowPayloadSpec fileid userid) (WorkflowPayloadField fileid userid payload) => Prism' (WorkflowPayloadSpec fileid userid) (WorkflowPayloadField fileid userid payload)
@ -332,7 +364,7 @@ _WorkflowPayloadSpec = prism' WorkflowPayloadSpec $ \(WorkflowPayloadSpec pF) ->
data WorkflowPayloadField' = WPFText' | WPFNumber' | WPFBool' | WPFDay' | WPFFile' | WPFUser' | WPFCaptureUser' | WPFReference' | WPFMultiple' data WorkflowPayloadField' = WPFText' | WPFNumber' | WPFBool' | WPFDay' | WPFFile' | WPFUser' | WPFCaptureUser' | WPFReference' | WPFMultiple'
deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable) deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite, NFData)
----- WORKFLOW INSTANCE ----- ----- WORKFLOW INSTANCE -----
@ -349,7 +381,7 @@ data WorkflowScope termid schoolid courseid
data WorkflowScope' data WorkflowScope'
= WSGlobal' | WSTerm' | WSSchool' | WSTermSchool' | WSCourse' = WSGlobal' | WSTerm' | WSSchool' | WSTermSchool' | WSCourse'
deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic, Typeable) deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic, Typeable)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite, NFData)
classifyWorkflowScope :: WorkflowScope termid schoolid courseid -> WorkflowScope' classifyWorkflowScope :: WorkflowScope termid schoolid courseid -> WorkflowScope'
classifyWorkflowScope = \case classifyWorkflowScope = \case
@ -372,6 +404,7 @@ instance PersistFieldSql WorkflowPayloadLabel where
newtype WorkflowStateIndex = WorkflowStateIndex { unWorkflowStateIndex :: Word64 } newtype WorkflowStateIndex = WorkflowStateIndex { unWorkflowStateIndex :: Word64 }
deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable) deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable)
deriving newtype (Num, Real, Integral, Enum, Bounded, ToJSON, FromJSON, PathPiece, Binary) deriving newtype (Num, Real, Integral, Enum, Bounded, ToJSON, FromJSON, PathPiece, Binary)
deriving anyclass (NFData)
type WorkflowState fileid userid = NonNull (Seq (WorkflowAction fileid userid)) type WorkflowState fileid userid = NonNull (Seq (WorkflowAction fileid userid))
@ -395,13 +428,16 @@ data WorkflowAction fileid userid = WorkflowAction
, wpTime :: UTCTime , wpTime :: UTCTime
} }
deriving (Eq, Ord, Show, Generic, Typeable) deriving (Eq, Ord, Show, Generic, Typeable)
deriving anyclass (NFData)
data WorkflowActionInfo fileid userid = WorkflowActionInfo data WorkflowActionInfo fileid userid = WorkflowActionInfo
{ waiIx :: WorkflowStateIndex { waiIx :: WorkflowStateIndex
, waiFrom :: Maybe WorkflowGraphNodeLabel , waiFrom :: Maybe WorkflowGraphNodeLabel
, waiHistory :: [WorkflowAction fileid userid] , waiHistory :: [WorkflowAction fileid userid]
, waiAction :: WorkflowAction fileid userid , waiAction :: WorkflowAction fileid userid
} deriving (Eq, Ord, Show, Generic, Typeable) }
deriving (Eq, Ord, Show, Generic, Typeable)
deriving anyclass (NFData)
workflowActionInfos :: WorkflowState fileid userid -> [WorkflowActionInfo fileid userid] workflowActionInfos :: WorkflowState fileid userid -> [WorkflowActionInfo fileid userid]
workflowActionInfos wState workflowActionInfos wState
@ -416,6 +452,9 @@ workflowActionInfos wState
data WorkflowFieldPayloadW fileid userid = forall payload. IsWorkflowFieldPayload' fileid userid payload => WorkflowFieldPayloadW (WorkflowFieldPayload fileid userid payload) data WorkflowFieldPayloadW fileid userid = forall payload. IsWorkflowFieldPayload' fileid userid payload => WorkflowFieldPayloadW (WorkflowFieldPayload fileid userid payload)
deriving (Typeable) deriving (Typeable)
instance (NFData fileid, NFData userid) => NFData (WorkflowFieldPayloadW fileid userid) where
rnf (WorkflowFieldPayloadW fPayload) = rnf fPayload
instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid) => Eq (WorkflowFieldPayloadW fileid userid) where instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid) => Eq (WorkflowFieldPayloadW fileid userid) where
(WorkflowFieldPayloadW a) == (WorkflowFieldPayloadW b) (WorkflowFieldPayloadW a) == (WorkflowFieldPayloadW b)
= case typeOf a `eqTypeRep` typeOf b of = case typeOf a `eqTypeRep` typeOf b of
@ -476,6 +515,7 @@ workflowPayloadSort ordFiles ordUsers (WorkflowFieldPayloadW a) (WorkflowFieldPa
instance (Show fileid, Show userid) => Show (WorkflowFieldPayloadW fileid userid) where instance (Show fileid, Show userid) => Show (WorkflowFieldPayloadW fileid userid) where
show (WorkflowFieldPayloadW payload) = show payload show (WorkflowFieldPayloadW payload) = show payload
-- Don't forget to update the NFData instance for every change!
data WorkflowFieldPayload fileid userid (payload :: Type) where data WorkflowFieldPayload fileid userid (payload :: Type) where
WFPText :: Text -> WorkflowFieldPayload fileid userid Text WFPText :: Text -> WorkflowFieldPayload fileid userid Text
WFPNumber :: Scientific -> WorkflowFieldPayload fileid userid Scientific WFPNumber :: Scientific -> WorkflowFieldPayload fileid userid Scientific
@ -489,6 +529,15 @@ deriving instance (Show fileid, Show userid) => Show (WorkflowFieldPayload filei
deriving instance (Typeable fileid, Typeable userid, Eq fileid, Eq userid) => Eq (WorkflowFieldPayload fileid userid payload) deriving instance (Typeable fileid, Typeable userid, Eq fileid, Eq userid) => Eq (WorkflowFieldPayload fileid userid payload)
deriving instance (Typeable fileid, Typeable userid, Ord fileid, Ord userid) => Ord (WorkflowFieldPayload fileid userid payload) deriving instance (Typeable fileid, Typeable userid, Ord fileid, Ord userid) => Ord (WorkflowFieldPayload fileid userid payload)
instance (NFData fileid, NFData userid) => NFData (WorkflowFieldPayload fileid userid payload) where
rnf = \case
WFPText t -> rnf t
WFPNumber n -> rnf n
WFPBool b -> rnf b
WFPDay d -> rnf d
WFPFile f -> rnf f
WFPUser u -> rnf u
_WorkflowFieldPayloadW :: forall payload fileid userid. _WorkflowFieldPayloadW :: forall payload fileid userid.
( IsWorkflowFieldPayload' fileid userid payload, Typeable fileid, Typeable userid ) ( IsWorkflowFieldPayload' fileid userid payload, Typeable fileid, Typeable userid )
=> Prism' (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayload fileid userid payload) => Prism' (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayload fileid userid payload)
@ -496,7 +545,7 @@ _WorkflowFieldPayloadW = prism' WorkflowFieldPayloadW $ \(WorkflowFieldPayloadW
data WorkflowFieldPayload' = WFPText' | WFPNumber' | WFPBool' | WFPDay' | WFPFile' | WFPUser' data WorkflowFieldPayload' = WFPText' | WFPNumber' | WFPBool' | WFPDay' | WFPFile' | WFPUser'
deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable) deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite, NFData)
type IsWorkflowFieldPayload' fileid userid payload = IsWorkflowFieldPayload fileid fileid userid userid payload payload type IsWorkflowFieldPayload' fileid userid payload = IsWorkflowFieldPayload fileid fileid userid userid payload payload

View File

@ -31,9 +31,7 @@ import Control.Lens
deriving instance Read Address deriving instance Read Address
deriving instance Ord Address deriving instance Ord Address
deriving instance Generic Address deriving instance Generic Address
deriving anyclass instance Hashable Address
instance Hashable Address
instance NFData Address
deriveToJSON defaultOptions deriveToJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1 { fieldLabelModifier = camelToPathPiece' 1
@ -58,6 +56,7 @@ instance Csv.DefaultOrdered Address where
newtype MailHeaders = MailHeaders Headers newtype MailHeaders = MailHeaders Headers
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
instance ToJSON MailHeaders where instance ToJSON MailHeaders where
toJSON (MailHeaders hs) = toJSON $ over (traverse . _1) decodeUtf8 hs toJSON (MailHeaders hs) = toJSON $ over (traverse . _1) decodeUtf8 hs
@ -77,6 +76,13 @@ instance Binary Part
instance Binary Address instance Binary Address
instance Binary Mail instance Binary Mail
deriving anyclass instance NFData Encoding
deriving anyclass instance NFData Disposition
deriving anyclass instance NFData PartContent
deriving anyclass instance NFData Part
deriving anyclass instance NFData Address
deriving anyclass instance NFData Mail
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece { constructorTagModifier = camelToPathPiece
} ''Encoding } ''Encoding

View File

@ -7,7 +7,6 @@ module Settings.Cluster
) where ) where
import ClassyPrelude.Yesod import ClassyPrelude.Yesod
import Web.HttpApiData
import Data.Kind (Type) import Data.Kind (Type)
@ -51,21 +50,15 @@ data ClusterSettingsKey
| ClusterMemcachedKey | ClusterMemcachedKey
| ClusterVerpSecret | ClusterVerpSecret
| ClusterAuthKey | ClusterAuthKey
deriving (Eq, Ord, Enum, Bounded, Show, Read) deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
deriving anyclass (Universe, Finite, NFData)
instance Universe ClusterSettingsKey
instance Finite ClusterSettingsKey
nullaryPathPiece ''ClusterSettingsKey $ camelToPathPiece' 1 nullaryPathPiece ''ClusterSettingsKey $ camelToPathPiece' 1
pathPieceJSON ''ClusterSettingsKey pathPieceJSON ''ClusterSettingsKey
pathPieceJSONKey ''ClusterSettingsKey pathPieceJSONKey ''ClusterSettingsKey
pathPieceHttpApiData ''ClusterSettingsKey
derivePersistFieldPathPiece ''ClusterSettingsKey derivePersistFieldPathPiece ''ClusterSettingsKey
instance ToHttpApiData ClusterSettingsKey where
toUrlPiece = toPathPiece
instance FromHttpApiData ClusterSettingsKey where
parseUrlPiece = maybe (Left "Could not parse url piece") Right . fromPathPiece
class (ToJSON (ClusterSettingValue key), FromJSON (ClusterSettingValue key)) => ClusterSetting (key :: ClusterSettingsKey) where class (ToJSON (ClusterSettingValue key), FromJSON (ClusterSettingValue key)) => ClusterSetting (key :: ClusterSettingsKey) where
type ClusterSettingValue key :: Type type ClusterSettingValue key :: Type

View File

@ -1,3 +1,5 @@
{-# LANGUAGE BangPatterns #-}
module Utils.ARC module Utils.ARC
( ARCTick ( ARCTick
, ARC, initARC , ARC, initARC
@ -133,17 +135,18 @@ arcAlterF :: forall f k w v.
( Ord k, Hashable k ( Ord k, Hashable k
, Functor f , Functor f
, Integral w , Integral w
, NFData k, NFData w, NFData v
) )
=> k => k
-> (Maybe (v, w) -> f (Maybe (v, w))) -> (Maybe (v, w) -> f (Maybe (v, w)))
-> ARC k w v -> ARC k w v
-> ARCTick -> f (ARC k w v, ARCTick) -> ARCTick -> f (ARC k w v, ARCTick)
-- | Unchecked precondition: item weights are always less than `arcMaximumWeight` -- | Unchecked precondition: item weights are always less than `arcMaximumWeight`
arcAlterF unhashedK@(hashed -> k) f oldARC@ARC{..} now arcAlterF !(force -> unhashedK@(hashed -> k)) f oldARC@ARC{..} now
| later <= initialARCTick = uncurry (arcAlterF unhashedK f) $ initARC arcMaximumGhost arcMaximumWeight | later <= initialARCTick = uncurry (arcAlterF unhashedK f) $ initARC arcMaximumGhost arcMaximumWeight
| otherwise = (, later) <$> if | otherwise = (, later) <$> if
| Just (_p, x@(_, w), arcFrequent') <- HashPSQ.deleteView k arcFrequent | Just (_p, x@(_, w), arcFrequent') <- HashPSQ.deleteView k arcFrequent
-> f (Just x) <&> \(fromMaybe x -> x'@(_, w')) -> f (Just x) <&> \(fromMaybe x -> !(force -> x'@(_, w')))
-> let (arcFrequent'', arcFrequentWeight'', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent |- w') arcFrequent' (arcFrequentWeight - w) arcGhostFrequent -> let (arcFrequent'', arcFrequentWeight'', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent |- w') arcFrequent' (arcFrequentWeight - w) arcGhostFrequent
in oldARC in oldARC
{ arcFrequent = HashPSQ.insert k now x' arcFrequent'' { arcFrequent = HashPSQ.insert k now x' arcFrequent''
@ -151,7 +154,7 @@ arcAlterF unhashedK@(hashed -> k) f oldARC@ARC{..} now
, arcGhostFrequent = arcGhostFrequent' , arcGhostFrequent = arcGhostFrequent'
} }
| Just (_p, x@(_, w), arcRecent') <- HashPSQ.deleteView k arcRecent | Just (_p, x@(_, w), arcRecent') <- HashPSQ.deleteView k arcRecent
-> f (Just x) <&> \(fromMaybe x -> x'@(_, w')) -> f (Just x) <&> \(fromMaybe x -> !(force -> x'@(_, w')))
-> let (arcFrequent', arcFrequentWeight', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent |- w') arcFrequent arcFrequentWeight arcGhostFrequent -> let (arcFrequent', arcFrequentWeight', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent |- w') arcFrequent arcFrequentWeight arcGhostFrequent
in oldARC in oldARC
{ arcRecent = arcRecent' { arcRecent = arcRecent'
@ -165,7 +168,7 @@ arcAlterF unhashedK@(hashed -> k) f oldARC@ARC{..} now
Nothing -> oldARC Nothing -> oldARC
{ arcGhostRecent = HashPSQ.insert k now () arcGhostRecent' { arcGhostRecent = HashPSQ.insert k now () arcGhostRecent'
} }
Just x@(_, w) Just !(force -> x@(_, w))
-> let arcTargetRecent' = min arcMaximumWeight $ arcTargetRecent + max avgWeight (round $ toRational (HashPSQ.size arcGhostFrequent) / toRational (HashPSQ.size arcGhostRecent) * toRational avgWeight) -> let arcTargetRecent' = min arcMaximumWeight $ arcTargetRecent + max avgWeight (round $ toRational (HashPSQ.size arcGhostFrequent) / toRational (HashPSQ.size arcGhostRecent) * toRational avgWeight)
(arcFrequent', arcFrequentWeight', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent' |- w) arcFrequent arcFrequentWeight arcGhostFrequent (arcFrequent', arcFrequentWeight', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent' |- w) arcFrequent arcFrequentWeight arcGhostFrequent
(arcRecent', arcRecentWeight', arcGhostRecent'') = evictToSize (max arcTargetRecent' $ arcMaximumWeight |- arcFrequentWeight' |- w) arcRecent arcRecentWeight arcGhostRecent' (arcRecent', arcRecentWeight', arcGhostRecent'') = evictToSize (max arcTargetRecent' $ arcMaximumWeight |- arcFrequentWeight' |- w) arcRecent arcRecentWeight arcGhostRecent'
@ -183,7 +186,7 @@ arcAlterF unhashedK@(hashed -> k) f oldARC@ARC{..} now
Nothing -> oldARC Nothing -> oldARC
{ arcGhostFrequent = HashPSQ.insert k now () arcGhostFrequent' { arcGhostFrequent = HashPSQ.insert k now () arcGhostFrequent'
} }
Just x@(_, w) Just !(force -> x@(_, w))
-> let arcTargetRecent' = arcTargetRecent |- max avgWeight (round $ toRational (HashPSQ.size arcGhostRecent) / toRational (HashPSQ.size arcGhostFrequent) * toRational avgWeight) -> let arcTargetRecent' = arcTargetRecent |- max avgWeight (round $ toRational (HashPSQ.size arcGhostRecent) / toRational (HashPSQ.size arcGhostFrequent) * toRational avgWeight)
(arcFrequent', arcFrequentWeight', arcGhostFrequent'') = evictToSize (arcMaximumWeight |- arcTargetRecent' |- w) arcFrequent arcFrequentWeight arcGhostFrequent' (arcFrequent', arcFrequentWeight', arcGhostFrequent'') = evictToSize (arcMaximumWeight |- arcTargetRecent' |- w) arcFrequent arcFrequentWeight arcGhostFrequent'
(arcRecent', arcRecentWeight', arcGhostRecent') = evictToSize (max arcTargetRecent' $ arcMaximumWeight |- arcFrequentWeight' |- w) arcRecent arcRecentWeight arcGhostRecent (arcRecent', arcRecentWeight', arcGhostRecent') = evictToSize (max arcTargetRecent' $ arcMaximumWeight |- arcFrequentWeight' |- w) arcRecent arcRecentWeight arcGhostRecent
@ -200,7 +203,7 @@ arcAlterF unhashedK@(hashed -> k) f oldARC@ARC{..} now
Nothing -> oldARC Nothing -> oldARC
{ arcGhostRecent = HashPSQ.insert k now () $ evictGhostToCount arcGhostRecent { arcGhostRecent = HashPSQ.insert k now () $ evictGhostToCount arcGhostRecent
} }
Just x@(_, w) Just !(force -> x@(_, w))
-> let (arcRecent', arcRecentWeight', arcGhostRecent') = evictToSize (max arcTargetRecent (arcMaximumWeight |- arcFrequentWeight) |- w) arcRecent arcRecentWeight arcGhostRecent -> let (arcRecent', arcRecentWeight', arcGhostRecent') = evictToSize (max arcTargetRecent (arcMaximumWeight |- arcFrequentWeight) |- w) arcRecent arcRecentWeight arcGhostRecent
in oldARC in oldARC
{ arcRecent = HashPSQ.insert k now x arcRecent' { arcRecent = HashPSQ.insert k now x arcRecent'
@ -228,6 +231,7 @@ arcAlterF unhashedK@(hashed -> k) f oldARC@ARC{..} now
lookupARC :: forall k w v. lookupARC :: forall k w v.
( Ord k, Hashable k ( Ord k, Hashable k
, Integral w , Integral w
, NFData k, NFData w, NFData v
) )
=> k => k
-> (ARC k w v, ARCTick) -> (ARC k w v, ARCTick)
@ -237,6 +241,7 @@ lookupARC k = getConst . uncurry (arcAlterF k Const)
insertARC :: forall k w v. insertARC :: forall k w v.
( Ord k, Hashable k ( Ord k, Hashable k
, Integral w , Integral w
, NFData k, NFData w, NFData v
) )
=> k => k
-> Maybe (v, w) -> Maybe (v, w)
@ -272,7 +277,7 @@ cachedARC' :: forall k w v m.
cachedARC' (ARCHandle arcVar) k f = do cachedARC' (ARCHandle arcVar) k f = do
oldVal <- lookupARC k <$> readIORef arcVar oldVal <- lookupARC k <$> readIORef arcVar
newVal <- f oldVal newVal <- f oldVal
modifyIORef' arcVar $ force . uncurry (insertARC k newVal) modifyIORef' arcVar $ uncurry (insertARC k newVal)
-- Using `modifyIORef'` instead of `atomicModifyIORef'` might very -- Using `modifyIORef'` instead of `atomicModifyIORef'` might very
-- well drop newer values computed during the update. -- well drop newer values computed during the update.
-- --
@ -304,6 +309,7 @@ lookupARCHandle :: forall k w v m.
( MonadIO m ( MonadIO m
, Ord k, Hashable k , Ord k, Hashable k
, Integral w , Integral w
, NFData k, NFData w, NFData v
) )
=> ARCHandle k w v => ARCHandle k w v
-> k -> k

View File

@ -100,6 +100,7 @@ instance HasLocalTime TimeOfDay where
newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String } newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
deriving newtype (ToJSON, FromJSON, PersistField, IsString) deriving newtype (ToJSON, FromJSON, PersistField, IsString)
deriving anyclass (NFData)
instance PersistFieldSql DateTimeFormat where instance PersistFieldSql DateTimeFormat where
sqlType _ = sqlType $ Proxy @String sqlType _ = sqlType $ Proxy @String
@ -108,10 +109,7 @@ instance Hashable DateTimeFormat
data SelDateTimeFormat = SelFormatDate | SelFormatTime | SelFormatDateTime data SelDateTimeFormat = SelFormatDate | SelFormatTime | SelFormatDateTime
deriving (Eq, Ord, Read, Show, Enum, Bounded, Data, Generic, Typeable) deriving (Eq, Ord, Read, Show, Enum, Bounded, Data, Generic, Typeable)
deriving anyclass (Universe, Finite, Hashable, NFData)
instance Universe SelDateTimeFormat
instance Finite SelDateTimeFormat
instance Hashable SelDateTimeFormat
nullaryPathPiece ''SelDateTimeFormat $ camelToPathPiece' 2 nullaryPathPiece ''SelDateTimeFormat $ camelToPathPiece' 2
pathPieceJSON ''SelDateTimeFormat pathPieceJSON ''SelDateTimeFormat

View File

@ -98,6 +98,7 @@ data Icon
| IconVideo | IconVideo
| IconSubmissionUserDuplicate | IconSubmissionUserDuplicate
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable) deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
deriving anyclass (Universe, Finite, NFData)
iconText :: Icon -> Text iconText :: Icon -> Text
iconText = \case iconText = \case
@ -175,8 +176,6 @@ iconText = \case
IconVideo -> "video" IconVideo -> "video"
IconSubmissionUserDuplicate -> "copy" IconSubmissionUserDuplicate -> "copy"
instance Universe Icon
instance Finite Icon
nullaryPathPiece ''Icon $ camelToPathPiece' 1 nullaryPathPiece ''Icon $ camelToPathPiece' 1
deriveLift ''Icon deriveLift ''Icon

View File

@ -31,7 +31,7 @@ import Text.HTML.SanitizeXSS (sanitizeBalance)
data MessageStatus = Error | Warning | Info | Success data MessageStatus = Error | Warning | Info | Success
deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift, Generic, Typeable) deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift, Generic, Typeable)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite, NFData)
instance Default MessageStatus where instance Default MessageStatus where
def = Info def = Info

View File

@ -222,6 +222,7 @@ mkI18nWidgetEnum (splitCamel -> namebase) basename = do
, derivClause (Just AnyclassStrategy) , derivClause (Just AnyclassStrategy)
[ conT ''Universe [ conT ''Universe
, conT ''Finite , conT ''Finite
, conT ''NFData
] ]
] ]
, instanceD (cxt []) (conT ''PathPiece `appT` conT dataName) , instanceD (cxt []) (conT ''PathPiece `appT` conT dataName)