Merge remote-tracking branch 'origin/master' into 126-ubungsbetrieb-statistik-seiten-pro-kurs

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?
+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!
-SheetDelText       submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben.
 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
@@ -575,3 +585,7 @@ AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren
 AuthTagAuthentication: Authentifizierung erfüllt Anforderungen
 AuthTagRead: Zugriff ist nur lesend
 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.

models

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

models/config

@@ -0,0 +1,4 @@
+ClusterConfig
+    setting             ClusterSettingsKey
+    value               Value
+    Primary setting

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

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)

models/files

@@ -0,0 +1,5 @@
+File
+    title           FilePath
+    content         ByteString Maybe -- Nothing iff this is a directory
+    modified        UTCTime
+    deriving Show Eq Generic

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

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

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

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

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

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

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

models/tutorials

@@ -0,0 +1,8 @@
+Tutorial json
+    name        Text
+    tutor       UserId
+    course      CourseId
+TutorialUser
+    user        UserId
+    tutorial    TutorialId
+    UniqueTutorialUser user   tutorial

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

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

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

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
 

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

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 ]
+    assertM_ (<= 0) . lift $ count [ CourseParticipantCourse ==. cid ]
-    guard $ registered <= 0
+    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

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
+    , dbtFilterUI = \mPrev -> mconcat
-      [ Map.singleton "search" . maybeToList <$> aopt textField (fslI MsgCourseFilterSearch) Nothing
+      [ Map.singleton "search" . maybeToList <$> aopt textField (fslI MsgCourseFilterSearch) (Just <$> listToMaybe =<< Map.lookup "search" =<< mPrev)
-      , Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) Nothing
+      , 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, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-getCDeleteR = error "TODO: implement getCDeleteR"
+getCDeleteR = postCDeleteR
-postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+postCDeleteR tid ssh csh = do
-postCDeleteR = error "TODO: implement getCDeleteR"
+  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

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, postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
-getSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
+getSDelR = postSDelR
-getSDelR tid ssh csh shn = do
+postSDelR tid ssh csh shn = do
-  ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
+  sid <- runDB $ fetchSheetId tid ssh csh shn
-  case result of
+  deleteR DeleteRoute
-    (FormSuccess BtnAbort)  -> redirectUltDest $ CSheetR tid ssh csh shn SShowR
+    { drRecords = Set.singleton sid
-    (FormSuccess BtnDelete) -> do
+    , drRenderRecord = \(Entity _ Sheet{sheetName, sheetCourse}) -> do
-      runDB $ fetchSheetId tid ssh csh shn >>= deleteCascade
+        Course{courseTerm, courseSchool, courseName} <- getJust sheetCourse
-      -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
+        School{schoolName} <- getJust courseSchool
-      addMessageI Info $ MsgSheetDelOk tid ssh csh shn
+        return [whamlet|
-      redirect $ CourseR tid ssh csh SheetListR
+          #{sheetName} (_{ShortTermIdentifier (unTermKey courseTerm)}, #{schoolName}, #{courseName})
-    _other -> do
+        |]
-      submissionno <- runDB $ do
+    , drRecordConfirmString = \(Entity _ Sheet{sheetName, sheetCourse}) -> do
-          sid <- fetchSheetId tid ssh csh shn
+        Course{courseTerm, courseSchool, courseShorthand} <- getJust sheetCourse
-          count [SubmissionSheet ==. sid]
+        return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{sheetName}|]
-      let formText  = Just $ MsgSheetDelText submissionno
+    , drCaption = SomeMessage MsgSheetDeleteQuestion
-      let actionUrl = CSheetR tid ssh csh shn SDelR
+    , drSuccessMessage = SomeMessage MsgSheetDeleted
-      defaultLayout $ do
+    , drAbort = SomeRoute $ CSheetR tid ssh csh shn SShowR
-        setTitleI $ MsgSheetTitle tid ssh csh shn
+    , drSuccess = SomeRoute $ CourseR tid ssh csh SheetListR
-        $(widgetFile "formPageI18n")
+    }
-
-postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
-postSDelR = getSDelR
-
 
 
 insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX ()

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
+          <ul .list--comma-separated .list--inline .list--iconless>
+            $forall (dName, sName) <- subNames
+              <li>^{nameWidget dName sName}
+          &nbsp;(_{ShortTermIdentifier (unTermKey courseTerm)}, #{schoolName}, #{courseName}, #{sheetName})
+        |]
+    , drRecordConfirmString = \(Entity subId' Submission{submissionSheet}) -> do
+        Sheet{sheetName, sheetCourse} <- getJust submissionSheet
+        Course{courseShorthand, courseSchool, courseTerm} <- getJust sheetCourse
+        subUsers <- selectList [SubmissionUserSubmission ==. subId'] []
+        subNames <- fmap sort . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> userSurname <$> getJust submissionUserUser
+        let subNames' = Text.intercalate ", " subNames
+        return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{sheetName}/#{subNames'}|]
+    , drCaption = SomeMessage $ MsgSubmissionsDeleteQuestion 1
+    , drSuccessMessage = SomeMessage $ MsgSubmissionsDeleted 1
+    , drAbort = SomeRoute $ CSubmissionR tid ssh csh shn cID SubShowR
+    , drSuccess = SomeRoute $ CSheetR tid ssh csh shn SShowR
+    }

src/Handler/SystemMessage.hs

@@ -59,7 +59,7 @@ postMessageR cID = do
                   <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent)
                   <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary)
               )
