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-get install -y --no-install-recommends locales-all
-    - apt-get install openssh-client -y
+    - apt-key add ${LLVM_APT_KEY}
+    - apt update -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-get install -y --no-install-recommends openssh-client
+    - apt update -y
+    - 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
-      - -rtsopts "-with-rtsopts=-N -T"
+      - -threaded -rtsopts "-with-rtsopts=-N -T -xn"
     source-dirs: test
     dependencies:
       - uniworx
@@ -277,8 +277,7 @@ executables:
     main: Load.hs
     ghc-options:
       - -main-is Load
-      - -threaded
-      - -rtsopts "-with-rtsopts=-N -T"
+      - -threaded -rtsopts "-with-rtsopts=-N -T -xn"
     source-dirs: load
     dependencies:
       - uniworx
@@ -312,9 +311,7 @@ tests:
       - yesod-persistent
     ghc-options:
       - -fno-warn-orphans
-      - -threaded
-      - -rtsopts
-      - -with-rtsopts=-N
+      - -threaded -rtsopts "-with-rtsopts=-N -T -xn"
   hlint:
     main: Hlint.hs
     other-modules: []

src/Application.hs

@@ -94,13 +94,15 @@ import Handler.Utils.Routes (classifyHandler)
 
 import qualified Data.Acid.Memory as Acid
 import qualified Web.ServerSession.Backend.Acid as Acid
-  
+
 import qualified Ldap.Client as Ldap (Host(Plain, Tls))
 
 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
@@ -140,7 +142,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
 makeFoundation :: (MonadResource m, MonadUnliftIO m, MonadCatch m) => AppSettings -> m UniWorX
 makeFoundation appSettings'@AppSettings{..} = do
     registerGHCMetrics
-  
+
     -- Some basic initializations: HTTP connection manager, logger, and static
     -- subsite.
     appHttpManager <- newManager
@@ -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"
@@ -353,7 +356,7 @@ makeApplication foundation = liftIO $ makeMiddleware foundation <*> toWaiAppPlai
 makeMiddleware :: MonadIO m => UniWorX -> m Middleware
 makeMiddleware app = do
   logWare <- makeLogWare
-  return $ observeHTTPRequestLatency classifyHandler . logWare . normalizeCookies . defaultMiddlewaresNoLogging 
+  return $ observeHTTPRequestLatency classifyHandler . logWare . normalizeCookies . defaultMiddlewaresNoLogging
   where
     makeLogWare = do
       logWareMap <- liftIO $ newTVarIO HashMap.empty
@@ -388,7 +391,7 @@ makeMiddleware app = do
         respond $ Wai.mapResponseHeaders (const resHdrs') res
       where parseSetCookie' :: ByteString -> IO (Maybe SetCookie)
             parseSetCookie' = fmap (either (\(_ :: SomeException) -> Nothing) Just) . try . evaluate . force . parseSetCookie
-              
+
             go [] = return []
             go (hdr@(hdrName, hdrValue) : hdrs)
               | hdrName == hSetCookie = do
@@ -455,7 +458,7 @@ warpSettings foundation = defaultSettings
           Just (SessionDoesNotExist{} :: StorageException (AcidStorage SessionMap)) -> False
           _other -> True
       ]
-                           
+
 
 getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings
 getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
@@ -476,7 +479,7 @@ develMain = runResourceT $ do
           lift $ threadDelay 100e3
           whenM (lift $ doesFileExist "yesod-devel/devel-terminate") $
             callCC ($ ())
-  
+
   void . liftIO $ installHandler sigINT (Signals.Catch $ return ()) Nothing
   runAppLoggingT foundation $ handleJobs foundation
   void . liftIO $ awaitTermination `race` runSettings wsettings app

src/Audit.hs

@@ -54,7 +54,7 @@ getRemote = handle testHandler $ do
       guard $ h `elem` ["x-real-ip", "x-forwarded-for"]
       v' <- either (const mzero) return $ Text.decodeUtf8' v
       maybeToList $ IP.decode v'
-    
+
     byRemoteHost wai = case Wai.remoteHost wai of
       Wai.SockAddrInet _ hAddr
         -> let (b1, b2, b3, b4) = Wai.hostAddressToTuple hAddr

src/Audit/Types.hs

@@ -23,7 +23,7 @@ data Transaction
     { transactionExam   :: ExamId
     , transactionUser   :: UserId
     }
-  
+
   | TransactionExamPartResultEdit
     { transactionExamPart :: ExamPartId
     , transactionUser     :: UserId
@@ -88,7 +88,7 @@ data Transaction
     { transactionSubmission :: SubmissionId
     , transactionUser       :: UserId
     }
-  
+
   | TransactionSubmissionFileEdit
     { transactionSubmissionFile :: SubmissionFileId
     , transactionSubmission     :: SubmissionId
@@ -133,7 +133,7 @@ data Transaction
     { transactionExternalExam :: ExternalExamId
     , transactionSchool       :: SchoolId
     }
-  
+
   | TransactionExternalExamStaffEdit
     { transactionExternalExam :: ExternalExamId
     , transactionUser         :: UserId

src/Auth/Dummy.hs

@@ -45,7 +45,7 @@ dummyLogin = AuthPlugin{..}
   where
     apName :: Text
     apName = "dummy"
-    
+
     apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
     apDispatch method [] | encodeUtf8 method == methodPost = liftSubHandler $ do
       ((loginRes, _), _) <- runFormPost $ renderWForm FormStandard dummyForm
@@ -62,7 +62,7 @@ dummyLogin = AuthPlugin{..}
           setCredsRedirect $ Creds apName (CI.original ident) []
     apDispatch _ [] = badMethod
     apDispatch _ _ = notFound
-  
+
     apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
     apLogin toMaster = do
       (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormStandard dummyForm

src/Auth/LDAP.hs

@@ -52,7 +52,7 @@ findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM
       [ ldapUserDisplayName   Ldap.:= Text.encodeUtf8 ident
       , ldapUserMatriculation Ldap.:= Text.encodeUtf8 ident
       ]
-      
+
 findUserMatr :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
 findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
   where
@@ -76,8 +76,8 @@ ldapUserFirstName         = Ldap.Attr "givenName"
 ldapUserSurname           = Ldap.Attr "sn"
 ldapUserTitle             = Ldap.Attr "title"
 ldapUserStudyFeatures     = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
-ldapUserFieldName         = Ldap.Attr "LMU-Stg-Fach" 
-ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString" 
+ldapUserFieldName         = Ldap.Attr "LMU-Stg-Fach"
+ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString"
 ldapSex                   = Ldap.Attr "schacGender"
 ldapUserSubTermsSemester  = Ldap.Attr "LMU-Stg-FachundFS"
 
@@ -145,7 +145,7 @@ campusUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return
     [] -> throwM CampusUserNoResult
     [Ldap.SearchEntry _ attrs] -> return attrs
     _otherwise -> throwM CampusUserAmbiguous
-  
+
 campusUserMatr' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
 campusUserMatr' pool mode
   = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr pool mode
@@ -177,7 +177,7 @@ campusLogin pool mode = AuthPlugin{..}
   where
     apName :: Text
     apName = apLdap
-  
+
     apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
     apDispatch method [] | encodeUtf8 method == methodPost = liftSubHandler $ do
       ((loginRes, _), _) <- runFormPost $ renderWForm FormStandard campusForm

src/Control/Monad/Trans/Memo/StateCache/Instances.hs

@@ -16,7 +16,7 @@ instance MonadResource m => MonadResource (StateCache c m) where
 
 instance MonadLogger m => MonadLogger (StateCache c m)
 instance MonadLoggerIO m => MonadLoggerIO (StateCache c m)
-  
+
 instance MonadHandler m => MonadHandler (StateCache c m) where
   type HandlerSite (StateCache c m) = HandlerSite m
   type SubHandlerSite (StateCache c m) = SubHandlerSite m

src/Cron.hs

@@ -21,7 +21,7 @@ import qualified Data.Set as Set
 
 import Utils.Lens hiding (from, to)
 
-  
+
 data CronDate = CronDate
   { cdYear, cdWeekYear, cdWeekOfYear, cdDayOfYear
   , cdMonth, cdWeekOfMonth, cdDayOfMonth
@@ -101,7 +101,7 @@ instance Alternative CronNextMatch where
   _ <|> MatchAsap = MatchAsap
   MatchAsap <|> _ = MatchAsap
   (MatchAt a) <|> (MatchAt _) = MatchAt a
-  
+
 
 listToMatch :: [a] -> CronNextMatch a
 listToMatch [] = MatchNone
@@ -203,7 +203,7 @@ nextCronMatch tz mPrev prec now c@Cron{..} = onlyOnceWithinPrec $ case notAfter
                    in case execRef now False cronInitial of
                         MatchAsap
                           | now < cutoffTime -> MatchAt cutoffTime
-                        MatchAt ts 
+                        MatchAt ts
                           | ts < cutoffTime -> MatchAt cutoffTime
                         other -> other
             CronRepeatScheduled cronNext

src/Cron/Types.hs

@@ -11,12 +11,12 @@ import ClassyPrelude
 
 import Utils.Lens.TH
 
-import Data.Time 
+import Data.Time
 
 import Numeric.Natural
 
 import qualified Data.Set as Set
-  
+
 
 data CronMatch
   = CronMatchAny

src/Crypto/Hash/Instances.hs

@@ -26,7 +26,7 @@ instance HashAlgorithm hash => PersistField (Digest hash) where
   fromPersistValue _ = Left "Digest values must be converted from PersistByteString or PersistText"
 
 instance HashAlgorithm hash => PersistFieldSql (Digest hash) where
-  sqlType _ = SqlBlob 
+  sqlType _ = SqlBlob
 
 instance HashAlgorithm hash => PathPiece (Digest hash) where
   toPathPiece = showToPathPiece

src/CryptoID.hs

@@ -38,7 +38,7 @@ encrypt :: forall plaintext ciphertext m.
            , Typeable ciphertext
            , PathPiece plaintext
            )
-        => plaintext -> m (I.CryptoID ciphertext plaintext) 
+        => plaintext -> m (I.CryptoID ciphertext plaintext)
 encrypt plain = $cachedHereBinary (toPathPiece plain) $ I.encrypt plain
 
 decrypt :: forall plaintext ciphertext m.
@@ -47,7 +47,7 @@ decrypt :: forall plaintext ciphertext m.
            , Typeable plaintext
            , PathPiece ciphertext
            )
-        => I.CryptoID ciphertext plaintext -> m plaintext 
+        => I.CryptoID ciphertext plaintext -> m plaintext
 decrypt cipher = $cachedHereBinary (toPathPiece $ ciphertext cipher) $ I.decrypt cipher
 
 

src/Data/CaseInsensitive/Instances.hs

@@ -38,7 +38,7 @@ instance PersistField (CI String) where
   toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 . pack $ CI.original ciText
   fromPersistValue (PersistDbSpecific bs) = Right . CI.mk . unpack $ Text.decodeUtf8 bs
   fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
-  
+
 instance PersistFieldSql (CI Text) where
   sqlType _ = SqlOther "citext"
 
@@ -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
-  lift (CI.original -> orig) = [e|CI.mk $(lift orig)|]
+instance (CI.FoldCase t, Lift t) => Lift (CI t) where
+  liftTyped (CI.original -> orig) = [||CI.mk $$(liftTyped orig)||]
 
 
 instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where

src/Data/Fixed/Instances.hs

@@ -16,7 +16,7 @@ import Data.Proxy (Proxy(..))
 
 import Data.Scientific
 import Data.Scientific.Instances ()
-  
+
 
 instance HasResolution a => ToMarkup (Fixed a) where
   toMarkup = toMarkup . showFixed True

src/Data/Maybe/Instances.hs

@@ -10,4 +10,4 @@ import Text.Blaze (ToMarkup(..), string)
 
 instance ToMarkup a => ToMarkup (Maybe a) where
   toMarkup Nothing  = string ""
-  toMarkup (Just x) = toMarkup x
+  toMarkup (Just x) = toMarkup x

src/Data/MonoTraversable/Instances.hs

@@ -19,7 +19,7 @@ instance MonoFunctor All where
 
 instance MonoPointed Any where
   opoint = Any
-  
+
 instance MonoPointed All where
   opoint = All
 

src/Data/Scientific/Instances.hs

@@ -11,5 +11,5 @@ import Web.PathPieces
 
 
 instance PathPiece Scientific where
-  toPathPiece = pack . formatScientific Fixed Nothing 
+  toPathPiece = pack . formatScientific Fixed Nothing
   fromPathPiece = readFromPathPiece

src/Data/Sum/Instances.hs

@@ -10,4 +10,4 @@ import Data.Monoid (Sum(..))
 import Text.Blaze (ToMarkup(..))
 
 instance ToMarkup a => ToMarkup (Sum a) where
-  toMarkup = toMarkup . getSum
+  toMarkup = toMarkup . getSum

src/Data/UUID/Instances.hs

@@ -10,7 +10,7 @@ import qualified Data.UUID as UUID
 import Database.Persist.Sql
 
 import Text.Blaze (ToMarkup(..))
-  
+
 
 instance PathPiece UUID where
   fromPathPiece = UUID.fromString . unpack

src/Data/Universe/Instances/Reverse/MonoTraversable.hs

@@ -7,11 +7,11 @@ module Data.Universe.Instances.Reverse.MonoTraversable
 import Data.Universe
 import Data.MonoTraversable
 
-import Data.Universe.Instances.Reverse 
-  
+import Data.Universe.Instances.Reverse
+
 
 type instance Element (a -> b) = b
 
 instance Finite a => MonoFoldable (a -> b)
 instance (Ord a, Finite a) => MonoTraversable (a -> b)
-  
+

src/Data/Universe/TH.hs

@@ -23,7 +23,7 @@ import Data.List (elemIndex)
 getTVBName :: TyVarBndr -> Name
 getTVBName (PlainTV  name  ) = name
 getTVBName (KindedTV name _) = name
-  
+
 
 
 finiteEnum :: Name -> DecsQ
@@ -33,7 +33,7 @@ finiteEnum tName = do
 
   let datatype = foldl appT (conT datatypeName) $ map (varT . getTVBName) datatypeVars
       tUniverse = [e|universeF :: [$(datatype)]|]
-  
+
   [d|
     instance Bounded $(datatype) where
       minBound = head $(tUniverse)

src/Database/Esqueleto/Utils.hs

@@ -196,7 +196,7 @@ orderByList :: PersistField a => [a] -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Va
 orderByList vals
   = let sortUni = zip [1..] vals -- memoize this, might not work due to polymorphism
      in \x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val . succ $ List.length vals)
-  
+
 orderByOrd :: (Ord a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
 orderByOrd = orderByList $ List.sort universeF
 
@@ -206,12 +206,12 @@ orderByEnum = orderByList $ List.sortOn fromEnum universeF
 
 lower :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)
 lower = E.unsafeSqlFunction "LOWER"
-  
+
 strip :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)
 strip = E.unsafeSqlFunction "TRIM"
 
 infix 4 `ciEq`
-  
+
 ciEq :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
 ciEq a b = lower a E.==. lower b
 
@@ -249,7 +249,7 @@ maybe onNothing onJust val = E.case_
       (onJust $ E.veryUnsafeCoerceSqlExprValue val)
   ]
   (E.else_ onNothing)
-  
+
 infix 4 `maybeEq`
 
 maybeEq :: PersistField a

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

@@ -18,13 +18,13 @@ import qualified System.Directory.Tree as DirTree
 import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT)
 
 import Control.Lens
