Merge branch 'master' into eecorrectr

.gitlab-ci.yml

@@ -32,13 +32,13 @@ npm install:
   before_script: &npm
     - rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d
     - install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list
-    - apt-get update -y
+    - apt update -y
     - npm install -g n
     - n 13.5.0
     - export PATH="${N_PREFIX}/bin:$PATH"
     - npm install -g npm
     - hash -r
-    - apt-get -y install openssh-client exiftool
+    - apt -y install openssh-client exiftool
     - install -v -m 0700 -d ~/.ssh
     - install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts
     - install -v -T -m 0400 ${SSH_DEPLOY_KEY} ~/.ssh/deploy && echo "IdentityFile ~/.ssh/deploy" >> ~/.ssh/config; 
@@ -93,9 +93,11 @@ yesod:build:dev:
   before_script: &haskell
     - rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d
     - install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list
-    - apt-get update -y
+    - apt-key add ${LLVM_APT_KEY}
-    - apt-get install -y --no-install-recommends locales-all
+    - apt update -y
-    - apt-get install openssh-client -y
+    - apt install -y --no-install-recommends locales-all openssh-client llvm-9
+    - ln -vsf llc-9 /usr/bin/llc
+    - ln -vsf opt-9 /usr/bin/opt
     - install -v -m 0700 -d ~/.ssh
     - install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts
     - install -v -T -m 0400 ${SSH_DEPLOY_KEY} ~/.ssh/deploy && echo "IdentityFile ~/.ssh/deploy" >> ~/.ssh/config; 
@@ -143,13 +145,13 @@ frontend:test:
   before_script:
     - rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d
     - install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list
-    - apt-get update -y
+    - apt update -y
     - npm install -g n
     - n 13.5.0
     - export PATH="${N_PREFIX}/bin:$PATH"
     - npm install -g npm
     - hash -r
-    - apt-get install -y --no-install-recommends chromium-browser
+    - apt install -y --no-install-recommends chromium-browser
   dependencies:
     - npm install
   retry: 2
@@ -243,8 +245,8 @@ deploy:uniworx3:
   before_script:
     - rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d
     - install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list
-    - apt-get update -y
+    - apt update -y
-    - apt-get install -y --no-install-recommends openssh-client
+    - apt install -y --no-install-recommends openssh-client
     - install -v -m 0700 -d ~/.ssh
     - install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts
     - install -v -T -m 0400 ${SSH_PRIVATE_KEY_UNIWORX3} ~/.ssh/uniworx3; echo "IdentityFile ~/.ssh/uniworx3" >> ~/.ssh/config; 

CHANGELOG.md

@@ -2,6 +2,69 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+## [19.0.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.6.0...v19.0.0) (2020-08-15)
+
+
+### refactor
+
+* split foundation & llvm ([c68a01d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c68a01d))
+
+
+### BREAKING CHANGES
+
+* split foundation
+
+
+
+## [18.6.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.5.0...v18.6.0) (2020-08-11)
+
+
+### Bug Fixes
+
+* **personalised-sheet-files:** more thorough check wrt sub-warnings ([0b0eaff](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0b0eaff))
+* hlint ([5ea7816](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5ea7816))
+* **course-visibility:** (more) correct visibility check for favourites ([796a806](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/796a806))
+* **course-visibility:** account for active auth tags everywhere ([c99433c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c99433c))
+* **course-visibility:** allow access for admin-like roles ([7569195](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7569195))
+* **course-visibility:** allow deregistration from invisible courses ([29da6e2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/29da6e2))
+* **course-visibility:** allow for caching Nothing results of getBy ([f129ce6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f129ce6))
+* **course-visibility:** check for mayEdit on course list ([b1d0893](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b1d0893))
+* **course-visibility:** correctly count courses on AllocationListR ([7530287](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7530287))
+* **course-visibility:** fix favourites ([1ac3c08](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1ac3c08))
+* **course-visibility:** rework routes ([7ce60a3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7ce60a3))
+* **course-visibility:** show icon to lecturers only ([cbb8e72](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cbb8e72))
+* **course-visibility:** visibility for admin-like users ([43f625b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/43f625b))
+
+
+### Features
+
+* **course-visibility:** account for visibility in routes ([cb0bf15](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cb0bf15))
+* **course-visibility:** account for visibility on AllocationListR ([4185742](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4185742))
+* **course-visibility:** account for visibility on AShowR ([df7a784](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/df7a784))
+* **course-visibility:** account for visibility on TShowR ([0ff07a5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0ff07a5))
+* **course-visibility:** add invisible icon to CShowR title ([6c0adde](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6c0adde))
+* **course-visibility:** add visibleFrom,visibleTo ([222d566](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/222d566))
+* **course-visibility:** allow access for exam correctors ([dfa70ee](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/dfa70ee))
+* **course-visibility:** display icon in course list for lecturers ([17dbccf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/17dbccf))
+* **course-visibility:** error on visibleFrom > visibleTo ([9494019](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9494019))
+* **course-visibility:** hide invisible courses from favourites + icon ([d86fed7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d86fed7))
+* **course-visibility:** more precise description on CShowR ([6fbb2ea](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6fbb2ea))
+* **course-visibility:** no invisible courses in course list ([24f1289](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/24f1289))
+* **course-visibility:** now as default visibleFrom for new courses ([7bdf8ca](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7bdf8ca))
+* **course-visibility:** redirect to NewsR after deregister (WIP!) ([183aa8d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/183aa8d))
+* **course-visibility:** reorder course form ([7af82bc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7af82bc))
+* **course-visibility:** rework visibility check for ZA courses ([a16eb1a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a16eb1a))
+* **course-visibility:** warn on deregister from invisible course ([16ad72d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/16ad72d))
+* **course-visibility:** warn on invisibility during registration ([23aca1c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/23aca1c))
+* **personalised-sheet-files:** collated ignore ([1fe63a2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1fe63a2))
+* **personalised-sheet-files:** download from CUsersR ([93d0ace](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/93d0ace))
+* **personalised-sheet-files:** finish upload functionality ([ed5fb6e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ed5fb6e))
+* **personalised-sheet-files:** i18n ([f452b2b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f452b2b))
+* **personalised-sheet-files:** introduce routes & work on crypto ([9ee44aa](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9ee44aa))
+* **personalised-sheet-files:** participant interaction ([db205f6](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/db205f6))
+
+
+
 ## [18.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.4.0...v18.5.0) (2020-08-03)
 
 

load/Load.hs

@@ -96,7 +96,7 @@ sampleIntegral = sampleN scaleIntegral
 
 
 instance PathPiece DiffTime where
-  toPathPiece = toPathPiece . MkFixed @E12 . diffTimeToPicoseconds
+  toPathPiece = (toPathPiece :: Pico -> Text) . MkFixed . diffTimeToPicoseconds
   fromPathPiece t = fromPathPiece t <&> \(MkFixed ps :: Pico) -> picosecondsToDiffTime ps
   
 

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "18.5.0",
+  "version": "19.0.0",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "18.5.0",
+  "version": "19.0.0",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name:    uniworx
-version: 18.5.0
+version: 19.0.0
 
 dependencies:
   - base
@@ -63,7 +63,6 @@ dependencies:
   - cryptoids-class
   - binary
   - binary-instances
-  - cereal
   - mtl
   - esqueleto >=3.1.0
   - mime-types
@@ -210,6 +209,8 @@ default-extensions:
   - TypeFamilyDependencies
   - QuantifiedConstraints
   - EmptyDataDeriving
+  - StandaloneKindSignatures
+  - NoStarIsType
 
 ghc-options:
   - -Wall
@@ -229,42 +230,41 @@ when:
     ghc-options:
       - -Werror
       - -fwarn-tabs
+  - condition: flag(dev)
+    then:
+      ghc-options:
+        - -O0
+        - -ddump-splices
+        - -ddump-to-file
+      cpp-options: -DDEVELOPMENT
+      ghc-prof-options:
+        - -fprof-auto
+    else:
+      ghc-options:
+        - -O -fllvm
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.
 library:
   source-dirs: src
-  when:
-    - condition: flag(dev)
-      then:
-        ghc-options:
-          - -O0
-          - -ddump-splices
-          - -ddump-to-file
-        cpp-options: -DDEVELOPMENT
-        ghc-prof-options:
-          - -fprof-auto
-      else:
-        ghc-options:
-          - -O2
 
 # Runnable executable for our application
 executables:
   uniworx:
     main: main.hs
     source-dirs: app
-    ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T"
     dependencies:
       - uniworx
     when:
       - condition: flag(library-only)
         buildable: false
+    ghc-options:
+      - -threaded -rtsopts "-with-rtsopts=-N -T -xn"
   uniworxdb:
     main: Database.hs
     ghc-options:
       - -main-is Database
-      - -threaded
+      - -threaded -rtsopts "-with-rtsopts=-N -T -xn"
-      - -rtsopts "-with-rtsopts=-N -T"
     source-dirs: test
     dependencies:
       - uniworx
@@ -277,8 +277,7 @@ executables:
     main: Load.hs
     ghc-options:
       - -main-is Load
-      - -threaded
+      - -threaded -rtsopts "-with-rtsopts=-N -T -xn"
-      - -rtsopts "-with-rtsopts=-N -T"
     source-dirs: load
     dependencies:
       - uniworx
@@ -312,9 +311,7 @@ tests:
       - yesod-persistent
     ghc-options:
       - -fno-warn-orphans
-      - -threaded
+      - -threaded -rtsopts "-with-rtsopts=-N -T -xn"
-      - -rtsopts
-      - -with-rtsopts=-N
   hlint:
     main: Hlint.hs
     other-modules: []

src/Application.hs

@@ -101,6 +101,8 @@ import qualified Network.Minio as Minio
 
 import Web.ServerSession.Core (StorageException(..))
 
+import GHC.RTS.Flags (getRTSFlags)
+
 -- Import all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)
 import Handler.News
@@ -200,6 +202,7 @@ makeFoundation appSettings'@AppSettings{..} = do
     runAppLoggingT tempFoundation $ do
       $logInfoS "InstanceID" $ UUID.toText appInstanceID
       $logDebugS "Configuration" $ tshow appSettings'
+      $logDebugS "RTSFlags" . tshow =<< liftIO getRTSFlags
 
       smtpPool <- for appSmtpConf $ \c -> do
         $logDebugS "setup" "SMTP-Pool"

src/Data/CaseInsensitive/Instances.hs

@@ -77,8 +77,8 @@ instance ToWidget site a => ToWidget site (CI a) where
 instance RenderMessage site a => RenderMessage site (CI a) where
   renderMessage f ls msg = renderMessage f ls $ CI.original msg
 
-instance Lift t => Lift (CI t) where
+instance (CI.FoldCase t, Lift t) => Lift (CI t) where
-  lift (CI.original -> orig) = [e|CI.mk $(lift orig)|]
+  liftTyped (CI.original -> orig) = [||CI.mk $$(liftTyped orig)||]
 
 
 instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where

src/Database/Esqueleto/Utils/TH.hs

@@ -46,7 +46,7 @@ sqlInTuple arity = do
   xsV <- newName "xs"
 
   let
-    matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) `sqlEq` $(xE)|]) $ zip vVs xVs)
+    matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) $ zipWith (\(varE -> vE) (varE -> xE) -> [e|E.val $(vE) `sqlEq` $(xE)|]) vVs xVs)
     tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars
 
   instanceD (cxt $ map (\v -> [t|SqlEq $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|]

src/Database/Persist/Sql/Types/Instances.hs

@@ -0,0 +1,22 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Database.Persist.Sql.Types.Instances
+  (
+  ) where
+
+import ClassyPrelude
+
+import Database.Persist.Sql
+
+
+instance BackendCompatible SqlWriteBackend SqlWriteBackend where
+  projectBackend = id
+
+instance BackendCompatible SqlReadBackend SqlReadBackend where
+  projectBackend = id
+
+instance BackendCompatible SqlReadBackend SqlBackend where
+  projectBackend = SqlReadBackend
+
+instance BackendCompatible SqlWriteBackend SqlBackend where
+  projectBackend = SqlWriteBackend

src/Database/Persist/TH/Directory.hs

@@ -24,7 +24,7 @@ persistDirectoryWith :: PersistSettings -> FilePath -> Q Exp
 persistDirectoryWith settings dir = do
   files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> runMaybeT $ do
     fn <- MaybeT . return . fromNullable $ takeFileName fp
-    guard . not $ head fn == '.'
+    guard $ head fn /= '.'
     guard . not $ head fn == '#' && last fn == '#'
 
     lift $ do

src/Foundation/DB.hs

@@ -0,0 +1,46 @@
+module Foundation.DB
+  ( runDBRead
+  , runSqlPoolRetry
+  ) where
+
+import Import.NoFoundation hiding (runDB, getDBRunner)
+
+import Foundation.Type
+
+import qualified Control.Retry as Retry
+import GHC.IO.Exception (IOErrorType(OtherError))
+  
+import Database.Persist.Sql (runSqlPool, SqlReadBackend(..))
+
+  
+runSqlPoolRetry :: forall m a backend.
+                   ( MonadUnliftIO m, BackendCompatible SqlBackend backend
+                   , MonadLogger m, MonadMask m
+                   )
+                => ReaderT backend m a
+                -> Pool backend
+                -> m a
+runSqlPoolRetry action pool = do
+  let policy = Retry.fullJitterBackoff 1e3 & Retry.limitRetriesByCumulativeDelay 10e6
+      handlers = Retry.skipAsyncExceptions `snoc` Retry.logRetries suggestRetry logRetry
+        where suggestRetry :: IOException -> m Bool
+              suggestRetry ioExc = return $
+                   ioeGetErrorType ioExc == OtherError
+                && ioeGetLocation ioExc == "libpq"
+              logRetry :: forall e.
+                          Exception e
+                       => Bool -- ^ Will retry
+                       -> e
+                       -> Retry.RetryStatus
+                       -> m ()
+              logRetry shouldRetry@False err status = $logErrorS "runSqlPoolRetry" . pack $ Retry.defaultLogMsg shouldRetry err status
+              logRetry shouldRetry@True  err status = $logWarnS "runSqlPoolRetry" . pack $ Retry.defaultLogMsg shouldRetry err status
+
+  Retry.recovering policy handlers $ \Retry.RetryStatus{..} -> do
+    $logDebugS "runSqlPoolRetry" $ "rsIterNumber = " <> tshow rsIterNumber
+    runSqlPool action pool
+
+runDBRead :: ReaderT SqlReadBackend (HandlerFor UniWorX) a -> (HandlerFor UniWorX) a
+runDBRead action = do
+  $logDebugS "YesodPersist" "runDBRead"
+  runSqlPoolRetry (withReaderT SqlReadBackend action) . appConnPool =<< getYesod

src/Foundation/I18n.hs

@@ -1,11 +1,12 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Foundation.I18n
-  ( appLanguages
+  ( appLanguages, appLanguagesOpts
   , UniWorXMessage(..)
   , ShortTermIdentifier(..)
   , MsgLanguage(..)
   , ShortSex(..)
+  , ShortWeekDay(..)
   , SheetTypeHeader(..)
   , SheetArchiveFileTypeDirectory(..)
   , ShortStudyDegree(..)
@@ -34,16 +35,17 @@ import qualified Data.Text as Text
 
 import Utils.Form
 
-import GHC.Exts (IsList(..))
+import qualified GHC.Exts (IsList(..))
 
 import Yesod.Form.I18n.German
 import Yesod.Form.I18n.English
 
-import qualified Data.Foldable as F
 import qualified Data.Char as Char
 import Text.Unidecode (unidecode)
 import Data.Text.Lens (packed)
 
+import Data.List ((!!))
+
 
 appLanguages :: NonEmpty Lang
 appLanguages = "de-de-formal" :| ["en-eu"]
@@ -183,6 +185,20 @@ instance RenderMessage UniWorX MsgLanguage where
     where
       mr = renderMessage foundation $ lang : filter (/= lang) ls
 
+appLanguagesOpts :: ( MonadHandler m
+                    , RenderMessage (HandlerSite m) MsgLanguage
+                    ) => m (OptionList Lang)
+-- ^ Authoritive list of supported Languages
+appLanguagesOpts = do
+  MsgRenderer mr <- getMsgRenderer
+  let mkOption l = Option
+        { optionDisplay = mr $ MsgLanguage l
+        , optionInternalValue = l
+        , optionExternalValue = l
+        }
+      langOptions = map mkOption $ toList appLanguages
+  return $ mkOptionList langOptions
+
 embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>)
 embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
 embedRenderMessage ''UniWorX ''StudyFieldType id
@@ -364,6 +380,23 @@ instance RenderMessage UniWorX (ValueRequired UniWorX) where
       mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
       mr = renderMessage foundation ls
 
+instance RenderRoute UniWorX => RenderMessage UniWorX (UnsupportedAuthPredicate AuthTag (Route UniWorX)) where
+  renderMessage f ls (UnsupportedAuthPredicate tag route) = mr . MsgUnsupportedAuthPredicate (mr tag) $ Text.intercalate "/" pieces
+    where
+      mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
+      mr = renderMessage f ls
+      (pieces, _) = renderRoute route
+
+instance RenderMessage UniWorX WeekDay where
+  renderMessage _ ls wDay = pack . fst $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7)
+
+newtype ShortWeekDay = ShortWeekDay { longWeekDay :: WeekDay }
+
+instance RenderMessage UniWorX ShortWeekDay where
+  renderMessage _ ls (ShortWeekDay wDay) = pack . snd $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7)
+
+embedRenderMessage ''UniWorX ''ButtonSubmit id
+
 
 unRenderMessage' :: (Eq a, Finite a, RenderMessage master a) => (Text -> Text -> Bool) -> master -> Text -> [a]
 unRenderMessage' cmp foundation inp = nub $ do
@@ -371,7 +404,7 @@ unRenderMessage' cmp foundation inp = nub $ do
   x <- universeF
   guard $ renderMessage foundation (l : filter (/= l) appLanguages') x `cmp` inp
   return x
-  where appLanguages' = F.toList appLanguages
+  where appLanguages' = toList appLanguages
 
 unRenderMessage :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a]
 unRenderMessage = unRenderMessage' (==)
@@ -379,3 +412,7 @@ unRenderMessage = unRenderMessage' (==)
 unRenderMessageLenient :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a]
 unRenderMessageLenient = unRenderMessage' cmp
   where cmp = (==) `on` mk . under packed (filter Char.isAlphaNum . concatMap unidecode)