-          <*> combinedButtonField (universeF :: [BtnSubmitDelete])
+          <*> combinedButtonFieldF ""
 
       let modifyTranss = Map.map (view $ _1._1) modifyTranss'
 

src/Handler/Utils/Delete.hs

@@ -0,0 +1,75 @@
+module Handler.Utils.Delete
+  ( DeleteRoute(..)
+  , deleteR
+  ) where
+
+import Import
+import Handler.Utils.Form
+
+import Utils.Lens
+
+import qualified Data.Text as Text
+import qualified Data.Set as Set
+
+import qualified Data.CaseInsensitive as CI
+
+import Control.Monad.Trans.Random
+import System.Random (mkStdGen)
+import System.Random.Shuffle (shuffleM)
+import qualified Crypto.Hash as Crypto (hash)
+import Crypto.Hash (Digest, SHAKE128)
+
+import qualified Data.ByteArray as ByteArray
+
+import Data.Char (isAlphaNum)
+
+
+data DeleteRoute = forall record. (DeleteCascade record SqlBackend, Hashable (Key record)) => DeleteRoute
+  { drRecords :: Set (Key record)
+  , drRenderRecord :: Entity record -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget
+  , drRecordConfirmString :: Entity record -> ReaderT SqlBackend (HandlerT UniWorX IO) Text
+  , drCaption
+  , drSuccessMessage :: SomeMessage UniWorX
+  , drAbort
+  , drSuccess :: SomeRoute UniWorX
+  }
+
+
+deleteR :: DeleteRoute -> Handler Html
+deleteR DeleteRoute{..} = do
+  targets <- runDB . mconcatForM drRecords $ \rKey -> do
+    ent <- Entity rKey <$> get404 rKey
+    recordWdgt <- drRenderRecord ent
+    recordConfirmString <- drRecordConfirmString ent
+    return $ pure (recordWdgt, recordConfirmString)
+
+  cIDKey <- hash . (ByteArray.convert :: Digest (SHAKE128 64) -> ByteString) . Crypto.hash <$> getsYesod appCryptoIDKey
+
+  let sTargets = evalRand (shuffleM targets) . mkStdGen . hashWithSalt cIDKey $ Set.toList drRecords
+      confirmString = Text.unlines $ map (Text.strip . view _2) sTargets
+      confirmField
+        | Set.size drRecords <= 1 = textField
+        | otherwise = convertField unTextarea Textarea textareaField
+  
+  ((deleteFormRes, deleteFormWdgt), deleteFormEnctype) <- runFormPost . identForm FIDDelete . renderAForm FormStandard $ (,)
+    <$> areq confirmField (fslI MsgDeleteConfirmation) Nothing
+    <*> combinedButtonFieldF ""
+
+  formResult deleteFormRes $ \case
+    (_, catMaybes -> [BtnAbort]) ->
+      redirect drAbort
+    (inpConfirmStr, catMaybes -> [BtnDelete])
+      | ((==) `on` map (CI.mk . filter isAlphaNum) . Text.words) confirmString inpConfirmStr
+        -> do
+          runDB $ do
+            forM_ drRecords deleteCascade
+            addMessageI Success drSuccessMessage
+          redirect drSuccess
+      | otherwise
+        -> addMessageI Error MsgDeleteConfirmationWrong
+    _other -> return ()
+
+  Just targetRoute <- getCurrentRoute
+  
+  defaultLayout
+    $(widgetFile "widgets/delete-confirmation")

src/Handler/Utils/Form.hs

