From 93c8b0062a397af1fcd8c3ae6b4bfd5c59eedffd Mon Sep 17 00:00:00 2001
From: Felix Hamann <felix.hamann@campus.lmu.de>
Date: Wed, 18 Jul 2018 21:58:44 +0200
Subject: [PATCH 01/17] content centered when logged-out

---
 templates/default-layout.lucius | 10 +++++++++-
 1 file changed, 9 insertions(+), 1 deletion(-)

diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius
index 9ec372125..25a12154c 100644
--- a/templates/default-layout.lucius
+++ b/templates/default-layout.lucius
@@ -171,6 +171,8 @@ h4 {
   background-color: white;
   overflow: hidden;
   transition: padding-left .2s ease-out;
+  max-width: 1200px;
+  margin: 0 auto;
 
   > .container {
     margin: 20px 0;
@@ -185,6 +187,13 @@ h4 {
   }
 }
 
+.logged-in {
+  .main__content {
+    margin: 0;
+    max-width: none;
+  }
+}
+
 @media (max-width: 768px) {
   .logged-in {
     .main__content {
@@ -210,7 +219,6 @@ h4 {
 }
 
 @media (min-width: 1200px) {
-
   .logged-in {
     .main__content {
       padding-left: 320px;

From 69125f5704987c4645cbde90d3d4a2301a916bf3 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Fri, 20 Jul 2018 11:48:33 +0200
Subject: [PATCH 02/17] Implement submission blacklist

Fixes #130
---
 config/submission-blacklist                   | 12 +++++
 messages/de.msg                               |  2 +
 package.yaml                                  |  1 +
 src/Handler/Corrections.hs                    |  4 +-
 src/Handler/Submission.hs                     |  2 +-
 src/Handler/Utils.hs                          |  2 +-
 src/Handler/Utils/Submission.hs               | 45 ++++++++++++++++++-
 src/Handler/Utils/Submission/TH.hs            | 39 ++++++++++++++++
 .../messages/submissionFilesIgnored.hamlet    |  4 ++
 9 files changed, 105 insertions(+), 6 deletions(-)
 create mode 100644 config/submission-blacklist
 create mode 100644 src/Handler/Utils/Submission/TH.hs
 create mode 100644 templates/messages/submissionFilesIgnored.hamlet

diff --git a/config/submission-blacklist b/config/submission-blacklist
new file mode 100644
index 000000000..1027b869b
--- /dev/null
+++ b/config/submission-blacklist
@@ -0,0 +1,12 @@
+$# Syntax:
+$#   - Leere zeilen werden ignoriert
+$#   - Zeilen, die mit '$#' beginnen, werden ignoriert
+$#   - Verbleibende Zeilen werden jeweils als `Glob`-Pattern kompiliert
+
+$# Ignoriere rekursiv alle Ordner __MACOSX und ihren Inhalt
+**/__MACOSX
+**/__MACOSX/*
+**/__MACOSX/**/*
+
+$# Ignoriere rekursiv alle Dateien .DS_Store
+**/.DS_Store
\ No newline at end of file
diff --git a/messages/de.msg b/messages/de.msg
index 0c7147ecd..a5a17e6fa 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -221,3 +221,5 @@ AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC ko
 LastEdits: Letzte Änderungen
 EditedBy name@Text time@Text: Durch #{name} um #{time}
 LastEdit: Letzte Änderung
+
+SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert:
\ No newline at end of file
diff --git a/package.yaml b/package.yaml
index 2133c682c..f6aba2b60 100644
--- a/package.yaml
+++ b/package.yaml
@@ -87,6 +87,7 @@ dependencies:
 - system-locale
 - th-lift-instances
 - gitrev
+- Glob
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 7379ae4c0..b861990b5 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -403,7 +403,7 @@ postCorrectionR tid csh shn cid = do
         FormSuccess fileSource -> do
           uid <- requireAuthId
           
-          runDB . runConduit $ transPipe lift fileSource .| extractRatings .| sinkSubmission uid (Right sub) True
+          runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
 
           addMessageI "success" MsgRatingFilesUpdated
           redirect $ CSubmissionR tid csh shn cid CorrectionR
@@ -438,7 +438,7 @@ postCorrectionsUploadR = do
     FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
     FormSuccess files -> do
       uid <- requireAuthId
-      subs <- runDB . runConduit $ transPipe lift files .| extractRatings .| sinkMultiSubmission uid True
+      subs <- runDB . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkMultiSubmission uid True
       subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
       mr <- (toHtml .) <$> getMessageRender
       addMessage "success" =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index 483443b75..8b71cbefb 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -220,7 +220,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
             (Nothing, Just smid)   -- no new files, existing submission partners updated
               -> return smid
             (Just files, _)  -- new files
-              -> runConduit $ transPipe lift files .| extractRatings .| sinkSubmission uid (maybe (Left shid) Right msmid) False
+              -> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
             _ -> error "Impossible, because of definition of `makeSubmissionForm`"
           -- Determine members of pre-registered group
           groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs
index 72a833f48..b173b2219 100644
--- a/src/Handler/Utils.hs
+++ b/src/Handler/Utils.hs
@@ -17,7 +17,7 @@ import Handler.Utils.Table as Handler.Utils
 import Handler.Utils.Table.Pagination as Handler.Utils
 
 import Handler.Utils.Zip        as Handler.Utils
-import Handler.Utils.Rating     as Handler.Utils
+import Handler.Utils.Rating     as Handler.Utils hiding (extractRatings)
 import Handler.Utils.Submission as Handler.Utils
 import Handler.Utils.Sheet      as Handler.Utils
 import Handler.Utils.Templates  as Handler.Utils
diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs
index 0bed9cd36..b65705bd1 100644
--- a/src/Handler/Utils/Submission.hs
+++ b/src/Handler/Utils/Submission.hs
@@ -15,6 +15,7 @@
 module Handler.Utils.Submission
   ( AssignSubmissionException(..)
   , assignSubmissions
+  , submissionBlacklist, filterSubmission, extractRatings, extractRatingsMsg
   , submissionFileSource, submissionFileQuery
   , submissionMultiArchive 
   , SubmissionSinkException(..)
@@ -29,6 +30,7 @@ import Control.Lens.Extras (is)
 import Utils.Lens
 
 import Control.Monad.State hiding (forM_, mapM_,foldM)
+import Control.Monad.Writer (MonadWriter(..))
 import qualified Control.Monad.Random as Rand
 
 import Data.Maybe
@@ -45,16 +47,22 @@ import qualified Data.CaseInsensitive as CI
 import Data.Monoid (Monoid, Any(..))
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 
-import Handler.Utils.Rating
+import Handler.Utils.Rating hiding (extractRatings)
+import qualified Handler.Utils.Rating as Rating (extractRatings)
 import Handler.Utils.Zip
 import Handler.Utils.Sheet
+import Handler.Utils.Submission.TH
 
 import qualified Database.Esqueleto as E
 
+import Data.Conduit
 import qualified Data.Conduit.List as Conduit
 import Data.Conduit.ResumableSink
 
 import System.FilePath
+import System.FilePath.Glob
+
+import Text.Hamlet (ihamletFile)
 
 
 data AssignSubmissionException = NoCorrectorsByProportion
@@ -191,6 +199,39 @@ data SubmissionSinkException = DuplicateFileTitle FilePath
 
 instance Exception SubmissionSinkException
 
+submissionBlacklist :: [Pattern]
+submissionBlacklist = $(patternFile compDefault "config/submission-blacklist")
+
+filterSubmission :: MonadLogger m => ConduitM File File m (Set FilePath)
+-- ^ Removes all `File`s matching `submissionBlacklist`, returning their `fileTitle`s
+filterSubmission = do
+  $logDebugS "filterSubmission" $ tshow submissionBlacklist
+  execWriterLC . awaitForever $ \case
+    File{fileTitle}
+      | any (`match'` fileTitle) submissionBlacklist -> tell $ Set.singleton fileTitle
+    file -> yield file
+  where
+    match' = matchWith $ matchDefault
+      { matchDotsImplicitly = True -- Special treatment for . makes no sense since we're multiplatform
+      }
+
+extractRatings :: ( MonadHandler m
+                  , HandlerSite m ~ UniWorX
+                  , MonadCatch m
+                  , MonadLogger m
+                  ) => ConduitM File SubmissionContent m (Set FilePath)
+extractRatings = filterSubmission `fuseUpstream` Rating.extractRatings
+
+extractRatingsMsg :: ( MonadHandler m
+                     , HandlerSite m ~ UniWorX
+                     , MonadCatch m
+                     , MonadLogger m
+                     ) => Conduit File m SubmissionContent
+extractRatingsMsg = do
+  ignored <- filterSubmission `fuseUpstream` Rating.extractRatings
+  mr <- (toHtml . ) <$> getMessageRender
+  addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
+
 sinkSubmission :: UserId
                -> Either SheetId SubmissionId
                -> Bool -- ^ Is this a correction
@@ -228,7 +269,7 @@ sinkSubmission userId mExists isUpdate = do
     sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
       Left file@(File{..}) -> do
         $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle)
-        
+
         alreadySeen <- gets (Set.member fileTitle . sinkFilenames)
         when alreadySeen . throwM $ DuplicateFileTitle fileTitle
         tell $ mempty{ sinkFilenames = Set.singleton fileTitle  }
diff --git a/src/Handler/Utils/Submission/TH.hs b/src/Handler/Utils/Submission/TH.hs
new file mode 100644
index 000000000..99de8a01f
--- /dev/null
+++ b/src/Handler/Utils/Submission/TH.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE NoImplicitPrelude
+           , TemplateHaskell
+           , ViewPatterns
+           , OverloadedStrings
+           , StandaloneDeriving
+           , DeriveLift
+  #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Handler.Utils.Submission.TH
+  ( patternFile
+  ) where
+
+import ClassyPrelude.Yesod
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (qAddDependentFile, Lift(..))
+
+import System.FilePath.Glob
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+
+deriving instance Lift CompOptions
+
+-- $(patternFile compDefault file) :: [System.FilePath.Glob.Pattern]
+patternFile :: CompOptions -> FilePath -> ExpQ
+patternFile opts file = do
+  qAddDependentFile file
+  patternStrings <- runIO $ filter (not . isComment) . Text.lines <$> Text.readFile file
+  listE $ map (\(Text.unpack -> pat) -> [|compileWith opts pat|]) patternStrings
+
+isComment :: Text -> Bool
+isComment line = or
+  [ commentSymbol `Text.isPrefixOf` Text.stripStart line
+  , Text.null $ Text.strip line
+  ]
+  where
+    commentSymbol = "$#"
diff --git a/templates/messages/submissionFilesIgnored.hamlet b/templates/messages/submissionFilesIgnored.hamlet
new file mode 100644
index 000000000..9c08b02dc
--- /dev/null
+++ b/templates/messages/submissionFilesIgnored.hamlet
@@ -0,0 +1,4 @@
+_{MsgSubmissionFilesIgnored}
+<ul style="font-family: monospace">
+  $forall fileTitle <- ignored
+    <li>#{fileTitle}

From 29fe30b90e18530d6f111d601110a875074ada32 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Fri, 20 Jul 2018 11:49:22 +0200
Subject: [PATCH 03/17] Fix alert historical alert class

---
 src/Handler/Corrections.hs | 6 +++---
 src/Handler/Sheet.hs       | 2 +-
 2 files changed, 4 insertions(+), 4 deletions(-)

diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index b861990b5..87b132cd4 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -215,7 +215,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
         when (not $ null alreadyAssigned) $ do
           mr <- (toHtml . ) <$> getMessageRender
           alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) 
-          addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
+          addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
         let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
         when (not $ null unassigned) $ do
           num <- updateWhereCount [SubmissionId <-. Set.toList unassigned] [SubmissionRatingBy =. Just uid]
@@ -238,7 +238,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
         when (not $ null alreadyAssigned) $ do
           mr <- (toHtml . ) <$> getMessageRender
           alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) 
-          addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
+          addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
         let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
         when (not $ null unassigned) $ do
           (assigned, unassigned) <- assignSubmissions shid (Just unassigned)
@@ -247,7 +247,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
           when (not $ null unassigned) $ do
             mr <- (toHtml . ) <$> getMessageRender
             unassigned' <- forM (Set.toList unassigned) $ \sid -> (encrypt sid :: DB CryptoFileNameSubmission) 
-            addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
+            addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
       redirect currentRoute
 
   fmap toTypedContent . defaultLayout $ do
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index 8d70902bb..539ba05eb 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -495,7 +495,7 @@ correctorForm shid = do
   (defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads
   loads' <- fmap (Map.fromList [(uid, mempty) | uid <- formCIDs] `Map.union`) $ if
     | Map.null currentLoads'
-    , null formCIDs          -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warn" MsgCorrectorsDefaulted)
+    , null formCIDs          -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warning" MsgCorrectorsDefaulted)
     | otherwise              -> return $ Map.fromList (map (, mempty) formCIDs) `Map.union` currentLoads'
 
   deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads')

From 460c62dfe50df425fb40417a3bef73e0bc8083a2 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Fri, 20 Jul 2018 12:57:27 +0200
Subject: [PATCH 04/17] Better error messages for submission uploads

---
 messages/de.msg                               |  4 +-
 src/Handler/Corrections.hs                    | 11 ++--
 src/Handler/Utils/Submission.hs               | 52 ++++++++++++++-----
 .../messages/submissionFilesIgnored.hamlet    | 11 ++--
 4 files changed, 57 insertions(+), 21 deletions(-)

diff --git a/messages/de.msg b/messages/de.msg
index a5a17e6fa..de6d18014 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -174,6 +174,7 @@ UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den
 CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden:
 
 CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert:
+NoCorrectionsUploaded: In der hochgeladenen Datei wurden keine Korrekturen gefunden.
 
 RatingBy: Korrigiert von
 AchievedBonusPoints: Erreichte Bonuspunkte
@@ -222,4 +223,5 @@ LastEdits: Letzte Änderungen
 EditedBy name@Text time@Text: Durch #{name} um #{time}
 LastEdit: Letzte Änderung
 
-SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert:
\ No newline at end of file
+SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert:
+SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}.
\ No newline at end of file
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 87b132cd4..a3bd66f5a 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -14,6 +14,7 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiWayIf #-}
 
 module Handler.Corrections where
 
@@ -439,9 +440,13 @@ postCorrectionsUploadR = do
     FormSuccess files -> do
       uid <- requireAuthId
       subs <- runDB . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkMultiSubmission uid True
-      subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
-      mr <- (toHtml .) <$> getMessageRender
-      addMessage "success" =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
+      if
+        | null subs -> addMessageI "warning" MsgNoCorrectionsUploaded
+        | otherwise -> do
+            subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
+            mr <- (toHtml .) <$> getMessageRender
+            addMessage "success" =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
+        
 
   defaultLayout $ do
     $(widgetFile "corrections-upload")
diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs
index b65705bd1..00ca2f06b 100644
--- a/src/Handler/Utils/Submission.hs
+++ b/src/Handler/Utils/Submission.hs
@@ -24,6 +24,7 @@ module Handler.Utils.Submission
   ) where
 
 import Import hiding ((.=), joinPath)
+import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
 
 import Control.Lens
 import Control.Lens.Extras (is)
@@ -31,6 +32,7 @@ import Utils.Lens
 
 import Control.Monad.State hiding (forM_, mapM_,foldM)
 import Control.Monad.Writer (MonadWriter(..))
+import Control.Monad.RWS.Lazy (RWST)
 import qualified Control.Monad.Random as Rand
 
 import Data.Maybe
@@ -64,6 +66,8 @@ import System.FilePath.Glob
 
 import Text.Hamlet (ihamletFile)
 
+import qualified Control.Monad.Catch as E (Handler(..))
+
 
 data AssignSubmissionException = NoCorrectorsByProportion
   deriving (Typeable, Show)
@@ -228,7 +232,9 @@ extractRatingsMsg :: ( MonadHandler m
                      , MonadLogger m
                      ) => Conduit File m SubmissionContent
 extractRatingsMsg = do
-  ignored <- filterSubmission `fuseUpstream` Rating.extractRatings
+  ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings
+  let ignored :: Set (Either CryptoFileNameSubmission FilePath)
+      ignored = Right `Set.map` ignored'
   mr <- (toHtml . ) <$> getMessageRender
   addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
 
@@ -439,7 +445,9 @@ sinkMultiSubmission userId isUpdate = do
   let
     feed :: SubmissionId
          -> SubmissionContent
-         -> StateT
+         -> RWST
+              ()
+              _
               (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId))
               (YesodDB UniWorX)
               ()
@@ -449,8 +457,9 @@ sinkMultiSubmission userId isUpdate = do
         Just sink -> return sink
         Nothing -> do
           lift $ do
-            Submission{..} <- get404 sId
             cID <- encrypt sId
+            $(logDebugS) "sinkMultiSubmission" $ "Doing auth checks for " <> toPathPiece cID 
+            Submission{..} <- get404 sId
             Sheet{..} <- get404 submissionSheet
             Course{..} <- get404 sheetCourse
             authRes <- evalAccessDB (CSubmissionR courseTerm courseShorthand sheetName cID CorrectionR) True
@@ -463,30 +472,45 @@ sinkMultiSubmission userId isUpdate = do
       case sink' of
         Left _ -> error "sinkSubmission returned prematurely"
         Right nSink -> modify $ Map.insert sId nSink
-  sinks <- execStateLC Map.empty . awaitForever $ \case
+  (sinks, ignored) <- execRWSLC () Map.empty . awaitForever $ \case
     v@(Right (sId, _)) -> do
       cID <- encrypt sId
-      handle (throwM . SubmissionSinkException cID Nothing) $
-        lift $ feed sId v
+      $logDebugS "sinkMultiSubmission" $ "Feeding rating for " <> toPathPiece cID
+      lift (feed sId v) `catches` [ E.Handler (throwM . SubmissionSinkException cID Nothing), E.Handler (void . handleHCError (Left cID)) ]
     (Left f@File{..})  -> do
       let
-        tryDecrypt :: FilePath -> _ (Either SomeException SubmissionId)
-        tryDecrypt (CI.mk -> ciphertext) = try $ decrypt (CryptoID{..} :: CryptoFileNameSubmission)
-        acc (Just cID, fp) segment = return (Just cID, fp ++ [segment])
+        acc :: (Maybe SubmissionId, [FilePath]) -> FilePath -> _ (Maybe SubmissionId, [FilePath])
+        acc (Just sId, fp) segment = return (Just sId, fp ++ [segment])
         acc (Nothing , fp) segment = do
-          msId <- tryDecrypt segment
-          return . either (const id) (set _1 . Just) msId $ (Nothing, fp)
+          let
+            tryDecrypt ciphertext = do
+              sId <- decrypt (CryptoID (CI.mk segment) :: CryptoFileNameSubmission)
+              Just sId <$ get404 sId
+          msId <- lift (lift $ tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ]
+          return (msId, fp)
       (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle
-      $logDebugS "sinkMultiSubmission" $ tshow (splitDirectories fileTitle, msId, fileTitle')
       case msId of
-        Nothing -> $logDebugS "sinkMultiSubmission" "Dropped"
+        Nothing -> do
+          $logDebugS "sinkMultiSubmission" $ "Dropping " <> tshow (splitDirectories fileTitle, msId, fileTitle')
         Just sId -> do
+          $logDebugS "sinkMultiSubmission" $ "Feeding " <> tshow (splitDirectories fileTitle, msId, fileTitle')
           cID <- encrypt sId
           handle (throwM . SubmissionSinkException cID (Just fileTitle)) $
             lift . feed sId $ Left f{ fileTitle = fileTitle' }
+  when (not $ null ignored) $ do
+    mr <- (toHtml .) <$> getMessageRender
+    addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
   fmap Map.keysSet . lift . sequence $ flip Map.mapWithKey sinks $ \sId sink -> do
     cID <- encrypt sId
-    handle (throwM . SubmissionSinkException cID Nothing) . void $ closeResumableSink sink
+    handle (throwM . SubmissionSinkException cID Nothing) $
+      void $ closeResumableSink sink
+  where
+    handleHCError :: Either CryptoFileNameSubmission FilePath -> HandlerContents -> _ (Maybe a)
+    handleHCError ident (HCError NotFound) = Nothing <$ tell (Set.singleton ident)
+    handleHCError _ e = throwM e
+    handleCryptoID :: CryptoIDError -> _ (Maybe a)
+    handleCryptoID _ = return Nothing
+    
 
 submissionMatchesSheet :: TermId -> Text -> Text -> CryptoFileNameSubmission -> DB ()
 submissionMatchesSheet tid csh shn cid = do
diff --git a/templates/messages/submissionFilesIgnored.hamlet b/templates/messages/submissionFilesIgnored.hamlet
index 9c08b02dc..f02bed623 100644
--- a/templates/messages/submissionFilesIgnored.hamlet
+++ b/templates/messages/submissionFilesIgnored.hamlet
@@ -1,4 +1,9 @@
 _{MsgSubmissionFilesIgnored}
-<ul style="font-family: monospace">
-  $forall fileTitle <- ignored
-    <li>#{fileTitle}
+<ul>
+  $forall ident <- ignored
+    $case ident
+      $of Right fileTitle
+        <li style="font-family: monospace">#{fileTitle}
+      $of Left cID
+        <li>Bewertungsdatei für <span style="font-family: monospace">#{toPathPiece cID}</span>
+    

From ea118d37137dd46272998cce5bc268354d0221b9 Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Sat, 21 Jul 2018 13:05:45 +0200
Subject: [PATCH 05/17] Refactor fileIdTables done

---
 src/Handler/Sheet.hs | 27 ++++++++++++---------------
 src/Model/Types.hs   | 20 ++++++++++++++++++++
 src/Utils.hs         | 17 +++++++++++++++--
 3 files changed, 47 insertions(+), 17 deletions(-)

diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index 8d70902bb..25e46109b 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -85,17 +85,19 @@ data SheetForm = SheetForm
       -- Keine SheetId im Formular!
       }
 
+getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileId)
+getFtIdMap sId = do
+  allfIds <- E.select . E.from $ \(sheetFile `E.InnerJoin` file) -> do
+      E.on     $ sheetFile E.^. SheetFileFile  E.==. file E.^. FileId
+      E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId
+      return    (sheetFile E.^. SheetFileType, file E.^. FileId)
+  return $ partitionFileType [(t,i)|(E.Value t, E.Value i) <- allfIds]
 
 makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
 makeSheetForm msId template = identForm FIDsheet $ \html -> do
-    -- TODO: SJ to refactor this; extract Code from getSEditR to joint code piece
-    let oldFileIds fType
-          | Just sId <- msId = fmap setFromList . fmap (map E.unValue) . runDB . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
-              E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
-              E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId
-                   E.&&. sheetFile E.^. SheetFileType    E.==. E.val fType
-              return (file E.^. FileId)
-          | otherwise = return Set.empty
+    oldFileIds <- (return.) <$> case msId of
+      Nothing    -> return $ partitionFileType mempty
+      (Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId
     mr <- getMsgRenderer
     ctime <- liftIO $ getCurrentTime
     (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
@@ -313,13 +315,8 @@ getSEditR :: TermId -> Text -> Text -> Handler Html
 getSEditR tid csh shn = do
   (sheetEnt, sheetFileIds) <- runDB $ do
     ent <- fetchSheet tid csh shn
-    allfIds <- E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
-      E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
-      E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val (entityKey ent)
-      return (sheetFile E.^. SheetFileType, file E.^. FileId)
-    let ftIds :: SheetFileType -> Set FileId
-        ftIds ft = Set.fromList $ mapMaybe (\(E.Value t, E.Value i) -> i <$ guard (ft==t)) allfIds
-    return (ent, ftIds)
+    fti <- getFtIdMap $ entityKey ent
+    return (ent, fti)
   let sid = entityKey sheetEnt
   let oldSheet@(Sheet {..}) = entityVal sheetEnt
   let template = Just $ SheetForm
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index 8a2b908d7..f1af94def 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -15,6 +16,8 @@ import Utils
 
 import Data.Map (Map)
 import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
 import Data.Fixed
 
 import Database.Persist.TH
@@ -95,6 +98,23 @@ instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instan
   display SheetSolution = "Musterlösung"
   display SheetMarking  = "Korrekturhinweise"
 
+-- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a)
+-- partitionFileType' = groupMap
+
+partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a
+partitionFileType fts =
+    let (se,sh,ss,sm) = foldl' switchft (Set.empty,Set.empty,Set.empty,Set.empty) fts
+    in \case  SheetExercise -> se
+              SheetHint     -> sh
+              SheetSolution -> ss
+              SheetMarking  -> sm
+  where
+    switchft :: Ord a => (Set a, Set a, Set a, Set a) -> (SheetFileType,a) -> (Set a, Set a, Set a, Set a)
+    switchft (se,sh,ss,sm) (SheetExercise,x) = (Set.insert x se, sh, ss, sm)
+    switchft (se,sh,ss,sm) (SheetHint    ,x) = (se, Set.insert x sh, ss, sm)
+    switchft (se,sh,ss,sm) (SheetSolution,x) = (se, sh, Set.insert x ss, sm)
+    switchft (se,sh,ss,sm) (SheetMarking ,x) = (se, sh, ss, Set.insert x sm)
+
 data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 
diff --git a/src/Utils.hs b/src/Utils.hs
index 1ec44e5ba..a0e72b036 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -23,8 +23,10 @@ import Utils.DateTime as Utils
 
 import Text.Blaze (Markup, ToMarkup)
 
--- import Data.Map (Map)
--- import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Map (Map)
+import qualified Data.Map as Map
 -- import qualified Data.List as List
 
 import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
@@ -149,6 +151,17 @@ trd3 (_,_,z) = z
 -- Maps --
 ----------
 
+infixl 5 !!!
+
+
+(!!!) :: (Ord k, Monoid v) => Map k v -> k -> v
+(!!!) m k = (fromMaybe mempty) $ Map.lookup k m
+
+groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v)
+groupMap l = Map.fromListWith mappend $ [(k, Set.singleton v) | (k,v) <- l]
+
+partMap :: (Ord k, Monoid v) => [(k,v)] -> Map k v
+partMap = Map.fromListWith mappend
 
 -----------
 -- Maybe --

From cc28e6f78689472a9a1ec00f71b42e9f0b98eea7 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sun, 22 Jul 2018 16:28:00 +0200
Subject: [PATCH 06/17] Introduce 'submissionRatingDone'

Resolves #129
---
 messages/de.msg            |  1 +
 routes                     |  2 +-
 src/Foundation.hs          | 14 +++++++++++---
 src/Handler/Corrections.hs |  2 +-
 src/Model.hs               |  4 ++++
 5 files changed, 18 insertions(+), 5 deletions(-)

diff --git a/messages/de.msg b/messages/de.msg
index de6d18014..c28db3a46 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -109,6 +109,7 @@ UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung
 UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
 UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
 UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
+UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert.
 UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe.
 OnlyUploadOneFile: Bitte nur eine Datei hochladen.
 DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen.
diff --git a/routes b/routes
index 27263ba9a..0adcb0bf7 100644
--- a/routes
+++ b/routes
@@ -67,7 +67,7 @@
     /sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead:
       /                           SubShowR                   GET POST !ownerANDtime !ownerANDisRead
       /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR                GET      !owner
-      /correction                 CorrectionR                GET POST !corrector !ownerANDisRead
+      /correction                 CorrectionR                GET POST !corrector !ownerANDisReadANDrated
       !/#SubmissionFileType/*FilePath SubDownloadR           GET      !owner
     /correctors                 SCorrR        GET POST
     !/#SheetFileType/*FilePath  SFileR        GET             !timeANDregistered !timeANDmaterials !corrector
diff --git a/src/Foundation.hs b/src/Foundation.hs
index b76ad30f2..cb8ac4f42 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -389,6 +389,16 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
          $logErrorS "AccessControl" $ "'!owner' used on route that doesn't support it: " <> tshow r
          unauthorizedI MsgUnauthorized
    )
+  ,("rated", APDB $ \route _ -> case route of
+       CSubmissionR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
+         sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
+         sub <- MaybeT $ get sid
+         guard $ submissionRatingDone sub
+         return Authorized
+       r -> do
+         $logErrorS "AccessControl" $ "'!rated' used on route that doesn't support it: " <> tshow r
+         unauthorizedI MsgUnauthorized
+   )
   ,("isRead",  APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite))
   ,("isWrite", APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized))
   ]
@@ -875,9 +885,7 @@ pageActions (CSubmissionR tid csh shn cid SubShowR) =
       , menuItemAccessCallback' = do
           smid <- decrypt cid
           sm <- runDB $ get smid
-          case sm of
-            (Just (Submission { submissionRatingTime=Just _})) -> return True
-            _ -> return False
+          return $ maybe False submissionRatingDone sm
       }
   ]
 pageActions (CSheetR tid csh shn SCorrR) =
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index a3bd66f5a..3c7c20024 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -371,7 +371,7 @@ postCorrectionR tid csh shn cid = do
       let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
 
       ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,)