-  
+
 
 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
@@ -32,5 +32,5 @@ persistDirectoryWith settings dir = do
       SIO.hSetEncoding h SIO.utf8_bom
       Text.hGetContents h
   mapM_ qAddDependentFile . toListOf (traverse . filtered (has $ _2 . _Just) . _1) $ DirTree.zipPaths files
-  
+
   parseReferences settings . Text.intercalate "\n" . toListOf (traverse . _Just) $ DirTree.dirTree files

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"]
@@ -116,7 +118,7 @@ ordinalEN (toMessage -> numStr) = case lastChar of
   Just '3' -> [st|#{numStr}rd|]
   _other   -> [st|#{numStr}th|]
   where
-    lastChar = last <$> fromNullable numStr 
+    lastChar = last <$> fromNullable numStr
 
 
 -- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers
@@ -178,11 +180,25 @@ instance RenderMessage UniWorX MsgLanguage where
     | ("de" : "DE" : _) <- lang' = mr MsgGermanGermany
     | ("de" : _)        <- lang' = mr MsgGerman
     | ("en" : "EU" : _) <- lang' = mr MsgEnglishEurope
-    | ("en" : _)        <- lang' = mr MsgEnglish 
+    | ("en" : _)        <- lang' = mr MsgEnglish
     | otherwise = lang
     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
@@ -255,7 +271,7 @@ instance RenderMessage UniWorX StudyDegreeTerm where
     where
       mr :: RenderMessage UniWorX msg => msg -> Text
       mr = renderMessage foundation ls
-  
+
 newtype ShortStudyFieldType = ShortStudyFieldType StudyFieldType
 embedRenderMessageVariant ''UniWorX ''ShortStudyFieldType ("Short" <>)
 
@@ -341,7 +357,7 @@ instance RenderMessage UniWorX UniWorXMessages where
 uniworxMessages :: [UniWorXMessage] -> UniWorXMessages
 uniworxMessages = UniWorXMessages . map SomeMessage
 
-  
+
 -- This instance is required to use forms. You can modify renderMessage to
 -- achieve customized and internationalized form validation messages.
 instance RenderMessage UniWorX FormMessage where
@@ -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 Widget    = WidgetT  UniWorX IO ()
+-- type Handler x = HandlerFor UniWorX x
+-- type Widget    = WidgetFor  UniWorX ()
 mkYesodData "UniWorX" uniworxRoutes
 
 deriving instance Generic CourseR
@@ -75,11 +75,11 @@ pattern CSubmissionR tid ssh csh shn cid ptn
 pattern CApplicationR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> CourseApplicationR -> Route UniWorX
 pattern CApplicationR tid ssh csh appId ptn
   = CourseR tid ssh csh (CourseApplicationR appId ptn)
-  
+
 pattern CNewsR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> CourseNewsR -> Route UniWorX
 pattern CNewsR tid ssh csh nId ptn
   = CourseR tid ssh csh (CourseNewsR nId ptn)
-  
+
 pattern CEventR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseEvent -> CourseEventR -> Route UniWorX
 pattern CEventR tid ssh csh nId ptn
   = CourseR tid ssh csh (CourseEventR nId ptn)

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/StudyFeatures.hs

@@ -47,7 +47,7 @@ embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsParents id
 instance Button UniWorX ButtonAdminStudyTermsParents where
   btnClasses BtnParentCandidatesInfer     = [BCIsButton, BCPrimary]
   btnClasses BtnParentCandidatesDeleteAll = [BCIsButton, BCDanger]
-  
+
 data ButtonAdminStudyTermsStandalone
   = BtnStandaloneCandidatesDeleteRedundant
   | BtnStandaloneCandidatesDeleteAll
@@ -62,7 +62,7 @@ instance Button UniWorX ButtonAdminStudyTermsStandalone where
   btnClasses BtnStandaloneCandidatesDeleteRedundant = [BCIsButton, BCPrimary]
   btnClasses BtnStandaloneCandidatesDeleteAll       = [BCIsButton, BCDanger]
 
-  
+
 {-# ANN postAdminFeaturesR ("HLint: ignore Redundant void" :: String) #-}
 getAdminFeaturesR, postAdminFeaturesR :: Handler Html
 getAdminFeaturesR = postAdminFeaturesR
@@ -147,7 +147,7 @@ postAdminFeaturesR = do
           deleteWhere ([] :: [Filter StudyTermStandaloneCandidate])
           addMessageI Success MsgAllStandaloneIncidencesDeleted
         redirect AdminFeaturesR
-  
+
 
     newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
     badStudyTermKeys <- lookupSessionJson SessionConflictingStudyTerms
@@ -208,7 +208,7 @@ postAdminFeaturesR = do
         infRedundantStandalone <- Candidates.removeRedundantStandalone
         unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone
         return updated
-      
+
       let newKeys = catMaybes $ Map.elems updated
       unless (null newKeys) $ do
         setSessionJson SessionNewStudyTerms newKeys
@@ -247,19 +247,19 @@ postAdminFeaturesR = do
                   => Lens' a (Maybe Text)
                   -> Getter (DBRow r) (Maybe Text)
                   -> Getter (DBRow r) i
-                  -> DBRow r 
+                  -> DBRow r
                   -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
     textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
       (\row _mkUnique -> bimap (fmap $ set lensRes . assertM (not . Text.null)) fvWidget
         <$> mopt (textField & cfStrip) "" (Just $ row ^. lensDefault)
       )
-  
+
     checkboxCell :: Ord i
                  => Lens' a Bool
                  -> Getter (DBRow r) Bool
                  -> Getter (DBRow r) i
-                 -> DBRow r 
-                 -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r))) 
+                 -> DBRow r
+                 -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
     checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
       ( \row _mkUnique -> bimap (fmap $ set lensRes) fvWidget
         <$> mpopt checkBoxField "" (Just $ row ^. lensDefault)
@@ -306,7 +306,7 @@ postAdminFeaturesR = do
       ( \row _mkUnique -> bimap (fmap $ set lensRes) fvWidget
         <$> mopt degreeField "" (Just $ row ^. lensDefault)
       )
-  
+
     fieldTypeCell :: Ord i
                   => Lens' a (Maybe StudyFieldType)
                   -> Getter (DBRow r) (Maybe StudyFieldType)
@@ -359,7 +359,7 @@ postAdminFeaturesR = do
             fieldSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do
               E.where_ . E.exists . E.from $ \schoolTerms ->
                 E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
-                     E.&&. schoolTerms E.^. SchoolTermsTerms  E.==. E.val fId 
+                     E.&&. schoolTerms E.^. SchoolTermsTerms  E.==. E.val fId
               E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools)
               return $ school E.^. SchoolId
             fieldParents <- fmap (setOf folded) . E.select . E.from $ \terms -> do

src/Handler/Admin/Test/Download.hs

@@ -45,10 +45,10 @@ testDownloadForm = identifyForm FIDTestDownload . renderWForm FormStandard $ do
 
   maxSizeRes <- wreq intField (fslI MsgTestDownloadMaxSize) . Just $ 2 * 2^30
   modeRes <- wpopt (selectField optionsFinite) (fslI MsgTestDownloadMode) $ Just TestDownloadDirect
-  
+
   return $ TestDownloadOptions
-    <$> pure randomSeed
-    <*> maxSizeRes
+        randomSeed
+    <$> maxSizeRes
     <*> pure (2^20)
     <*> modeRes
 
@@ -86,7 +86,7 @@ testDownload = do
           sourceDBFiles = E.selectSource . E.from $ \fileContent -> do
             E.orderBy [E.asc $ E.random_ @Int64]
             return fileContent
-          
+
           takeLimit n | n <= 0 = return ()
           takeLimit n = do
             c <- await

src/Handler/Admin/Tokens.hs

@@ -30,7 +30,7 @@ bearerTokenForm :: WForm Handler (FormResult BearerTokenForm)
 bearerTokenForm = do
   muid <- maybeAuthId
   mr <- getMessageRender