@@ -56,6 +56,9 @@ import Data.Aeson.Text (encodeToLazyText)
 data BtnDelete = BtnDelete | BtnAbort
   deriving (Enum, Eq, Ord, Bounded, Read, Show)
 
+instance Universe BtnDelete
+instance Finite BtnDelete
+
 instance PathPiece BtnDelete where    -- for displaying the button only, not really for paths
   toPathPiece   = showToPathPiece
   fromPathPiece = readFromPathPiece

src/Handler/Utils/Table/Pagination.hs

@@ -343,7 +343,7 @@ data DBTable m x = forall a r r' h i t k k'.
   , dbtColonnade :: Colonnade h r' (DBCell m x)
   , dbtSorting :: Map SortingKey (SortColumn t)
   , dbtFilter :: Map FilterKey (FilterColumn t)
-  , dbtFilterUI :: AForm (ReaderT SqlBackend (HandlerT UniWorX IO)) (Map FilterKey [Text])
+  , dbtFilterUI :: Maybe (Map FilterKey [Text]) -> AForm (ReaderT SqlBackend (HandlerT UniWorX IO)) (Map FilterKey [Text])
   , dbtStyle :: DBStyle
   , dbtParams :: DBParams m x
   , dbtIdent :: i
@@ -452,7 +452,7 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
   -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
   -- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
   -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
-  runDBTable dbtable pi pKeys = fmap (view _1) . dbParamsFormEvaluate (dbtParams dbtable) . dbParamsFormWrap (dbtParams dbtable) . addPIHiddenFields dbtable pi pKeys . withFragment
+  runDBTable dbtable pi pKeys = fmap (view _1) . dbParamsFormEvaluate (dbtParams dbtable) . dbParamsFormWrap (dbtParams dbtable) . addPIHiddenField dbtable pi . addPreviousHiddenField dbtable pKeys . withFragment
 
 instance Monoid a => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
   def = DBParamsForm
@@ -475,18 +475,37 @@ dbParamsFormWrap DBParamsForm{..} tableForm frag = do
         enctype' = bool id (mappend $ fieldEnctype submitField) dbParamsFormAddSubmit enctype
     $(widgetFile "table/form-wrap")
 
-addPIHiddenFields :: ToJSON k' => DBTable m x -> PaginationInput -> [k'] -> Form a -> Form a
+data WithIdent x = forall ident. PathPiece ident => WithIdent { _ident :: ident, _withoutIdent :: x }
-addPIHiddenFields DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi pKeys form fragment = do
+
+instance PathPiece x => PathPiece (WithIdent x) where
+  toPathPiece (WithIdent ident x)
+    | not . null $ toPathPiece ident = toPathPiece ident <> "-" <> toPathPiece x
+    | otherwise = toPathPiece x
+  fromPathPiece txt = do
+    let sep = "-"
+    (ident, (Text.stripSuffix sep -> Just rest)) <- return $ Text.breakOn sep txt
+    WithIdent <$> pure ident <*> fromPathPiece rest
+
+addPIHiddenField :: DBTable m' x -> PaginationInput -> (Html -> MForm m a) -> (Html -> MForm m a)
+addPIHiddenField DBTable{ dbtIdent } pi form fragment
+  = form $ fragment <> [shamlet|
+      $newline never
+      <input type=hidden name=#{wIdent "pagination"} value=#{encodeToTextBuilder pi}>
+    |]
+  where
+    wIdent :: Text -> Text
+    wIdent = toPathPiece . WithIdent dbtIdent
+
+addPreviousHiddenField :: (ToJSON k', MonadHandler m, HandlerSite m ~ UniWorX) => DBTable m' x -> [k'] -> (Html -> MForm m a) -> (Html -> MForm m a)
+addPreviousHiddenField DBTable{ dbtIdent } pKeys form fragment = do
   encrypted <- encodedSecretBox SecretBoxShort pKeys
   form $ fragment <> [shamlet|
     $newline never
-    <input type=hidden name=#{wIdent "pagination"} value=#{encodeToTextBuilder pi}>
     <input type=hidden name=#{wIdent "previous"} value=#{encrypted}>
   |]
   where
-    wIdent n
+    wIdent :: Text -> Text
-      | not $ null dbtIdent = dbtIdent <> "-" <> n
+    wIdent = toPathPiece . WithIdent dbtIdent
-      | otherwise           = n
 
 instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
   mempty = FormCell mempty (return mempty)
@@ -505,9 +524,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       , d <- [SortAsc, SortDesc]
       , let t' = toPathPiece $ SortingSetting t d
       ]
-    wIdent n
+    wIdent :: Text -> Text
-      | not $ null dbtIdent = dbtIdent <> "-" <> n
+    wIdent = toPathPiece . WithIdent dbtIdent 
-      | otherwise           = n
     dbsAttrs'
       | not $ null dbtIdent = ("id", dbtIdent) : dbsAttrs
       | otherwise           = dbsAttrs
@@ -517,7 +535,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       , fieldEnctype = UrlEncoded
       }
 
