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

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

Browse Source
This commit is contained in:
SJost 2018-12-20 19:19:07 +01:00
commit 8b5c8fbc36
36 changed files with 640 additions and 344 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
messages/uniworx/de.msg
View File

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

262
models
View File

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

4
models/config Normal file
View File

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

40
models/courses Normal file
View File

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

22
models/exams Normal file
View File

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

5
models/files Normal file
View File

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

12
models/jobs Normal file
View File

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

26
models/rooms Normal file
View File

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

7
models/schools Normal file
View File

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

37
models/sheets Normal file
View File

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

34
models/submissions Normal file
View File

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

14
models/system-messages Normal file
View File

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

10
models/terms Normal file
View File

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

8
models/tutorials Normal file
View File

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

43
models/users Normal file
View File

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

2
package.yaml
View File

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

4
routes
View File

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

4
src/Data/CaseInsensitive/Instances.hs
View File

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

27
src/Database/Persist/TH/Directory.hs Normal file
View File

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

52
src/Foundation.hs
View File

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

40
src/Handler/Course.hs
View File

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

45
src/Handler/Sheet.hs
View File

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

34
src/Handler/Submission.hs
View File

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

2
src/Handler/SystemMessage.hs
View File

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

75
src/Handler/Utils/Delete.hs Normal file
View File

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

3
src/Handler/Utils/Form.hs
View File

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

63
src/Handler/Utils/Table/Pagination.hs
View File

@ -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
addPIHiddenFields DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi pKeys form fragment = do
data WithIdent x = forall ident. PathPiece ident => WithIdent { _ident :: ident, _withoutIdent :: x }
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
| not $ null dbtIdent = dbtIdent <> "-" <> n
| otherwise = n
wIdent :: Text -> Text
wIdent = toPathPiece . WithIdent dbtIdent
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
| not $ null dbtIdent = dbtIdent <> "-" <> n
| otherwise = n
wIdent :: Text -> Text
wIdent = toPathPiece . WithIdent dbtIdent
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 $ (,)
<$> areq (jsonField True) ("" & addName (wIdent "pagination")) (Just $ prevPi & _piFilter .~ Nothing & _piPage .~ Nothing)
<*> dbtFilterUI
(((filterRes, filterWdgt), filterEnc), ((pagesizeRes, pagesizeWdgt), pagesizeEnc)) <- mdo
(filterRes'@((filterRes, _), _)) <- runFormGet . identForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
let referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi
let referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi
((pagesizeRes, pagesizeWdgt), pagesizeEnc) <- lift . runFormGet . 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)
<* autosubmitButton
(pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize)
<* autosubmitButton
return (filterRes', pagesizeRes')
let
piResult = piPreviousRes
<|> (\(prev, fSettings) -> prev & _piFilter .~ Just fSettings) <$> filterRes
<|> (\(prev, ps) -> prev & _piLimit .~ Just ps) <$> pagesizeRes
piResult = (\fSettings -> prevPi & _piFilter .~ Just fSettings) <$> filterRes
<|> (\ps -> prevPi & _piLimit .~ Just ps) <$> pagesizeRes
<|> piPreviousRes
<|> piInput
psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit

1
src/Import/NoFoundation.hs
View File

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

3
src/Model.hs
View File

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

9
src/Utils.hs
View File

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

35
src/Utils/Form.hs
View File

@ -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 = traverse b2f
where
b2f b = aopt (buttonField b) "" Nothing
combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> FieldSettings site -> AForm (HandlerT site IO) [Maybe a]
combinedButtonField bs FieldSettings{..} = formToAForm $ do
mr <- getMessageRender
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

16
src/Yesod/Core/Types/Instances.hs Normal file
View File

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

1
templates/default-layout.lucius
View File

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

4
templates/table/layout.julius
View File

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

13
templates/widgets/delete-confirmation.hamlet Normal file
View File

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

5
templates/widgets/delete-confirmation.lucius Normal file
View File

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