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

refactor: be more explicit about ARC strictness

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
models/allocations.model
View File

@ -31,6 +31,7 @@ AllocationMatching
fingerprint AllocationFingerprint
time UTCTime
log FileContentReference
deriving Generic
AllocationCourse
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
acceptSubstitutes UTCTime Maybe
UniqueAllocationCourse course
deriving Generic
AllocationUser
allocation AllocationId
@ -45,17 +47,18 @@ AllocationUser
totalCourses Word64 -- number of total allocated courses for this user must be <= than this number
priority AllocationPriority Maybe
UniqueAllocationUser allocation user
deriving Eq Ord Show
deriving Eq Ord Show Generic
AllocationDeregister -- self-inflicted user-deregistrations from an allocated course
user UserId
course CourseId Maybe
time UTCTime
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
user UserId
allocation AllocationId
isOptOut Bool
UniqueAllocationNotificationSetting user allocation
UniqueAllocationNotificationSetting user allocation
deriving Generic

2
models/audit.model
View File

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

1
models/changelog.model
View File

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

3
models/config.model
View File

@ -3,4 +3,5 @@
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, ...
value Value -- JSON-encoded value
Primary setting
Primary setting
deriving Generic

10
models/courses.model
View File

@ -3,6 +3,7 @@ DegreeCourse json -- for which degree programmes this course is appropriate fo
degree StudyDegreeId
terms StudyTermsId
UniqueDegreeCourse course degree terms
deriving Generic
Course -- Information about a single course; contained info is always visible to all users
name (CI Text)
description StoredMarkup Maybe -- user-defined large Html, ought to contain module description
@ -36,6 +37,7 @@ CourseEvent
time Occurrences
note StoredMarkup Maybe
lastChanged UTCTime default=now()
deriving Generic
CourseAppInstructionFile
course CourseId
@ -43,16 +45,19 @@ CourseAppInstructionFile
content FileContentReference Maybe
modified UTCTime
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)
user UserId
time UTCTime
course CourseId
deriving Generic
Lecturer -- course ownership
user UserId
course CourseId
type LecturerType default='"lecturer"'::jsonb
UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table
deriving Generic
CourseParticipant -- course enrolement
course CourseId
user UserId
@ -61,7 +66,7 @@ CourseParticipant -- course enrolement
allocated AllocationId Maybe -- participant was centrally allocated
state CourseParticipantState
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
-- CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student
-- course CourseId
@ -75,13 +80,16 @@ CourseUserNote -- lecturers of a specific course may share a tex
user UserId
note StoredMarkup -- arbitrary user-defined text; visible only to lecturer of this course
UniqueCourseUserNote user course
deriving Generic
CourseUserNoteEdit -- who edited a participants course note when
user UserId
time UTCTime
note CourseUserNoteId -- PROBLEM: deleted notes have no modification date any more
deriving Generic
CourseUserExamOfficeOptOut
course CourseId
user UserId
school SchoolId
UniqueCourseUserExamOfficeOptOut course user school
deriving Generic

2
models/courses/applications.model
View File

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

4
models/courses/favourite.model
View File

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

3
models/courses/materials.model
View File

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

4
models/courses/news.model
View File

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

6
models/exam-office.model
View File

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

15
models/exams.model
View File

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

7
models/external-exams.model
View File

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

8
models/files.model
View File

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

3
models/invitations.model
View File

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

6
models/jobs.model
View File

@ -6,7 +6,7 @@ QueuedJob
lockInstance InstanceId Maybe -- instance that has started to execute this job
lockTime UTCTime Maybe -- time when execution had begun
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@
-- 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
instance InstanceId -- Which uni2work-instance did the work
UniqueCronLastExec job
deriving Generic
TokenBucket
ident TokenBucketIdent
lastValue Int64
lastAccess UTCTime
Primary ident
Primary ident
deriving Generic

4
models/mail.model
View File

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

4
models/schools.model
View File

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

