Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX into sheet-type

.gitignore

@@ -1,8 +1,6 @@
 dist*
 static/tmp/
 static/combined/
-client_session_key.aes
-cryptoid_key.bf
 *.hi
 *.o
 *.sqlite3

config/settings.yml

@@ -26,6 +26,7 @@ job-stale-threshold: 300
 notification-rate-limit: 3600
 notification-collate-delay: 300
 notification-expiration: 259201
+session-timeout: 7200
 
 log-settings:
   log-detailed:      "_env:DETAILED_LOGGING:false"
@@ -41,10 +42,11 @@ auth-pw-hash:
   strength: 14
 
 # Optional values with the following production defaults.
-# In development, they default to true.
+# In development, they default to the opposite.
 # reload-templates: false
 # mutable-static: false
 # skip-combining: false
+# encrypt-errors: true
 
 database:
   user:     "_env:PGUSER:uniworx"
@@ -86,5 +88,4 @@ user-defaults:
   time-format:      "%R"
   download-files:   false
 
-cryptoid-keyfile: "_env:CRYPTOID_KEYFILE:cryptoid_key.bf"
+instance-idfile: "_env:INSTANCE_ID:instance"
-instance-idfile: "_env:INSTANCEID_FILE:instance"

messages/uniworx/de.msg

@@ -376,7 +376,7 @@ NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert
 NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen
 NotificationTriggerSheetSoonInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben
 NotificationTriggerSheetInactive: Abgabefrist eines meiner Übungsblätter ist abgelaufen
-NotificationCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt
+NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt
 
 CorrCreate: Abgaben erstellen
 UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
@@ -440,4 +440,25 @@ MessageWarning: Warnung
 MessageInfo: Information
 MessageSuccess: Erfolg
 
-InvalidLangFormat: Ungültiger Sprach-Code (RFC1766)
+InvalidLangFormat: Ungültiger Sprach-Code (RFC1766)
+
+ErrorResponseTitleNotFound: Ressource nicht gefunden
+ErrorResponseTitleInternalError internalError@Text: Ein interner Fehler ist aufgetreten
+ErrorResponseTitleInvalidArgs invalidArgs@Texts: Anfrage-Nachricht enthielt ungültige Argumente
+ErrorResponseTitleNotAuthenticated: Anfrage benötigt Authentifizierung
+ErrorResponseTitlePermissionDenied permissionDenied@Text: Mangelnde Authorisierung
+ErrorResponseTitleBadMethod requestMethod@Method: HTTP-Methode nicht unterstützt
+
+UnknownErrorResponse: Ein nicht weiter klassifizierter Fehler ist aufgetreten:
+ErrorResponseNotFound: Unter der von Ihrem Browser angefragten URL wurde keine Seite gefunden.
+ErrorResponseNotAuthenticated: Um Zugriff auf einige Teile des Systems zu erhalten müssen Sie sich zunächst anmelden.
+ErrorResponseBadMethod requestMethodText@Text: Ihr Browser kann auf mehrere verschiedene Arten versuchen mit den vom System angebotenen Ressourcen zu interagieren. Die aktuell versuchte Methode (#{requestMethodText}) wird nicht unterstützt.
+
+ErrorResponseEncrypted: Um keine sensiblen Daten preiszugeben wurden nähere Details verschlüsselt. Wenn Sie eine Anfrage an den Support schicken fügen Sie bitte die unten aufgeführten verschlüsselten Daten mit an.
+ErrMsgCiphertext: Verschlüsselte Fehlermeldung
+ErrMsgCiphertextTooShort: Verschlüsselte Daten zu kurz um valide zu sein
+ErrMsgInvalidBase64 base64Err@String: Verschlüsselte Daten nicht korrekt base64url-kodiert: #{base64Err}
+ErrMsgCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren
+ErrMsgCouldNotOpenSecretbox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch)
+ErrMsgCouldNotDecodePlaintext utf8Err@Text: Konnte Klartext nicht UTF8-dekodieren: #{utf8Err}
+ErrMsgHeading: Fehlermeldung entschlüsseln

models

@@ -255,4 +255,8 @@ SystemMessageTranslation
     language            Lang
     content             Html
     summary             Html Maybe
-    UniqueSystemMessageTranslation message language
+    UniqueSystemMessageTranslation message language
+ClusterConfig
+    setting             ClusterSettingsKey
+    value               Value
+    Primary setting

package.yaml

@@ -48,6 +48,7 @@ dependencies:
 - wai
 - cryptonite
 - cryptonite-conduit
+- saltine
 - base64-bytestring
 - memory
 - http-api-data
@@ -67,6 +68,7 @@ dependencies:
 - cryptoids
 - cryptoids-class
 - binary
+- cereal
 - mtl
 - sandi
 - esqueleto
@@ -107,6 +109,55 @@ dependencies:
 - postgresql-simple
 - word24
 - mmorph
+- clientsession
+
+other-extensions:
+  - GeneralizedNewtypeDeriving
+  - IncoherentInstances
+  - OverloadedLists
+  - UndecidableInstances
+
+default-extensions:
+  - OverloadedStrings
+  - PartialTypeSignatures
+  - ScopedTypeVariables
+  - TemplateHaskell
+  - QuasiQuotes
+  - CPP
+  - TypeSynonymInstances
+  - KindSignatures
+  - ConstraintKinds
+  - ViewPatterns
+  - TypeOperators
+  - TupleSections
+  - TypeFamilies
+  - GADTs
+  - StandaloneDeriving
+  - RecordWildCards
+  - RankNTypes
+  - PatternGuards
+  - PatternSynonyms
+  - ParallelListComp
+  - NumDecimals
+  - MultiWayIf
+  - NamedFieldPuns
+  - NoImplicitPrelude
+  - LambdaCase
+  - MultiParamTypeClasses
+  - FlexibleContexts
+  - FlexibleInstances
+  - FunctionalDependencies
+  - EmptyDataDecls
+  - ExistentialQuantification
+  - DefaultSignatures
+  - DeriveDataTypeable
+  - DeriveGeneric
+  - DeriveLift
+  - DeriveFunctor
+  - DerivingStrategies
+  - DataKinds
+  - BinaryLiterals
+  - PolyKinds
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

routes

@@ -36,6 +36,7 @@
 /admin/test                 AdminTestR        GET POST
 /admin/user/#CryptoUUIDUser AdminUserR        GET
 /admin/user/#CryptoUUIDUser/hijack AdminHijackUserR POST
+/admin/errMsg               AdminErrMsgR      GET POST
 /info                       VersionR          GET             !free
 /help                       HelpR             GET POST        !free
 

src/Application.hs

@@ -1,12 +1,5 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE FlexibleContexts #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Application
     ( getApplicationDev, getAppDevSettings
     , appMain
@@ -67,6 +60,12 @@ import qualified Yesod.Core.Types as Yesod (Logger(..))
 import qualified Data.HashMap.Strict as HashMap
 
 import Control.Lens ((&))
+
+import Data.Proxy
+
+import qualified Data.Aeson as Aeson
+
+import System.Exit (exitFailure)
   
 -- Import all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)
@@ -105,8 +104,7 @@ makeFoundation appSettings@(AppSettings{..}) = do
       return $ Yesod.Logger loggerSet tgetter
     appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir
 
-    appCryptoIDKey <- readKeyFile appCryptoIDKeyFile
+    appInstanceID <- liftIO $ maybe UUID.nextRandom (either readInstanceIDFile return) appInitialInstanceID
-    appInstanceID <- liftIO $ maybe UUID.nextRandom readInstanceIDFile appInstanceIDFile
 
     (appJobCtl, recvChans) <- fmap unzip . atomically . replicateM appJobWorkers $ do
         chan <- newBroadcastTMChan
@@ -120,11 +118,16 @@ makeFoundation appSettings@(AppSettings{..}) = do
     -- logging function. To get out of this loop, we initially create a
     -- temporary foundation without a real connection pool, get a log function
     -- from there, and then create the real foundation.
-    let mkFoundation appConnPool appSmtpPool = UniWorX {..}
+    let mkFoundation appConnPool appSmtpPool appCryptoIDKey appSessionKey appErrorMsgKey = UniWorX {..}
         -- The UniWorX {..} syntax is an example of record wild cards. For more
         -- information, see:
         -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
-        tempFoundation = mkFoundation (error "connPool forced in tempFoundation") (error "smtpPool forced in tempFoundation")
+        tempFoundation = mkFoundation
+          (error "connPool forced in tempFoundation")
+          (error "smtpPool forced in tempFoundation")
+          (error "cryptoIDKey forced in tempFoundation")
+          (error "sessionKey forced in tempFoundation")
+          (error "errorMsgKey forced in tempFoundation")
         logFunc = messageLoggerSource tempFoundation appLogger
 
     flip runLoggingT logFunc $ do
