From c757bf9a005e1f343c46052025350c5de1aa42e4 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 5 Dec 2018 15:07:24 +0100
Subject: [PATCH 01/10] Include preload hints about static content

---
 src/Foundation.hs           | 18 ++++++++++++++----
 src/Handler/Utils/Rating.hs |  2 +-
 src/Utils/Lens.hs           |  2 +-
 3 files changed, 16 insertions(+), 6 deletions(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index 0dc658312..80f979ff3 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -710,11 +710,19 @@ instance Yesod UniWorX where
       UniWorX{appWidgetMemcached, appSettings} <- getYesod
       for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings) $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
         let expiry = (maybe 0 ceiling widgetMemcachedExpiry)
-            touch = liftIO $ Memcached.touch expiry fileName mConn
-            add = liftIO $ Memcached.add zeroBits expiry fileName content mConn
+            touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
+            add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
+            link = pack $ unpack widgetMemcachedBaseUrl </> fileName
+            linkAs :: Maybe Text
+            linkAs
+              | ext == "js"  = Just "script"
+              | ext == "css" = Just "style"
+              | otherwise    = Nothing
         C.catchIf Memcached.isKeyNotFound touch $ \_ ->
           C.handleIf Memcached.isKeyExists (\_ -> return ()) add
-        return . Left $ widgetMemcachedBaseUrl <> "/" <> decodeUtf8 fileName
+        whenIsJust linkAs $ \linkAs' -> 
+          addHeader "Link" [st|<#{link}>; as=#{linkAs'}; rel=preload|]
+        return $ Left link
       where
         -- Generate a unique filename based on the content itself, this is used
         -- for deduplication so a collision resistant hash function is required
@@ -723,7 +731,9 @@ instance Yesod UniWorX where
         --
         -- Length of hash is 144 bits instead of MD5's 128, so as to avoid
         -- padding after base64-conversion
-        fileName = (<> ("." <> encodeUtf8 ext))
+        fileName = (<.> unpack ext)
+                 . unpack
+                 . decodeUtf8
                  . Base64.encode
                  . (convert :: Digest (SHAKE256 144) -> ByteString)
                  . runIdentity
diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs
index be259344f..624b6cea4 100644
--- a/src/Handler/Utils/Rating.hs
+++ b/src/Handler/Utils/Rating.hs
@@ -41,7 +41,7 @@ import qualified Database.Esqueleto as E
 
 import qualified Data.Conduit.List as Conduit
 
-import Utils.Lens hiding ((<.>))
+import Utils.Lens
 
 
 instance HasResolution prec => Pretty (Fixed prec) where
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index 7d7df4350..7d71d63ef 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -1,7 +1,7 @@
 module Utils.Lens ( module Utils.Lens ) where
 
 import Import.NoFoundation
-import Control.Lens as Utils.Lens
+import Control.Lens as Utils.Lens hiding ((<.>))
 import Control.Lens.Extras as Utils.Lens (is)
 import Utils.Lens.TH as Utils.Lens (makeLenses_)
 

From e94173acb10a3f7bfba91e78e53ddb246a2f8ff5 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 5 Dec 2018 15:13:12 +0100
Subject: [PATCH 02/10] Fix build

---
 src/Handler/Utils/SheetType.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Handler/Utils/SheetType.hs b/src/Handler/Utils/SheetType.hs
index 69885e759..150b7cd63 100644
--- a/src/Handler/Utils/SheetType.hs
+++ b/src/Handler/Utils/SheetType.hs
@@ -5,7 +5,7 @@ module Handler.Utils.SheetType
 
 import Import
 import Data.Monoid (Sum(..))
-import Utils.Lens hiding ((<.>))
+import Utils.Lens
 
 addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
 addBonusToPoints sts =

From 3f60f6391c8a3625a3baa19c89cfa3e885f75bb5 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 5 Dec 2018 15:30:51 +0100
Subject: [PATCH 03/10] Revert "Include preload hints about static content"

This reverts commit c757bf9a005e1f343c46052025350c5de1aa42e4.
---
 src/Foundation.hs           | 18 ++++--------------
 src/Handler/Utils/Rating.hs |  2 +-
 src/Utils/Lens.hs           |  2 +-
 3 files changed, 6 insertions(+), 16 deletions(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index 86216a4ed..a3a63fb55 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -721,19 +721,11 @@ instance Yesod UniWorX where
       UniWorX{appWidgetMemcached, appSettings} <- getYesod
       for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings) $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
         let expiry = (maybe 0 ceiling widgetMemcachedExpiry)
-            touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
-            add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
-            link = pack $ unpack widgetMemcachedBaseUrl </> fileName
-            linkAs :: Maybe Text
-            linkAs
-              | ext == "js"  = Just "script"
-              | ext == "css" = Just "style"
-              | otherwise    = Nothing
+            touch = liftIO $ Memcached.touch expiry fileName mConn
+            add = liftIO $ Memcached.add zeroBits expiry fileName content mConn
         C.catchIf Memcached.isKeyNotFound touch $ \_ ->
           C.handleIf Memcached.isKeyExists (\_ -> return ()) add
-        whenIsJust linkAs $ \linkAs' -> 
-          addHeader "Link" [st|<#{link}>; as=#{linkAs'}; rel=preload|]
-        return $ Left link
+        return . Left $ widgetMemcachedBaseUrl <> "/" <> decodeUtf8 fileName
       where
         -- Generate a unique filename based on the content itself, this is used
         -- for deduplication so a collision resistant hash function is required
@@ -742,9 +734,7 @@ instance Yesod UniWorX where
         --
         -- Length of hash is 144 bits instead of MD5's 128, so as to avoid
         -- padding after base64-conversion
-        fileName = (<.> unpack ext)
-                 . unpack
-                 . decodeUtf8
+        fileName = (<> ("." <> encodeUtf8 ext))
                  . Base64.encode
                  . (convert :: Digest (SHAKE256 144) -> ByteString)
                  . runIdentity
diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs
index fc4e88574..8c8b4f273 100644
--- a/src/Handler/Utils/Rating.hs
+++ b/src/Handler/Utils/Rating.hs
@@ -41,7 +41,7 @@ import qualified Database.Esqueleto as E
 
 import qualified Data.Conduit.List as Conduit
 
-import Utils.Lens
+import Utils.Lens hiding ((<.>))
 
 
 instance HasResolution prec => Pretty (Fixed prec) where
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index 7d71d63ef..7d7df4350 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -1,7 +1,7 @@
 module Utils.Lens ( module Utils.Lens ) where
 
 import Import.NoFoundation
-import Control.Lens as Utils.Lens hiding ((<.>))
+import Control.Lens as Utils.Lens
 import Control.Lens.Extras as Utils.Lens (is)
 import Utils.Lens.TH as Utils.Lens (makeLenses_)
 

From 7fc705730d5d70e4c1ae03826503618e2bb82eda Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 5 Dec 2018 17:57:13 +0100
Subject: [PATCH 04/10] Minor cleanup

---
 src/Foundation.hs           | 11 +++++++----
 src/Handler/Utils/Rating.hs |  2 +-
 src/Utils/Lens.hs           |  2 +-
 3 files changed, 9 insertions(+), 6 deletions(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index a3a63fb55..ab9552bdf 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -721,11 +721,12 @@ instance Yesod UniWorX where
       UniWorX{appWidgetMemcached, appSettings} <- getYesod
       for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings) $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
         let expiry = (maybe 0 ceiling widgetMemcachedExpiry)
-            touch = liftIO $ Memcached.touch expiry fileName mConn
-            add = liftIO $ Memcached.add zeroBits expiry fileName content mConn
+            touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
+            add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
+            absoluteLink = unpack widgetMemcachedBaseUrl </> fileName
         C.catchIf Memcached.isKeyNotFound touch $ \_ ->
           C.handleIf Memcached.isKeyExists (\_ -> return ()) add
-        return . Left $ widgetMemcachedBaseUrl <> "/" <> decodeUtf8 fileName
+        return . Left $ pack absoluteLink
       where
         -- Generate a unique filename based on the content itself, this is used
         -- for deduplication so a collision resistant hash function is required
@@ -734,7 +735,9 @@ instance Yesod UniWorX where
         --
         -- Length of hash is 144 bits instead of MD5's 128, so as to avoid
         -- padding after base64-conversion
-        fileName = (<> ("." <> encodeUtf8 ext))
+        fileName = (<.> unpack ext)
+                 . unpack
+                 . decodeUtf8
                  . Base64.encode
                  . (convert :: Digest (SHAKE256 144) -> ByteString)
                  . runIdentity
diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs
index 8c8b4f273..fc4e88574 100644
--- a/src/Handler/Utils/Rating.hs
+++ b/src/Handler/Utils/Rating.hs
@@ -41,7 +41,7 @@ import qualified Database.Esqueleto as E
 
 import qualified Data.Conduit.List as Conduit
 
-import Utils.Lens hiding ((<.>))
+import Utils.Lens
 
 
 instance HasResolution prec => Pretty (Fixed prec) where
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index 7d7df4350..7d71d63ef 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -1,7 +1,7 @@
 module Utils.Lens ( module Utils.Lens ) where
 
 import Import.NoFoundation
-import Control.Lens as Utils.Lens
+import Control.Lens as Utils.Lens hiding ((<.>))
 import Control.Lens.Extras as Utils.Lens (is)
 import Utils.Lens.TH as Utils.Lens (makeLenses_)
 

From 5c8f837b88431727e6805d54f675b341276362c1 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 5 Dec 2018 19:47:18 +0100
Subject: [PATCH 05/10] Minor cleanup

---
 messages/uniworx/de.msg |  2 +-
 src/Foundation.hs       | 20 ++++++++++----------
 src/Utils.hs            | 19 ++++++++++---------
 3 files changed, 21 insertions(+), 20 deletions(-)

diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 8b15af8b0..1595dc8d9 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -171,7 +171,7 @@ MaterialFree: Kursmaterialien ohne Anmeldung zugänglich
 UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
 UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar.
 UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar.
-UnsupportedAuthPredicate tag@String shownRoute@String: "#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
+UnsupportedAuthPredicate authTagT@Text shownRoute@String: "#{authTagT}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
 UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv
 UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt
 
diff --git a/src/Foundation.hs b/src/Foundation.hs
index ab9552bdf..601db3527 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -454,7 +454,7 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
          && NTop systemMessageTo   >= cTime
     return Authorized
 
-  r -> $unsupportedAuthPredicate "time" r
+  r -> $unsupportedAuthPredicate AuthTime r
 tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
   CourseR tid ssh csh _ -> exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
@@ -467,14 +467,14 @@ tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
       return (E.countRows :: E.SqlExpr (E.Value Int64))
     guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant)
     return Authorized
-  r -> $unsupportedAuthPredicate "registered" r
+  r -> $unsupportedAuthPredicate AuthRegistered r
 tagAccessPredicate AuthCapacity = APDB $ \route _ -> case route of
   CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
     Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
     guard $ NTop courseCapacity > NTop (Just registered)
     return Authorized
-  r -> $unsupportedAuthPredicate "capacity" r
+  r -> $unsupportedAuthPredicate AuthCapacity r
 tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of
   CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
     -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
@@ -482,41 +482,41 @@ tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of
     registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
     guard $ registered <= 0
     return Authorized
-  r -> $unsupportedAuthPredicate "empty" r
+  r -> $unsupportedAuthPredicate AuthEmpty r
 tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of
   CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
     Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     guard courseMaterialFree
     return Authorized
-  r -> $unsupportedAuthPredicate "materials" r
+  r -> $unsupportedAuthPredicate AuthMaterials r
 tagAccessPredicate AuthOwner = APDB $ \route _ -> case route of
   CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do
     sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
     authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
     void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
     return Authorized
-  r -> $unsupportedAuthPredicate "owner" r
+  r -> $unsupportedAuthPredicate AuthOwner r
 tagAccessPredicate AuthRated = 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 -> $unsupportedAuthPredicate "rated" r
+  r -> $unsupportedAuthPredicate AuthRated r
 tagAccessPredicate AuthUserSubmissions = APDB $ \route _ -> case route of
   CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
     Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
     guard $ sheetSubmissionMode == UserSubmissions
     return Authorized
-  r -> $unsupportedAuthPredicate "user-submissions" r
+  r -> $unsupportedAuthPredicate AuthUserSubmissions r
 tagAccessPredicate AuthCorrectorSubmissions = APDB $ \route _ -> case route of
   CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
     Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
     Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
     guard $ sheetSubmissionMode == CorrectorSubmissions
     return Authorized
-  r -> $unsupportedAuthPredicate "corrector-submissions" r
+  r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
 tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of
   MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
     smId <- decrypt cID
@@ -524,7 +524,7 @@ tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of
     isAuthenticated <- isJust <$> liftHandlerT maybeAuthId
     guard $ not systemMessageAuthenticatedOnly || isAuthenticated
     return Authorized
-  r -> $unsupportedAuthPredicate "authentication" r
+  r -> $unsupportedAuthPredicate AuthAuthentication r
 tagAccessPredicate AuthRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
 tagAccessPredicate AuthWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
 
diff --git a/src/Utils.hs b/src/Utils.hs
index 0bd5a400d..fed726e6f 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -63,6 +63,9 @@ import qualified Crypto.Saltine.Core.SecretBox as SecretBox
 import qualified Crypto.Saltine.Class as Saltine
 import qualified Crypto.Data.PKCS7 as PKCS7
 
+import Data.Fixed (Centi)
+import Data.Ratio ((%))
+
 
 
 -----------
@@ -87,7 +90,7 @@ guardAuthResult AuthenticationRequired = notAuthenticated
 guardAuthResult (Unauthorized t) = permissionDenied t
 guardAuthResult Authorized = return ()
 
-data UnsupportedAuthPredicate route = UnsupportedAuthPredicate String route
+data UnsupportedAuthPredicate route = UnsupportedAuthPredicate Text route
   deriving (Eq, Ord, Typeable, Show)
 instance (Show route, Typeable route) => Exception (UnsupportedAuthPredicate route)
 
@@ -95,8 +98,8 @@ 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)
+        $(return logFunc) "AccessControl" [st|"!#{toPathPiece tag}" used on route that doesn't support it: #{tshow route}|]
+        unauthorizedI (UnsupportedAuthPredicate (toPathPiece tag) route)
     |]
 
 