-  
+
   btfAuthorityGroups <- aFormToWForm $ HashSet.fromList . map Left <$> massInputListA pathPieceField (const "") MsgBearerTokenAuthorityGroupMissing (\p -> Just . SomeRoute $ AdminTokensR :#: p) ("token-groups" :: Text) (fslI MsgBearerTokenAuthorityGroups & setTooltip MsgBearerTokenAuthorityGroupsTip) False Nothing
   btfAuthorityUsers <- fmap (fmap . ofoldMap $ HashSet.singleton . Right) <$> wopt (checkMap (foldMapM $ fmap Set.singleton . left MsgBearerTokenAuthorityUnknownUser) (Set.map Right) $ multiUserField False Nothing) (fslpI MsgBearerTokenAuthorityUsers (mr MsgLdapIdentificationOrEmail) & setTooltip MsgBearerTokenAuthorityUsersTip) (Just $ Set.singleton <$> muid)
   let btfAuthority' :: FormResult (HashSet (Either UserGroupName UserId))
@@ -58,7 +58,7 @@ bearerTokenForm = do
 
               miLayout' :: MassInputLayout ListLength (Route UniWorX, Value) (Route UniWorX, Value)
               miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/token-restrictions/layout")
-                
+
   btfRestrict' <- fmap HashMap.fromList <$> btfRestrictForm
 
   btfAddAuth' <- fmap (assertM $ not . Set.null . dnfTerms) <$> wopt pathPieceField (fslI MsgBearerTokenAdditionalAuth & setTooltip MsgBearerTokenAdditionalAuthTip) Nothing
@@ -87,8 +87,8 @@ postAdminTokensR = do
           & HashSet.map (left toJSON)
 
     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/Accept.hs

@@ -33,7 +33,7 @@ newtype SessionDataAllocationResults = SessionDataAllocationResults
     deriving (Monoid, Semigroup) via Dual (Map (TermId, SchoolId, AllocationShorthand) (UTCTime, AllocationFingerprint, Set (UserId, CourseId), Seq MatchingLogRun))
 
 makeWrapped ''SessionDataAllocationResults
-  
+
 
 data AllocationAcceptButton
   = BtnAllocationAccept
@@ -59,7 +59,7 @@ allocationAcceptForm aId = runMaybeT $ do
     let applications = E.subSelectCount . E.from $ \courseApplication ->
           E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.val (Just aId)
                E.&&. courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser
-    return . (allocationUser E.^. AllocationUserUser, ) $ E.case_ 
+    return . (allocationUser E.^. AllocationUserUser, ) $ E.case_
       [ E.when_ (E.castNum (allocationUser E.^. AllocationUserTotalCourses) E.>. applications)
         E.then_ (applications :: E.SqlExpr (E.Value Int))
       ]
@@ -124,7 +124,7 @@ allocationAcceptForm aId = runMaybeT $ do
         = invDualHeat (optimumAllocated capN) capN
       degenerateHeat capN
         = capN <= optimumAllocated capN
-      
+
     return (prevAllocMatches, $(widgetFile "allocation/accept"))
 
 getAAcceptR, postAAcceptR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
@@ -135,7 +135,7 @@ postAAcceptR tid ssh ash = do
 
     acceptForm <- maybe (redirect $ AllocationR tid ssh ash AComputeR) return =<< allocationAcceptForm aId
 
-    formRes@((acceptRes, _), _) <- liftHandler $ runFormPost acceptForm 
+    formRes@((acceptRes, _), _) <- liftHandler $ runFormPost acceptForm
 
     didStore <- formResultMaybe acceptRes $ \(now, allocFp, allocMatchings, allocLog) -> do
       modifySessionJson SessionAllocationResults . fmap (assertM $ not . views _Wrapped onull) . over (mapped . _Wrapped :: Setter' (Maybe SessionDataAllocationResults) _) $

src/Handler/Allocation/Application.hs

@@ -58,24 +58,24 @@ data ApplicationFormMode = ApplicationFormMode
   , afmApplicantEdit :: Bool -- ^ Allow editing text, files, priority (if shown)
   , afmLecturer      :: Bool -- ^ Allow editing rating
   }
- 
+
 
 data ApplicationFormException = ApplicationFormNoApplication -- ^ Could not fill forced fields of application form with data from application
   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
                 -> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView)
 applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf = do
-  
+
   (mApp, coursesNum, Course{..}, maxPrio) <- liftHandler . runDB $ do
     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)
@@ -91,25 +91,25 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
 
     mkPrioOption :: Natural -> Option Natural
     mkPrioOption i = Option
-      { optionDisplay       = mr . MsgAllocationCoursePriority $ coursesNum' - i 
+      { optionDisplay       = mr . MsgAllocationCoursePriority $ coursesNum' - i
       , optionInternalValue = i
       , optionExternalValue = tshow i
       }
-    
+
     prioOptions :: OptionList Natural
     prioOptions = OptionList
       { olOptions = sortOn (Down . optionInternalValue) . map mkPrioOption $ [0 .. pred coursesNum']
       , olReadExternal = readMay
       }
     prioField = selectField' (Just $ SomeMessage MsgAllocationCourseNoApplication) $ return prioOptions
-      
+
   (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, _      )
-      -> over _2 Just <$> mforcedOpt prioField (fslI MsgApplicationPriority) oldPrio 
+      -> over _2 Just <$> mforcedOpt prioField (fslI MsgApplicationPriority) oldPrio
     (True , False, _    , Just _ )
       | is _Just oldPrio
         -> pure (FormSuccess oldPrio, Nothing)
@@ -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,16 +174,16 @@ 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
       -> over _2 Just <$> mopt examGradeField (fslI MsgApplicationRatingPoints & setTooltip MsgApplicationRatingPointsTip) (fmap Just $ mApp >>= courseApplicationRatingPoints . entityVal)
@@ -195,7 +195,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
       -> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' (fslI MsgApplicationRatingComment & setTooltip (bool MsgApplicationRatingCommentInvisibleTip MsgApplicationRatingCommentVisibleTip courseApplicationsRatingsVisible)) (fmap Just $ mApp >>= courseApplicationRatingComment . entityVal)
     | otherwise
       -> return (FormSuccess $ courseApplicationRatingComment . entityVal =<< mApp, Nothing)
-  
+
   let
     buttons = catMaybes
       [ guardOn (not afmApplicantEdit && is _Just    mApp && afmLecturer) BtnAllocationApplicationRate
@@ -225,7 +225,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
            <*> actionRes
          , ApplicationFormView
            { afvPriority = prioView
-           , afvForm = catMaybes $ 
+           , afvForm = catMaybes $
              [ Just fieldView'
              , textView
              , filesLinkView
@@ -240,7 +240,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
            }
          )
 
- 
+
 
 
 editApplicationR :: Maybe AllocationId
@@ -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
@@ -354,7 +354,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
     redirect postAction
 
   return (appView, appEnc)
-        
+
 
 postAApplyR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDCourse -> Handler Void
 postAApplyR tid ssh ash cID = do

src/Handler/Allocation/Compute.hs

@@ -62,7 +62,7 @@ missingPriorities aId = wFormToAForm $ do
           missingPriosFieldView theId name attrs res isReq
             = $(i18nWidgetFile "allocation-confirm-missing-prios")
             where checkBoxFieldView = labeledCheckBoxView (i18n MsgAllocationUsersMissingPrioritiesOk) theId name attrs res isReq
-          
+
   if
     | null usersWithoutPrio
       -> return $ pure Set.empty

src/Handler/Allocation/List.hs

@@ -58,7 +58,7 @@ resultApplied = _dbrOutput . _3
 
 allocationTermLink :: TermId -> SomeRoute UniWorX
 allocationTermLink tid = SomeRoute (AllocationListR, [(dbFilterKey allocationListIdent "term", toPathPiece tid)])
-  
+
 allocationSchoolLink :: SchoolId -> SomeRoute UniWorX
 allocationSchoolLink ssh = SomeRoute (AllocationListR, [(dbFilterKey allocationListIdent "school", toPathPiece ssh)])
 

src/Handler/Allocation/Prios.hs

@@ -26,7 +26,7 @@ instance Finite AllocationPrioritiesMode
 nullaryPathPiece ''AllocationPrioritiesMode $ camelToPathPiece' 2
 
 embedRenderMessage ''UniWorX ''AllocationPrioritiesMode id
-  
+
 
 getAPriosR, postAPriosR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
 getAPriosR = postAPriosR
@@ -37,7 +37,7 @@ postAPriosR tid ssh ash = do
     numericPrios <- E.selectCountRows . E.from $ \allocationUser -> do
       E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId
       E.where_ . E.maybe E.false sqlAllocationPriorityNumeric $ allocationUser E.^. AllocationUserPriority
-  
+
     ordinalPrios <- E.selectCountRows . E.from $ \allocationUser -> do
       E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId
       E.where_ . E.maybe E.false (E.not_ . sqlAllocationPriorityNumeric) $ allocationUser E.^. AllocationUserPriority
@@ -59,7 +59,7 @@ postAPriosR tid ssh ash = do
     let sourcePrios = case mode of
           AllocationPrioritiesNumeric -> transPipe liftHandler fInfo .| fileSourceCsvPositional Csv.NoHeader
           AllocationPrioritiesOrdinal -> transPipe liftHandler fInfo .| fileSourceCsvPositional Csv.NoHeader .| C.map Csv.fromOnly .| ordinalPriorities
-    
+
     (matrSunk, matrMissing) <- runDB $ do
       Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash
       updateWhere
@@ -77,7 +77,7 @@ postAPriosR tid ssh ash = do
                E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (E.val aId)
       return (matrSunk, matrMissing)
 
-    when (matrSunk > 0) $ 
+    when (matrSunk > 0) $
       addMessageI Success $ MsgAllocationPrioritiesSunk matrSunk
     when (matrMissing > 0) $
       addMessageI Error $ MsgAllocationPrioritiesMissing matrMissing

src/Handler/Allocation/Register.hs

@@ -46,7 +46,7 @@ postARegisterR tid ssh ash = do
   formResult registerRes $ \AllocationRegisterForm{..} -> runDB $ do
     aId <- getKeyBy404 $ TermSchoolAllocationShort tid ssh ash
     isRegistered <- existsBy $ UniqueAllocationUser aId uid
-    void $ upsert AllocationUser 
+    void $ upsert AllocationUser
       { allocationUserAllocation = aId
       , allocationUserUser = uid
       , allocationUserTotalCourses = arfTotalCourses
@@ -57,5 +57,5 @@ postARegisterR tid ssh ash = do
     if
       | isRegistered -> addMessageI Success MsgAllocationRegistrationEdited
       | otherwise -> addMessageI Success MsgAllocationRegistered
-  
+
   redirect $ AllocationR tid ssh ash AShowR :#: ("allocation-participation" :: Text)

src/Handler/Allocation/Show.hs

@@ -7,7 +7,7 @@ import Import
 import Utils.Course
 
 import Handler.Utils
-  
+
 import Handler.Allocation.Register
 import Handler.Allocation.Application
 

src/Handler/Allocation/Users.hs

@@ -63,11 +63,11 @@ type UserTableData = DBRow ( Entity User
                            , Int -- ^ Applied
                            , Int -- ^ Assigned
                            , Int -- ^ Vetoed
-                           )                          
+                           )
 
 resultUser :: Lens' UserTableData (Entity User)
 resultUser = _dbrOutput . _1
-  
+
 resultAllocationUser :: Lens' UserTableData (Entity AllocationUser)
 resultAllocationUser = _dbrOutput . _2
 
@@ -83,7 +83,7 @@ data AllocationUserTableCsv = AllocationUserTableCsv
   , csvAUserName          :: Text
   , csvAUserMatriculation :: Maybe Text
   , csvAUserRequested
-  , csvAUserApplied   
+  , csvAUserApplied
   , csvAUserVetos
   , csvAUserAssigned      :: Natural
   , csvAUserPriority      :: Maybe AllocationPriority
@@ -94,10 +94,10 @@ allocationUserTableCsvOptions :: Csv.Options
 allocationUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3}
 
 instance Csv.ToNamedRecord AllocationUserTableCsv where
-  toNamedRecord = Csv.genericToNamedRecord allocationUserTableCsvOptions 
+  toNamedRecord = Csv.genericToNamedRecord allocationUserTableCsvOptions
 
 instance Csv.DefaultOrdered AllocationUserTableCsv where
-  headerOrder = Csv.genericHeaderOrder allocationUserTableCsvOptions 
+  headerOrder = Csv.genericHeaderOrder allocationUserTableCsvOptions
 
 instance CsvColumnsExplained AllocationUserTableCsv where
   csvColumnsExplanations = genericCsvColumnsExplanations allocationUserTableCsvOptions $ mconcat

src/Handler/Course/Application/Files.hs

@@ -42,7 +42,7 @@ getCAppsFilesR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
 getCAppsFilesR tid ssh csh = do
   runDB . existsBy404 $ TermSchoolCourseShort tid ssh csh
   MsgRenderer mr <- getMsgRenderer
-  
+
   archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseAllApplicationsArchiveName tid ssh csh
 
   let
@@ -61,12 +61,12 @@ getCAppsFilesR tid ssh csh = do
         hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR
       let
         applicationAllocs = setOf (folded . _1) apps'
-        
+
         allocations = applicationAllocs ^.. folded . _Just . _entityVal . $(multifocusG 3) _allocationTerm _allocationSchool _allocationShorthand
 
         allEqualOn :: Eq x => Getter _ x -> Bool
         allEqualOn l = maybe True (\x -> allOf (folded . l) (== x) allocations) (allocations ^? _head . l)
-        
+
         mkAllocationDir mbAlloc
           | not $ allEqualOn _1
           , Just Allocation{..} <- mbAlloc
@@ -92,7 +92,7 @@ getCAppsFilesR tid ssh csh = do
             fileEntitySource = E.selectSource . E.from $ \courseApplicationFile -> do
               E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId
               return courseApplicationFile
-        
+
         yield $ _FileReference # ( FileReference
                                    { fileReferenceModified = courseApplicationTime
                                    , fileReferenceTitle = mkAppDir ""

src/Handler/Course/Application/List.hs

@@ -47,7 +47,7 @@ type CourseApplicationsTableData = DBRow ( Entity CourseApplication
                                          , Maybe (Entity StudyDegree)
                                          , Bool -- isParticipant
                                          )
-  
+
 courseApplicationsIdent :: Text
 courseApplicationsIdent = "applications"
 
@@ -120,7 +120,7 @@ instance Csv.FromField CourseApplicationsTableVeto where
     (CI.map Text.strip -> t :: CI Text) <- Csv.parseField f
     return . CourseApplicationsTableVeto $ elem t
       [ "veto", "v", "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ]
-  
+
 data CourseApplicationsTableCsv = CourseApplicationsTableCsv
   { csvCAAllocation :: Maybe AllocationShorthand
   , csvCAApplication :: Maybe CryptoFileNameCourseApplication
@@ -223,7 +223,7 @@ instance Exception CourseApplicationsTableCsvException
 
 embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvException id
 
-  
+
 data ButtonAcceptApplications = BtnAcceptApplications
   deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
 instance Universe ButtonAcceptApplications
@@ -277,7 +277,7 @@ postCApplicationsR tid ssh csh = do
       applicationLink appId = liftHandler $ do
         cID <- encrypt appId
         return . SomeRoute $ CApplicationR tid ssh csh cID CAEditR
-      
+
       dbtSQLQuery :: CourseApplicationsTableExpr -> E.SqlQuery _
       dbtSQLQuery = runReaderT $ do
         courseApplication <- view queryCourseApplication
@@ -415,13 +415,13 @@ postCApplicationsR tid ssh csh = do
               -> return () -- no addition
             DBCsvDiffExisting{..} -> do
               let appId = dbCsvOld ^. resultCourseApplication . _entityKey
-              
+
               newFeatures <- lift $ lookupStudyFeatures dbCsvNew
               when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $
                 yield $ CourseApplicationsTableCsvSetFieldData appId newFeatures
 
               let mVeto = dbCsvNew ^? _csvCAVeto . _Just . _CourseApplicationsTableVeto
-              whenIsJust mVeto $ \veto -> 
+              whenIsJust mVeto $ \veto ->
                 when (veto /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingVeto) $
                   yield $ CourseApplicationsTableCsvSetVetoData appId veto
 
@@ -638,7 +638,7 @@ postCApplicationsR tid ssh csh = do
   let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle
       registrationOpen = maybe True (now <)
 
-  
+
   ((acceptRes, acceptWgt'), acceptEnc) <- runFormPost . identifyForm BtnAcceptApplications . renderAForm FormStandard $
     (,) <$> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsMode & setTooltip MsgAcceptApplicationsModeTip) (Just AcceptApplicationsInvite)
         <*> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsSecondary & setTooltip MsgAcceptApplicationsSecondaryTip) (Just AcceptApplicationsSecondaryTime)
@@ -679,7 +679,7 @@ postCApplicationsR tid ssh csh = do
             AcceptApplicationsSecondaryRandom
               -> comparing $ view   ratingL
         sortedApplications <- unstableSortBy cmp applications
-  
+
         let applicants = sortedApplications
                        & nubOn (view $ _1 . _entityKey)
                        & maybe id take openCapacity
@@ -687,7 +687,7 @@ postCApplicationsR tid ssh csh = do
                                   AcceptApplicationsDirect -> folded . _1 . _entityKey . to Right
                                   AcceptApplicationsInvite -> folded . _1 . _entityVal . _userEmail . to Left
                                )
-  
+
         mapM_ addMessage' <=< execWriterT $ registerUsers cid applicants
       redirect $ CourseR tid ssh csh CUsersR
 

src/Handler/Course/Communication.hs

@@ -94,7 +94,7 @@ postCCommR tid ssh csh = do
               E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val cid
                    E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
                    E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
-            return user  
+            return user
         )
       ] ++ tuts ++ exams ++ sheets
     , crRecipientAuth = Just $ \uid -> do

src/Handler/Course/Edit.hs

@@ -92,7 +92,7 @@ courseToForm cEnt@(Entity cid Course{..}) lecs lecInvites alloc = CourseForm
       where selectAppFiles = E.selectSource . E.from $ \courseAppInstructionFile -> do
               E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
               return courseAppInstructionFile
-      
+
 
 allocationCourseToForm :: Entity Course -> Entity AllocationCourse -> AllocationCourseForm
 allocationCourseToForm (Entity _ Course{..}) (Entity _ AllocationCourse{..}) = AllocationCourseForm
@@ -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)
-                   , (Just . toMidnight     . termStart . entityVal) <$> mbLastTerm
-                   , (Just . beforeMidnight . termEnd   . entityVal) <$> mbLastTerm
-                   , (Just . beforeMidnight . termEnd   . entityVal) <$> mbLastTerm )
+            return ( Just $ Just now
+                   , Just . toMidnight     . termStart . entityVal <$> mbLastTerm
+                   , Just . beforeMidnight . termEnd   . entityVal <$> mbLastTerm
+                   , Just . beforeMidnight . termEnd   . entityVal <$> mbLastTerm
+                   )
 
     let
       allocationForm :: AForm Handler (Maybe AllocationCourseForm)