@@ -140,12 +143,36 @@ makeFoundation appSettings@(AppSettings{..}) = do
     
       -- Perform database migration using our application's logging settings.
       migrateAll `runSqlPool` sqlPool
+      appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool
+      appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
+      appErrorMsgKey <- clusterSetting (Proxy :: Proxy 'ClusterErrorMessageKey) `runSqlPool` sqlPool
 
-      handleJobs recvChans $ mkFoundation sqlPool smtpPool
+      let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appErrorMsgKey
+
+      handleJobs recvChans foundation
 
       -- Return the foundation
-      return $ mkFoundation sqlPool smtpPool
+      return foundation
 
+clusterSetting :: forall key m p.
+                  ( MonadIO m
+                  , ClusterSetting key
+                  , MonadLogger m
+                  )
+               => p (key :: ClusterSettingsKey)
+               -> ReaderT SqlBackend m (ClusterSettingValue key)
+clusterSetting proxy@(knownClusterSetting -> key) = do
+  current' <- get (ClusterConfigKey key)
+  case Aeson.fromJSON . clusterConfigValue <$> current' of
+    Just (Aeson.Success c) -> return c
+    Just (Aeson.Error str) -> do
+      $logErrorS "clusterSetting" $ "Could not parse JSON-Value for " <> toPathPiece key <> ": " <> pack str
+      liftIO exitFailure
+    Nothing -> do
+      new <- initClusterSetting proxy
+      void . insert $ ClusterConfig key (Aeson.toJSON new)
+      return new
+  
 readInstanceIDFile :: MonadIO m => FilePath -> m UUID
 readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFile >>= parseBS
   where

src/Auth/Dummy.hs

@@ -1,11 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , TemplateHaskell
-           , FlexibleContexts
-           , TypeFamilies
-           , OverloadedStrings
-  #-}
-
 module Auth.Dummy
   ( dummyLogin
   , DummyMessage(..)

src/Auth/LDAP.hs

@@ -1,14 +1,3 @@
-{-# LANGUAGE RecordWildCards
-           , OverloadedStrings
-           , TemplateHaskell
-           , ViewPatterns
-           , TypeFamilies
-           , FlexibleContexts
-           , FlexibleInstances
-           , NoImplicitPrelude
-           , ScopedTypeVariables
-  #-}
-
 module Auth.LDAP
   ( campusLogin
   , CampusUserException(..)

src/Auth/PWHash.hs

@@ -1,13 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , QuasiQuotes
-           , TemplateHaskell
-           , ViewPatterns
-           , RecordWildCards
-           , OverloadedStrings
-           , FlexibleContexts
-           , TypeFamilies
-  #-}
-
 module Auth.PWHash
   ( hashLogin
   , PWHashMessage(..)

src/Cron.hs

@@ -1,12 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , PatternGuards
-           , ViewPatterns
-           , DeriveFunctor
-           , TemplateHaskell
-           , NamedFieldPuns
-  #-}
-
 module Cron
   ( CronNextMatch(..)
   , nextCronMatch

src/Cron/Types.hs

@@ -1,8 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , TemplateHaskell
-           , DuplicateRecordFields
-  #-}
-
 module Cron.Types
   ( Cron(..), Crontab
   , CronMatch(..)

src/CryptoID.hs

@@ -1,11 +1,3 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
-{-# LANGUAGE RecordWildCards, ViewPatterns, PatternGuards #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module CryptoID

src/CryptoID/TH.hs

@@ -1,7 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE ViewPatterns #-}
-
 module CryptoID.TH where
 
 import ClassyPrelude

src/Data/CaseInsensitive/Instances.hs

@@ -1,11 +1,8 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Data.CaseInsensitive.Instances
-  () where
+  (
+  ) where
 
 import ClassyPrelude.Yesod
 

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

@@ -1,6 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , ScopedTypeVariables
-  #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Data.Universe.Instances.Reverse.Hashable

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

@@ -1,6 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , ScopedTypeVariables
-  #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Data.Universe.Instances.Reverse.JSON

src/Foundation.hs

@@ -1,17 +1,4 @@
-{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE PatternGuards, MultiWayIf #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE FlexibleInstances, UndecidableInstances, FlexibleContexts #-}
 
 module Foundation where
 
@@ -20,6 +7,8 @@ import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Text.Hamlet          (hamletFile)
 import Text.Jasmine         (minifym)
 
+import qualified Web.ClientSession as ClientSession
+
 import Yesod.Auth.Message
 import Yesod.Auth.Dummy
 import Auth.LDAP
@@ -96,6 +85,9 @@ import qualified Yesod.Auth.Message as Auth
 
 import qualified Data.Conduit.List as C
 
+import qualified Crypto.Saltine.Core.SecretBox as SecretBox
+import qualified Crypto.Saltine.Class as Saltine
+
 
 instance DisplayAble b => DisplayAble (E.CryptoID a b) where
   display = display . ciphertext
@@ -127,6 +119,8 @@ data UniWorX = UniWorX
     , appCryptoIDKey :: CryptoIDKey
     , appInstanceID  :: InstanceId
     , appJobCtl      :: [TMChan JobCtl]
+    , appErrorMsgKey :: SecretBox.Key
+    , appSessionKey  :: ClientSession.Key
     }
 
 type SMTPPool = Pool SMTPConnection
@@ -197,14 +191,8 @@ instance RenderMessage UniWorX TermIdentifier where
     Winter -> renderMessage' $ MsgWinterTerm year
     where renderMessage' = renderMessage foundation ls
 
-instance RenderMessage UniWorX StudyFieldType where
-  renderMessage foundation ls = renderMessage foundation ls . \case
-    FieldPrimary -> MsgFieldPrimary
-    FieldSecondary -> MsgFieldSecondary
-
 newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
   deriving (Eq, Ord, Read, Show)
-
 instance RenderMessage UniWorX ShortTermIdentifier where
   renderMessage foundation ls (ShortTermIdentifier TermIdentifier{..}) = case season of
     Summer -> renderMessage' $ MsgSummerTermShort year
@@ -214,33 +202,12 @@ instance RenderMessage UniWorX ShortTermIdentifier where
 instance RenderMessage UniWorX String where
   renderMessage f ls str = renderMessage f ls $ Text.pack str
 
-instance RenderMessage UniWorX SheetFileType where
-  renderMessage foundation ls = renderMessage foundation ls . \case
-      SheetExercise -> MsgSheetExercise
-      SheetHint     -> MsgSheetHint
-      SheetSolution -> MsgSheetSolution
-      SheetMarking  -> MsgSheetMarking
-
-instance RenderMessage UniWorX CorrectorState where
-  renderMessage foundation ls = renderMessage foundation ls . \case
-      CorrectorNormal  -> MsgCorrectorNormal
-      CorrectorMissing -> MsgCorrectorMissing
-      CorrectorExcused -> MsgCorrectorExcused
-
-
 instance RenderMessage UniWorX Load where
   renderMessage foundation ls = renderMessage foundation ls . \case
       (Load {byTutorial=Nothing   , byProportion=p}) -> MsgCorByProportionOnly p
       (Load {byTutorial=Just True , byProportion=p}) -> MsgCorByProportionIncludingTutorial p
       (Load {byTutorial=Just False, byProportion=p}) -> MsgCorByProportionExcludingTutorial p
 
-instance RenderMessage UniWorX SheetType where
-  renderMessage foundation ls = renderMessage foundation ls . \case
-      Bonus{..} -> MsgSheetTypeBonus' maxPoints
-      Normal{..} -> MsgSheetTypeNormal' maxPoints
-      Pass{..} -> MsgSheetTypePass' maxPoints passingPoints
-      NotGraded{} -> MsgSheetTypeNotGraded'
-
 newtype MsgLanguage = MsgLanguage Lang
   deriving (Eq, Ord, Show, Read)
 instance RenderMessage UniWorX MsgLanguage where
@@ -250,24 +217,18 @@ instance RenderMessage UniWorX MsgLanguage where
     where
       mr = renderMessage foundation ls
 
-instance RenderMessage UniWorX NotificationTrigger where
-  renderMessage foundation ls = renderMessage foundation ls . \case
-    NTSubmissionRatedGraded -> MsgNotificationTriggerSubmissionRatedGraded
-    NTSubmissionRated -> MsgNotificationTriggerSubmissionRated
-    NTSheetActive -> MsgNotificationTriggerSheetActive
-    NTSheetSoonInactive -> MsgNotificationTriggerSheetSoonInactive
-    NTSheetInactive -> MsgNotificationTriggerSheetInactive 
-    NTCorrectionsAssigned -> MsgNotificationCorrectionsAssigned
-
 instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
   renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)
 
-instance RenderMessage UniWorX MessageClass where
+embedRenderMessage ''UniWorX ''MessageClass ("Message" <>)
-  renderMessage f ls = renderMessage f ls . \case
+embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
-    Error -> MsgMessageError
+embedRenderMessage ''UniWorX ''SheetType $ \st -> "SheetType" <> st <> "'"
-    Warning -> MsgMessageWarning
+embedRenderMessage ''UniWorX ''StudyFieldType id
-    Info -> MsgMessageInfo
+embedRenderMessage ''UniWorX ''SheetFileType id
-    Success -> MsgMessageSuccess
+embedRenderMessage ''UniWorX ''CorrectorState id
+
+newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse
+embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>)
 
 
 data instance ButtonCssClass UniWorX = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink
@@ -573,9 +534,9 @@ instance Yesod UniWorX where
 
     -- Store session data on the client in encrypted cookies,
     -- default session idle timeout is 120 minutes
-    makeSessionBackend _ = Just <$> defaultClientSessionBackend
+    makeSessionBackend UniWorX{appSessionKey,appSettings=AppSettings{appSessionTimeout}} = do
-        120    -- timeout in minutes
+      (getCachedDate, _) <- clientSessionDateCacher appSessionTimeout
-        "client_session_key.aes"
+      return . Just $ clientSessionBackend appSessionKey getCachedDate
 
     maximumContentLength _ _ = Just $ 50 * 2^20
 
@@ -627,101 +588,52 @@ instance Yesod UniWorX where
             $logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|]
             redirectWith movedPermanently301 route'
 
-    defaultLayout widget = do
+    -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget`
-        master <- getYesod
+    defaultMessageWidget _title _body = error "defaultMessageWidget: undefined"
-        let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master
 
-        applySystemMessages
+    errorHandler err = do
-        mmsgs  <- getMessages
+      mr <- getMessageRender
+      let
+        encrypted :: ToJSON a => a -> Widget -> Widget
+        encrypted plaintextJson plaintext = do
+          canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True
+          shouldEncrypt <- getsYesod $ appEncryptErrors . appSettings
+          errKey <- getsYesod appErrorMsgKey
+          if
+            | shouldEncrypt
+            , not canDecrypt -> do
+                nonce <- liftIO SecretBox.newNonce
+                let ciphertext = SecretBox.secretbox errKey nonce . Lazy.ByteString.toStrict $ encode plaintextJson
+                    encoded = decodeUtf8 . Base64.encode $ Saltine.encode nonce <> ciphertext
+                    formatted = Text.intercalate "\n" $ Text.chunksOf 76 encoded
+                [whamlet|
+                  <p>_{MsgErrorResponseEncrypted}
+                  <pre .errMsg>
+                    #{formatted}
+                |]
+            | 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)}|]
+      fmap toTypedContent . siteLayout (Just . toHtml . mr $ ErrorResponseTitle err) $ do
+        toWidget
+          [cassius|
+            .errMsg
+              white-space: pre-wrap
+              font-family: monospace
+          |]
+        errPage
 
-        mcurrentRoute <- getCurrentRoute
+    defaultLayout = siteLayout Nothing
-
-        -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
-        (title, parents) <- breadcrumbs
-
---         let isParent :: Route UniWorX -> Bool
---             isParent r = r == (fst parents)
-
-        let menu = defaultLinks ++ maybe [] pageActions mcurrentRoute
-
-        menuTypes <- mapM (\x -> (x, ) <$> newIdent) =<< filterM (menuItemAccessCallback . menuItem) menu
-
-        isAuth <- isJust <$> maybeAuthId
-
-        -- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?!
-        (favourites', currentTheme) <- do
-            muid <- maybeAuthPair
-            case muid of
-                Nothing         -> return ([],userDefaultTheme)
-                (Just (uid,user)) -> do
-                    favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do
-                        E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse)
-                        E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid)
-                        E.orderBy [ E.asc $ course E.^. CourseShorthand ]
-                        return course
-                    return (favs, userTheme user)
-        favourites <- forM favourites' $ \(Entity _ c@Course{..})
-            -> let
-                   courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
-               in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute)
-
-        let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
-            highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents
-                            navItems = map snd3 favourites ++ map (menuItemRoute . menuItem . fst) menuTypes
-                            highR  = find (`elem` navItems) . uncurry (++) $ partition (`elem` map snd3 favourites) crumbs
-                        in \r -> Just r == highR
-            favouriteTerms :: [TermIdentifier]
-            favouriteTerms = Set.toDescList $ foldMap (\(Course{..}, _, _) -> Set.singleton $ unTermKey courseTerm) favourites
-            favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [MenuTypes])]
-            favouriteTerm tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites
-
-        -- 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.
-
-
-        let
-            navbar :: Widget
-            navbar = $(widgetFile "widgets/navbar")
-            asidenav :: Widget
-            asidenav = $(widgetFile "widgets/asidenav")
-            contentHeadline :: Maybe Widget
-            contentHeadline = pageHeading =<< mcurrentRoute
-            breadcrumbs :: Widget
-            breadcrumbs = $(widgetFile "widgets/breadcrumbs")
-            pageactionprime :: Widget
-            pageactionprime = $(widgetFile "widgets/pageactionprime") -- TODO: rename, since it also shows secondary pageActions now
-            -- functions to determine if there are page-actions (primary or secondary)
-            isPageActionPrime :: MenuTypes -> Bool
-            isPageActionPrime (PageActionPrime _)     = True
-            isPageActionPrime (PageActionSecondary _) = True
-            isPageActionPrime _ = False
-            hasPageActions :: Bool
-            hasPageActions = any (isPageActionPrime . fst) menuTypes
-
-        pc <- widgetToPageContent $ do
-            addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900|Roboto:300,400,600"
-            addScript $ StaticR js_zepto_js
-            addScript $ StaticR js_fetchPolyfill_js
-            addScript $ StaticR js_urlPolyfill_js
-            addScript $ StaticR js_featureChecker_js
-            addScript $ StaticR js_flatpickr_js
-            addScript $ StaticR js_tabber_js
-            addStylesheet $ StaticR css_flatpickr_css
-            addStylesheet $ StaticR css_tabber_css
-            addStylesheet $ StaticR css_fonts_css
-            addStylesheet $ StaticR css_fontawesome_css
-            $(widgetFile "default-layout")
-            $(widgetFile "standalone/modal")
-            $(widgetFile "standalone/showHide")
-            $(widgetFile "standalone/inputs")
-            $(widgetFile "standalone/tooltip")
-            $(widgetFile "standalone/tabber")
-            $(widgetFile "standalone/alerts")
-            $(widgetFile "standalone/datepicker")
-        withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
 
     -- The page to be redirected to when authentication is required.
     authRoute _ = Just $ AuthR LoginR
@@ -768,6 +680,105 @@ instance Yesod UniWorX where
     makeLogger = return . appLogger
 
 
+siteLayout :: Maybe Html -- ^ Optionally override `pageHeading`
+           -> Widget -> Handler Html
+siteLayout headingOverride widget = do
+  master <- getYesod
+  let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master
+
+  applySystemMessages
+  mmsgs  <- getMessages
+
+  mcurrentRoute <- getCurrentRoute
+
+  -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
+  (title, parents) <- breadcrumbs
+
+  --         let isParent :: Route UniWorX -> Bool
+  --             isParent r = r == (fst parents)
+
+  let menu = defaultLinks ++ maybe [] pageActions mcurrentRoute
+
+  menuTypes <- mapM (\x -> (x, ) <$> newIdent) =<< filterM (menuItemAccessCallback . menuItem) menu
+
+  isAuth <- isJust <$> maybeAuthId
+
+  -- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?!
+  (favourites', currentTheme) <- do
+      muid <- maybeAuthPair
+      case muid of
+          Nothing         -> return ([],userDefaultTheme)
+          (Just (uid,user)) -> do
+              favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do
+                  E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse)
+                  E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid)
+                  E.orderBy [ E.asc $ course E.^. CourseShorthand ]
+                  return course
+              return (favs, userTheme user)
+  favourites <- forM favourites' $ \(Entity _ c@Course{..})
+      -> let
+             courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
+         in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute)
+
+  let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
+      highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents
+                      navItems = map snd3 favourites ++ map (menuItemRoute . menuItem . fst) menuTypes
+                      highR  = find (`elem` navItems) . uncurry (++) $ partition (`elem` map snd3 favourites) crumbs
+                  in \r -> Just r == highR
+      favouriteTerms :: [TermIdentifier]
+      favouriteTerms = Set.toDescList $ foldMap (\(Course{..}, _, _) -> Set.singleton $ unTermKey courseTerm) favourites
+      favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [MenuTypes])]
+      favouriteTerm tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites
+
+  -- 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.
+
+
+  let
+      navbar :: Widget
+      navbar = $(widgetFile "widgets/navbar")
+      asidenav :: Widget
+      asidenav = $(widgetFile "widgets/asidenav")
+      contentHeadline :: Maybe Widget
+      contentHeadline = (toWidget <$> headingOverride) <|> (pageHeading =<< mcurrentRoute)
+      breadcrumbs :: Widget
+      breadcrumbs = $(widgetFile "widgets/breadcrumbs")
+      pageactionprime :: Widget
+      pageactionprime = $(widgetFile "widgets/pageactionprime") -- TODO: rename, since it also shows secondary pageActions now
+      -- functions to determine if there are page-actions (primary or secondary)
+      isPageActionPrime :: MenuTypes -> Bool
+      isPageActionPrime (PageActionPrime _)     = True
+      isPageActionPrime (PageActionSecondary _) = True
+      isPageActionPrime _ = False
+      hasPageActions :: Bool
+      hasPageActions = any (isPageActionPrime . fst) menuTypes
+
+  pc <- widgetToPageContent $ do
+      addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900|Roboto:300,400,600"
+      addScript $ StaticR js_zepto_js
+      addScript $ StaticR js_fetchPolyfill_js
+      addScript $ StaticR js_urlPolyfill_js
+      addScript $ StaticR js_featureChecker_js
+      addScript $ StaticR js_flatpickr_js
+      addScript $ StaticR js_tabber_js
+      addStylesheet $ StaticR css_flatpickr_css
+      addStylesheet $ StaticR css_tabber_css
+      addStylesheet $ StaticR css_fonts_css
+      addStylesheet $ StaticR css_fontawesome_css
+      $(widgetFile "default-layout")
+      $(widgetFile "standalone/modal")
+      $(widgetFile "standalone/showHide")
+      $(widgetFile "standalone/inputs")
+      $(widgetFile "standalone/tooltip")
+      $(widgetFile "standalone/tabber")
+      $(widgetFile "standalone/alerts")
+      $(widgetFile "standalone/datepicker")
+  withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
+
+
 applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m ()
 applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage
   where
@@ -949,8 +960,8 @@ pageActions (HomeR) =
 --       , menuItemAccessCallback' = return True
 --       }
 --   ,
-    NavbarAside $ MenuItem
+    PageActionPrime $ MenuItem
-      { menuItemLabel = "AdminDemo"
+      { menuItemLabel = "Admin-Demo"
       , menuItemIcon  = Just "screwdriver"
       , menuItemRoute = AdminTestR
       , menuItemModal = False
@@ -963,6 +974,13 @@ pageActions (HomeR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , PageActionPrime $ MenuItem
+      { menuItemLabel = "Fehlermeldung entschlüsseln"
+      , menuItemIcon = Nothing
+      , menuItemRoute = AdminErrMsgR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
   ]
 pageActions (ProfileR) =
   [ PageActionPrime $ MenuItem
@@ -1210,6 +1228,8 @@ pageHeading (AdminTestR)
   = Just $ [whamlet|Internal Code Demonstration Page|]
 pageHeading (AdminUserR _)
   = Just $ [whamlet|User Display for Admin|]
+pageHeading (AdminErrMsgR)
+  = Just $ i18nHeading MsgErrMsgHeading
 pageHeading (VersionR)
   = Just $ i18nHeading MsgImpressumHeading
 pageHeading (HelpR)

src/Handler/Admin.hs

@@ -1,20 +1,22 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
-
 module Handler.Admin where
 
 import Import
 import Handler.Utils
 import Jobs
 
+import qualified Data.ByteString as BS
+
+import qualified Crypto.Saltine.Internal.ByteSizes as Saltine
+import qualified Data.ByteString.Base64.URL as Base64
+import Crypto.Saltine.Core.SecretBox (secretboxOpen)
+import qualified Crypto.Saltine.Class as Saltine
+
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import Data.Char (isSpace)
+
+import Control.Monad.Trans.Except
+
 -- import Data.Time
 -- import qualified Data.Text as T
 -- import Data.Function ((&))
@@ -105,3 +107,35 @@ getAdminUserR uuid = do
       <h2>Admin Page for User ^{nameWidget userDisplayName userSurname}
     |]
 
+getAdminErrMsgR, postAdminErrMsgR :: Handler Html
+getAdminErrMsgR = postAdminErrMsgR
+postAdminErrMsgR = do
+  errKey <- getsYesod appErrorMsgKey
+  
+  ((ctResult, ctView), ctEncoding) <- runFormPost . renderAForm FormStandard $
+        (unTextarea <$> areq textareaField (fslpI MsgErrMsgCiphertext "Ciphertext") Nothing)
+    <*  submitButton
+
+  plaintext <- formResultMaybe ctResult $ \(encodeUtf8 . Text.filter (not . isSpace) -> inputBS) ->
+    exceptT (\err -> Nothing <$ addMessageI Error err) (return . Just) $ do
+      ciphertext <- either (throwE . MsgErrMsgInvalidBase64) return $ Base64.decode inputBS
+
+      unless (BS.length ciphertext >= Saltine.secretBoxNonce + Saltine.secretBoxMac) $
+        throwE MsgErrMsgCiphertextTooShort
+      let (nonceBS, secretbox) = BS.splitAt Saltine.secretBoxNonce ciphertext
+
+      nonce <- maybe (throwE MsgErrMsgCouldNotDecodeNonce) return $ Saltine.decode nonceBS
+
+      plainBS <- maybe (throwE MsgErrMsgCouldNotOpenSecretbox) return $ secretboxOpen errKey nonce secretbox
+
+      either (throwE . MsgErrMsgCouldNotDecodePlaintext . tshow) return $ Text.decodeUtf8' plainBS
+
+  defaultLayout $
+    [whamlet|
+      $maybe t <- plaintext
+        <pre style="white-space:pre-wrap; font-family:monospace">
+          #{t}
+
+      <form action=@{AdminErrMsgR} method=post enctype=#{ctEncoding}>
+        ^{ctView}
+    |]

src/Handler/Common.hs

@@ -1,8 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
 -- | Common handler functions.
 module Handler.Common where
 

src/Handler/Corrections.hs

@@ -1,20 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE MultiWayIf, LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE MultiWayIf #-}
-
 module Handler.Corrections where
 
 import Import

src/Handler/Course.hs

@@ -1,18 +1,3 @@
-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE FlexibleContexts #-}
-
 module Handler.Course where
 
 import Import hiding (catMaybes)

src/Handler/CryptoIDDispatch.hs

@@ -1,23 +1,9 @@
-{-# LANGUAGE NoImplicitPrelude
-           , DataKinds
-           , KindSignatures
-           , TypeFamilies
-           , FlexibleInstances
-           , TypeOperators
-           , RankNTypes
-           , PolyKinds
-           , RecordWildCards
-           , MultiParamTypeClasses
-           , ScopedTypeVariables
-           , ViewPatterns
-  #-}
-
 module Handler.CryptoIDDispatch
   ( getCryptoUUIDDispatchR
   , getCryptoFileNameDispatchR
   ) where
 
-import Import hiding (Proxy)
+import Import
 
 import Data.Proxy
 

src/Handler/Home.hs

@@ -1,16 +1,3 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE IncoherentInstances #-} -- why is this needed? Instance for "display deadline" ought to be clear
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-
 module Handler.Home where
 
 import Import
@@ -279,10 +266,8 @@ helpForm mReferer mUid = HelpForm
       , (HIAnonymous, pure $ Left Nothing)
       ]
 
-getHelpR :: Handler Html
+getHelpR, postHelpR :: Handler Html
 getHelpR = postHelpR
-
-postHelpR :: Handler Html
 postHelpR = do
   mUid <- maybeAuthId
   mRefererBS <- requestHeaderReferer <$> waiRequest

src/Handler/Profile.hs

@@ -1,17 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE MultiWayIf, LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE FlexibleInstances #-}
-
 module Handler.Profile where
 
 import Import

src/Handler/School.hs

@@ -1,18 +1,3 @@
-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE FlexibleContexts #-}
-
 module Handler.School where
 
 import Import

src/Handler/Sheet.hs

@@ -1,20 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE MultiWayIf, LambdaCase #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE NamedFieldPuns #-}
-
 module Handler.Sheet where
 
 import Import

src/Handler/Submission.hs

@@ -1,21 +1,3 @@
-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE ParallelListComp #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE MultiWayIf #-}
-
 module Handler.Submission where
 
 import Import hiding (joinPath)
@@ -314,14 +296,15 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
         , dbtProj = return . dbrOutput
         , dbtStyle = def
         , dbtIdent = "files" :: Text
-        , dbtSorting =  [ ( "path"
+        , dbtSorting = Map.fromList
-                          , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle]
+          [ ( "path"
-                          )
+            , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle]
-                        , ( "time"
+            )
-                          , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime)))
+          , ( "time"
-                          )
+            , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime)))
-                        ]
+            )
-        , dbtFilter = []
+          ]
+        , dbtFilter = Map.empty
         }
   mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
 

src/Handler/SystemMessage.hs

@@ -1,17 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , TemplateHaskell
-           , NamedFieldPuns
-           , RecordWildCards
-           , OverloadedStrings
-           , TypeFamilies
-           , ViewPatterns
-           , FlexibleContexts
-           , LambdaCase
-           , MultiParamTypeClasses
-           , QuasiQuotes
-  #-}
-
 module Handler.SystemMessage where
 
 import Import

src/Handler/Term.hs

@@ -1,19 +1,8 @@
-{-# LANGUAGE NoImplicitPrelude
-           , OverloadedStrings
-           , OverloadedLists
-           , RecordWildCards
-           , TemplateHaskell
-           , QuasiQuotes
-           , MultiParamTypeClasses
-           , TypeFamilies
-           , FlexibleContexts
-           , PartialTypeSignatures
-  #-}
-
 module Handler.Term where
 
 import Import
 import Handler.Utils
+import qualified Data.Map as Map
 
 -- import qualified Data.Text as T
 import Yesod.Form.Bootstrap3
@@ -111,30 +100,32 @@ getTermShowR = do
         { dbtSQLQuery = termData
         , dbtColonnade = colonnadeTerms
         , dbtProj = return . dbrOutput
-        , dbtSorting = [ ( "start"
+        , dbtSorting = Map.fromList
-                         , SortColumn $ \term -> term E.^. TermStart
+            [ ( "start"
-                         )
+              , SortColumn $ \term -> term E.^. TermStart
-                       , ( "end"
+              )
-                         , SortColumn $ \term -> term E.^. TermEnd
+            , ( "end"
-                         )
+              , SortColumn $ \term -> term E.^. TermEnd
-                       , ( "lecture-start"
+              )
-                         , SortColumn $ \term -> term E.^. TermLectureStart
+            , ( "lecture-start"
-                         )
+              , SortColumn $ \term -> term E.^. TermLectureStart
-                       , ( "lecture-end"
+              )
-                         , SortColumn $ \term -> term E.^. TermLectureEnd
+            , ( "lecture-end"
-                         )
+              , SortColumn $ \term -> term E.^. TermLectureEnd
-                       ]
+              )
-        , dbtFilter = [ ( "active"
+            ]
-                        , FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool))
+        , dbtFilter = Map.fromList
-                        )
+            [ ( "active"
-                      , ( "course"
+              , FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool))
-                        , FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are 
+              )
-                            []   -> E.val True :: E.SqlExpr (E.Value Bool)
+            , ( "course"
-                            cshs -> E.exists . E.from $ \course -> do
+              , FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are 
-                              E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
+                  []   -> E.val True :: E.SqlExpr (E.Value Bool)
-                                   E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
+                  cshs -> E.exists . E.from $ \course -> do
-                        )
+                    E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
-                      ]
+                         E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
+              )
+            ]
         , dbtStyle = def
         , dbtIdent = "terms" :: Text
         }

src/Handler/Users.hs

@@ -1,11 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
-
 module Handler.Users where
 
 import Import

src/Handler/Utils.hs

@@ -1,10 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RecordWildCards #-}
-
-
 module Handler.Utils
   ( module Handler.Utils
   ) where

src/Handler/Utils/DateTime.hs

@@ -1,10 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , TemplateHaskell
-           , OverloadedStrings
-           , RecordWildCards
-           , TypeFamilies
-  #-}
-
 module Handler.Utils.DateTime
   ( utcToLocalTime
   , localTimeToUTC, TZ.LocalToUTCResult(..)

src/Handler/Utils/Form.hs

@@ -1,17 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE LambdaCase #-}
-
 module Handler.Utils.Form
   ( module Handler.Utils.Form
   , module Utils.Form

src/Handler/Utils/Form/Types.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
 module Handler.Utils.Form.Types where
 
 import Import

src/Handler/Utils/Mail.hs

@@ -1,11 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , NamedFieldPuns
-           , TypeFamilies
-           , FlexibleContexts
-           , ViewPatterns
-           , LambdaCase
-  #-}
-
 module Handler.Utils.Mail
   ( addRecipientsDB
   , userMailT

src/Handler/Utils/Rating.hs

@@ -1,16 +1,4 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
-
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 
 module Handler.Utils.Rating
   ( Rating(..), Rating'(..)

src/Handler/Utils/Sheet.hs

@@ -1,13 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-
 module Handler.Utils.Sheet where
 
 import Import

src/Handler/Utils/StudyFeatures.hs

@@ -1,7 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-  #-}
-
 module Handler.Utils.StudyFeatures
   ( parseStudyFeatures
   ) where

src/Handler/Utils/Submission.hs

@@ -1,19 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MultiWayIf #-}
-
-
 module Handler.Utils.Submission
   ( AssignSubmissionException(..)
   , assignSubmissions

src/Handler/Utils/Submission/TH.hs

@@ -1,10 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , TemplateHaskell
-           , ViewPatterns
-           , OverloadedStrings
-           , StandaloneDeriving
-           , DeriveLift
-  #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Handler.Utils.Submission.TH

src/Handler/Utils/Table.hs

@@ -1,8 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TypeFamilies #-}
-
 module Handler.Utils.Table where
 -- General Utilities for Tables
 

src/Handler/Utils/Table/Cells.hs

@@ -1,10 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-
 module Handler.Utils.Table.Cells where
 
 import Import

src/Handler/Utils/Table/Pagination.hs

@@ -1,23 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , ExistentialQuantification
-           , RecordWildCards
-           , NamedFieldPuns
-           , OverloadedStrings
-           , TemplateHaskell
-           , QuasiQuotes
-           , LambdaCase
-           , ViewPatterns
-           , FlexibleContexts
-           , FlexibleInstances
-           , MultiParamTypeClasses
-           , TypeFamilies
-           , ScopedTypeVariables
-           , TupleSections
-           , RankNTypes
-           , MultiWayIf
-           , FunctionalDependencies
-  #-}
-
 module Handler.Utils.Table.Pagination
   ( SortColumn(..), SortDirection(..)
   , FilterColumn(..), IsFilterColumn
@@ -47,7 +27,7 @@ module Handler.Utils.Table.Pagination
 import Handler.Utils.Table.Pagination.Types
 import Utils.Lens.TH
 
-import Import hiding (Proxy(..))
+import Import
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)
 import qualified Database.Esqueleto.Internal.Language as E (From)

src/Handler/Utils/Table/Pagination/Types.hs

@@ -1,9 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , ExistentialQuantification
-           , RankNTypes
-           , RecordWildCards
-  #-}
-
 module Handler.Utils.Table.Pagination.Types where
 
 import Import hiding (singleton)

src/Handler/Utils/Templates.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude, TemplateHaskell, QuasiQuotes #-}
-
 module Handler.Utils.Templates where
 
 import Data.Either (isLeft)

src/Handler/Utils/Zip.hs

@@ -1,7 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
 {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- This concerns zipEntrySize in produceZip
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 

src/Import/NoFoundation.hs

@@ -1,10 +1,9 @@
-{-# LANGUAGE CPP #-}
 module Import.NoFoundation
     ( module Import
     , MForm
     ) where
 
-import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm)
+import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy)
 import Model                  as Import
 import Model.Types.JSON       as Import
 import Model.Migration        as Import

src/Jobs.hs

@@ -1,29 +1,14 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , TemplateHaskell
-           , OverloadedStrings
-           , FlexibleContexts
-           , ViewPatterns
-           , TypeFamilies
-           , DeriveGeneric
-           , DeriveDataTypeable
-           , QuasiQuotes
-           , NamedFieldPuns
-           , MultiWayIf
-  #-}
-
 module Jobs
   ( module Types
   , module Jobs.Queue
   , handleJobs
   ) where
 
-import Import hiding (Proxy)
+import Import
 
 import Jobs.Types as Types hiding (JobCtl(JobCtlQueue))
 import Jobs.Types (JobCtl(JobCtlQueue))
 import Jobs.Queue
-import Jobs.TH
 import Jobs.Crontab
 
 import Data.Conduit.TMChan

src/Jobs/Crontab.hs

@@ -1,11 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , FlexibleContexts
-           , MultiWayIf
-           , NamedFieldPuns
-           , TypeFamilies
-  #-}
-
 module Jobs.Crontab
   ( determineCrontab
   ) where

src/Jobs/Handler/HelpRequest.hs

@@ -1,9 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , TemplateHaskell
-           , RecordWildCards
-           , OverloadedStrings
-  #-}
-
 module Jobs.Handler.HelpRequest
   ( dispatchJobHelpRequest
   ) where

src/Jobs/Handler/QueueNotification.hs

@@ -1,8 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , NamedFieldPuns
-  #-}
-
 module Jobs.Handler.QueueNotification
   ( dispatchJobQueueNotification
   ) where

src/Jobs/Handler/SendNotification.hs

@@ -1,14 +1,9 @@
-{-# LANGUAGE NoImplicitPrelude
-           , TemplateHaskell
-  #-}
-
 module Jobs.Handler.SendNotification
   ( dispatchJobSendNotification
   ) where
 
 import Import
 
-import Jobs.TH
 import Jobs.Types
 
 

src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs

@@ -1,10 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , NamedFieldPuns
-           , TemplateHaskell
-           , OverloadedStrings
-  #-}
-
 module Jobs.Handler.SendNotification.CorrectionsAssigned
   ( dispatchNotificationCorrectionsAssigned
   ) where

src/Jobs/Handler/SendNotification/SheetActive.hs

@@ -1,10 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , NamedFieldPuns
-           , TemplateHaskell
-           , OverloadedStrings
-  #-}
-
 module Jobs.Handler.SendNotification.SheetActive
   ( dispatchNotificationSheetActive
   ) where

src/Jobs/Handler/SendNotification/SheetInactive.hs

@@ -1,10 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , NamedFieldPuns
-           , TemplateHaskell
-           , OverloadedStrings
-  #-}
-
 module Jobs.Handler.SendNotification.SheetInactive
   ( dispatchNotificationSheetSoonInactive
   , dispatchNotificationSheetInactive
@@ -55,4 +48,4 @@ dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
   addAlternatives $ do
     let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
     providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
-    
+    

src/Jobs/Handler/SendNotification/SubmissionRated.hs

@@ -1,10 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , NamedFieldPuns
-           , TemplateHaskell
-           , OverloadedStrings
-  #-}
-
 module Jobs.Handler.SendNotification.SubmissionRated
   ( dispatchNotificationSubmissionRated
   ) where

src/Jobs/Handler/SendTestEmail.hs

@@ -1,9 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , NamedFieldPuns
-           , QuasiQuotes
-  #-}
-
 module Jobs.Handler.SendTestEmail
   ( dispatchJobSendTestEmail
   ) where

src/Jobs/Handler/SetLogSettings.hs

@@ -1,6 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-  #-}
-
 module Jobs.Handler.SetLogSettings
   ( dispatchJobSetLogSettings
   ) where

src/Jobs/Queue.hs

@@ -1,7 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , TypeFamilies
-  #-}
-
 module Jobs.Queue
   ( writeJobCtl, writeJobCtlBlock
   , queueJob, queueJob'

src/Jobs/TH.hs

@@ -1,29 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude
-           , TemplateHaskell
-           , QuasiQuotes
-           , RecordWildCards
-  #-}
-
-module Jobs.TH
-  ( dispatchTH
-  ) where
-
-import ClassyPrelude
-
-import Language.Haskell.TH
-import Language.Haskell.TH.Datatype
-
-import Data.List (foldl)
-
-
-dispatchTH :: Name -- ^ Datatype to pattern match
-           -> ExpQ
-dispatchTH dType = do
-  DatatypeInfo{..} <- reifyDatatype dType
-  let
-    matches = map mkMatch datatypeCons
-    mkMatch ConstructorInfo{..} = do
-      pats <- forM constructorFields $ \_ -> newName "x"
-      let fName = mkName $ "dispatch" <> nameBase constructorName
-      match (conP constructorName $ map varP pats) (normalB $ foldl (\e pat -> e `appE` varE pat) (varE fName) pats) []
-  lamCaseE matches

src/Jobs/Types.hs

@@ -1,9 +1,3 @@
-{-# LANGUAGE TemplateHaskell
-           , NoImplicitPrelude
-           , DeriveGeneric
-           , DeriveDataTypeable
-  #-}
-
 module Jobs.Types
   ( Job(..), Notification(..)
   , JobCtl(..)

src/Mail.hs

@@ -1,22 +1,5 @@
-{-# LANGUAGE NoImplicitPrelude
+{-# LANGUAGE GeneralizedNewtypeDeriving
-           , GeneralizedNewtypeDeriving
-           , DerivingStrategies
-           , FlexibleInstances
-           , MultiParamTypeClasses
            , UndecidableInstances
-           , DeriveGeneric
-           , TemplateHaskell
-           , OverloadedStrings
-           , RecordWildCards
-           , FlexibleContexts
-           , TypeFamilies
-           , ViewPatterns
-           , NamedFieldPuns
-           , MultiWayIf
-           , QuasiQuotes
-           , RankNTypes
-           , ScopedTypeVariables
-           , DeriveDataTypeable
   #-}
 
 module Mail

src/Model.hs

@@ -1,17 +1,4 @@
-{-# LANGUAGE EmptyDataDecls             #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE NoImplicitPrelude          #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE TemplateHaskell            #-}
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE DeriveDataTypeable         #-}
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE RecordWildCards            #-}
-{-# LANGUAGE StandaloneDeriving         #-}
-
 
 module Model
   ( module Model
@@ -33,6 +20,7 @@ import Data.CaseInsensitive (CI)
 import Data.CaseInsensitive.Instances ()
 
 import Utils.Message (MessageClass)
+import Settings.Cluster (ClusterSettingsKey)
 
 -- You can define all of your database entities in the entities file.
 -- You can find more information on persistent and how to declare entities
@@ -43,12 +31,6 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll
 
 -- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only
 deriving instance Eq (Unique Course)
-  
-data PWEntry = PWEntry
-  { pwUser :: User
-  , pwHash :: Text
-  } deriving (Show)
-$(deriveJSON defaultOptions ''PWEntry)
 
 submissionRatingDone :: Submission -> Bool
 submissionRatingDone Submission{..} = isJust submissionRatingTime

src/Model/Migration.hs

@@ -1,11 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
-{-# LANGUAGE TypeFamilies, FlexibleInstances #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-
 module Model.Migration
   ( migrateAll
   ) where

src/Model/Migration/Version.hs

@@ -1,10 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE DeriveLift, DeriveGeneric, DeriveDataTypeable #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Model.Migration.Version

src/Model/Types.hs

@@ -1,16 +1,6 @@
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving
-{-# LANGUAGE PatternGuards #-}
+           , UndecidableInstances
-{-# LANGUAGE LambdaCase #-}
+  #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE BinaryLiterals #-}
-{-# LANGUAGE MultiWayIf #-}
-{-- # LANGUAGE ExistentialQuantification #-} -- for DA type
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
 
 module Model.Types

src/Model/Types/JSON.hs

@@ -1,7 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
-
 module Model.Types.JSON
   ( derivePersistFieldJSON
   ) where

src/Model/Types/Wordlist.hs

@@ -1,9 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , TemplateHaskell
-           , ViewPatterns
-           , OverloadedStrings
-  #-}
-
 module Model.Types.Wordlist (wordlist) where
 
 import ClassyPrelude hiding (lift)

src/Settings.hs

@@ -1,25 +1,21 @@
-{-# LANGUAGE CPP                #-}
-{-# LANGUAGE NoImplicitPrelude  #-}
-{-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE RecordWildCards    #-}
-{-# LANGUAGE TemplateHaskell    #-}
-{-# LANGUAGE MultiWayIf         #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+
 -- | Settings are centralized, as much as possible, into this file. This
 -- includes database connection settings, static file locations, etc.
 -- In addition, you can configure a number of different aspects of Yesod
 -- by overriding methods in the Yesod typeclass. That instance is
 -- declared in the Foundation.hs file.
-module Settings where
+module Settings
+  ( module Settings
+  , module Settings.Cluster
+  ) where
 
 import           ClassyPrelude.Yesod
+import Data.UUID (UUID)
 import qualified Control.Exception           as Exception
-import           Data.Aeson                  (Result (..), fromJSON, withObject,
+import           Data.Aeson                  (Result (..), fromJSON, withObject
-                                              (.!=), (.:?), withScientific)
+                                             ,(.!=), (.:?), withScientific
+                                             )
 import qualified Data.Aeson.Types as Aeson
 import           Data.Aeson.TH
 import           Data.FileEmbed              (embedFile)
@@ -57,6 +53,7 @@ import Network.Mail.Mime (Address)
 import Mail (VerpMode)
 
 import Model
+import Settings.Cluster
 
 -- | Runtime settings to configure this application. These settings can be
 -- loaded from various sources: defaults, environment variables, config files,
@@ -91,6 +88,7 @@ data AppSettings = AppSettings
     , appNotificationRateLimit  :: NominalDiffTime
     , appNotificationCollateDelay :: NominalDiffTime
     , appNotificationExpiration :: NominalDiffTime
+    , appSessionTimeout         :: NominalDiffTime
 
     , appInitialLogSettings     :: LogSettings
 
@@ -104,12 +102,12 @@ data AppSettings = AppSettings
     -- ^ Indicate if auth dummy login should be enabled.
     , appAllowDeprecated        :: Bool
     -- ^ Indicate if deprecated routes are accessible for everyone
+    , appEncryptErrors          :: Bool
 
     , appUserDefaults           :: UserDefaultConf
     , appAuthPWHash             :: PWHashConf
 
-    , appCryptoIDKeyFile        :: FilePath
+    , appInitialInstanceID      :: Maybe (Either FilePath UUID)
-    , appInstanceIDFile         :: Maybe FilePath
     } deriving (Show)
 
 data LogSettings = LogSettings
@@ -264,7 +262,6 @@ deriveFromJSON
   ''Address
 
 
-
 instance FromJSON AppSettings where
     parseJSON = withObject "AppSettings" $ \o -> do
         let defaultDev =
@@ -298,19 +295,21 @@ instance FromJSON AppSettings where
         appNotificationCollateDelay <- o .: "notification-collate-delay"
         appNotificationExpiration <- o .: "notification-expiration"
 
+        appSessionTimeout         <- o .: "session-timeout"
+
         appReloadTemplates        <- o .:? "reload-templates" .!= defaultDev
         appMutableStatic          <- o .:? "mutable-static"   .!= defaultDev
         appSkipCombining          <- o .:? "skip-combining"   .!= defaultDev
         appAuthDummyLogin         <- o .:? "auth-dummy-login" .!= defaultDev
         appAllowDeprecated        <- o .:? "allow-deprecated" .!= defaultDev
+        appEncryptErrors          <- o .:? "encrypt-errors"   .!= not defaultDev
 
         appInitialLogSettings     <- o .:  "log-settings"
 
         appUserDefaults           <- o .:  "user-defaults"
         appAuthPWHash             <- o .:  "auth-pw-hash"
 
-        appCryptoIDKeyFile        <- o .:  "cryptoid-keyfile"
+        appInitialInstanceID      <- (o .:? "instance-id") >>= maybe (return Nothing) (\v -> Just <$> ((Right <$> parseJSON v) <|> (Left <$> parseJSON v)))
-        appInstanceIDFile         <- o .:? "instance-idfile"
 
         return AppSettings {..}
 

src/Settings/Cluster.hs

@@ -0,0 +1,126 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Settings.Cluster
+  ( ClusterSettingsKey(..)
+  , ClusterSetting(..)
+  ) where
+
+import ClassyPrelude.Yesod
+import Database.Persist.Sql
+import Web.HttpApiData
+
+import Utils
+import Control.Lens
+import Data.Universe
+
+import Data.Aeson ( FromJSON(..), ToJSON(..)
+                  , Options(..), defaultOptions
+                  , FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..)
+                  )
+import Data.Aeson.TH (deriveJSON)
+import Data.Aeson.Types (toJSONKeyText)
+import qualified Data.Aeson as Aeson
+
+import qualified Web.ClientSession as ClientSession
+import qualified Crypto.Saltine.Core.SecretBox as SecretBox
+import qualified Crypto.Saltine.Class as Saltine
+
+import Data.CryptoID.ByteString (CryptoIDKey)
+import qualified Data.CryptoID.ByteString as CryptoID
+
+import qualified Data.Binary as Binary
+import qualified Data.Serialize as Serialize
+import qualified Data.ByteString.Base64.URL as Base64
+
+
+data ClusterSettingsKey
+  = ClusterCryptoIDKey
+  | ClusterClientSessionKey
+  | ClusterErrorMessageKey
+  deriving (Eq, Ord, Enum, Bounded, Show, Read)
+
+instance Universe ClusterSettingsKey
+instance Finite ClusterSettingsKey
+
+$(return [])
+
+instance PathPiece ClusterSettingsKey where
+  toPathPiece = $(nullaryToPathPiece ''ClusterSettingsKey [intercalate "-" . map toLower . drop 1 . splitCamel])
+  fromPathPiece = finiteFromPathPiece
+
+deriveJSON
+  defaultOptions
+    { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+    }
+  ''ClusterSettingsKey
+
+instance ToJSONKey ClusterSettingsKey where
+  toJSONKey = toJSONKeyText $ \v -> let String t = toJSON v in t
+
+instance FromJSONKey ClusterSettingsKey where
+  fromJSONKey = FromJSONKeyTextParser $ parseJSON . String
+
+instance PersistField ClusterSettingsKey where
+  toPersistValue = PersistText . toPathPiece
+  fromPersistValue (PersistText t) = maybe (Left $ "Could not parse " <> t) Right $ fromPathPiece t
+  fromPersistValue _other = Left "Expecting PersistText"
+
+instance PersistFieldSql ClusterSettingsKey where
+  sqlType _ = SqlString
+
+instance ToHttpApiData ClusterSettingsKey where
+  toUrlPiece = toPathPiece
+instance FromHttpApiData ClusterSettingsKey where
+  parseUrlPiece = maybe (Left "Could not parse url piece") Right . fromPathPiece
+
+  
+class (ToJSON (ClusterSettingValue key), FromJSON (ClusterSettingValue key)) => ClusterSetting (key :: ClusterSettingsKey) where
+  type ClusterSettingValue key :: *
+  initClusterSetting :: forall m p. MonadIO m => p key -> m (ClusterSettingValue key)
+  knownClusterSetting :: forall p. p key -> ClusterSettingsKey
+
+
+instance ClusterSetting 'ClusterCryptoIDKey where
+  type ClusterSettingValue 'ClusterCryptoIDKey = CryptoIDKey
+  initClusterSetting _ = CryptoID.genKey
+  knownClusterSetting _ = ClusterCryptoIDKey
+
+instance ToJSON CryptoIDKey where
+  toJSON = Aeson.String . decodeUtf8 . Base64.encode . toStrict . Binary.encode
+
+instance FromJSON CryptoIDKey where
+  parseJSON = Aeson.withText "CryptoIDKey" $ \t -> do
+    bytes <- either fail (return . fromStrict) . Base64.decode $ encodeUtf8 t
+    case Binary.decodeOrFail bytes of
+      Left (_, _, err) -> fail err
+      Right (bs, _, ret)
+        | null bs -> return ret
+        | otherwise -> fail $ show (length bs) ++ " extra bytes"
+
+
+instance ClusterSetting 'ClusterClientSessionKey where
+  type ClusterSettingValue 'ClusterClientSessionKey = ClientSession.Key
+  initClusterSetting _ = liftIO $ view _2 <$> ClientSession.randomKey
+  knownClusterSetting _ = ClusterClientSessionKey
+
+instance ToJSON ClientSession.Key where
+  toJSON = Aeson.String . decodeUtf8 . Base64.encode . Serialize.encode
+
+instance FromJSON ClientSession.Key where
+  parseJSON = Aeson.withText "Key" $ \t -> do
+    bytes <- either fail return . Base64.decode $ encodeUtf8 t
+    either fail return $ Serialize.decode bytes
+
+
+instance ClusterSetting 'ClusterErrorMessageKey where
+  type ClusterSettingValue 'ClusterErrorMessageKey = SecretBox.Key
+  initClusterSetting _ = liftIO $ SecretBox.newKey
+  knownClusterSetting _ = ClusterErrorMessageKey
+
+instance ToJSON SecretBox.Key where
+  toJSON = Aeson.String . decodeUtf8 . Base64.encode . Saltine.encode
+
+instance FromJSON SecretBox.Key where
+  parseJSON = Aeson.withText "Key" $ \t -> do
+    bytes <- either fail return . Base64.decode $ encodeUtf8 t
+    maybe (fail "Could not parse key") return $ Saltine.decode bytes

src/Settings/StaticFiles.hs

@@ -1,6 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell   #-}
 module Settings.StaticFiles where
 
 import Settings     (appStaticDir, compileTimeAppSettings)

src/Utils.hs

@@ -1,12 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
-{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
-{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}
-{-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult
 
 module Utils

src/Utils/DB.hs

@@ -1,8 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
-{-# LANGUAGE QuasiQuotes #-}
-
 module Utils.DB where
 
 import ClassyPrelude.Yesod

src/Utils/DateTime.hs

@@ -1,15 +1,4 @@
-{-# LANGUAGE NoImplicitPrelude
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-           , TemplateHaskell
-           , QuasiQuotes
-           , StandaloneDeriving
-           , DerivingStrategies
-           , DeriveLift
-           , DeriveDataTypeable
-           , DeriveGeneric
-           , GeneralizedNewtypeDeriving
-           , OverloadedStrings
-           , FlexibleInstances
-  #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Utils.DateTime

src/Utils/Form.hs

@@ -1,18 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , TemplateHaskell
-           , ViewPatterns
-           , OverloadedStrings
-           , QuasiQuotes
-           , TemplateHaskell
-           , MultiParamTypeClasses
-           , TypeFamilies
-           , FlexibleContexts
-           , NamedFieldPuns
-           , ScopedTypeVariables
-           , MultiWayIf
-           , RecordWildCards
-#-}
-
 module Utils.Form where
 
 import ClassyPrelude.Yesod hiding (addMessage)
@@ -284,6 +269,9 @@ reorderField optList = Field{..}
 ---------------------
 
 formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m ()
-formResult (FormFailure errs) _ = forM_ errs $ addMessage Error . toHtml
+formResult res f = void . formResultMaybe res $ \x -> Nothing <$ f x
-formResult  FormMissing       _ = return ()
+
-formResult (FormSuccess res)  f = f res
+formResultMaybe :: MonadHandler m => FormResult a -> (a -> m (Maybe b)) -> m (Maybe b)
+formResultMaybe (FormFailure errs) _ = Nothing <$ forM_ errs (addMessage Error . toHtml)
+formResultMaybe  FormMissing       _ = return Nothing
+formResultMaybe (FormSuccess res)  f = f res

src/Utils/Lang.hs

@@ -1,7 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
 module Utils.Lang where
 
 import ClassyPrelude.Yesod

src/Utils/Lens.hs

@@ -1,8 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FunctionalDependencies #-}
 module Utils.Lens ( module Utils.Lens ) where
 
 import Import.NoFoundation

src/Utils/Message.hs

@@ -1,10 +1,3 @@
-{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DeriveLift #-}
-
-
 module Utils.Message
   ( MessageClass(..)
   , addMessage, addMessageI, addMessageIHamlet, addMessageFile

src/Utils/PathPiece.hs

@@ -1,6 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-  #-}
-
 module Utils.PathPiece
   ( finiteFromPathPiece
   , nullaryToPathPiece

src/Utils/Sql.hs

@@ -1,11 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NumDecimals #-}
-{-# LANGUAGE FlexibleContexts #-}
-
 module Utils.Sql
   ( setSerializable
   ) where

src/Utils/SystemMessage.hs

@@ -1,7 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-  #-}
-
 module Utils.SystemMessage where
 
 import Import.NoFoundation

src/Utils/TH.hs

@@ -1,19 +1,18 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
 module Utils.TH where
 -- Common Utility Functions that require TemplateHaskell
 
 -- import Data.Char
 
-import Prelude
+import ClassyPrelude.Yesod
 import Language.Haskell.TH
+import Language.Haskell.TH.Datatype
 -- import Control.Monad
 -- import Control.Monad.Trans.Class
 -- import Control.Monad.Trans.Maybe
 -- import Control.Monad.Trans.Except
 
+import Data.List ((!!), foldl)
+
 ------------
 -- Tuples --
 ------------
@@ -45,7 +44,7 @@ altFun perm = lamE pat rhs
   where pat = map varP $ fn:xs
         rhs = foldl appE (varE fn) $ map varE ps
 --         rhs = appE (varE fn) (varE $ xs!!1)        
-        mx  = maximum perm
+        mx  = maximum $ impureNonNull perm
         xs  = [ mkName $ "x" ++ show j | j <- [1..mx] ]
         ps  = [ xs !! (j-1) | j <- perm ]
         fn  = mkName "fn" 
@@ -78,3 +77,75 @@ deriveSimpleWith cls fun strOp ty = do
       in return $ Clause pats body []
     genClause _ = fail "deriveShowTheme: constructors not allowed to have arguments"
 
+embedRenderMessage :: Name -- ^ Foundation type
+                   -> Name -- ^ Type to embed into message type
+                   -> (Text -> Text) -- ^ Mangle constructor names
+                   -> DecsQ
+-- ^ @embedRenderMessage ''Foundation ''MessageType mangle@ declares a
+--   `RenderMessage Foundation MessageType` instance expecting the default
+--   message-datatype (@FoundationMessage@) to contain one constructor for each
+--   constructor of @MessageType@, taking the same arguments:
+--
+-- > data NewMessage = NewMessageOne | NewMessageTwo
+-- > data FoundationMessage = MsgOne | MsgTwo
+-- >
+-- > -- embedRenderMessage ''Foundation ''NewMessage (drop 2 . splitCamel)
+-- > instance RenderMessage Foundation NewMessage where
+-- >   renderMessage f ls = renderMessage f ls . \case
+-- >     NewMessageOne -> MsgOne
+-- >     NewMessageTwo -> MsgTwo
+embedRenderMessage f inner mangle = do
+  DatatypeInfo{..} <- reifyDatatype inner
+  let
+    matches :: [MatchQ]
+    matches = flip map datatypeCons $ \ConstructorInfo{..} -> do
+      vars <- forM constructorFields $ \_ -> newName "x"
+      let body = foldl (\e v -> e `appE` varE v) (conE . mkName . unpack $ "Msg" <> mangle (pack $ nameBase constructorName)) vars
+      match (conP constructorName $ map varP vars) (normalB body) []
+
+  f' <- newName "f"
+  ls <- newName "ls"
+  
+  pure <$> instanceD (cxt []) [t|RenderMessage $(conT f) $(conT inner)|]
+    [ funD 'renderMessage
+      [ clause [varP f', varP ls] (normalB $ [e|renderMessage $(varE f') $(varE ls) . $(lamCaseE matches)|]) [] 
+      ]
+    ]
+
+embedRenderMessageVariant :: Name -- ^ Foundation Type
+                          -> Name -- ^ Name of newtype
+                          -> (Text -> Text) -- ^ Mangle constructor names
+                          -> DecsQ
+embedRenderMessageVariant f newT mangle = do
+  [ConstructorInfo{ constructorName = newtypeName, constructorFields = [ ConT newtypeInner ] }] <- datatypeCons <$> reifyDatatype newT
+  DatatypeInfo{..} <- reifyDatatype newtypeInner
+
+  let
+    matches :: [MatchQ]
+    matches = flip map datatypeCons $ \ConstructorInfo{..} -> do
+      vars <- forM constructorFields $ \_ -> newName "x"
+      let body = foldl (\e v -> e `appE` varE v) (conE . mkName . unpack $ "Msg" <> mangle (pack $ nameBase constructorName)) vars
+      match (conP newtypeName [conP constructorName $ map varP vars]) (normalB body) []
+
+  f' <- newName "f"
+  ls <- newName "ls"
+  
+  pure <$> instanceD (cxt []) [t|RenderMessage $(conT f) $(conT newT)|]
+    [ funD 'renderMessage
+      [ clause [varP f', varP ls] (normalB $ [e|renderMessage $(varE f') $(varE ls) . $(lamCaseE matches)|]) [] 
+      ]
+    ]
+  
+
+dispatchTH :: Name -- ^ Datatype to pattern match
+           -> ExpQ
+-- ^ Produces a lambda-case-expression matching all constructors of the named datatype and calling a function (named after the constructor prefixed with @dispatch@) on the fields of each constructor
+dispatchTH dType = do
+  DatatypeInfo{..} <- reifyDatatype dType
+  let
+    matches = map mkMatch datatypeCons
+    mkMatch ConstructorInfo{..} = do
+      pats <- forM constructorFields $ \_ -> newName "x"
+      let fName = mkName $ "dispatch" <> nameBase constructorName
+      match (conP constructorName $ map varP pats) (normalB $ foldl (\e pat -> e `appE` varE pat) (varE fName) pats) []
+  lamCaseE matches

stack.nix

@@ -7,7 +7,7 @@ in haskell.lib.buildStackProject {
   inherit ghc;
   name = "stackenv";
   buildInputs = (with pkgs;
-    [ postgresql zlib openldap cyrus_sasl.dev
+    [ postgresql zlib openldap cyrus_sasl.dev libsodium
     ]) ++ (with haskellPackages;
     [ yesod-bin
     ]);

stack.yaml

@@ -36,4 +36,6 @@ extra-deps:
 
   - persistent-2.7.3.1
 
+  - saltine-0.1.0.1
+
 resolver: lts-10.5

templates/default-layout.hamlet

@@ -14,13 +14,11 @@
 
     <div .main__content-body>
 
-      <h1>
+      $maybe headline <- contentHeadline
-        <!-- $maybe back <- lastMaybe parents
+        <h1>
+          <!-- $maybe back <- lastMaybe parents
             <a .breadcrumbs__link href="@{fst back}">#{snd back}  -->
-        $maybe headline <- contentHeadline
           ^{headline}
-        $nothing
-          HEADLINE MISSING!
 
       <!-- prime page actions -->
       ^{pageactionprime}

templates/mail/support.hamlet

@@ -28,5 +28,10 @@ $newline never
               <dd>#{lang}
       <dt>Zeit
       <dd>#{rtime}
+      $maybe referer <- jReferer
+        <dt>Referer
+        <dd>
+          <a href=#{referer} style="font-family: monospace">
+            #{referer}
     <p style="white-space: pre-wrap; font-family: monospace">
       #{jHelpRequest}