@@ -204,17 +207,15 @@ instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out
   display = pack . show
 -}
 
-textPercent :: Double -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
+textPercent :: Real a => a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
 textPercent x = lz <> pack (show rx) <> "%"
  where
-   round' :: Double -> Int -- avoids annoying warning
-   round' = round
-   rx :: Double
-   rx = fromIntegral (round' $ 1000.0*x) / 10.0
+   rx :: Centi
+   rx = realToFrac (x * 100)
    lz = if rx < 10.0 then "0" else ""
 
 textPercentInt :: Integral a => a -> a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
-textPercentInt part whole = textPercent $ (fromIntegral part) / (fromIntegral whole)
+textPercentInt part whole = textPercent $ fromIntegral part % fromIntegral whole
 
 stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes
 stepTextCounterCI = CI.map stepTextCounter

From 32e6306cd512a97f3852152cb9557c6e276532a4 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 5 Dec 2018 20:57:04 +0100
Subject: [PATCH 06/10] Fix typo breaking modals without memcached

---
 templates/standalone/modal.julius | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/templates/standalone/modal.julius b/templates/standalone/modal.julius
index 607e9a7fe..5c2eb991c 100644
--- a/templates/standalone/modal.julius
+++ b/templates/standalone/modal.julius
@@ -76,7 +76,7 @@
 
                 var scriptClone = document.createElement('script');
                 if (scriptTag.text)
-                  scriptClone.text = striptTag.text;
+                  scriptClone.text = scriptTag.text;
                 if (scriptTag.hasAttributes()) {
                   var attrs = scriptTag.attributes;
                   for (var i = attrs.length - 1; i >= 0; i--) {

From 19413380753684aa0d378e31f7e489279d0c5b0b Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 5 Dec 2018 21:52:37 +0100
Subject: [PATCH 07/10] Cleanup pseudonym handling

Fixes #247
---
 src/Handler/Corrections.hs | 167 ++++++++++++++++++++-----------------
 test/Database.hs           |  10 ++-
 2 files changed, 101 insertions(+), 76 deletions(-)

diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 31465c5f8..803ef4bae 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -14,12 +14,13 @@ import Utils.Lens
 
 import Data.Set (Set)
 import qualified Data.Set as Set
-import Data.Map (Map)
+import Data.Map (Map, (!))
 import qualified Data.Map as Map
 
 import qualified Data.Text as Text
 
 import Data.Semigroup (Sum(..))
+import Data.Monoid (All(..))
 
 -- import Data.Time
 -- import qualified Data.Text as T
@@ -46,7 +47,8 @@ import Database.Persist.Sql (updateWhereCount)
 
 import Data.List (genericLength)
 
-import Control.Monad.Trans.Writer (WriterT(..), runWriter)
+import Control.Monad.Trans.Writer (WriterT(..), runWriter, execWriterT)
+import Control.Monad.Trans.Reader (mapReaderT)
 
 import Control.Monad.Trans.RWS (RWST)
 
@@ -668,81 +670,96 @@ postCorrectionsCreateR = do
     FormMissing -> return ()
     FormFailure errs -> forM_ errs $ addMessage Error . toHtml
     FormSuccess (sid, (pss, invalids)) -> do
-      forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Warning "templates/messages/ignoredInvalidPseudonym.hamlet")
+      allDone <- fmap getAll . execWriterT $ do 
+        forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Error "templates/messages/ignoredInvalidPseudonym.hamlet")
+        tell . All $ null invalids
 
-      runDB $ do
-        Sheet{..} <- get404 sid
-        (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
-        forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText
-        now <- liftIO getCurrentTime
-        let
-          sps' :: [[SheetPseudonym]]
-          duplicate :: Set Pseudonym
-          ( sps'
-            , Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate
-            ) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do
-                  known <- State.gets $ Map.member sheetPseudonymPseudonym
-                  State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1)
-                  return $ bool (p :) id known ps
-          submissionPrototype = Submission
-            { submissionSheet = sid
-            , submissionRatingPoints = Nothing
-            , submissionRatingComment = Nothing
-            , submissionRatingBy = Just uid
-            , submissionRatingAssigned = Just now
-            , submissionRatingTime = Nothing
-            }
-        unless (null duplicate)
-          $(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet")
-        existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
-          E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
-          E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps')
-               E.&&. submission E.^. SubmissionSheet E.==. E.val sid
-          return submissionUser
-        unless (null existingSubUsers) $ do
-          (Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers
-          $(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet")
-        let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps'
-        forM_ sps'' $ \spGroup
-          -> let
-               sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup
-              in case sheetGrouping of
-          Arbitrary maxSize -> do
-            subId <- insert submissionPrototype
-            void . insert $ SubmissionEdit uid now subId
-            insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
-              { submissionUserUser = sheetPseudonymUser
-              , submissionUserSubmission = subId
+        WriterT . runDB . mapReaderT runWriterT $ do
+          Sheet{..} <- get404 sid
+          (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
+          forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText
+          tell . All $ null unknown
+          now <- liftIO getCurrentTime
+          let
+            sps' :: [[SheetPseudonym]]
+            duplicate :: Set Pseudonym
+            ( sps'
+              , Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate
+              ) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do
+                    known <- State.gets $ Map.member sheetPseudonymPseudonym
+                    State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1)
+                    return $ bool (p :) id known ps
+            submissionPrototype = Submission
+              { submissionSheet = sid
+              , submissionRatingPoints = Nothing
+              , submissionRatingComment = Nothing
+              , submissionRatingBy = Just uid
+              , submissionRatingAssigned = Just now
+              , submissionRatingTime = Nothing
               }
-            when (genericLength spGroup > maxSize) $
-              addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc
-          RegisteredGroups -> do
-            groups <- E.select . E.from $ \submissionGroup -> do
-              E.where_ . E.exists . E.from $ \submissionGroupUser ->
-                E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup)
-              return $ submissionGroup E.^. SubmissionGroupId
-            if
-              | length (groups :: [E.Value SubmissionGroupId]) < 2
-                -> do
-                  subId <- insert submissionPrototype
-                  void . insert $ SubmissionEdit uid now subId
-                  insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
-                    { submissionUserUser = sheetPseudonymUser
-                    , submissionUserSubmission = subId
-                    }
-                  when (null groups) $
-                    addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
-              | otherwise -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
-          NoGroups -> do
-            subId <- insert submissionPrototype
-            void . insert $ SubmissionEdit uid now subId
-            insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
-              { submissionUserUser = sheetPseudonymUser
-              , submissionUserSubmission = subId
-              }
-            when (length spGroup > 1) $
-              addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
-      redirect CorrectionsGradeR
+          unless (null duplicate)
+            $(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet")
+          existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
+            E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
+            E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps')
+                 E.&&. submission E.^. SubmissionSheet E.==. E.val sid
+            return submissionUser
+          unless (null existingSubUsers) . mapReaderT lift $ do
+            (Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers
+            $(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet")
+          let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps'
+          forM_ sps'' $ \spGroup
+            -> let
+                 sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup
+                in case sheetGrouping of
+            Arbitrary maxSize -> do
+              subId <- insert submissionPrototype
+              void . insert $ SubmissionEdit uid now subId
+              insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
+                { submissionUserUser = sheetPseudonymUser
+                , submissionUserSubmission = subId
+                }
+              when (genericLength spGroup > maxSize) $
+                addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc
+            RegisteredGroups -> do
+              let spGroup' = Map.fromList $ map (sheetPseudonymUser &&& id) spGroup
+              groups <- E.select . E.from $ \submissionGroup -> do
+                E.where_ . E.exists . E.from $ \submissionGroupUser ->
+                  E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup)
+                return $ submissionGroup E.^. SubmissionGroupId
+              groupUsers <- fmap (Set.fromList . map E.unValue) . E.select . E.from $ \submissionGroupUser -> do
+                E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup `E.in_` E.valList (map E.unValue groups)
+                return $ submissionGroupUser E.^. SubmissionGroupUserUser
+              if
+                | [_] <- groups
+                , Map.keysSet spGroup' `Set.isSubsetOf` groupUsers
+                  -> do
+                    subId <- insert submissionPrototype
+                    void . insert $ SubmissionEdit uid now subId
+                    insertMany_ . flip map (Set.toList groupUsers) $ \sheetUser -> SubmissionUser
+                      { submissionUserUser = sheetUser
+                      , submissionUserSubmission = subId
+                      }
+                    when (null groups) $
+                      addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
+                | length groups < 2
+                  -> do
+                    forM_ (Set.toList (Map.keysSet spGroup' `Set.difference` groupUsers)) $ \((spGroup' !) -> SheetPseudonym{sheetPseudonymPseudonym}) -> do
+                      addMessageI Error $ MsgSheetNoRegisteredGroup (review _PseudonymText sheetPseudonymPseudonym)
+                      tell $ All False
+                | otherwise ->
+                    addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
+            NoGroups -> do
+              subId <- insert submissionPrototype
+              void . insert $ SubmissionEdit uid now subId
+              insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
+                { submissionUserUser = sheetPseudonymUser
+                , submissionUserSubmission = subId
+                }
+              when (length spGroup > 1) $
+                addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
+      when allDone $
+        redirect CorrectionsGradeR
 
 
   defaultLayout $
diff --git a/test/Database.hs b/test/Database.hs
index 0308a3dfa..1e42ecaf6 100755
--- a/test/Database.hs
+++ b/test/Database.hs
@@ -24,6 +24,9 @@ import qualified Data.ByteString as BS
 
 import Data.Time
 
+import Utils.Lens (review)
+import Control.Monad.Random.Class (MonadRandom(..))
+
 
 data DBAction = DBClear
               | DBTruncate
@@ -151,7 +154,7 @@ fillDb = do
     , userMailLanguages = MailLanguages ["de"]
     , userNotificationSettings = def
     }
-  void . insert $ User
+  tinaTester <- insert $ User
     { userIdent  = "tester@campus.lmu.de"
     , userAuthentication = AuthLDAP
     , userMatrikelnummer = Just "999"
@@ -312,6 +315,7 @@ fillDb = do
   insert_ $ CourseEdit jost now pmo
   void . insert $ DegreeCourse pmo sdBsc sdInf
   void . insert $ Lecturer jost pmo
+  void . insertMany $ map (\u -> CourseParticipant pmo u now) [fhamann, maxMuster, tinaTester]
   sh1 <- insert Sheet
     { sheetCourse = pmo
     , sheetName = "Blatt 1"
@@ -328,6 +332,10 @@ fillDb = do
     , sheetSolutionFrom = Nothing
     }
   void . insert $ SheetEdit jost now sh1
+  forM_ [fhamann, maxMuster, tinaTester] $ \u -> do
+    p <- liftIO getRandom
+    $logDebug (review _PseudonymText p)
+    void . insert $ SheetPseudonym sh1 p u
   void . insert $ SheetCorrector jost sh1 (Load (Just True) 0) CorrectorNormal
   void . insert $ SheetCorrector gkleen sh1 (Load (Just True) 1) CorrectorNormal
   h102 <- insertFile "H10-2.hs"

From aea7837c49643a02346ae916337f96cb9a977be3 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 5 Dec 2018 22:03:10 +0100
Subject: [PATCH 08/10] Debounce notifications much more aggressively

Fixes #251
---
 src/Jobs.hs | 14 ++++++++++----
 1 file changed, 10 insertions(+), 4 deletions(-)

diff --git a/src/Jobs.hs b/src/Jobs.hs
index 45a5f74f6..9385eeff4 100644
--- a/src/Jobs.hs
+++ b/src/Jobs.hs
@@ -134,6 +134,7 @@ execCrontab = evalStateT go HashMap.empty
         runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
 
       refT <- liftIO getCurrentTime
+      settings <- getsYesod appSettings
       currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do
         crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab
         case crontab' of
@@ -141,7 +142,7 @@ execCrontab = evalStateT go HashMap.empty
           Just crontab -> Just <$> do
             State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
             prevExec <- State.get
-            case earliestJob prevExec crontab refT of
+            case earliestJob settings prevExec crontab refT of
               Nothing -> liftBase retry
               Just (_, MatchNone) -> liftBase retry
               Just x -> return (crontab, x)
@@ -189,6 +190,11 @@ execCrontab = evalStateT go HashMap.empty
         acc :: NominalDiffTime
         acc = 1e-3
 
+        debouncingAcc :: AppSettings -> JobCtl -> NominalDiffTime
+        debouncingAcc AppSettings{appNotificationRateLimit} = \case
+          JobCtlQueue (JobQueueNotification _) -> appNotificationRateLimit
+          _ -> acc
+
         applyJitter :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime
         applyJitter seed t = do
           appInstance <- getsYesod appInstanceID
@@ -197,8 +203,8 @@ execCrontab = evalStateT go HashMap.empty
             diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed)
           return $ addUTCTime diff t
 
-        earliestJob :: HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime)
-        earliestJob lastTimes crontab now = foldr go' Nothing $ HashMap.toList crontab
+        earliestJob :: AppSettings -> HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime)
+        earliestJob settings lastTimes crontab now = foldr go' Nothing $ HashMap.toList crontab
           where
             go' (jobCtl, cron) mbPrev
               | Just (_, t') <- mbPrev
@@ -207,7 +213,7 @@ execCrontab = evalStateT go HashMap.empty
               | otherwise
               = Just (jobCtl, t)
               where
-                t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) acc now cron
+                t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) (debouncingAcc settings jobCtl) now cron
 
         waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TMVar a -> a -> UTCTime -> m Bool
         waitUntil crontabTV crontab nextTime = runResourceT $ do

From 3541c1dc40d477f0b9fe2381b18622931f776dc7 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Thu, 6 Dec 2018 18:55:06 +0100
Subject: [PATCH 09/10] Prevent user from locking themselves out (authpreds)

---
 src/Handler/Home.hs | 8 ++++++--
 1 file changed, 6 insertions(+), 2 deletions(-)

diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs
index f4125de79..911827e00 100644
--- a/src/Handler/Home.hs
+++ b/src/Handler/Home.hs
@@ -283,8 +283,12 @@ getAuthPredsR, postAuthPredsR :: Handler Html
 getAuthPredsR = postAuthPredsR
 postAuthPredsR = do
   (AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
-  
-  let taForm authTag = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag)
+
+  let
+    blacklist = Set.fromList [ AuthFree, AuthDevelopment, AuthDeprecated ]
+    taForm authTag
+      | authTag `Set.member` blacklist = aforced checkBoxField (fslI authTag) (authTagIsActive def authTag)
+      | otherwise = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag)
   
   ((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard
     $ AuthTagActive

From 01cee62b10b6963852f7fa4501f8cf887c3fff95 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Thu, 6 Dec 2018 19:30:29 +0100
Subject: [PATCH 10/10] Work on #39

---
 messages/uniworx/de.msg                      |  3 ++
 src/Data/CaseInsensitive/Instances.hs        |  5 ++
 src/Data/Monoid/Instances.hs                 | 19 ++++++++
 src/Handler/Corrections.hs                   |  1 +
 src/Handler/Course.hs                        | 19 +++++++-
 src/Handler/Home.hs                          |  2 +
 src/Handler/Profile.hs                       |  5 ++
 src/Handler/Sheet.hs                         |  7 +--
 src/Handler/Submission.hs                    |  3 +-
 src/Handler/SystemMessage.hs                 |  9 ++--
 src/Handler/Term.hs                          |  1 +
 src/Handler/Users.hs                         |  1 +
 src/Handler/Utils/Form.hs                    | 24 +++++++++
 src/Handler/Utils/Table/Pagination.hs        | 51 +++++++++++++++-----
 src/Import/NoFoundation.hs                   |  1 +
 src/Utils/Form.hs                            |  2 +-
 templates/table/layout-filter-default.hamlet |  6 +++
 templates/widgets/form.hamlet                |  2 +-
 18 files changed, 136 insertions(+), 25 deletions(-)
 create mode 100644 src/Data/Monoid/Instances.hs
 create mode 100644 templates/table/layout-filter-default.hamlet

diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 1595dc8d9..340c9fa16 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -72,6 +72,8 @@ CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gese
 CourseRegisterFromTip: Ohne Datum ist keine Anmeldung möglich
 CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein
 CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein
+CourseFilterSearch: Volltext-Suche
+CourseFilterRegistered: Registriert
 
 NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht.
 NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht.
@@ -233,6 +235,7 @@ CorrUpload: Korrekturen hochladen
 CorrSetCorrector: Korrektor zuweisen
 CorrAutoSetCorrector: Korrekturen verteilen
 NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein!
+JSONFieldDecodeFailure aesonFailure@String: Konnte JSON nicht parsen: #{aesonFailure}
 
 SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
 SubmissionsAssignUnauthorized num@Int64: #{display num} Abgaben können momentan nicht einem Korrektor zugeteilt werden (z.B. weil die Abgabe noch offen ist):
diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs
index 7dc9123e8..c9e7f0c5d 100644
--- a/src/Data/CaseInsensitive/Instances.hs
+++ b/src/Data/CaseInsensitive/Instances.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Data.CaseInsensitive.Instances
@@ -20,6 +21,8 @@ import Language.Haskell.TH.Syntax (Lift(..))
 
 import Data.Aeson (ToJSON(..), FromJSON(..), ToJSONKey(..), FromJSONKey(..), ToJSONKeyFunction(..))
 
+import qualified Database.Esqueleto as E
+
 
 instance PersistField (CI Text) where
   toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
@@ -37,6 +40,8 @@ instance PersistFieldSql (CI Text) where
 instance PersistFieldSql (CI String) where
   sqlType _ = SqlOther "citext"
 
+instance (E.SqlString a, PersistField (CI a)) => E.SqlString (CI a)
+
 instance ToJSON a => ToJSON (CI a) where
   toJSON = toJSON . CI.original
 
diff --git a/src/Data/Monoid/Instances.hs b/src/Data/Monoid/Instances.hs
new file mode 100644
index 000000000..44909d53f
--- /dev/null
+++ b/src/Data/Monoid/Instances.hs
@@ -0,0 +1,19 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Monoid.Instances
+  (
+  ) where
+
+import ClassyPrelude
+import Data.Monoid
+
+type instance Element (Dual a) = a
+instance MonoPointed (Dual a)
+type instance Element (Sum a) = a
+instance MonoPointed (Sum a)
+type instance Element (Product a) = a
+instance MonoPointed (Product a)
+type instance Element (First a) = a
+instance MonoPointed (First a)
+type instance Element (Last a) = a
+instance MonoPointed (Last a)
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 803ef4bae..b77167ca8 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -277,6 +277,7 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
                            E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False)
         )
       ]