-        <$> aopt pointsField (fslI MsgRatingPoints) (Just $ submissionRatingPoints)
+        <$> aopt pointsField (fslpI MsgRatingPoints "Punktezahl" & setTooltip "Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist") (Just $ submissionRatingPoints)
         <*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment))
         <* submitButton
 
diff --git a/src/Model.hs b/src/Model.hs
index aef13b517..1feeab96e 100644
--- a/src/Model.hs
+++ b/src/Model.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE TemplateHaskell            #-}
 {-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE RecordWildCards            #-}
 module Model
   ( module Model
   , module Model.Types
@@ -31,3 +32,6 @@ data PWEntry = PWEntry
   , pwHash :: Text
   } deriving (Show)
 $(deriveJSON defaultOptions ''PWEntry)
+
+submissionRatingDone :: Submission -> Bool
+submissionRatingDone Submission{..} = isJust submissionRatingPoints

From 49ae1a38651876d9c094ba15e20609dc61765ec3 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sun, 22 Jul 2018 17:18:04 +0200
Subject: [PATCH 07/17] Propagate restriction on 'rated' to file downloads

---
 src/Handler/Corrections.hs      |  2 +-
 src/Handler/Sheet.hs            | 21 ++++++++-------
 src/Handler/Submission.hs       | 48 ++++++++++++++++++++-------------
 src/Handler/Utils/Submission.hs |  9 +++----
 src/Import/NoFoundation.hs      |  2 ++
 src/Utils.hs                    |  5 ++++
 6 files changed, 52 insertions(+), 35 deletions(-)

diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 3c7c20024..db8da1dda 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -207,7 +207,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
     FormMissing      -> return ()
     FormSuccess (CorrDownloadData, subs) -> do
       ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
-      addHeader "Content-Disposition" "attachment; filename=\"corrections.zip\""
+      addHeader "Content-Disposition" [st|attachment; filename="corrections.zip"|]
       sendResponse =<< submissionMultiArchive ids
     FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do
       subs <- mapM decrypt $ Set.toList subs'
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index 539ba05eb..1fa719f2a 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -274,7 +274,7 @@ getSShowR tid csh shn = do
 
 getSFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
 getSFileR tid csh shn typ title = do
-  content <- runDB $ E.select $ E.from $
+  results <- runDB $ E.select $ E.from $
     \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
       -- Restrict to consistent rows that correspond to each other
       E.on (file      E.^. FileId           E.==. sheetFile E.^. SheetFileFile)
@@ -288,15 +288,18 @@ getSFileR tid csh shn typ title = do
         E.&&.   (course    E.^. CourseTerm    E.==. E.val tid  )
         )
       -- return desired columns
