diff --git a/models b/models deleted file mode 100644 index 47e95f579..000000000 --- a/models +++ /dev/null @@ -1,262 +0,0 @@ -User json - ident (CI Text) - authentication AuthenticationMode - matrikelnummer Text Maybe - email (CI Text) - displayName Text - surname Text -- always use: nameWidget displayName surname - maxFavourites Int default=12 - theme Theme default='Default' - dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" - dateFormat DateTimeFormat "default='%d.%m.%Y'" - timeFormat DateTimeFormat "default='%R'" - downloadFiles Bool default=false - mailLanguages MailLanguages default='[]' - notificationSettings NotificationSettings - UniqueAuthentication ident - UniqueEmail email - deriving Show Eq -UserAdmin - user UserId - school SchoolId - UniqueUserAdmin user school -UserLecturer - user UserId - school SchoolId - UniqueSchoolLecturer user school -StudyFeatures - user UserId - degree StudyDegreeId - field StudyTermsId - type StudyFieldType - semester Int - -- UniqueUserSubject user degree field -- There exists a counterexample -StudyDegree - key Int - shorthand Text Maybe - name Text Maybe - Primary key -StudyTerms - key Int - shorthand Text Maybe - name Text Maybe - Primary key -Term json - name TermIdentifier -- unTermKey :: TermId -> TermIdentifier - start Day -- TermKey :: TermIdentifier -> TermId - end Day - holidays [Day] - lectureStart Day - lectureEnd Day - active Bool - Primary name -- newtype Key Term = TermKey { unTermKey :: TermIdentifier } - deriving Show -- type TermId = Key Term -School json - name (CI Text) - shorthand (CI Text) - UniqueSchool name - UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text - Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand } - deriving Eq -DegreeCourse json - course CourseId - degree StudyDegreeId - terms StudyTermsId - UniqueDegreeCourse course degree terms -Course - name (CI Text) - description Html Maybe - linkExternal Text Maybe - shorthand (CI Text) - term TermId - school SchoolId - capacity Int64 Maybe - -- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo - registerFrom UTCTime Maybe - registerTo UTCTime Maybe - deregisterUntil UTCTime Maybe - registerSecret Text Maybe -- Falls ein Passwort erforderlich ist - materialFree Bool - TermSchoolCourseShort term school shorthand - TermSchoolCourseName term school name -CourseEdit - user UserId - time UTCTime - course CourseId -CourseFavourite - user UserId - time UTCTime - course CourseId - UniqueCourseFavourite user course - deriving Show -Lecturer - user UserId - course CourseId - UniqueLecturer user course -CourseParticipant - course CourseId - user UserId - registration UTCTime - UniqueParticipant user course -Sheet - course CourseId - name (CI Text) - description Html Maybe - type SheetType - grouping SheetGroup - markingText Html Maybe - visibleFrom UTCTime Maybe - activeFrom UTCTime - activeTo UTCTime - hintFrom UTCTime Maybe - solutionFrom UTCTime Maybe - uploadMode UploadMode - submissionMode SheetSubmissionMode default='UserSubmissions' - CourseSheet course name -SheetEdit - user UserId - time UTCTime - sheet SheetId -SheetPseudonym - sheet SheetId - pseudonym Pseudonym - user UserId - UniqueSheetPseudonym sheet pseudonym - UniqueSheetPseudonymUser sheet user -SheetCorrector - user UserId - sheet SheetId - load Load - state CorrectorState default='CorrectorNormal' - UniqueSheetCorrector user sheet - deriving Show Eq Ord -SheetFile - sheet SheetId - file FileId - type SheetFileType - UniqueSheetFile file sheet type -File - title FilePath - content ByteString Maybe -- Nothing iff this is a directory - modified UTCTime - deriving Show Eq Generic -Submission - sheet SheetId - ratingPoints Points Maybe -- "Just" does not mean done - ratingComment Text Maybe -- "Just" does not mean done - ratingBy UserId Maybe -- assigned corrector - ratingAssigned UTCTime Maybe -- time assigned corrector - ratingTime UTCTime Maybe -- "Just" here indicates done! - deriving Show -SubmissionEdit - user UserId - time UTCTime - submission SubmissionId -SubmissionFile - submission SubmissionId - file FileId - 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 file submission isUpdate - deriving Show -SubmissionUser -- Actual submission participant - user UserId - submission SubmissionId - UniqueSubmissionUser user submission -SubmissionGroup - course CourseId - name Text Maybe -SubmissionGroupEdit - user UserId - time UTCTime - submissionGroup SubmissionGroupId -SubmissionGroupUser -- Registered submission groups, independent of actual SubmissionUser - submissionGroup SubmissionGroupId - user UserId - UniqueSubmissionGroupUser submissionGroup user -Tutorial json - name Text - tutor UserId - course CourseId -TutorialUser - user UserId - tutorial TutorialId - UniqueTutorialUser user tutorial -Booking - term TermId - begin UTCTime - end UTCTime - weekly Bool - exceptions [Day] -- only if weekly, begin in exception - bookedFor RoomForId - room RoomId -BookingEdit - user UserId - time UTCTime - boooking BookingId -Room - name Text - capacity Int Maybe - building Text Maybe --- BookingRoom --- subject RoomForId --- room RoomId --- booking BookingId --- UniqueRoomCourse subject room booking -+RoomFor - course CourseId - tutorial TutorialId - exam ExamId --- data RoomFor = RoomForCourseSum CourseId | RoomForTutorialSum TutorialId ... --- EXAMS ARE TODO: -Exam - course CourseId - name Text - description Text - begin UTCTime - end UTCTime - registrationBegin UTCTime - registrationEnd UTCTime - deregistrationEnd UTCTime - ratingVisible Bool - statisticsVisible Bool ---ExamEdit --- user UserId --- time UTCTime --- exam ExamId ---ExamUser --- user UserId --- examId ExamId --- -- CONTINUE HERE: Include rating in this table or separately? --- UniqueExamUser user examId --- By default this file is used in Model.hs (which is imported by Foundation.hs) -QueuedJob - content Value - creationInstance InstanceId - creationTime UTCTime - lockInstance InstanceId Maybe - lockTime UTCTime Maybe - deriving Eq Read Show Generic Typeable -CronLastExec - job Value - time UTCTime - instance InstanceId - UniqueCronLastExec job -SystemMessage - from UTCTime Maybe - to UTCTime Maybe - authenticatedOnly Bool - severity MessageClass - defaultLanguage Lang - content Html - summary Html Maybe -SystemMessageTranslation - message SystemMessageId - language Lang - content Html - summary Html Maybe - UniqueSystemMessageTranslation message language -ClusterConfig - setting ClusterSettingsKey - value Value - Primary setting \ No newline at end of file diff --git a/models/config b/models/config new file mode 100644 index 000000000..33bcaf8d6 --- /dev/null +++ b/models/config @@ -0,0 +1,4 @@ +ClusterConfig + setting ClusterSettingsKey + value Value + Primary setting \ No newline at end of file diff --git a/models/courses b/models/courses new file mode 100644 index 000000000..9ecc31abe --- /dev/null +++ b/models/courses @@ -0,0 +1,40 @@ +DegreeCourse json + course CourseId + degree StudyDegreeId + terms StudyTermsId + UniqueDegreeCourse course degree terms +Course + name (CI Text) + description Html Maybe + linkExternal Text Maybe + shorthand (CI Text) + term TermId + school SchoolId + capacity Int64 Maybe + -- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo + registerFrom UTCTime Maybe + registerTo UTCTime Maybe + deregisterUntil UTCTime Maybe + registerSecret Text Maybe -- Falls ein Passwort erforderlich ist + materialFree Bool + TermSchoolCourseShort term school shorthand + TermSchoolCourseName term school name +CourseEdit + user UserId + time UTCTime + course CourseId +CourseFavourite + user UserId + time UTCTime + course CourseId + UniqueCourseFavourite user course + deriving Show +Lecturer + user UserId + course CourseId + UniqueLecturer user course +CourseParticipant + course CourseId + user UserId + registration UTCTime + UniqueParticipant user course diff --git a/models/exams b/models/exams new file mode 100644 index 000000000..e356e4221 --- /dev/null +++ b/models/exams @@ -0,0 +1,22 @@ +-- EXAMS ARE TODO: +Exam + course CourseId + name Text + description Text + begin UTCTime + end UTCTime + registrationBegin UTCTime + registrationEnd UTCTime + deregistrationEnd UTCTime + ratingVisible Bool + statisticsVisible Bool +--ExamEdit +-- user UserId +-- time UTCTime +-- exam ExamId +--ExamUser +-- user UserId +-- examId ExamId +-- -- CONTINUE HERE: Include rating in this table or separately? +-- UniqueExamUser user examId +-- By default this file is used in Model.hs (which is imported by Foundation.hs) \ No newline at end of file diff --git a/models/files b/models/files new file mode 100644 index 000000000..62a5ffe72 --- /dev/null +++ b/models/files @@ -0,0 +1,5 @@ +File + title FilePath + content ByteString Maybe -- Nothing iff this is a directory + modified UTCTime + deriving Show Eq Generic diff --git a/models/jobs b/models/jobs new file mode 100644 index 000000000..15f7bb7dc --- /dev/null +++ b/models/jobs @@ -0,0 +1,12 @@ +QueuedJob + content Value + creationInstance InstanceId + creationTime UTCTime + lockInstance InstanceId Maybe + lockTime UTCTime Maybe + deriving Eq Read Show Generic Typeable +CronLastExec + job Value + time UTCTime + instance InstanceId + UniqueCronLastExec job diff --git a/models/rooms b/models/rooms new file mode 100644 index 000000000..7b62d41f5 --- /dev/null +++ b/models/rooms @@ -0,0 +1,26 @@ +Booking + term TermId + begin UTCTime + end UTCTime + weekly Bool + exceptions [Day] -- only if weekly, begin in exception + bookedFor RoomForId + room RoomId +BookingEdit + user UserId + time UTCTime + boooking BookingId +Room + name Text + capacity Int Maybe + building Text Maybe +-- BookingRoom +-- subject RoomForId +-- room RoomId +-- booking BookingId +-- UniqueRoomCourse subject room booking ++RoomFor + course CourseId + tutorial TutorialId + exam ExamId +-- data RoomFor = RoomForCourseSum CourseId | RoomForTutorialSum TutorialId ... diff --git a/models/schools b/models/schools new file mode 100644 index 000000000..b253c7390 --- /dev/null +++ b/models/schools @@ -0,0 +1,7 @@ +School json + name (CI Text) + shorthand (CI Text) + UniqueSchool name + UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text + Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand } + deriving Eq diff --git a/models/sheets b/models/sheets new file mode 100644 index 000000000..e6e7c1051 --- /dev/null +++ b/models/sheets @@ -0,0 +1,37 @@ +Sheet + course CourseId + name (CI Text) + description Html Maybe + type SheetType + grouping SheetGroup + markingText Html Maybe + visibleFrom UTCTime Maybe + activeFrom UTCTime + activeTo UTCTime + hintFrom UTCTime Maybe + solutionFrom UTCTime Maybe + uploadMode UploadMode + submissionMode SheetSubmissionMode default='UserSubmissions' + CourseSheet course name +SheetEdit + user UserId + time UTCTime + sheet SheetId +SheetPseudonym + sheet SheetId + pseudonym Pseudonym + user UserId + UniqueSheetPseudonym sheet pseudonym + UniqueSheetPseudonymUser sheet user +SheetCorrector + user UserId + sheet SheetId + load Load + state CorrectorState default='CorrectorNormal' + UniqueSheetCorrector user sheet + deriving Show Eq Ord +SheetFile + sheet SheetId + file FileId + type SheetFileType + UniqueSheetFile file sheet type diff --git a/models/submissions b/models/submissions new file mode 100644 index 000000000..db7e543a6 --- /dev/null +++ b/models/submissions @@ -0,0 +1,34 @@ +Submission + sheet SheetId + ratingPoints Points Maybe -- "Just" does not mean done + ratingComment Text Maybe -- "Just" does not mean done + ratingBy UserId Maybe -- assigned corrector + ratingAssigned UTCTime Maybe -- time assigned corrector + ratingTime UTCTime Maybe -- "Just" here indicates done! + deriving Show +SubmissionEdit + user UserId + time UTCTime + submission SubmissionId +SubmissionFile + submission SubmissionId + file FileId + 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 file submission isUpdate + deriving Show +SubmissionUser -- Actual submission participant + user UserId + submission SubmissionId + UniqueSubmissionUser user submission +SubmissionGroup + course CourseId + name Text Maybe +SubmissionGroupEdit + user UserId + time UTCTime + submissionGroup SubmissionGroupId +SubmissionGroupUser -- Registered submission groups, independent of actual SubmissionUser + submissionGroup SubmissionGroupId + user UserId + UniqueSubmissionGroupUser submissionGroup user diff --git a/models/system-messages b/models/system-messages new file mode 100644 index 000000000..0547718ae --- /dev/null +++ b/models/system-messages @@ -0,0 +1,14 @@ +SystemMessage + from UTCTime Maybe + to UTCTime Maybe + authenticatedOnly Bool + severity MessageClass + defaultLanguage Lang + content Html + summary Html Maybe +SystemMessageTranslation + message SystemMessageId + language Lang + content Html + summary Html Maybe + UniqueSystemMessageTranslation message language diff --git a/models/terms b/models/terms new file mode 100644 index 000000000..ba6cafd73 --- /dev/null +++ b/models/terms @@ -0,0 +1,10 @@ +Term json + name TermIdentifier -- unTermKey :: TermId -> TermIdentifier + start Day -- TermKey :: TermIdentifier -> TermId + end Day + holidays [Day] + lectureStart Day + lectureEnd Day + active Bool + Primary name -- newtype Key Term = TermKey { unTermKey :: TermIdentifier } + deriving Show -- type TermId = Key Term diff --git a/models/tutorials b/models/tutorials new file mode 100644 index 000000000..51e20b195 --- /dev/null +++ b/models/tutorials @@ -0,0 +1,8 @@ +Tutorial json + name Text + tutor UserId + course CourseId +TutorialUser + user UserId + tutorial TutorialId + UniqueTutorialUser user tutorial diff --git a/models/users b/models/users new file mode 100644 index 000000000..0cd2d682a --- /dev/null +++ b/models/users @@ -0,0 +1,43 @@ +User json + ident (CI Text) + authentication AuthenticationMode + matrikelnummer Text Maybe + email (CI Text) + displayName Text + surname Text -- always use: nameWidget displayName surname + maxFavourites Int default=12 + theme Theme default='Default' + dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" + dateFormat DateTimeFormat "default='%d.%m.%Y'" + timeFormat DateTimeFormat "default='%R'" + downloadFiles Bool default=false + mailLanguages MailLanguages default='[]' + notificationSettings NotificationSettings + UniqueAuthentication ident + UniqueEmail email + deriving Show Eq +UserAdmin + user UserId + school SchoolId + UniqueUserAdmin user school +UserLecturer + user UserId + school SchoolId + UniqueSchoolLecturer user school +StudyFeatures + user UserId + degree StudyDegreeId + field StudyTermsId + type StudyFieldType + semester Int + -- UniqueUserSubject user degree field -- There exists a counterexample +StudyDegree + key Int + shorthand Text Maybe + name Text Maybe + Primary key +StudyTerms + key Int + shorthand Text Maybe + name Text Maybe + Primary key diff --git a/package.yaml b/package.yaml index e480feb22..1bd402afd 100644 --- a/package.yaml +++ b/package.yaml @@ -112,6 +112,7 @@ dependencies: - text-metrics - pkcs7 - memcached-binary + - directory-tree other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Database/Persist/TH/Directory.hs b/src/Database/Persist/TH/Directory.hs new file mode 100644 index 000000000..770b71d71 --- /dev/null +++ b/src/Database/Persist/TH/Directory.hs @@ -0,0 +1,27 @@ +module Database.Persist.TH.Directory + ( persistDirectoryWith + ) where + +import ClassyPrelude hiding (mapM_, toList) + +import Database.Persist.TH (parseReferences) +import Database.Persist.Quasi (PersistSettings) +import Language.Haskell.TH.Syntax + +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import qualified System.IO as SIO + +import qualified System.Directory.Tree as DirTree + +import Data.Foldable (Foldable(..), mapM_) + +persistDirectoryWith :: PersistSettings -> FilePath -> Q Exp +persistDirectoryWith settings dir = do + files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> do + h <- SIO.openFile fp SIO.ReadMode + SIO.hSetEncoding h SIO.utf8_bom + Text.hGetContents h + mapM_ (qAddDependentFile . fst) $ DirTree.zipPaths files + + parseReferences settings . Text.intercalate "\n" . toList $ DirTree.dirTree files diff --git a/src/Model.hs b/src/Model.hs index 91de5c48c..417c551fb 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -8,6 +8,7 @@ module Model import ClassyPrelude.Yesod import Database.Persist.Quasi +import Database.Persist.TH.Directory -- import Data.Time -- import Data.ByteString import Model.Types @@ -26,7 +27,7 @@ import Settings.Cluster (ClusterSettingsKey) -- at: -- http://www.yesodweb.com/book/persistent/ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'", mkSave "currentModel"] - $(persistFileWith lowerCaseSettings "models") + $(persistDirectoryWith lowerCaseSettings "models") -- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only deriving instance Eq (Unique Course)