10
models/sheets.model
View File

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

14
models/study-features.model
View File

@ -10,13 +10,14 @@ StudyFeatures -- multiple entries possible for students pursuing several degree
valid Bool default=true
relevanceCached UUID Maybe
UniqueStudyFeatures user degree field type semester
deriving Eq Show
deriving Eq Show Generic
-- UniqueUserSubject ubuser degree field -- There exists a counterexample
RelevantStudyFeatures
term TermId
studyFeatures StudyFeaturesId
UniqueRelevantStudyFeatures term studyFeatures
deriving Generic
StudyDegree -- Studienabschluss
key Int -- LMU-internal key
@ -24,7 +25,7 @@ StudyDegree -- Studienabschluss
name Text Maybe -- description given by LDAP
Primary key -- column key is used as actual DB row key
-- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int }
deriving Eq Show
deriving Eq Show Generic
StudyTerms -- Studiengang
key Int -- standardised key
shorthand Text Maybe -- admin determined shorthand
@ -33,11 +34,12 @@ StudyTerms -- Studiengang
defaultType StudyFieldType Maybe
Primary key -- column key is used as actual DB row key
-- newtype Key StudyTerms = StudyTermsKey' { unStudyTermsKey :: Int }
deriving Eq Ord Show
deriving Eq Ord Show Generic
StudySubTerms
child StudyTermsId
parent StudyTermsId
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.
-- 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.
@ -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
key Int -- a possible key for the studyTermName or studySubTermName
name Text -- studyTermName as plain text from LDAP
deriving Show Eq Ord
deriving Show Eq Ord Generic
StudySubTermParentCandidate
incidence TermCandidateIncidence
key Int
parent Int
deriving Show Eq Ord
deriving Show Eq Ord Generic
StudyTermStandaloneCandidate
incidence TermCandidateIncidence
key Int
deriving Show Eq Ord
deriving Show Eq Ord Generic

7
models/submissions.model
View File

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

5
models/system-messages.model
View File

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

4
models/tutorials.model
View File

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

6
models/users.model
View File

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

7
models/workflows.model
View File

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

3
src/Database/Persist/Class/Instances.hs
View File

@ -30,9 +30,6 @@ instance PersistEntity record => Binary (Key record) where
putList = Binary.putList . map toPersistValue
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 = fmap Map.fromList $ zip <$> persistUniqueToFieldNames <*> persistUniqueToValues

3
src/Database/Persist/Types/Instances.hs
View File

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

4
src/Model.hs
View File

@ -33,7 +33,7 @@ type SqlBackendKey = BackendKey SqlBackend
-- You can find more information on persistent and how to declare entities
-- at:
-- 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")
@ -51,8 +51,6 @@ deriving newtype instance FromJSONKey ExamOccurrenceId
deriving instance Show (Unique ExamPart)
deriving anyclass instance NFData ExamPart
-- ToMarkup and ToMessage instances for displaying selected database primary keys
instance ToMarkup (Key School) where

6
src/Model/Types/Allocation.hs
View File

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

6
src/Model/Types/Course.hs
View File

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

6
src/Model/Types/DateTime.hs
View File

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

36
src/Model/Types/Exam.hs
View File

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

20
src/Model/Types/File.hs
View File

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

9
src/Model/Types/Mail.hs
View File

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

6
src/Model/Types/Markup.hs
View File

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

14
src/Model/Types/Misc.hs
View File

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

1
src/Model/Types/Room.hs
View File

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

5
src/Model/Types/School.hs
View File

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

2
src/Model/Types/Security.hs
View File

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

18
src/Model/Types/Sheet.hs
View File

