From 51c04aec2082b1dda71e3fc589763fa07fd7fef2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 22 Jul 2018 18:49:39 +0200 Subject: [PATCH] Make a bunch of things case insensitive in database Fixes #96 Might require manual database migration --- messages/de.msg | 50 ++++++++++++++++----------------- models | 14 +++++---- routes | 4 +-- src/Application.hs | 2 +- src/Foundation.hs | 8 +++--- src/Handler/Corrections.hs | 10 +++---- src/Handler/Course.hs | 23 ++++++--------- src/Handler/Home.hs | 8 +++--- src/Handler/Sheet.hs | 38 ++++++++++++------------- src/Handler/Submission.hs | 31 ++++++++++---------- src/Handler/Utils/Form.hs | 5 ++++ src/Handler/Utils/Rating.hs | 4 +-- src/Handler/Utils/Sheet.hs | 8 +++--- src/Handler/Utils/Submission.hs | 2 +- src/Model.hs | 11 +++++++- src/Model/Types.hs | 48 ++++++++++++++++++++++++++++++- 16 files changed, 161 insertions(+), 105 deletions(-) diff --git a/messages/de.msg b/messages/de.msg index c28db3a46..b61a36e31 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -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 diff --git a/models b/models index 0fbb50c92..47f6f824a 100644 --- a/models +++ b/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 diff --git a/routes b/routes index 0adcb0bf7..f207525b7 100644 --- a/routes +++ b/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 diff --git a/src/Application.hs b/src/Application.hs index 4d9e54e11..aa4685549 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 44c02a3c0..ac7cd37d2 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index db8da1dda..412d380c5 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 5d3ee913c..38cfbe239 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -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) diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 0448c1718..786828b70 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -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) )) diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 06fe311ba..64cc2a6b2 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -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 diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index f85c0f0fd..37e2c9c56 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 4c549109a..280f5dfa6 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -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 diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 2ec19d999..9fa4b97d1 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -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' diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs index 76fed4737..dbcd79dd9 100644 --- a/src/Handler/Utils/Sheet.hs +++ b/src/Handler/Utils/Sheet.hs @@ -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 diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 6b591928f..c7280bc7e 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -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 diff --git a/src/Model.hs b/src/Model.hs index 1feeab96e..b810d9588 100644 --- a/src/Model.hs +++ b/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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index f1af94def..2d62a610b 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -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