Merge branch 'version-bumps' into 'master'

refactor: split foundation & llvm

See merge request uni2work/uni2work!21

.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,9 @@ 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
+    - curl https://apt.llvm.org/llvm-snapshot.gpg.key | apt-key add -
-    - apt-get install -y --no-install-recommends locales-all
+    - apt update -y
-    - apt-get install openssh-client -y
+    - apt install -y --no-install-recommends locales-all openssh-client clang-9 lldb-9 lld-9 clangd-9
     - 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 +143,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 +243,8 @@ deploy:uniworx3:
   before_script:
     - rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d
     - install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list
-    - apt-get update -y
+    - apt update -y
-    - apt-get install -y --no-install-recommends openssh-client
+    - apt install -y --no-install-recommends openssh-client
     - install -v -m 0700 -d ~/.ssh
     - install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts
     - install -v -T -m 0400 ${SSH_PRIVATE_KEY_UNIWORX3} ~/.ssh/uniworx3; echo "IdentityFile ~/.ssh/uniworx3" >> ~/.ssh/config; 

package.yaml

@@ -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 -xn"
     dependencies:
       - uniworx
     when:
       - condition: flag(library-only)
         buildable: false
+    ghc-options:
+      - -threaded -rtsopts "-with-rtsopts=-N -T -xn"
   uniworxdb:
     main: Database.hs
     ghc-options:
       - -main-is Database
-      - -threaded
+      - -threaded -rtsopts "-with-rtsopts=-N -T -xn"
-      - -rtsopts "-with-rtsopts=-N -T"
     source-dirs: test
     dependencies:
       - uniworx
@@ -277,8 +277,7 @@ executables:
     main: Load.hs
     ghc-options:
       - -main-is Load
-      - -threaded
+      - -threaded -rtsopts "-with-rtsopts=-N -T -xn"
-      - -rtsopts "-with-rtsopts=-N -T -xn"
     source-dirs: load
     dependencies:
       - uniworx
@@ -312,8 +311,7 @@ tests:
       - yesod-persistent
     ghc-options:
       - -fno-warn-orphans
-      - -threaded
+      - -threaded -rtsopts "-with-rtsopts=-N -T -xn"
-      - -rtsopts "-with-rtsopts=-N -xn"
   hlint:
     main: Hlint.hs
     other-modules: []

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/Foundation/DB.hs

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

src/Foundation/I18n.hs

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

src/Foundation/Instances.hs

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

src/Foundation/Routes.hs

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

src/Foundation/SiteLayout.hs

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

src/Foundation/Type.hs

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

src/Foundation/Yesod/Auth.hs

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

src/Foundation/Yesod/ErrorHandler.hs

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

src/Foundation/Yesod/Middleware.hs

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

src/Foundation/Yesod/Persist.hs

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

src/Foundation/Yesod/Session.hs

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

src/Foundation/Yesod/StaticContent.hs

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

src/Handler/Admin.hs

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

src/Handler/Admin/Tokens.hs

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

src/Handler/CryptoIDDispatch.hs

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

src/Handler/Info.hs

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

src/Handler/Profile.hs

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

src/Handler/Sheet.hs

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

src/Handler/Sheet/Current.hs

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

src/Handler/Submission.hs

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

src/Handler/Utils.hs

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

src/Handler/Utils/Form.hs

@@ -15,8 +15,6 @@ import Handler.Utils.Pandoc
 
 import Handler.Utils.DateTime
 
-import Handler.Utils.Widgets
-
 import Handler.Utils.I18n
 
 import Handler.Utils.Files

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

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

src/Handler/Utils/Invitations.hs

@@ -44,19 +44,19 @@ class ( PersistRecordBackend junction (YesodPersistBackend UniWorX)
       , Typeable junction
       ) => IsInvitableJunction junction where
   -- | One side of the junction is always `User`; `InvitationFor junction` is the other
-  type InvitationFor       junction :: *
+  type InvitationFor       junction :: Type
   -- | `junction` without `Key User` and `Key (InvitationFor junction)`
-  data InvitableJunction   junction :: *
+  data InvitableJunction   junction :: Type
 
   -- | `InvitationData` is all data associated with an invitation except for the `UserEmail` and `InvitationFor junction`
   --
   -- Note that this is only the data associated with the invitation; some user input might still be required to construct `InvitableJunction junction`
-  type InvitationData      junction = (dat :: *) | dat -> junction
+  type InvitationData      junction = (dat :: Type) | dat -> junction
   type InvitationData      junction = (InvitationDBData junction, InvitationTokenData junction)
   -- | `InvitationDBData` is the part of `InvitationData` that is stored confidentially in the database