@@ -214,7 +215,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
                 E.exists . E.from $ \allocationCourse ->
                   E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. E.val cid
                        E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId
-    
+
           E.where_ $ term E.^. TermActive
                E.||. alreadyParticipates
                E.||. allocation E.^. AllocationSchool `E.in_` E.valList adminSchools
@@ -243,8 +244,8 @@ 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
                     ainp
@@ -265,8 +266,8 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
     multipleTermsMsg <- messageI Warning MsgCourseSemesterMultipleTip
 
     (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
-      <$> pure (cfCourseId =<< template)
-      <*> areq (textField & cfStrip & cfCI) (fslI MsgCourseName)                             (cfName       <$> template)
+          (cfCourseId =<< 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/Events/Delete.hs

@@ -8,13 +8,13 @@ import Handler.Utils.Occurrences
 import Handler.Utils.Delete
 
 import qualified Data.Set as Set
-  
+
 
 getCEvDeleteR, postCEvDeleteR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseEvent -> Handler Html
 getCEvDeleteR = postCEvDeleteR
 postCEvDeleteR tid ssh csh cID = do
   nId <- decrypt cID
-  
+
   let
     drRecords :: Set (Key CourseEvent)
     drRecords = Set.singleton nId
@@ -31,23 +31,23 @@ postCEvDeleteR tid ssh csh cID = do
         :
         ^{occurrencesWidget courseEventTime}
       |]
-  
+
     drRecordConfirmString :: Entity CourseEvent -> DB Text
     drRecordConfirmString _ = return ""
-  
+
     drCaption, drSuccessMessage :: SomeMessage UniWorX
     drCaption = SomeMessage MsgCourseEventDeleteQuestion
     drSuccessMessage = SomeMessage MsgCourseEventDeleted
-  
+
     drAbort, drSuccess :: SomeRoute UniWorX
     drAbort = SomeRoute $ CourseR tid ssh csh CShowR :#: [st|event-#{toPathPiece cID}|]
     drSuccess = SomeRoute $ CourseR tid ssh csh CShowR
-  
+
     drFormMessage :: [Entity CourseEvent] -> DB (Maybe Message)
     drFormMessage _ = return Nothing
-  
+
     drDelete :: forall a. CourseEventId -> JobDB a -> JobDB a
     drDelete _ = id
-  
+
   deleteR DeleteRoute{..}
 

src/Handler/Course/Events/Edit.hs

@@ -4,7 +4,7 @@ module Handler.Course.Events.Edit
 
 import Import
 import Handler.Utils
-  
+
 import Handler.Course.Events.Form
 
 

src/Handler/Course/Events/Form.hs

@@ -31,7 +31,7 @@ courseEventForm template = identifyForm FIDCourseEvent . renderWForm FormStandar
     )
   let courseEventTypes = optionsPairs [ (courseEventType, courseEventType) | Entity _ CourseEvent{..} <- existingEvents ]
       courseEventRooms = optionsPairs [ (courseEventRoom, courseEventRoom) | Entity _ CourseEvent{..} <- existingEvents ]
-  
+
   cefType' <- wreq (textField & cfStrip & cfCI & addDatalist courseEventTypes) (fslI MsgCourseEventType & addPlaceholder (mr MsgCourseEventTypePlaceholder)) (cefType <$> template)
   cefRoom' <- wreq (textField & cfStrip & addDatalist courseEventRooms) (fslI MsgCourseEventRoom) (cefRoom <$> template)
   cefTime' <- aFormToWForm $ occurrencesAForm ("time" :: Text) (cefTime <$> template)

src/Handler/Course/Events/New.hs

@@ -4,7 +4,7 @@ module Handler.Course.Events.New
 
 import Import
 import Handler.Utils
-  
+
 import Handler.Course.Events.Form
 
 getCEventsNewR, postCEventsNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html

src/Handler/Course/News/Delete.hs

@@ -12,7 +12,7 @@ getCNDeleteR, postCNDeleteR :: TermId -> SchoolId -> CourseShorthand -> CryptoUU
 getCNDeleteR = postCNDeleteR
 postCNDeleteR tid ssh csh cID = do
   nId <- decrypt cID
-  
+
   let
     drRecords :: Set (Key CourseNews)
     drRecords = Set.singleton nId
@@ -26,22 +26,22 @@ postCNDeleteR tid ssh csh cID = do
         [ toWidget <$> courseNewsTitle
         , toWidget <$> courseNewsSummary
         ]
-  
+
     drRecordConfirmString :: Entity CourseNews -> DB Text
     drRecordConfirmString _ = return ""
-  
+
     drCaption, drSuccessMessage :: SomeMessage UniWorX
     drCaption = SomeMessage MsgCourseNewsDeleteQuestion
     drSuccessMessage = SomeMessage MsgCourseNewsDeleted
-  
+
     drAbort, drSuccess :: SomeRoute UniWorX
     drAbort = SomeRoute $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
     drSuccess = SomeRoute $ CourseR tid ssh csh CShowR
 
     drFormMessage :: [Entity CourseNews] -> DB (Maybe Message)
     drFormMessage _ = return Nothing
-  
+
     drDelete :: forall a. CourseNewsId -> JobDB a -> JobDB a
     drDelete _ = id
-  
+
   deleteR DeleteRoute{..}

src/Handler/Course/News/Download.hs

@@ -25,7 +25,7 @@ getCNArchiveR tid ssh csh cID = do
 
   serveSomeFiles archiveName getFilesQuery
 