+    , dbtFilterUI  = mempty
     , dbtStyle     = def
     , dbtIdent     = "corrections" :: Text
     }
diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs
index e843ade32..d34542f87 100644
--- a/src/Handler/Course.hs
+++ b/src/Handler/Course.hs
@@ -12,6 +12,8 @@ import qualified Data.Text as T
 import Data.Function ((&))
 -- import Yesod.Form.Bootstrap3
 
+import Data.Monoid (Last(..))
+
 import Data.Maybe
 import qualified Data.Set as Set
 import qualified Data.Map as Map
@@ -161,13 +163,27 @@ makeCourseTable whereClause colChoices psValidator = do
                 | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
                 | otherwise          -> school E.^. SchoolShorthand `E.in_` E.valList (Set.toList criterias)
           )
+        , ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of
+              Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
+              Just needle -> course2Registered muid tExpr E.==. E.val needle
+          )
+        , ( "search", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Text) of
+              Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
+              Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
+                       E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
+                       E.||. (E.castString (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
+          )
         ]
+    , dbtFilterUI = mconcat
+      [ Map.singleton "search" . maybeToList <$> aopt textField (fslI MsgCourseFilterSearch) Nothing
+      , Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) Nothing
+      ]
     , dbtStyle = def
     , dbtIdent = "courses" :: Text
     }
 
 getCourseListR :: Handler Html
-getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
+getCourseListR = do
   muid <- maybeAuthId
   let colonnade = widgetColonnade $ mconcat
         [ colCourseDescr
@@ -182,7 +198,6 @@ getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
   coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
   defaultLayout $ do
     setTitleI MsgCourseListTitle
-    [whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO
     $(widgetFile "courses")
 
 getTermCurrentR :: Handler Html
diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs
index 911827e00..f5bd47c51 100644
--- a/src/Handler/Home.hs
+++ b/src/Handler/Home.hs
@@ -97,6 +97,7 @@ homeAnonymous = do
                             | otherwise     -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
                         )
                         ] -}
+    , dbtFilterUI  = mempty
     , dbtStyle     = def
     , dbtIdent     = "upcomingdeadlines" :: Text
     }
@@ -198,6 +199,7 @@ homeUser uid = do
                             | otherwise     -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
                         )
                         ] -}
+    , dbtFilterUI  = mempty
     , dbtStyle     = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
     , dbtIdent     = "upcomingdeadlines" :: Text
     }
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index dab2a6b83..410f6862a 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -273,6 +273,7 @@ mkOwnedCoursesTable =
           , ( "term",   FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm     )
           , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool   )
           ]
+      dbtFilterUI = mempty
   in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
 
 
@@ -319,6 +320,7 @@ mkEnrolledCoursesTable =
           , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool)
 --          , ( "time"  , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration )
           ]