-  data InvitationDBData    junction :: *
+  data InvitationDBData    junction :: Type
   -- | `InvitationTokenData` is the part of `InvitationData` that is stored readably within the token
-  data InvitationTokenData junction :: *
+  data InvitationTokenData junction :: Type
 
   _InvitableJunction :: Iso' junction (UserId, Key (InvitationFor junction), InvitableJunction junction)
 

src/Handler/Utils/Memcached.hs

@@ -30,7 +30,7 @@ import Crypto.Hash.Algorithms (SHAKE256)
 
 import qualified Data.ByteArray as BA
 
-import Language.Haskell.TH
+import Language.Haskell.TH hiding (Type)
 
 import Data.Typeable (typeRep)
 import Type.Reflection (typeOf, TypeRep)
@@ -52,7 +52,7 @@ import qualified Crypto.Saltine.Core.AEAD as AEAD
 import qualified Control.Monad.State.Class as State
 
 
-type Expiry = (Either UTCTime DiffTime)
+type Expiry = Either UTCTime DiffTime
 
 _MemcachedExpiry :: Prism' Expiry Memcached.Expiry
 _MemcachedExpiry = prism' fromExpiry toExpiry
@@ -169,7 +169,7 @@ memcachedSet :: ( MonadHandler m, HandlerSite m ~ UniWorX
              => Maybe Expiry -> a -> m ()
 memcachedSet mExp = memcachedBySet mExp () . MemcachedUnkeyed
 
-memcachedInvalidate :: forall (a :: *) m p.
+memcachedInvalidate :: forall (a :: Type) m p.
                        ( MonadHandler m, HandlerSite m ~ UniWorX
                        , Typeable a
                        )

src/Handler/Utils/Table/Pagination.hs

@@ -54,7 +54,6 @@ import Handler.Utils.Form
 import Handler.Utils.Csv
 import Handler.Utils.ContentDisposition
 import Handler.Utils.I18n
-import Handler.Utils.Widgets
 import Utils
 import Utils.Lens
 
@@ -665,12 +664,12 @@ simpleCsvEncodeM fName f = Just DBTCsvEncode
   }
 
 
-class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: * -> *) (x :: *) where
+class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: Type -> Type) (x :: Type) where
-  data DBParams m x :: *
+  data DBParams m x :: Type
-  type DBResult m x :: *
+  type DBResult m x :: Type
-  -- type DBResult' m x :: *
+  -- type DBResult' m x :: Type
 
-  data DBCell m x :: *
+  data DBCell m x :: Type
   dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget)
 
   -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)

src/Handler/Utils/Users.hs

@@ -10,6 +10,7 @@ module Handler.Utils.Users
 
 import Import
 import Auth.LDAP (campusUserMatr')
+import Foundation.Yesod.Auth (upsertCampusUser)
 
 import Crypto.Hash (hashlazy)
 

src/Handler/Utils/Widgets.hs

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

src/Import/NoModel.hs

@@ -39,6 +39,7 @@ import Utils                  as Import
 import Utils.Frontend.I18n    as Import
 import Utils.DB               as Import
 import Utils.Sql              as Import
+import Utils.Widgets          as Import
 
 import Data.Fixed             as Import
 
@@ -170,6 +171,7 @@ import Network.Minio.Instances as Import ()
 import System.Clock.Instances as Import ()
 import Data.Word.Word24.Instances as Import ()
 import Control.Monad.Trans.Memo.StateCache.Instances as Import (hoistStateCache)
+import Database.Persist.Sql.Types.Instances as Import ()
 
 import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512)
 import Crypto.Random as Import (ChaChaDRG, Seed)
@@ -192,6 +194,8 @@ import GHC.TypeLits as Import (KnownSymbol)
 
 import Data.Word.Word24 as Import
 
+import Data.Kind as Import (Type, Constraint)
+
 
 import Control.Monad.Trans.RWS (RWST)
 

src/Jobs/Handler/SynchroniseLdap.hs

@@ -8,6 +8,7 @@ import Import
 import qualified Data.Conduit.List as C
 
 import Auth.LDAP
+import Foundation.Yesod.Auth (CampusUserConversionException, upsertCampusUser)
 
 import Jobs.Queue
 

src/Mail.hs

@@ -38,6 +38,8 @@ module Mail
 
 import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON)
 
+import Data.Kind (Type)
+
 import Model.Types.Languages
 
 import Network.Mail.Mime hiding (addPart, addAttachment)
@@ -325,7 +327,7 @@ instance Monoid (PrioritisedAlternatives m) where
   mappend = (<>)
 
 class YesodMail site => ToMailPart site a where