-  
+
 getCNFileR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> FilePath -> Handler TypedContent
 getCNFileR _ _ _ cID title = do
   nId <- decrypt cID

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 ]
-       in void . replaceFileReferences mkFilter (CourseNewsFileResidual nId) $ traverse_ id cnfFiles
+      let mkFilter CourseNewsFileResidual{} = [ CourseNewsFileNews ==. nId ]
+       in void . replaceFileReferences mkFilter (CourseNewsFileResidual nId) $ sequence_ cnfFiles
     addMessageI Success MsgCourseNewsEdited
     redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
 

src/Handler/Course/News/Form.hs

@@ -16,7 +16,7 @@ data CourseNewsForm = CourseNewsForm
   , cnfContent          :: Html
   , cnfParticipantsOnly :: Bool
   , cnfVisibleFrom      :: Maybe UTCTime
-  , cnfFiles            :: Maybe FileUploads 
+  , cnfFiles            :: Maybe FileUploads
   }
 
 courseNewsForm :: Maybe CourseNewsForm -> Form CourseNewsForm

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
@@ -138,7 +138,7 @@ postCAddUserR tid ssh csh = do
 
     formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $
       hoist runDBJobs . registerUsers' cid
-      
+
 
     let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
 
@@ -169,7 +169,7 @@ addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
                               => AddParticipantsResult
                               -> ReaderT (YesodPersistBackend UniWorX) m [Message]
 addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do
-  (aurAlreadyRegistered', aurNoUniquePrimaryField') <- 
+  (aurAlreadyRegistered', aurNoUniquePrimaryField') <-
     (,) <$> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurAlreadyRegistered)
         <*> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurNoUniquePrimaryField)
 

src/Handler/Course/Register.hs

@@ -69,7 +69,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
       isRegistered = btn `elem` [BtnCourseRetractApplication, BtnCourseDeregister]
   return . (, btn) . wFormToAForm $ do
     MsgRenderer mr <- getMsgRenderer
-    
+
     secretRes <- if
       | Just secret <- courseRegisterSecret
       , not isRegistered
@@ -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
@@ -171,7 +171,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
       <*> appTextRes
       <*> appFilesRes
 
- 
+
 -- | Workaround for klicking register button without being logged in.
 -- After log in, the user sees a "get request not supported" error.
 getCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@@ -212,8 +212,8 @@ postCRegisterR tid ssh csh = do
 
                 return $ Just prevId
 
-            whenIsJust appRes $ 
-              audit . TransactionCourseApplicationEdit cid uid 
+            whenIsJust appRes $
+              audit . TransactionCourseApplicationEdit cid uid
             whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do
               runConduit $ transPipe liftHandler fSource .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
             return appRes
@@ -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
 
@@ -300,7 +300,7 @@ deregisterParticipant uid cid = do
   forM_ examRegistrations $ \(Entity erId ExamRegistration{..}) -> do
     delete erId
     audit $ TransactionExamDeregister examRegistrationExam uid
-  
+
   E.delete . E.from $ \tutorialParticipant -> do
     let tutorialCourse = E.subSelectForeign tutorialParticipant TutorialParticipantTutorial (E.^. TutorialCourse)
 

src/Handler/Course/Show.hs

@@ -109,12 +109,11 @@ getCShowR tid ssh csh = do
     return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen)
 
   let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course
-  mDereg <- traverse (formatTime SelFormatDateTime) mDereg' 
+  mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
 
   cID <- encrypt cid :: Handler CryptoUUIDCourse
-  mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (,)
-    <$> pure alloc
-    <*> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
+  mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (alloc, )
+    <$> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
   regForm <- if
     | is _Just mbAid -> do
         (courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course)
@@ -127,9 +126,9 @@ getCShowR tid ssh csh = do
     | otherwise
       -> return . modal $(widgetFile "course/login-to-register") . Left . SomeRoute $ AuthR LoginR
   registrationOpen <- hasWriteAccessTo $ CourseR tid ssh csh CRegisterR
-  
+
   MsgRenderer mr <- getMsgRenderer
-  
+
   let
     tutorialDBTable = DBTable{..}
       where

src/Handler/Course/User.hs

@@ -60,7 +60,7 @@ postCUserR tid ssh csh uCId = do
     registered <- exists [ CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive ]
 
     return (course, Entity uid user, registered)
-  
+
   sections <- mapM (runMaybeT . ($ user) . ($ course))
     [ courseUserProfileSection
     , courseUserNoteSection
@@ -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' ]
@@ -202,11 +202,11 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex =
 
   return $(widgetFile "course/user/profile")
 
-      
+
 courseUserNoteSection :: Entity Course -> Entity User -> MaybeT Handler Widget
 courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do
   guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CUsersR
-  
+
   currentRoute <- MaybeT getCurrentRoute
 
   (thisUniqueNote, noteText, noteEdits) <- lift . runDB $ do
@@ -306,7 +306,7 @@ courseUserExamsSection (Entity cid Course{..}) (Entity uid _) = do
   guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CExamNewR
 
   uCID <- encrypt uid
-  
+
   let
     examDBTable = DBTable{..}
       where

src/Handler/Course/Users.hs

@@ -139,7 +139,7 @@ _userSheets = _dbrOutput . _8
 
 colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
 colUserComment tid ssh csh =
-    sortable (Just "note") (i18nCell MsgCourseUserNote) $ views (_dbrOutput . $(multifocusG 2) (_1 . _entityKey) _3) $ \(uid, mbNoteKey) -> 
+    sortable (Just "note") (i18nCell MsgCourseUserNote) $ views (_dbrOutput . $(multifocusG 2) (_1 . _entityKey) _3) $ \(uid, mbNoteKey) ->
                                                                                                                            maybeEmpty mbNoteKey $ const $
          anchorCellM (courseLink <$> encrypt uid) (hasComment True)
   where
@@ -191,15 +191,15 @@ colUserSubmissionGroup = sortable (Just "submission-group") (i18nCell MsgSubmiss
 colUserSheets :: forall m c. IsDBTable m c => [SheetName] -> Cornice Sortable ('Cap 'Base) UserTableData (DBCell m c)
 colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns
   where
-    caption = i18nCell MsgCourseUserSheets 
+    caption = i18nCell MsgCourseUserSheets
       & cellAttrs <>~ [ ("uw-hide-column-header", "sheets")
                       , ("uw-hide-column-default-hidden", "")
                       ]
-    
+
     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
 
 
@@ -210,7 +210,7 @@ data UserTableCsvStudyFeature = UserTableCsvStudyFeature
   , csvUserType :: StudyFieldType
   } deriving (Eq, Ord, Read, Show, Generic, Typeable)
 makeLenses_ ''UserTableCsvStudyFeature
-  
+
 data UserTableCsv = UserTableCsv
   { csvUserName :: Text
   , csvUserSex :: Maybe Sex
@@ -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-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
-          , single $ ("field"       , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsName))
-          , single $ ("field-short" , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsShorthand))
-          , single $ ("semesternr"  , SortColumn $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
-          , single $ ("registration", SortColumn $ queryParticipant    >>> (E.^. CourseParticipantRegistration))
-          , single $ ("note"        , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
+          , single ("degree"      , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
+          , single ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
+          , single ("field"       , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsName))
+          , single ("field-short" , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsShorthand))
+          , single ("semesternr"  , SortColumn $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
+          , single ("registration", SortColumn $ queryParticipant    >>> (E.^. CourseParticipantRegistration))
+          , 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 $ ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
+          , single ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
+          , single ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
           , mconcat
             [ single ( SortingKey $ "sheet-" <> sheetName
                      , SortColumn $ \(queryUser -> user) -> E.subSelectMaybe . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
@@ -438,8 +438,8 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
                          E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
                          E.where_ $ submission E.^. SubmissionSheet E.==. E.val shId
                          return $ submission E.^. SubmissionRatingPoints
-                         
-                     ) 
+
+                     )
             | Entity shId Sheet{..} <- sheets
             ]
           ]
@@ -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-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
-          , single $ ("field-key"   , FilterColumn $ E.mkExactFilter    $ queryFeaturesField >>> (E.?. StudyTermsKey))
-          , single $ ("field"       , FilterColumn $ E.anyFilter
+          , single ("field-name"  , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
+          , single ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
+          , single ("field-key"   , FilterColumn $ E.mkExactFilter    $ queryFeaturesField >>> (E.?. StudyTermsKey))
+          , 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 $ ("tutorial"    , FilterColumn $ E.mkExistsFilter   $ \row criterion ->
+          , single ("semesternr"  , FilterColumn $ E.mkExactFilter    $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
+          , 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 $ ("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
-                       -> E.exists . E.from $ \(psFile `E.InnerJoin` sheet) -> do
-                            E.on $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
-                            E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. queryParticipant t E.^. CourseParticipantUser
-                            E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
-                                 E.&&. sheet E.^. SheetName E.==. E.val shn
-                     )
+          , single ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
+          , 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
+                     -> E.exists . E.from $ \(psFile `E.InnerJoin` sheet) -> do
+                          E.on $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
+                          E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. queryParticipant t E.^. CourseParticipantUser
+                          E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
+                               E.&&. sheet E.^. SheetName E.==. E.val shn
+                   )
           ]
           where single = uncurry Map.singleton
         dbtFilterUI mPrev = mconcat $
@@ -525,7 +525,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
             { dbtCsvExportForm = UserCsvExportData
                 <$> apopt checkBoxField (fslI MsgUserSimplifiedFeaturesOfStudyCsv & setTooltip MsgUserSimplifiedFeaturesOfStudyCsvTip) (Just $ csvUserSimplifiedFeaturesOfStudy def)
                 <*> apopt checkBoxField (fslI MsgCourseUserCsvIncludeSheets & setTooltip MsgCourseUserCsvIncludeSheetsTip) (Just $ csvUserIncludeSheets def)
-            , dbtCsvDoEncode = \UserCsvExportData{..} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $ 
+            , dbtCsvDoEncode = \UserCsvExportData{..} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $
                 UserTableCsv
                   <$> view (hasUser . _userDisplayName)
                   <*> view (hasUser . _userSex)
@@ -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)
@@ -726,7 +726,7 @@ postCUsersR tid ssh csh = do
         addMessageI Success $ MsgCourseUsersDeregistered nrDel
         redirect $ CourseR tid ssh csh CUsersR
     (CourseUserRegisterTutorialData{..}, selectedUsers) -> do
-        runDB . forM_ selectedUsers $ 
+        runDB . forM_ selectedUsers $
           void . insertUnique . TutorialParticipant registerTutorial
         addMessageI Success . MsgCourseUsersTutorialRegistered . fromIntegral $ Set.size selectedUsers
         redirect $ CourseR tid ssh csh CUsersR
@@ -767,7 +767,7 @@ postCUsersR tid ssh csh = do
           ]
           [ CourseParticipantState =. CourseParticipantActive
           , CourseParticipantRegistration =. now
-          , CourseParticipantAllocated =. Nothing 
+          , CourseParticipantAllocated =. Nothing
           ]
         guard $ didUpdate > 0
         lift $ deleteWhere [ AllocationDeregisterCourse ==. Just cid, AllocationDeregisterUser ==. uid ]

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
@@ -62,7 +64,7 @@ instance (CryptoRoute ciphertext plaintext, Dispatch ciphertext ps) => Dispatch
           handleCryptoID :: CryptoIDError -> Handler (Maybe a)
           handleCryptoID _ = return Nothing
       dispatchTail = dispatchID (Proxy :: Proxy ps) ciphertext
-  
+
 
 getCryptoUUIDDispatchR :: UUID -> Handler ()
 getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectAccessWith movedPermanently301)
@@ -75,5 +77,5 @@ getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectAcce
 getCryptoFileNameDispatchR :: CI FilePath -> Handler ()
 getCryptoFileNameDispatchR path = dispatchID p path >>= maybe notFound (redirectAccessWith movedPermanently301)
   where
-    p :: Proxy '[ SubmissionId ] 
+    p :: Proxy '[ SubmissionId ]
     p = Proxy

src/Handler/Exam/AddUser.hs