-      return $ file E.^. FileContent
+      return $ (file E.^. FileTitle, file E.^. FileContent)
   let mimeType = defaultMimeLookup $ pack title
-  case content of
-    [E.Value (Just nochmalContent)] -> do
-      addHeader "Content-Disposition" "attachment"
-      respond mimeType nochmalContent
-    []     -> notFound
-    _other -> error "Multiple matching files found."
-
+  case results of
+    [(E.Value fileTitle, E.Value fileContent)]
+      | Just fileContent' <- fileContent -> do
+          addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
+          return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
+      | otherwise -> sendResponseStatus noContent204 ()
+    [] -> notFound
+    other -> do
+      $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
+      error "Multiple matching files found."
 
 getSheetNewR :: TermId -> Text -> Handler Html
 getSheetNewR tid csh = do
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index 8b71cbefb..f85c0f0fd 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE OverloadedLists #-}
@@ -56,8 +56,6 @@ import Colonnade hiding (bool, fromMaybe)
 import qualified Yesod.Colonnade as Yesod
 import qualified Text.Blaze.Html5.Attributes as HA
 
-import Text.Shakespeare.Text (st)
-
 
 numberOfSubmissionEditDates :: Int64
 numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
@@ -143,7 +141,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
             addMessageI "info" $ MsgSubmissionAlreadyExists
             redirect $ CSubmissionR tid csh shn cID SubShowR
       (Just smid) -> do