-  piPrevious <- lift . runInputPostMaybe $ ireq (jsonField True) (wIdent "pagination")
+  piPrevious <- lift . runInputMaybe $ ireq (jsonField True) (wIdent "pagination")
   let piPreviousRes = maybe FormMissing FormSuccess piPrevious
   previousKeys <- throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ wIdent "previous")
 
@@ -533,21 +551,20 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
         | otherwise
           = def
 
-  ((filterRes, filterWdgt), filterEnc) <- runFormGet . renderAForm FormDBTableFilter $ (,)
+  (((filterRes, filterWdgt), filterEnc), ((pagesizeRes, pagesizeWdgt), pagesizeEnc)) <- mdo
-    <$> areq (jsonField True) ("" & addName (wIdent "pagination")) (Just $ prevPi & _piFilter .~ Nothing & _piPage .~ Nothing)
+    (filterRes'@((filterRes, _), _)) <- runFormGet . identForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
-    <*> dbtFilterUI
 
-  let referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi
+    let referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi
 
-  ((pagesizeRes, pagesizeWdgt), pagesizeEnc) <- lift . runFormGet . renderAForm FormDBTablePagesize $ (,)
+    (pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
-    <$> areq (jsonField True) ("" & addName (wIdent "pagination")) (Just $ prevPi & _piPage .~ Nothing & _piLimit .~ Nothing)
+          areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize)
-    <*> areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize)
+      <*  autosubmitButton
-    <*  autosubmitButton
+    return (filterRes', pagesizeRes')
 
   let
-    piResult = piPreviousRes
+    piResult = (\fSettings -> prevPi & _piFilter .~ Just fSettings) <$> filterRes
-           <|> (\(prev, fSettings) -> prev & _piFilter .~ Just fSettings) <$> filterRes
+           <|> (\ps -> prevPi & _piLimit .~ Just ps) <$> pagesizeRes
-           <|> (\(prev, ps) -> prev & _piLimit .~ Just ps) <$> pagesizeRes
+           <|> piPreviousRes
            <|> piInput
 
   psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit

src/Import/NoFoundation.hs

@@ -16,6 +16,7 @@ import Yesod.Core.Types       as Import (loggerSet)
 import Yesod.Default.Config2  as Import
 import Utils                  as Import
 import Yesod.Core.Json        as Import (provideJson)
+import Yesod.Core.Types.Instances as Import ()
 
 
 import Data.Fixed             as Import

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 hiding (_maxPoints, _passingPoints)
@@ -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)

src/Utils.hs

@@ -448,6 +448,9 @@ guardM f = guard =<< f
 assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
 assertM f x = x >>= assertM' f
 
+assertM_ :: MonadPlus m => (a -> Bool) -> m a -> m ()
+assertM_ f x = guard . f =<< x
+
 assertM' :: MonadPlus m => (a -> Bool) -> a -> m a
 assertM' f x = x <$ guard (f x)
 
@@ -495,6 +498,12 @@ partitionM crit = ofoldlM dist mempty
         | okay ->      acc `mappend` (opoint x, mempty)
         | otherwise -> acc `mappend` (mempty, opoint x)
 
+mconcatMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b
+mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList
+
+mconcatForM :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b
+mconcatForM = flip mconcatMapM
+
 
 --------------
 -- Sessions --

src/Utils/Form.hs

@@ -170,6 +170,9 @@ data FormIdentifier
   | FIDSystemMessageModify
   | FIDSystemMessageModifyTranslation UUID
   | FIDSystemMessageAddTranslation
+  | FIDDBTableFilter
+  | FIDDBTablePagesize
+  | FIDDelete
   deriving (Eq, Ord, Read, Show)
 
 instance PathPiece FormIdentifier where
@@ -228,13 +231,30 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
       | otherwise  = return $ Left "Wrong button value"
     fieldParse _ _ = return $ Left "Multiple button values"
 
-combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a]
+combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> FieldSettings site -> AForm (HandlerT site IO) [Maybe a]
-combinedButtonField = traverse b2f
+combinedButtonField bs FieldSettings{..} = formToAForm $ do
-  where
+  mr <- getMessageRender
-    b2f b = aopt (buttonField b) "" Nothing
+  fvId <- maybe newIdent return fsId
+  name <- maybe newIdent return fsName
+  (ress, fvs) <- fmap unzip . for bs $ \b -> mopt (buttonField b) ("" { fsId = Just $ fvId <> "__" <> toPathPiece b
+                                                                      , fsName = Just $ name <> "__" <> toPathPiece b
+                                                                      }) Nothing
+  return ( sequenceA ress
+         , pure FieldView
+             { fvLabel = toHtml $ mr fsLabel
+             , fvTooltip = fmap (toHtml . mr) fsTooltip
+             , fvId
+             , fvInput = foldMap fvInput fvs
+             , fvErrors = bool Nothing (Just $ foldMap (fromMaybe mempty . fvErrors) fvs) $ any (isJust . fvErrors) fvs
+             , fvRequired = False
+             }
+         )
+
+combinedButtonFieldF :: forall site a. (Button site a, Show (ButtonCssClass site), Finite a) => FieldSettings site -> AForm (HandlerT site IO) [Maybe a]
+combinedButtonFieldF = combinedButtonField (universeF :: [a])
 
 submitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) ()
-submitButton = void $ combinedButtonField [BtnSubmit]
+submitButton = void $ combinedButtonField [BtnSubmit] ""
 
 autosubmitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) ()
 autosubmitButton = void $ aopt (buttonField BtnSubmit) ("" & addAutosubmit) Nothing
@@ -319,6 +339,11 @@ formResultMaybe (FormFailure errs) _ = Nothing <$ forM_ errs (addMessage Error .
 formResultMaybe  FormMissing       _ = return Nothing
 formResultMaybe (FormSuccess res)  f = f res
 
+formResult' :: FormResult a -> Maybe a
+formResult'  FormMissing    = Nothing
+formResult' (FormFailure _) = Nothing
+formResult' (FormSuccess x) = Just x
+
 runInputGetMaybe, runInputPostMaybe, runInputMaybe :: MonadHandler m => FormInput m a -> m (Maybe a)
 runInputGetMaybe form = do
   res <- runInputGetResult form

src/Yesod/Core/Types/Instances.hs

@@ -0,0 +1,16 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Yesod.Core.Types.Instances
+  (
+  ) where
+
+import ClassyPrelude
+import Yesod.Core.Types
+
+import Control.Monad.Fix
+
+instance MonadFix m => MonadFix (HandlerT site m) where
+  mfix f = HandlerT $ \r -> mfix $ \a -> unHandlerT (f a) r
+  
+instance MonadFix m => MonadFix (WidgetT site m) where
+  mfix f = WidgetT $ \r -> mfix $ \ ~(a, _) -> unWidgetT (f a) r

templates/default-layout.lucius

@@ -439,6 +439,7 @@ input[type="button"].btn-info:hover,
 }
 
 .list--inline {
+  display: inline-block;
   margin-left: 0;
 
   li {

templates/table/layout.julius

@@ -10,12 +10,12 @@
 
     function setupAsync(wrapper) {
 
-      var table = wrapper.querySelector('#' + #{String $ dbtIdent});
+      var table = wrapper.querySelector('#' + #{String dbtIdent});
       if (!table)
         return;
         
       var ths = Array.from(table.querySelectorAll('th.sortable'));
-      var pagination = wrapper.querySelector('#' + #{String $ dbtIdent} + '-pagination');
+      var pagination = wrapper.querySelector('#' + #{String dbtIdent} + '-pagination');
 
       ths.forEach(function(th) {
         th.addEventListener('click', clickHandler);

templates/widgets/delete-confirmation.hamlet

@@ -0,0 +1,13 @@
+<p>_{drCaption}
+<ul>
+  $forall (wdgt, _) <- sTargets
+    <li>
+      ^{wdgt}
+
+<p>_{SomeMessage $ MsgDeleteCopyStringIfSure (Set.size drRecords)}
+
+<p .confirmationText>
+  #{confirmString}
+
+<form method=POST action=@{targetRoute} enctype=#{deleteFormEnctype}>
+  ^{deleteFormWdgt}

templates/widgets/delete-confirmation.lucius

@@ -0,0 +1,5 @@
+.confirmationText {
+    white-space: pre-wrap;
+    font-size: 14px;
+    font-family: monospace;
+}