diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 4e5ddb679..602641b4e 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -74,6 +74,8 @@ CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein CourseFilterSearch: Volltext-Suche CourseFilterRegistered: Registriert +CourseDeleteQuestion: Wollen Sie den unten aufgeführten Kurs wirklich löschen? +CourseDeleted: Kurs gelöscht NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht. NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht. @@ -89,10 +91,12 @@ SheetTitleNew tid@TermId ssh@SchoolId csh@CourseShorthand SheetEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} editieren SheetEditOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{csh} wurde gespeichert. SheetNameDup tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh}. -SheetDelHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen? -SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben. +SheetDelHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen? Alle assoziierten Abgaben und Korrekturen gehen ebenfalls verloren! SheetDelOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht. +SheetDeleteQuestion: Wollen Sie das unten aufgeführte Übungsblatt und alle zugehörigen Abgaben wirklich löschen? +SheetDeleted: Übungsblatt gelöscht + SheetUploadMode: Abgabe von Dateien SheetSubmissionMode: Abgabe-Modus SheetExercise: Aufgabenstellung @@ -140,6 +144,9 @@ SubmissionFile: Datei zur Abgabe SubmissionFiles: Abgegebene Dateien SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt. +SubmissionsDeleteQuestion count@Int: Wollen Sie #{pluralDE count "die unten aufgeführte Abgabe" "die unten aufgeführten Abgaben"} wirklich löschen? +SubmissionsDeleted count@Int: #{pluralDE count "Abgabe gelöscht" "Abgaben gelöscht"} + SubmissionGroupName: Gruppenname CorrectionsTitle: Zugewiesene Korrekturen @@ -533,6 +540,7 @@ MenuLogout: Logout MenuCourseList: Kurse MenuTermShow: Semester MenuCorrection: Korrektur +MenuSubmissionDelete: Abgabe löschen MenuUsers: Benutzer MenuAdminTest: Admin-Demo MenuMessageList: Systemnachrichten @@ -546,17 +554,19 @@ MenuCorrections: Abgaben MenuSheetNew: Neues Übungsblatt anlegen MenuCourseEdit: Kurs editieren MenuCourseNewTemplate: Als neuen Kurs klonen +MenuCourseDelete: Kurs löschen MenuSubmissionNew: Abgabe anlegen MenuSubmissionOwn: Abgabe MenuCorrectors: Korrektoren MenuSheetEdit: Übungsblatt editieren +MenuSheetDelete: Übungsblatt löschen MenuCorrectionsUpload: Korrekturen hochladen MenuCorrectionsCreate: Abgaben registrieren MenuCorrectionsGrade: Abgaben bewerten AuthPredsActive: Aktive Authorisierungsprädikate AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert -AuthTagFree: Seite ist generell zugänglich +AuthTagFree: Seite ist universell zugänglich AuthTagAdmin: Nutzer ist Administrator AuthTagNoEscalation: Nutzer-Rechte werden nicht erweitert AuthTagDeprecated: Seite ist nicht überholt @@ -574,4 +584,8 @@ AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren AuthTagAuthentication: Authentifizierung erfüllt Anforderungen AuthTagRead: Zugriff ist nur lesend -AuthTagWrite: Zugriff ist i.A. schreibend \ No newline at end of file +AuthTagWrite: Zugriff ist i.A. schreibend + +DeleteCopyStringIfSure count@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE count "das obige Objekt" "obige Objekte"} unwiderbringlich löschen möchten, schreiben Sie bitte zunächst den angezeigten Text ab. +DeleteConfirmation: Bestätigung +DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen. \ No newline at end of file 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 4bc841965..1bd402afd 100644 --- a/package.yaml +++ b/package.yaml @@ -112,6 +112,7 @@ dependencies: - text-metrics - pkcs7 - memcached-binary + - directory-tree other-extensions: - GeneralizedNewtypeDeriving @@ -162,6 +163,7 @@ default-extensions: - PolyKinds - PackageImports - TypeApplications + - RecursiveDo ghc-options: - -Wall diff --git a/routes b/routes index 25d5bb346..f29cc077b 100644 --- a/routes +++ b/routes @@ -60,7 +60,6 @@ -- For Pattern Synonyms see Foundation /course/ CourseListR GET !free !/course/new CourseNewR GET POST !lecturer -!/course/new/#{Maybe TermId}/#{Maybe SchoolId}/#{Maybe CourseShorthand} CourseNewTemplateR GET !lecturer /course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer: / CShowR GET !free /register CRegisterR POST !timeANDcapacity @@ -80,8 +79,9 @@ !/subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions !/subs/own SubmissionOwnR GET !free -- just redirect /subs/#CryptoFileNameSubmission SubmissionR: - / SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread + / SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector + /delete SubDelR GET POST !ownerANDtime /assign SAssignR GET POST !lecturerANDtime /correction CorrectionR GET POST !corrector !ownerANDreadANDrated !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index c9e7f0c5d..bfc2790ff 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -13,6 +13,7 @@ import qualified Data.CaseInsensitive as CI import Database.Persist.Sql import Text.Blaze (ToMarkup(..)) +import Text.Shakespeare.Text (ToText(..)) import Data.Text (Text) import qualified Data.Text.Encoding as Text @@ -63,6 +64,9 @@ instance ToMarkup a => ToMarkup (CI a) where toMarkup = toMarkup . CI.original preEscapedToMarkup = preEscapedToMarkup . CI.original +instance ToText a => ToText (CI a) where + toText = toText . CI.original + instance ToWidget site a => ToWidget site (CI a) where toWidget = toWidget . CI.original 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/Foundation.hs b/src/Foundation.hs index 76af3794e..b63830a54 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -146,6 +146,15 @@ pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Cr pattern CSubmissionR tid ssh csh shn cid ptn = CSheetR tid ssh csh shn (SubmissionR cid ptn) + +pluralDE :: Int -- ^ Count + -> Text -- ^ Singular + -> Text -- ^ Plural + -> Text +pluralDE num singularForm pluralForm + | num == 1 = singularForm + | otherwise = pluralForm + -- Messages creates type UniWorXMessage and RenderMessage UniWorX instance mkMessage "UniWorX" "messages/uniworx" "de" mkMessageVariant "UniWorX" "Campus" "messages/campus" "de" @@ -491,8 +500,11 @@ tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] - guard $ registered <= 0 + assertM_ (<= 0) . lift $ count [ CourseParticipantCourse ==. cid ] + assertM_ ((<= 0) :: Int -> Bool) . lift . fmap (E.unValue . unsafeHead) $ E.select . E.from $ \(sheet `E.InnerJoin` submission) -> do + E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet + E.where_ $ sheet E.^. SheetCourse E.==. E.val cid + return E.countRows return Authorized r -> $unsupportedAuthPredicate AuthEmpty r tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of @@ -1190,7 +1202,15 @@ pageActions (CourseR tid ssh csh CShowR) = { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseNewTemplate , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseNewTemplateR (Just tid) (Just ssh) (Just csh) + , menuItemRoute = SomeRoute (CourseNewR, [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)]) + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuCourseDelete + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR , menuItemModal = False , menuItemAccessCallback' = return True } @@ -1254,6 +1274,14 @@ pageActions (CSheetR tid ssh csh shn SShowR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuSheetDelete + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SDelR + , menuItemModal = False + , menuItemAccessCallback' = return True + } ] pageActions (CSheetR tid ssh csh shn SSubsR) = [ MenuItem @@ -1282,6 +1310,24 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = , menuItemModal = True , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuSubmissionDelete + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = + [ MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuSubmissionDelete + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR + , menuItemModal = False + , menuItemAccessCallback' = return True + } ] pageActions (CSheetR tid ssh csh shn SCorrR) = [ MenuItem diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 116a54487..3ac565d92 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -1,11 +1,12 @@ module Handler.Course where -import Import hiding (catMaybes) +import Import import Utils.Lens -- import Utils.DB import Handler.Utils import Handler.Utils.Table.Cells +import Handler.Utils.Delete -- import Data.Time import qualified Data.Text as T @@ -18,8 +19,6 @@ import Data.Maybe import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Data.CaseInsensitive as CI - import qualified Database.Esqueleto as E @@ -175,9 +174,9 @@ makeCourseTable whereClause colChoices psValidator = do E.||. (E.castString (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) ) ] - , dbtFilterUI = mconcat - [ Map.singleton "search" . maybeToList <$> aopt textField (fslI MsgCourseFilterSearch) Nothing - , Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) Nothing + , dbtFilterUI = \mPrev -> mconcat + [ Map.singleton "search" . maybeToList <$> aopt textField (fslI MsgCourseFilterSearch) (Just <$> listToMaybe =<< Map.lookup "search" =<< mPrev) + , Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) (Just <$> fromPathPiece =<< listToMaybe =<< Map.lookup "registered" =<< mPrev) ] , dbtStyle = def , dbtParams = def @@ -316,13 +315,6 @@ postCRegisterR tid ssh csh = do redirect $ CourseR tid ssh csh CShowR -getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html -getCourseNewTemplateR mbTid mbSsh mbCsh = - redirect (CourseNewR, catMaybes [ ("tid",).termToText.unTermKey <$> mbTid - , ("ssh",).CI.original.unSchoolKey <$> mbSsh - , ("csh",).CI.original <$> mbCsh - ]) - getCourseNewR :: Handler Html -- call via toTextUrl getCourseNewR = do uid <- requireAuthId @@ -395,10 +387,24 @@ pgCEditR isGetReq tid ssh csh = do courseEditHandler isGetReq $ courseToForm <$> course -getCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCDeleteR = error "TODO: implement getCDeleteR" -postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -postCDeleteR = error "TODO: implement getCDeleteR" +getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCDeleteR = postCDeleteR +postCDeleteR tid ssh csh = do + Entity cId _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh + deleteR DeleteRoute + { drRecords = Set.singleton cId + , drRenderRecord = \(Entity _ Course{courseName, courseTerm, courseSchool}) -> do + School{schoolName} <- getJust courseSchool + return [whamlet| + #{courseName} (_{SomeMessage $ ShortTermIdentifier (unTermKey courseTerm)}, #{schoolName}) + |] + , drRecordConfirmString = \(Entity _ Course{courseShorthand, courseTerm, courseSchool}) -> + return [st|#{unSchoolKey courseSchool}/#{termToText (unTermKey courseTerm)}/#{courseShorthand}|] + , drCaption = SomeMessage MsgCourseDeleteQuestion + , drSuccessMessage = SomeMessage MsgCourseDeleted + , drAbort = SomeRoute $ CourseR tid ssh csh CShowR + , drSuccess = SomeRoute CourseListR + } {- TODO | False -- DELETE -- TODO: This no longer works that way!!! See new way in Handler.Term.termEditHandler , Just cid <- cfCourseId res -> do diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 447a8a006..3cb1b9d24 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -7,6 +7,7 @@ import Handler.Utils -- import Handler.Utils.Zip import Handler.Utils.Table.Cells import Handler.Utils.SheetType +import Handler.Utils.Delete -- import Data.Time -- import qualified Data.Text as T @@ -528,30 +529,26 @@ handleSheetEdit tid ssh csh msId template dbAction = do $(widgetFile "formPageI18n") - -getSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html -getSDelR tid ssh csh shn = do - ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete) - case result of - (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid ssh csh shn SShowR - (FormSuccess BtnDelete) -> do - runDB $ fetchSheetId tid ssh csh shn >>= deleteCascade - -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!! - addMessageI Info $ MsgSheetDelOk tid ssh csh shn - redirect $ CourseR tid ssh csh SheetListR - _other -> do - submissionno <- runDB $ do - sid <- fetchSheetId tid ssh csh shn - count [SubmissionSheet ==. sid] - let formText = Just $ MsgSheetDelText submissionno - let actionUrl = CSheetR tid ssh csh shn SDelR - defaultLayout $ do - setTitleI $ MsgSheetTitle tid ssh csh shn - $(widgetFile "formPageI18n") - -postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html -postSDelR = getSDelR - +getSDelR, postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html +getSDelR = postSDelR +postSDelR tid ssh csh shn = do + sid <- runDB $ fetchSheetId tid ssh csh shn + deleteR DeleteRoute + { drRecords = Set.singleton sid + , drRenderRecord = \(Entity _ Sheet{sheetName, sheetCourse}) -> do + Course{courseTerm, courseSchool, courseName} <- getJust sheetCourse + School{schoolName} <- getJust courseSchool + return [whamlet| + #{sheetName} (_{ShortTermIdentifier (unTermKey courseTerm)}, #{schoolName}, #{courseName}) + |] + , drRecordConfirmString = \(Entity _ Sheet{sheetName, sheetCourse}) -> do + Course{courseTerm, courseSchool, courseShorthand} <- getJust sheetCourse + return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{sheetName}|] + , drCaption = SomeMessage MsgSheetDeleteQuestion + , drSuccessMessage = SomeMessage MsgSheetDeleted + , drAbort = SomeRoute $ CSheetR tid ssh csh shn SShowR + , drSuccess = SomeRoute $ CourseR tid ssh csh SheetListR + } insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX () diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index d3641e34c..8357e4023 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -7,6 +7,7 @@ import Jobs -- import Yesod.Form.Bootstrap3 import Handler.Utils +import Handler.Utils.Delete import Handler.Utils.Submission import Handler.Utils.Table.Cells @@ -19,6 +20,7 @@ import Network.Mime import Data.Monoid (Any(..)) import Data.Maybe (fromJust) -- import qualified Data.Maybe +import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.CaseInsensitive (CI) @@ -390,3 +392,35 @@ getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do zipComment = Text.encodeUtf8 $ toPathPiece cID fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder + +getSubDelR, postSubDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html +getSubDelR = postSubDelR +postSubDelR tid ssh csh shn cID = do + subId <- runDB $ submissionMatchesSheet tid ssh csh shn cID + deleteR DeleteRoute + { drRecords = Set.singleton subId + , drRenderRecord = \(Entity subId' Submission{submissionSheet}) -> do + Sheet{sheetName, sheetCourse} <- getJust submissionSheet + Course{courseName, courseSchool, courseTerm} <- getJust sheetCourse + School{schoolName} <- getJust courseSchool + subUsers <- selectList [SubmissionUserSubmission ==. subId'] [] + subNames <- fmap (sortOn snd) . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> (userDisplayName &&& userSurname) <$> getJust submissionUserUser + return [whamlet| + $newline never +