-        submissionMatchesSheet tid csh shn (fromJust mcid)
+        void $ submissionMatchesSheet tid csh shn (fromJust mcid)
         
         shid' <- submissionSheet <$> get404 smid
         -- fetch buddies from current submission
@@ -311,40 +309,52 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
 
 getSubDownloadR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
 getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
-  submissionID <- decrypt cID
-
   runDB $ do
-    submissionMatchesSheet tid csh shn cID
+    submissionID <- submissionMatchesSheet tid csh shn cID
 
     isRating <- maybe False (== submissionID) <$> isRatingFile path
+
+    when (isUpdate || isRating) $
+      guardAuthResult =<< evalAccessDB (CSubmissionR tid csh shn cID CorrectionR) False
+  
     case isRating of
-      True  -> do
-        file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
-        maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
+      True
+        | isUpdate -> do
+            file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
+            maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
+        | otherwise -> notFound
       False -> do
         results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
           E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
           E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
                E.&&. f E.^. FileTitle E.==. E.val path
-               E.&&. E.not_ (E.isNothing $ f E.^. FileContent)
                E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
                E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
+               -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
           return f
 
         let fileName = Text.pack $ takeFileName path
         case results of
-          [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName <> "; charset=utf-8") (toContent c)
-          _ -> notFound
+          [Entity _ File{ fileContent = Just c, fileTitle }] -> do
+            addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
+            return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c)
+          [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 ()
+          other -> do
+            $logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other
+            error "Multiple matching files found."
 
 getSubArchiveR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
 getSubArchiveR tid csh shn cID@CryptoID{..} (ZIPArchiveName sfType) = do
-  submissionID <- decrypt cID
-
-  addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece cID}-#{toPathPiece sfType}.zip"|]
+  when (sfType == SubmissionCorrected) $ 
+    guardAuthResult =<< evalAccess (CSubmissionR tid csh shn cID CorrectionR) False
 
+  let filename
+        | SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType
+        | otherwise = ZIPArchiveName $ toPathPiece cID
+  
+  addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|]
   respondSourceDB "application/zip" $ do
-    lift $ submissionMatchesSheet tid csh shn cID
-
+    submissionID <- lift $ submissionMatchesSheet tid csh shn cID
     rating <- lift $ getRating submissionID
 
     let
@@ -361,6 +371,6 @@ getSubArchiveR tid csh shn cID@CryptoID{..} (ZIPArchiveName sfType) = do
         when (sfType == SubmissionCorrected) $
           maybe (return ()) (yieldM . ratingFile cID) rating
 
-      zipComment = Text.encodeUtf8 . pack $ CI.foldedCase ciphertext
+      zipComment = Text.encodeUtf8 $ toPathPiece cID
 
     fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs
index 00ca2f06b..2fbfb5532 100644
--- a/src/Handler/Utils/Submission.hs
+++ b/src/Handler/Utils/Submission.hs
@@ -462,11 +462,7 @@ sinkMultiSubmission userId isUpdate = do
             Submission{..} <- get404 sId
             Sheet{..} <- get404 submissionSheet
             Course{..} <- get404 sheetCourse
-            authRes <- evalAccessDB (CSubmissionR courseTerm courseShorthand sheetName cID CorrectionR) True
-            case authRes of
-              AuthenticationRequired -> notAuthenticated
-              Unauthorized t -> permissionDenied t
-              Authorized -> return ()
+            guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseShorthand sheetName cID CorrectionR) True
           return . newResumableSink $ sinkSubmission userId (Right sId) isUpdate
       sink' <- lift $ yield val ++$$ sink
       case sink' of
@@ -512,9 +508,10 @@ sinkMultiSubmission userId isUpdate = do
     handleCryptoID _ = return Nothing
     
 
-submissionMatchesSheet :: TermId -> Text -> Text -> CryptoFileNameSubmission -> DB ()
+submissionMatchesSheet :: TermId -> Text -> Text -> CryptoFileNameSubmission -> DB SubmissionId
 submissionMatchesSheet tid csh shn cid = do
   sid <- decrypt cid
   shid <- fetchSheetId tid csh shn
   Submission{..} <- get404 sid
   when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
+  return sid
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index 2e586ba56..665c509b5 100644
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@@ -19,3 +19,5 @@ import CryptoID               as Import
 import Data.UUID              as Import (UUID)
 
 import Text.Lucius            as Import
+
+import Text.Shakespeare.Text  as Import hiding (text, stext)
diff --git a/src/Utils.hs b/src/Utils.hs
index 1ec44e5ba..10559c802 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -51,6 +51,11 @@ instance Monad FormResult where
   (FormFailure errs) >>= _ = FormFailure errs
   (FormSuccess a)    >>= f = f a
 
+guardAuthResult :: MonadHandler m => AuthResult -> m ()
+guardAuthResult AuthenticationRequired = notAuthenticated
+guardAuthResult (Unauthorized t) = permissionDenied t
+guardAuthResult Authorized = return ()
+
 
 
 ---------------------

From 8da542fb9038d3d9ca87f3942673c04c71e44983 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sun, 22 Jul 2018 17:28:53 +0200
Subject: [PATCH 08/17] Don't hide CorrectionR-PageAction

Fixes #128
---
 src/Foundation.hs | 5 +----
 1 file changed, 1 insertion(+), 4 deletions(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index cb8ac4f42..44c02a3c0 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -882,10 +882,7 @@ pageActions (CSubmissionR tid csh shn cid SubShowR) =
       { menuItemLabel = "Korrektur"
       , menuItemIcon  = Nothing
       , menuItemRoute = CSubmissionR tid csh shn cid CorrectionR
-      , menuItemAccessCallback' = do
-          smid <- decrypt cid
-          sm <- runDB $ get smid
-          return $ maybe False submissionRatingDone sm
+      , menuItemAccessCallback' = return True
       }
   ]
 pageActions (CSheetR tid csh shn SCorrR) =

From 969ada63d82e86e415ec936236756eec8670504e Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sun, 22 Jul 2018 17:44:52 +0200
Subject: [PATCH 09/17] Stop emitting SubmissionFilesIgnored when nothing was
 ignored

---
 src/Handler/Utils/Submission.hs | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs
index 2fbfb5532..6b591928f 100644
--- a/src/Handler/Utils/Submission.hs
+++ b/src/Handler/Utils/Submission.hs
@@ -235,8 +235,9 @@ extractRatingsMsg = do
   ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings
   let ignored :: Set (Either CryptoFileNameSubmission FilePath)
       ignored = Right `Set.map` ignored'
-  mr <- (toHtml . ) <$> getMessageRender
-  addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
+  unless (null ignored) $ do
+    mr <- (toHtml . ) <$> getMessageRender
+    addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
 
 sinkSubmission :: UserId
                -> Either SheetId SubmissionId

From 51c04aec2082b1dda71e3fc589763fa07fd7fef2 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sun, 22 Jul 2018 18:49:39 +0200
Subject: [PATCH 10/17] 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

From 02fc791e0feb1df5033a076d60d82f0b88c4daed Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 23 Jul 2018 12:00:37 +0200
Subject: [PATCH 11/17] Bump cryptoids

---
 stack.yaml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/stack.yaml b/stack.yaml
index 255d30efa..5462c2462 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -38,7 +38,7 @@ extra-deps:
 
   - uuid-crypto-1.4.0.0
   - filepath-crypto-0.1.0.0
-  - cryptoids-0.5.0.0
+  - cryptoids-0.5.1.0
   - cryptoids-types-0.0.0
   - cryptoids-class-0.0.0
 

From 6a53fb1401cf90f6de4e565da9a04bfbe60bb5ab Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 30 Jul 2018 16:30:38 +0200
Subject: [PATCH 12/17] Display submission users

---
 messages/de.msg                       |  1 +
 src/Handler/Corrections.hs            | 56 ++++++++++++++++--------
 src/Handler/Utils/Table/Pagination.hs | 63 +++++++++++++++++++--------
 src/Utils.hs                          | 22 ++++++++++
 templates/default-layout.lucius       |  4 +-
 templates/table/cell/body.hamlet      |  3 +-
 templates/table/cell/link.hamlet      |  1 +
 templates/table/cell/list.hamlet      |  5 +++
 8 files changed, 116 insertions(+), 39 deletions(-)
 create mode 100644 templates/table/cell/list.hamlet

diff --git a/messages/de.msg b/messages/de.msg
index b61a36e31..db368200b 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -188,6 +188,7 @@ Passed: Bestanden
 NotPassed: Nicht bestanden
 RatingTime: Korrigiert
 RatingComment: Kommentar
+SubmissionUsers: Studenten
 
 RatingPoints: Punkte
 RatingFiles: Korrigierte Dateien
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 412d380c5..3d2a61116 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -75,54 +75,60 @@ 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 CourseName, E.Value CourseShorthand, E.Value (Key Term), E.Value (Key School)), Maybe (Entity User))
+type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId User)
 
 colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colTerm = sortable (Just "term") (i18nCell MsgTerm)
-        $ \DBRow{ dbrOutput=(_, _, course, _) } ->
+        $ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
           -- cell [whamlet| _{untermKey $ course ^. _3}|]   -- lange, internationale Semester
-          textCell $ termToText $ unTermKey $ E.unValue $ course ^. _3 -- kurze Semsterkürzel
+          textCell $ termToText $ unTermKey $ course ^. _3 -- kurze Semsterkürzel
 
 colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colCourse = sortable (Just "course") (i18nCell MsgCourse)
-        $ \DBRow{ dbrOutput=(_, _, course, _) } -> cell $
-          let tid = E.unValue $ course ^. _3
-              csh = E.unValue $ course ^. _2
+        $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> cell $
+          let tid = course ^. _3
+              csh = course ^. _2
           in [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]
 
 colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