+      , dbtFilterUI  = mempty
       , dbtStyle     = def
       }
 
@@ -396,6 +398,7 @@ mkSubmissionTable =
         , ( "term",   FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm     )
         , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool   )
         ]
+      dbtFilterUI = mempty
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
                   dbtSorting  = dbtSorting'  uid
               in  dbTableWidget' validator DBTable{..}
@@ -465,6 +468,7 @@ mkSubmissionGroupTable =
         , ( "term",   FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm     )
         , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool   )
         ]
+      dbtFilterUI = mempty
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
               in  dbTableWidget' validator DBTable{..}
 
@@ -538,6 +542,7 @@ mkCorrectionsTable =
         , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool   )
         , ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
         ]
+      dbtFilterUI = mempty
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
               in  dbTableWidget' validator DBTable{..}
 
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index 6728e11a2..f8b4b8f51 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -225,8 +225,8 @@ getSheetListR tid ssh csh = do
 --             (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType)
 --         )
       ]
-    , dbtFilter    = Map.fromList
-      []
+    , dbtFilter    = mempty
+    , dbtFilterUI  = mempty
     , dbtStyle     = def
     , dbtIdent     = "sheets" :: Text
     }
@@ -294,7 +294,8 @@ getSShowR tid ssh csh shn = do
     , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
                    -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False)
     , dbtStyle = def
