Make a bunch of things case insensitive in database
Fixes #96 Might require manual database migration
This commit is contained in:
Gregor Kleen
parent
969ada63d8
commit
51c04aec20
@ -34,29 +34,29 @@ CourseRegisterOk: Sie wurden angemeldet
|
||||
CourseDeregisterOk: Sie wurden abgemeldet
|
||||
CourseSecretWrong: Falsches Kennwort
|
||||
CourseSecret: Zugangspasswort
|
||||
CourseNewOk tid@TermId courseShortHand@Text: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich erstellt.
|
||||
CourseEditOk tid@TermId courseShortHand@Text: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich geändert.
|
||||
CourseNewDupShort tid@TermId courseShortHand@Text: Kurs #{display tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
|
||||
CourseEditDupShort tid@TermId courseShortHand@Text: Kurs #{display tid}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
|
||||
CourseNewOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich erstellt.
|
||||
CourseEditOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich geändert.
|
||||
CourseNewDupShort tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
|
||||
CourseEditDupShort tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
|
||||
FFSheetName: Name
|
||||
TermCourseListHeading tid@TermId: Kursübersicht #{display tid}
|
||||
TermCourseListTitle tid@TermId: Kurse #{display tid}
|
||||
CourseNewHeading: Neuen Kurs anlegen
|
||||
CourseEditHeading tid@TermId courseShortHand@Text: Kurs #{display tid}-#{courseShortHand} editieren
|
||||
CourseEditHeading tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} editieren
|
||||
CourseEditTitle: Kurs editieren/anlegen
|
||||
|
||||
Sheet: Blatt
|
||||
SheetList tid@TermId courseShortHand@Text: #{display tid}-#{courseShortHand} Übersicht Übungsblätter
|
||||
SheetNewHeading tid@TermId courseShortHand@Text: #{display tid}-#{courseShortHand} Neues Übungsblatt anlegen
|
||||
SheetNewOk tid@TermId courseShortHand@Text sheetName@Text: Neues Übungsblatt #{sheetName} wurde im Kurs #{display tid}-#{courseShortHand} erfolgreich erstellt.
|
||||
SheetTitle tid@TermId courseShortHand@Text sheetName@Text: #{display tid}-#{courseShortHand} #{sheetName}
|
||||
SheetTitleNew tid@TermId courseShortHand@Text : #{display tid}-#{courseShortHand}: Neues Übungsblatt
|
||||
SheetEditHead tid@TermId courseShortHand@Text sheetName@Text: #{display tid}-#{courseShortHand} #{sheetName} editieren
|
||||
SheetEditOk tid@TermId courseShortHand@Text sheetName@Text: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{courseShortHand} wurde gespeichert.
|
||||
SheetNameDup tid@TermId courseShortHand@Text sheetName@Text: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{courseShortHand}.
|
||||
SheetDelHead tid@TermId courseShortHand@Text sheetName@Text: Übungsblatt #{sheetName} wirklich aus Kurs #{display tid}-#{courseShortHand} herauslöschen?
|
||||
SheetList tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Übersicht Übungsblätter
|
||||
SheetNewHeading tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Neues Übungsblatt anlegen
|
||||
SheetNewOk tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Neues Übungsblatt #{sheetName} wurde im Kurs #{display tid}-#{courseShortHand} erfolgreich erstellt.
|
||||
SheetTitle tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName}
|
||||
SheetTitleNew tid@TermId courseShortHand@CourseShorthand : #{display tid}-#{courseShortHand}: Neues Übungsblatt
|
||||
SheetEditHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName} editieren
|
||||
SheetEditOk tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{courseShortHand} wurde gespeichert.
|
||||
SheetNameDup tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{courseShortHand}.
|
||||
SheetDelHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} wirklich aus Kurs #{display tid}-#{courseShortHand} herauslöschen?
|
||||
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 courseShortHand@Text sheetName@Text: #{display tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht.
|
||||
SheetDelOk tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht.
|
||||
|
||||
SheetExercise: Aufgabenstellung
|
||||
SheetHint: Hinweis
|
||||
@ -80,21 +80,21 @@ Deadline: Abgabe
|
||||
Done: Eingereicht
|
||||
|
||||
Submission: Abgabenummer
|
||||
SubmissionsCourse tid@TermId courseShortHand@Text: Alle Abgaben Kurs #{display tid}-#{courseShortHand}
|
||||
SubmissionsSheet sheetName@Text: Abgaben für Blatt #{sheetName}
|
||||
SubmissionsCourse tid@TermId courseShortHand@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{courseShortHand}
|
||||
SubmissionsSheet sheetName@SheetName: Abgaben für Blatt #{sheetName}
|
||||
SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
|
||||
SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
|
||||
SubmissionEditHead tid@TermId courseShortHand@Text sheetName@Text: #{display tid}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen
|
||||
CorrectionHead tid@TermId courseShortHand@Text sheetName@Text cid@CryptoFileNameSubmission: #{display tid}-#{courseShortHand} #{sheetName}: Korrektur
|
||||
SubmissionEditHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen
|
||||
CorrectionHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{courseShortHand} #{sheetName}: Korrektur
|
||||
SubmissionMember g@Int: Mitabgebende(r) ##{display g}
|
||||
SubmissionArchive: Zip-Archiv der Abgabedatei(en)
|
||||
SubmissionFile: Datei zur Abgabe
|
||||
SubmissionFiles: Abgegebene Dateien
|
||||
SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem bÜbungsblatt.
|
||||
SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt.
|
||||
|
||||
CorrectionsTitle: Zugewiesene Korrekturen
|
||||
CourseCorrectionsTitle: Korrekturen für diesen Kurs
|
||||
CorrectorsHead sheetName@Text: Korrektoren für Blatt #{sheetName}
|
||||
CorrectorsHead sheetName@SheetName: Korrektoren für Blatt #{sheetName}
|
||||
|
||||
Unauthorized: Sie haben hierfür keine explizite Berechtigung.
|
||||
UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
|
||||
@ -118,13 +118,13 @@ MaterialFree: Kursmaterialien ohne Anmeldung zugänglich
|
||||
UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
|
||||
|
||||
EMail: E-Mail
|
||||
EMailUnknown email@Text: E-Mail #{email} gehört zu keinem bekannten Benutzer.
|
||||
NotAParticipant user@Text tid@TermId csh@Text: #{user} ist nicht im Kurs #{display tid}-#{csh} angemeldet.
|
||||
EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
|
||||
NotAParticipant email@UserEmail tid@TermId csh@CourseShorthand: #{email} ist nicht im Kurs #{display tid}-#{csh} angemeldet.
|
||||
TooManyParticipants: Es wurden zu viele Mitabgebende angegeben
|
||||
|
||||
AddCorrector: Zusätzlicher Korrektor
|
||||
CorrectorExists user@Text: #{user} ist bereits als Korrektor eingetragen
|
||||
SheetCorrectorsTitle tid@TermId courseShortHand@Text sheetName@Text: Korrektoren für #{display tid}-#{courseShortHand} #{sheetName}
|
||||
CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
|
||||
SheetCorrectorsTitle tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{courseShortHand} #{sheetName}
|
||||
CountTutProp: Tutorien zählen gegen Proportion
|
||||
Corrector: Korrektor
|
||||
Correctors: Korrektoren
|
||||
|
||||
14
models
14
models
@ -2,7 +2,7 @@ User json
|
||||
plugin Text
|
||||
ident Text
|
||||
matrikelnummer Text Maybe
|
||||
email Text
|
||||
email (CI Text)
|
||||
displayName Text
|
||||
maxFavourites Int default=12
|
||||
theme Theme default='Default'
|
||||
@ -48,9 +48,10 @@ Term json
|
||||
Primary name -- newtype Key Term = TermKey { unTermKey :: TermIdentifier }
|
||||
deriving Show -- type TermId = Key Term
|
||||
School json
|
||||
name Text
|
||||
shorthand Text
|
||||
name (CI Text)
|
||||
shorthand (CI Text)
|
||||
UniqueSchool name
|
||||
UniqueSchoolShorthand shorthand
|
||||
deriving Eq
|
||||
DegreeCourse json
|
||||
course CourseId
|
||||
@ -58,10 +59,10 @@ DegreeCourse json
|
||||
terms StudyTermsId
|
||||
UniqueDegreeCourse course degree terms
|
||||
Course
|
||||
name Text
|
||||
name (CI Text)
|
||||
description Html Maybe
|
||||
linkExternal Text Maybe
|
||||
shorthand Text
|
||||
shorthand (CI Text)
|
||||
term TermId
|
||||
school SchoolId
|
||||
capacity Int64 Maybe
|
||||
@ -72,6 +73,7 @@ Course
|
||||
registerSecret Text Maybe -- Falls ein Passwort erforderlich ist
|
||||
materialFree Bool
|
||||
CourseTermShort term shorthand
|
||||
CourseTermName term name
|
||||
CourseEdit
|
||||
user UserId
|
||||
time UTCTime
|
||||
@ -92,7 +94,7 @@ CourseParticipant
|
||||
UniqueParticipant user course
|
||||
Sheet
|
||||
course CourseId
|
||||
name Text
|
||||
name (CI Text)
|
||||
description Html Maybe
|
||||
type SheetType
|
||||
grouping SheetGroup
|
||||
|
||||
4
routes
4
routes
@ -50,14 +50,14 @@
|
||||
-- For Pattern Synonyms see Foundation
|
||||
/course/ CourseListR GET !free
|
||||
!/course/new CourseNewR GET POST !lecturer
|
||||
/course/#TermId/#Text CourseR !lecturer:
|
||||
/course/#TermId/#CourseShorthand CourseR !lecturer:
|
||||
/ CShowR GET !free
|
||||
/register CRegisterR POST !timeANDcapacity
|
||||
/edit CEditR GET POST
|
||||
/subs CCorrectionsR GET POST
|
||||
/ex SheetListR GET !registered !materials
|
||||
!/ex/new SheetNewR GET POST
|
||||
/ex/#Text SheetR:
|
||||
/ex/#SheetName SheetR:
|
||||
/ SShowR GET !timeANDregistered !timeANDmaterials !corrector
|
||||
/edit SEditR GET POST
|
||||
/delete SDelR GET POST
|
||||
|
||||
@ -98,7 +98,7 @@ makeFoundation appSettings@(AppSettings{..}) = do
|
||||
(pgPoolSize appDatabaseConf)
|
||||
|
||||
-- Perform database migration using our application's logging settings.
|
||||
runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
|
||||
runLoggingT (runSqlPool (runMigration $ migrateAll) pool) logFunc
|
||||
|
||||
-- Return the foundation
|
||||
return $ mkFoundation pool
|
||||
|
||||
@ -643,14 +643,14 @@ instance YesodBreadcrumbs UniWorX where
|
||||
|
||||
breadcrumb CourseListR = return ("Kurs" , Just HomeR)
|
||||
breadcrumb CourseNewR = return ("Neu" , Just CourseListR)
|
||||
breadcrumb (CourseR tid csh CShowR) = return (csh , Just $ TermCourseListR tid)
|
||||
breadcrumb (CourseR tid csh CShowR) = return (CI.original csh, Just $ TermCourseListR tid)
|
||||
-- (CourseR tid csh CRegisterR) -- is POST only
|
||||
breadcrumb (CourseR tid csh CEditR) = return ("Editieren", Just $ CourseR tid csh CShowR)
|
||||
breadcrumb (CourseR tid csh CCorrectionsR) = return ("Abgaben",Just $ CourseR tid csh CShowR)
|
||||
breadcrumb (CourseR tid csh SheetListR) = return ("Übungen" , Just $ CourseR tid csh CShowR)
|
||||
breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu", Just $ CourseR tid csh SheetListR)
|
||||
|
||||
breadcrumb (CSheetR tid csh shn SShowR) = return (shn, Just $ CourseR tid csh SheetListR)
|
||||
breadcrumb (CSheetR tid csh shn SShowR) = return (CI.original shn, Just $ CourseR tid csh SheetListR)
|
||||
breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSheetR tid csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid csh shn SShowR)
|
||||
@ -667,7 +667,7 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR)
|
||||
breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all
|
||||
|
||||
submissionList :: TermId -> Text -> Text -> UserId -> DB [E.Value SubmissionId]
|
||||
submissionList :: TermId -> CourseShorthand -> SheetName -> UserId -> DB [E.Value SubmissionId]
|
||||
submissionList tid csh shn uid = E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
|
||||
E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
||||
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||
@ -1031,7 +1031,7 @@ instance YesodAuth UniWorX where
|
||||
userEmail' = lookup "mail" credsExtra
|
||||
userDisplayName' = lookup "displayName" credsExtra
|
||||
|
||||
userEmail <- maybe (throwError $ ServerError "Could not retrieve user email") return userEmail'
|
||||
userEmail <- maybe (throwError $ ServerError "Could not retrieve user email") (return . CI.mk) userEmail'
|
||||
userDisplayName <- maybe (throwError $ ServerError "Could not retrieve user name") return userDisplayName'
|
||||
|
||||
AppSettings{..} <- getsYesod appSettings
|
||||
|
||||
@ -75,7 +75,7 @@ sheetIs :: Key Sheet -> CorrectionsWhere
|
||||
sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid
|
||||
|
||||
|
||||
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (E.Value Text, E.Value Text, E.Value (Key Term), E.Value (Key School)), Maybe (Entity User))
|
||||
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (E.Value CourseName, E.Value CourseShorthand, E.Value (Key Term), E.Value (Key School)), Maybe (Entity User))
|
||||
|
||||
colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colTerm = sortable (Just "term") (i18nCell MsgTerm)
|
||||
@ -127,7 +127,7 @@ makeCorrectionsTable whereClause colChoices psValidator = do
|
||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.where_ $ whereClause (course,sheet,submission)
|
||||
let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value Text)
|
||||
let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value CourseName)
|
||||
, course E.^. CourseShorthand
|
||||
, course E.^. CourseTerm
|
||||
, course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId)
|
||||
@ -309,7 +309,7 @@ postCorrectionsR = do
|
||||
[ downloadAction
|
||||
]
|
||||
|
||||
getCCorrectionsR, postCCorrectionsR :: TermId -> Text -> Handler TypedContent
|
||||
getCCorrectionsR, postCCorrectionsR :: TermId -> CourseShorthand -> Handler TypedContent
|
||||
getCCorrectionsR = postCCorrectionsR
|
||||
postCCorrectionsR tid csh = do
|
||||
Entity cid _ <- runDB $ getBy404 $ CourseTermShort tid csh
|
||||
@ -327,7 +327,7 @@ postCCorrectionsR tid csh = do
|
||||
, assignAction (Left cid)
|
||||
]
|
||||
|
||||
getSSubsR, postSSubsR :: TermId -> Text -> Text -> Handler TypedContent
|
||||
getSSubsR, postSSubsR :: TermId -> CourseShorthand -> SheetName -> Handler TypedContent
|
||||
getSSubsR = postSSubsR
|
||||
postSSubsR tid csh shn = do
|
||||
shid <- runDB $ fetchSheetId tid csh shn
|
||||
@ -357,7 +357,7 @@ correctionData tid csh shn sub = E.select . E.from $ \((course `E.InnerJoin` she
|
||||
|
||||
return (course, sheet, submission, corrector)
|
||||
|
||||
getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> Handler Html
|
||||
getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
||||
getCorrectionR tid csh shn cid = do
|
||||
mayPost <- isAuthorized (CSubmissionR tid csh shn cid CorrectionR) True
|
||||
bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid csh shn cid
|
||||
|
||||
@ -94,7 +94,7 @@ getTermCourseListR tid = do
|
||||
setTitleI . MsgTermCourseListTitle $ tid
|
||||
$(widgetFile "courses")
|
||||
|
||||
getCShowR :: TermId -> Text -> Handler Html
|
||||
getCShowR :: TermId -> CourseShorthand -> Handler Html
|
||||
getCShowR tid csh = do
|
||||
mbAid <- maybeAuthId
|
||||
(courseEnt,(schoolMB,participants,registered)) <- runDB $ do
|
||||
@ -130,7 +130,7 @@ registerForm registered msecret extra = do
|
||||
return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes
|
||||
|
||||
|
||||
postCRegisterR :: TermId -> Text -> Handler Html
|
||||
postCRegisterR :: TermId -> CourseShorthand -> Handler Html
|
||||
postCRegisterR tid csh = do
|
||||
aid <- requireAuthId
|
||||
(cid, course, registered) <- runDB $ do
|
||||
@ -159,12 +159,12 @@ getCourseNewR = do
|
||||
postCourseNewR :: Handler Html
|
||||
postCourseNewR = courseEditHandler False Nothing
|
||||
|
||||
getCEditR :: TermId -> Text -> Handler Html
|
||||
getCEditR :: TermId -> CourseShorthand -> Handler Html
|
||||
getCEditR tid csh = do
|
||||
course <- runDB $ getBy $ CourseTermShort tid csh
|
||||
courseEditHandler True course
|
||||
|
||||
postCEditR :: TermId -> Text -> Handler Html
|
||||
postCEditR :: TermId -> CourseShorthand -> Handler Html
|
||||
postCEditR tid csh = do
|
||||
course <- runDB $ getBy $ CourseTermShort tid csh
|
||||
courseEditHandler False course
|
||||
@ -255,8 +255,7 @@ courseEditHandler isGet course = do
|
||||
-- else addMessageI "danger" $ MsgCourseEditDupShort tid csh
|
||||
|
||||
(FormFailure _) -> addMessageI "warning" MsgInvalidInput
|
||||
(FormMissing) | isGet -> return ()
|
||||
other -> addMessage "error" $ [shamlet| Error: #{show other}|]
|
||||
(FormMissing) -> return ()
|
||||
actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
|
||||
defaultLayout $ do
|
||||
setTitleI MsgCourseEditTitle
|
||||
@ -265,10 +264,10 @@ courseEditHandler isGet course = do
|
||||
|
||||
data CourseForm = CourseForm
|
||||
{ cfCourseId :: Maybe CourseId -- Maybe CryptoUUIDCourse
|
||||
, cfName :: Text
|
||||
, cfName :: CourseName
|
||||
, cfDesc :: Maybe Html
|
||||
, cfLink :: Maybe Text
|
||||
, cfShort :: Text
|
||||
, cfShort :: CourseShorthand
|
||||
, cfTerm :: TermId
|
||||
, cfSchool :: SchoolId
|
||||
, cfCapacity :: Maybe Int64
|
||||
@ -279,10 +278,6 @@ data CourseForm = CourseForm
|
||||
, cfDeRegUntil :: Maybe UTCTime
|
||||
}
|
||||
|
||||
instance Show CourseForm where
|
||||
show cf = T.unpack (cfShort cf) ++ ' ':(show $ cfCourseId cf)
|
||||
|
||||
|
||||
courseToForm :: Entity Course -> CourseForm
|
||||
courseToForm cEntity = CourseForm
|
||||
{ cfCourseId = Just $ entityKey cEntity
|
||||
@ -312,10 +307,10 @@ newCourseForm template = identForm FIDcourse $ \html -> do
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
|
||||
-- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work?
|
||||
<$> aopt hiddenField "KursId" (cfCourseId <$> template)
|
||||
<*> areq textField (fsb "Name") (cfName <$> template)
|
||||
<*> areq (ciField textField) (fsb "Name") (cfName <$> template)
|
||||
<*> aopt htmlField (fsb "Beschreibung") (cfDesc <$> template)
|
||||
<*> aopt urlField (fsb "Homepage") (cfLink <$> template)
|
||||
<*> areq textField (fsb "Kürzel"
|
||||
<*> areq (ciField textField) (fsb "Kürzel"
|
||||
-- & addAttr "disabled" "disabled"
|
||||
& setTooltip "Muss innerhalb des Semesters eindeutig sein")
|
||||
(cfShort <$> template)
|
||||
|
||||
@ -115,8 +115,8 @@ homeUser uid = do
|
||||
-- (E.SqlExpr (Entity Course )))
|
||||
-- (E.SqlExpr (Entity Sheet ))
|
||||
_ -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term))
|
||||
, E.SqlExpr (E.Value Text)
|
||||
, E.SqlExpr (E.Value Text)
|
||||
, E.SqlExpr (E.Value CourseShorthand)
|
||||
, E.SqlExpr (E.Value SheetName)
|
||||
, E.SqlExpr (E.Value UTCTime)
|
||||
, E.SqlExpr (E.Value (Maybe SubmissionId)))
|
||||
tableData ((participant `E.InnerJoin` course `E.InnerJoin` sheet) `E.LeftOuterJoin` (submission `E.InnerJoin` subuser)) = do
|
||||
@ -138,8 +138,8 @@ homeUser uid = do
|
||||
)
|
||||
|
||||
colonnade :: Colonnade Sortable (DBRow ( E.Value (Key Term)
|
||||
, E.Value Text
|
||||
, E.Value Text
|
||||
, E.Value CourseShorthand
|
||||
, E.Value SheetName
|
||||
, E.Value UTCTime
|
||||
, E.Value (Maybe SubmissionId)
|
||||
))
|
||||
|
||||
@ -34,6 +34,9 @@ import Text.Blaze (text)
|
||||
import qualified Data.UUID.Cryptographic as UUID
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Internal.Sql as E
|
||||
|
||||
@ -68,7 +71,7 @@ instance Eq (Unique Sheet) where
|
||||
-}
|
||||
|
||||
data SheetForm = SheetForm
|
||||
{ sfName :: Text
|
||||
{ sfName :: SheetName
|
||||
, sfDescription :: Maybe Html
|
||||
, sfType :: SheetType
|
||||
, sfGrouping :: SheetGroup
|
||||
@ -101,7 +104,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
||||
mr <- getMsgRenderer
|
||||
ctime <- liftIO $ getCurrentTime
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
|
||||
<$> areq textField (fsb "Name") (sfName <$> template)
|
||||
<$> areq (ciField textField) (fsb "Name") (sfName <$> template)
|
||||
<*> aopt htmlField (fsb "Hinweise für Teilnehmer") (sfDescription <$> template)
|
||||
<*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template)
|
||||
<*> sheetGroupAFormReq (fsb "Abgabegruppengröße") (sfGrouping <$> template)
|
||||
@ -151,7 +154,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
||||
, ( NTop sfSolutionFrom >= NTop (Just sfActiveTo) , render MsgSheetErrSolutionEarly)
|
||||
] ]
|
||||
|
||||
getSheetListR :: TermId -> Text -> Handler Html
|
||||
getSheetListR :: TermId -> CourseShorthand -> Handler Html
|
||||
getSheetListR tid csh = do
|
||||
Entity cid _ <- runDB . getBy404 $ CourseTermShort tid csh
|
||||
let
|
||||
@ -208,7 +211,7 @@ getSheetListR tid csh = do
|
||||
|
||||
|
||||
-- Show single sheet
|
||||
getSShowR :: TermId -> Text -> Text -> Handler Html
|
||||
getSShowR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSShowR tid csh shn = do
|
||||
entSheet <- runDB $ fetchSheet tid csh shn
|
||||
let sheet = entityVal entSheet
|
||||
@ -267,14 +270,14 @@ getSShowR tid csh shn = do
|
||||
hasSolution <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetSolution ]
|
||||
return (hasHints, hasSolution)
|
||||
defaultLayout $ do
|
||||
setTitle $ toHtml $ T.append "Übung " $ sheetName sheet
|
||||
setTitleI $ MsgSheetTitle tid csh shn
|
||||
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
|
||||
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
|
||||
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
|
||||
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
|
||||
$(widgetFile "sheetShow")
|
||||
|
||||
getSFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
|
||||
getSFileR :: TermId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
|
||||
getSFileR tid csh shn typ title = do
|
||||
results <- runDB $ E.select $ E.from $
|
||||
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
|
||||
@ -303,18 +306,18 @@ getSFileR tid csh shn typ title = do
|
||||
$logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
|
||||
error "Multiple matching files found."
|
||||
|
||||
getSheetNewR :: TermId -> Text -> Handler Html
|
||||
getSheetNewR :: TermId -> CourseShorthand -> Handler Html
|
||||
getSheetNewR tid csh = do
|
||||
let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days
|
||||
let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
|
||||
insertUnique $ newSheet
|
||||
handleSheetEdit tid csh Nothing template action
|
||||
|
||||
postSheetNewR :: TermId -> Text -> Handler Html
|
||||
postSheetNewR :: TermId -> CourseShorthand -> Handler Html
|
||||
postSheetNewR = getSheetNewR
|
||||
|
||||
|
||||
getSEditR :: TermId -> Text -> Text -> Handler Html
|
||||
getSEditR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSEditR tid csh shn = do
|
||||
(sheetEnt, sheetFileIds) <- runDB $ do
|
||||
ent <- fetchSheet tid csh shn
|
||||
@ -345,10 +348,10 @@ getSEditR tid csh shn = do
|
||||
(Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here
|
||||
handleSheetEdit tid csh (Just sid) template action
|
||||
|
||||
postSEditR :: TermId -> Text -> Text -> Handler Html
|
||||
postSEditR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
postSEditR = getSEditR
|
||||
|
||||
handleSheetEdit :: TermId -> Text -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
|
||||
handleSheetEdit :: TermId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
|
||||
handleSheetEdit tid csh msId template dbAction = do
|
||||
let mbshn = sfName <$> template
|
||||
aid <- requireAuthId
|
||||
@ -396,7 +399,7 @@ handleSheetEdit tid csh msId template dbAction = do
|
||||
|
||||
|
||||
|
||||
getSDelR :: TermId -> Text -> Text -> Handler Html
|
||||
getSDelR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSDelR tid csh shn = do
|
||||
((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
|
||||
case result of
|
||||
@ -417,7 +420,7 @@ getSDelR tid csh shn = do
|
||||
setTitleI $ MsgSheetTitle tid csh shn
|
||||
$(widgetFile "formPageI18n")
|
||||
|
||||
postSDelR :: TermId -> Text -> Text -> Handler Html
|
||||
postSDelR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
postSDelR = getSDelR
|
||||
|
||||
|
||||
@ -505,8 +508,8 @@ correctorForm shid = do
|
||||
|
||||
(countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\Load{..} -> fromMaybe False byTutorial) $ Map.elems loads'
|
||||
let
|
||||
tutorField :: Field Handler [Text]
|
||||
tutorField = multiEmailField
|
||||
tutorField :: Field Handler [UserEmail]
|
||||
tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField
|
||||
{ fieldView = \theId name attrs val isReq -> asWidgetT $ do
|
||||
listIdent <- newIdent
|
||||
userId <- handlerToWidget requireAuthId
|
||||
@ -616,10 +619,7 @@ correctorForm shid = do
|
||||
-- Eingabebox für Korrektor hinzufügen
|
||||
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
|
||||
|
||||
getSCorrR, postSCorrR :: TermId
|
||||
-> Text -- ^ Course shorthand
|
||||
-> Text -- ^ Sheet name
|
||||
-> Handler Html
|
||||
getSCorrR, postSCorrR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
postSCorrR = getSCorrR
|
||||
getSCorrR tid csh shn = do
|
||||
Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn
|
||||
|
||||
@ -61,11 +61,11 @@ numberOfSubmissionEditDates :: Int64
|
||||
numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
|
||||
|
||||
|
||||
makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [Text] -> Form (Maybe (Source Handler File), [Text])
|
||||
makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail])
|
||||
makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do
|
||||
flip (renderAForm FormStandard) html $ (,)
|
||||
<$> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
|
||||
<*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies textField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
|
||||
<*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies (ciField textField) (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
|
||||
| g <- [1..(max groupNr $ length buddies)] -- groupNr might have decreased meanwhile
|
||||
| buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
|
||||
])
|
||||
@ -78,16 +78,16 @@ makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $
|
||||
aforced' f fs (Just (Just v)) = Just <$> aforced f fs v
|
||||
aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary"
|
||||
|
||||
getSubmissionNewR, postSubmissionNewR :: TermId -> Text -> Text -> Handler Html
|
||||
getSubmissionNewR, postSubmissionNewR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSubmissionNewR = postSubmissionNewR
|
||||
postSubmissionNewR tid csh shn = submissionHelper tid csh shn NewSubmission
|
||||
|
||||
|
||||
getSubShowR, postSubShowR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> Handler Html
|
||||
getSubShowR, postSubShowR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
||||
getSubShowR = postSubShowR
|
||||
postSubShowR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid
|
||||
|
||||
getSubmissionOwnR :: TermId -> Text -> Text -> Handler Html
|
||||
getSubmissionOwnR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSubmissionOwnR tid csh shn = do
|
||||
authId <- requireAuthId
|
||||
sid <- runDB $ do
|
||||
@ -103,7 +103,7 @@ getSubmissionOwnR tid csh shn = do
|
||||
cID <- encrypt sid
|
||||
redirect $ CSubmissionR tid csh shn cID SubShowR
|
||||
|
||||
submissionHelper :: TermId -> Text -> Text -> SubmissionMode -> Handler Html
|
||||
submissionHelper :: TermId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html
|
||||
submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
uid <- requireAuthId
|
||||
msmid <- traverse decrypt mcid
|
||||
@ -167,14 +167,13 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
(FormMissing ) -> return $ FormMissing
|
||||
(FormFailure failmsgs) -> return $ FormFailure failmsgs
|
||||
(FormSuccess (mFiles,[])) -> return $ FormSuccess (mFiles,[]) -- Type change
|
||||
(FormSuccess (mFiles, (map CI.mk -> gEMails@(_:_)))) -- Validate AdHoc Group Members
|
||||
(FormSuccess (mFiles,gEMails@(_:_))) -- Validate AdHoc Group Members
|
||||
| (Arbitrary {..}) <- sheetGrouping -> do
|
||||
-- , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for
|
||||
let gemails = map CI.foldedCase gEMails
|
||||
prep :: [(E.Value Text, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool))
|
||||
prep ps = Map.filter (maybe True $ \(i,_,_) -> i /= uid) . Map.fromList $ map (, Nothing) gEMails ++ [(CI.mk m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps]
|
||||
let prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool))
|
||||
prep ps = Map.filter (maybe True $ \(i,_,_) -> i /= uid) . Map.fromList $ map (, Nothing) gEMails ++ [(m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps]
|
||||
participants <- fmap prep . E.select . E.from $ \user -> do
|
||||
E.where_ $ (E.lower_ $ user E.^. UserEmail) `E.in_` E.valList gemails
|
||||
E.where_ $ (user E.^. UserEmail) `E.in_` E.valList gEMails
|
||||
let
|
||||
isParticipant = E.sub_select . E.from $ \courseParticipant -> do
|
||||
E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
|
||||
@ -196,9 +195,9 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
let
|
||||
failmsgs = (concat :: [[Text]] -> [Text])
|
||||
[ flip Map.foldMapWithKey participants $ \email -> \case
|
||||
Nothing -> pure . mr $ MsgEMailUnknown $ CI.original email
|
||||
(Just (_,False,_)) -> pure . mr $ MsgNotAParticipant (CI.original email) tid csh
|
||||
(Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor (CI.original email)
|
||||
Nothing -> pure . mr $ MsgEMailUnknown email
|
||||
(Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh
|
||||
(Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email
|
||||
_other -> mempty
|
||||
, case length participants `compare` maxParticipants of
|
||||
LT -> mempty
|
||||
@ -307,7 +306,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
$(widgetFile "submission")
|
||||
|
||||
|
||||
getSubDownloadR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
|
||||
getSubDownloadR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
|
||||
getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
|
||||
runDB $ do
|
||||
submissionID <- submissionMatchesSheet tid csh shn cID
|
||||
@ -343,7 +342,7 @@ getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path =
|
||||
$logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other
|
||||
error "Multiple matching files found."
|
||||
|
||||
getSubArchiveR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
|
||||
getSubArchiveR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
|
||||
getSubArchiveR tid csh shn cID@CryptoID{..} (ZIPArchiveName sfType) = do
|
||||
when (sfType == SubmissionCorrected) $
|
||||
guardAuthResult =<< evalAccess (CSubmissionR tid csh shn cID CorrectionR) False
|
||||
|
||||
@ -23,6 +23,9 @@ import Import
|
||||
import qualified Data.Char as Char
|
||||
import Data.String (IsString(..))
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.Foldable as Foldable
|
||||
|
||||
-- import Yesod.Core
|
||||
@ -263,6 +266,8 @@ buttonForm csrf = do
|
||||
-- Fields --
|
||||
------------
|
||||
|
||||
ciField :: (Functor m, CI.FoldCase a) => Field m a -> Field m (CI a)
|
||||
ciField = convertField CI.mk CI.original
|
||||
|
||||
natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
|
||||
natFieldI msg = checkBool (>= 0) msg intField
|
||||
|
||||
@ -66,8 +66,8 @@ instance Pretty x => Pretty (CI x) where
|
||||
|
||||
|
||||
data Rating = Rating
|
||||
{ ratingCourseName :: Text
|
||||
, ratingSheetName :: Text
|
||||
{ ratingCourseName :: CourseName
|
||||
, ratingSheetName :: SheetName
|
||||
, ratingCorrectorName :: Maybe Text
|
||||
, ratingSheetType :: SheetType
|
||||
, ratingValues :: Rating'
|
||||
|
||||
@ -24,7 +24,7 @@ fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
|
||||
, PersistQueryRead backend, PersistUniqueRead backend
|
||||
)
|
||||
=> (E.SqlExpr (Entity Sheet) -> b)
|
||||
-> TermId -> Text -> Text -> ReaderT backend m a
|
||||
-> TermId -> CourseShorthand -> SheetName -> ReaderT backend m a
|
||||
fetchSheetAux prj tid csh shn =
|
||||
let cachId = encodeUtf8 $ tshow (tid,csh,shn)
|
||||
in cachedBy cachId $ do
|
||||
@ -42,11 +42,11 @@ fetchSheetAux prj tid csh shn =
|
||||
[sheet] -> return sheet
|
||||
_other -> notFound
|
||||
|
||||
fetchSheet :: TermId -> Text -> Text -> YesodDB UniWorX (Entity Sheet)
|
||||
fetchSheet :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet)
|
||||
fetchSheet = fetchSheetAux id
|
||||
|
||||
fetchSheetId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet)
|
||||
fetchSheetId :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet)
|
||||
fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn
|
||||
|
||||
fetchSheetIdCourseId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet, Key Course)
|
||||
fetchSheetIdCourseId :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course)
|
||||
fetchSheetIdCourseId tid cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid cid shn
|
||||
|
||||
@ -509,7 +509,7 @@ sinkMultiSubmission userId isUpdate = do
|
||||
handleCryptoID _ = return Nothing
|
||||
|
||||
|
||||
submissionMatchesSheet :: TermId -> Text -> Text -> CryptoFileNameSubmission -> DB SubmissionId
|
||||
submissionMatchesSheet :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> DB SubmissionId
|
||||
submissionMatchesSheet tid csh shn cid = do
|
||||
sid <- decrypt cid
|
||||
shid <- fetchSheetId tid csh shn
|
||||
|
||||
11
src/Model.hs
11
src/Model.hs
@ -15,18 +15,27 @@ module Model
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Database.Persist.Quasi
|
||||
import Database.Persist.Postgresql (migrateEnableExtension)
|
||||
import Database.Persist.Sql (Migration)
|
||||
-- import Data.Time
|
||||
-- import Data.ByteString
|
||||
import Model.Types
|
||||
import Data.Aeson.TH
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
|
||||
-- You can define all of your database entities in the entities file.
|
||||
-- You can find more information on persistent and how to declare entities
|
||||
-- at:
|
||||
-- http://www.yesodweb.com/book/persistent/
|
||||
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll"]
|
||||
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'"]
|
||||
$(persistFileWith lowerCaseSettings "models")
|
||||
|
||||
migrateAll :: Migration
|
||||
migrateAll = do
|
||||
migrateEnableExtension "citext"
|
||||
migrateAll'
|
||||
|
||||
data PWEntry = PWEntry
|
||||
{ pwUser :: User
|
||||
, pwHash :: Text
|
||||
|
||||
@ -8,6 +8,7 @@
|
||||
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-- # LANGUAGE ExistentialQuantification #-} -- for DA type
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Model.Types where
|
||||
|
||||
@ -28,10 +29,11 @@ import Web.HttpApiData
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
|
||||
import Text.Read (readMaybe,readsPrec)
|
||||
|
||||
-- import Data.CaseInsensitive (CI)
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Yesod.Core.Dispatch (PathPiece(..))
|
||||
@ -41,6 +43,10 @@ import Data.Aeson.TH (deriveJSON, defaultOptions)
|
||||
import GHC.Generics (Generic)
|
||||
import Data.Typeable (Typeable)
|
||||
|
||||
import Text.Shakespeare.I18N (ToMessage(..), RenderMessage(..))
|
||||
import Text.Blaze (ToMarkup(..))
|
||||
import Yesod.Core.Widget (ToWidget(..))
|
||||
|
||||
|
||||
type Points = Centi
|
||||
|
||||
@ -317,3 +323,43 @@ newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
|
||||
|
||||
data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded)
|
||||
|
||||
|
||||
instance PersistField (CI Text) where
|
||||
toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
|
||||
fromPersistValue (PersistDbSpecific bs) = Right . CI.mk $ Text.decodeUtf8 bs
|
||||
fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
|
||||
|
||||
instance PersistField (CI String) where
|
||||
toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 . pack $ CI.original ciText
|
||||
fromPersistValue (PersistDbSpecific bs) = Right . CI.mk . unpack $ Text.decodeUtf8 bs
|
||||
fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
|
||||
|
||||
instance PersistFieldSql (CI Text) where
|
||||
sqlType _ = SqlOther "citext"
|
||||
|
||||
instance ToJSON a => ToJSON (CI a) where
|
||||
toJSON = toJSON . CI.original
|
||||
|
||||
instance (FromJSON a, CI.FoldCase a) => FromJSON (CI a) where
|
||||
parseJSON = fmap CI.mk . parseJSON
|
||||
|
||||
instance ToMessage a => ToMessage (CI a) where
|
||||
toMessage = toMessage . CI.original
|
||||
|
||||
instance ToMarkup a => ToMarkup (CI a) where
|
||||
toMarkup = toMarkup . CI.original
|
||||
preEscapedToMarkup = preEscapedToMarkup . CI.original
|
||||
|
||||
instance ToWidget site a => ToWidget site (CI a) where
|
||||
toWidget = toWidget . CI.original
|
||||
|
||||
instance RenderMessage site a => RenderMessage site (CI a) where
|
||||
renderMessage f ls msg = renderMessage f ls $ CI.original msg
|
||||
|
||||
-- Type synonyms
|
||||
|
||||
type SheetName = CI Text
|
||||
type CourseShorthand = CI Text
|
||||
type CourseName = CI Text
|
||||
type UserEmail = CI Text
|
||||
|
||||
Loading…
Reference in New Issue
Block a user