-  type MailPartReturn site a :: *
+  type MailPartReturn site a :: Type
   type MailPartReturn site a = ()
   toMailPart :: (MonadMail m, HandlerSite m ~ site) => a -> StateT Part m (MailPartReturn site a)
 

src/Model/Types/File.hs

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

src/Settings.hs

@@ -587,3 +587,10 @@ compileTimeAppSettings =
     case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
         Aeson.Error e -> error e
         Aeson.Success settings -> settings
+
+
+getTimeLocale' :: [Lang] -> TimeLocale
+getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")])
+
+appTZ :: TZ
+appTZ = $(includeSystemTZ "Europe/Berlin")

src/Settings/Cluster.hs

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

src/Utils.hs

@@ -183,7 +183,6 @@ instance HasContentType YamlValue where
 toYAML :: ToJSON a => a -> YamlValue
 toYAML = YamlValue . toJSON
 
-
 ---------------------
 -- Text and String --
 ---------------------

src/Utils/DB.hs

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

src/Utils/Form.hs

@@ -5,6 +5,7 @@
 module Utils.Form where
 
 import ClassyPrelude.Yesod hiding (addMessage, addMessageI, cons, Proxy(..), identifyForm, addClass, mreq, areq, wreq)
+import Data.Kind (Type)
 import qualified Yesod.Form.Functions as Yesod
 import Yesod.Core.Instances ()
 import Settings
@@ -275,7 +276,7 @@ identifyForm = identifyForm' id
 -- Buttons (new version ) --
 ----------------------------
 
-data family ButtonClass site :: *
+data family ButtonClass site :: Type
 
 class (PathPiece a, PathPiece (ButtonClass site), RenderMessage site ButtonMessage) => Button site a where
   btnLabel :: a -> WidgetT site IO ()

src/Utils/SystemMessage.hs

@@ -6,11 +6,11 @@ import qualified Data.List.NonEmpty as NonEmpty
 import Data.List (findIndex)
 
 
-getSystemMessage :: MonadHandler m
+getSystemMessage :: (MonadHandler m, BackendCompatible SqlReadBackend backend)
                  => NonEmpty Lang -- ^ `appLanguages`
                  -> SystemMessageId
-                 -> ReaderT SqlBackend m (Maybe (SystemMessage, Maybe SystemMessageTranslation))
+                 -> ReaderT backend m (Maybe (SystemMessage, Maybe SystemMessageTranslation))
-getSystemMessage appLanguages smId = runMaybeT $ do
+getSystemMessage appLanguages smId = withReaderT (projectBackend @SqlReadBackend) . runMaybeT $ do
   SystemMessage{..} <- MaybeT $ get smId
   translations <- lift $ selectList [SystemMessageTranslationMessage ==. smId] []
   let

src/Utils/Widgets.hs

@@ -0,0 +1,13 @@
+module Utils.Widgets
+  ( i18n
+  ) where
+
+import ClassyPrelude.Yesod
+import Yesod.Core.Types.Instances ()
+
+
+i18n :: forall m msg.
+        ( MonadWidget m
+        , RenderMessage (HandlerSite m) msg
+        ) => msg -> m ()
+i18n = toWidget . (SomeMessage :: msg -> SomeMessage (HandlerSite m))

stack.yaml

@@ -120,6 +120,8 @@ extra-deps:
 
   # - base64-bytestring-1.1.0.0
 
+  - generic-lens-1.2.0.0
+
   - acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
   - bytebuild-0.3.6.0@sha256:aec785c906db5c7ec730754683196eb99a0d48e0deff7d4034c7b58307040b85,2982
   - byteslice-0.2.3.0@sha256:3ebcc77f8ac9fec3ca1a8304e66cfe0a1590c9272b768f2b19637e06de00bf6d,2014
@@ -154,4 +156,5 @@ extra-deps:
   - hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814
 
 resolver: nightly-2020-08-08
+compiler: ghc-8.10.2
 allow-newer: true

stack.yaml.lock

@@ -164,6 +164,13 @@ packages:
   original:
     git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git
     commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
+- completed:
+    hackage: generic-lens-1.2.0.0@sha256:b19e7970c93743a46bc3702331512a96d163de4356472f2d51a2945887aefe8c,6524
+    pantry-tree:
+      size: 4315
+      sha256: 9ed161eadfda5b1eb36cfcf077146f7b66db1da69f1041fc720aea287ec021b0
+  original:
+    hackage: generic-lens-1.2.0.0
 - completed:
     hackage: acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
     pantry-tree:

test/ModelSpec.hs

@@ -5,6 +5,8 @@ module ModelSpec where
 
 import TestImport
 
+import Settings (getTimeLocale')
+
 import Model.TypesSpec ()
 
 import qualified Data.CaseInsensitive as CI