-        $ \DBRow{ dbrOutput=(_, sheet, course, _) } -> cell $
-          let tid = E.unValue $ course ^. _3
-              csh = E.unValue $ course ^. _2
+        $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> cell $
+          let tid = course ^. _3
+              csh = course ^. _2
               shn = sheetName $ entityVal sheet
           in [whamlet|<a href=@{CSheetR tid csh shn SShowR}>#{display shn}|]
           -- textCell $ sheetName $ entityVal sheet
 
 colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
-  DBRow{ dbrOutput = (_, _, _, Nothing) } -> cell mempty
-  DBRow{ dbrOutput = (_, _, _, Just corr) } -> textCell . display . userDisplayName $ entityVal corr
+  DBRow{ dbrOutput = (_, _, _, Nothing, _) } -> cell mempty
+  DBRow{ dbrOutput = (_, _, _, Just corr, _) } -> textCell . display . userDisplayName $ entityVal corr
 
 colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
-        $ \DBRow{ dbrOutput=(submission, sheet, course, _) } -> cell $ do
-          let tid = E.unValue $ course ^. _3
-              csh = E.unValue $ course ^. _2
+        $ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } -> cell $ do
+          let tid = course ^. _3
+              csh = course ^. _2
               shn = sheetName $ entityVal sheet
           cid <- encrypt (entityKey submission :: SubmissionId)
           [whamlet|<a href=@{CSubmissionR tid csh shn cid SubShowR}>#{display cid}|]
 
 colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
-colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _) } -> encrypt subId
+colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
+
+colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
+  cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (toWidget userDisplayName)
+  in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
+  
 
 type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
             
 makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
                      => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
 makeCorrectionsTable whereClause colChoices psValidator = do
-  let tableData :: CorrectionTableExpr -> E.SqlQuery _
-      tableData ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
+  let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
+      dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
         E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
         E.on $ sheet  E.^. SheetId  E.==. submission E.^. SubmissionSheet
         E.on $ course E.^. CourseId E.==. sheet      E.^. SheetCourse
@@ -133,10 +139,20 @@ makeCorrectionsTable whereClause colChoices psValidator = do
                     , course E.^. CourseSchool    :: E.SqlExpr (E.Value SchoolId)
                     )
         return (submission, sheet, crse, corrector)
+      dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData
+      dbtProj = traverse $ \(submission@(Entity sId _), sheet, (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do
+        submittors <- lift . E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
+          E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
+          E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId
+          E.orderBy [E.asc $ user E.^. UserId]
+          return user
+        let
+          submittorMap = foldr (\(Entity userId user) -> Map.insert userId user) Map.empty submittors
+        return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
   dbTable psValidator $ DBTable
-    { dbtSQLQuery  = tableData
+    { dbtSQLQuery
     , dbtColonnade = colChoices
-    , dbtProj      = return 
+    , dbtProj
     , dbtSorting   = [ ( "term"
                        , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm
                        )
@@ -319,6 +335,7 @@ postCCorrectionsR tid csh = do
         , dbRow
         , colSheet
         , colCorrector
+        , colSubmittors
         , colSubmissionLink
         ] -- Continue here
       psValidator = def
@@ -336,6 +353,7 @@ postSSubsR tid csh shn = do
         [ colSelect
         , dbRow
         , colCorrector
+        , colSubmittors
         , colSubmissionLink
         ]
       psValidator = def
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index 26acd65dc..a7bda4a73 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -24,6 +24,7 @@ module Handler.Utils.Table.Pagination
   , DBRow(..)
   , DBStyle(..), DBEmptyStyle(..)
   , DBTable(..), IsDBTable(..), DBCell(..)
+  , cellAttrs, cellContents
   , PaginationSettings(..), PaginationInput(..), piIsUnset
   , PSValidator(..)
   , defaultFilter, defaultSorting
@@ -31,10 +32,13 @@ module Handler.Utils.Table.Pagination
   , ToSortable(..), Sortable(..), sortable
   , dbTable
   , widgetColonnade, formColonnade, dbColonnade
-  , textCell, stringCell, i18nCell, anchorCell, anchorCell', anchorCellM
+  , cell, textCell, stringCell, i18nCell
+  , anchorCell, anchorCell', anchorCellM
+  , listCell
   , formCell, DBFormResult, getDBFormResult
   , dbRow, dbSelect
   , (&)
+  , module Control.Monad.Trans.Maybe
   ) where
 
 import Handler.Utils.Table.Pagination.Types
@@ -59,6 +63,8 @@ import Control.Monad.Writer hiding ((<>), Foldable(..), mapM_, forM_)
 import Control.Monad.Reader (ReaderT(..), mapReaderT)
 import Control.Monad.Trans.Maybe
 
+import Data.Foldable (Foldable(foldMap))
+
 import Data.Map (Map, (!))
 import qualified Data.Map as Map
 
@@ -123,6 +129,15 @@ data DBRow r = DBRow
   , dbrIndex, dbrCount :: Int64
   } deriving (Show, Read, Eq, Ord)
 
+instance Functor DBRow where
+  fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. }
+
+instance Foldable DBRow where
+  foldMap f DBRow{..} = f dbrOutput
+
+instance Traversable DBRow where
+  traverse f DBRow{..} = DBRow <$> f dbrOutput <*> pure dbrIndex <*> pure dbrCount
+
 data DBEmptyStyle = DBESNoHeading | DBESHeading
   deriving (Enum, Bounded, Ord, Eq, Show, Read)
 
@@ -238,16 +253,19 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *)
   -- type DBResult' m x :: *
 
   data DBCell m x :: *
-  cellAttrs :: Lens' (DBCell m x) [(Text, Text)]
-  cellContents :: DBCell m x -> WriterT x m Widget
-
-  cell :: Widget -> DBCell m x
+  dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget)
     
   -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
   dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> DBResult m x -> m' Widget
   dbHandler :: forall m'. (MonadHandler m' , HandlerSite m' ~ UniWorX) => DBTable m x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
   runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)
 
+cellAttrs :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)]
+cellAttrs = dbCell . _1
+
+cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget)
+cellContents = dbCell . _2
+
 instance IsDBTable (WidgetT UniWorX IO) () where
   type DBResult (WidgetT UniWorX IO) () = Widget
   -- type DBResult' (WidgetT UniWorX IO) () = ()
@@ -256,10 +274,10 @@ instance IsDBTable (WidgetT UniWorX IO) () where
     { wgtCellAttrs :: [(Text, Text)]
     , wgtCellContents :: Widget
     }
-  cellAttrs = lens wgtCellAttrs $ \w as -> w { wgtCellAttrs = as }
-  cellContents = return . wgtCellContents
 
-  cell = WidgetCell []
+  dbCell = iso
+    (\WidgetCell{..} -> (wgtCellAttrs, return wgtCellContents))
+    (\(attrs, mkWidget) -> WidgetCell attrs . join . fmap fst $ runWriterT mkWidget)
   
   -- dbWidget Proxy Proxy = iso (, ()) $ view _1
   dbWidget _ = return
@@ -278,10 +296,9 @@ instance IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) () where
     , dbCellContents :: ReaderT SqlBackend (HandlerT UniWorX IO) Widget
     }
 
-  cellAttrs = lens dbCellAttrs $ \w as -> w { dbCellAttrs = as }
-  cellContents = lift . dbCellContents
-
-  cell = DBCell [] . return
+  dbCell = iso
+    (\DBCell{..} -> (dbCellAttrs, lift dbCellContents))
+    (\(attrs, mkWidget) -> DBCell attrs . fmap fst $ runWriterT mkWidget)
 
   dbWidget _ = return
   dbHandler _ f x = return $ f x
@@ -301,10 +318,13 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
     { formCellAttrs :: [(Text, Text)]
     , formCellContents :: MForm (HandlerT UniWorX IO) (FormResult a, Widget)
     }
-  cellAttrs = lens formCellAttrs $ \w as -> w { formCellAttrs = as }
-  cellContents = WriterT . fmap swap . formCellContents
 
-  cell widget = FormCell [] $ return (mempty, widget)
+  -- dbCell :: Iso'
+  --             (DBCell (RWST ... ... ... (HandlerT UniWorX IO)) (FormResult a))
+  --             ([(Text, Text)], WriterT (FormResult a) (RWST ... ... ... (HandlerT UniWorX IO)) Widget)
+  dbCell = iso
+    (\FormCell{..} -> (formCellAttrs, WriterT $ fmap swap formCellContents))
+    (\(attrs, mkWidget) -> FormCell attrs . fmap swap $ runWriterT mkWidget)
   
   -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
   --                            ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
@@ -393,7 +413,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
           tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
 
           genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
-            widget <- cellContents sortableContent
+            widget <- sortableContent ^. cellContents
             let
               directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
               isSortable = isJust sortableKey
@@ -407,7 +427,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
         wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
 
         wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do
-          widget <- cellContents cell
+          widget <- cell ^. cellContents
           let attrs = cell ^. cellAttrs
           return $(widgetFile "table/cell/body")
       
@@ -444,6 +464,9 @@ dbColonnade :: Headedness h
             -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ())
 dbColonnade = id
 
+cell :: IsDBTable m a => Widget -> DBCell m a
+cell wgt = dbCell # ([], return wgt)
+
 textCell, stringCell, i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
 stringCell = textCell
 i18nCell = textCell
@@ -467,6 +490,12 @@ anchorCellM routeM widget = cell $ do
     | Authorized <- authResult -> $(widgetFile "table/cell/link")
     | otherwise                -> widget
 
+listCell :: (IsDBTable m a, Traversable f) => f r' -> (r' -> DBCell m a) -> DBCell m a
+listCell xs mkCell = review dbCell . ([], ) $ do
+  cells <- forM xs $
+    \(view dbCell . mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget
+  return $(widgetFile "table/cell/list")
+
 newtype DBFormResult r i a = DBFormResult (Map i (r, a -> a))
 
 instance Ord i => Monoid (DBFormResult r i a) where
diff --git a/src/Utils.hs b/src/Utils.hs
index 648b5d358..20c395570 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -17,6 +17,9 @@ import Data.List (foldl)
 import Data.Foldable as Fold
 import qualified Data.Char as Char
 
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
 import Utils.DB as Utils
 import Utils.Common as Utils
 import Utils.DateTime as Utils
@@ -123,6 +126,9 @@ instance DisplayAble a => DisplayAble (Maybe a) where
 instance DisplayAble a => DisplayAble (E.Value a) where
   display = display . E.unValue
 
+instance DisplayAble a => DisplayAble (CI a) where
+  display = display . CI.original
+
 -- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated)
 instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where
   display = pack . show
@@ -151,6 +157,22 @@ trd3 (_,_,z) = z
 
 -- notNull = not . null
 