-    , dbtFilter = Map.empty
+    , dbtFilter = mempty
+    , dbtFilterUI = mempty
     , dbtIdent = "files" :: Text
     , dbtSorting = Map.fromList
       [ ( "type"
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index cc645a929..7129dfeeb 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -310,7 +310,8 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
             , SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime)))
             )
           ]
-        , dbtFilter = Map.empty
+        , dbtFilter = mempty
+        , dbtFilterUI = mempty
         }
   mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
 
diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs
index 0bde9b1c8..a71104eff 100644
--- a/src/Handler/SystemMessage.hs
+++ b/src/Handler/SystemMessage.hs
@@ -178,12 +178,9 @@ postMessageListR = do
     { dbtSQLQuery
     , dbtColonnade
     , dbtProj
-    , dbtSorting = Map.fromList
-      [ -- TODO: from, to, authenticated, severity
-      ]
-    , dbtFilter = Map.fromList
-      [
-      ]
+    , dbtSorting = mempty -- TODO: from, to, authenticated, severity
+    , dbtFilter = mempty
+    , dbtFilterUI = mempty
     , dbtStyle = def
     , dbtIdent = "messages" :: Text
     }
diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs
index 41262bd44..0b1e67100 100644
--- a/src/Handler/Term.hs
+++ b/src/Handler/Term.hs
@@ -126,6 +126,7 @@ getTermShowR = do
                          E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
               )
             ]
