Make a bunch of things case insensitive in database

Fixes #96

Might require manual database migration

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.
+CourseNewOk        tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich erstellt.
-CourseEditOk       tid@TermId courseShortHand@Text: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich geändert.
+CourseEditOk       tid@TermId courseShortHand@CourseShorthand: 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.
+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@Text: Kurs #{display tid}-#{courseShortHand} konnte nicht geändert 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
+SheetList          tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Übersicht Übungsblätter
-SheetNewHeading    tid@TermId courseShortHand@Text: #{display tid}-#{courseShortHand} Neues Übungsblatt anlegen
+SheetNewHeading    tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Neues Übungsblatt anlegen
-SheetNewOk         tid@TermId courseShortHand@Text sheetName@Text: Neues Übungsblatt #{sheetName} wurde im Kurs #{display tid}-#{courseShortHand} erfolgreich erstellt.
+SheetNewOk         tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Neues Übungsblatt #{sheetName} wurde im Kurs #{display tid}-#{courseShortHand} erfolgreich erstellt.
-SheetTitle         tid@TermId courseShortHand@Text sheetName@Text: #{display tid}-#{courseShortHand} #{sheetName}
+SheetTitle         tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName}
-SheetTitleNew      tid@TermId courseShortHand@Text               : #{display tid}-#{courseShortHand}: Neues Übungsblatt
+SheetTitleNew      tid@TermId courseShortHand@CourseShorthand               : #{display tid}-#{courseShortHand}: Neues Übungsblatt
-SheetEditHead      tid@TermId courseShortHand@Text sheetName@Text: #{display tid}-#{courseShortHand} #{sheetName} editieren
+SheetEditHead      tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName} editieren
-SheetEditOk        tid@TermId courseShortHand@Text sheetName@Text: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{courseShortHand} wurde gespeichert.
+SheetEditOk        tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Ü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}.
+SheetNameDup       tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: 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?
+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}
+SubmissionsCourse tid@TermId courseShortHand@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{courseShortHand}
-SubmissionsSheet sheetName@Text: Abgaben für Blatt #{sheetName}
+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
+SubmissionEditHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen
-CorrectionHead tid@TermId courseShortHand@Text sheetName@Text cid@CryptoFileNameSubmission: #{display tid}-#{courseShortHand} #{sheetName}: Korrektur
+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.
+EMailUnknown email@UserEmail: 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.
+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
+CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
-SheetCorrectorsTitle tid@TermId courseShortHand@Text sheetName@Text: Korrektoren für #{display tid}-#{courseShortHand} #{sheetName}
+SheetCorrectorsTitle tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{courseShortHand} #{sheetName}
 CountTutProp: Tutorien zählen gegen Proportion
 Corrector: Korrektor
 Correctors: Korrektoren

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 
+    name          (CI Text)
-    shorthand     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

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

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

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

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

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 ()
+      (FormMissing) -> return ()
-      other -> addMessage "error" $ [shamlet| Error: #{show other}|]
     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)

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 CourseShorthand)
-                                , E.SqlExpr (E.Value Text)
+                                , 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 CourseShorthand
-                                             , E.Value Text
+                                             , E.Value SheetName
                                              , E.Value UTCTime
                                              , E.Value (Maybe SubmissionId)
                                              ))

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 :: Field Handler [UserEmail]
-    tutorField = multiEmailField
+    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
+getSCorrR, postSCorrR :: TermId -> CourseShorthand -> SheetName -> Handler Html
-                      -> Text -- ^ Course shorthand
-                      -> Text -- ^ Sheet name
-                      -> Handler Html
 postSCorrR = getSCorrR
 getSCorrR tid csh shn = do
   Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn

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
+          let prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool))
-              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 ++ [(m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps]
-              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]
           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
+                  Nothing            -> pure . mr $ MsgEMailUnknown email
-                  (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant (CI.original email) tid csh
+                  (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh
-                  (Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor (CI.original email)
+                  (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

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

src/Handler/Utils/Rating.hs

@@ -66,8 +66,8 @@ instance Pretty x => Pretty (CI x) where
 
 
 data Rating = Rating
-  { ratingCourseName :: Text
+  { ratingCourseName :: CourseName
-  , ratingSheetName :: Text
+  , ratingSheetName :: SheetName
   , ratingCorrectorName :: Maybe Text
   , ratingSheetType :: SheetType
   , ratingValues :: Rating'

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

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

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

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