+mergeAttrs :: [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
+mergeAttrs = mergeAttrs' `on` sort
+  where
+    special = [ ("class", \v1 v2 -> v1 <> " " <> v2)
+              ]
+
+    mergeAttrs' (x1@(n1, v1):xs1) (x2@(n2, v2):xs2)
+      | Just merge <- lookup n1 special
+      , n2 == n1
+      = mergeAttrs' ((n1, merge v1 v2) : xs1) xs2
+      | Just _ <- lookup n1 special
+      , n1 < n2
+      = x2 : mergeAttrs' (x1:xs1) xs2
+      | otherwise = x1 : mergeAttrs' xs1 (x2:xs2)
+    mergeAttrs' [] xs2 = xs2
+    mergeAttrs' xs1 [] = xs1
 
 ----------
 -- Maps --
diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius
index 25a12154c..f55073584 100644
--- a/templates/default-layout.lucius
+++ b/templates/default-layout.lucius
@@ -428,10 +428,10 @@ input[type="button"].btn-info:hover,
   display: inline-block;
 }
 
-.list--comma-separated > li {
-
+.list--comma-separated li {
   &::after {
     content: ', ';
+    white-space: pre;
   }
 
   &:last-of-type::after {
diff --git a/templates/table/cell/body.hamlet b/templates/table/cell/body.hamlet
index f2892c2a2..46bf50fd1 100644
--- a/templates/table/cell/body.hamlet
+++ b/templates/table/cell/body.hamlet
@@ -1,3 +1,4 @@
-<td .table__td *{attrs}>
+$newline never
+<td *{mergeAttrs attrs [("class", "table__td")]}>
   <div .table__td-content>
     ^{widget}
diff --git a/templates/table/cell/link.hamlet b/templates/table/cell/link.hamlet
index 21ce1108a..0ced27282 100644
--- a/templates/table/cell/link.hamlet
+++ b/templates/table/cell/link.hamlet
@@ -1,2 +1,3 @@
+$newline never
 <a href=@{route}>
   ^{widget}
diff --git a/templates/table/cell/list.hamlet b/templates/table/cell/list.hamlet
new file mode 100644
index 000000000..86a1f0520
--- /dev/null
+++ b/templates/table/cell/list.hamlet
@@ -0,0 +1,5 @@
+$newline never
+<ul>
+  $forall (attrs, widget) <- cells
+    <li *{attrs}>
+      ^{widget}

From 1b516aef6612b147650c5120f3dce00e20b21577 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 30 Jul 2018 16:31:04 +0200
Subject: [PATCH 13/17] Fix NixOS postgresql-extension

---
 shell.nix | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/shell.nix b/shell.nix
index 5185715fd..d305354a1 100644
--- a/shell.nix
+++ b/shell.nix
@@ -10,7 +10,7 @@ let
   drv = haskellPackages.callPackage ./uniworx.nix {};
 
   postgresSchema = pkgs.writeText "schema.sql" ''
-    CREATE USER uniworx;
+    CREATE USER uniworx WITH SUPERUSER;
     CREATE DATABASE uniworx_test;
     GRANT ALL ON DATABASE uniworx_test TO uniworx;
     CREATE DATABASE uniworx;

From 44251428c89fcc6516b5d9655906c58aa9315384 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 30 Jul 2018 17:02:53 +0200
Subject: [PATCH 14/17] Tighten up CSRF

TODO #17
---
 src/Foundation.hs | 61 +++++++++++++++++++++++++++--------------------
 1 file changed, 35 insertions(+), 26 deletions(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index ac7cd37d2..8134af45a 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -25,6 +25,8 @@ import Yesod.Auth.Message
 import Yesod.Auth.Dummy
 import Yesod.Auth.LDAP
 
+import qualified Network.Wai as W (requestMethod)
+
 import LDAP.Data (LDAPScope(..))
 import LDAP.Search (LDAPEntry(..))
 
@@ -456,33 +458,40 @@ instance Yesod UniWorX where
     --   b) Validates that incoming write requests include that token in either a header or POST parameter.
     -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
     -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
-    yesodMiddleware handler = do
-      void . runMaybeT $ do
-        route <- MaybeT getCurrentRoute
-        guardM . lift $ (== Authorized) <$> isAuthorized route False
-        case route of -- update Course Favourites here
-          CourseR tid csh _  -> do
-            uid <- MaybeT maybeAuthId
-            $(logDebug) "Favourites save"
-            now <- liftIO $ getCurrentTime
-            void . lift . runDB . runMaybeT $ do
-              cid  <- MaybeT . getKeyBy $ CourseTermShort tid csh
-              user <- MaybeT $ get uid
-              -- update Favourites
-              void . lift $ upsertBy
-                      (UniqueCourseFavourite uid cid)
-                      (CourseFavourite uid now cid)
-                      [CourseFavouriteTime =. now]
-              -- prune Favourites to user-defined size
-              oldFavs <- lift $ selectKeysList
-                                  [ CourseFavouriteUser ==. uid]
-                                  [ Desc CourseFavouriteTime
-                                  , OffsetBy $ userMaxFavourites user
-                                  ]
-              lift $ mapM_ delete oldFavs
+    yesodMiddleware = updateFavouritesMiddleware . defaultYesodMiddleware . defaultCsrfMiddleware
+      where
+        updateFavouritesMiddleware :: Handler a -> Handler a
+        updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
+          route <- MaybeT getCurrentRoute
+          guardM . lift $ (== Authorized) <$> isAuthorized route False
+          case route of -- update Course Favourites here
+            CourseR tid csh _  -> do
+              uid <- MaybeT maybeAuthId
+              $(logDebug) "Favourites save"
+              now <- liftIO $ getCurrentTime
+              void . lift . runDB . runMaybeT $ do
+                cid  <- MaybeT . getKeyBy $ CourseTermShort tid csh
+                user <- MaybeT $ get uid
+                -- update Favourites
+                void . lift $ upsertBy
+                  (UniqueCourseFavourite uid cid)
+                  (CourseFavourite uid now cid)
+                  [CourseFavouriteTime =. now]
+                -- prune Favourites to user-defined size
+                oldFavs <- lift $ selectKeysList
+                  [ CourseFavouriteUser ==. uid]
+                  [ Desc CourseFavouriteTime
+                  , OffsetBy $ userMaxFavourites user
+                  ]
+                lift $ mapM_ delete oldFavs
+            _other -> return ()
 
-          _other -> return ()
-      defaultYesodMiddleware handler -- handler is executed afterwards, so Favourites are updated immediately
+    -- The following exception permits drive-by login via LDAP plugin. FIXME: Blocked by #17
+    isWriteRequest (AuthR (PluginR "LDAP" _)) = return False
+    isWriteRequest _ = do
+      wai <- waiRequest
+      return $ W.requestMethod wai `notElem`
+        ["GET", "HEAD", "OPTIONS", "TRACE"]
 
     defaultLayout widget = do
         master <- getYesod

From 99d7b5813d13f0e8aa5b4cb77f890243f33f4172 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 30 Jul 2018 18:48:11 +0200
Subject: [PATCH 15/17] Clean up auth-predicate evaluation

---
 messages/de.msg   |  1 +
 src/Foundation.hs | 27 +++++++++------------------
 src/Utils.hs      | 19 ++++++++++++++++++-
 3 files changed, 28 insertions(+), 19 deletions(-)

diff --git a/messages/de.msg b/messages/de.msg
index db368200b..2104013c8 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -116,6 +116,7 @@ DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen.
 UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben.
 MaterialFree: Kursmaterialien ohne Anmeldung zugänglich
 UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
+UnsupportedAuthPredicate tag@String shownRoute@String: "!#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
 
 EMail: E-Mail
 EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 8134af45a..2049e7172 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -183,6 +183,9 @@ instance RenderMessage UniWorX SheetFileType where
       SheetMarking  -> renderMessage' MsgSheetMarking
     where renderMessage' = renderMessage foundation ls
 
+instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
+  renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)
+
 getTimeLocale' :: [Lang] -> TimeLocale
 getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8")])
 
@@ -343,9 +346,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
              && NTop courseRegisterTo   >= cTime
         return Authorized
 
-      r -> do
-         $logErrorS "AccessControl" $ "'!time' used on route that doesn't support it: " <> tshow r
-         unauthorizedI MsgUnauthorized
+      r -> $unsupportedAuthPredicate "time" r
    )
   ,("registered", APDB $ \route _ -> case route of
        CourseR tid csh _ -> exceptT return return $ do
@@ -358,9 +359,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
            return (E.countRows :: E.SqlExpr (E.Value Int64))
          guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant)
          return Authorized
-       r -> do
-         $logErrorS "AccessControl" $ "'!registered' used on route that doesn't support it: " <> tshow r
-         unauthorizedI MsgUnauthorized
+       r -> $unsupportedAuthPredicate "registered" r
    )
   ,("capacity", APDB $ \route _ -> case route of
        CourseR tid csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
@@ -368,18 +367,14 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
          registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
          guard $ NTop courseCapacity > NTop (Just registered)
          return Authorized
-       r -> do
-         $logErrorS "AccessControl" $ "'!capacity' used on route that doesn't support it: " <> tshow r
-         unauthorizedI MsgUnauthorized
+       r -> $unsupportedAuthPredicate "capacity" r
    )
   ,("materials", APDB $ \route _ -> case route of
       CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
         Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh
         guard courseMaterialFree
         return Authorized
-      r -> do
-        $logErrorS "AccessControl" $ "'!materials' used on route that doesn't support it: " <> tshow r
-        unauthorizedI MsgUnauthorized
+      r -> $unsupportedAuthPredicate "materials" r
     )
   ,("owner", APDB $ \route _ -> case route of
        CSubmissionR _ _ _ cID _ -> exceptT return return $ do
@@ -387,9 +382,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
          authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
          void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
          return Authorized
-       r -> do
-         $logErrorS "AccessControl" $ "'!owner' used on route that doesn't support it: " <> tshow r
-         unauthorizedI MsgUnauthorized
+       r -> $unsupportedAuthPredicate "owner" r
    )
   ,("rated", APDB $ \route _ -> case route of
        CSubmissionR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
@@ -397,9 +390,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
          sub <- MaybeT $ get sid
          guard $ submissionRatingDone sub
          return Authorized
-       r -> do
-         $logErrorS "AccessControl" $ "'!rated' used on route that doesn't support it: " <> tshow r
-         unauthorizedI MsgUnauthorized
+       r -> $unsupportedAuthPredicate "rated" r
    )
   ,("isRead",  APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite))
   ,("isWrite", APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized))