@@ -8,15 +8,15 @@ import Handler.Exam.RegistrationInvite
 import Handler.Utils
 import Handler.Utils.Exam
 import Handler.Utils.Invitations
-  
+
 import qualified Data.Set as Set
 
 import Data.Semigroup (Option(..))
-  
+
 import Control.Monad.Error.Class (MonadError(..))
 
 import Jobs.Queue
-  
+
 import Generics.Deriving.Monoid
 
 
@@ -43,7 +43,7 @@ postEAddUserR tid ssh csh examn = do
     ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
       now <- liftIO getCurrentTime
       occurrences <- liftHandler . runDB $ selectList [ExamOccurrenceExam ==. eid] []
-      
+
       let
         localNow = utcToLocalTime now
         tomorrowEndOfDay = case localTimeToUTC (LocalTime (addDays 2 $ localDay localNow) midnight) of
@@ -65,7 +65,7 @@ postEAddUserR tid ssh csh examn = do
           = max tomorrowEndOfDay earliestDate'
           | otherwise
           = tomorrowEndOfDay
-          
+
       deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline)
       enlist <- wpopt checkBoxField (fslI MsgExamRegistrationEnlistDirectly & setTooltip MsgExamRegistrationEnlistDirectlyTip) (Just False)
       registerCourse <- wpopt checkBoxField (fslI MsgExamRegistrationRegisterCourse & setTooltip MsgExamRegistrationRegisterCourseTip) (Just False)
@@ -132,7 +132,7 @@ postEAddUserR tid ssh csh examn = do
         lift $ lift examRegister
         throwError $ mempty { aurSuccess = pure userEmail }
 
-      unless registerCourse $ 
+      unless registerCourse $
         throwError $ mempty { aurNoCourseRegistration = pure userEmail }
 
       guardAuthResult =<< lift (lift $ evalAccessDB (CourseR tid ssh csh CAddUserR) True)

src/Handler/Exam/AutoOccurrence.hs

@@ -52,7 +52,7 @@ examAutoOccurrenceCalculateForm :: ExamAutoOccurrenceCalculateForm -> Form ExamA
 examAutoOccurrenceCalculateForm ExamAutoOccurrenceCalculateForm{ eaofConfig }
   = identifyForm FIDExamAutoOccurrenceCalculate . renderAForm FormStandard $ ExamAutoOccurrenceCalculateForm <$> eaocForm
   where
-    eaocForm = 
+    eaocForm =
       (set _eaocMinimizeRooms <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just $ eaofConfig ^. _eaocMinimizeRooms))
       <*> pure def
 
@@ -62,7 +62,7 @@ examAutoOccurrenceNudgeForm occId protoForm html = do
   (btnRes, wgt) <- identifyForm (FIDExamAutoOccurrenceNudge $ ciphertext cID) (buttonForm' [BtnExamAutoOccurrenceNudgeUp, BtnExamAutoOccurrenceNudgeDown]) html
   oldDataRes <- globalPostParamField PostExamAutoOccurrencePrevious secretJsonField
   oldDataId <- newIdent
-  
+
   let protoForm' = fromMaybe def $ oldDataRes <|> protoForm
       genForm btn = protoForm' & _eaofConfig . _eaocNudge %~ Map.insertWith (+) occId n
         where n = case btn of
@@ -83,12 +83,12 @@ examAutoOccurrenceAcceptForm confirmData = identifyForm FIDExamAutoOccurrenceCon
 examAutoOccurrenceCalculateWidget :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Widget
 examAutoOccurrenceCalculateWidget tid ssh csh examn = do
   (formView, formEncoding) <- liftHandler . generateFormPost $ examAutoOccurrenceCalculateForm def
-  
+
   wrapForm' BtnExamAutoOccurrenceCalculate $(i18nWidgetFile "exam-auto-occurrence-calculate") def
     { formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR
     , formEncoding
     }
-      
+
 
 postEAutoOccurrenceR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
 postEAutoOccurrenceR tid ssh csh examn = do
@@ -96,8 +96,8 @@ postEAutoOccurrenceR tid ssh csh examn = do
     exam@(Entity eId _) <- fetchExam tid ssh csh examn
     occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [ Asc ExamOccurrenceName ]
     return (exam, occurrences)
-  
-  
+
+
   ((calculateRes, _), _) <- runFormPost $ examAutoOccurrenceCalculateForm def
 
   nudgeRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId ->

src/Handler/Exam/Correct.hs

@@ -36,15 +36,15 @@ getECorrectR tid ssh csh examn = do
     return (exam, entityVal <$> examParts)
 
   mayEditResults <- hasWriteAccessTo $ CExamR tid ssh csh examn EUsersR
-  
+
   let
     heading = prependCourseTitle tid ssh csh $ (mr . MsgExamCorrectHeading . CI.original) examName
-    
+
     ptsInput :: ExamPartNumber -> Widget
     ptsInput n = do
       name <- newIdent
       fieldView (pointsField :: Field Handler Points) ("exam-correct__" <> toPathPiece n) name [("uw-exam-correct--part-input", toPathPiece n)] (Left "") False
-    
+
     examGrades :: [ExamGrade]
     examGrades = universeF
 
@@ -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) $ 
@@ -131,7 +131,7 @@ postECorrectR tid ssh csh examn = do
                          in CorrectInterfaceResponseFailure
                               <$> (Just <$> userToResponse match)
                               <*> (getMessageRender <*> pure msg)
-                      
+
                       newExamPartResult <- lift $ upsert ExamPartResult
                         { examPartResultExamPart    = examPartId
                         , examPartResultUser        = uid
@@ -173,7 +173,7 @@ postECorrectR tid ssh csh examn = do
                   return $ newResult ^? _entityVal . _examResultResult
                 | otherwise -> return $ mOldResult ^? _Just . _entityVal . _examResultResult
             | otherwise -> return Nothing
-              
+
         user <- userToResponse match
         return CorrectInterfaceResponseSuccess
           { cirsUser    = user

src/Handler/Exam/CorrectorInvite.hs

@@ -18,7 +18,7 @@ import Data.Aeson hiding (Result(..))
 
 import qualified Data.HashSet as HashSet
 
-  
+
 instance IsInvitableJunction ExamCorrector where
   type InvitationFor ExamCorrector = Exam
   data InvitableJunction ExamCorrector = JunctionExamCorrector

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
@@ -201,7 +201,7 @@ examPartsForm prev = wFormToAForm $ do
   fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts) False $ Set.toList <$> prev
   where
     examPartForm' nudge mPrev csrf = do
-      (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)  
+      (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)
       (epfNumberRes, epfNumberView) <- mpreq (isoField (from _ExamPartNumber) $ textField & cfStrip & cfCI) (fslI MsgExamPartNumber & addName (nudge "number") & addPlaceholder "1, 6a, 3.1.4, ...") (epfNumber <$> mPrev)
       (epfNameRes, epfNameView) <- mopt (textField & cfStrip & cfCI) (fslI MsgExamPartName & addName (nudge "name")) (epfName <$> mPrev)
       (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField (fslI MsgExamPartMaxPoints & addName (nudge "max-points")) (epfMaxPoints <$> mPrev)
@@ -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 MsgExamFinishedMustBeAfterStart                          . fromMaybe True $ (>=) <$> efFinished <*> efStart
+  guardValidation MsgExamFinishedMustBeAfterEnd   $ Just False /= ((>=) <$> efFinished <*> efEnd)
+  guardValidation MsgExamFinishedMustBeAfterStart $ Just False /= ((>=) <$> efFinished <*> efStart)
 
   forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
     guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName)       $ NTop eofEnd >= NTop (Just eofStart)

src/Handler/Exam/List.hs

@@ -6,7 +6,7 @@ module Handler.Exam.List
 import Import
 
 import Handler.Utils
-  
+
 import qualified Data.Map as Map
 
 import qualified Database.Esqueleto as E
@@ -75,16 +75,15 @@ mkExamTable (Entity cid Course{..}) = do
     examDBTableValidator = def
       & defaultSorting [SortAscBy "time"]
       & forceFilter "may-read" (Any True)
-  
+
   dbTable examDBTableValidator examDBTable
 
 
 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
-    return (c, examTable)
+    view _2 <$> mkExamTable c
 
   siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do
     setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading

src/Handler/Exam/New.hs

@@ -12,7 +12,7 @@ import Handler.Utils
 import Handler.Utils.Invitations
 
 import Jobs.Queue
-  
+
 import qualified Data.Conduit.Combinators as C
 
 
@@ -29,7 +29,7 @@ postCExamNewR tid ssh csh = do
   formResult newExamResult $ \ExamForm{..} -> do
     insertRes <- runDBJobs $ do
       now <- liftIO getCurrentTime
-      
+
       insertRes <- insertUnique Exam
         { examName                         = efName
         , examCourse                       = cid
@@ -90,7 +90,7 @@ postCExamNewR tid ssh csh = do
               when didRecord $
                 audit $ TransactionExamResultEdit examid courseParticipantUser
         runConduit $ selectSource [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantInactive True ] [] .| C.mapM_ recordNoShow
-        
+
       return insertRes
     case insertRes of
       Nothing -> addMessageI Error $ MsgExamNameTaken efName

src/Handler/Exam/Register.hs

@@ -21,7 +21,7 @@ data ButtonExamRegister = BtnExamRegisterOccurrence
 instance Universe ButtonExamRegister
 instance Finite ButtonExamRegister
 nullaryPathPiece ''ButtonExamRegister $ camelToPathPiece' 2
-  
+
 instance Button UniWorX ButtonExamRegister where
   btnClasses BtnExamRegisterOccurrence = [BCIsButton, BCPrimary]
   btnClasses BtnExamSwitchOccurrence   = [BCIsButton, BCPrimary]
@@ -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,14 +63,14 @@ 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
-  (Entity eId Exam{..}, Entity occId ExamOccurrence{..}) <- runDB $ do
-    eexam@(Entity eId _) <- fetchExam tid ssh csh examn
-    occ <- getBy404 $ UniqueExamOccurrence eId occn
-    return (eexam, occ)
+  uid <- requireAuthId
+  (eId, occId) <- runDB $ do
+    Entity eId _ <- fetchExam tid ssh csh examn
+    occ <- getKeyBy404 $ UniqueExamOccurrence eId occn
+    return (eId, occ)
 
   ((btnResult, _), _) <- runFormPost buttonForm
-  
+
   formResult btnResult $ \case
     BtnExamDeregister -> do
       runDB $ do
@@ -89,4 +89,4 @@ postERegisterOccR tid ssh csh examn occn = do
     _other -> error "Unexpected due to definition of buttonForm'"
 
   redirect $ CExamR tid ssh csh examn EShowR
-  
+

src/Handler/Exam/RegistrationInvite.hs

@@ -16,13 +16,13 @@ import Handler.Utils.Invitations
 import qualified Data.Set as Set
 
 import Text.Hamlet (ihamlet)
-  
+
 import Data.Aeson hiding (Result(..))
 
 import Jobs.Queue
 
 import qualified Data.HashSet as HashSet
-  
+
 
 instance IsInvitableJunction ExamRegistration where
   type InvitationFor ExamRegistration = Exam
@@ -98,7 +98,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
         (False, True ) -> do
           fieldRes <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing
           return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes
-        (True , _    ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) 
+        (True , _    ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing)
     invitationInsertHook _ (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do
       whenIsJust mField $ \cpField -> do
         void $ upsert
@@ -110,7 +110,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
           ]
         queueDBJob . JobQueueNotification $ NotificationCourseRegistered examRegistrationUser examCourse
         audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser
-      
+
       let doAudit = audit $ TransactionExamRegister eid examRegistrationUser
       act <* doAudit
     invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInvitationAccepted examName

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

@@ -88,7 +88,7 @@ queryExamOccurrence = $(sqlLOJproj 6 2)
 
 queryCourseParticipant :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseParticipant))
 queryCourseParticipant = $(sqlLOJproj 2 1) . $(sqlLOJproj 6 3)
-  
+
 queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
 queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
 