+        , dbtFilterUI = mempty
         , dbtStyle = def
         , dbtIdent = "terms" :: Text
         }
diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs
index ec3924508..d3a9a1d50 100644
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@@ -85,6 +85,7 @@ getUsersR = do
           )
         ]
     , dbtFilter    = mempty
+    , dbtFilterUI  = mempty
     , dbtStyle     = def
     , dbtIdent     = "users" :: Text
     }
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index cc16635d7..906aa48fc 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -45,6 +45,9 @@ import Text.Read (readMaybe)
 
 import Utils.Lens
 
+import Data.Aeson (eitherDecodeStrict')
+import Data.Aeson.Text (encodeToLazyText)
+
 ----------------------------
 -- Buttons (new version ) --
 ----------------------------
@@ -455,6 +458,27 @@ langField :: Bool -- ^ Only allow values from `appLanguages`
 langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) . T.splitOn "-") MsgInvalidLangFormat $ textField & addDatalist (return $ toList appLanguages)
 langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages
 
+jsonField :: ( ToJSON a, FromJSON a
+             , MonadHandler m
+             , RenderMessage (HandlerSite m) UniWorXMessage
+             , RenderMessage (HandlerSite m) FormMessage
+             )
+          => Bool {-^ Hidden? -}
+          -> Field m a
+jsonField hide = Field{..}
+  where
+    inputType :: Text
+    inputType
+      | hide      = "hidden"
+      | otherwise = "text"
+    fieldParse [v] [] = return . second Just . first (SomeMessage . MsgJSONFieldDecodeFailure) . eitherDecodeStrict' $ encodeUtf8 v
+    fieldParse [] [] = return $ Right Nothing
+    fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
+    fieldView theId name attrs val isReq = liftWidgetT [whamlet|
+      <input id=#{theId} name=#{name} *{attrs} type=#{inputType} :isReq:required value=#{either fromStrict encodeToLazyText val}>
+    |]
+    fieldEnctype = UrlEncoded
+
 
 funcForm :: forall k v m.
             ( Finite k, Ord k
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index 808ad04af..170d52bbd 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -25,6 +25,7 @@ module Handler.Utils.Table.Pagination
   ) where
 
 import Handler.Utils.Table.Pagination.Types
+import Handler.Utils.Form
 import Utils
 import Utils.Lens.TH
 
@@ -228,6 +229,11 @@ data DBStyle = DBStyle
   { dbsEmptyStyle :: DBEmptyStyle
   , dbsEmptyMessage :: UniWorXMessage
   , dbsAttrs :: [(Text, Text)]
+  , dbsLayoutFilter :: Widget -- ^ Filter UI
+                    -> Enctype
+                    -> Text -- ^ Filter action (target uri)
+                    -> Widget -- ^ Table
+                    -> Widget
   }
 
 instance Default DBStyle where
@@ -235,8 +241,12 @@ instance Default DBStyle where
     { dbsEmptyStyle = def
     , dbsEmptyMessage = MsgNoTableContent
     , dbsAttrs = [ ("class", "table table--striped table--hover table--sortable") ]
+    , dbsLayoutFilter = \filterWgdt filterEnctype filterAction scrolltable -> $(widgetFile "table/layout-filter-default")
     }
 