diff --git a/src/Utils.hs b/src/Utils.hs
index 20c395570..36412836a 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -4,7 +4,8 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, UndecidableInstances #-}
 {-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult
 
 module Utils
@@ -39,6 +40,11 @@ import Control.Monad.Catch
 
 import qualified Database.Esqueleto as E (Value, unValue)
 
+import Language.Haskell.TH
+import Instances.TH.Lift ()
+
+import Text.Shakespeare.Text (st)
+
 -----------
 -- Yesod --
 -----------
@@ -61,6 +67,17 @@ guardAuthResult AuthenticationRequired = notAuthenticated
 guardAuthResult (Unauthorized t) = permissionDenied t
 guardAuthResult Authorized = return ()
 
+data UnsupportedAuthPredicate route = UnsupportedAuthPredicate String route
+  deriving (Eq, Ord, Typeable, Show)
+instance (Show route, Typeable route) => Exception (UnsupportedAuthPredicate route)
+
+unsupportedAuthPredicate :: ExpQ
+unsupportedAuthPredicate = do
+  logFunc <- logErrorS
+  [e| \tag route -> do
+        $(return logFunc) "AccessControl" [st|"!#{tag}" used on route that doesn't support it: #{tshow route}|]
+        unauthorizedI (UnsupportedAuthPredicate tag route)
+    |]
 
 
 ---------------------

From c1cff156a1351395aaebe5df35826cbada920199 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 30 Jul 2018 22:35:31 +0200
Subject: [PATCH 16/17] Normalize paths & CryptoFileNameSubmission-prefix

---
 models                          |  1 +
 src/CryptoID.hs                 |  9 +++-
 src/Foundation.hs               | 88 ++++++++++++++++++++++++++-------
 src/Handler/CryptoIDDispatch.hs | 20 ++++----
 src/Handler/Submission.hs       |  2 +-
 src/Handler/Utils/Rating.hs     |  9 ++--
 src/Handler/Utils/Submission.hs | 15 ++++--
 7 files changed, 106 insertions(+), 38 deletions(-)

diff --git a/models b/models
index 47f6f824a..e68c47c43 100644
--- a/models
+++ b/models
@@ -83,6 +83,7 @@ CourseFavourite
     time         UTCTime
     course       CourseId
     UniqueCourseFavourite user course
+    deriving Show
 Lecturer 
     user         UserId
     course       CourseId
diff --git a/src/CryptoID.hs b/src/CryptoID.hs
index b8b4b2eed..3b5efceec 100644
--- a/src/CryptoID.hs
+++ b/src/CryptoID.hs
@@ -20,6 +20,7 @@ import CryptoID.TH
 import ClassyPrelude hiding (fromString)
 import Model
 
+import qualified Data.CryptoID as E
 import Data.CryptoID.Poly.ImplicitNamespace
 import Data.UUID.Cryptographic.ImplicitNamespace
 import System.FilePath.Cryptographic.ImplicitNamespace
@@ -39,7 +40,7 @@ instance PathPiece UUID where
 
 instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
   fromPathPiece = fmap CI.mk . fromPathPiece
-  toPathPiece = toPathPiece . CI.foldedCase
+  toPathPiece = toPathPiece . CI.original
 
 instance {-# OVERLAPS #-} PathMultiPiece FilePath where
   fromPathMultiPiece = Just . unpack . intercalate "/"
@@ -55,8 +56,12 @@ decCryptoIDs [ ''SubmissionId
              , ''FileId
              , ''UserId
              ]
-{- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -}
 
+instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where
+  fromPathPiece (Text.unpack -> piece) = do
+    piece' <- (stripPrefix `on` map CI.mk) "uwa" piece
+    return . CryptoID . CI.mk $ map CI.original piece'
+  toPathPiece = Text.pack . ("uwa" <>) . CI.foldedCase . ciphertext
 
 
 newtype SubmissionMode = SubmissionMode (Maybe CryptoFileNameSubmission)
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 2049e7172..51d839610 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -9,9 +9,9 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE PatternGuards, MultiWayIf #-}
 {-# LANGUAGE TupleSections #-}
-{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances, UndecidableInstances, FlexibleContexts #-}
 
 module Foundation where
 
@@ -25,7 +25,7 @@ import Yesod.Auth.Message
 import Yesod.Auth.Dummy
 import Yesod.Auth.LDAP
 
-import qualified Network.Wai as W (requestMethod)
+import qualified Network.Wai as W (requestMethod, pathInfo)
 
 import LDAP.Data (LDAPScope(..))
 import LDAP.Search (LDAPEntry(..))
@@ -37,14 +37,14 @@ import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Text.Encoding as TE
 
+import qualified Data.CryptoID as E
+
 import Data.ByteArray (convert)
 import Crypto.Hash (Digest, SHAKE256)
 import Crypto.Hash.Conduit (sinkHash)
 
 import Yesod.Auth.Util.PasswordStore
 
-import qualified Data.CryptoID (CryptoID) -- for DisplayAble instance only
-
 import qualified Data.ByteString.Base64.URL as Base64 (encode)
 
 import Data.ByteString (ByteString)
@@ -60,6 +60,8 @@ import qualified Data.Set as Set
 import Data.Map (Map, (!?))
 import qualified Data.Map as Map
 
+import Data.Monoid (Any(..))
+
 
 import Data.Conduit (($$))
 import Data.Conduit.List (sourceList)
@@ -69,6 +71,9 @@ import qualified Database.Esqueleto as E
 import Control.Monad.Except (MonadError(..), runExceptT)
 import Control.Monad.Trans.Maybe (MaybeT(..))
 import Control.Monad.Trans.Reader (runReader)
+import Control.Monad.Trans.Writer (WriterT(..))
+import Control.Monad.Writer.Class (MonadWriter(..))
+import Control.Monad.Catch (handleAll)
 
 import System.FilePath
 
@@ -85,15 +90,15 @@ import qualified Data.Yaml as Yaml
 import Text.Shakespeare.Text (st)
 
 
+instance DisplayAble b => DisplayAble (E.CryptoID a b) where
+  display = display . ciphertext
+
+instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => DisplayAble (E.CryptoID namespace (CI FilePath)) where
+  display = toPathPiece
 
--- -- TODO: Move the following to the appropriate place, if DisplayAble is kept
 instance DisplayAble TermId where
   display = termToText . unTermKey
 
-instance (PathPiece b) => DisplayAble (Data.CryptoID.CryptoID a b) where
-  display = toPathPiece -- requires import of Data.CryptoID here
--- -- MOVE ABOVE
-
 
 -- infixl 9 :$:
 -- pattern a :$: b = a b
@@ -449,24 +454,28 @@ instance Yesod UniWorX where
     --   b) Validates that incoming write requests include that token in either a header or POST parameter.
     -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
     -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
-    yesodMiddleware = updateFavouritesMiddleware . defaultYesodMiddleware . defaultCsrfMiddleware
+    yesodMiddleware = defaultYesodMiddleware . normalizeRouteMiddleware . defaultCsrfMiddleware . updateFavouritesMiddleware
       where
         updateFavouritesMiddleware :: Handler a -> Handler a
         updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
           route <- MaybeT getCurrentRoute
-          guardM . lift $ (== Authorized) <$> isAuthorized route False
           case route of -- update Course Favourites here
             CourseR tid csh _  -> do
-              uid <- MaybeT maybeAuthId
-              $(logDebug) "Favourites save"
-              now <- liftIO $ getCurrentTime
               void . lift . runDB . runMaybeT $ do
+                guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid csh CShowR) False
+                $logDebugS "updateFavourites" "Updating favourites"
+
+                now <- liftIO $ getCurrentTime
+                uid <- MaybeT $ liftHandlerT maybeAuthId
                 cid  <- MaybeT . getKeyBy $ CourseTermShort tid csh
                 user <- MaybeT $ get uid
+                let courseFavourite = CourseFavourite uid now cid
+    
+                $logDebugS "updateFavourites" [st|Updating/Inserting: #{tshow courseFavourite}|]
                 -- update Favourites
                 void . lift $ upsertBy
                   (UniqueCourseFavourite uid cid)
-                  (CourseFavourite uid now cid)
+                  courseFavourite
                   [CourseFavouriteTime =. now]
                 -- prune Favourites to user-defined size
                 oldFavs <- lift $ selectKeysList
@@ -474,8 +483,17 @@ instance Yesod UniWorX where
                   [ Desc CourseFavouriteTime
                   , OffsetBy $ userMaxFavourites user
                   ]
-                lift $ mapM_ delete oldFavs
+                lift . forM_ oldFavs $ \fav -> do
+                  $logDebugS "updateFavourites" "Deleting old favourite."
+                  delete fav
             _other -> return ()
+        normalizeRouteMiddleware :: Handler a -> Handler a
+        normalizeRouteMiddleware handler = (*> handler) . runMaybeT $ do
+          route <- MaybeT getCurrentRoute
+          (route', getAny -> changed) <- lift . runDB . runWriterT $ foldM (&) route routeNormalizers
+          when changed $ do
+            $logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|]
+            redirectWith movedPermanently301 route'
 
     -- The following exception permits drive-by login via LDAP plugin. FIXME: Blocked by #17
     isWriteRequest (AuthR (PluginR "LDAP" _)) = return False
@@ -985,6 +1003,42 @@ pageHeading _
   = Nothing
 
 
+routeNormalizers :: [Route UniWorX -> WriterT Any (ReaderT (YesodPersistBackend UniWorX) (HandlerT UniWorX IO)) (Route UniWorX)]
+routeNormalizers =
+  [ normalizeRender
+  , ncCourse
+  , ncSheet
+  ]
+  where
+    normalizeRender route = route <$ do
+      YesodRequest{..} <- liftHandlerT getRequest
+      let original = (W.pathInfo reqWaiRequest, reqGetParams)
+          rendered = renderRoute route
+      if
+        | (isSuffixOf `on` fst) original rendered -> do -- FIXME: this breaks when subsite prefixes are dynamic
+            $logDebugS "normalizeRender" [st|#{tshow rendered} matches #{tshow original}|]
+        | otherwise -> do
+            $logDebugS "normalizeRender" [st|Redirecting because #{tshow rendered} does not match #{tshow original}|]
+            tell $ Any True
+    maybeOrig f route = maybeT (return route) $ f route
+    hasChanged a b
+      | ((/=) `on` CI.original) a b = do
+          $logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|]
+          tell $ Any True
+      | otherwise                   = return ()
+    ncCourse = maybeOrig $ \route -> do
+      CourseR tid csh subRoute <- return route
+      Entity _ Course{..} <- MaybeT . lift . getBy $ CourseTermShort tid csh
+      hasChanged csh courseShorthand
+      return $ CourseR tid courseShorthand subRoute
+    ncSheet = maybeOrig $ \route -> do
+      CSheetR tid csh shn subRoute <- return route
+      Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh
+      Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn
+      hasChanged shn sheetName
+      return $ CSheetR tid csh sheetName subRoute
+
+  
 -- How to run database actions.
 instance YesodPersist UniWorX where
     type YesodPersistBackend UniWorX = SqlBackend
diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs
index 32781c28d..6f198828b 100644
--- a/src/Handler/CryptoIDDispatch.hs
+++ b/src/Handler/CryptoIDDispatch.hs
@@ -21,7 +21,7 @@ import Import hiding (Proxy)
 
 import Data.Proxy
 
-import Handler.Utils
+import qualified Data.Text as Text
 
 import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
 
@@ -46,14 +46,16 @@ instance CryptoRoute UUID SubmissionId where
     return $ CSubmissionR tid csh shn cID' SubShowR
 
 instance CryptoRoute (CI FilePath) SubmissionId where
-  cryptoIDRoute _ (CryptoID -> cID) = do
-    (smid :: SubmissionId) <- decrypt cID
-    (tid,csh,shn) <- runDB $ do
-      shid <- submissionSheet <$> get404 smid
-      Sheet{..}  <- get404 shid
-      Course{..} <- get404 sheetCourse
-      return (courseTerm, courseShorthand, sheetName)
-    return $ CSubmissionR tid csh shn cID SubShowR
+  cryptoIDRoute _ ciphertext
+    | Just cID <- fromPathPiece . Text.pack $ CI.original ciphertext = do
+        smid <- decrypt cID
+        (tid,csh,shn) <- runDB $ do
+          shid <- submissionSheet <$> get404 smid
+          Sheet{..}  <- get404 shid
+          Course{..} <- get404 sheetCourse
+          return (courseTerm, courseShorthand, sheetName)
+        return $ CSubmissionR tid csh shn cID SubShowR
+    | otherwise = notFound
 
 instance CryptoRoute UUID UserId where
   cryptoIDRoute _ (CryptoID -> cID) = do
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index 37e2c9c56..73f68f988 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -343,7 +343,7 @@ getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path =
             error "Multiple matching files found."
 
 getSubArchiveR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
-getSubArchiveR tid csh shn cID@CryptoID{..} (ZIPArchiveName sfType) = do
+getSubArchiveR tid csh shn cID (ZIPArchiveName sfType) = do
   when (sfType == SubmissionCorrected) $ 
     guardAuthResult =<< evalAccess (CSubmissionR tid csh shn cID CorrectionR) False
 
diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs
index 9fa4b97d1..7702a7d52 100644
--- a/src/Handler/Utils/Rating.hs
+++ b/src/Handler/Utils/Rating.hs
@@ -133,7 +133,7 @@ formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let
       , ("Korrektor:" <+>) . pretty <$> ratingCorrectorName
       , Just $ "Bewertung:" <+> pretty (display ratingSheetType)
       ]
-    , "Abgabe-Id:" <+> pretty (ciphertext cID)
+    , "Abgabe-Id:" <+> pretty (Text.unpack $ toPathPiece cID)
     , "============================================="
     , "Bewertung:" <+> pretty ratingPoints
     , "=========== Beginn der Kommentare ==========="
@@ -145,7 +145,7 @@ ratingFile :: MonadIO m => CryptoFileNameSubmission -> Rating -> m File
 ratingFile cID rating@(Rating{ ratingValues = Rating'{..}, .. }) = do
   fileModified <- maybe (liftIO getCurrentTime) return ratingTime
   let
-    fileTitle = "bewertung_" <> (CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)) <.> "txt"
+    fileTitle = "bewertung_" <> (Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission)) <.> "txt"
     fileContent = Just . Lazy.ByteString.toStrict $ formatRating cID rating
   return File{..}
 
@@ -212,7 +212,8 @@ isRatingFile fName
 isRatingFile' :: FilePath -> Maybe CryptoFileNameSubmission
 isRatingFile' (takeFileName -> fName)
   | (bName, ".txt") <- splitExtension fName
-  , Just (CI.mk -> ciphertext) <- stripPrefix "bewertung_" bName
-  = Just CryptoID{..}
+  , Just piece <- stripPrefix "bewertung_" bName
+  , Just cID <- fromPathPiece $ Text.pack piece
+  = Just cID
   | otherwise
   = Nothing
diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs
index 28a8a3abc..097a505d8 100644
--- a/src/Handler/Utils/Submission.hs
+++ b/src/Handler/Utils/Submission.hs
@@ -10,6 +10,7 @@
 {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 
 module Handler.Utils.Submission
@@ -43,6 +44,8 @@ import qualified Data.Set as Set
 import Data.Map (Map, (!?))
 import qualified Data.Map as Map
 
+import qualified Data.Text as Text
+
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 
@@ -159,7 +162,7 @@ submissionMultiArchive (Set.toList -> ids) = do
         cID <- encrypt submissionID
 
         let
-          directoryName = CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)
+          directoryName = Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission)
               
           fileEntitySource = do
             submissionFileSource submissionID =$= Conduit.map entityVal
@@ -480,9 +483,11 @@ sinkMultiSubmission userId isUpdate = do
         acc (Just sId, fp) segment = return (Just sId, fp ++ [segment])
         acc (Nothing , fp) segment = do
           let
-            tryDecrypt ciphertext = do
-              sId <- decrypt (CryptoID (CI.mk segment) :: CryptoFileNameSubmission)
-              Just sId <$ get404 sId
+            tryDecrypt (Text.pack -> ciphertext)
+              | Just cID <- fromPathPiece ciphertext = do
+                  sId <- decrypt (cID :: CryptoFileNameSubmission)
+                  Just sId <$ get404 sId
+              | otherwise = return Nothing
           msId <- lift (lift $ tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ]
           return (msId, fp)
       (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle
@@ -515,4 +520,4 @@ submissionMatchesSheet tid csh shn cid = do
   shid <- fetchSheetId tid csh shn
   Submission{..} <- get404 sid
   when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
-  return sid
\ No newline at end of file
+  return sid

From 534c7183ff7e8d6cf2612b8e31516828011e44ac Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 30 Jul 2018 23:29:58 +0200
Subject: [PATCH 17/17] Two-digit years

---
 messages/de.msg       |  2 +-
 src/Foundation.hs     | 11 ++++++++++-
 src/Handler/Term.hs   |  2 +-
 src/Model/Types.hs    | 29 ++++++++++++++++++++++++-----
 src/Utils/DateTime.hs |  7 +++++++
 5 files changed, 43 insertions(+), 8 deletions(-)

diff --git a/messages/de.msg b/messages/de.msg
index 2104013c8..8b271d82e 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -12,7 +12,7 @@ DeRegUntil: Abmeldungen bis
 SummerTerm year@Integer: Sommersemester #{display year}
 WinterTerm year@Integer: Wintersemester #{display year}/#{display $ succ year}
 SummerTermShort year@Integer: SoSe #{display year}
-WinterTermShort year@Integer: WiSe #{display year}/#{display $ succ year}
+WinterTermShort year@Integer: WiSe #{display year}/#{display $ mod (succ year) 100}
 PSLimitNonPositive: “pagesize” muss größer als null sein
 Page n@Int64: #{display n}
 
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 51d839610..b8f8fe169 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -177,6 +177,15 @@ instance RenderMessage UniWorX TermIdentifier where
     Winter -> renderMessage' $ MsgWinterTerm year
     where renderMessage' = renderMessage foundation ls
 
+newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
+  deriving (Eq, Ord, Read, Show)
+
+instance RenderMessage UniWorX ShortTermIdentifier where
+  renderMessage foundation ls (ShortTermIdentifier TermIdentifier{..}) = case season of
+    Summer -> renderMessage' $ MsgSummerTermShort year
+    Winter -> renderMessage' $ MsgWinterTermShort year
+    where renderMessage' = renderMessage foundation ls
+
 instance RenderMessage UniWorX String where
   renderMessage f ls str = renderMessage f ls $ Text.pack str
 
@@ -657,7 +666,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb TermCurrentR           = return ("Aktuell"   , Just TermShowR)
   breadcrumb TermEditR              = return ("Neu"       , Just TermCurrentR)
   breadcrumb (TermEditExistR tid)   = return ("Editieren" , Just $ TermCourseListR tid)
-  breadcrumb (TermCourseListR term) = return (display term, Just TermShowR)
+  breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Just TermShowR)
 
   breadcrumb  CourseListR                 = return ("Kurs"     , Just HomeR)
   breadcrumb  CourseNewR                  = return ("Neu"      , Just CourseListR)
diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs
index 89547f436..20f12eaa3 100644
--- a/src/Handler/Term.hs
+++ b/src/Handler/Term.hs
@@ -44,7 +44,7 @@ getTermShowR = do
       let colonnadeTerms = widgetColonnade $ mconcat
             [ sortable Nothing "Kürzel" $
                 anchorCell' (\(Entity tid _, _) -> TermCourseListR tid)
-                            (\(Entity tid _, _) -> [whamlet|#{display tid}|])
+                            (\(Entity tid _, _) -> [whamlet|#{toPathPiece tid}|])
             , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) ->
                 cell $ formatTime SelFormatDate termLectureStart >>= toWidget
             , sortable (Just "lecture-end") "Ende Vorlesungen"   $ \(Entity _ Term{..},_) ->
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index 2d62a610b..bf035c79c 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -14,6 +14,7 @@ module Model.Types where
 
 import ClassyPrelude
 import Utils
+import Control.Lens
 
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -204,17 +205,35 @@ data TermIdentifier = TermIdentifier
 -- from_TermId_to_TermIdentifier = unTermKey
 -- from_TermIdentifier_to_TermId = TermKey
 
-instance DisplayAble TermIdentifier where
-  display = termToText
+shortened :: Iso' Integer Integer
+shortened = iso shorten expand
+  where
+    century = ($currentYear `div` 100) * 100
+    expand year
+      | 0 <= year
+      , year < 100 = let
+          options = [ expanded | offset <- [-1, 0, 1]
+                               , let century' = century + offset * 100
+                                     expanded = century' + year
+                               , $currentYear - 50 <= expanded
+                               , expanded < $currentYear + 50
+                               ]
+          in case options of
+               [unique] -> unique
+               failed   -> error $ "Could not expand year " ++ show year ++ ": " ++ show failed
+      | otherwise = year
+    shorten year
+      | $currentYear - 50 <= year
+      , year < $currentYear + 50 = year `mod` 100
+      | otherwise = year
 
---TODO: Enforce the number of digits within year, with parsing filling in the current leading digits? Goal: short urls
 termToText :: TermIdentifier -> Text
-termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show year
+termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened)
 
 termFromText :: Text -> Either Text TermIdentifier
 termFromText t
   | (s:ys) <- Text.unpack t
-  , Just year <- readMaybe ys
+  , Just (review shortened -> year) <- readMaybe ys
   , Right season <- seasonFromChar s
   = Right TermIdentifier{..}
   | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”"
diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs
index 23c08df08..cb9135120 100644
--- a/src/Utils/DateTime.hs
+++ b/src/Utils/DateTime.hs
@@ -9,6 +9,7 @@
 module Utils.DateTime
   ( timeLocaleMap
   , TimeLocale(..)
+  , currentYear
   , module Data.Time.Zones
   , module Data.Time.Zones.TH
   ) where
@@ -55,3 +56,9 @@ timeLocaleMap extra@((_, defLocale):_) = do
     localeExp = lift <=< runIO . getLocale . Just
   
   letE [localeMap'] (varE localeMap)
+
+currentYear :: ExpQ
+currentYear = do
+  now <- runIO getCurrentTime
+  let (year, _, _) = toGregorian $ utctDay now
+  [e|year|]