@@ -184,7 +184,7 @@ csvExamPartHeader = prism' toHeader fromHeader
       review _ExamPartNumber . CI.mk <$> stripPrefix partPrefix tHdr
 
     partPrefix = "part-"
-  
+
 
 data ExamUserTableCsv = ExamUserTableCsv
   { csvEUserSurname :: Maybe Text
@@ -499,7 +499,7 @@ postEUsersR tid ssh csh examn = do
                   [ (epId, (examPart, mbRes))
                   | (Entity epId examPart, mbRes) <- rawResults
                   ]
-            
+
           dbtColonnade = mconcat $ catMaybes
             [ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey)
             , pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
@@ -508,7 +508,7 @@ postEUsersR tid ssh csh examn = do
             , pure $ colDegreeShort      resultStudyDegree
             , pure $ colFeaturesSemester resultStudyFeatures
             , pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence
-            , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> 
+            , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) ->
                 let SheetGradeSummary{achievedPasses} = examBonusAchieved uid bonus
                     SheetGradeSummary{numSheetsPasses} = examBonusPossible uid bonus
                  in propCell (getSum achievedPasses) (getSum numSheetsPasses)
@@ -517,7 +517,7 @@ postEUsersR tid ssh csh examn = do
                     SheetGradeSummary{sumSheetsPoints} = examBonusPossible uid bonus
                  in propCell (getSum achievedPoints) (getSum sumSheetsPoints)
             , guardOn doBonus $ sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) . automaticCell $ resultExamBonus . _entityVal . _examBonusBonus . to Right <> resultAutomaticExamBonus' . to Left
-            , pure $ mconcat 
+            , pure $ mconcat
               [ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) $ maybe mempty i18nCell . preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult)
               | Entity epId ExamPart{..} <- sortOn (examPartNumber . entityVal) examParts
               ]
@@ -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) $
@@ -663,10 +663,10 @@ postEUsersR tid ssh csh examn = do
                   iforMOf_ (ifolded <. _Just) (csvEUserExamPartResults dbCsvNew) $ \epNumber epRes ->
                     when (epNumber `elem` examPartNumbers) $
                       yield $ ExamUserCsvSetPartResultData uid epNumber (Just epRes)
-            
+
                   when (doBonus && is _Just (join $ csvEUserBonus dbCsvNew)) $
                     yield . ExamUserCsvSetBonusData False uid . join $ csvEUserBonus dbCsvNew
-            
+
                   whenIsJust (csvEUserExamResult dbCsvNew) $ \res -> do
                     yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
                     guardResultKind res
@@ -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)
@@ -703,7 +703,7 @@ postEUsersR tid ssh csh examn = do
                       newResult, oldResult :: Maybe ExamResultPassedGrade
                       newResult = fmap (fmap $ bool Right (Left . view passingGrade) $ is _ExamGradingGrades examGradingMode) . examGrade examVal (newBonus <|> oldBonus) =<< newResults
                       oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult')
-                  
+
                   when doBonus $
                     case newBonus of
                       _ | newBonus == oldBonus
@@ -716,7 +716,7 @@ postEUsersR tid ssh csh examn = do
                         -> yield $ ExamUserCsvSetBonusData False uid newBonus
                       Just _
                         -> yield $ ExamUserCsvSetBonusData True uid newBonus
-            
+
                   case newResult of
                     _ | csvEUserExamResult dbCsvNew == oldResult
                         -> return ()
@@ -965,12 +965,12 @@ postEUsersR tid ssh csh examn = do
                     | is (_ExamAttended . _Left) res -> ExamGradingPass
                     | otherwise -> ExamGradingGrades
                 | otherwise = return ()
-              
+
               registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget
               registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname
                 where
                   Entity _ User{..} = view resultUser $ existing ! registration
-    
+
               guessUser' :: ExamUserTableCsv -> DB (Bool, UserId)
               guessUser' ExamUserTableCsv{..} = do
                 let criteria = PredDNF $ Set.singleton $ impureNonNull $ Set.fromList $ (PLVariable <$>) $ catMaybes $
@@ -1090,7 +1090,7 @@ postEUsersR tid ssh csh examn = do
                   audit $ TransactionExamBonusEdit eId uid
                 | otherwise
                 -> return ()
-              
+
               insert_ ExamResult
                 { examResultExam = eId
                 , examResultUser = uid

src/Handler/ExamOffice/Course.hs

@@ -28,7 +28,7 @@ getCExamOfficeR = postCExamOfficeR
 postCExamOfficeR tid ssh csh = do
   uid <- requireAuthId
   isModal <- hasCustomHeader HeaderIsModal
-  
+
   (cid, optOuts, hasForced) <- runDB $ do
     cid <- getKeyBy404 (TermSchoolCourseShort tid ssh csh)
     optOuts <- selectList [ CourseUserExamOfficeOptOutCourse ==. cid, CourseUserExamOfficeOptOutUser ==. uid ] []
@@ -65,7 +65,7 @@ postCExamOfficeR tid ssh csh = do
     setTitleI MsgMenuCourseExamOffice
 
     let explanation = $(i18nWidgetFile "course-exam-office-explanation")
-  
+
     [whamlet|
       $newline never
       <section>

src/Handler/ExamOffice/Exam.hs

@@ -34,7 +34,7 @@ embedRenderMessage ''UniWorX ''ButtonCloseExam id
 instance Button UniWorX ButtonCloseExam where
   btnClasses BtnCloseExam = [BCIsButton]
 
-  
+
 examCloseWidget :: SomeRoute UniWorX -> ExamId -> Handler Widget
 examCloseWidget dest eId = do
   Exam{..} <- runDB $ get404 eId
@@ -47,7 +47,7 @@ examCloseWidget dest eId = do
 
       unless (is _Nothing examClosed) $
         invalidArgs ["Exam is already closed"]
-  
+
       runDB $ update eId [ ExamClosed =. Just now ]
       addMessageI Success MsgExamDidClose
       redirect dest
@@ -189,7 +189,7 @@ newtype ExamUserCsvExportData = ExamUserCsvExportData
   { csvEUserMarkSynchronised :: Bool
   } deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
-  
+
 -- | View a list of all users' grades that the current user has access to
 getEGradesR, postEGradesR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
 getEGradesR = postEGradesR
@@ -271,7 +271,7 @@ postEGradesR tid ssh csh examn = do
 
               E.where_ $ examResult E.^. ExamResultExam E.==. E.val eid
 
-              unless isLecturer $ 
+              unless isLecturer $
                 E.where_ $ Exam.examOfficeExamResultAuth (E.val uid) examResult
 
             return (examResult, user, occurrence, studyFeatures, studyDegree, studyField, examRegistration, isSynced)
@@ -314,9 +314,9 @@ postEGradesR tid ssh csh examn = do
               syncs' = [ Right sync | sync@(_, _, t, _) <- syncs, t >  lastChange]
                     ++ [ Left lastChange ]
                     ++ [ Right sync | sync@(_, _, t, _) <- syncs, t <= lastChange]
-              
+
               syncIcon :: Widget
-              syncIcon 
+              syncIcon
                 | not isSynced
                 , not hasSyncs
                 = mempty
@@ -324,7 +324,7 @@ postEGradesR tid ssh csh examn = do
                 = toWidget iconNotOK
                 | otherwise
                 = toWidget iconOK
-            
+
               syncsModal :: Widget
               syncsModal = $(widgetFile "exam-office/exam-result-synced")
             lift $ bool id (flip modal $ Right syncsModal) hasSyncs syncIcon

src/Handler/ExamOffice/Exams.hs

@@ -30,7 +30,7 @@ queryExam = to $ $(E.sqlIJproj 2 1) . $(E.sqlFOJproj 2 1)
 
 queryCourse :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity Course)))
 queryCourse = to $ $(E.sqlIJproj 2 2) . $(E.sqlFOJproj 2 1)
-  
+
 queryExternalExam :: Getter ExamsTableExpr (E.SqlExpr (Maybe (Entity ExternalExam)))
 queryExternalExam = to $(E.sqlFOJproj 2 2)
 
@@ -48,7 +48,7 @@ querySynchronised office = to . runReader $ do
       E.where_ $ ExternalExam.examOfficeExternalExamResultAuth office externalExamResult
       E.where_ $ ExternalExam.resultIsSynced office externalExamResult
   return $ E.maybe (E.val 0) examSynchronised (exam' E.?. ExamId) E.+. E.maybe (E.val 0) externalExamSynchronised (externalExam' E.?. ExternalExamId)
-  
+
 queryResults :: E.SqlExpr (E.Value UserId) -> Getter ExamsTableExpr (E.SqlExpr (E.Value Natural))
 queryResults office = to . runReader $ do
   exam' <- view queryExam
@@ -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)
 
 
@@ -95,7 +95,7 @@ resultResults = _dbrOutput . _3
 resultIsSynced :: Getter ExamsTableData Bool
 resultIsSynced = to $ (>=) <$> view resultSynchronised <*> view resultResults
 
-  
+
 -- | List of all exams where the current user may (in her function as
 --   exam-office) access users grades
 getEOExamsR :: Handler Html
@@ -106,15 +106,15 @@ getEOExamsR = do
   examsTable <- runDB $ do
     let
       examLink :: Course -> Exam -> SomeRoute UniWorX
-      examLink Course{..} Exam{..} 
+      examLink Course{..} Exam{..}
         = SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EGradesR
 
       courseLink :: Course -> SomeRoute UniWorX
       courseLink Course{..}
         = SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
-    
+
       externalExamLink :: ExternalExam -> SomeRoute UniWorX
-      externalExamLink ExternalExam{..} 
+      externalExamLink ExternalExam{..}
         = SomeRoute $ EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEGradesR
 
       querySynchronised' = querySynchronised $ E.val uid
@@ -150,11 +150,9 @@ getEOExamsR = do
 
             case (exam, course, externalExam) of
               (Just exam', Just course', Nothing) ->