+type FilterKey = CI Text
+type SortingKey = CI Text
+
 data DBTable m x = forall a r r' h i t.
   ( ToSortable h, Functor h
   , E.SqlSelect a r
@@ -246,8 +256,9 @@ data DBTable m x = forall a r r' h i t.
   { dbtSQLQuery :: t -> E.SqlQuery a
   , dbtProj :: DBRow r -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) r'
   , dbtColonnade :: Colonnade h r' (DBCell m x)
-  , dbtSorting :: Map (CI Text) (SortColumn t)
-  , dbtFilter :: Map (CI Text) (FilterColumn t)
+  , dbtSorting :: Map SortingKey (SortColumn t)
+  , dbtFilter :: Map FilterKey (FilterColumn t)
+  , dbtFilterUI :: AForm (ReaderT SqlBackend (HandlerT UniWorX IO)) (Map FilterKey [Text])
   , dbtStyle :: DBStyle
   , dbtIdent :: i
   }
@@ -379,18 +390,31 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       , fieldEnctype = UrlEncoded
       }
 
-  piResult <- lift . runInputGetResult $ PaginationInput
+  piPrevious <- fmap (maybe FormMissing FormSuccess) . runMaybeT $ MaybeT . return . decodeStrict' . encodeUtf8 =<< MaybeT (lookupPostParam $ wIdent "pagination")
+
+  piInput <- lift . runInputGetResult $ PaginationInput
     <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
     <*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
     <*> iopt intField (wIdent "pagesize")
     <*> iopt intField (wIdent "page")
 
-  piPrevious <- fmap (maybe FormMissing FormSuccess) . runMaybeT $ MaybeT . return . decodeStrict' . encodeUtf8 =<< MaybeT (lookupPostParam $ wIdent "pagination")
+  let filterPi
+        | FormSuccess PaginationInput{..} <- piPrevious <|> piInput
+          = def{ piSorting, piLimit }
+        | otherwise
+          = def
+
+  ((filterRes, filterWdgt), filterEnc) <- runFormGet . renderAForm FormDBTableFilter $ (,)
+    <$> areq (jsonField True) "" (Just filterPi)
+    <*> dbtFilterUI
+
+  let
+    piResult = piPrevious <|> (\(prev, fSettings) -> prev & _piFilter .~ Just fSettings) <$> filterRes <|> piInput
 
   psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit
 
   let
-    (errs, PaginationSettings{..}) = case piPrevious <|> piResult of
+    (errs, PaginationSettings{..}) = case piResult of
       FormSuccess pi
         | not (piIsUnset pi)
           -> runPSValidator dbtable $ Just pi
@@ -398,7 +422,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
           -> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
       _   -> runPSValidator dbtable Nothing
     paginationInput
-      | FormSuccess pi <- piPrevious <|> piResult
+      | FormSuccess pi <- piResult
       , not $ piIsUnset pi
       = pi
       | otherwise
@@ -419,18 +443,23 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
 
   rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'
 
+  getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
+
   let
     rowCount
       | (E.Value n, _):_ <- rows' = n
       | otherwise = 0
 
+    tblLink f = decodeUtf8 . toStrict . Builder.toLazyByteString . renderQueryText True $ f getParams
+
+    filterAction = tblLink
+      $ setParam (wIdent "page") Nothing
+      . Map.foldrWithKey (\k _ f -> setParam (wIdent $ CI.foldedCase k) Nothing . f) id dbtFilter
+
     table' :: WriterT x m Widget
     table' = do
-      getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
 
       let
-        tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
-
         genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
           widget <- sortableContent ^. cellContents
           let
@@ -456,7 +485,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
 
       return $(widgetFile "table/layout")
 
-  bool (dbHandler dbtable paginationInput $ \table -> $(widgetFile "table/layout-wrapper")) (sendResponse <=< tblLayout <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
+  bool (dbHandler dbtable paginationInput $ (\table -> $(widgetFile "table/layout-wrapper")) . dbsLayoutFilter filterWdgt filterEnc filterAction) (sendResponse <=< tblLayout . dbsLayoutFilter filterWdgt filterEnc filterAction <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
   where
     tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
     tblLayout tbl' = do
@@ -464,7 +493,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       withUrlRenderer $(hamletFile "templates/table/layout-standalone.hamlet")
 
     setParam :: Text -> Maybe Text -> QueryText -> QueryText
-    setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]
+    setParam key v qt = maybe id (\v' -> (:) (key, Just v')) v [ i | i@(key', _) <- qt, key' /= key ]
 
 dbTableWidget :: Monoid x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x
     -> DB (DBResult (HandlerT UniWorX IO) x)
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index 3bd7ebc45..a832df0db 100644
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@@ -41,6 +41,7 @@ import Data.Hashable          as Import
 import Data.List.NonEmpty     as Import (NonEmpty(..))
 import Data.Text.Encoding.Error    as Import(UnicodeException(..))
 import Data.Semigroup         as Import (Semigroup)
+import Data.Monoid.Instances  as Import ()
 
 import Control.Monad.Morph    as Import (MFunctor(..))
 
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index 5450e0f40..c754bf227 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -28,7 +28,7 @@ import Utils.Message
 -------------------
 
 -- | Use this type to pass information to the form template
-data FormLayout = FormStandard
+data FormLayout = FormStandard | FormDBTableFilter
 
 renderAForm :: Monad m => FormLayout -> FormRender m a
 renderAForm formLayout aform fragment = do
diff --git a/templates/table/layout-filter-default.hamlet b/templates/table/layout-filter-default.hamlet
new file mode 100644
index 000000000..9291c30fb
--- /dev/null
+++ b/templates/table/layout-filter-default.hamlet
@@ -0,0 +1,6 @@
+$newline never
+<section>
+  <form method=GET action=#{filterAction} enctype=#{filterEnctype}>
+    ^{filterWgdt}
+<section>
+  ^{scrolltable}
diff --git a/templates/widgets/form.hamlet b/templates/widgets/form.hamlet
index 79c2178a6..50d90cbb3 100644
--- a/templates/widgets/form.hamlet
+++ b/templates/widgets/form.hamlet
@@ -1,7 +1,7 @@
 $newline never
 #{fragment}
 $case formLayout
-  $of FormStandard
+  $of _
     $forall view <- views
       $# TODO: add class 'form-group--submit' if this is the submit-button view
       <div .form-group :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>