+
+
+instance Default DateTimeFormatter where
+  def = mkDateTimeFormatter (getTimeLocale' []) def appTZ

src/Foundation/Instances.hs

@@ -0,0 +1,203 @@
+{-# LANGUAGE UndecidableInstances #-} -- for `MonadCrypto` and `MonadSecretBox`
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Foundation.Instances
+  ( ButtonClass(..), YesodPersistBackend, AuthId, MonadCryptoKey
+  , unsafeHandler
+  ) where
+
+import Import.NoFoundation
+
+import qualified Data.Text as Text
+import qualified Data.List as List
+import Data.List (inits)
+
+import qualified Yesod.Core.Unsafe as Unsafe
+import qualified Yesod.Auth.Message as Auth
+
+import Utils.Form
+import Auth.LDAP
+import Auth.PWHash
+import Auth.Dummy
+
+import qualified Foundation.Yesod.Session as UniWorX
+import qualified Foundation.Yesod.Middleware as UniWorX
+import qualified Foundation.Yesod.ErrorHandler as UniWorX
+import qualified Foundation.Yesod.StaticContent as UniWorX
+import qualified Foundation.Yesod.Persist as UniWorX
+import qualified Foundation.Yesod.Auth as UniWorX
+
+import Foundation.SiteLayout
+import Foundation.Type
+import Foundation.I18n
+import Foundation.Authorization
+import Foundation.Yesod.Auth hiding (authenticate)
+import Foundation.Routes
+import Foundation.DB
+
+import Network.Wai.Parse (lbsBackEnd)
+
+import Control.Monad.Writer.Class (MonadWriter(..))
+import UnliftIO.Pool (withResource)
+
+
+data instance ButtonClass UniWorX
+  = BCIsButton
+  | BCDefault
+  | BCPrimary
+  | BCSuccess
+  | BCInfo
+  | BCWarning
+  | BCDanger
+  | BCLink
+  | BCMassInputAdd | BCMassInputDelete
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+
+instance PathPiece (ButtonClass UniWorX) where
+  toPathPiece BCIsButton = "btn"
+  toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass
+  fromPathPiece = flip List.lookup $ map (toPathPiece &&& id) universeF
+
+instance Button UniWorX ButtonSubmit where
+  btnClasses BtnSubmit = [BCIsButton, BCPrimary]
+
+
+
+-- Please see the documentation for the Yesod typeclass. There are a number
+-- of settings which can be configured by overriding methods here.
+instance Yesod UniWorX where
+    -- Controls the base of generated URLs. For more information on modifying,
+    -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
+    approot = ApprootRequest $ \app req ->
+        case app ^. _appRoot of
+            Nothing -> getApprootText guessApproot app req
+            Just root -> root
+
+    makeSessionBackend = UniWorX.makeSessionBackend
+
+    maximumContentLength app _ = app ^. _appMaximumContentLength
+
+    -- Yesod Middleware allows you to run code before and after each handler function.
+    -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
+    -- Some users may also want to add the defaultCsrfMiddleware, which:
+    --   a) Sets a cookie with a CSRF token in it.
+    --   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 = UniWorX.yesodMiddleware
+
+    -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget`
+    defaultMessageWidget _title _body = error "defaultMessageWidget: undefined"
+
+    errorHandler = UniWorX.errorHandler
+
+    defaultLayout = siteLayout' Nothing
+
+    -- The page to be redirected to when authentication is required.
+    authRoute _ = Just $ AuthR LoginR
+
+    isAuthorized = evalAccess
+
+    addStaticContent = UniWorX.addStaticContent
+
+    fileUpload _site _length = FileUploadMemory lbsBackEnd
+
+    -- What messages should be logged. The following includes all messages when
+    -- in development, and warnings and errors in production.
+    shouldLogIO app _source level = do
+      LogSettings{..} <- readTVarIO $ appLogSettings app
+      return $ logAll || level >= logMinimumLevel
+
+    makeLogger = readTVarIO . snd . appLogger
+
+unsafeHandler :: UniWorX -> HandlerFor UniWorX a -> IO a
+unsafeHandler f h = do
+  logger <- makeLogger f
+  Unsafe.fakeHandlerGetLogger (const logger) f h
+
+
+-- How to run database actions.
+instance YesodPersist UniWorX where
+    type YesodPersistBackend UniWorX = SqlBackend
+    runDB = UniWorX.runDB
+
+instance YesodPersistRunner UniWorX where
+    getDBRunner = UniWorX.getDBRunner
+
+    
+instance YesodAuth UniWorX where
+    type AuthId UniWorX = UserId
+
+    -- Where to send a user after successful login
+    loginDest _ = NewsR
+    -- Where to send a user after logout
+    logoutDest _ = NewsR
+    -- Override the above two destinations when a Referer: header is present
+    redirectToReferer _ = True
+
+    loginHandler = do
+      toParent <- getRouteToParent
+      liftHandler . defaultLayout $ do
+        plugins <- getsYesod authPlugins
+        $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins)
+
+        setTitleI MsgLoginTitle
+        $(widgetFile "login")
+
+    authenticate = UniWorX.authenticate
+
+    authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool } = catMaybes
+      [ flip campusLogin campusUserFailoverMode <$> appLdapPool
+      , Just . hashLogin $ pwHashAlgorithm appAuthPWHash
+      , dummyLogin <$ guard appAuthDummyLogin
+      ]
+
+    authHttpManager = getsYesod appHttpManager
+
+    onLogin = liftHandler $ do
+      mlang <- runDB $ updateUserLanguage Nothing
+      app <- getYesod
+      let mr | Just lang <- mlang = renderMessage app . map (Text.intercalate "-") . reverse . inits $ Text.splitOn "-" lang
+             | otherwise = renderMessage app []
+      addMessage Success . toHtml $ mr Auth.NowLoggedIn
+
+    onErrorHtml dest msg = do
+      addMessage Error $ toHtml msg
+      redirect dest
+
+    renderAuthMessage _ ls = case lang of
+      ("en" : _) -> Auth.englishMessage
+      _other     -> Auth.germanMessage
+      where lang = Text.splitOn "-" $ selectLanguage' appLanguages ls
+
+instance YesodAuthPersist UniWorX where
+  getAuthEntity = liftHandler . runDBRead . get
+
+    
+instance YesodMail UniWorX where
+  defaultFromAddress = getsYesod $ view _appMailFrom
+  mailObjectIdDomain = getsYesod $ view _appMailObjectDomain
+  mailVerp = getsYesod $ view _appMailVerp
+  mailDateTZ = return appTZ
+  mailSmtp act = do
+    pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
+    withResource pool act
+  mailT ctx mail = defMailT ctx $ do
+    void setMailObjectIdRandom
+    setDateCurrent
+    replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail)
+
+    (mRes, smtpData) <- listen mail
+    unless (view _MailSmtpDataSet smtpData)
+      setMailSmtpData
+
+    return mRes
+
+
+instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
+  type MonadCryptoKey m = CryptoIDKey
+  cryptoIDKey f = getsYesod appCryptoIDKey >>= f
+
+instance {-# OVERLAPPING #-} (Monad m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadSecretBox m where
+  secretBoxKey = getsYesod appSecretBoxKey

src/Foundation/Routes.hs

@@ -21,8 +21,8 @@ import Foundation.Routes.Definitions
 -- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules
 --
 -- This function also generates the following type synonyms:
--- type Handler x = HandlerT UniWorX IO x
+-- type Handler x = HandlerFor UniWorX x
--- type Widget    = WidgetT  UniWorX IO ()
+-- type Widget    = WidgetFor  UniWorX ()
 mkYesodData "UniWorX" uniworxRoutes
 
 deriving instance Generic CourseR

src/Foundation/SiteLayout.hs

@@ -0,0 +1,569 @@
+{-# LANGUAGE UndecidableInstances #-} -- for `MemcachedKeyFavourites`
+
+module Foundation.SiteLayout
+  ( siteLayout', siteLayout
+  , siteLayoutMsg', siteLayoutMsg
+  , getSystemMessageState
+  ) where
+
+import Import.NoFoundation hiding (embedFile)
+
+import Foundation.Type
+import Foundation.Authorization
+import Foundation.Routes
+import Foundation.Navigation
+import Foundation.I18n
+import Foundation.DB
+
+import Utils.SystemMessage
+import Utils.Form
+import Utils.Course
+import Utils.Metrics
+
+import Handler.Utils.Routes
+import Handler.Utils.Memcached
+
+import qualified Data.Text as Text
+import qualified Data.Set as Set
+import qualified Data.HashMap.Strict as HashMap
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+import qualified Data.Conduit.Combinators as C
+
+import Text.Cassius (cassiusFile)
+import Text.Hamlet (hamletFile)
+import Data.FileEmbed (embedFile)
+
+
+data MemcachedKeyFavourites
+  = MemcachedKeyFavouriteQuickActions CourseId AuthContext (NonEmpty Lang)
+  deriving (Generic, Typeable)
+
+deriving instance Eq AuthContext => Eq MemcachedKeyFavourites
+deriving instance Read AuthContext => Read MemcachedKeyFavourites
+deriving instance Show AuthContext => Show MemcachedKeyFavourites
+deriving instance Hashable AuthContext => Hashable MemcachedKeyFavourites
+deriving instance Binary AuthContext => Binary MemcachedKeyFavourites
+
+data MemcachedLimitKeyFavourites
+  = MemcachedLimitKeyFavourites
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Hashable, Binary)
+
+
+siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
+siteLayoutMsg = siteLayout . i18n
+
+{-# DEPRECATED siteLayoutMsg' "Use siteLayoutMsg" #-}
+siteLayoutMsg' :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
+siteLayoutMsg' = siteLayoutMsg
+
+siteLayout :: ( BearerAuthSite UniWorX
+              , BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
+              , Button UniWorX ButtonSubmit
+              )
+           => WidgetFor UniWorX () -- ^ `pageHeading`
+           -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
+siteLayout = siteLayout' . Just
+
+siteLayout' :: ( BearerAuthSite UniWorX
+               , BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
+               , Button UniWorX ButtonSubmit
+               )
+            => Maybe (WidgetFor UniWorX ()) -- ^ `pageHeading`
+            -> WidgetFor UniWorX () -> HandlerFor UniWorX Html
+siteLayout' overrideHeading widget = do
+  AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings
+
+  isModal <- hasCustomHeader HeaderIsModal
+
+  primaryLanguage <- unsafeHead . Text.splitOn "-" <$> selectLanguage appLanguages
+
+  mcurrentRoute <- getCurrentRoute
+  let currentHandler = classifyHandler <$> mcurrentRoute
+
+  currentApproot' <- siteApproot <$> getYesod <*> (reqWaiRequest <$> getRequest)
+
+  -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
+  let
+    breadcrumbs' mcRoute = do
+      mr <- getMessageRender
+      case mcRoute of
+        Nothing -> return (mr MsgErrorResponseTitleNotFound, [])
+        Just cRoute -> do
+          (title, next) <- breadcrumb cRoute
+          crumbs <- go [] next
+          return (title, crumbs)
+      where
+        go crumbs  Nothing      = return crumbs
+        go crumbs (Just cRoute) = do
+          hasAccess <- hasReadAccessTo cRoute
+          (title, next) <- breadcrumb cRoute
+          go ((cRoute, title, hasAccess) : crumbs) next
+  (title, parents) <- breadcrumbs' mcurrentRoute
+
+  --         let isParent :: Route UniWorX -> Bool
+  --             isParent r = r == (fst parents)
+
+  isAuth <- isJust <$> maybeAuthId
+  
+  now <- liftIO getCurrentTime
+
+  -- Lookup Favourites & Theme if possible
+  (favourites', maxFavouriteTerms, currentTheme) <- do
+      muid <- maybeAuthPair
+
+      favCourses'' <- runDBRead . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do
+        E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse
+         E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid)
+
+        let isFavourite = E.not_ . E.isNothing $ courseFavourite E.?. CourseFavouriteId
+            isCurrent
+              | Just (CourseR tid ssh csh _) <- mcurrentRoute
+              =       course E.^. CourseTerm E.==. E.val tid
+                E.&&. course E.^. CourseSchool E.==. E.val ssh
+                E.&&. course E.^. CourseShorthand E.==. E.val csh
+              | otherwise
+              = E.false
+            notBlacklist = E.not_ . E.exists . E.from $ \courseNoFavourite ->
+              E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid)
+                   E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId
+            isParticipant = E.exists . E.from $ \participant ->
+              E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
+                   E.&&. E.just (participant E.^. CourseParticipantUser) E.==. E.val (view _1 <$> muid)
+                   E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
+            isLecturer = E.exists . E.from $ \lecturer ->
+              E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
+                   E.&&. E.just (lecturer E.^. LecturerUser) E.==. E.val (view _1 <$> muid)
+            isCorrector = E.exists . E.from $ \(corrector `E.InnerJoin` sheet) -> do
+              E.on $ corrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
+               E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId
+              E.where_ $ E.just (corrector E.^. SheetCorrectorUser) E.==. E.val (view _1 <$> muid)
+            isTutor = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do
+              E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
+               E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId
+              E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid)
+            isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor
+            courseVisible = courseIsVisible now course Nothing
+
+            reason = E.case_
+              [ E.when_ isCurrent    E.then_ . E.just $ E.val FavouriteCurrent
+              , E.when_ isAssociated E.then_ . E.just $ E.val FavouriteParticipant
+              ] (E.else_ $ courseFavourite E.?. CourseFavouriteReason)
+
+        E.where_ $ ((isFavourite E.||. isAssociated) E.&&. notBlacklist) E.||. isCurrent
+
+        return (course, reason, courseVisible)
+
+      favCourses' <- forM favCourses'' $ \(course@(Entity _ Course{..}), reason, E.Value courseVisible) -> do
+        mayView <- hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CShowR
+        mayEdit <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
+        return (course, reason, courseVisible, mayView, mayEdit)
+
+      let favCourses = favCourses' & filter (\(_, _, _, mayView, _) -> mayView)
+
+      return ( favCourses
+             , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid
+             , maybe userDefaultTheme userTheme $ view _2 <$> muid
+             )
+
+  let favouriteTerms :: [TermIdentifier]
+      favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Entity _ Course{..}, _, _, _, _) -> Set.singleton $ unTermKey courseTerm) favourites'
+  
+  favourites <- fmap catMaybes . forM favourites' $ \(Entity cId c@Course{..}, E.Value mFavourite, courseVisible, mayView, mayEdit)
+      -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
+             favouriteReason = fromMaybe FavouriteCurrent mFavourite
+         in runMaybeT . guardOnM (unTermKey courseTerm `elem` favouriteTerms) . lift $ do
+              ctx <- getAuthContext
+              MsgRenderer mr <- getMsgRenderer
+              langs <- selectLanguages appLanguages <$> languages
+              let cK = MemcachedKeyFavouriteQuickActions cId ctx langs
+              $logDebugS "FavouriteQuickActions" $ tshow cK <> " Checking..."
+              items <- memcachedLimitedKeyTimeoutBy
+                MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1
+                (Right <$> appFavouritesQuickActionsCacheTTL)
+                appFavouritesQuickActionsTimeout
+                cK
+                cK
+                . observeFavouritesQuickActionsDuration $ do
+                  $logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..."
+                  items' <- pageQuickActions NavQuickViewFavourite courseRoute
+                  items <- forM items' $ \n@NavLink{navLabel} -> (mr navLabel,) <$> toTextUrl n
+                  $logDebugS "FavouriteQuickActions" $ tshow cK <> " Done."
+                  return items
+              $logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items)
+              return (c, courseRoute, items, favouriteReason, courseVisible, mayView, mayEdit)
+
+  nav'' <- mconcat <$> sequence
+    [ defaultLinks
+    , maybe (return []) pageActions mcurrentRoute
+    ]
+  nav' <- catMaybes <$> mapM (runMaybeT . navAccess) nav''
+  nav <- forM nav' $ \n -> (n,,,) <$> newIdent <*> traverse toTextUrl (n ^? _navLink) <*> traverse (\nc -> (nc,, ) <$> newIdent <*> toTextUrl nc) (n ^. _navChildren)
+
+  mmsgs <- if
+    | isModal -> return mempty
+    | otherwise -> do
+        applySystemMessages
+        authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags
+        forM_ authTagPivots $
+          \authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute]))
+        getMessages
+
+  -- (langFormView, langFormEnctype) <- generateFormPost $ identifyForm FIDLanguage langForm
+  -- let langFormView' = wrapForm langFormView def
+  --       { formAction = Just $ SomeRoute LangR
+  --       , formSubmit = FormAutoSubmit
+  --       , formEncoding = langFormEnctype
+  --       }
+
+  let highlight :: HasRoute UniWorX url => url -> Bool
+      -- ^ highlight last route in breadcrumbs, favorites taking priority
+      highlight = (highR ==) . Just . urlRoute
+        where crumbs = mcons mcurrentRoute $ view _1 <$> reverse parents
+              navItems = map (view _2) favourites ++ toListOf (folded . typesUsing @NavChildren @NavLink . to urlRoute) nav
+              highR  = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs
+      highlightNav = (||) <$> navForceActive <*> highlight
+      favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason, Bool, Bool, Bool)]
+      favouriteTermReason tid favReason' = favourites
+        & filter (\(Course{..}, _, _, favReason, _, _, _) -> unTermKey courseTerm == tid && favReason == favReason')
+        & sortOn (\(Course{..}, _, _, _, _, _, _) -> courseName)
+
+      -- We break up the default layout into two components:
+      -- default-layout is the contents of the body tag, and
+      -- default-layout-wrapper is the entire page. Since the final
+      -- value passed to hamletToRepHtml cannot be a widget, this allows
+      -- you to use normal widget features in default-layout.
+
+      navWidget :: (Nav, Text, Maybe Text, [(NavLink, Text, Text)]) -> WidgetFor UniWorX ()
+      navWidget (n, navIdent, navRoute', navChildren') = case n of
+        NavHeader{ navLink = navLink@NavLink{..}, .. }
+          | NavTypeLink{..} <- navType
+          , navModal
+            -> customModal Modal
+                 { modalTriggerId = Just navIdent
+                 , modalId = Nothing
+                 , modalTrigger = \mroute ident -> case mroute of
+                     Just route -> $(widgetFile "widgets/navbar/item")
+                     Nothing -> error "navWidget with non-link modal"
+                 , modalContent = Left $ SomeRoute navLink
+                 }
+          | NavTypeLink{} <- navType
+            -> let route = navRoute'
+                   ident = navIdent
+                in $(widgetFile "widgets/navbar/item")
+        NavPageActionPrimary{ navLink = navLink@NavLink{..} }
+          -> let pWidget
+                   | NavTypeLink{..} <- navType
+                   , navModal
+                     = customModal Modal
+                         { modalTriggerId = Just navIdent
+                         , modalId = Nothing
+                         , modalTrigger = \mroute ident -> case mroute of
+                             Just route -> $(widgetFile "widgets/pageaction/primary")
+                             Nothing -> error "navWidget with non-link modal"
+                         , modalContent = Left $ SomeRoute navLink
+                         }
+                   | NavTypeLink{} <- navType
+                     = let route = navRoute'
+                           ident = navIdent
+                        in $(widgetFile "widgets/pageaction/primary")
+                   | otherwise
+                     = error "not implemented"
+                 sWidgets = navChildren'
+                   & map (\(l, i, r) -> navWidget (NavPageActionSecondary l, i, Just r, []))
+              in $(widgetFile "widgets/pageaction/primary-wrapper")
+        NavPageActionSecondary{ navLink = navLink@NavLink{..} }
+          | NavTypeLink{..} <- navType
+          , navModal
+            -> customModal Modal
+                 { modalTriggerId = Just navIdent
+                 , modalId = Nothing
+                 , modalTrigger = \mroute ident -> case mroute of
+                     Just route -> $(widgetFile "widgets/pageaction/secondary")
+                     Nothing -> error "navWidget with non-link modal"
+                 , modalContent = Left $ SomeRoute navLink
+                 }
+          | NavTypeLink{} <- navType
+            -> let route = navRoute'
+                   ident = navIdent
+                in $(widgetFile "widgets/pageaction/secondary")
+        NavHeaderContainer{..} -> $(widgetFile "widgets/navbar/container")
+        NavFooter{ navLink = navLink@NavLink{..} }
+          | NavTypeLink{..} <- navType
+          , not navModal
+            -> let route = navRoute'
+                   ident = navIdent
+                in $(widgetFile "widgets/footer/link")
+        _other -> error "not implemented"
+
+      navContainerItemWidget :: (Nav, Text, Maybe Text, [(NavLink, Text, Text)])
+                             -> (NavLink, Text, Text)
+                             -> WidgetFor UniWorX ()
+      navContainerItemWidget (n, _navIdent, _navRoute', _navChildren') (iN@NavLink{..}, iNavIdent, iNavRoute) = case n of
+        NavHeaderContainer{}
+          | NavTypeLink{..} <- navType
+          , navModal
+            -> customModal Modal
+                 { modalTriggerId = Just iNavIdent
+                 , modalId = Nothing
+                 , modalTrigger = \mroute ident -> case mroute of
+                     Just route -> $(widgetFile "widgets/navbar/navbar-container-item--link")
+                     Nothing -> error "navWidget with non-link modal"
+                 , modalContent = Left $ SomeRoute iN
+                 }
+          | NavTypeLink{} <- navType
+            -> let route = iNavRoute
+                   ident = iNavIdent
+                in $(widgetFile "widgets/navbar/navbar-container-item--link")
+          | NavTypeButton{..} <- navType -> do
+              csrfToken <- reqToken <$> getRequest
+              wrapForm $(widgetFile "widgets/navbar/navbar-container-item--button") def
+                { formMethod = navMethod
+                , formSubmit = FormNoSubmit
+                , formAction = Just $ SomeRoute iN
+                }
+        _other -> error "not implemented"
+
+      navbar :: WidgetFor UniWorX ()
+      navbar = do
+        $(widgetFile "widgets/navbar/navbar")
+        forM_ (filter isNavHeaderContainer nav) $ \(_, containerIdent, _, _) ->
+          toWidget $(cassiusFile "templates/widgets/navbar/container-radio.cassius")
+        where isNavHeaderPrimary   = has $ _1 . _navHeaderRole . only NavHeaderPrimary
+              isNavHeaderSecondary = has $ _1 . _navHeaderRole . only NavHeaderSecondary
+      asidenav :: WidgetFor UniWorX ()
+      asidenav = $(widgetFile "widgets/asidenav/asidenav")
+        where
+          logo = preEscapedToMarkup $ decodeUtf8 $(embedFile "assets/lmu/logo.svg")
+      footer :: WidgetFor UniWorX ()
+      footer = $(widgetFile "widgets/footer/footer")
+        where isNavFooter = has $ _1 . _NavFooter
+      alerts :: WidgetFor UniWorX ()
+      alerts = $(widgetFile "widgets/alerts/alerts")
+      contentHeadline :: Maybe (WidgetFor UniWorX ())
+      contentHeadline = overrideHeading <|> (pageHeading =<< mcurrentRoute)
+      breadcrumbsWgt :: WidgetFor UniWorX ()
+      breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs/breadcrumbs")
+      pageaction :: WidgetFor UniWorX ()
+      pageaction = $(widgetFile "widgets/pageaction/pageaction")
+      -- functions to determine if there are page-actions (primary or secondary)
+      hasPageActions, hasSecondaryPageActions, hasPrimaryPageActions :: Bool
+      hasPageActions = hasPrimaryPageActions || hasSecondaryPageActions
+      hasSecondaryPageActions = has (folded . _1 . _NavPageActionSecondary) nav
+      hasPrimaryPageActions   = has (folded . _1 . _NavPageActionPrimary  ) nav
+      hasPrimarySubActions = has (folded . _1 . filtered (is _NavPageActionPrimary) . _navChildren . folded) nav
+      contentRibbon :: Maybe (WidgetFor UniWorX ())
+      contentRibbon = fmap toWidget appRibbon
+
+      isNavHeaderContainer = has $ _1 . _NavHeaderContainer
+      isPageActionPrimary = has $ _1 . _NavPageActionPrimary
+      isPageActionSecondary = has $ _1 . _NavPageActionSecondary
+
+  MsgRenderer mr <- getMsgRenderer
+  let
+    -- See Utils.Frontend.I18n and files in messages/frontend for message definitions
+    frontendI18n = toJSON (mr :: FrontendMessage -> Text)
+  frontendDatetimeLocale <- toJSON <$> selectLanguage frontendDatetimeLocales
+
+  pc <- widgetToPageContent $ do
+      webpackLinks_main StaticR
+      toWidget $(juliusFile "templates/i18n.julius")
+      whenIsJust currentApproot' $ \currentApproot ->
+        toWidget $(juliusFile "templates/approot.julius")
+      whenIsJust mcurrentRoute $ \currentRoute' -> do
+        currentRoute <- toTextUrl currentRoute'
+        toWidget $(juliusFile "templates/current-route.julius")
+      wellKnownHtmlLinks
+
+      $(widgetFile "default-layout")
+  withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
+
+  
+getSystemMessageState :: (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => SystemMessageId -> m UserSystemMessageState
+getSystemMessageState smId = liftHandler $ do
+  muid <- maybeAuthId
+  reqSt <- $cachedHere getSystemMessageStateRequest
+  dbSt <- $cachedHere $ maybe (return mempty) getDBSystemMessageState muid
+  let MergeHashMap smSt = reqSt <> dbSt
+      smSt' = MergeHashMap $ HashMap.filter (/= mempty) smSt
+  when (smSt' /= reqSt) $
+        setRegisteredCookieJson CookieSystemMessageState
+    =<< ifoldMapM (\smId' v -> MergeHashMap <$> (HashMap.singleton <$> encrypt smId' <*> pure v :: HandlerFor UniWorX (HashMap CryptoUUIDSystemMessage _))) smSt'
+
+  return . fromMaybe mempty $ HashMap.lookup smId smSt
+  where
+    getSystemMessageStateRequest =
+          (lookupRegisteredCookiesJson id CookieSystemMessageState :: HandlerFor UniWorX (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState))
+      >>= ifoldMapM (\(cID :: CryptoUUIDSystemMessage) v -> MergeHashMap <$> (maybeT (return mempty) . catchMPlus (Proxy @CryptoIDError) $ HashMap.singleton <$> decrypt cID <*> pure v))
+    getDBSystemMessageState uid = runDBRead . runConduit $ selectSource [ SystemMessageHiddenUser ==. uid ] [] .| C.foldMap foldSt
+      where foldSt (Entity _ SystemMessageHidden{..})
+              = MergeHashMap . HashMap.singleton systemMessageHiddenMessage $ mempty { userSystemMessageHidden = Just systemMessageHiddenTime }
+
+applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), BearerAuthSite UniWorX) => m ()
+applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) $ do
+  lift $ maybeAuthId >>= traverse_ syncSystemMessageHidden
+
+  cRoute <- lift getCurrentRoute
+  guard $ cRoute /= Just NewsR
+
+  lift . runDBRead . runConduit $ selectSource [] [Asc SystemMessageManualPriority] .| C.mapM_ applyMessage
+  where
+    syncSystemMessageHidden :: UserId -> HandlerFor UniWorX ()
+    syncSystemMessageHidden uid = runDB . withReaderT projectBackend $ do
+      smSt <- lookupRegisteredCookiesJson id CookieSystemMessageState :: SqlPersistT (HandlerFor UniWorX) (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState)
+      iforM_ smSt $ \cID UserSystemMessageState{..} -> do
+        smId <- decrypt cID
+        whenIsJust userSystemMessageHidden $ \systemMessageHiddenTime -> void $
+          upsert SystemMessageHidden
+            { systemMessageHiddenMessage = smId
+            , systemMessageHiddenUser = uid
+            , systemMessageHiddenTime
+            }
+            [ SystemMessageHiddenTime =. systemMessageHiddenTime ]
+
+        when (maybe False (maybe (const True) (<=) userSystemMessageHidden) userSystemMessageUnhidden) $ do
+          deleteBy $ UniqueSystemMessageHidden uid smId
+
+        modifyRegisteredCookieJson CookieSystemMessageState $ \(fold -> MergeHashMap hm)
+          -> fmap MergeHashMap . assertM' (/= mempty) $
+               HashMap.update (\smSt' -> assertM' (/= mempty) $ smSt' { userSystemMessageHidden = Nothing, userSystemMessageUnhidden = Nothing }) cID hm
+
+    applyMessage :: Entity SystemMessage -> ReaderT SqlReadBackend (HandlerFor UniWorX) ()
+    applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do
+      guard $ not systemMessageNewsOnly
+
+      cID <- encrypt smId
+      void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False
+
+      now <- liftIO getCurrentTime
+      guard $ NTop systemMessageFrom <= NTop (Just now)
+      guard $ NTop (Just now) < NTop systemMessageTo
+
+      UserSystemMessageState{..} <- lift $ getSystemMessageState smId
+      guard $ userSystemMessageShown <= Just systemMessageLastChanged
+      guard $ userSystemMessageHidden <= Just systemMessageLastUnhide
+
+      (_, smTrans) <- MaybeT $ getSystemMessage appLanguages smId
+      let
+        (summary, content) = case smTrans of
+          Nothing -> (systemMessageSummary, systemMessageContent)
+          Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
+      case summary of
+        Just s ->
+          addMessageWidget systemMessageSeverity $ msgModal (toWidget s) (Left . SomeRoute $ MessageR cID)
+        Nothing -> addMessage systemMessageSeverity content
+
+      tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $
+        HashMap.singleton cID mempty{ userSystemMessageShown = Just now }
+
+
+-- FIXME: Move headings into their respective handlers
+  
+-- | Method for specifying page heading for handlers that call defaultLayout
+--
+-- All handlers whose code is under our control should use
+-- `siteLayout` instead; `pageHeading` is only a fallback solution for
+-- e.g. subsites like `AuthR`
+pageHeading :: ( YesodPersist UniWorX
+               , BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
+               ) => Route UniWorX -> Maybe Widget
+pageHeading (AuthR _)
+  = Just $ i18n MsgLoginHeading
+pageHeading NewsR
+  = Just $ i18n MsgNewsHeading
+pageHeading UsersR
+  = Just $ i18n MsgUsers
+pageHeading (AdminUserR _)
+  = Just $ i18n MsgAdminUserHeading
+pageHeading AdminTestR
+  = Just [whamlet|Internal Code Demonstration Page|]
+pageHeading AdminErrMsgR
+  = Just $ i18n MsgErrMsgHeading
+
+pageHeading InfoR
+  = Just $ i18n MsgInfoHeading
+pageHeading LegalR
+  = Just $ i18n MsgLegalHeading
+pageHeading VersionR
+  = Just $ i18n MsgVersionHeading
+
+pageHeading HelpR
+  = Just $ i18n MsgHelpRequest
+
+pageHeading ProfileR
+  = Just $ i18n MsgProfileHeading
+pageHeading ProfileDataR
+  = Just $ i18n MsgProfileDataHeading
+
+pageHeading TermShowR
+  = Just $ i18n MsgTermsHeading
+pageHeading TermCurrentR
+  = Just $ i18n MsgTermCurrent
+pageHeading TermEditR
+  = Just $ i18n MsgTermEditHeading
+pageHeading (TermEditExistR tid)
+  = Just $ i18n $ MsgTermEditTid tid
+pageHeading (TermCourseListR tid)
+  = Just . i18n . MsgTermCourseListHeading $ tid
+pageHeading (TermSchoolCourseListR tid ssh)
+  = Just $ do
+      School{schoolName=school} <- handlerToWidget . runDB . withReaderT (projectBackend @SqlBackend) $ get404 ssh
+      i18n $ MsgTermSchoolCourseListHeading tid school
+
+pageHeading CourseListR
+  = Just $ i18n MsgCourseListTitle
+pageHeading CourseNewR
+  = Just $ i18n MsgCourseNewHeading
+pageHeading (CourseR tid ssh csh CShowR)
+  = Just $ do
+    Entity _ Course{..} <- handlerToWidget . runDB . withReaderT (projectBackend @SqlBackend) . getBy404 $ TermSchoolCourseShort tid ssh csh
+    toWidget courseName
+--          (CourseR tid csh CRegisterR) -- just for POST
+pageHeading (CourseR tid ssh csh CEditR)
+  = Just $ i18n $ MsgCourseEditHeading tid ssh csh
+pageHeading (CourseR tid ssh csh CCorrectionsR)
+  = Just $ i18n $ MsgSubmissionsCourse tid ssh csh
+pageHeading (CourseR tid ssh csh SheetListR)
+  = Just $ i18n $ MsgSheetList tid ssh csh
+pageHeading (CourseR tid ssh csh SheetNewR)
+  = Just $ i18n $ MsgSheetNewHeading tid ssh csh
+pageHeading (CSheetR tid ssh csh shn SShowR)
+  = Just $ i18n $ MsgSheetTitle tid ssh csh shn
+  -- = Just $ i18n $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity
+pageHeading (CSheetR tid ssh csh shn SEditR)
+  = Just $ i18n $ MsgSheetEditHead tid ssh csh shn
+pageHeading (CSheetR tid ssh csh shn SDelR)
+  = Just $ i18n $ MsgSheetDelHead tid ssh csh shn
+pageHeading (CSheetR _tid _ssh _csh shn SSubsR)
+  = Just $ i18n $ MsgSubmissionsSheet shn
+pageHeading (CSheetR tid ssh csh shn SubmissionNewR)
+  = Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn
+pageHeading (CSheetR tid ssh csh shn SubmissionOwnR)
+  = Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn
+pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one!
+  = Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn
+--          (CSubmissionR tid csh shn cid SubArchiveR) -- just a download
+pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR)
+  = Just $ i18n $ MsgCorrectionHead tid ssh csh shn cid
+--          (CSubmissionR tid csh shn cid SubDownloadR) -- just a download
+--          (CSheetR tid ssh csh shn SFileR) -- just for Downloads
+
+pageHeading CorrectionsR
+  = Just $ i18n MsgCorrectionsTitle
+pageHeading CorrectionsUploadR
+  = Just $ i18n MsgCorrUpload
+pageHeading CorrectionsCreateR
+  = Just $ i18n MsgCorrCreate
+pageHeading CorrectionsGradeR
+  = Just $ i18n MsgCorrGrade
+pageHeading (MessageR _)
+  = Just $ i18n MsgSystemMessageHeading
+pageHeading MessageListR
+  = Just $ i18n MsgSystemMessageListHeading
+
+-- TODO: add headings for more single course- and single term-pages
+pageHeading _
+  = Nothing

src/Foundation/Type.hs

@@ -7,6 +7,7 @@ module Foundation.Type
   , _SessionStorageMemcachedSql, _SessionStorageAcid
   , SMTPPool
   , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport
+  , DB, Form, MsgRenderer, MailM
   ) where
 
 import Import.NoFoundation
@@ -74,3 +75,9 @@ instance HasCookieSettings RegisteredCookie UniWorX where
 
 instance (MonadHandler m, HandlerSite m ~ UniWorX) => ReadLogSettings m where
   readLogSettings = liftIO . readTVarIO =<< getsYesod (view _appLogSettings)
+
+  
+type DB = YesodDB UniWorX
+type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, WidgetFor UniWorX ())
+type MsgRenderer = MsgRendererS UniWorX -- see Utils
+type MailM a = MailT (HandlerFor UniWorX) a

src/Foundation/Yesod/Auth.hs

@@ -0,0 +1,498 @@
+module Foundation.Yesod.Auth
+  ( authenticate
+  , upsertCampusUser
+  , CampusUserConversionException(..)
+  , campusUserFailoverMode, updateUserLanguage
+  ) where
+
+import Import.NoFoundation hiding (authenticate)
+
+import Foundation.Type
+import Foundation.Types
+import Foundation.I18n
+
+import Handler.Utils.Profile
+import Handler.Utils.StudyFeatures
+import Handler.Utils.SchoolLdap
+
+import Yesod.Auth.Message
+import Auth.LDAP
+
+import qualified Data.CaseInsensitive as CI
+import qualified Control.Monad.Catch as C (Handler(..))
+import qualified Data.List.NonEmpty as NonEmpty
+import qualified Ldap.Client as Ldap
+import qualified Data.Text.Encoding as Text
+import qualified Data.ByteString as ByteString
+import qualified Data.Set as Set
+import qualified Data.Conduit.Combinators as C
+
+import qualified Data.List as List ((\\))
+  
+import qualified Data.UUID as UUID
+import Data.ByteArray (convert)
+import Crypto.Hash (SHAKE128)
+import qualified Data.Binary as Binary
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+import Control.Monad.Writer.Class (MonadWriter(..))
+import Crypto.Hash.Conduit (sinkHash)
+
+
+authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
+                , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
+                , YesodAuth UniWorX, UserId ~ AuthId UniWorX
+                )
+             => Creds UniWorX -> m (AuthenticationResult UniWorX)
+authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
+  now <- liftIO getCurrentTime
+
+  let
+    uAuth = UniqueAuthentication $ CI.mk credsIdent
+    upsertMode = creds ^? _upsertCampusUserMode
+
+    isDummy = is (_Just . _UpsertCampusUserDummy) upsertMode
+    isOther = is (_Just . _UpsertCampusUserOther) upsertMode
+
+    excRecovery res
+      | isDummy || isOther
+      = do
+          case res of
+            UserError   err -> addMessageI Error   err
+            ServerError err -> addMessage  Error $ toHtml err
+            _other          -> return ()
+          acceptExisting
+      | otherwise
+      = return res
+
+    excHandlers =
+      [ C.Handler $ \case
+          CampusUserNoResult -> do
+            $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
+            excRecovery . UserError $ IdentifierNotFound credsIdent
+          CampusUserAmbiguous -> do
+            $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
+            excRecovery . UserError $ IdentifierNotFound credsIdent
+          err -> do
+            $logErrorS "LDAP" $ tshow err
+            mr <- getMessageRender
+            excRecovery . ServerError $ mr MsgInternalLdapError
+      , C.Handler $ \(cExc :: CampusUserConversionException) -> do
+          $logErrorS "LDAP" $ tshow cExc
+          mr <- getMessageRender
+          excRecovery . ServerError $ mr cExc
+      ]
+
+    acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX)
+    acceptExisting = do
+      res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
+      case res of
+        Authenticated uid
+          -> associateUserSchoolsByTerms uid
+        _other
+          -> return ()
+      case res of
+        Authenticated uid
+          | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
+        _other -> return res
+
+  $logDebugS "auth" $ tshow Creds{..}
+  UniWorX{..} <- getYesod
+
+  flip catches excHandlers $ case appLdapPool of
+    Just ldapPool
+      | Just upsertMode' <- upsertMode -> do
+          ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..}
+          $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
+          Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData
+    _other
+      -> acceptExisting
+
+  
+data CampusUserConversionException
+  = CampusUserInvalidIdent
+  | CampusUserInvalidEmail
+  | CampusUserInvalidDisplayName
+  | CampusUserInvalidGivenName
+  | CampusUserInvalidSurname
+  | CampusUserInvalidTitle
+  | CampusUserInvalidMatriculation
+  | CampusUserInvalidSex
+  | CampusUserInvalidFeaturesOfStudy Text
+  | CampusUserInvalidAssociatedSchools Text
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Exception)
+
+_upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode
+_upsertCampusUserMode mMode cs@Creds{..}
+  | credsPlugin == "dummy"    = setMode <$> mMode (UpsertCampusUserDummy $ CI.mk credsIdent)
+  | credsPlugin `elem` others = setMode <$> mMode (UpsertCampusUserOther $ CI.mk credsIdent)
+  | otherwise                 = setMode <$> mMode  UpsertCampusUser
+  where
+    setMode UpsertCampusUser
+      = cs{ credsPlugin = "LDAP" }
+    setMode (UpsertCampusUserDummy ident)
+      = cs{ credsPlugin = "dummy", credsIdent = CI.original ident }
+    setMode (UpsertCampusUserOther ident)
+      = cs{ credsPlugin = bool (NonEmpty.head others) credsPlugin (credsPlugin `elem` others), credsIdent = CI.original ident }
+
+    others = "PWHash" :| []
+
+upsertCampusUser :: forall m.
+                    ( MonadHandler m, HandlerSite m ~ UniWorX
+                    , MonadThrow m
+                    )
+                 => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
+upsertCampusUser plugin ldapData = do
+  now <- liftIO getCurrentTime
+  UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
+
+  let
+    userIdent''         = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ]
+    userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ]
+    userEmail'          = fold $ do
+      k' <- toList ldapUserEmail
+      (k, v) <- ldapData
+      guard $ k' == k
+      return v
+    userDisplayName''   = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName   ]
+    userFirstName'      = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName     ]
+    userSurname'        = fold [ v | (k, v) <- ldapData, k == ldapUserSurname       ]
+    userTitle'          = fold [ v | (k, v) <- ldapData, k == ldapUserTitle         ]
+    userSex'            = fold [ v | (k, v) <- ldapData, k == ldapSex               ]
+
+    userAuthentication
+      | is _UpsertCampusUserOther plugin
+      = error "PWHash should only work for users that are already known"
+      | otherwise = AuthLDAP
+    userLastAuthentication = now <$ guard (isn't _UpsertCampusUserDummy plugin)
+
+  userIdent <- if
+    | [bs] <- userIdent''
+    , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
+    , hasn't _upsertCampusUserIdent plugin || has (_upsertCampusUserIdent . only userIdent') plugin
+      -> return userIdent'
+    | Just userIdent' <- plugin ^? _upsertCampusUserIdent
+      -> return userIdent'
+    | otherwise
+      -> throwM CampusUserInvalidIdent
+  userEmail <- if
+    | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') userEmail'
+      -> return $ CI.mk userEmail
+    | otherwise
+      -> throwM CampusUserInvalidEmail
+  userDisplayName' <- if
+    | [bs] <- userDisplayName''
+    , Right userDisplayName' <- Text.decodeUtf8' bs
+      -> return userDisplayName'
+    | otherwise
+      -> throwM CampusUserInvalidDisplayName
+  userFirstName <- if
+    | [bs] <- userFirstName'
+    , Right userFirstName <- Text.decodeUtf8' bs
+      -> return userFirstName
+    | otherwise
+      -> throwM CampusUserInvalidGivenName
+  userSurname <- if
+    | [bs] <- userSurname'
+    , Right userSurname <- Text.decodeUtf8' bs
+      -> return userSurname
+    | otherwise
+      -> throwM CampusUserInvalidSurname
+  userTitle <- if
+    | all ByteString.null userTitle'
+      -> return Nothing
+    | [bs] <- userTitle'
+    , Right userTitle <- Text.decodeUtf8' bs
+      -> return $ Just userTitle
+    | otherwise
+      -> throwM CampusUserInvalidTitle
+  userMatrikelnummer <- if
+    | [bs] <- userMatrikelnummer'
+    , Right userMatrikelnummer <- Text.decodeUtf8' bs
+      -> return $ Just userMatrikelnummer
+    | [] <- userMatrikelnummer'
+      -> return Nothing
+    | otherwise
+      -> throwM CampusUserInvalidMatriculation
+  userSex <- if
+    | [bs] <- userSex'
+    , Right userSex'' <- Text.decodeUtf8' bs
+    , Just userSex''' <- readMay userSex''
+    , Just userSex <- userSex''' ^? iso5218
+      -> return $ Just userSex
+    | [] <- userSex'
+      -> return   Nothing
+    | otherwise
+      -> throwM CampusUserInvalidSex
+
+  let
+    newUser = User
+      { userMaxFavourites        = userDefaultMaxFavourites
+      , userMaxFavouriteTerms    = userDefaultMaxFavouriteTerms
+      , userTheme                = userDefaultTheme
+      , userDateTimeFormat       = userDefaultDateTimeFormat
+      , userDateFormat           = userDefaultDateFormat
+      , userTimeFormat           = userDefaultTimeFormat
+      , userDownloadFiles        = userDefaultDownloadFiles
+      , userWarningDays          = userDefaultWarningDays
+      , userShowSex              = userDefaultShowSex
+      , userNotificationSettings = def
+      , userLanguages            = Nothing
+      , userCsvOptions           = def
+      , userTokensIssuedAfter    = Nothing
+      , userCreated              = now
+      , userLastLdapSynchronisation = Just now
+      , userDisplayName          = userDisplayName'
+      , userDisplayEmail         = userEmail
+      , ..
+      }
+    userUpdate =  [ UserMatrikelnummer          =. userMatrikelnummer
+                  -- , UserDisplayName             =. userDisplayName
+                  , UserFirstName               =. userFirstName
+                  , UserSurname                 =. userSurname
+                  , UserTitle                   =. userTitle
+                  , UserEmail                   =. userEmail
+                  , UserSex                     =. userSex
+                  , UserLastLdapSynchronisation =. Just now
+                  ] ++
+                  [ UserLastAuthentication =. Just now | isn't _UpsertCampusUserDummy plugin ]
+
+  user@(Entity userId userRec) <- upsertBy (UniqueAuthentication userIdent) newUser userUpdate
+  unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $
+    update userId [ UserDisplayName =. userDisplayName' ]
+
+  let
+    userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
+    userStudyFeatures' = do
+      (k, v) <- ldapData
+      guard $ k == ldapUserStudyFeatures
+      v' <- v
+      Right str <- return $ Text.decodeUtf8' v'
+      return str
+
+    termNames = nubBy ((==) `on` CI.mk) $ do
+      (k, v) <- ldapData
+      guard $ k == ldapUserFieldName
+      v' <- v
+      Right str <- return $ Text.decodeUtf8' v'
+      return str
+
+    userSubTermsSemesters = forM userSubTermsSemesters' parseSubTermsSemester
+    userSubTermsSemesters' = do
+      (k, v) <- ldapData
+      guard $ k == ldapUserSubTermsSemester
+      v' <- v
+      Right str <- return $ Text.decodeUtf8' v'
+      return str
+
+  fs' <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures
+  sts <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userSubTermsSemesters
+
+  let
+    studyTermCandidates = Set.fromList $ do
+      let sfKeys = unStudyTermsKey . studyFeaturesField <$> fs'
+          subTermsKeys = unStudyTermsKey . fst <$> sts
+
+      (,) <$> sfKeys ++ subTermsKeys <*> termNames
+
+  let
+    assimilateSubTerms :: [(StudyTermsId, Int)] -> [StudyFeatures] -> WriterT (Set (StudyTermsId, Maybe StudyTermsId)) (SqlPersistT m) [StudyFeatures]
+    assimilateSubTerms [] xs = return xs
+    assimilateSubTerms ((subterm, subSemester) : subterms) unusedFeats = do
+      standalone <- lift $ get subterm
+      case standalone of
+        _other
+          | (match : matches, unusedFeats') <- partition
+              (\StudyFeatures{..} -> subterm     == studyFeaturesField
+                                  && subSemester == studyFeaturesSemester
+              ) unusedFeats
+            -> do
+              $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” and matching feature “#{tshow match}”|]
+              (:) match <$> assimilateSubTerms subterms (matches ++ unusedFeats')
+          | any ((== subterm) . studyFeaturesField) unusedFeats
+            -> do
+              $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” due to feature of matching field|]
+              assimilateSubTerms subterms unusedFeats
+        Just StudyTerms{..}
+          | Just defDegree <- studyTermsDefaultDegree
+          , Just defType   <- studyTermsDefaultType
+            -> do
+              $logDebugS "Campus" [st|Applying default for standalone study term “#{tshow subterm}”|]
+              (:) (StudyFeatures userId defDegree subterm Nothing defType subSemester now True) <$> assimilateSubTerms subterms unusedFeats
+        Nothing
+          | [] <- unusedFeats -> do
+              $logDebugS "Campus" [st|Saw subterm “#{tshow subterm}” when no fos-terms remain|]
+              tell $ Set.singleton (subterm, Nothing)
+              assimilateSubTerms subterms []
+        _other -> do
+          knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] []
+          let matchingFeatures = case knownParents of
+                []      -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats
+                ps      -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> elem studyFeaturesField ps && studyFeaturesSemester == subSemester) unusedFeats
+          when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} ->
+            tell $ Set.singleton (subterm, Just studyFeaturesField)
+          if
+            | not $ null knownParents -> do
+                $logDebugS "Campus" [st|Applying subterm “#{tshow subterm}” to #{tshow matchingFeatures}|]
+                let setSuperField sf = sf
+                      & _studyFeaturesSuperField %~ (<|> Just (sf ^. _studyFeaturesField))
+                      & _studyFeaturesField .~ subterm
+                (++) (map setSuperField matchingFeatures) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures)
+            | otherwise -> do
+                $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}”|]
+                assimilateSubTerms subterms unusedFeats
+  $logDebugS "Campus" [st|Terms for “#{userIdent}”: #{tshow (sts, fs')}|]
+  (fs, studyFieldParentCandidates) <- runWriterT $ assimilateSubTerms sts fs'
+
+  let
+    studyTermCandidateIncidence
+      = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen
+      . UUID.fromByteString
+      . fromStrict
+      . (convert :: Digest (SHAKE128 128) -> ByteString)
+      . runConduitPure
+      $ C.yieldMany ((toStrict . Binary.encode <$> Set.toList studyTermCandidates) ++ (toStrict . Binary.encode <$> Set.toList studyFieldParentCandidates)) .| sinkHash
+
+  candidatesRecorded <- E.selectExists . E.from $ \(candidate `E.FullOuterJoin` parentCandidate `E.FullOuterJoin` standaloneCandidate) -> do
+    E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence
+    E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. parentCandidate E.?. StudySubTermParentCandidateIncidence
+    E.where_ $ candidate E.?. StudyTermNameCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
+         E.||. parentCandidate E.?. StudySubTermParentCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
+         E.||. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence)
+
+  unless candidatesRecorded $ do
+    let
+      studyTermCandidates' = do
+        (studyTermNameCandidateKey, studyTermNameCandidateName) <- Set.toList studyTermCandidates
+        let studyTermNameCandidateIncidence = studyTermCandidateIncidence
+        return StudyTermNameCandidate{..}
+    insertMany_ studyTermCandidates'
+
+    let
+      studySubTermParentCandidates' = do
+        (StudyTermsKey' studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates
+        let studySubTermParentCandidateIncidence = studyTermCandidateIncidence
+        return StudySubTermParentCandidate{..}
+    insertMany_ studySubTermParentCandidates'
+
+    let
+      studyTermStandaloneCandidates' = do
+        (StudyTermsKey' studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates
+        let studyTermStandaloneCandidateIncidence = studyTermCandidateIncidence
+        return StudyTermStandaloneCandidate{..}
+    insertMany_ studyTermStandaloneCandidates'
+
+  E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
+  forM_ fs $ \f@StudyFeatures{..} -> do
+    insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
+    insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing
+    oldFs <- selectKeysList
+      [ StudyFeaturesUser ==. studyFeaturesUser
+       , StudyFeaturesDegree ==. studyFeaturesDegree
+       , StudyFeaturesField ==. studyFeaturesField
+       , StudyFeaturesType ==. studyFeaturesType
+       , StudyFeaturesSemester ==. studyFeaturesSemester
+       ]
+      []
+    case oldFs of
+      [oldF] -> update oldF
+        [ StudyFeaturesUpdated =. now
+        , StudyFeaturesValid =. True
+        , StudyFeaturesField =. studyFeaturesField
+        , StudyFeaturesSuperField =. studyFeaturesSuperField
+        ]
+      _other -> void $ upsert f
+        [ StudyFeaturesUpdated =. now
+        , StudyFeaturesValid =. True
+        , StudyFeaturesSuperField =. studyFeaturesSuperField
+        ]
+  associateUserSchoolsByTerms userId
+
+  let
+    userAssociatedSchools = concat <$> forM userAssociatedSchools' parseLdapSchools
+    userAssociatedSchools' = do
+      (k, v) <- ldapData
+      guard $ k == ldapUserSchoolAssociation
+      v' <- v
+      Right str <- return $ Text.decodeUtf8' v'
+      return str
+
+  ss <- either (throwM . CampusUserInvalidAssociatedSchools . tshow) return userAssociatedSchools
+
+  forM_ ss $ \frag -> void . runMaybeT $ do
+    let
+      exactMatch = MaybeT . getBy $ UniqueOrgUnit frag
+      infixMatch = (hoistMaybe . preview _head) <=< (lift . E.select . E.from) $ \schoolLdap -> do
+        E.where_ $ E.val frag `E.isInfixOf` schoolLdap E.^. SchoolLdapOrgUnit
+             E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool)
+        return schoolLdap
+    Entity _ SchoolLdap{..} <- exactMatch <|> infixMatch
+    ssh <- hoistMaybe schoolLdapSchool
+
+    lift . void $ insertUnique UserSchool
+      { userSchoolUser     = userId
+      , userSchoolSchool   = ssh
+      , userSchoolIsOptOut = False
+      }
+
+  forM_ ss $ void . insertUnique . SchoolLdap Nothing
+
+  return user
+  where
+    insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
+
+associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
+associateUserSchoolsByTerms uid = do
+  sfs <- selectList [StudyFeaturesUser ==. uid] []
+
+  forM_ sfs $ \(Entity _ StudyFeatures{..}) -> do
+    schoolTerms <- selectList [SchoolTermsTerms ==. studyFeaturesField] []
+    forM_ schoolTerms $ \(Entity _ SchoolTerms{..}) ->
+      void $ insertUnique UserSchool
+        { userSchoolUser     = uid
+        , userSchoolSchool   = schoolTermsSchool
+        , userSchoolIsOptOut = False
+        }
+  
+updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX
+                      , YesodAuth UniWorX
+                      , UserId ~ AuthId UniWorX
+                      )
+                   => Maybe Lang -> SqlPersistT m (Maybe Lang)
+updateUserLanguage (Just lang) = do
+  unless (lang `elem` appLanguages) $
+    invalidArgs ["Unsupported language"]
+
+  muid <- maybeAuthId
+  for_ muid $ \uid -> do
+    langs <- languages
+    update uid [ UserLanguages =. Just (Languages $ lang : nub (filter ((&&) <$> (`elem` appLanguages) <*> (/= lang)) langs)) ]
+  setRegisteredCookie CookieLang lang
+  return $ Just lang
+updateUserLanguage Nothing = runMaybeT $ do
+  uid <- MaybeT maybeAuthId
+  User{..} <- MaybeT $ get uid
+  setLangs <- toList . selectLanguages appLanguages <$> languages
+  highPrioSetLangs <- toList . selectLanguages appLanguages <$> highPrioRequestedLangs
+  let userLanguages' = toList . selectLanguages appLanguages <$> userLanguages ^? _Just . _Wrapped
+  lang <- case (userLanguages', setLangs, highPrioSetLangs) of
+    (_, _, hpl : _)
+      -> lift $ hpl <$ update uid [ UserLanguages =. Just (Languages highPrioSetLangs) ]
+    (Just (l : _), _, _)
+      -> return l
+    (Nothing, l : _, _)
+      -> lift $ l <$ update uid [ UserLanguages =. Just (Languages setLangs) ]
+    (Just [], l : _, _)
+      -> return l
+    (_, [], _)
+      -> mzero
+  setRegisteredCookie CookieLang lang
+  return lang
+
+campusUserFailoverMode :: FailoverMode
+campusUserFailoverMode = FailoverUnlimited
+
+embedRenderMessage ''UniWorX ''CampusUserConversionException id

src/Foundation/Yesod/ErrorHandler.hs

@@ -0,0 +1,90 @@
+module Foundation.Yesod.ErrorHandler
+  ( errorHandler
+  ) where
+
+import Import.NoFoundation hiding (errorHandler)
+
+import Utils.Form
+
+import Foundation.Type
+import Foundation.I18n
+import Foundation.Authorization
+import Foundation.SiteLayout
+import Foundation.Routes
+
+import qualified Data.Aeson as JSON
+import qualified Data.Text as Text
+  
+
+errorHandler :: ( MonadSecretBox (HandlerFor UniWorX)
+                , MonadSecretBox (WidgetFor UniWorX)
+                , BearerAuthSite UniWorX
+                , Button UniWorX ButtonSubmit
+                , BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
+                )
+             => ErrorResponse -> HandlerFor UniWorX TypedContent
+errorHandler err = do
+  shouldEncrypt <- do
+    canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
+    shouldEncrypt <- getsYesod $ view _appEncryptErrors
+    return $ shouldEncrypt && not canDecrypt
+
+  sessErr <- bool return (_InternalError $ encodedSecretBox SecretBoxShort) shouldEncrypt err
+  setSessionJson SessionError sessErr
+
+  selectRep $ do
+    provideRep $ do
+      mr <- getMessageRender
+      let
+        encrypted :: ToJSON a => a -> WidgetFor UniWorX () -> WidgetFor UniWorX ()
+        encrypted plaintextJson plaintext = do
+          if
+            | shouldEncrypt -> do
+                ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson
+
+                [whamlet|
+                  <p>_{MsgErrorResponseEncrypted}
+                  <pre .errMsg>
+                    #{ciphertext}
+                |]
+            | otherwise -> plaintext
+
+        errPage = case err of
+          NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
+          InternalError err' -> encrypted err' [whamlet|<p .errMsg>#{err'}|]
+          InvalidArgs errs -> [whamlet|
+              <ul>
+                $forall err' <- errs
+                  <li .errMsg>#{err'}
+             |]
+          NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|]
+          PermissionDenied err' -> [whamlet|<p .errMsg>#{err'}|]
+          BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
+      siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
+        toWidget
+          [cassius|
+            .errMsg
+              white-space: pre-wrap
+              font-family: monospace
+          |]
+        errPage
+    provideRep . fmap PrettyValue $ case err of
+      PermissionDenied err' -> return $ object [ "message" JSON..= err' ]
+      InternalError err'
+        | shouldEncrypt -> do
+            ciphertext <- encodedSecretBox SecretBoxShort err'
+            return $ object [ "message" JSON..= ciphertext
+                            , "encrypted" JSON..= True
+                            ]
+        | otherwise -> return $ object [ "message" JSON..= err' ]
+      InvalidArgs errs -> return $ object [ "messages" JSON..= errs ]
+      _other -> return $ object []
+    provideRep $ case err of
+      PermissionDenied err' -> return err'
+      InternalError err'
+        | shouldEncrypt -> do
+            addHeader "Encrypted-Error-Message" "True"
+            encodedSecretBox SecretBoxPretty err'
+        | otherwise -> return err'
+      InvalidArgs errs -> return . Text.unlines . map (Text.replace "\n" "\n\t") $ errs
+      _other -> return Text.empty

src/Foundation/Yesod/Middleware.hs

@@ -0,0 +1,251 @@
+module Foundation.Yesod.Middleware
+  ( yesodMiddleware
+  , updateFavourites
+  ) where
+
+import Import.NoFoundation hiding (yesodMiddleware)
+
+import Foundation.Type
+import Foundation.Routes
+import Foundation.I18n
+import Foundation.Authorization
+
+import Utils.Metrics
+
+import qualified Network.Wai as W
+import qualified Data.Aeson as JSON
+import qualified Data.CaseInsensitive as CI
+  
+import Control.Monad.Reader.Class (MonadReader(..))
+import Control.Monad.Writer.Class (MonadWriter(..))
+
+import Yesod.Core.Types (GHState(..), HandlerData(..), RunHandlerEnv(rheSite, rheChild))
+
+
+yesodMiddleware :: ( BearerAuthSite UniWorX
+                   , BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
+                   , BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
+                   )
+                => HandlerFor UniWorX res -> HandlerFor UniWorX res
+yesodMiddleware = storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . updateFavouritesMiddleware
+  where
+    dryRunMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+    dryRunMiddleware handler = do
+      dryRun <- isDryRun
+      if | dryRun -> do
+             hData <- ask
+             prevState <- readIORef (handlerState hData)
+             let
+               restoreSession =
+                 modifyIORef (handlerState hData) $
+                   \hst -> hst { ghsSession = ghsSession prevState
+                               , ghsCache = ghsCache prevState
+                               , ghsCacheBy = ghsCacheBy prevState
+                               }
+               site' = (rheSite $ handlerEnv hData) { appMemcached = Nothing }
+               handler' = local (\hd -> hd { handlerEnv = (handlerEnv hd) { rheSite = site', rheChild = site' } }) handler
+
+             addCustomHeader HeaderDryRun $ toPathPiece True
+
+             handler' `finally` restoreSession
+         | otherwise -> handler
+    updateFavouritesMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+    updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
+      route <- MaybeT getCurrentRoute
+      case route of -- update Course Favourites here
+        CourseR tid ssh csh _  -> do
+          void . lift . runDB . runMaybeT $ do
+            guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid ssh csh CShowR) False
+            lift . updateFavourites $ Just (tid, ssh, csh)
+        _other -> return ()
+    normalizeRouteMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX 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'
+    headerMessagesMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+    headerMessagesMiddleware handler = (handler `finally`) . runMaybeT $ do
+      isModal <- hasCustomHeader HeaderIsModal
+      dbTableShortcircuit <- hasCustomHeader HeaderDBTableShortcircuit
+      massInputShortcircuit <- hasCustomHeader HeaderMassInputShortcircuit
+      $logDebugS "headerMessagesMiddleware" $ tshow (isModal, dbTableShortcircuit, massInputShortcircuit)
+      guard $ or
+        [ isModal
+        , dbTableShortcircuit
+        , massInputShortcircuit
+        ]
+
+      lift . bracketOnError getMessages (mapM_ addMessage') $
+        addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode
+    observeYesodCacheSizeMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+    observeYesodCacheSizeMiddleware handler = handler `finally` observeYesodCacheSize
+    csrfMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+    csrfMiddleware handler = do
+      hasBearer <- is _Just <$> lookupBearerAuth
+
+      if | hasBearer -> local (\HandlerData{..} -> HandlerData{ handlerRequest = handlerRequest { reqToken = Nothing }, .. }) handler
+         | otherwise -> csrfSetCookieMiddleware' . defaultCsrfCheckMiddleware $ handler
+      where
+        csrfSetCookieMiddleware' handler' = do
+          mcsrf <- reqToken <$> getRequest
+          whenIsJust mcsrf $ setRegisteredCookie CookieXSRFToken
+          handler'
+    storeBearerMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+    storeBearerMiddleware handler = do
+      askBearer >>= \case
+        Just (Jwt bs) -> setSessionBS (toPathPiece SessionBearer) bs
+        Nothing       -> return ()
+
+      handler
+
+updateFavourites :: forall m backend.
+                    ( MonadHandler m, HandlerSite m ~ UniWorX
+                    , BackendCompatible SqlBackend backend
+                    , YesodAuth UniWorX
+                    , UserId ~ AuthId UniWorX
+                    )
+                 => Maybe (TermId, SchoolId, CourseShorthand) -- ^ Insert course into favourites, as appropriate
+                 -> ReaderT backend m ()
+updateFavourites cData = void . withReaderT projectBackend . runMaybeT $ do
+  $logDebugS "updateFavourites" "Updating favourites"
+
+  now <- liftIO getCurrentTime
+  uid <- MaybeT $ liftHandler maybeAuthId
+  mcid  <- (for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh) :: MaybeT (SqlPersistT m) (Maybe CourseId)
+  User{userMaxFavourites} <- MaybeT $ get uid
+
+  -- update Favourites
+  for_ mcid $ \cid ->
+    void . lift $ upsertBy
+      (UniqueCourseFavourite uid cid)
+      (CourseFavourite uid cid FavouriteVisited now)
+      [CourseFavouriteLastVisit =. now]
+  -- prune Favourites to user-defined size
+  oldFavs <- lift $ selectList [CourseFavouriteUser ==. uid] []
+  let deleteFavs = oldFavs
+        & sortOn ((courseFavouriteReason &&& Down . courseFavouriteLastVisit) . entityVal)
+        & drop userMaxFavourites
+        & filter ((<= FavouriteVisited) . courseFavouriteReason . entityVal)
+        & map entityKey
+  unless (null deleteFavs) $
+    lift $ deleteWhere [CourseFavouriteId <-. deleteFavs]
+
+  
+routeNormalizers :: forall m backend.
+                    ( BackendCompatible SqlReadBackend backend
+                    , MonadHandler m, HandlerSite m ~ UniWorX
+                    , BearerAuthSite UniWorX
+                    ) => [Route UniWorX -> WriterT Any (ReaderT backend m) (Route UniWorX)]
+routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .)
+  [ normalizeRender
+  , ncSchool
+  , ncAllocation
+  , ncCourse
+  , ncSheet
+  , ncMaterial
+  , ncTutorial
+  , ncExam
+  , ncExternalExam
+  , verifySubmission
+  , verifyCourseApplication
+  , verifyCourseNews
+  ]
+  where
+    normalizeRender :: Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX)
+    normalizeRender route = route <$ do
+      YesodRequest{..} <- liftHandler 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 :: (Route UniWorX -> MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX))) (Route UniWorX))
+              -> Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX)
+    maybeOrig f route = maybeT (return route) $ f route
+
+    caseChanged :: (Eq a, Show a) => CI a -> CI a -> MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX))) ()
+    caseChanged a b
+      | ((/=) `on` CI.original) a b = do
+          $logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|]
+          tell $ Any True
+      | otherwise                   = return ()
+
+    ncSchool = maybeOrig . typesUsing @RouteChildren @SchoolId $ \ssh -> $cachedHereBinary ssh $ do
+      let schoolShort :: SchoolShorthand
+          schoolShort = unSchoolKey ssh
+      Entity ssh' _  <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort
+      (caseChanged `on` unSchoolKey) ssh ssh'
+      return ssh'
+    ncAllocation = maybeOrig $ \route -> do
+      AllocationR tid ssh ash _ <- return route
+      Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . lift . getBy $ TermSchoolAllocationShort tid ssh ash
+      caseChanged ash allocationShorthand
+      return $ route & typesUsing @RouteChildren @AllocationShorthand . filtered (== ash) .~ allocationShorthand
+    ncCourse = maybeOrig $ \route -> do
+      CourseR tid ssh csh _ <- return route
+      Entity _ Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
+      caseChanged csh courseShorthand
+      return $ route & typesUsing @RouteChildren @CourseShorthand . filtered (== csh) .~ courseShorthand
+    ncSheet = maybeOrig $ \route -> do
+      CSheetR tid ssh csh shn _ <- return route
+      cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
+      Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . lift . getBy $ CourseSheet cid shn
+      caseChanged shn sheetName
+      return $ route & typesUsing @RouteChildren @SheetName . filtered (== shn) .~ sheetName
+    ncMaterial = maybeOrig $ \route -> do
+      CMaterialR tid ssh csh mnm _ <- return route
+      cid <- MaybeT  . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
+      Entity _ Material{..} <- MaybeT . $cachedHereBinary (cid, mnm) . lift . getBy $ UniqueMaterial cid mnm
+      caseChanged mnm materialName
+      return $ route & typesUsing @RouteChildren @MaterialName . filtered (== mnm) .~ materialName
+    ncTutorial = maybeOrig $ \route -> do
+      CTutorialR tid ssh csh tutn _ <- return route
+      cid <- MaybeT  . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
+      Entity _ Tutorial{..} <- MaybeT . $cachedHereBinary (cid, tutn) . lift . getBy $ UniqueTutorial cid tutn
+      caseChanged tutn tutorialName
+      return $ route & typesUsing @RouteChildren @TutorialName . filtered (== tutn) .~ tutorialName
+    ncExam = maybeOrig $ \route -> do
+      CExamR tid ssh csh examn _ <- return route
+      cid <- MaybeT  . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
+      Entity _ Exam{..} <- MaybeT . $cachedHereBinary (cid, examn) . lift . getBy $ UniqueExam cid examn
+      caseChanged examn examName
+      return $ route & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ examName
+    ncExternalExam = maybeOrig $ \route -> do
+      EExamR tid ssh coursen examn _ <- return route
+      Entity _ ExternalExam{..} <- MaybeT . $cachedHereBinary (tid, ssh, coursen, examn) . lift . getBy $ UniqueExternalExam tid ssh coursen examn
+      caseChanged coursen externalExamCourseName
+      caseChanged examn externalExamExamName
+      return $ route
+        & typesUsing @RouteChildren @CourseName . filtered (== coursen) .~ externalExamCourseName
+        & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ externalExamExamName
+    verifySubmission = maybeOrig $ \route -> do
+      CSubmissionR _tid _ssh _csh _shn cID sr <- return route
+      sId <- $cachedHereBinary cID $ decrypt cID
+      Submission{submissionSheet} <- MaybeT . $cachedHereBinary cID . lift $ get sId
+      Sheet{sheetCourse, sheetName} <- MaybeT . $cachedHereBinary submissionSheet . lift $ get submissionSheet
+      Course{courseTerm, courseSchool, courseShorthand} <- MaybeT . $cachedHereBinary sheetCourse . lift $ get sheetCourse
+      let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr
+      tell . Any $ route /= newRoute
+      return newRoute
+    verifyCourseApplication = maybeOrig $ \route -> do
+      CApplicationR _tid _ssh _csh cID sr <- return route
+      aId <- decrypt cID
+      CourseApplication{courseApplicationCourse} <- lift . lift $ get404 aId
+      Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseApplicationCourse
+      let newRoute = CApplicationR courseTerm courseSchool courseShorthand cID sr
+      tell . Any $ route /= newRoute
+      return newRoute
+    verifyCourseNews = maybeOrig $ \route -> do
+      CNewsR _tid _ssh _csh cID sr <- return route
+      aId <- decrypt cID
+      CourseNews{courseNewsCourse} <- lift . lift $ get404 aId
+      Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseNewsCourse
+      let newRoute = CNewsR courseTerm courseSchool courseShorthand cID sr
+      tell . Any $ route /= newRoute
+      return newRoute

src/Foundation/Yesod/Persist.hs

@@ -0,0 +1,44 @@
+module Foundation.Yesod.Persist
+  ( runDB, getDBRunner
+  , module Foundation.DB
+  ) where
+
+import Import.NoFoundation hiding (runDB, getDBRunner)
+
+import Foundation.Type
+import Foundation.DB
+import Foundation.Authorization
+
+import Database.Persist.Sql (transactionUndo)
+
+
+runDB :: ( YesodPersistBackend UniWorX ~ SqlBackend
+         , BearerAuthSite UniWorX
+         )
+      => YesodDB UniWorX a -> HandlerFor UniWorX a
+runDB action = do
+  -- stack <- liftIO currentCallStack
+  -- $logDebugS "YesodPersist" . unlines $ "runDB" : map pack stack
+  $logDebugS "YesodPersist" "runDB"
+  dryRun <- isDryRun
+  let action'
+        | dryRun = action <* transactionUndo
+        | otherwise = action
+
+  runSqlPoolRetry action' . appConnPool =<< getYesod
+
+getDBRunner :: ( YesodPersistBackend UniWorX ~ SqlBackend
+               , BearerAuthSite UniWorX
+               )
+            => HandlerFor UniWorX (DBRunner UniWorX, HandlerFor UniWorX ())
+getDBRunner = do
+  (DBRunner{..}, cleanup) <- defaultGetDBRunner appConnPool
+  return . (, cleanup) $ DBRunner
+    (\action -> do
+        dryRun <- isDryRun
+        let action'
+              | dryRun = action <* transactionUndo
+              | otherwise = action
+        $logDebugS "YesodPersist" "runDBRunner"
+        runDBRunner action'
+    )

src/Foundation/Yesod/Session.hs

@@ -0,0 +1,62 @@
+module Foundation.Yesod.Session
+  ( makeSessionBackend
+  ) where
+
+import Import.NoFoundation hiding (makeSessionBackend)
+
+import Foundation.Type
+
+import qualified Web.ServerSession.Core as ServerSession
+import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession
+
+import qualified Network.Wai as W
+import qualified Network.HTTP.Types.Header as W
+import qualified Network.Wai.Middleware.HttpAuth as W (extractBearerAuth)
+
+import Web.Cookie
+
+
+makeSessionBackend :: Yesod UniWorX => UniWorX -> IO (Maybe SessionBackend)
+makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of
+        SessionStorageMemcachedSql sqlStore
+          -> mkBackend . stateSettings =<< ServerSession.createState sqlStore
+        SessionStorageAcid acidStore
+          | appServerSessionAcidFallback
+            -> mkBackend . stateSettings =<< ServerSession.createState acidStore
+        _other
+          -> return Nothing
+      where
+        cfg = JwtSession.ServerSessionJwtConfig
+          { sJwtJwkSet     = appJSONWebKeySet
+          , sJwtStart      = Nothing
+          , sJwtExpiration = appSessionTokenExpiration
+          , sJwtEncoding   = appSessionTokenEncoding
+          , sJwtIssueBy    = appInstanceID
+          , sJwtIssueFor   = appClusterID
+          }
+        mkBackend :: forall sto.
+                   ( ServerSession.SessionData sto ~ Map Text ByteString
+                   , ServerSession.Storage sto
+                   )
+                  => ServerSession.State sto -> IO (Maybe SessionBackend)
+        mkBackend = JwtSession.backend cfg (JwtSession.siteApproot app)
+        stateSettings :: forall sto. ServerSession.State sto -> ServerSession.State sto
+        stateSettings = ServerSession.setCookieName (toPathPiece CookieSession) . applyServerSessionSettings appServerSessionConfig
+        sameSite
+          | Just sameSiteStrict == cookieSameSite (getCookieSettings app CookieSession)
+          = strictSameSiteSessions
+          | Just sameSiteLax    == cookieSameSite (getCookieSettings app CookieSession)
+          = laxSameSiteSessions
+          | otherwise
+          = id
+        notForBearer :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
+        notForBearer = fmap $ fmap notForBearer'
+          where notForBearer' :: SessionBackend -> SessionBackend
+                notForBearer' (SessionBackend load)
+                  = let load' req
+                          | aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req
+                          , any (is _Just . W.extractBearerAuth) aHdrs
+                          = return (mempty, const $ return [])
+                          | otherwise
+                          = load req
+                     in SessionBackend load'

src/Foundation/Yesod/StaticContent.hs

@@ -0,0 +1,49 @@
+module Foundation.Yesod.StaticContent
+  ( addStaticContent
+  ) where
+
+import Import.NoFoundation hiding (addStaticContent)
+
+import Foundation.Type
+
+import qualified Database.Memcached.Binary.IO as Memcached
+
+import qualified Data.ByteString.Lazy as Lazy
+import qualified Data.ByteString.Base64.URL as Base64 (encodeUnpadded)
+import Data.ByteArray (convert)
+import Crypto.Hash (SHAKE256)
+import Crypto.Hash.Conduit (sinkHash)
+import Data.Bits (Bits(zeroBits))
+
+import qualified Data.Conduit.Combinators as C
+
+
+addStaticContent :: Text
+                 -> Text
+                 -> Lazy.ByteString
+                 -> HandlerFor UniWorX (Maybe (Either Text (Route UniWorX, [(Text, Text)])))
+addStaticContent ext _mime content = do
+  UniWorX{appWidgetMemcached, appSettings'} <- getYesod
+  for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConf = MemcachedConf { memcachedExpiry }, widgetMemcachedBaseUrl }) -> do
+    let expiry = maybe 0 ceiling memcachedExpiry
+        touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
+        add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
+        absoluteLink = unpack widgetMemcachedBaseUrl </> fileName
+    catchIf Memcached.isKeyNotFound touch . const $
+      handleIf Memcached.isKeyExists (const $ return ()) add
+    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
+    --
+    -- SHA-3 (SHAKE256) seemed to be a future-proof choice
+    --
+    -- Length of hash is 144 bits ~~instead of MD5's 128, so as to avoid
+    -- padding after base64-conversion~~ for backwards compatability
+    fileName = (<.> unpack ext)
+             . unpack
+             . decodeUtf8
+             . Base64.encodeUnpadded
+             . (convert :: Digest (SHAKE256 144) -> ByteString)
+             . runConduitPure
+             $ C.sourceLazy content .| sinkHash

src/Handler/Admin.hs

@@ -4,8 +4,6 @@ module Handler.Admin
 
 import Import
 
-import Handler.Utils
-
 import Handler.Admin.Test as Handler.Admin
 import Handler.Admin.ErrorMessage as Handler.Admin
 import Handler.Admin.StudyFeatures as Handler.Admin

src/Handler/Admin/Test/Download.hs

@@ -47,8 +47,8 @@ testDownloadForm = identifyForm FIDTestDownload . renderWForm FormStandard $ do
   modeRes <- wpopt (selectField optionsFinite) (fslI MsgTestDownloadMode) $ Just TestDownloadDirect
 
   return $ TestDownloadOptions
-    <$> pure randomSeed
+        randomSeed
-    <*> maxSizeRes
+    <$> maxSizeRes
     <*> pure (2^20)
     <*> modeRes
 

src/Handler/Admin/Tokens.hs

@@ -88,7 +88,7 @@ postAdminTokensR = do
 
     fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' btfRoutes btfAddAuth btfExpiresAt btfStartsAt
 
-  siteLayoutMsg' MsgMenuAdminTokens $ do
+  siteLayoutMsg MsgMenuAdminTokens $ do
     setTitleI MsgMenuAdminTokens
 
     let bearerForm = wrapForm bearerView def

src/Handler/Allocation/Application.hs

@@ -64,7 +64,7 @@ data ApplicationFormException = ApplicationFormNoApplication -- ^ Could not fill
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 instance Exception ApplicationFormException
 
-applicationForm :: (Maybe AllocationId)
+applicationForm :: Maybe AllocationId
                 -> CourseId
                 -> UserId
                 -> ApplicationFormMode -- ^ Which parts of the shared form to display
@@ -75,7 +75,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
     mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
     coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId])
     course <- getJust cid
-    (fromMaybe 0 -> maxPrio) <- fmap ((>>= E.unValue) . listToMaybe) . E.select . E.from $ \courseApplication -> do
+    (fromMaybe 0 -> maxPrio) <- fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \courseApplication -> do
       E.where_ $ courseApplication E.^. CourseApplicationUser       E.==. E.val uid
            E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId
            E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority)
@@ -105,7 +105,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
 
   (prioRes, prioView) <- case (isAlloc, afmApplicant, afmApplicantEdit, mApp) of
     (True , True , True , Nothing)
-      -> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just $ oldPrio) 
+      -> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just oldPrio)
     (True , True , True , Just _ )
       -> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio
     (True , True , False, _      )
@@ -144,7 +144,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
   let appFilesInfo = (,) <$> hasFiles <*> appCID
 
   filesLinkView <- if
-    | fromMaybe False hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit)
+    | Just True == hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit)
       -> let filesLinkField = Field{..}
                where
                  fieldParse _ _ = return $ Right Nothing
@@ -165,7 +165,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
       -> return Nothing
 
   filesWarningView <- if
-    | fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit
+    | Just True == hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit
       -> fmap (Just . snd) . formMessage =<< messageIconI Info IconFileUpload MsgCourseApplicationFilesNeedReupload
     | otherwise
       -> return Nothing
@@ -174,15 +174,15 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
     let mkFs = bool MsgCourseApplicationFile MsgCourseApplicationArchive
      in if
       | not afmApplicantEdit || is _NoUpload courseApplicationsFiles
-        -> return $ (FormSuccess Nothing, Nothing)
+        -> return (FormSuccess Nothing, Nothing)
       | otherwise
         -> fmap (over _2 $ Just . ($ [])) . aFormToForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles
 
   (vetoRes, vetoView) <- if
     | afmLecturer
-      -> over _2 Just <$> mpopt checkBoxField (fslI MsgApplicationVeto & setTooltip MsgApplicationVetoTip) (Just . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp)
+      -> over _2 Just <$> mpopt checkBoxField (fslI MsgApplicationVeto & setTooltip MsgApplicationVetoTip) (Just $ Just True == fmap (courseApplicationRatingVeto . entityVal) mApp)
     | otherwise
-      -> return (FormSuccess . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp, Nothing)
+      -> return (FormSuccess $ Just True == fmap (courseApplicationRatingVeto . entityVal) mApp, Nothing)
 
   (pointsRes, pointsView) <- if
     | afmLecturer
@@ -285,7 +285,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
             , courseApplicationRatingTime         = guardOn rated now
             }
 
-          runConduit $ transPipe liftHandler (traverse_ id afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
+          runConduit $ transPipe liftHandler (sequence_ afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
           audit $ TransactionCourseApplicationEdit cid uid appId
           addMessageI Success $ MsgCourseApplicationCreated courseShorthand
       | is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction

src/Handler/Course/Edit.hs

@@ -139,7 +139,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
                 , not $ Set.null existing
                   -> FormFailure [mr MsgCourseLecturerAlreadyAdded]
                 | otherwise
-                  -> FormSuccess . Map.fromList . zip [maybe 0 succ . fmap fst $ Map.lookupMax oldDat ..] $ Set.toList newDat
+                  -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat
               addView' = $(widgetFile "course/lecturerMassInput/add")
           return (addRes'', addView')
 
@@ -199,10 +199,11 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
         (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing,Nothing)
         _allIOtherCases -> do
             mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
-            return (  Just (Just now)
+            return ( Just $ Just now
-                   , (Just . toMidnight     . termStart . entityVal) <$> mbLastTerm
+                   , Just . toMidnight     . termStart . entityVal <$> mbLastTerm
-                   , (Just . beforeMidnight . termEnd   . entityVal) <$> mbLastTerm
+                   , Just . beforeMidnight . termEnd   . entityVal <$> mbLastTerm
-                   , (Just . beforeMidnight . termEnd   . entityVal) <$> mbLastTerm )
+                   , Just . beforeMidnight . termEnd   . entityVal <$> mbLastTerm
+                   )
 
     let
       allocationForm :: AForm Handler (Maybe AllocationCourseForm)
@@ -243,7 +244,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
 
             let
               userAdmin = not $ null adminSchools
-              mayChange = fromMaybe True $ (|| userAdmin) <$> currentAllocationAvailable
+              mayChange = Just False /= fmap (|| userAdmin) currentAllocationAvailable
 
               allocationForm' =
                 let ainp :: Field Handler a -> FieldSettings UniWorX -> Maybe a -> AForm Handler a
@@ -265,8 +266,8 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
     multipleTermsMsg <- messageI Warning MsgCourseSemesterMultipleTip
 
     (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
-      <$> pure (cfCourseId =<< template)
+          (cfCourseId =<< template)
-      <*> areq (textField & cfStrip & cfCI) (fslI MsgCourseName)                             (cfName       <$> template)
+      <$> areq (textField & cfStrip & cfCI) (fslI MsgCourseName)                             (cfName       <$> template)
       <*> areq (textField & cfStrip & cfCI) (fslpI MsgCourseShorthand "ProMo, LinAlg1, AlgoDat, Ana2, EiP, …"
             -- & addAttr "disabled" "disabled"
             & setTooltip MsgCourseShorthandUnique)                      (cfShort      <$> template)
@@ -333,7 +334,7 @@ validateCourse = do
   guardValidation MsgCourseRegistrationEndMustBeAfterStart
     $ NTop cfRegFrom <= NTop cfRegTo
   guardValidation MsgCourseDeregistrationEndMustBeAfterStart
-    $ fromMaybe True $ (<=) <$> cfRegFrom <*> cfDeRegUntil
+    $ Just False /= ((<=) <$> cfRegFrom <*> cfDeRegUntil)
   unless userAdmin $
     guardValidation MsgCourseUserMustBeLecturer
       $ anyOf (traverse . _Right . _1) (== uid) cfLecturers
@@ -538,7 +539,7 @@ courseEditHandler miButtonAction mbCourseForm = do
                     insert_ $ CourseEdit aid now cid
 
                     let mkFilter CourseAppInstructionFileResidual{..} = [ CourseAppInstructionFileCourse ==. courseAppInstructionFileResidualCourse ]
-                     in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . traverse_ id $ cfAppInstructionFiles res
+                     in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . sequence_ $ cfAppInstructionFiles res
 
                     upsertAllocationCourse cid $ cfAllocation res
 
@@ -556,7 +557,7 @@ courseEditHandler miButtonAction mbCourseForm = do
 upsertAllocationCourse :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
 upsertAllocationCourse cid cfAllocation = do
   now <- liftIO getCurrentTime
-  Course{..} <- getJust cid
+  Course{} <- getJust cid
   prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
   prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
   userAdmin <- fromMaybe False <$> for prevAllocation (\Allocation{..} -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR)

src/Handler/Course/News/Edit.hs

@@ -33,8 +33,8 @@ postCNEditR tid ssh csh cID = do
         , courseNewsSummary          = cnfSummary
         , courseNewsLastEdit         = now
         }
-      let mkFilter CourseNewsFileResidual{..} = [ CourseNewsFileNews ==. nId ]
+      let mkFilter CourseNewsFileResidual{} = [ CourseNewsFileNews ==. nId ]
-       in void . replaceFileReferences mkFilter (CourseNewsFileResidual nId) $ traverse_ id cnfFiles
+       in void . replaceFileReferences mkFilter (CourseNewsFileResidual nId) $ sequence_ cnfFiles
     addMessageI Success MsgCourseNewsEdited
     redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
 

src/Handler/Course/ParticipantInvite.hs

@@ -92,11 +92,11 @@ participantInvitationConfig = InvitationConfig{..}
       itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
-    invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do
+    invitationForm _ _ uid = hoistAForm lift . wFormToAForm $ do
       now <- liftIO getCurrentTime
       studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
           (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
-      return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing <*> pure CourseParticipantActive
+      return . fmap (, ()) $ JunctionParticipant now <$> studyFeatures <*> pure Nothing <*> pure CourseParticipantActive
     invitationInsertHook _ _ (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do
       deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert
       res <- act -- insertUnique

src/Handler/Course/Register.hs

@@ -118,7 +118,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
     let appFilesInfo = (,) <$> hasFiles <*> appCID
         filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired
 
-    when (isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles) $
+    when (isn't _NoUpload courseApplicationsFiles || Just True == hasFiles) $
       let filesLinkField = Field{..}
             where
               fieldParse _ _ = return $ Right Nothing
@@ -136,7 +136,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
                   |]
        in void $ wforced filesLinkField (fslI filesMsg) Nothing
 
-    when (fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles) $
+    when (Just True == hasFiles && isn't _NoUpload courseApplicationsFiles) $
       wformMessage <=< messageIconI Info IconFileUpload $ bool MsgCourseRegistrationFilesNeedReupload MsgCourseApplicationFilesNeedReupload courseApplicationsRequired
 
     appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive
@@ -288,7 +288,7 @@ deregisterParticipant :: UserId -> CourseId -> DB ()
 deregisterParticipant uid cid = do
   deleteApplications uid cid
   part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
-  forM_ part $ \(Entity partId CourseParticipant{..}) -> do
+  forM_ part $ \(Entity partId CourseParticipant{}) -> do
     update partId [CourseParticipantState =. CourseParticipantInactive False]
     audit $ TransactionCourseParticipantDeleted cid uid
 

src/Handler/Course/Show.hs

@@ -112,9 +112,8 @@ getCShowR tid ssh csh = do
   mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
 
   cID <- encrypt cid :: Handler CryptoUUIDCourse
-  mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (,)
+  mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (alloc, )
-    <$> pure alloc
+    <$> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
-    <*> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
   regForm <- if
     | is _Just mbAid -> do
         (courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course)

src/Handler/Course/User.hs

@@ -115,7 +115,7 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex =
         , formSubmit = FormAutoSubmit
         , formAnchor = Just registrationFieldFrag
         }
-  for_ mRegistration $ \(Entity pId CourseParticipant{..}) ->
+  for_ mRegistration $ \(Entity pId CourseParticipant{}) ->
     formResult regFieldRes $ \courseParticipantField' -> do
       lift . runDB $ do
         update pId [ CourseParticipantField =. courseParticipantField' ]

src/Handler/Course/Users.hs

@@ -199,7 +199,7 @@ colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns
     userSheetCol :: SheetName -> Colonnade Sortable UserTableData (DBCell m c)
     userSheetCol shn = sortable (Just . SortingKey $ "sheet-" <> shn) (i18nCell shn) . views (_userSheets . at shn) $ \case
       Just (preview _grading -> Just Points{..}, Just points) -> i18nCell $ MsgAchievedOf points maxPoints
-      Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgNotPassed MsgPassed . fromMaybe False $ gradingPassed grading' points
+      Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgNotPassed MsgPassed $ Just True == gradingPassed grading' points
       _other -> mempty
 
 
@@ -404,33 +404,33 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
           , single $ sortUserEmail       queryUser
           , single $ sortUserMatriclenr  queryUser
           , sortUserSex (to queryUser . to (E.^. UserSex))
-          , single $ ("degree"      , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
+          , single ("degree"      , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
-          , single $ ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
+          , single ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
-          , single $ ("field"       , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsName))
+          , single ("field"       , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsName))
-          , single $ ("field-short" , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsShorthand))
+          , single ("field-short" , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsShorthand))
-          , single $ ("semesternr"  , SortColumn $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
+          , single ("semesternr"  , SortColumn $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
-          , single $ ("registration", SortColumn $ queryParticipant    >>> (E.^. CourseParticipantRegistration))
+          , single ("registration", SortColumn $ queryParticipant    >>> (E.^. CourseParticipantRegistration))
-          , single $ ("note"        , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
+          , single ("note"        , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
                 E.subSelectMaybe . E.from $ \edit -> do
                   E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
                   return . E.max_ $ edit E.^. CourseUserNoteEditTime
             )
-          , single $ ("tutorials"   , SortColumn $ queryUser >>> \user ->
+          , single ("tutorials"   , SortColumn $ queryUser >>> \user ->
                 E.subSelectMaybe . E.from $ \(tutorial `E.InnerJoin` participant) -> do
                   E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
                    E.&&. tutorial E.^. TutorialCourse E.==. E.val cid
                   E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId
                   return . E.min_ $ tutorial E.^. TutorialName
             )
-          , single $ ("exams"       , SortColumn $ queryUser >>> \user ->
+          , single ("exams"       , SortColumn $ queryUser >>> \user ->
                 E.subSelectMaybe . E.from $ \(exam `E.InnerJoin` examRegistration) -> do
                   E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
                    E.&&. exam E.^. ExamCourse E.==. E.val cid
                   E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
                   return . E.min_ $ exam E.^. ExamName
             )
-          , single $ ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
+          , single ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
-          , single $ ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
+          , single ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
           , mconcat
             [ single ( SortingKey $ "sheet-" <> sheetName
                      , SortColumn $ \(queryUser -> user) -> E.subSelectMaybe . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
@@ -450,28 +450,28 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
           , single $ fltrUserMatriclenr  queryUser
           , single $ fltrUserNameEmail   queryUser
           , fltrUserSex (to queryUser . to (E.^. UserSex))
-          , single $ ("field-name"  , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
+          , single ("field-name"  , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
-          , single $ ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
+          , single ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
-          , single $ ("field-key"   , FilterColumn $ E.mkExactFilter    $ queryFeaturesField >>> (E.?. StudyTermsKey))
+          , single ("field-key"   , FilterColumn $ E.mkExactFilter    $ queryFeaturesField >>> (E.?. StudyTermsKey))
-          , single $ ("field"       , FilterColumn $ E.anyFilter
+          , single ("field"       , FilterColumn $ E.anyFilter
                                         [ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
                                         , E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
                                         , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
                                         ] )
-          , single $ ("degree"      , FilterColumn $ E.anyFilter
+          , single ("degree"      , FilterColumn $ E.anyFilter
                                         [ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName)
                                         , E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
                                         , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
                                         ] )
-          , single $ ("semesternr"  , FilterColumn $ E.mkExactFilter    $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
+          , single ("semesternr"  , FilterColumn $ E.mkExactFilter    $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
-          , single $ ("tutorial"    , FilterColumn $ E.mkExistsFilter   $ \row criterion ->
+          , single ("tutorial"    , FilterColumn $ E.mkExistsFilter   $ \row criterion ->
                          E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
                            E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
                            E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
                                 E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
                                 E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
                      )
-          , single $ ("exam"        , FilterColumn $ E.mkExistsFilter $ \row criterion -> 
+          , single ("exam"        , FilterColumn $ E.mkExistsFilter $ \row criterion ->
                          E.from $ \(exam `E.InnerJoin` examRegistration) -> do
                            E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
                            E.where_ $ exam E.^. ExamCourse E.==. E.val cid
@@ -480,15 +480,15 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
                      )
           -- , ("course-registration", error "TODO") -- TODO
           -- , ("course-user-note", error "TODO") -- TODO
-          , single $ ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
+          , single ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
-          , single $ ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
+          , single ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
-          , single $ ("has-personalised-sheet-files", FilterColumn $ \t (Last criterion) -> flip (maybe E.true) criterion $ \shn
+          , single ("has-personalised-sheet-files", FilterColumn $ \t (Last criterion) -> flip (maybe E.true) criterion $ \shn
-                       -> E.exists . E.from $ \(psFile `E.InnerJoin` sheet) -> do
+                     -> E.exists . E.from $ \(psFile `E.InnerJoin` sheet) -> do
-                            E.on $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
+                          E.on $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
-                            E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. queryParticipant t E.^. CourseParticipantUser
+                          E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. queryParticipant t E.^. CourseParticipantUser
-                            E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
+                          E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
-                                 E.&&. sheet E.^. SheetName E.==. E.val shn
+                               E.&&. sheet E.^. SheetName E.==. E.val shn
-                     )
+                   )
           ]
           where single = uncurry Map.singleton
         dbtFilterUI mPrev = mconcat $
@@ -652,7 +652,7 @@ postCUsersR tid ssh csh = do
         hasExams = not $ null exams
         examOccActs :: Map ExamId (AForm Handler (ExamId, Maybe ExamOccurrenceId))
         examOccActs = examOccurrencesPerExam
-          & (map (bimap entityKey hoistMaybe)) 
+          & map (bimap entityKey hoistMaybe)
           & Map.fromListWith (<>)
           & imap (\k v -> case v of
             [] -> pure (k, Nothing)

src/Handler/CryptoIDDispatch.hs

@@ -5,6 +5,8 @@ module Handler.CryptoIDDispatch
 
 import Import
 
+import Handler.Utils
+  
 import qualified Data.Text as Text
 
 import Yesod.Core.Types (HandlerContents(..))
@@ -45,7 +47,7 @@ instance CryptoRoute UUID UserId where
     (_ :: UserId) <- decrypt cID
     return $ AdminUserR cID
 
-class Dispatch ciphertext (x :: [*]) where
+class Dispatch ciphertext (x :: [Type]) where
   dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX))
 
 instance Dispatch ciphertext '[] where

src/Handler/Exam/Correct.hs

@@ -65,7 +65,7 @@ postECorrectR tid ssh csh examn = do
   mayEditResults <- hasWriteAccessTo $ CExamR tid ssh csh examn EUsersR
 
   response <- runDB . exceptT (<$ transactionUndo) return $ do
-    Entity eId Exam{..} <- lift $ fetchExam tid ssh csh examn
+    Entity eId Exam{} <- lift $ fetchExam tid ssh csh examn
     euid <- traverse decrypt ciqUser
 
     guardMExceptT (maybe True ((>= minNeedleLength) . length) $ euid ^? _Left) $ 

src/Handler/Exam/Form.hs

@@ -96,7 +96,7 @@ examForm template html = do
     <*> apopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (efPublicStatistics <$> template <|> Just True)
     <*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template)
     <*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template)
-    <*> (examOccurrenceRuleForm $ efOccurrenceRule <$> template)
+    <*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
     <*  aformSection MsgExamFormCorrection
     <*> examCorrectorsForm (efCorrectors <$> template)
     <*  aformSection MsgExamFormParts
@@ -117,7 +117,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do
       (addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser $ Just corrUserSuggestions) (fslI MsgExamCorrectorEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
       let
         addRes'
-          | otherwise
+
           = addRes <&> \newDat oldDat -> if
               | existing <- newDat `Set.intersection` Set.fromList oldDat
               , not $ Set.null existing
@@ -221,7 +221,7 @@ examPartsForm prev = wFormToAForm $ do
       (res, formWidget) <- examPartForm' nudge Nothing csrf
       let
         addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
-          | any (\old -> fromMaybe False $ (==) <$> epfName newDat <*> epfName old) oldDat
+          | any (\old -> Just True == ((==) <$> epfName newDat <*> epfName old)) oldDat
             -> FormFailure [mr MsgExamPartAlreadyExists]
           | otherwise -> FormSuccess $ pure newDat
       return (addRes, $(widgetFile "widgets/massinput/examParts/add"))
@@ -336,10 +336,10 @@ validateExam = do
 
   guardValidation MsgExamRegisterToMustBeAfterRegisterFrom                 $ NTop efRegisterTo                   >= NTop efRegisterFrom
   guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom            $ NTop efDeregisterUntil              >= NTop efRegisterFrom
-  guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments      . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments
+  guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments      $ Just False /= ((>=) <$> efStart <*> efPublishOccurrenceAssignments)
   guardValidation MsgExamEndMustBeAfterStart                               $ NTop efEnd                          >= NTop efStart
-  guardValidation MsgExamFinishedMustBeAfterEnd                            . fromMaybe True $ (>=) <$> efFinished <*> efEnd
+  guardValidation MsgExamFinishedMustBeAfterEnd   $ Just False /= ((>=) <$> efFinished <*> efEnd)
-  guardValidation MsgExamFinishedMustBeAfterStart                          . fromMaybe True $ (>=) <$> efFinished <*> efStart
+  guardValidation MsgExamFinishedMustBeAfterStart $ Just False /= ((>=) <$> efFinished <*> efStart)
 
   forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
     guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName)       $ NTop eofEnd >= NTop (Just eofStart)

src/Handler/Exam/List.hs

@@ -81,10 +81,9 @@ mkExamTable (Entity cid Course{..}) = do
 
 getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCExamListR tid ssh csh = do
-  (Entity _ Course{..}, examTable) <- runDB $ do
+  examTable <- runDB $ do
     c <- getBy404 $ TermSchoolCourseShort tid ssh csh
-    (_, examTable) <- mkExamTable c
+    view _2 <$> mkExamTable c
-    return (c, examTable)
 
   siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do
     setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading

src/Handler/Exam/Register.hs

@@ -36,9 +36,9 @@ instance Button UniWorX ButtonExamRegister where
 
 postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
 postERegisterR tid ssh csh examn = do
-  Entity uid User{..} <- requireAuth
+  uid <- requireAuthId
 
-  Entity eId Exam{..} <- runDB $ fetchExam tid ssh csh examn
+  Entity eId Exam{} <- runDB $ fetchExam tid ssh csh examn
 
   ((btnResult, _), _) <- runFormPost $ buttonForm' [BtnExamRegister, BtnExamDeregister]
 
@@ -63,11 +63,11 @@ postERegisterR tid ssh csh examn = do
 
 postERegisterOccR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> ExamOccurrenceName -> Handler Html
 postERegisterOccR tid ssh csh examn occn = do
-  Entity uid User{..} <- requireAuth
+  uid <- requireAuthId
-  (Entity eId Exam{..}, Entity occId ExamOccurrence{..}) <- runDB $ do
+  (eId, occId) <- runDB $ do
-    eexam@(Entity eId _) <- fetchExam tid ssh csh examn
+    Entity eId _ <- fetchExam tid ssh csh examn
-    occ <- getBy404 $ UniqueExamOccurrence eId occn
+    occ <- getKeyBy404 $ UniqueExamOccurrence eId occn
-    return (eexam, occ)
+    return (eId, occ)
 
   ((btnResult, _), _) <- runFormPost buttonForm
 

src/Handler/Exam/Show.hs

@@ -96,9 +96,9 @@ getEShowR tid ssh csh examn = do
 
       sumRegisteredCount = sumOf (folded . _3) occurrences
 
-      noBonus = fromMaybe False $ do
+      noBonus = (Just True ==) $ do
         guardM $ bonusOnlyPassed <$> examBonusRule
-        return . fromMaybe True $ result ^? _Just . _entityVal . _examResultResult . _examResult . to (either id $ view passingGrade) . _Wrapped . to not
+        return $ Just False /= result ^? _Just . _entityVal . _examResultResult . _examResult . to (either id $ view passingGrade) . _Wrapped . to not
 
       sumPoints = fmap getSum . mconcat $ catMaybes
         [ Just $ foldMap (fmap Sum . examPartResultResult . entityVal) results
@@ -187,5 +187,5 @@ getEShowR tid ssh csh examn = do
       examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
 
       occurrenceMapping :: ExamOccurrenceName -> Maybe Widget
-      occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (fmap examOccurrenceMappingMapping examExamOccurrenceMapping >>= Map.lookup occName)
+      occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (examExamOccurrenceMapping >>= Map.lookup occName . examOccurrenceMappingMapping)
     $(widgetFile "exam-show")

src/Handler/Exam/Users.hs

@@ -598,7 +598,7 @@ postEUsersR tid ssh csh examn = do
                     tell =<< optionsF [ ExamUserDeregister, ExamUserAssignOccurrence ]
                     when (is _Just examGradingRule) $
                       tell =<< optionsF [ ExamUserAcceptComputedResult, ExamUserResetToComputedResult ]
-                    when (not $ null examParts) $
+                    unless (null examParts) $
                       tell =<< optionsF [ ExamUserSetPartResult ]
                     when doBonus $
                       tell =<< optionsF [ ExamUserSetBonus ]
@@ -652,7 +652,7 @@ postEUsersR tid ssh csh examn = do
                   (isPart, uid) <- lift $ guessUser' dbCsvNew
                   if
                     | isPart -> do
-                        yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew
+                        yieldM $ ExamUserCsvRegisterData uid <$> lookupOccurrence dbCsvNew
                         newFeatures <- lift $ lookupStudyFeatures dbCsvNew
                         Entity cpId CourseParticipant{ courseParticipantField = oldFeatures } <- lift . getJustBy $ UniqueParticipant uid examCourse
                         when (newFeatures /= oldFeatures) $
@@ -694,7 +694,7 @@ postEUsersR tid ssh csh examn = do
 
                   let newResults :: Maybe (Map ExamPartNumber ExamResultPoints)
                       newResults = sequence (csvEUserExamPartResults dbCsvNew)
-                               <|> sequence (toMapOf (resultExamParts .> ito (over _1 $ examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld)
+                               <|> sequence (toMapOf (resultExamParts .> ito (over _1 examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld)
 
                       newBonus, oldBonus :: Maybe Points
                       newBonus = join (csvEUserBonus dbCsvNew)

src/Handler/ExamOffice/Exams.hs

@@ -75,7 +75,7 @@ queryIsSynced now office = to . runReader $ do
       E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. externalExamId
       E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult
       E.where_ . E.not_ $ ExternalExam.resultIsSynced office externalExamResult
-    open examClosed' = E.maybe E.true (E.>. E.val now) $ examClosed'
+    open examClosed' = E.maybe E.true (E.>. E.val now) examClosed'
   return $ E.maybe E.false examSynchronised (exam' E.?. ExamId) E.||. E.maybe E.false open (exam' E.?. ExamClosed) E.||. E.maybe E.false externalExamSynchronised (externalExam' E.?. ExternalExamId)
 
 
@@ -150,11 +150,9 @@ getEOExamsR = do
 
             case (exam, course, externalExam) of
               (Just exam', Just course', Nothing) ->
-                (,,)
+                (Right (exam', course'),,) <$> view (_4 . _Value) <*> view (_5 . _Value)
-                  <$> pure (Right (exam', course')) <*> view (_4 . _Value) <*> view (_5 . _Value)
               (Nothing, Nothing, Just externalExam') ->
-                (,,)
+                (Left externalExam',,) <$> view (_4 . _Value) <*> view (_5 . _Value)
-                  <$> pure (Left externalExam') <*> view (_4 . _Value) <*> view (_5 . _Value)
               _other -> return $ error "Got exam & externalExam in same result"
 
 

src/Handler/ExamOffice/Fields.hs

@@ -78,7 +78,7 @@ postEOFieldsR = do
   oldFields <- runDB $ do
     fields <- E.select . E.from $ \examOfficeField -> do
       E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val uid
-      return $ (examOfficeField E.^. ExamOfficeFieldField, examOfficeField E.^. ExamOfficeFieldForced)
+      return (examOfficeField E.^. ExamOfficeFieldField, examOfficeField E.^. ExamOfficeFieldForced)
     return $ toMapOf (folded .> ito (over _1 E.unValue . over _2 E.unValue)) fields
 
   ((fieldsRes, fieldsView), fieldsEnc) <- runFormPost . makeExamOfficeFieldsForm uid $ Just oldFields

src/Handler/Info.hs

@@ -23,7 +23,7 @@ getVersionR = selectRep $ do
 -- | Datenschutzerklaerung und Aufbewahrungspflichten, Nutzungsbedingungen, Urheberrecht, Impressum
 getLegalR :: Handler Html
 getLegalR =
-  siteLayoutMsg' MsgMenuLegal $ do
+  siteLayoutMsg MsgMenuLegal $ do
     setTitleI MsgLegalHeading
     let dataProtection = $(i18nWidgetFile "data-protection")
         termsUse       = $(i18nWidgetFile "terms-of-use")
@@ -48,7 +48,7 @@ getInfoR = -- do
 
 getInfoLecturerR :: Handler Html
 getInfoLecturerR =
-  siteLayoutMsg' MsgInfoLecturerTitle $ do
+  siteLayoutMsg MsgInfoLecturerTitle $ do
     setTitleI MsgInfoLecturerTitle
     $(i18nWidgetFile "info-lecturer")
   where
@@ -76,7 +76,7 @@ getInfoLecturerR =
 
 getGlossaryR :: Handler Html
 getGlossaryR =
-  siteLayoutMsg' MsgGlossaryTitle $ do
+  siteLayoutMsg MsgGlossaryTitle $ do
     setTitleI MsgGlossaryTitle
     MsgRenderer mr <- getMsgRenderer
     let
@@ -137,7 +137,7 @@ faqsWidget mLimit route = do
 
 getFaqR :: Handler Html
 getFaqR =
-  siteLayoutMsg' MsgFaqTitle $ do
+  siteLayoutMsg MsgFaqTitle $ do
     setTitleI MsgFaqTitle
 
     fromMaybe mempty . view _1 =<< faqsWidget Nothing Nothing

src/Handler/Profile.hs

@@ -28,6 +28,8 @@ import qualified Data.CaseInsensitive as CI
 
 import Jobs
 
+import Foundation.Yesod.Auth (updateUserLanguage)
+
 
 data SettingsForm = SettingsForm
       { stgDisplayName          :: UserDisplayName

src/Handler/Sheet.hs

@@ -6,8 +6,6 @@ module Handler.Sheet
 
 import Import
 
-import Handler.Utils
-
 
 import Handler.Sheet.CorrectorInvite as Handler.Sheet (getSCorrInviteR, postSCorrInviteR)
 import Handler.Sheet.Delete as Handler.Sheet

src/Handler/Sheet/Current.hs

@@ -5,6 +5,7 @@ module Handler.Sheet.Current
 
 import Import
 
+import Handler.Utils
 import Utils.Sheet
 
 

src/Handler/Sheet/Edit.hs

@@ -86,7 +86,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
               , sheetAutoDistribute = sfAutoDistribute
               , sheetAnonymousCorrection = sfAnonymousCorrection
               , sheetRequireExamRegistration = sfRequireExamRegistration
-              , sheetAllowNonPersonalisedSubmission = fromMaybe True $ spffAllowNonPersonalisedSubmission <$> sfPersonalF
+              , sheetAllowNonPersonalisedSubmission = maybe True spffAllowNonPersonalisedSubmission sfPersonalF
               }
         mbsid <- dbAction newSheet
         case mbsid of
@@ -98,7 +98,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
             insertSheetFile' sid SheetMarking  $ fromMaybe (return ()) sfMarkingF
             runConduit $
                  maybe (return ()) (transPipe liftHandler) (spffFiles =<< sfPersonalF)
-              .| sinkPersonalisedSheetFiles cid sid (fromMaybe False $ spffFilesKeepExisting <$> sfPersonalF)
+              .| sinkPersonalisedSheetFiles cid sid (maybe False spffFilesKeepExisting sfPersonalF)
             insert_ $ SheetEdit aid actTime sid
             addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
             -- Sanity checks generating warnings only, but not errors!
@@ -127,7 +127,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
             return True
       when saveOkay $
         redirect $ CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
-    (FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml
+    (FormFailure msgs) -> forM_ msgs $ addMessage Error . toHtml
     _ -> runDB $ warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
             [(sfVisibleFrom  =<< template, MsgSheetVisibleFrom)
             ,(sfActiveFrom   =<< template, MsgSheetActiveFrom)

src/Handler/Sheet/Form.hs

@@ -97,7 +97,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
       <*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
       <*> aopt htmlField    (fslI MsgSheetMarking) (sfMarkingText <$> template)
       <*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template)
-      <*> correctorForm (fromMaybe mempty $ sfCorrectors <$> template)
+      <*> correctorForm (maybe mempty sfCorrectors template)
   where
     makeSheetPersonalisedFilesForm :: Maybe SheetPersonalisedFilesForm -> MForm Handler (AForm Handler SheetPersonalisedFilesForm)
     makeSheetPersonalisedFilesForm template' = do
@@ -162,7 +162,7 @@ correctorForm loads' = wFormToAForm $ do
     loads :: Map (Either UserEmail UserId) (CorrectorState, Load)
     loads = loads' <&> \(InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector) -> (cState, load)
 
-  countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads
+  countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> Just True == byTutorial) $ Map.elems loads
 
 
   let
@@ -173,7 +173,7 @@ correctorForm loads' = wFormToAForm $ do
       E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
       E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
       E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
-      E.orderBy $ [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
+      E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
       return user
 
     miAdd :: ListPosition
@@ -199,7 +199,7 @@ correctorForm loads' = wFormToAForm $ do
     miCell _ userIdent initRes nudge csrf = do
       (stateRes, stateView) <- mreq (selectField optionsFinite) (fslI MsgSheetCorrectorState & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal
       (byTutRes, byTutView) <- mreq checkBoxField ("" & addName (nudge "bytut")) $ (isJust . byTutorial . snd <$> initRes) <|> Just False
-      (propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fslI MsgSheetCorrectorProportion & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
+      (propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative rationalField) (fslI MsgSheetCorrectorProportion & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
       let
         res :: FormResult (CorrectorState, Load)
         res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)

src/Handler/Sheet/List.hs

@@ -69,7 +69,7 @@ getSheetListR tid ssh csh = do
       , sortable Nothing (i18nCell MsgSubmission)
           $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub, _)} -> case mbSub of
               Nothing -> mempty
-              (Just (Entity sid Submission{..})) ->
+              (Just (Entity sid Submission{})) ->
                 let mkCid = encrypt sid -- TODO: executed twice
                     mkRoute = do
                       cid' <- mkCid

src/Handler/StorageKey.hs

@@ -11,6 +11,8 @@ import qualified Data.ByteString.Base64 as Base64 (encode, decodeLenient)
 import qualified Data.Binary as Binary (encode)
 import qualified Crypto.KDF.HKDF as HKDF
 
+{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
+
 
 data StorageKeyType
   = SKTExamCorrect

src/Handler/Submission.hs

@@ -25,6 +25,8 @@ import Handler.Submission.Create
 import Handler.Submission.Grade
 import Handler.Submission.Upload
 
+import Handler.Utils
+
 
 import Import
 

src/Handler/Submission/Correction.hs

@@ -51,7 +51,7 @@ postCorrectionR tid ssh csh shn cid = do
   MsgRenderer mr <- getMsgRenderer
   case results of
     [(Entity cId Course{..}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector, E.Value filesCorrected)] -> do
-      let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
+      let ratingComment = submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) . Text.strip
           pointsForm = case sheetType of
             NotGraded
               -> pure Nothing

src/Handler/Submission/Helper.hs

@@ -104,7 +104,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
     submittorsForm' = maybeT submittorsForm $ do
       restr <- MaybeT (maybeCurrentBearerRestrictions @Value) >>= hoistMaybe . preview (_Object . ix "submittors" . _Array)
       let _Submittor = prism (either toJSON toJSON) $ \x -> first (const x) $ JSON.parseEither (\x' -> fmap Right (parseJSON x') <|> fmap Left (parseJSON x')) x
-      submittors <- fmap (pure @FormResult @([Either UserEmail CryptoUUIDUser])) . forM (toList restr) $ hoistMaybe . preview _Submittor
+      submittors <- fmap (pure @FormResult @[Either UserEmail CryptoUUIDUser]) . forM (toList restr) $ hoistMaybe . preview _Submittor
       fmap Set.fromList <$> forMOf (traverse . traverse . _Right) submittors decrypt
 
 
@@ -165,7 +165,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
             guard $ Map.size dat > 1
 
             -- User may drop from submission only if it already exists; no directly creating submissions for other people
-            guard $ maybe True (/= Right uid) (dat !? delPos) || isJust msmid
+            guard $ Just (Right uid) /= dat !? delPos || isJust msmid
 
             miDeleteList dat delPos
 
@@ -304,7 +304,7 @@ submissionHelper tid ssh csh shn mcid = do
                 return (userName, submissionEdit E.^. SubmissionEditTime)
               forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
 
-          corrector <- fmap join $ traverse getEntity submissionRatingBy
+          corrector <- join <$> traverse getEntity submissionRatingBy
 
           return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner,Just sub,corrector)
 

src/Handler/Submission/List.hs

@@ -122,7 +122,7 @@ colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnad
 colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(_, _, _, _, _, _, cid, _) } -> return cid
 
 colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, course, _, _, users, _, hasAccess) } ->
+colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, _, users, _, hasAccess) } ->
   let
     csh = course ^. _2
     tid = course ^. _3
@@ -136,8 +136,8 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB
         | otherwise -> mempty
 
 colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, (_, csh, tid, ssh), _, _, users, _, hasAccess) } ->
+colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, (_, csh, tid, ssh), _, _, users, _, hasAccess) } ->
-  let protoCell = listCell (Map.toList $ Map.mapMaybe (\x@(User{..}, _, _) -> (x,) <$> assertM (not . null) userMatrikelnummer) users) $ \(userId, ((User{..}, _, _), matr)) -> anchorCellCM $cacheIdentHere (CourseR tid ssh csh . CUserR <$> encrypt userId) matr 
+  let protoCell = listCell (Map.toList $ Map.mapMaybe (\x@(User{userMatrikelnummer}, _, _) -> (x,) <$> assertM (not . null) userMatrikelnummer) users) $ \(userId, (_, matr)) -> anchorCellCM $cacheIdentHere (CourseR tid ssh csh . CUserR <$> encrypt userId) matr 
   in if | hasAccess -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
         | otherwise -> mempty
 
@@ -193,7 +193,7 @@ colPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (
 colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
   (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
   (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _, _, _) } mkUnique -> case sheetType of
-      NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty)
+      NotGraded -> pure $ over (_1.mapped) (_2 .~) (FormSuccess Nothing, mempty)
       _other -> over (_1.mapped) (_2 .~) . over _2 fvWidget <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints)
   )
 
@@ -201,7 +201,7 @@ colMaxPointsField :: _ => Colonnade Sortable CorrectionTableData (DBCell m (Form
 colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ i18nCell . (\DBRow{ dbrOutput=(_, Entity _ Sheet{sheetType}, _, _, _, _, _, _) } -> sheetType)
 
 colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
-colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (cellAttrs <>~ [("style","width:60%")]) $ formCell id
+colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id
   (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
   (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
 
@@ -398,11 +398,11 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams
         , FilterProjected $ \(DBRow{..} :: CorrectionTableData) (criteria :: Set Text) ->
             let cid = map CI.mk . unpack . toPathPiece $ dbrOutput ^. _7
                 criteria' = map CI.mk . unpack <$> Set.toList criteria
-             in any (\c -> c `isInfixOf` cid) criteria'
+             in any (`isInfixOf` cid) criteria'
         )
       ]
     , dbtFilterUI  = fromMaybe mempty dbtFilterUI
-    , dbtStyle     = def { dbsFilterLayout = maybe (\_ _ _ -> id) (\_ -> defaultDBSFilterLayout) dbtFilterUI }
+    , dbtStyle     = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI }
     , dbtParams
     , dbtIdent     = "corrections" :: Text
     , dbtCsvEncode = noCsvEncode
@@ -465,8 +465,8 @@ correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do
     -- let statistics = gradeSummaryWidget MsgSubmissionGradingSummaryTitle gradingSummary
     -- return (tableRes, statistics)
 
-  let actionRes = actionRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
+  let actionRes = actionRes' <&> _2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
-                             & mapped._1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast
+                             <&> _1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast
       auditAllSubEdit = mapM_ $ \sId -> getJust sId >>= \sub -> audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet
 
   formResult actionRes $ \case
@@ -610,7 +610,7 @@ assignAction selId = ( CorrSetCorrector
 
                            E.where_ $ either (\cId -> course E.^. CourseId E.==. E.val cId) (\shId -> sheet E.^. SheetId E.==. E.val shId) selId
 
-                           E.orderBy $ [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
+                           E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
 
                            E.distinct $ return user
 

src/Handler/SystemMessage.hs

@@ -57,9 +57,8 @@ postMessageR cID = do
         runFormPost . identifyForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
           $ (,)
           <$> fmap (Entity tId)
-              ( SystemMessageTranslation
+              ( SystemMessageTranslation systemMessageTranslationMessage
-                  <$> pure systemMessageTranslationMessage
+                  <$> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageTranslationLanguage)
-                  <*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageTranslationLanguage)
                   <*> areq htmlField (fslI MsgSystemMessageContent) (Just systemMessageTranslationContent)
                   <*> aopt htmlField (fslI MsgSystemMessageSummary) (Just systemMessageTranslationSummary)
               )
@@ -71,9 +70,8 @@ postMessageR cID = do
             & filter (\l -> none (`langMatches` l) $ Map.keys ts')
 
       ((addTransRes, addTransView), addTransEnctype) <- runFormPost . identifyForm FIDSystemMessageAddTranslation . renderAForm FormStandard
-        $ SystemMessageTranslation
+        $ SystemMessageTranslation smId
-          <$> pure smId
+          <$> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (listToMaybe nextLang)
-          <*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (listToMaybe nextLang)
           <*> areq htmlField (fslI MsgSystemMessageContent) Nothing
           <*> aopt htmlField (fslI MsgSystemMessageSummary) Nothing
 

src/Handler/Tutorial/Form.hs

@@ -43,7 +43,7 @@ tutorialForm cid template html = do
           (addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser . Just $ tutUserSuggestions uid) (fslI MsgTutorEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
           let
             addRes'
-              | otherwise
+
               = addRes <&> \newDat oldDat -> if
                   | existing <- newDat `Set.intersection` Set.fromList oldDat
                   , not $ Set.null existing

src/Handler/Tutorial/List.hs

@@ -15,7 +15,7 @@ import qualified Data.CaseInsensitive as CI
 
 getCTutorialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCTutorialListR tid ssh csh = do
-  Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
+  cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
   MsgRenderer mr <- getMsgRenderer
 
   let

src/Handler/Tutorial/New.hs

@@ -16,7 +16,7 @@ import Handler.Tutorial.TutorInvite
 getCTutorialNewR, postCTutorialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCTutorialNewR = postCTutorialNewR
 postCTutorialNewR tid ssh csh = do
-  Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
+  cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
 
   ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing
 

src/Handler/Users.hs

@@ -74,7 +74,7 @@ getUsersR = postUsersR
 postUsersR = do
   MsgRenderer mr <- getMsgRenderer
   let
-    dbtColonnade = mconcat $
+    dbtColonnade = mconcat
       [ dbSelect (applying _2) id (return . view (_dbrOutput . _entityKey))
       , sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
           (AdminUserR <$> encrypt uid)
@@ -233,7 +233,7 @@ postUsersR = do
   formResult allUsersRes $ \case
     AllUsersLdapSync -> do
       runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
-      addMessageI Success $ MsgSynchroniseLdapAllUsersQueued
+      addMessageI Success MsgSynchroniseLdapAllUsersQueued
       redirect UsersR
   let allUsersWgt' = wrapForm allUsersWgt def
         { formSubmit = FormNoSubmit
@@ -569,7 +569,7 @@ functionInvitationConfig = InvitationConfig{..}
           itStartsAt = Nothing
       return InvitationTokenConfig{..}
     invitationRestriction _ _ = return Authorized
-    invitationForm _ (_, InvTokenDataUserFunction{..}) _ = pure $ (JunctionUserFunction invTokenUserFunctionFunction, ())
+    invitationForm _ (_, InvTokenDataUserFunction{..}) _ = pure (JunctionUserFunction invTokenUserFunctionFunction, ())
     invitationInsertHook _ _ _ _ _ = id
     invitationSuccessMsg (Entity _ School{..}) (Entity _ UserFunction{..}) = do
       MsgRenderer mr <- getMsgRenderer

src/Handler/Utils.hs

@@ -157,3 +157,21 @@ studyFeaturesWidget featId = do
 
 getShowSex :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
 getShowSex = maybe False (userShowSex . entityVal) <$> maybeAuth
+
+
+-- | Conditional redirect that hides the URL if the user is not authorized for the route
+redirectAccess :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
+redirectAccess url = liftHandler $ do
+  -- must hide URL if not authorized
+  access <- isAuthorized url False
+  case access of
+    Authorized -> redirect url
+    _          -> permissionDeniedI MsgUnauthorizedRedirect
+
+redirectAccessWith :: (MonadHandler m, HandlerSite m ~ UniWorX) => Status -> Route (HandlerSite m) -> m a
+redirectAccessWith status url = liftHandler $ do
+  -- must hide URL if not authorized
+  access <- isAuthorized url False
+  case access of
+    Authorized -> redirectWith status url
+    _          -> permissionDeniedI MsgUnauthorizedRedirect

src/Handler/Utils/Allocation.hs

@@ -19,7 +19,7 @@ import qualified Database.Esqueleto.Utils as E
 import Control.Monad.Trans.State (execStateT)
 import qualified Control.Monad.State.Class as State (get, modify')
 
-import Data.List (genericLength, elemIndex)
+import Data.List (genericLength)
 import qualified Data.Vector as Vector
 import Data.Vector.Lens (vector)
 import qualified Data.Set as Set
@@ -201,7 +201,7 @@ computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = d
           withNumericGrade :: Rational -> Rational
           withNumericGrade
             | Just grade' <- grade
-            = let numberGrade' = fromMaybe (error "non-passing grade") (fromIntegral <$> elemIndex grade' passingGrades) / pred (genericLength passingGrades)
+            = let numberGrade' = maybe (error "non-passing grade") fromIntegral (elemIndex grade' passingGrades) / pred (genericLength passingGrades)
                   passingGrades = sort $ filter (view $ passingGrade . _Wrapped) universeF
                   numericGrade = -gradeScale + numberGrade' * 2 * gradeScale
                in (+) numericGrade
@@ -244,7 +244,7 @@ doAllocation :: AllocationId
              -> DB ()
 doAllocation allocId now regs =
   forM_ regs $ \(uid, cid) -> do
-    mField <- (courseApplicationField . entityVal =<<) . listToMaybe <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] []
+    mField <- (courseApplicationField . entityVal <=< listToMaybe) <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] []
     void $ upsert
       (CourseParticipant cid uid now mField (Just allocId) CourseParticipantActive)
       [ CourseParticipantRegistration =. now

src/Handler/Utils/Csv.hs

@@ -151,7 +151,7 @@ encodeCsv hdr = do
         | otherwise
         = encodeLazyByteString enc . decodeLazyByteString UTF8
         where enc = csvOpts ^. _csvFormat . _csvEncoding
-  fmap (encodeByNameWith (csvOpts ^. _csvFormat . _CsvEncodeOptions) hdr) (C.foldMap pure) >>= C.sourceLazy . recode'
+  C.foldMap pure >>= (C.sourceLazy . recode') . encodeByNameWith (csvOpts ^. _csvFormat . _CsvEncodeOptions) hdr
 
 timestampCsv :: ( MonadHandler m
                 , HandlerSite m ~ UniWorX

src/Handler/Utils/DateTime.hs

@@ -175,7 +175,7 @@ validDateTimeFormats TimeLocale{..} SelFormatTime = Set.fromList . concat . catM
         ]
   , do
       guard $ uncurry (/=) amPm
-      guard $ any (any $ not . Char.isLower) [fst amPm, snd amPm]
+      guard . not $ all (all Char.isLower) [fst amPm, snd amPm]
       Just
         [ DateTimeFormat "%I:%M %P"
         , DateTimeFormat "%I:%M:%S %P"

src/Handler/Utils/Exam.hs

@@ -367,7 +367,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
         wordMap = Map.fromListWith (+) wordLengths
 
         wordIx :: Iso' wordId Int
-        wordIx = iso (\wId -> let Just ix' = findIndex (== wId) $ Array.elems collapsedWords
+        wordIx = iso (\wId -> let Just ix' = elemIndex wId $ Array.elems collapsedWords
                                in ix'
                      )
                      (collapsedWords Array.!)
@@ -477,7 +477,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
     bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])]
     bestOption = case rule of
       ExamRoomSurname -> do
-        (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` toListOf (_1 . folded . to CI.foldedCase)) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' lineNudges charCost
+        (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` (pack . toListOf (_1 . folded . to CI.foldedCase))) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' lineNudges charCost
         -- traceM $ show cost
         return res
       ExamRoomMatriculation -> do

src/Handler/Utils/Files.hs

@@ -34,7 +34,7 @@ sourceFile FileReference{..} = do
       -> maybeT (throwM SourceFilesContentUnavailable) $ do
         let uploadName = decodeUtf8 . Base64.encodeUnpadded $ ByteArray.convert fileContentHash
         uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket
-        fmap Just . (hoistMaybe =<<) . runAppMinio . runMaybeT $ do
+        fmap Just . hoistMaybe <=< runAppMinio . runMaybeT $ do
           objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket uploadName Minio.defaultGetObjectOptions
           lift . runConduit $ Minio.gorObjectStream objRes .| C.fold
     | fmap (fmap fileContentHash) mFileContent /= fmap Just fileReferenceContent

src/Handler/Utils/Form.hs

@@ -15,14 +15,12 @@ import Handler.Utils.Pandoc
 
 import Handler.Utils.DateTime
 
-import Handler.Utils.Widgets
-
 import Handler.Utils.I18n
 
 import Handler.Utils.Files
 
 import Import
-import Data.Char (chr, ord)
+import Data.Char ( chr, ord, isDigit )
 import qualified Data.Char as Char
 import qualified Data.Text as Text
 import qualified Data.CaseInsensitive as CI
@@ -55,8 +53,6 @@ import Data.Aeson.Text (encodeToLazyText)
 import qualified Text.Email.Validate as Email
 
 import Data.Text.Lens (unpacked)
-
-import Data.Char (isDigit)
 import Text.Blaze (toMarkup)
 
 import Handler.Utils.Form.MassInput
@@ -64,6 +60,8 @@ import Handler.Utils.Form.MassInput
 import qualified Data.Binary as Binary
 import qualified Data.ByteString.Base64.URL as Base64
 
+{-# ANN module ("HLint: ignore Use const" :: String) #-}
+
 
 ----------------------------
 -- Buttons (new version ) --
@@ -257,7 +255,7 @@ multiActionField :: forall action a.
                  -> FieldSettings UniWorX
                  -> Maybe action
                  -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
-multiActionField minp acts (actField, actExternal, actMessage) fs@FieldSettings{..} defAction csrf = do
+multiActionField minp acts (actField, actExternal, actMessage) fs defAction csrf = do
   (actionRes, actionView) <- minp (checkBool (`Map.member` acts) MsgMultiActionUnknownAction actField) fs defAction
   results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
 
@@ -285,15 +283,15 @@ multiActionOpts' :: forall action a.
                  -> FieldSettings UniWorX
                  -> Maybe action
                  -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
-multiActionOpts' minp acts mActsOpts fs@FieldSettings{..} defAction csrf = do
+multiActionOpts' minp acts mActsOpts fs defAction csrf = do
   actsOpts <- liftHandler mActsOpts
   let actsOpts' = OptionList
         { olOptions      = filter (flip Map.member acts . optionInternalValue) $ olOptions actsOpts
-        , olReadExternal = assertM (flip Map.member acts) . olReadExternal actsOpts
+        , olReadExternal = assertM (`Map.member` acts) . olReadExternal actsOpts
         }
       acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue) $ olOptions actsOpts') acts
 
-      actOption act = listToMaybe . filter (\Option{..} -> optionInternalValue == act) $ olOptions actsOpts'
+      actOption act = find (\Option{..} -> optionInternalValue == act) $ olOptions actsOpts'
       actExternal = fmap optionExternalValue . actOption
       actMessage = fmap (SomeMessage . optionDisplay) . actOption
 
@@ -397,13 +395,13 @@ explainedMultiAction' :: forall action a.
                       -> FieldSettings UniWorX
                       -> Maybe action
                       -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
-explainedMultiAction' minp acts mActsOpts fs@FieldSettings{..} defAction csrf = do
+explainedMultiAction' minp acts mActsOpts fs defAction csrf = do
   (actsOpts, actsReadExternal) <- liftHandler mActsOpts
   let actsOpts' = filter (flip Map.member acts . optionInternalValue . view _1) actsOpts
-      actsReadExternal' = assertM (flip Map.member acts) . actsReadExternal
+      actsReadExternal' = assertM (`Map.member` acts) . actsReadExternal
       acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue . view _1) actsOpts') acts
 
-      actOption act = listToMaybe . filter (\Option{..} -> optionInternalValue == act) $ view _1 <$> actsOpts'
+      actOption act = find (\Option{..} -> optionInternalValue == act) $ view _1 <$> actsOpts'
       actExternal = fmap optionExternalValue . actOption
       actMessage = fmap (SomeMessage . optionDisplay) . actOption
 
@@ -463,7 +461,7 @@ pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points
 pointsField = pointsFieldMinMax (Just 0) Nothing
 
 pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points
-pointsFieldMax limit = pointsFieldMinMax (Just 0) limit
+pointsFieldMax = pointsFieldMinMax (Just 0)
 
 pointsFieldMinMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Maybe Points -> Field m Points
 pointsFieldMinMax lower upper = checklower $ checkupper $ fixedPrecMinMaxField lower upper -- NOTE: fixedPrecMinMaxField uses HTML5 input attributes min & max for better browser supprt, but may not be supported by all browsers yet
@@ -795,7 +793,7 @@ examGradingRuleForm prev = multiActionA actions (fslI MsgExamGradingRule) $ clas
 
       let errors
             | anyOf (folded . _1 . _FormSuccess) (< 0) bounds = [mr MsgPointsMustBeNonNegative]
-            | FormSuccess bounds' <- sequence $ map (view _1) bounds
+            | FormSuccess bounds' <- mapM (view _1) bounds
             , not $ monotone bounds'
             = [mr MsgPointsMustBeMonotonic]
             | otherwise
@@ -967,7 +965,7 @@ genericFileField mkOpts = Field{..}
                      .| C.mapMaybe (\fTitle -> fmap (fTitle, ) . assertM (views _3 $ not . fieldOptionForce) $ Map.lookup fTitle permittedFiles)
                      .| C.filter (\(fTitle, _) ->
                                      fieldMultiple
-                                  || (    (bool (\n h -> h == pure n) elem fieldMultiple) fTitle (mapMaybe (preview _FileTitle) vals)
+                                  || (    bool (\n h -> h == pure n) elem fieldMultiple fTitle (mapMaybe (preview _FileTitle) vals)
                                        && null files
                                      )
                                  )
@@ -1091,7 +1089,7 @@ fileUploadForm isReq mkFs = \case
   UploadAny{..}
     -> bool aopt (\f fs _ -> Just <$> areq f fs Nothing) isReq (zipFileField unpackZips extensionRestriction) (mkFs unpackZips) Nothing
   UploadSpecific{..}
-    -> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles)
+    -> mergeFileSources <$> traverse specificFileForm (Set.toList $ toNullable specificFiles)
   where
     specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe FileUploads)
     specificFileForm spec@UploadSpecificFile{..}
@@ -1445,7 +1443,7 @@ examOccurrenceField :: ( MonadHandler m
                     => ExamId
                     -> Field m ExamOccurrenceId
 examOccurrenceField eid
-  = hoistField liftHandler . selectField . (fmap $ fmap entityKey)
+  = hoistField liftHandler . selectField . fmap (fmap entityKey)
     $ optionsPersistCryptoId [ ExamOccurrenceExam ==. eid ] [ Asc ExamOccurrenceName ] examOccurrenceName
 
 
@@ -1553,7 +1551,7 @@ multiUserField onlySuggested suggestions = Field{..}
       whenIsJust suggestions $ \suggestions' -> do
         suggestedEmails <- fmap (Map.assocs . Map.fromListWith min . map (over _2 E.unValue . over _1 E.unValue)) . liftHandler . runDB . E.select $ do
           user <- suggestions'
-          return $ ( E.case_
+          return ( E.case_
                        [ E.when_ (unique UserDisplayEmail user)
                          E.then_ (user E.^. UserDisplayEmail)
                        , E.when_ (unique UserEmail user)
@@ -1768,7 +1766,7 @@ examField :: forall m.
              , HandlerSite m ~ UniWorX
              )
           => Maybe (SomeMessage UniWorX) -> CourseId -> Field m ExamId
-examField optMsg cId = hoistField liftHandler . selectField' optMsg . (fmap $ fmap entityKey) $
+examField optMsg cId = hoistField liftHandler . selectField' optMsg . fmap (fmap entityKey) $
                   optionsPersistCryptoId [ExamCourse ==. cId] [Asc ExamName] examName
 
 

src/Handler/Utils/Form/MassInput.hs

@@ -37,6 +37,8 @@ import Text.Hamlet (hamletFile)
 
 import Algebra.Lattice.Ordered (Ordered(..))
 
+{-# ANN module ("HLint: ignore Use const" :: String) #-}
+
 
 $(mapM tupleBoxCoord [2..4])
 
@@ -149,7 +151,7 @@ instance (Liveliness l1, Liveliness l2) => Liveliness (MapLiveliness l1 l2) wher
     (\ts -> let ks = Set.mapMonotonic fst ts in fmap MapLiveliness . sequence $ Map.fromSet (\k -> preview liveCoords . Set.mapMonotonic snd $ Set.filter ((== k) . fst) ts) ks)
 
 
-type MassInputDelete liveliness = forall m a. Applicative m => Map (BoxCoord liveliness) a -> (BoxCoord liveliness) -> m (Map (BoxCoord liveliness) (BoxCoord liveliness))
+type MassInputDelete liveliness = forall m a. Applicative m => Map (BoxCoord liveliness) a -> BoxCoord liveliness -> m (Map (BoxCoord liveliness) (BoxCoord liveliness))
 
 
 miDeleteList :: MassInputDelete ListLength
@@ -330,9 +332,9 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
                   guard $ isn't _FormMissing btnRes
                   res
                 miAdd' = traverse ($ mempty) $ miAdd miCoord dimIx nudgeAddWidgetName btnView
-            addRes'' <- miAdd' & mapped . _Just . _1 %~ wBtnRes
+            addRes'' <- miAdd' <&> (_Just . _1) %~ wBtnRes
             addRes' <- fmap join . for addRes'' $ bool (return . Just) (\(res, _view) -> set (_Just . _1) res <$> local (set _1 Nothing) miAdd') (is (_Just . _FormSuccess) (fst <$> addRes'') || is _FormMissing btnRes)
-            let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just) $ fmap fst addRes', fmap snd addRes')
+            let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just . fst) addRes', fmap snd addRes')
             case remDims of
               [] -> return dimRes'
               ((_, BoxDimension dim) : _) -> do
@@ -373,7 +375,7 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
     delShapeUpdate
         | [FormSuccess shapeUpdate'] <- Map.elems . Map.filter (is _FormSuccess) $ fmap fst delResults = Just shapeUpdate'
         | otherwise = Nothing
-    delShape = traverse (flip Map.lookup addedShape) =<< delShapeUpdate
+    delShape = traverse (`Map.lookup` addedShape) =<< delShapeUpdate
 
 
   let shapeChanged = Fold.any (isn't _FormMissing . view _1) addResults || Fold.any (is _FormSuccess . view _1) delResults
@@ -490,7 +492,7 @@ massInputList :: forall handler cellResult ident msg.
               -> (Markup -> MForm handler (FormResult [cellResult], FieldView UniWorX))
 massInputList field fieldSettings onMissing miButtonAction miIdent miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput
   MassInput { miAdd = \_ _ _ submitBtn -> Just $ \csrf ->
-                return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax pRes) (), toWidget csrf >> fvWidget submitBtn)
+                return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 (succ . fst) $ Map.lookupMax pRes) (), toWidget csrf >> fvWidget submitBtn)
             , miCell = \pos () iRes nudge csrf ->
                 over _2 (\fv -> $(widgetFile "widgets/massinput/list/cell")) <$> mreqMsg field (fieldSettings pos & addName (nudge "field")) onMissing iRes
             , miDelete = miDeleteList
@@ -544,7 +546,7 @@ massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequire
     miAdd :: ListPosition -> Natural
           -> (Text -> Text) -> FieldView UniWorX
           -> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
-    miAdd _pos _dim nudge submitView = Just $ \csrf' -> over (_1 . mapped) doAdd <$> miAdd' nudge submitView csrf'
+    miAdd _pos _dim nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)
 
     doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
     doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
@@ -622,7 +624,7 @@ massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fReq
     miAdd :: ListPosition -> Natural
           -> (Text -> Text) -> FieldView UniWorX
           -> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
-    miAdd _pos _dim nudge submitView = Just $ \csrf' -> over (_1 . mapped) doAdd <$> miAdd' nudge submitView csrf'
+    miAdd _pos _dim nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)
 
     doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
     doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems

src/Handler/Utils/Form/MassInput/Liveliness.hs

@@ -6,6 +6,7 @@ module Handler.Utils.Form.MassInput.Liveliness
   ) where
 
 import ClassyPrelude
+import Data.Kind (Type)
 
 import Web.PathPieces (PathPiece)
 import Data.Aeson (ToJSON, FromJSON, ToJSONKey, FromJSONKey)
@@ -38,7 +39,7 @@ boxDimension n
 -- zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim
 
 class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where
-  type BoxCoord a :: *
+  type BoxCoord a :: Type
   liveCoords :: Prism' (Set (BoxCoord a)) a
   liveCoord :: BoxCoord a -> Prism' Bool a
   liveCoord bC = prism' (\l -> bC `Set.member` review liveCoords l) (bool (Just bottom) (preview liveCoords $ Set.singleton bC))

src/Handler/Utils/Form/MassInput/TH.hs

@@ -30,7 +30,7 @@ tupleBoxCoord tupleDim = do
 
   instanceD tCxt ([t|IsBoxCoord|] `appT` tupleType)
     [ funD 'boxDimensions
-      [ clause [] (normalB . foldr1 (\ds1 ds2 -> [e|(++)|] `appE` ds1 `appE` ds2) . map (\field -> [e|map (\(BoxDimension dim) -> BoxDimension $ $(field) . dim) boxDimensions|]) $ map (fieldLenses !!) [0..pred tupleDim]) []
+      [ clause [] (normalB . foldr1 (\ds1 ds2 -> [e|(++)|] `appE` ds1 `appE` ds2) $ map (\field -> [e|map (\(BoxDimension dim) -> BoxDimension $ $(fieldLenses !! field) . dim) boxDimensions|]) [0..pred tupleDim]) []
       ]
     , funD 'boxOrigin
       [ clause [] (normalB . tupE $ replicate tupleDim [e|boxOrigin|]) []

src/Handler/Utils/I18n.hs

@@ -58,7 +58,7 @@ i18nWidgetFilesAvailable' basename = do
   let fileKinds' = fmap (pack . dropExtension . takeBaseName &&& toTranslation . pack . takeBaseName) availableFiles
       fileKinds :: Map Text [Text]
       fileKinds = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . Set.toList <$> Map.fromListWith Set.union [ (kind, Set.singleton l) | (kind, Just l) <- fileKinds' ]
-      toTranslation fName = listToMaybe . sortOn length . mapMaybe (flip Text.stripPrefix fName . (<>".")) $ map fst fileKinds'
+      toTranslation fName = (listToMaybe . sortOn length) (mapMaybe ((flip Text.stripPrefix fName . (<>".")) . fst) fileKinds')
 
   iforM fileKinds $ \kind -> maybe (fail $ "‘" <> i18nDirectory <> "’ has no translations for ‘" <> unpack kind <> "’") return . NonEmpty.nonEmpty
 

src/Handler/Utils/Invitations.hs

@@ -44,19 +44,19 @@ class ( PersistRecordBackend junction (YesodPersistBackend UniWorX)
       , Typeable junction
       ) => IsInvitableJunction junction where
   -- | One side of the junction is always `User`; `InvitationFor junction` is the other
-  type InvitationFor       junction :: *
+  type InvitationFor       junction :: Type
   -- | `junction` without `Key User` and `Key (InvitationFor junction)`
-  data InvitableJunction   junction :: *
+  data InvitableJunction   junction :: Type
 
   -- | `InvitationData` is all data associated with an invitation except for the `UserEmail` and `InvitationFor junction`
   --
   -- Note that this is only the data associated with the invitation; some user input might still be required to construct `InvitableJunction junction`
-  type InvitationData      junction = (dat :: *) | dat -> junction
+  type InvitationData      junction = (dat :: Type) | dat -> junction
   type InvitationData      junction = (InvitationDBData junction, InvitationTokenData junction)
   -- | `InvitationDBData` is the part of `InvitationData` that is stored confidentially in the database
-  data InvitationDBData    junction :: *
+  data InvitationDBData    junction :: Type
   -- | `InvitationTokenData` is the part of `InvitationData` that is stored readably within the token
-  data InvitationTokenData junction :: *
+  data InvitationTokenData junction :: Type
 
   _InvitableJunction :: Iso' junction (UserId, Key (InvitationFor junction), InvitableJunction junction)
 
@@ -274,7 +274,7 @@ sourceInvitations :: forall junction m backend.
                   -> ConduitT () (UserEmail, InvitationDBData junction) (ReaderT backend m) ()
 sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode
   where
-    decode (Entity _ (Invitation{invitationEmail, invitationData}))
+    decode (Entity _ Invitation{invitationEmail, invitationData})
       = case fromJSON invitationData of
           JSON.Success dbData -> return (invitationEmail, dbData)
           JSON.Error   str    -> throwM . PersistMarshalError . pack $ "Could not decode invitationData: " <> str

src/Handler/Utils/Memcached.hs

@@ -30,7 +30,7 @@ import Crypto.Hash.Algorithms (SHAKE256)
 
 import qualified Data.ByteArray as BA
 
-import Language.Haskell.TH
+import Language.Haskell.TH hiding (Type)
 
 import Data.Typeable (typeRep)
 import Type.Reflection (typeOf, TypeRep)
@@ -52,7 +52,7 @@ import qualified Crypto.Saltine.Core.AEAD as AEAD
 import qualified Control.Monad.State.Class as State
 
 
-type Expiry = (Either UTCTime DiffTime)
+type Expiry = Either UTCTime DiffTime
 
 _MemcachedExpiry :: Prism' Expiry Memcached.Expiry
 _MemcachedExpiry = prism' fromExpiry toExpiry
@@ -169,7 +169,7 @@ memcachedSet :: ( MonadHandler m, HandlerSite m ~ UniWorX
              => Maybe Expiry -> a -> m ()
 memcachedSet mExp = memcachedBySet mExp () . MemcachedUnkeyed
 
-memcachedInvalidate :: forall (a :: *) m p.
+memcachedInvalidate :: forall (a :: Type) m p.
                        ( MonadHandler m, HandlerSite m ~ UniWorX
                        , Typeable a
                        )
@@ -389,9 +389,9 @@ liftAsyncTimeout dt (hashableDynamic -> cK) act = ifNotM memcachedAvailable (lif
       Nothing -> do
         startAct <- liftIO newEmptyTMVarIO
         act' <- async $ do
-          $logDebugS "liftAsyncTimeout" $ "Waiting for confirmation..."
+          $logDebugS "liftAsyncTimeout" "Waiting for confirmation..."
           atomically $ takeTMVar startAct
-          $logDebugS "liftAsyncTimeout" $ "Confirmed."
+          $logDebugS "liftAsyncTimeout" "Confirmed."
           act
         act'' <- atomically $ do
           hm <- readTVar memcachedAsync

src/Handler/Utils/Rating.hs

@@ -31,7 +31,7 @@ import qualified Data.Char as Char
 
 
 validateRating :: SheetType -> Rating' -> [RatingValidityException]
-validateRating ratingSheetType Rating'{ ratingPoints=Just rp, .. }
+validateRating ratingSheetType Rating'{ ratingPoints=Just rp }
   | rp < 0
     = [RatingNegative]
   | NotGraded <- ratingSheetType
@@ -93,7 +93,7 @@ ratingFile :: ( MonadHandler m
               , HandlerSite m ~ UniWorX
               )
            => CryptoFileNameSubmission -> Rating -> m File
-ratingFile cID rating@Rating{ ratingValues = Rating'{..}, .. } = do
+ratingFile cID rating@Rating{ ratingValues = Rating'{..} } = do
   mr'@(MsgRenderer mr) <- getMsgRenderer
   dtFmt <- getDateTimeFormatter
   fileModified <- maybe (liftIO getCurrentTime) return ratingTime

src/Handler/Utils/Rating/Format.hs

@@ -29,8 +29,6 @@ import qualified Data.YAML.Event as YAML.Event
 import qualified Data.YAML.Token as YAML (Encoding(..))
 import Data.YAML.Aeson () -- ToYAML Value
 
-import Data.List (elemIndex)
-
 import Control.Monad.Trans.State.Lazy (evalState)
 
 import qualified System.FilePath.Cryptographic as Explicit

src/Handler/Utils/Submission.hs

@@ -169,7 +169,7 @@ planSubmissions sid restriction = do
       targetSubmissionData = set _1 Nothing <$> Map.restrictKeys submissionData targetSubmissions
       oldSubmissionData    = Map.withoutKeys submissionData targetSubmissions
 
-    whenIsJust (fromNullable =<< fmap (`Set.difference` targetSubmissions) restriction) $ \missing ->
+    whenIsJust (fromNullable . (`Set.difference` targetSubmissions) =<< restriction) $ \missing ->
       throwM $ SubmissionsNotFound missing
 
     let
@@ -236,7 +236,7 @@ planSubmissions sid restriction = do
             | otherwise
             = Map.keysSet $ Map.filter (views _byProportion (/= 0)) sheetCorrectors
 
-      when (not $ null acceptableCorrectors) $ do
+      unless (null acceptableCorrectors) $ do
         deficits <- sequence . flip Map.fromSet acceptableCorrectors $ withSubmissionData . calculateDeficit
         let
           bestCorrectors :: Set UserId
@@ -320,7 +320,7 @@ submissionMultiArchive anonymous (Set.toList -> ids) = do
   respondSource typeZip . (<* lift cleanup) . transPipe (runDBRunner dbrunner) $ do
     let
       fileEntitySource' :: (Rating, Entity Submission, Maybe UTCTime, (SheetName,CourseShorthand,SchoolId,TermId,Bool)) -> ConduitT () File (YesodDB UniWorX) ()
-      fileEntitySource' (rating, Entity submissionID Submission{..}, subTime, (shn,csh,ssh,tid,sheetAnonymous)) = do
+      fileEntitySource' (rating, Entity submissionID Submission{}, subTime, (shn,csh,ssh,tid,sheetAnonymous)) = do
         cID <- encrypt submissionID
 
         let
@@ -574,7 +574,7 @@ sinkSubmission userId mExists isUpdate = do
     sinkSubmission' :: SubmissionId
                     -> ConduitT SubmissionContent Void (YesodJobDB UniWorX) ()
     sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
-      Left file@(FileReference{..}) -> do
+      Left file@FileReference{..} -> do
         $logDebugS "sinkSubmission" . tshow $ (submissionId, fileReferenceTitle)
 
         alreadySeen <- gets (Set.member fileReferenceTitle . sinkFilenames)
@@ -591,7 +591,7 @@ sinkSubmission userId mExists isUpdate = do
                                  , submissionFileIsUpdate sf == isUpdate
                                  ]
             underlyingFiles = [ t | t@(Entity _ sf) <- otherVersions
-                                  , submissionFileIsUpdate sf == False
+                                  , not (submissionFileIsUpdate sf)
                                   ]
             anyChanges
               | not (null collidingFiles)  = any (/~ file) [ view (_FileReference . _1) sf | Entity _ sf <- collidingFiles ]
@@ -658,7 +658,7 @@ sinkSubmission userId mExists isUpdate = do
         --
         -- 'fileModified' is simply stored and never inspected while
         -- 'submissionChanged' is always set to @now@.
-        let anyChanges = any (\f -> f submission submission') $
+        let anyChanges = any (\f -> f submission submission')
               [ (/=) `on` submissionRatingPoints
               , (/=) `on` submissionRatingComment
               , (/=) `on` submissionRatingDone
@@ -675,7 +675,7 @@ sinkSubmission userId mExists isUpdate = do
           when (submissionRatingDone submission' && not (submissionRatingDone submission)) $
             tellSt mempty { sinkSubmissionNotifyRating = Any True }
           lift $ replace submissionId submission'
-          sheetId <- lift $ getSheetId
+          sheetId <- lift getSheetId
           lift $ audit $ TransactionSubmissionEdit submissionId sheetId
       where
         a /~ b = not $ a ~~ b
@@ -699,14 +699,14 @@ sinkSubmission userId mExists isUpdate = do
         touchSubmission :: StateT SubmissionSinkState (YesodJobDB UniWorX) ()
         touchSubmission = do
           alreadyTouched <- gets $ getAny . sinkSubmissionTouched
-          when (not alreadyTouched) $ do
+          unless alreadyTouched $ do
             now <- liftIO getCurrentTime
-            case isUpdate of
+            if
-              False -> lift . insert_ $ SubmissionEdit userId now submissionId
+              | isUpdate -> do
-              True  -> do
+                  Submission{submissionRatingTime} <- lift $ getJust submissionId
-                Submission{submissionRatingTime} <- lift $ getJust submissionId
+                  when (is _Just submissionRatingTime) $
-                when (is _Just submissionRatingTime) $
+                    lift $ update submissionId [ SubmissionRatingTime =. Just now ]
-                  lift $ update submissionId [ SubmissionRatingTime =. Just now ]
+              | otherwise -> lift . insert_ $ SubmissionEdit userId now submissionId
             tellSt $ mempty{ sinkSubmissionTouched = Any True }
 
         getSheetId :: MonadIO m => ReaderT SqlBackend m SheetId
@@ -720,15 +720,36 @@ sinkSubmission userId mExists isUpdate = do
         finalize SubmissionSinkState{..} = do
           missingFiles <- E.select . E.from $ \sf -> E.distinctOnOrderBy [E.asc $ sf E.^. SubmissionFileTitle] $ do
             E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
-            when (not isUpdate) $
+            unless isUpdate $
               E.where_ . E.not_ $ sf E.^. SubmissionFileIsUpdate
             E.where_ $ sf E.^. SubmissionFileTitle `E.notIn` E.valList (Set.toList sinkFilenames)
             E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
 
             return sf
 
-          case isUpdate of
+          if
-            False -> do
+            | isUpdate -> forM_ missingFiles $ \(Entity sfId SubmissionFile{..}) -> do
+                shadowing <- existsBy $ UniqueSubmissionFile submissionFileSubmission submissionFileTitle False
+
+                if
+                  | not shadowing -> do
+                      delete sfId
+                      audit $ TransactionSubmissionFileDelete sfId submissionId
+                  | submissionFileIsUpdate -> do
+                      update sfId [ SubmissionFileContent =. Nothing, SubmissionFileIsDeletion =. True ]
+                      audit $ TransactionSubmissionFileEdit sfId submissionId
+                  | otherwise -> do
+                      now <- liftIO getCurrentTime
+                      sfId' <- insert $ SubmissionFile
+                        { submissionFileSubmission = submissionId
+                        , submissionFileTitle
+                        , submissionFileModified = now
+                        , submissionFileContent = Nothing
+                        , submissionFileIsUpdate = True
+                        , submissionFileIsDeletion = True
+                        }
+                      audit $ TransactionSubmissionFileEdit sfId' submissionId
+            | otherwise -> do
               shadowed <- selectKeysList
                 [ SubmissionFileSubmission ==. submissionId
                 , SubmissionFileIsUpdate ==. False
@@ -737,27 +758,6 @@ sinkSubmission userId mExists isUpdate = do
               forM_ shadowed $ \sfId' -> do
                 delete sfId'
                 audit $ TransactionSubmissionFileDelete sfId' submissionId
-            True  -> forM_ missingFiles $ \(Entity sfId SubmissionFile{..}) -> do
-              shadowing <- existsBy $ UniqueSubmissionFile submissionFileSubmission submissionFileTitle False
-
-              if
-                | not shadowing -> do
-                    delete sfId
-                    audit $ TransactionSubmissionFileDelete sfId submissionId
-                | submissionFileIsUpdate -> do
-                    update sfId [ SubmissionFileContent =. Nothing, SubmissionFileIsDeletion =. True ]
-                    audit $ TransactionSubmissionFileEdit sfId submissionId
-                | otherwise -> do
-                    now <- liftIO getCurrentTime
-                    sfId' <- insert $ SubmissionFile
-                      { submissionFileSubmission = submissionId
-                      , submissionFileTitle
-                      , submissionFileModified = now
-                      , submissionFileContent = Nothing
-                      , submissionFileIsUpdate = True
-                      , submissionFileIsDeletion = True
-                      }
-                    audit $ TransactionSubmissionFileEdit sfId' submissionId
 
           if
             | isUpdate
@@ -833,7 +833,7 @@ sinkMultiSubmission userId isUpdate = do
               | otherwise = return Nothing
           Dual (Alt msId) <- lift . flip foldMapM segments' $ \seg -> Dual . Alt <$> lift (tryDecrypt seg) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileReferenceTitle) ]
           return (msId, fp)
-      (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileReferenceTitle
+      (msId, joinPath -> fileTitle') <- foldM acc (Nothing, []) $ splitDirectories fileReferenceTitle
       case msId of
         Nothing -> do
           $logDebugS "sinkMultiSubmission" $ "Dropping " <> tshow (splitDirectories fileReferenceTitle, msId, fileTitle')
@@ -842,7 +842,7 @@ sinkMultiSubmission userId isUpdate = do
           cID <- encrypt sId
           lift . handle (throwM . SubmissionSinkException cID (Just fileReferenceTitle)) $
             feed sId $ Left f{ fileReferenceTitle = fileTitle' }
-  when (not $ null ignoredFiles) $ do
+  unless (null ignoredFiles) $ do
     mr <- (toHtml .) <$> getMessageRender
     addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
   lift . fmap Set.fromList . forM (Map.toList sinks) $ \(sId, sink) -> do
@@ -903,7 +903,7 @@ submissionDeleteRoute drRecords = DeleteRoute
           uid <- maybeAuthId
           subUsers <- selectList [SubmissionUserSubmission ==. subId] []
           if
-            | length subUsers >= 1
+            | not $ null subUsers
             , maybe True (flip any subUsers . (. submissionUserUser . entityVal) . (/=)) uid
               -> Just <$> messageI Warning (MsgSubmissionDeleteCosubmittorsWarning $ length infos)
             | otherwise

src/Handler/Utils/Table/Columns.hs

@@ -302,8 +302,8 @@ sortCourseName queryName = singletonMap "course-name" . SortColumn $ view queryN
 colApplicationId :: OpticColonnade CourseApplicationId
 colApplicationId resultId = Colonnade.singleton (fromSortable header) body
   where
-    header = Sortable Nothing (i18nCell MsgCourseApplicationId)
+    header = Sortable Nothing $ i18nCell MsgCourseApplicationId
-    body = views resultId $ cell . (toWidget . toMarkup =<<) . (encrypt :: CourseApplicationId -> WidgetFor UniWorX CryptoFileNameCourseApplication)
+    body = views resultId $ \aId -> cell $ toWidget . toMarkup =<< (encrypt :: CourseApplicationId -> WidgetFor UniWorX CryptoFileNameCourseApplication) aId
 
 colApplicationRatingPoints :: OpticColonnade (Maybe ExamGrade)
 colApplicationRatingPoints resultPoints = Colonnade.singleton (fromSortable header) body

src/Handler/Utils/Table/Pagination.hs

@@ -54,7 +54,6 @@ import Handler.Utils.Form
 import Handler.Utils.Csv
 import Handler.Utils.ContentDisposition
 import Handler.Utils.I18n
-import Handler.Utils.Widgets
 import Utils
 import Utils.Lens
 
@@ -92,7 +91,7 @@ import Colonnade.Encode hiding (row)
 
 import Text.Hamlet (hamletFile)
 
-import Data.List (elemIndex, inits)
+import Data.List (inits)
 
 import Data.Maybe (fromJust)
 
@@ -450,7 +449,7 @@ instance Traversable DBRow where
 newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) }
 
 instance Default (PSValidator m x) where
-  def = PSValidator $ \DBTable{..} -> \case
+  def = PSValidator $ \DBTable{} -> \case
     Nothing -> def
     Just pi -> swap . (\act -> execRWS act pi def) $ do
       asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s })
@@ -665,12 +664,12 @@ simpleCsvEncodeM fName f = Just DBTCsvEncode
   }
 
 
-class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: * -> *) (x :: *) where
+class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: Type -> Type) (x :: Type) where
-  data DBParams m x :: *
+  data DBParams m x :: Type
-  type DBResult m x :: *
+  type DBResult m x :: Type
-  -- type DBResult' m x :: *
+  -- type DBResult' m x :: Type
 
-  data DBCell m x :: *
+  data DBCell m x :: Type
   dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget)
 
   -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)

src/Handler/Utils/Users.hs

@@ -10,6 +10,7 @@ module Handler.Utils.Users
 
 import Import
 import Auth.LDAP (campusUserMatr')
+import Foundation.Yesod.Auth (upsertCampusUser)
 
 import Crypto.Hash (hashlazy)
 
@@ -156,14 +157,14 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
       
       if
         | x : [] <- users'
-        , fromMaybe False (matchesMatriculation x) || didLdap
+        , Just True == matchesMatriculation x || didLdap
           -> return $ Just $ Right x
         | x : x' : _ <- users'
-        , fromMaybe False (matchesMatriculation x) || didLdap
+        , Just True == matchesMatriculation x || didLdap
         , GT <- x `closeness` x'
           -> return $ Just $ Right x
         | xs@(x:_:_) <- takeClosest users'
-        , fromMaybe False (matchesMatriculation x) || didLdap
+        , Just True == matchesMatriculation x || didLdap
           -> return $ Just $ Left $ NonEmpty.fromList xs
         | not didLdap
         , userMatrs <- (Set.toList . Set.fromList . catMaybes) $ getTermMatr <$> criteria

src/Handler/Utils/Widgets.hs

@@ -148,12 +148,6 @@ invDualCoHeat :: ( Real a, Real b, Real c )
 -- ^ Distinguishes @full@, zero is mapped to 2, @optimal@ is mapped to 1, @full@ is mapped to 0
 invDualCoHeat optimal full achieved = 2 - dualCoHeat optimal full achieved
 
-i18n :: forall m msg.
-        ( MonadWidget m
-        , RenderMessage (HandlerSite m) msg
-        ) => msg -> m ()
-i18n = toWidget . (SomeMessage :: msg -> SomeMessage (HandlerSite m))
-
 
 examOccurrenceMappingDescriptionWidget :: ExamOccurrenceRule -> Set ExamOccurrenceMappingDescription -> Widget
 examOccurrenceMappingDescriptionWidget rule descriptions = $(widgetFile "widgets/exam-occurrence-mapping-description")

src/Import/NoModel.hs

@@ -39,6 +39,7 @@ import Utils                  as Import
 import Utils.Frontend.I18n    as Import
 import Utils.DB               as Import
 import Utils.Sql              as Import
+import Utils.Widgets          as Import
 
 import Data.Fixed             as Import
 
@@ -60,6 +61,7 @@ import GHC.Exts               as Import (IsList)
 import Data.Ix                as Import (Ix)
 
 import Data.Hashable          as Import
+import Data.List              as Import (elemIndex)
 import Data.List.NonEmpty     as Import (NonEmpty(..), nonEmpty)
 import Data.Text.Encoding.Error as Import(UnicodeException(..))
 import Data.Semigroup         as Import (Min(..), Max(..))
@@ -78,6 +80,8 @@ import Database.Persist.Sql as Import (SqlReadBackend, SqlReadT, SqlWriteT, IsSq
 
 import Ldap.Client.Pool as Import
 
+import Control.Monad as Import (zipWithM)
+
 import System.Random as Import (Random(..))
 import Control.Monad.Random.Class as Import (MonadRandom(..))
 
@@ -167,6 +171,7 @@ import Network.Minio.Instances as Import ()
 import System.Clock.Instances as Import ()
 import Data.Word.Word24.Instances as Import ()
 import Control.Monad.Trans.Memo.StateCache.Instances as Import (hoistStateCache)
+import Database.Persist.Sql.Types.Instances as Import ()
 
 import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512)
 import Crypto.Random as Import (ChaChaDRG, Seed)
@@ -189,6 +194,8 @@ import GHC.TypeLits as Import (KnownSymbol)
 
 import Data.Word.Word24 as Import
 
+import Data.Kind as Import (Type, Constraint)
+
 
 import Control.Monad.Trans.RWS (RWST)
 

src/Jobs.hs

@@ -493,7 +493,7 @@ jLocked jId act = do
       liftIO . atomically $ writeTVar hasLock True
       return val
 
-    unlock = whenM (liftIO . atomically $ readTVar hasLock) $
+    unlock = whenM (readTVarIO hasLock) $
       runDB . setSerializable $
         update jId [ QueuedJobLockInstance =. Nothing
                    , QueuedJobLockTime =. Nothing

src/Jobs/Crontab.hs

@@ -27,7 +27,7 @@ import qualified Database.Esqueleto as E
 determineCrontab :: DB (Crontab JobCtl)
 -- ^ Extract all future jobs from the database (sheet deadlines, ...)
 determineCrontab = execWriterT $ do
-  UniWorX{ appSettings' = AppSettings{..}, .. } <- getYesod
+  UniWorX{ appSettings' = AppSettings{..} } <- getYesod
 
   case appJobFlushInterval of
     Just interval -> tell $ HashMap.singleton
@@ -354,7 +354,7 @@ determineCrontab = execWriterT $ do
 
 
   let
-    externalExamJobs (Entity nExternalExam ExternalExam{..}) = do
+    externalExamJobs nExternalExam = do
       newestResult <- lift . E.select . E.from $ \externalExamResult -> do
         E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. E.val nExternalExam
         return . E.max_ $ externalExamResult E.^. ExternalExamResultLastChanged
@@ -371,7 +371,7 @@ determineCrontab = execWriterT $ do
               }
         _other -> return ()
 
-  runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ externalExamJobs
+  runConduit $ transPipe lift (selectKeys [] []) .| C.mapM_ externalExamJobs
 
   let
     allocationJobs (Entity nAllocation Allocation{..}) = do

src/Jobs/Handler/SendNotification/SubmissionEdited.hs

@@ -20,7 +20,7 @@ import qualified Data.Text as Text
 
 dispatchNotificationSubmissionEdited :: UserId -> SubmissionId -> UserId -> Handler ()
 dispatchNotificationSubmissionEdited nInitiator nSubmission jRecipient = userMailT jRecipient $ do
-  (Course{..}, Sheet{..}, Submission{..}, initiator, coSubmittors) <- liftHandler . runDB $ do
+  (Course{..}, Sheet{..}, Submission{}, initiator, coSubmittors) <- liftHandler . runDB $ do
     submission <- getJust nSubmission
     sheet <- belongsToJust submissionSheet submission
     course <- belongsToJust sheetCourse sheet
@@ -55,7 +55,7 @@ dispatchNotificationSubmissionEdited nInitiator nSubmission jRecipient = userMai
 
 dispatchNotificationSubmissionUserCreated :: UserId -> SubmissionId -> UserId -> Handler ()
 dispatchNotificationSubmissionUserCreated nUser nSubmission jRecipient = userMailT jRecipient $ do
-  (User{..}, Course{..}, Sheet{..}, Submission{..}, coSubmittors) <- liftHandler . runDB $ do
+  (User{..}, Course{..}, Sheet{..}, Submission{}, coSubmittors) <- liftHandler . runDB $ do
     submission <- getJust nSubmission
     sheet <- belongsToJust submissionSheet submission
     course <- belongsToJust sheetCourse sheet

src/Jobs/Handler/SynchroniseLdap.hs

@@ -8,6 +8,7 @@ import Import
 import qualified Data.Conduit.List as C
 
 import Auth.LDAP
+import Foundation.Yesod.Auth (CampusUserConversionException, upsertCampusUser)
 
 import Jobs.Queue
 
@@ -38,7 +39,7 @@ dispatchJobSynchroniseLdap numIterations epoch iteration
 
 dispatchJobSynchroniseLdapUser :: UserId -> JobHandler UniWorX
 dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do
-  UniWorX{ appSettings' = AppSettings{..}, .. } <- getYesod
+  UniWorX{..} <- getYesod
   case appLdapPool of
     Just ldapPool ->
       runDB . void . runMaybeT . handleExc $ do

src/Mail.hs

@@ -38,6 +38,8 @@ module Mail
 
 import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON)
 
+import Data.Kind (Type)
+
 import Model.Types.Languages
 
 import Network.Mail.Mime hiding (addPart, addAttachment)
@@ -231,7 +233,7 @@ instance Exception MailException
 
 class Yesod site => YesodMail site where
   defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
-  defaultFromAddress = (Address Nothing . ("yesod@" <>) . pack) <$> liftIO getHostName
+  defaultFromAddress = Address Nothing . ("yesod@" <>) . pack <$> liftIO getHostName
 
   mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text
   mailObjectIdDomain = pack <$> liftIO getHostName
@@ -325,7 +327,7 @@ instance Monoid (PrioritisedAlternatives m) where
   mappend = (<>)
 
 class YesodMail site => ToMailPart site a where
-  type MailPartReturn site a :: *
+  type MailPartReturn site a :: Type
   type MailPartReturn site a = ()
   toMailPart :: (MonadMail m, HandlerSite m ~ site) => a -> StateT Part m (MailPartReturn site a)
 

src/Model/Migration.hs

@@ -105,17 +105,17 @@ requiresMigration :: forall m.
                   => ReaderT SqlBackend m Bool
 requiresMigration = mapReaderT (exceptT return return) $ do
   initial <- either id (map snd) <$> parseMigration initialMigration
-  when (not $ null initial) $ do
+  unless (null initial) $ do
     $logInfoS "Migration" $ intercalate "; " initial
     throwError True
 
   customs <- mapReaderT lift $ getMissingMigrations @_ @m
-  when (not $ Map.null customs) $ do
+  unless (Map.null customs) $ do
     $logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs
     throwError True
 
   automatic <- either id (map snd) <$> parseMigration migrateAll'
-  when (not $ null automatic) $ do
+  unless (null automatic) $ do
     $logInfoS "Migration" $ intercalate "; " automatic
     throwError True
 
@@ -188,7 +188,7 @@ customMigrations = Map.fromListWith (>>)
           other -> error $ "Could not parse theme: " <> show other
     )
   , ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|]
-    , whenM (tableExists "sheet") $ -- Better JSON encoding
+    , whenM (tableExists "sheet") -- Better JSON encoding
         [executeQQ|
           ALTER TABLE "sheet" ALTER COLUMN "type" TYPE jsonb USING "type"::jsonb;
           ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE jsonb USING "grouping"::jsonb;
@@ -265,13 +265,13 @@ customMigrations = Map.fromListWith (>>)
           _other    -> error "Empty userDisplayName found"
     )
   , ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|]
-    , whenM (tableExists "sheet") $
+    , whenM (tableExists "sheet")
         [executeQQ|
           ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" jsonb DEFAULT '{ "tag": "Upload", "unpackZips": true }';
         |]
     )
   , ( AppliedMigrationKey [migrationVersion|3.2.0|] [version|4.0.0|]
-    , whenM (columnExists "user" "plugin") $
+    , whenM (columnExists "user" "plugin")
         -- <> is standard sql for /=
         [executeQQ|
           DELETE FROM "user" WHERE "plugin" <> 'LDAP';
@@ -280,7 +280,7 @@ customMigrations = Map.fromListWith (>>)
         |]
     )
   , ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|]
-    , whenM (tableExists "user") $
+    , whenM (tableExists "user")
         [executeQQ|
           ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" jsonb NOT NULL DEFAULT '[]';
         |]
@@ -291,13 +291,13 @@ customMigrations = Map.fromListWith (>>)
         forM_ sheets $ \(sid, Single lsty) -> update sid [SheetType =. Legacy.sheetType lsty]
     )
   , ( AppliedMigrationKey [migrationVersion|6.0.0|] [version|7.0.0|]
-    , whenM (tableExists "cluster_config") $
+    , whenM (tableExists "cluster_config")
         [executeQQ|
            UPDATE "cluster_config" SET "setting" = 'secret-box-key' WHERE "setting" = 'error-message-key';
         |]
     )
   , ( AppliedMigrationKey [migrationVersion|7.0.0|] [version|8.0.0|]
-    , whenM (tableExists "sheet") $
+    , whenM (tableExists "sheet")
         [executeQQ|
            UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', "type"->'') WHERE jsonb_exists("type", '');
            UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points')) WHERE ("type"->'grading'->'type') = '"points"' AND jsonb_exists("type"->'grading', 'points');
@@ -315,10 +315,10 @@ customMigrations = Map.fromListWith (>>)
     )
   , ( AppliedMigrationKey [migrationVersion|9.0.0|] [version|10.0.0|]
     , do
-        whenM (columnExists "study_degree" "shorthand") $ [executeQQ| UPDATE "study_degree" SET "shorthand" = NULL WHERE "shorthand" = '' |]
+        whenM (columnExists "study_degree" "shorthand") [executeQQ| UPDATE "study_degree" SET "shorthand" = NULL WHERE "shorthand" = '' |]
-        whenM (columnExists "study_degree" "name") $ [executeQQ| UPDATE "study_degree" SET "name" = NULL WHERE "shorthand" = '' |]
+        whenM (columnExists "study_degree" "name") [executeQQ| UPDATE "study_degree" SET "name" = NULL WHERE "shorthand" = '' |]
-        whenM (columnExists "study_terms" "shorthand") $ [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |]
+        whenM (columnExists "study_terms" "shorthand") [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |]
-        whenM (columnExists "study_terms" "name") $ [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |]
+        whenM (columnExists "study_terms" "name") [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |]
     )
   , ( AppliedMigrationKey [migrationVersion|10.0.0|] [version|11.0.0|]
     , whenM ((&&) <$> columnExists "sheet" "upload_mode" <*> columnExists "sheet" "submission_mode") $ do
@@ -388,7 +388,7 @@ customMigrations = Map.fromListWith (>>)
           ALTER TABLE transaction_log ADD COLUMN "initiator_id" bigint DEFAULT null;
         |]
 
-        whenM (tableExists "user") $
+        whenM (tableExists "user")
           [executeQQ|
             UPDATE transaction_log SET initiator_id = "user".id FROM "user" WHERE transaction_log.initiator = "user".ident;
           |]
@@ -572,13 +572,13 @@ customMigrations = Map.fromListWith (>>)
             |]
     )
   , ( AppliedMigrationKey [migrationVersion|22.0.0|] [version|23.0.0|]
-    , whenM (tableExists "exam") $
+    , whenM (tableExists "exam")
       [executeQQ|
         UPDATE "exam" SET "bonus_rule" = jsonb_insert("bonus_rule", '{round}' :: text[], '0.01' :: jsonb) WHERE "bonus_rule"->>'rule' = 'bonus-points';
       |]
     )
   , ( AppliedMigrationKey [migrationVersion|23.0.0|] [version|24.0.0|]
-    , whenM (tableExists "course_favourite") $
+    , whenM (tableExists "course_favourite")
       [executeQQ|
         ALTER TABLE "course_favourite" RENAME COLUMN "time" TO "last_visit";
         ALTER TABLE "course_favourite" ADD COLUMN "reason" jsonb DEFAULT '"visited"'::jsonb;
@@ -596,7 +596,7 @@ customMigrations = Map.fromListWith (>>)
           _other -> error "Cannot reconstruct course_participant.allocated"
     )
   , ( AppliedMigrationKey [migrationVersion|25.0.0|] [version|26.0.0|]
-    , whenM (tableExists "allocation") $
+    , whenM (tableExists "allocation")
         [executeQQ|
           CREATE TABLE "allocation_matching" ("id" SERIAL8 PRIMARY KEY UNIQUE, "allocation" INT8 NOT NULL, "fingerprint" BYTEA NOT NULL, "log" INT8 NOT NULL);
           INSERT INTO "allocation_matching" ("allocation", "fingerprint", "log") (select "id" as "allocation", "fingerprint", "matching_log" as "log" from "allocation" where not ("matching_log" is null) and not ("fingerprint" is null));
@@ -605,7 +605,7 @@ customMigrations = Map.fromListWith (>>)
         |]
     )
   , ( AppliedMigrationKey [migrationVersion|26.0.0|] [version|27.0.0|]
-    , whenM (tableExists "user") $
+    , whenM (tableExists "user")
         [executeQQ|
           ALTER TABLE "user" ADD COLUMN "languages" jsonb;
           UPDATE "user" SET "languages" = "mail_languages" where "mail_languages" <> '[]';
@@ -617,7 +617,7 @@ customMigrations = Map.fromListWith (>>)
         tableDropEmpty "exam_part_corrector"
     )
   , ( AppliedMigrationKey [migrationVersion|28.0.0|] [version|29.0.0|]
-    , whenM (tableExists "study_features") $
+    , whenM (tableExists "study_features")
         [executeQQ|
           ALTER TABLE "study_features" ADD COLUMN "super_field" bigint;
           UPDATE "study_features" SET "super_field" = "field", "field" = "sub_field" WHERE NOT ("sub_field" IS NULL);
@@ -625,7 +625,7 @@ customMigrations = Map.fromListWith (>>)
         |]
     )
   , ( AppliedMigrationKey [migrationVersion|29.0.0|] [version|30.0.0|]
-    , whenM (tableExists "exam") $
+    , whenM (tableExists "exam")
         [executeQQ|
           UPDATE "exam" SET "occurrence_rule" = #{ExamRoomManual} WHERE "occurrence_rule" IS NULL;
           ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" SET NOT NULL;
@@ -640,7 +640,7 @@ customMigrations = Map.fromListWith (>>)
            in [executeQQ|UPDATE exam_result SET result = #{res'} WHERE id = #{resId};|]
     )
   , ( AppliedMigrationKey [migrationVersion|31.0.0|] [version|32.0.0|]
-    , whenM (tableExists "exam") $
+    , whenM (tableExists "exam")
         [executeQQ|
           ALTER TABLE "exam" ADD COLUMN "grading_mode" character varying;
           UPDATE "exam" SET "grading_mode" = 'grades' WHERE "show_grades";
@@ -650,7 +650,7 @@ customMigrations = Map.fromListWith (>>)
         |]
     )
   , ( AppliedMigrationKey [migrationVersion|32.0.0|] [version|33.0.0|]
-    , whenM (tableExists "external_exam") $
+    , whenM (tableExists "external_exam")
         [executeQQ|
           ALTER TABLE "external_exam" ADD COLUMN "grading_mode" character varying;
           UPDATE "external_exam" SET "grading_mode" = 'grades' WHERE "show_grades";
@@ -849,7 +849,7 @@ customMigrations = Map.fromListWith (>>)
             ALTER TABLE "allocation_matching" RENAME COLUMN "log_ref" TO "log";
           |]
 
-        whenM (tableExists "session_file") $
+        whenM (tableExists "session_file")
           [executeQQ|
             ALTER TABLE "session_file" ADD COLUMN "content" BYTEA;
             UPDATE "session_file" SET "content" = (SELECT "hash" FROM "file" WHERE "file".id = "session_file"."file");

src/Model/Types/Exam.hs

@@ -59,6 +59,8 @@ import qualified Data.Foldable
 
 import Data.Aeson (genericToJSON, genericParseJSON)
 
+{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
+
 
 data ExamResult' res = ExamAttended { examResult :: res }
                      | ExamNoShow
@@ -170,7 +172,7 @@ derivePersistFieldJSON ''ExamOccurrenceRule
 makePrisms ''ExamOccurrenceRule
 
 examOccurrenceRuleAutomatic :: ExamOccurrenceRule -> Bool
-examOccurrenceRuleAutomatic x = or $ map ($ x)
+examOccurrenceRuleAutomatic x = any ($ x)
   [ is _ExamRoomSurname
   , is _ExamRoomMatriculation
   , is _ExamRoomRandom

src/Model/Types/File.hs

@@ -28,7 +28,7 @@ makeLenses_ ''FileReference
 
 
 class HasFileReference record where
-  data FileReferenceResidual record :: *
+  data FileReferenceResidual record :: Type
 
   _FileReference :: Iso' record (FileReference, FileReferenceResidual record)
 

src/Model/Types/Security.hs

@@ -162,7 +162,7 @@ instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
   parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
 
 instance (Ord a, PathPiece a) => PathPiece (PredDNF a) where
-  toPathPiece = Text.unwords . map (Text.intercalate "AND") . map (map toPathPiece . otoList) . otoList . dnfTerms
+  toPathPiece = Text.unwords . map (Text.intercalate "AND" . map toPathPiece . otoList) . otoList . dnfTerms
   fromPathPiece = fmap (PredDNF . Set.fromList) . mapM (fromNullable <=< foldMapM (fmap Set.singleton . fromPathPiece) . Text.splitOn "AND") . concatMap (Text.splitOn "OR") . Text.words
 
 type AuthLiteral = PredLiteral AuthTag

src/Model/Types/Submission.hs

@@ -21,7 +21,7 @@ import qualified Data.Text as Text
 import qualified Data.Set as Set
 
 
-import Data.List (elemIndex, genericIndex)
+import Data.List (genericIndex)
 import Data.Bits
 import Data.Text.Metrics (damerauLevenshtein)
 
@@ -118,7 +118,7 @@ _PseudonymText = prism' tToWords tFromWords . _PseudonymWords
 
 pseudonymWords :: Fold Text PseudonymWord
 pseudonymWords = folding
-  $ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
+  $ \(CI.mk -> input) -> maybe [] (map (view _2)) . listToMaybe . groupBy ((==) `on` view _1) . sortOn (view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
   where
     distance = damerauLevenshtein `on` CI.foldedCase
     -- | Arbitrary cutoff point, for reference: ispell cuts off at 1

src/Settings.hs

@@ -420,7 +420,7 @@ instance FromJSON AppSettings where
               Ldap.Plain host -> not $ null host
         appLdapConf               <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= []
         appSmtpConf               <- assertM (not . null . smtpHost) <$> o .:? "smtp"
-        let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}, ..} = and
+        let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}} = and
               [ not $ null connectHost
               , numConnection > 0
               , connectionIdleTime >= 0
@@ -587,3 +587,10 @@ compileTimeAppSettings =
     case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
         Aeson.Error e -> error e
         Aeson.Success settings -> settings
+
+
+getTimeLocale' :: [Lang] -> TimeLocale
+getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")])
+
+appTZ :: TZ
+appTZ = $(includeSystemTZ "Europe/Berlin")

src/Settings/Cluster.hs

@@ -8,6 +8,8 @@ module Settings.Cluster
 import ClassyPrelude.Yesod
 import Web.HttpApiData
 
+import Data.Kind (Type)
+
 import Utils
 import Data.Universe
 
@@ -59,7 +61,7 @@ instance FromHttpApiData ClusterSettingsKey where
 
 
 class (ToJSON (ClusterSettingValue key), FromJSON (ClusterSettingValue key)) => ClusterSetting (key :: ClusterSettingsKey) where
-  type ClusterSettingValue key :: *
+  type ClusterSettingValue key :: Type
   initClusterSetting :: forall m p. MonadIO m => p key -> m (ClusterSettingValue key)
   knownClusterSetting :: forall p. p key -> ClusterSettingsKey
 

src/Settings/WellKnownFiles/TH.hs

@@ -142,7 +142,7 @@ mkWellKnown defLang wellKnownBase wellKnownLinks = do
           [ clause [conP (mkName $ fNameManip fName) []] (normalB . TH.lift . map Text.pack $ splitDirectories fName) []
             | fName <- Set.toList fileNames
           ]
-        , funD 'fromPathMultiPiece $
+        , funD 'fromPathMultiPiece
           [ clause [] (normalB [e|flip HashMap.lookup $(varE nwellKnownFileNames)|]) []
           ]
         ]

src/Utils.hs

@@ -51,6 +51,7 @@ import Control.Lens as Utils (none)
 import Control.Lens.Extras (is)
 import Data.Set.Lens
 
+import Control.Monad (zipWithM)
 import Control.Arrow as Utils ((>>>))
 import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
 import Control.Monad.Except (MonadError(..))
@@ -154,8 +155,8 @@ maybeAttribute a c (Just v) = [(a,c v)]
 
 
 newtype PrettyValue = PrettyValue { unPrettyValue :: Value }
-  deriving (Eq, Read, Show, Generic, Typeable, Data)
+  deriving (Eq, Read, Show, Generic, Typeable, Data, TH.Lift)
-  deriving newtype (Hashable, IsString, TH.Lift, FromJSON, ToJSON, NFData)
+  deriving newtype (Hashable, IsString, FromJSON, ToJSON, NFData)
 
 instance ToContent PrettyValue where
   toContent = toContent . Builder.toLazyText . Aeson.encodePrettyToTextBuilder
@@ -169,8 +170,8 @@ toPrettyJSON = PrettyValue . toJSON
 
 
 newtype YamlValue = YamlValue { unYamlValue :: Value }
-  deriving (Eq, Read, Show, Generic, Typeable, Data)
+  deriving (Eq, Read, Show, Generic, Typeable, Data, TH.Lift)
-  deriving newtype (Hashable, IsString, TH.Lift, FromJSON, ToJSON, NFData)
+  deriving newtype (Hashable, IsString, FromJSON, ToJSON, NFData)
 
 instance ToContent YamlValue where
   toContent = toContent . Yaml.encode
@@ -182,7 +183,6 @@ instance HasContentType YamlValue where
 toYAML :: ToJSON a => a -> YamlValue
 toYAML = YamlValue . toJSON
 
-
 ---------------------
 -- Text and String --
 ---------------------
@@ -723,7 +723,7 @@ shortCircuitM sc binOp mx my = do
   x <- mx
   if
     | sc x      -> return x
-    | otherwise -> binOp <$> pure x <*> my
+    | otherwise -> binOp x <$> my
 
 
 guardM :: MonadPlus m => m Bool -> m ()
@@ -1193,8 +1193,7 @@ instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON
       Aeson.FromJSONKeyTextParser f -> Aeson.withObject "HashMap" $
           fmap MergeHashMap . HashMap.foldrWithKey (\k v m -> HashMap.insertWith (<>) <$> f k Aeson.<?> Aeson.Key k <*> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty)
       Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr ->
-          fmap (MergeHashMap . HashMap.fromListWith (<>)) . sequence .
+          fmap (MergeHashMap . HashMap.fromListWith (<>)) . zipWithM (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
-              zipWith (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
     where
       uc :: Aeson.Parser (HashMap Text v) -> Aeson.Parser (MergeHashMap k v)
       uc = unsafeCoerce

src/Utils/Allocation.hs

@@ -20,7 +20,7 @@ import Control.Monad.Writer (tell)
 
 import Control.Monad.ST
 
-import Data.List ((!!), elemIndex)
+import Data.List ((!!))
 
 
 type CourseIndex = Int
@@ -127,11 +127,11 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $
                           (newSpots, lostSpots) = force . Seq.splitAt capacity $ betterSpots <> Seq.singleton (st, cn) <> worseSpots
 
                           isUnstableWith :: CloneIndex -> (student, CloneIndex) -> Bool
-                          isUnstableWith cn' (stO, cnO) = fromMaybe False $ do
+                          isUnstableWith cn' (stO, cnO) = Just True == (do
                             c' <- matchingCourse st cn'
                             rMe <- courseRating c' (st, cn')
                             rOther <- courseRating c' (stO, cnO)
-                            return $ LT == compare (rMe, stb (st, cn')) (rOther, stb (stO, cnO))
+                            return $ LT == compare (rMe, stb (st, cn')) (rOther, stb (stO, cnO)))
 
                       if | any (uncurry isUnstableWith) $ (,) <$> [0,1..pred cn] <*> toList lostSpots
                            -> lift . tell . pure $ MatchingNoApplyCloneInstability st (fromIntegral cn) c

src/Utils/DB.hs

@@ -24,51 +24,51 @@ emptyOrIn criterion testSet
 entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
 entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty
 
-getJustBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
+getJustBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
           => Unique record -> ReaderT backend m (Entity record)
 getJustBy u = getBy u >>= maybe
   (throwM . PersistForeignConstraintUnmet $ tshow u)
   return
 
-getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
+getKeyBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m)
          => Unique record -> ReaderT backend m (Maybe (Key record))
 getKeyBy u = fmap entityKey <$> getBy u -- TODO optimize this, so that DB does not deliver entire record!
 
-getKeyJustBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
+getKeyJustBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
              => Unique record -> ReaderT backend m (Key record)
 getKeyJustBy u = getKeyBy u >>= maybe
   (throwM . PersistForeignConstraintUnmet $ tshow u)
   return
 
-getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadHandler m)
+getKeyBy404 :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadHandler m)
             => Unique record -> ReaderT backend m (Key record)
 getKeyBy404 u = getKeyBy u >>= maybe notFound return
 
-getEntity404 :: (PersistStoreRead backend, PersistRecordBackend val backend, MonadHandler m)
+getEntity404 :: (PersistStoreRead backend, PersistRecordBackend record backend, MonadHandler m)
-             => Key val -> ReaderT backend m (Entity val)
+             => Key record -> ReaderT backend m (Entity record)
-getEntity404 k = Entity <$> pure k <*> get404 k
+getEntity404 k = Entity k <$> get404 k
 
-existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
+existsBy :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadIO m)
          => Unique record -> ReaderT backend m Bool
 existsBy = fmap (is _Just) . getKeyBy
 
-existsBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadHandler m)
+existsBy404 :: (PersistRecordBackend record backend, PersistUniqueRead backend, MonadHandler m)
             => Unique record -> ReaderT backend m ()
 existsBy404 = bool notFound (return ()) <=< fmap (is _Just) . getKeyBy
 
-existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadIO m)
+existsKey :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
           => Key record -> ReaderT backend m Bool
 existsKey = exists . pure . (persistIdField ==.)
 
-exists :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadIO m)
+exists :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadIO m)
        => [Filter record] -> ReaderT backend m Bool
 exists = fmap (not . null) . flip selectKeysList [LimitTo 1]
 
-exists404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadHandler m)
+exists404 :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadHandler m)
           => [Filter record] -> ReaderT backend m ()
 exists404 = bool (return ()) notFound <=< fmap null . flip selectKeysList [LimitTo 1]
 
-existsKey404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadHandler m)
+existsKey404 :: (PersistRecordBackend record backend, PersistQueryRead backend, MonadHandler m)
              => Key record -> ReaderT backend m ()
 existsKey404 = bool notFound (return ()) <=< existsKey