@ -168,7 +168,8 @@ data SheetGroup
= Arbitrary { maxParticipants :: Natural }
| RegisteredGroups
| NoGroups
deriving (Show, Read, Eq, Generic)
deriving (Show, Read, Eq, Generic, Typeable)
deriving anyclass (NFData)
deriveJSON defaultOptions ''SheetGroup
derivePersistFieldJSON ''SheetGroup
@ -200,7 +201,9 @@ data UploadSpecificFile = UploadSpecificFile
, specificFileRequired :: Bool
, specificFileEmptyOk :: Bool
, specificFileMaxSize :: Maybe Natural
} deriving (Show, Read, Eq, Ord, Generic)
}
deriving (Show, Read, Eq, Ord, Generic, Typeable)
deriving anyclass (NFData)
instance ToJSON UploadSpecificFile where
toJSON UploadSpecificFile{..} = Aeson.object
@ -229,7 +232,8 @@ data UploadMode = NoUpload
| UploadSpecific
{ 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 = fromNullable $ Set.fromList ["txt", "pdf"]
@ -284,7 +288,8 @@ data SubmissionMode = SubmissionMode
{ submissionModeCorrector :: Bool
, submissionModeUser :: Maybe UploadMode
}
deriving (Show, Read, Eq, Ord, Generic)
deriving (Show, Read, Eq, Ord, Generic, Typeable)
deriving anyclass (NFData)
deriveJSON defaultOptions
{ 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
}
deriving (Show, Read, Eq, Ord, Generic)
deriving anyclass (Hashable, NFData)
deriveJSON defaultOptions ''Load
derivePersistFieldJSON ''Load
instance Hashable Load
instance Semigroup Load where
(Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')
where
@ -346,7 +350,7 @@ instance Monoid Load where
data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
deriving anyclass (Universe, Finite, Hashable)
deriving anyclass (Universe, Finite, Hashable, NFData)
deriveJSON defaultOptions
{ constructorTagModifier = fromJust . stripPrefix "Corrector"

1
src/Model/Types/Submission.hs
View File

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

69
src/Model/Types/Workflow.hs
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 (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 anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraph fileid userid)
newtype WorkflowGraphReference = WorkflowGraphReference (Digest SHA3_256)
deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
deriving newtype ( PersistField
, PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
, Hashable, NFData
, ByteArrayAccess
, Binary
)
deriving anyclass (Hashable, NFData)
instance PersistFieldSql WorkflowGraphReference where
sqlType _ = sqlType $ Proxy @(Digest SHA3_256)
@ -96,6 +97,7 @@ instance PersistFieldSql WorkflowGraphReference where
newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLabel :: CI Text }
deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable)
deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary)
deriving anyclass (NFData)
instance PersistFieldSql WorkflowGraphNodeLabel where
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 (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 anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraphNode fileid userid)
data WorkflowNodeView userid = WorkflowNodeView
{ wnvViewers :: NonNull (Set (WorkflowRole userid))
, 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
{ wnmViewers :: NonNull (Set (WorkflowRole userid))
, wnmRestriction :: Maybe (PredDNF WorkflowGraphRestriction)
, wnmStatus :: MessageStatus
, wnmContent :: I18nHtml
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
}
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
----- WORKFLOW GRAPH: EDGES -----
newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel { unWorkflowGraphEdgeLabel :: CI Text }
deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable)
deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary)
deriving anyclass (NFData)
instance PersistFieldSql WorkflowGraphEdgeLabel where
sqlType _ = sqlType $ Proxy @(CI Text)
@ -139,6 +147,7 @@ data WorkflowGraphRestriction
| WorkflowGraphRestrictionPreviousNode { wgrPreviousNode :: WorkflowGraphNodeLabel }
| WorkflowGraphRestrictionInitial
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
data WorkflowGraphEdge fileid userid
= 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 (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 anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraphEdge fileid userid)
data WorkflowEdgeMessage userid = WorkflowEdgeMessage
{ wemViewers :: NonNull (Set (WorkflowRole userid))
, wemRestriction :: Maybe (PredDNF WorkflowGraphRestriction)
, wemStatus :: MessageStatus
, wemContent :: I18nHtml
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
}
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (NFData)
-- | A wrapped `Scientific`
--
@ -180,6 +192,7 @@ newtype WorkflowGraphEdgeFormOrder = WorkflowGraphEdgeFormOrder { unWorkflowGrap
deriving (Read, Show, Generic, Typeable)
deriving (Eq, Ord) via (NTop (Maybe Scientific))
deriving (Semigroup, Monoid) via (Maybe (Min Scientific))
deriving anyclass (NFData)
newtype WorkflowGraphEdgeForm fileid userid
= WorkflowGraphEdgeForm
@ -191,11 +204,13 @@ newtype WorkflowGraphEdgeForm fileid userid
-- - optional fields are always considered to be filled
--
-- 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 (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 anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraphEdgeForm fileid userid)
----- WORKFLOW GRAPH: ROLES / ACTORS -----
@ -213,16 +228,21 @@ data WorkflowRole userid
data WorkflowPayloadView userid = WorkflowPayloadView
{ wpvViewers :: NonNull (Set (WorkflowRole userid))
, 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)
deriving (Typeable)
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
deriving (Typeable)
-- Don't forget to update the NFData instance for every change!
data WorkflowPayloadField fileid userid (payload :: Type) where
WorkflowPayloadFieldText :: { wpftLabel :: I18nText
, wpftPlaceholder :: Maybe I18nText
@ -325,6 +345,18 @@ instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileFie
(WorkflowPayloadFieldReference{}, _) -> LT
(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.
( Typeable payload, Typeable fileid, Typeable userid )
=> 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'
deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable)
deriving anyclass (Universe, Finite)
deriving anyclass (Universe, Finite, NFData)
----- WORKFLOW INSTANCE -----
@ -349,7 +381,7 @@ data WorkflowScope termid schoolid courseid
data WorkflowScope'
= WSGlobal' | WSTerm' | WSSchool' | WSTermSchool' | WSCourse'
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 = \case
@ -372,6 +404,7 @@ instance PersistFieldSql WorkflowPayloadLabel where
newtype WorkflowStateIndex = WorkflowStateIndex { unWorkflowStateIndex :: Word64 }
deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable)
deriving newtype (Num, Real, Integral, Enum, Bounded, ToJSON, FromJSON, PathPiece, Binary)
deriving anyclass (NFData)
type WorkflowState fileid userid = NonNull (Seq (WorkflowAction fileid userid))
@ -395,13 +428,16 @@ data WorkflowAction fileid userid = WorkflowAction
, wpTime :: UTCTime
}
deriving (Eq, Ord, Show, Generic, Typeable)
deriving anyclass (NFData)
data WorkflowActionInfo fileid userid = WorkflowActionInfo
{ waiIx :: WorkflowStateIndex
, waiFrom :: Maybe WorkflowGraphNodeLabel
, waiHistory :: [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 wState
@ -416,6 +452,9 @@ workflowActionInfos wState
data WorkflowFieldPayloadW fileid userid = forall payload. IsWorkflowFieldPayload' fileid userid payload => WorkflowFieldPayloadW (WorkflowFieldPayload fileid userid payload)
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
(WorkflowFieldPayloadW a) == (WorkflowFieldPayloadW b)
= 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
show (WorkflowFieldPayloadW payload) = show payload
-- Don't forget to update the NFData instance for every change!
data WorkflowFieldPayload fileid userid (payload :: Type) where
WFPText :: Text -> WorkflowFieldPayload fileid userid Text
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, 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.
( IsWorkflowFieldPayload' fileid userid payload, Typeable fileid, Typeable userid )
=> Prism' (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayload fileid userid payload)
@ -496,7 +545,7 @@ _WorkflowFieldPayloadW = prism' WorkflowFieldPayloadW $ \(WorkflowFieldPayloadW
data WorkflowFieldPayload' = WFPText' | WFPNumber' | WFPBool' | WFPDay' | WFPFile' | WFPUser'
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

12
src/Network/Mail/Mime/Instances.hs
View File

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

13
src/Settings/Cluster.hs
View File

@ -7,7 +7,6 @@ module Settings.Cluster
) where
import ClassyPrelude.Yesod
import Web.HttpApiData
import Data.Kind (Type)
@ -51,21 +50,15 @@ data ClusterSettingsKey
| ClusterMemcachedKey
| ClusterVerpSecret
| ClusterAuthKey
deriving (Eq, Ord, Enum, Bounded, Show, Read)
instance Universe ClusterSettingsKey
instance Finite ClusterSettingsKey
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
deriving anyclass (Universe, Finite, NFData)
nullaryPathPiece ''ClusterSettingsKey $ camelToPathPiece' 1
pathPieceJSON ''ClusterSettingsKey
pathPieceJSONKey ''ClusterSettingsKey
pathPieceHttpApiData ''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
type ClusterSettingValue key :: Type

20
src/Utils/ARC.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE BangPatterns #-}
module Utils.ARC
( ARCTick
, ARC, initARC
@ -133,17 +135,18 @@ arcAlterF :: forall f k w v.
( Ord k, Hashable k
, Functor f
, Integral w
, NFData k, NFData w, NFData v
)
=> k
-> (Maybe (v, w) -> f (Maybe (v, w)))
-> ARC k w v
-> ARCTick -> f (ARC k w v, ARCTick)
-- | 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
| otherwise = (, later) <$> if
| 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
in oldARC
{ arcFrequent = HashPSQ.insert k now x' arcFrequent''
@ -151,7 +154,7 @@ arcAlterF unhashedK@(hashed -> k) f oldARC@ARC{..} now
, arcGhostFrequent = arcGhostFrequent'
}
| 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
in oldARC
{ arcRecent = arcRecent'
@ -165,7 +168,7 @@ arcAlterF unhashedK@(hashed -> k) f oldARC@ARC{..} now
Nothing -> oldARC
{ 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)
(arcFrequent', arcFrequentWeight', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent' |- w) arcFrequent arcFrequentWeight arcGhostFrequent
(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
{ 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)
(arcFrequent', arcFrequentWeight', arcGhostFrequent'') = evictToSize (arcMaximumWeight |- arcTargetRecent' |- w) arcFrequent arcFrequentWeight arcGhostFrequent'
(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
{ 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
in oldARC
{ arcRecent = HashPSQ.insert k now x arcRecent'
@ -228,6 +231,7 @@ arcAlterF unhashedK@(hashed -> k) f oldARC@ARC{..} now
lookupARC :: forall k w v.
( Ord k, Hashable k
, Integral w
, NFData k, NFData w, NFData v
)
=> k
-> (ARC k w v, ARCTick)
@ -237,6 +241,7 @@ lookupARC k = getConst . uncurry (arcAlterF k Const)
insertARC :: forall k w v.
( Ord k, Hashable k
, Integral w
, NFData k, NFData w, NFData v
)
=> k
-> Maybe (v, w)
@ -272,7 +277,7 @@ cachedARC' :: forall k w v m.
cachedARC' (ARCHandle arcVar) k f = do
oldVal <- lookupARC k <$> readIORef arcVar
newVal <- f oldVal
modifyIORef' arcVar $ force . uncurry (insertARC k newVal)
modifyIORef' arcVar $ uncurry (insertARC k newVal)
-- Using `modifyIORef'` instead of `atomicModifyIORef'` might very
-- well drop newer values computed during the update.
--
@ -304,6 +309,7 @@ lookupARCHandle :: forall k w v m.
( MonadIO m
, Ord k, Hashable k
, Integral w
, NFData k, NFData w, NFData v
)
=> ARCHandle k w v
-> k

6
src/Utils/DateTime.hs
View File

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

3
src/Utils/Icon.hs
View File

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

2
src/Utils/Message.hs
View File

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

1
src/Utils/TH.hs
View File

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