Merge branch '93-implement-errorhandler' into 'master'

Resolve "Implement errorHandler"

See merge request !85

.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,12 @@ 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
+encrypt-errors: true
 
 database:
   user:     "_env:PGUSER:uniworx"
@@ -86,5 +89,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,18 @@ 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.

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,7 @@ dependencies:
 - postgresql-simple
 - word24
 - mmorph
+- clientsession
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

src/Application.hs

@@ -6,6 +6,9 @@
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Application
     ( getApplicationDev, getAppDevSettings
@@ -26,7 +29,7 @@ module Application
 import Control.Monad.Logger                 (liftLoc, LoggingT(..), MonadLoggerIO(..))
 import Database.Persist.Postgresql          (createPostgresqlPool, pgConnStr,
                                              pgPoolSize, runSqlPool)
-import Import
+import Import hiding (Proxy)
 import Language.Haskell.TH.Syntax           (qLocation)
 import Network.Wai (Middleware)
 import Network.Wai.Handler.Warp             (Settings, defaultSettings,
@@ -67,6 +70,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 +114,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 +128,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 +153,38 @@ 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 <- if
+        | appEncryptErrors -> Just <$> clusterSetting (Proxy :: Proxy 'ClusterErrorMessageKey) `runSqlPool` sqlPool
+        | otherwise -> return Nothing
 
-      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
+      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/Foundation.hs

@@ -20,6 +20,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 +98,10 @@ 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
+import qualified Data.Binary as Binary
+
 
 instance DisplayAble b => DisplayAble (E.CryptoID a b) where
   display = display . ciphertext
@@ -127,6 +133,8 @@ data UniWorX = UniWorX
     , appCryptoIDKey :: CryptoIDKey
     , appInstanceID  :: InstanceId
     , appJobCtl      :: [TMChan JobCtl]
+    , appErrorMsgKey :: Maybe SecretBox.Key
+    , appSessionKey  :: ClientSession.Key
     }
 
 type SMTPPool = Pool SMTPConnection
@@ -197,14 +205,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 +216,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 +231,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 +548,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 +602,49 @@ 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
+          errKey <- getsYesod appErrorMsgKey
+          case errKey of
+            Nothing -> plaintext
+            Just key -> do
+              nonce <- liftIO SecretBox.newNonce
+              let ciphertext = SecretBox.secretbox key nonce . Lazy.ByteString.toStrict $ encode plaintextJson
+                  encoded = decodeUtf8 . Base64.encode . Lazy.ByteString.toStrict $ Binary.encode (Saltine.encode nonce, ciphertext)
+                  formatted = Text.intercalate "\n" . map (Text.intercalate " " . Text.chunksOf 4) $ Text.chunksOf 72 encoded
+              [whamlet|
+                <p>_{MsgErrorResponseEncrypted}
+                <pre .errMsg>
+                  #{formatted}
+              |]
+        
+        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 +691,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

src/Handler/Home.hs

@@ -279,10 +279,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/Model.hs

@@ -33,6 +33,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

src/Settings.hs

@@ -7,6 +7,9 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 -- | Settings are centralized, as much as possible, into this file. This
@@ -14,12 +17,17 @@
 -- 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           ClassyPrelude.Yesod hiding (Proxy)
+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 +65,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 +100,7 @@ data AppSettings = AppSettings
     , appNotificationRateLimit  :: NominalDiffTime
     , appNotificationCollateDelay :: NominalDiffTime
     , appNotificationExpiration :: NominalDiffTime
+    , appSessionTimeout         :: NominalDiffTime
 
     , appInitialLogSettings     :: LogSettings
 
@@ -104,12 +114,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 +274,6 @@ deriveFromJSON
   ''Address
 
 
-
 instance FromJSON AppSettings where
     parseJSON = withObject "AppSettings" $ \o -> do
         let defaultDev =
@@ -298,19 +307,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,134 @@
+{-# LANGUAGE NoImplicitPrelude
+           , DataKinds
+           , TypeFamilies
+           , ScopedTypeVariables
+           , TemplateHaskell
+           , OverloadedStrings
+           , FlexibleContexts
+  #-}
+{-# 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/Utils/TH.hs

@@ -1,19 +1,24 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 
 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 +50,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 +83,62 @@ 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)|]) [] 
+      ]
+    ]
+  

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}