-                (,,)
-                  <$> pure (Right (exam', course')) <*> view (_4 . _Value) <*> view (_5 . _Value)
+                (Right (exam', course'),,) <$> view (_4 . _Value) <*> view (_5 . _Value)
               (Nothing, Nothing, Just externalExam') ->
-                (,,)
-                  <$> pure (Left externalExam') <*> view (_4 . _Value) <*> view (_5 . _Value)
+                (Left externalExam',,) <$> view (_4 . _Value) <*> view (_5 . _Value)
               _other -> return $ error "Got exam & externalExam in same result"
 
 
@@ -182,7 +180,7 @@ getEOExamsR = do
                      & cellAttrs <>~ [ ("class", "heated")
                                      , ("style", [st|--hotness: #{tshow (heat results synced)}|])
                                      ]
-        
+
 
           dbtColonnade :: Colonnade Sortable _ _
           dbtColonnade = mconcat
@@ -192,7 +190,7 @@ getEOExamsR = do
                                    )
                 $ emptyOpticColonnade (resultExam . _entityVal . _examName <> resultExternalExam . _entityVal . _externalExamExamName) colExamName
             , emptyOpticColonnade (resultExam . _entityVal . $(multifocusG 2) _examStart _examEnd) colExamTime
-            , emptyOpticColonnade (resultExam . _entityVal . _examFinished) colExamFinishedOffice 
+            , emptyOpticColonnade (resultExam . _entityVal . _examFinished) colExamFinishedOffice
             , emptyOpticColonnade (resultExam . _entityVal . _examClosed) colExamClosed
             , maybeAnchorColonnade (previews (resultCourse . _entityVal) courseLink)
                 $ emptyOpticColonnade (resultCourse . _entityVal . _courseName <> resultExternalExam . _entityVal . _externalExamCourseName) colCourseName

src/Handler/ExamOffice/ExternalExam.hs

@@ -7,7 +7,7 @@ import Import
 import Handler.Utils
 
 import Handler.Utils.ExternalExam.Users
-  
+
 getEEGradesR, postEEGradesR :: TermId -> SchoolId -> CourseName -> ExamName -> Handler Html
 getEEGradesR = postEEGradesR
 postEEGradesR tid ssh coursen examn = do

src/Handler/ExamOffice/Fields.hs

@@ -11,7 +11,7 @@ import qualified Database.Esqueleto as E
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
-  
+
 data ExamOfficeFieldMode
   = EOFNotSubscribed
   | EOFSubscribed
@@ -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/ExamOffice/Users.hs

@@ -21,7 +21,7 @@ import qualified Data.Map as Map
 import Data.Map ((!), (!?))
 
 import qualified Data.HashSet as HashSet
-  
+
 
 instance IsInvitableJunction ExamOfficeUser where
   type InvitationFor ExamOfficeUser = User
@@ -84,11 +84,11 @@ examOfficeUserInvitationConfig = InvitationConfig{..}
       return $ SomeMessage MsgExamOfficeUserInvitationAccepted
     invitationUltDest _ _ = return $ SomeRoute NewsR
 
-  
+
 makeExamOfficeUsersForm :: Maybe (Set (Either UserEmail UserId)) -> Form (Set (Either UserEmail UserId))
 makeExamOfficeUsersForm template = renderWForm FormStandard $ do
   cRoute <- fromMaybe (error "makeExamOfficeUsersForm called from 404-handler") <$> getCurrentRoute
-  
+
   let
     miAdd' :: (Text -> Text)
            -> FieldView UniWorX
@@ -132,7 +132,7 @@ makeExamOfficeUsersForm template = renderWForm FormStandard $ do
     return $ map Left invitations ++ map Right knownUsers'
 
   fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired template'
-    
+
 
 -- | Manage the list of users this user (in her function as exam-office)
 --   has an interest in, i.e. that authorize her to view their grades

src/Handler/ExternalExam/Edit.hs

@@ -39,7 +39,7 @@ postEEEditR tid ssh coursen examn = do
       , eefOfficeSchools = schools
       , eefStaff         = staff
       }
-  
+
   ((examResult, examWidget'), examEnctype) <- runFormPost . externalExamForm $ Just template
 
   formResult examResult $ \ExternalExamForm{..} -> do
@@ -54,7 +54,7 @@ postEEEditR tid ssh coursen examn = do
         }
       when (is _Nothing replaceRes) $ do
         audit $ TransactionExternalExamEdit eeId
-        
+
         forM_ (eefStaff `setSymmDiff` staff) $ \change -> if
           | change `Set.member` eefStaff -> case change of
               Left invEmail -> do

src/Handler/ExternalExam/Form.hs

@@ -5,7 +5,7 @@ module Handler.ExternalExam.Form
 
 import Import
 import Handler.Utils
-  
+
 import Handler.ExternalExam.StaffInvite ()
 
 import qualified Data.Set as Set
@@ -104,7 +104,7 @@ externalExamForm template = validateForm validateExternalExam $ \html -> do
 validateExternalExam :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExternalExamForm m ()
 validateExternalExam = do
   State.modify $ \eeForm -> eeForm & over _eefOfficeSchools (Set.delete $ eeForm ^. _eefSchool)
-  
+
   ExternalExamForm{..} <- State.get
 
   isAdmin <- hasWriteAccessTo $ SchoolR eefSchool SchoolEditR

src/Handler/ExternalExam/List.hs

@@ -3,7 +3,7 @@ module Handler.ExternalExam.List
   ) where
 
 import Import
-  
+
 import Handler.Utils
 
 import qualified Database.Esqueleto as E
@@ -24,7 +24,7 @@ getEExamListR = do
 
         queryEExam = $(E.sqlIJproj 2 1)
         querySchool = $(E.sqlIJproj 2 2)
-        
+
         dbtSQLQuery (eexam `E.InnerJoin` school) = do
           E.on $ eexam E.^. ExternalExamSchool E.==. school E.^. SchoolId
           let

src/Handler/ExternalExam/New.hs

@@ -32,7 +32,7 @@ postEExamNewR = do
         }
       whenIsJust insertRes $ \eeId -> do
         audit $ TransactionExternalExamEdit eeId
-        
+
         let eefOfficeSchools' = do
               externalExamOfficeSchoolSchool <- Set.toList eefOfficeSchools
               guard $ externalExamOfficeSchoolSchool /= eefSchool
@@ -41,7 +41,7 @@ postEExamNewR = do
         insertMany_ eefOfficeSchools'
         forM_ eefOfficeSchools' $ \ExternalExamOfficeSchool{..} ->
           audit $ TransactionExternalExamOfficeSchoolEdit eeId externalExamOfficeSchoolSchool
-        
+
         let (invites, adds) = partitionEithers $ Set.toList eefStaff
             eefStaff' = do
               externalExamStaffUser <- adds
@@ -50,7 +50,7 @@ postEExamNewR = do
         insertMany_ eefStaff'
         forM_ eefStaff' $ \ExternalExamStaff{..} ->
           audit $ TransactionExternalExamStaffEdit eeId externalExamStaffUser
-        
+
         sinkInvitationsF externalExamStaffInvitationConfig $ map (, eeId, (InvDBDataExternalExamStaff, InvTokenDataExternalExamStaff)) invites
         forM_ invites $ \invEmail ->
           audit $ TransactionExternalExamStaffInviteEdit eeId invEmail

src/Handler/Help.hs

@@ -10,7 +10,7 @@ import qualified Data.Map as Map
 import qualified Data.Yaml as Yaml
 
 import qualified Control.Monad.State.Class as State
-  
+
 
 data HelpIdentOptions = HIUser | HIEmail | HIAnonymous
   deriving (Eq, Ord, Bounded, Enum, Show, Read)
@@ -58,7 +58,7 @@ helpForm mReferer mUid = renderWForm FormStandard $ do
     Nothing -> return $ pure Nothing
     Just err ->
       let prettyErr = decodeUtf8 $ Yaml.encode err
-       in optionalActionW 
+       in optionalActionW
             (err <$ aforced textareaField (fslI MsgHelpError) (Textarea prettyErr))
             (fslI MsgHelpSendLastError)
             (Just True)
@@ -69,7 +69,7 @@ helpForm mReferer mUid = renderWForm FormStandard $ do
     <*> hfSubject'
     <*> hfRequest'
     <*> hfError'
-    
+
 validateHelpForm :: FormValidator HelpForm Handler ()
 validateHelpForm = do
   HelpForm{..} <- State.get
@@ -99,7 +99,7 @@ postHelpR = do
 
     whenIsJust hfError $ \error' ->
       modifySessionJson SessionError $ assertM (/= error')
-    
+
     tell . pure =<< messageI Success MsgHelpSent
 
   defaultLayout $ do
@@ -111,5 +111,5 @@ postHelpR = do
           }
 
     mFaqs <- (>>= \(mWgt, truncated) -> (, truncated) <$> mWgt) <$> traverse (faqsWidget $ Just 5) (Just <$> mReferer)
-    
+
     $(widgetFile "help")

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,12 +48,12 @@ getInfoR = -- do
 
 getInfoLecturerR :: Handler Html
 getInfoLecturerR =
-  siteLayoutMsg' MsgInfoLecturerTitle $ do
+  siteLayoutMsg MsgInfoLecturerTitle $ do
     setTitleI MsgInfoLecturerTitle
     $(i18nWidgetFile "info-lecturer")
   where
     allocationInfo = $(i18nWidgetFile "allocation-info")
-    
+
     tooltipNew, tooltipProblem, tooltipPlanned, tooltipNewU2W :: WidgetFor UniWorX ()
     tooltipNew     = [whamlet| _{MsgLecturerInfoTooltipNew} |]
     tooltipProblem = [whamlet| _{MsgLecturerInfoTooltipProblem} |]
@@ -64,7 +64,7 @@ getInfoLecturerR =
     probFeatInline    = [whamlet| ^{iconTooltip tooltipProblem (Just IconProblem) True} |]  -- to be used inside text blocks
     plannedFeat       = [whamlet| ^{iconTooltip tooltipPlanned (Just IconPlanned) False} |]
     plannedFeatInline = [whamlet| ^{iconTooltip tooltipPlanned (Just IconPlanned) True} |]  -- to be used inside text blocks
-    
+
     -- new feature with given introduction date
     newFeat :: Integer -> Int -> Int -> WidgetFor UniWorX ()
     newFeat year month day = do
@@ -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/Material.hs

@@ -21,7 +21,7 @@ data MaterialForm = MaterialForm
       , mfType         :: Maybe (CI Text)
       , mfDescription  :: Maybe Html
       , mfVisibleFrom  :: Maybe UTCTime
-      , mfFiles        :: Maybe FileUploads 
+      , mfFiles        :: Maybe FileUploads
       }
 
 makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm
@@ -135,7 +135,7 @@ getMaterialListR tid ssh csh = do
             , ( "last-edit"    , SortColumn (E.^. MaterialLastEdit)    )
             ]
       , dbtFilter    = mconcat
-        [ singletonMap "may-access" . FilterProjected $ \(Any b) dbr 
+        [ singletonMap "may-access" . FilterProjected $ \(Any b) dbr
             -> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool
         ]
       , dbtFilterUI  = mempty
@@ -347,4 +347,4 @@ getMArchiveR tid ssh csh mnm = do
           return materialFile
 
   serveSomeFiles archiveName getMatQuery
-    
+

src/Handler/Metrics.hs

@@ -28,7 +28,7 @@ getMetricsR = selectRep $ do
         guardM . lift . existsBy $ UniqueUserGroupMember UserGroupMetrics uid
 
         encodeBearer =<< bearerToken (HashSet.singleton . Left $ toJSON UserGroupMetrics) (Just $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing
-  
+
       defaultLayout $ do
         setTitleI MsgTitleMetrics
         $(widgetFile "metrics")

src/Handler/News.hs

@@ -29,7 +29,7 @@ getNewsR = do
 
     when (is _Nothing muid) $
       notificationWidget NotificationBroad Info $(i18nWidgetFile "pitch")
-  
+
     case muid of
       Just uid -> do
         newsUpcomingExams uid
@@ -51,7 +51,7 @@ newsSystemMessages = do
       mkHideForm smId SystemMessage{..} = liftHandler $ do
         cID <- encrypt smId
         hidden <- getSystemMessageState smId <&> \UserSystemMessageState{..} -> userSystemMessageHidden > Just systemMessageLastUnhide
-  
+
         (btnView, btnEnctype) <- generateFormPost . buttonForm' $ bool [BtnSystemMessageHide] [BtnSystemMessageUnhide] hidden
         return $ wrapForm btnView def
           { formSubmit = FormNoSubmit
@@ -65,7 +65,7 @@ newsSystemMessages = do
         tell $ Any hidden
 
         return $ guardOn (not hidden || showHidden) (smId, sm, trans, hidden)
-  
+
   (messages', Any anyHidden) <- liftHandler . runDB . runConduit . C.runWriterLC $
        transPipe lift (selectKeys [] [])
     .| C.filterM (hasReadAccessTo . MessageR <=< encrypt)
@@ -87,7 +87,7 @@ newsUpcomingSheets :: UserId -> Widget
 newsUpcomingSheets uid = do
   cTime <- liftIO getCurrentTime
   let noActiveToCutoff = toMidnight . addGregorianDurationRollOver (scaleCalendarDiffDays (-1) calendarMonth) $ utctDay cTime
-    
+
   let tableData :: E.LeftOuterJoin
                         (E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet)))
                         (E.InnerJoin (E.SqlExpr (Maybe (Entity Submission))) (E.SqlExpr (Maybe (Entity SubmissionUser))))
@@ -104,12 +104,12 @@ newsUpcomingSheets uid = do
         E.on $ course     E.^. CourseId        E.==. sheet        E.^. SheetCourse
         E.on $ course     E.^. CourseId        E.==. participant  E.^. CourseParticipantCourse
 
-        let showSheetNoActiveTo = 
+        let showSheetNoActiveTo =
                     E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetActiveFrom)
               E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetVisibleFrom)
               E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetHintFrom)
               E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetSolutionFrom)
-  
+
         E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
              E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
              E.&&. E.maybe showSheetNoActiveTo (E.>=. E.val cTime) (sheet E.^. SheetActiveTo)