Merge branch 'master' into datepicker-focusout

.gitlab-ci.yml

@@ -212,10 +212,10 @@ yesod:test:
       - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/
   retry: 2
 
-deploy:uniworx4:
+deploy:uniworx3:
   stage: deploy
   script:
-    - ssh -i ~/.ssh/id root@uniworx4.ifi.lmu.de <bin/uniworx
+    - ssh -i ~/.ssh/id root@uniworx3.ifi.lmu.de <bin/uniworx
   needs:
     - yesod:build
     - yesod:test # For sanity
@@ -225,13 +225,10 @@ deploy:uniworx4:
     - apt-get install -y --no-install-recommends openssh-client
     - install -m 0700 -d ~/.ssh
     - install -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts
-    - install -m 0400 ${SSH_PRIVATE_KEY_UNIWORX4} ~/.ssh/id
+    - install -m 0400 ${SSH_PRIVATE_KEY_UNIWORX3} ~/.ssh/id
   dependencies:
     - yesod:build
         
   only:
     variables:
       - $CI_COMMIT_REF_NAME =~ /^v[0-9].*/
-
-  when: manual
-  retry: 2

CHANGELOG.md

@@ -2,6 +2,10 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+### [7.22.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.22.0...v7.22.1) (2019-11-14)
+
+
+
 ## [7.22.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.21.5...v7.22.0) (2019-11-14)
 
 

package-lock.json

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

package.json

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

package.yaml

@@ -1,5 +1,5 @@
 name:    uniworx
-version: 7.22.0
+version: 7.22.1
 
 dependencies:
   - base >=4.9.1.0 && <5

src/Foundation.hs

@@ -2,23 +2,25 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- MonadCrypto
 
-module Foundation where
+module Foundation
+  ( module Foundation
+  ) where
+
+import Foundation.Type as Foundation
+import Foundation.I18n as Foundation
+
 
 import Import.NoFoundation hiding (embedFile)
-import Database.Persist.Sql (ConnectionPool, runSqlPool)
+import Database.Persist.Sql (runSqlPool)
 import Text.Hamlet          (hamletFile)
 
-import qualified Web.ClientSession as ClientSession
-
 import Yesod.Auth.Message
 import Auth.LDAP
 import Auth.PWHash
 import Auth.Dummy
-import Jobs.Types
 
 import qualified Network.Wai as W (pathInfo)
 
-import Yesod.Core.Types     (Logger)
 import qualified Yesod.Core.Unsafe as Unsafe
 import Data.CaseInsensitive (original, mk)
 
@@ -79,9 +81,6 @@ import qualified Yesod.Auth.Message as Auth
 
 import qualified Data.Conduit.List as C
 
-import qualified Crypto.Saltine.Core.SecretBox as SecretBox
-import qualified Jose.Jwk as Jose
-
 import qualified Database.Memcached.Binary.IO as Memcached
 import Data.Bits (Bits(zeroBits))
 
@@ -96,45 +95,6 @@ import qualified Ldap.Client as Ldap
 import UnliftIO.Pool
 
 
-type SMTPPool = Pool SMTPConnection
-
--- infixl 9 :$:
--- pattern a :$: b = a b
-
--- | The foundation datatype for your application. This can be a good place to
--- keep settings and values requiring initialization before your application
--- starts running, such as database connections. Every handler will have
--- access to the data present here.
-data UniWorX = UniWorX
-    { appSettings'       :: AppSettings
-    , appStatic          :: EmbeddedStatic -- ^ Settings for static file serving.
-    , appConnPool        :: ConnectionPool -- ^ Database connection pool.
-    , appSmtpPool        :: Maybe SMTPPool
-    , appLdapPool        :: Maybe LdapPool
-    , appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool
-    , appHttpManager     :: Manager
-    , appLogger          :: (ReleaseKey, TVar Logger)
-    , appLogSettings     :: TVar LogSettings
-    , appCryptoIDKey     :: CryptoIDKey
-    , appClusterID       :: ClusterId
-    , appInstanceID      :: InstanceId
-    , appJobState        :: TMVar JobState
-    , appSessionKey      :: ClientSession.Key
-    , appSecretBoxKey    :: SecretBox.Key
-    , appJSONWebKeySet   :: Jose.JwkSet
-    , appHealthReport    :: TVar (Set (UTCTime, HealthReport))
-    }
-
-makeLenses_ ''UniWorX
-instance HasInstanceID UniWorX InstanceId where
-  instanceID = _appInstanceID
-instance HasJSONWebKeySet UniWorX Jose.JwkSet where
-  jsonWebKeySet = _appJSONWebKeySet
-instance HasHttpManager UniWorX Manager where
-  httpManager = _appHttpManager
-instance HasAppSettings UniWorX where
-  appSettings = _appSettings'
-
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:
 -- http://www.yesodweb.com/book/routing-and-handlers
@@ -214,141 +174,7 @@ pattern CEventR tid ssh csh nId ptn
   = CourseR tid ssh csh (CourseEventR nId ptn)
 
 
-pluralDE :: (Eq a, Num a)
+-- Requires `rendeRoute`, thus cannot currently be moved to Foundation.I18n
-            =>    a -- ^ Count
-            -> Text -- ^ Singular
-            -> Text -- ^ Plural
-            -> Text
-pluralDE num singularForm pluralForm
-  | num == 1  = singularForm
-  | otherwise = pluralForm
-
-noneOneMoreDE :: (Eq a, Num a)
-            =>    a -- ^ Count
-            -> Text -- ^ None
-            -> Text -- ^ Singular
-            -> Text -- ^ Plural
-            -> Text
-noneOneMoreDE num noneText singularForm pluralForm
-  | num == 0  = noneText
-  | num == 1  = singularForm
-  | otherwise = pluralForm
-
-noneMoreDE :: (Eq a, Num a)
-            =>    a -- ^ Count
-            -> Text -- ^ None
-            -> Text -- ^ Some
-            -> Text
-noneMoreDE num noneText someText
-  | num == 0  = noneText
-  | otherwise = someText
-
-pluralEN :: (Eq a, Num a)
-            =>    a -- ^ Count
-            -> Text -- ^ Singular
-            -> Text -- ^ Plural
-            -> Text
-pluralEN num singularForm pluralForm
-  | num == 1  = singularForm
-  | otherwise = pluralForm
-
-noneOneMoreEN :: (Eq a, Num a)
-            =>    a -- ^ Count
-            -> Text -- ^ None
-            -> Text -- ^ Singular
-            -> Text -- ^ Plural
-            -> Text
-noneOneMoreEN num noneText singularForm pluralForm
-  | num == 0  = noneText
-  | num == 1  = singularForm
-  | otherwise = pluralForm
-
-noneMoreEN :: (Eq a, Num a)
-            =>    a -- ^ Count
-            -> Text -- ^ None
-            -> Text -- ^ Some
-            -> Text
-noneMoreEN num noneText someText
-  | num == 0  = noneText
-  | otherwise = someText
-
-ordinalEN :: ToMessage a
-          => a
-          -> Text
-ordinalEN (toMessage -> numStr) = case lastChar of
-  Just '1' -> [st|#{numStr}st|]
-  Just '2' -> [st|#{numStr}nd|]
-  Just '3' -> [st|#{numStr}rd|]
-  _other   -> [st|#{numStr}th|]
-  where
-    lastChar = last <$> fromNullable numStr 
-
-
--- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers
-type IntMaybe  = Maybe Int
-type TextList  = [Text]
-
--- | Convenience function for i18n messages definitions
-maybeToMessage :: ToMessage m => Text -> Maybe m -> Text -> Text
-maybeToMessage _      Nothing  _     = mempty
-maybeToMessage before (Just x) after = before <> (toMessage x) <> after
-
--- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
-mkMessage "UniWorX" "messages/uniworx" "de-de-formal"
-mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
-mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de"
-mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de"
-mkMessageVariant "UniWorX" "Button" "messages/button" "de"
-mkMessageVariant "UniWorX" "Frontend" "messages/frontend" "de-de-formal"
-
-instance RenderMessage UniWorX TermIdentifier where
-  renderMessage foundation ls TermIdentifier{..} = case season of
-    Summer -> renderMessage' $ MsgSummerTerm year
-    Winter -> renderMessage' $ MsgWinterTerm year
-    where renderMessage' = renderMessage foundation ls
-
-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
-    Winter -> renderMessage' $ MsgWinterTermShort year
-    where renderMessage' = renderMessage foundation ls
-
-instance RenderMessage UniWorX String where
-  renderMessage f ls str = renderMessage f ls $ Text.pack str
-
--- TODO: raw number representation; instead, display e.g. 1000 as 1.000 or 1,000 or ... (language-dependent!)
-instance RenderMessage UniWorX Int where
-  renderMessage f ls = renderMessage f ls . tshow
-instance RenderMessage UniWorX Int64 where
-  renderMessage f ls = renderMessage f ls . tshow
-instance RenderMessage UniWorX Integer where
-  renderMessage f ls = renderMessage f ls . tshow
-instance RenderMessage UniWorX Natural where
-  renderMessage f ls = renderMessage f ls . tshow
-
-instance HasResolution a => RenderMessage UniWorX (Fixed a) where
-  renderMessage f ls = renderMessage f ls . showFixed True
-
-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
-
-newtype MsgLanguage = MsgLanguage Lang
-  deriving (Eq, Ord, Show, Read)
-instance RenderMessage UniWorX MsgLanguage where
-  renderMessage foundation ls (MsgLanguage lang@(map mk . Text.splitOn "-" -> lang'))
-    | ("de" : "DE" : _) <- lang' = mr MsgGermanGermany
-    | ("de" : _)        <- lang' = mr MsgGerman
-    | ("en" : "EU" : _) <- lang' = mr MsgEnglishEurope
-    | ("en" : _)        <- lang' = mr MsgEnglish 
-    | otherwise = lang
-    where
-      mr = renderMessage foundation ls
-
 instance RenderMessage UniWorX (UnsupportedAuthPredicate AuthTag (Route UniWorX)) where
   renderMessage f ls (UnsupportedAuthPredicate tag route) = mr . MsgUnsupportedAuthPredicate (mr tag) $ Text.intercalate "/" pieces
     where
@@ -356,142 +182,6 @@ instance RenderMessage UniWorX (UnsupportedAuthPredicate AuthTag (Route UniWorX)
       mr = renderMessage f ls
       (pieces, _) = renderRoute route
 
-embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>)
-embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
-embedRenderMessage ''UniWorX ''StudyFieldType id
-embedRenderMessage ''UniWorX ''SheetFileType id
-embedRenderMessage ''UniWorX ''SubmissionFileType id
-embedRenderMessage ''UniWorX ''CorrectorState id
-embedRenderMessage ''UniWorX ''RatingException id
-embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>)
-embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
-embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
-embedRenderMessage ''UniWorX ''EncodedSecretBoxException id
-embedRenderMessage ''UniWorX ''LecturerType id
-embedRenderMessage ''UniWorX ''SubmissionModeDescr
-  $ let verbMap [_, _, "None"] = "NoSubmissions"
-        verbMap [_, _, v] = v <> "Submissions"
-        verbMap _ = error "Invalid number of verbs"
-     in verbMap . splitCamel
-embedRenderMessage ''UniWorX ''UploadModeDescr id
-embedRenderMessage ''UniWorX ''SecretJSONFieldException id
-embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel
-embedRenderMessage ''UniWorX ''SchoolFunction id
-embedRenderMessage ''UniWorX ''CsvPreset id
-embedRenderMessage ''UniWorX ''Quoting ("Csv" <>)
-embedRenderMessage ''UniWorX ''FavouriteReason id
-embedRenderMessage ''UniWorX ''Sex id
-
-embedRenderMessage ''UniWorX ''AuthenticationMode id
-
-newtype ShortSex = ShortSex Sex
-embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>)
-
-newtype SheetTypeHeader = SheetTypeHeader SheetType
-embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
-
-instance RenderMessage UniWorX SheetType where
-  renderMessage foundation ls sheetType = case sheetType of
-      NotGraded -> mr $ SheetTypeHeader NotGraded
-      other -> mr (grading other) <> ", " <> mr (SheetTypeHeader other)
-    where
-      mr :: RenderMessage UniWorX msg => msg -> Text
-      mr = renderMessage foundation ls
-
-instance RenderMessage UniWorX StudyDegree where
-  renderMessage _found _ls StudyDegree{..} = fromMaybe (tshow studyDegreeKey) (studyDegreeName <|> studyDegreeShorthand)
-
-newtype ShortStudyDegree = ShortStudyDegree StudyDegree
-
-instance RenderMessage UniWorX ShortStudyDegree where
-  renderMessage _found _ls (ShortStudyDegree StudyDegree{..}) = fromMaybe (tshow studyDegreeKey) studyDegreeShorthand
-
-instance RenderMessage UniWorX StudyTerms where
-  renderMessage _found _ls StudyTerms{..} = fromMaybe (tshow studyTermsKey) (studyTermsName <|> studyTermsShorthand)
-
-newtype ShortStudyTerms = ShortStudyTerms StudyTerms
-
-instance RenderMessage UniWorX ShortStudyTerms where
-  renderMessage _found _ls (ShortStudyTerms StudyTerms{..}) = fromMaybe (tshow studyTermsKey) studyTermsShorthand
-
-data StudyDegreeTerm = StudyDegreeTerm StudyDegree StudyTerms
-
-instance RenderMessage UniWorX StudyDegreeTerm where
-  renderMessage foundation ls (StudyDegreeTerm deg trm) = (mr trm) <> " (" <> (mr $ ShortStudyDegree deg) <> ")"
-    where
-      mr :: RenderMessage UniWorX msg => msg -> Text
-      mr = renderMessage foundation ls
-  
-newtype ShortStudyFieldType = ShortStudyFieldType StudyFieldType
-embedRenderMessageVariant ''UniWorX ''ShortStudyFieldType ("Short" <>)
-
-data StudyDegreeTermType = StudyDegreeTermType StudyDegree StudyTerms StudyFieldType
-
-instance RenderMessage UniWorX StudyDegreeTermType where
-  renderMessage foundation ls (StudyDegreeTermType deg trm typ) = (mr trm) <> " (" <> (mr $ ShortStudyDegree deg) <> ", " <> (mr $ ShortStudyFieldType typ) <> ")"
-    where
-      mr :: RenderMessage UniWorX msg => msg -> Text
-      mr = renderMessage foundation ls
-
-instance RenderMessage UniWorX ExamGrade where
-  renderMessage _ _ = pack . (showFixed False :: Deci -> String) . fromRational . review numberGrade
-
-instance RenderMessage UniWorX ExamPassed where
-  renderMessage foundation ls = \case
-    ExamPassed True  -> mr MsgExamPassed
-    ExamPassed False -> mr MsgExamNotPassed
-    where
-      mr :: RenderMessage UniWorX msg => msg -> Text
-      mr = renderMessage foundation ls
-
-instance RenderMessage UniWorX a => RenderMessage UniWorX (ExamResult' a) where
-  renderMessage foundation ls = \case
-    ExamAttended{..} -> mr examResult
-    ExamNoShow       -> mr MsgExamResultNoShow
-    ExamVoided       -> mr MsgExamResultVoided
-    where
-      mr :: RenderMessage UniWorX msg => msg -> Text
-      mr = renderMessage foundation ls
-
-instance RenderMessage UniWorX (Either ExamPassed ExamGrade) where
-  renderMessage foundation ls = either mr mr
-    where
-      mr :: RenderMessage UniWorX msg => msg -> Text
-      mr = renderMessage foundation ls
-
--- ToMessage instances for converting raw numbers to Text (no internationalization)
-
-instance ToMessage Int where
-  toMessage = tshow
-instance ToMessage Int64 where
-  toMessage = tshow
-instance ToMessage Integer where
-  toMessage = tshow
-instance ToMessage Natural where
-  toMessage = tshow
-
-instance HasResolution a => ToMessage (Fixed a) where
-  toMessage = toMessage . showFixed True
-
--- Do not use toMessage on Rationals and round them automatically. Instead, use rationalToFixed3 (declared in src/Utils.hs) to convert a Rational to Fixed E3!
--- instance ToMessage Rational where
---   toMessage = toMessage . fromRational'
---     where fromRational' = fromRational :: Rational -> Fixed E3
-
-
-newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse
-embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>)
-
-newtype UniWorXMessages = UniWorXMessages [SomeMessage UniWorX]
-  deriving (Generic, Typeable)
-  deriving newtype (Semigroup, Monoid, IsList)
-
-instance RenderMessage UniWorX UniWorXMessages where
-  renderMessage foundation ls (UniWorXMessages msgs) =
-    intercalate " " $ map (renderMessage foundation ls) msgs
-
-uniworxMessages :: [UniWorXMessage] -> UniWorXMessages
-uniworxMessages = UniWorXMessages . map SomeMessage
 
 -- Menus and Favourites
 data MenuType = NavbarAside | NavbarRight | NavbarSecondary | PageActionPrime | PageActionSecondary | Footer

src/Foundation/I18n.hs

@@ -0,0 +1,313 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Foundation.I18n
+  ( UniWorXMessage(..)
+  , ShortTermIdentifier(..)
+  , MsgLanguage(..)
+  , ShortSex(..)
+  , SheetTypeHeader(..)
+  , ShortStudyDegree(..)
+  , ShortStudyTerms(..)
+  , StudyDegreeTerm(..)
+  , ShortStudyFieldType(..)
+  , StudyDegreeTermType(..)
+  , ErrorResponseTitle(..)
+  , UniWorXMessages(..)
+  , uniworxMessages
+  ) where
+
+import Foundation.Type
+
+
+import Import.NoFoundation
+
+import Auth.LDAP
+import Auth.PWHash
+import Auth.Dummy
+
+import Data.CaseInsensitive (original, mk)
+
+import qualified Data.Text as Text
+
+import Utils.Form
+
+import Text.Shakespeare.Text (st)
+
+import GHC.Exts (IsList(..))
+
+
+pluralDE :: (Eq a, Num a)
+            =>    a -- ^ Count
+            -> Text -- ^ Singular
+            -> Text -- ^ Plural
+            -> Text
+pluralDE num singularForm pluralForm
+  | num == 1  = singularForm
+  | otherwise = pluralForm
+
+noneOneMoreDE :: (Eq a, Num a)
+            =>    a -- ^ Count
+            -> Text -- ^ None
+            -> Text -- ^ Singular
+            -> Text -- ^ Plural
+            -> Text
+noneOneMoreDE num noneText singularForm pluralForm
+  | num == 0  = noneText
+  | num == 1  = singularForm
+  | otherwise = pluralForm
+
+-- noneMoreDE :: (Eq a, Num a)
+--             =>    a -- ^ Count
+--             -> Text -- ^ None
+--             -> Text -- ^ Some
+--             -> Text
+-- noneMoreDE num noneText someText
+--   | num == 0  = noneText
+--   | otherwise = someText
+
+pluralEN :: (Eq a, Num a)
+            =>    a -- ^ Count
+            -> Text -- ^ Singular
+            -> Text -- ^ Plural
+            -> Text
+pluralEN num singularForm pluralForm
+  | num == 1  = singularForm
+  | otherwise = pluralForm
+
+noneOneMoreEN :: (Eq a, Num a)
+            =>    a -- ^ Count
+            -> Text -- ^ None
+            -> Text -- ^ Singular
+            -> Text -- ^ Plural
+            -> Text
+noneOneMoreEN num noneText singularForm pluralForm
+  | num == 0  = noneText
+  | num == 1  = singularForm
+  | otherwise = pluralForm
+
+-- noneMoreEN :: (Eq a, Num a)
+--             =>    a -- ^ Count
+--             -> Text -- ^ None
+--             -> Text -- ^ Some
+--             -> Text
+-- noneMoreEN num noneText someText
+--   | num == 0  = noneText
+--   | otherwise = someText
+
+ordinalEN :: ToMessage a
+          => a
+          -> Text
+ordinalEN (toMessage -> numStr) = case lastChar of
+  Just '1' -> [st|#{numStr}st|]
+  Just '2' -> [st|#{numStr}nd|]
+  Just '3' -> [st|#{numStr}rd|]
+  _other   -> [st|#{numStr}th|]
+  where
+    lastChar = last <$> fromNullable numStr 
+
+
+-- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers
+type IntMaybe  = Maybe Int
+
+-- | Convenience function for i18n messages definitions
+maybeToMessage :: ToMessage m => Text -> Maybe m -> Text -> Text
+maybeToMessage _      Nothing  _     = mempty
+maybeToMessage before (Just x) after = before <> toMessage x <> after
+
+-- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
+mkMessage "UniWorX" "messages/uniworx" "de-de-formal"
+mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
+mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de"
+mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de"
+mkMessageVariant "UniWorX" "Button" "messages/button" "de"
+mkMessageVariant "UniWorX" "Frontend" "messages/frontend" "de-de-formal"
+
+instance RenderMessage UniWorX TermIdentifier where
+  renderMessage foundation ls TermIdentifier{..} = case season of
+    Summer -> renderMessage' $ MsgSummerTerm year
+    Winter -> renderMessage' $ MsgWinterTerm year
+    where renderMessage' = renderMessage foundation ls
+
+newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
+  deriving stock (Eq, Ord, Read, Show)
+instance RenderMessage UniWorX ShortTermIdentifier where
+  renderMessage foundation ls (ShortTermIdentifier TermIdentifier{..}) = case season of
+    Summer -> renderMessage' $ MsgSummerTermShort year
+    Winter -> renderMessage' $ MsgWinterTermShort year
+    where renderMessage' = renderMessage foundation ls
+
+instance RenderMessage UniWorX String where
+  renderMessage f ls str = renderMessage f ls $ Text.pack str
+
+-- TODO: raw number representation; instead, display e.g. 1000 as 1.000 or 1,000 or ... (language-dependent!)
+instance RenderMessage UniWorX Int where
+  renderMessage f ls = renderMessage f ls . tshow
+instance RenderMessage UniWorX Int64 where
+  renderMessage f ls = renderMessage f ls . tshow
+instance RenderMessage UniWorX Integer where
+  renderMessage f ls = renderMessage f ls . tshow
+instance RenderMessage UniWorX Natural where
+  renderMessage f ls = renderMessage f ls . tshow
+
+instance HasResolution a => RenderMessage UniWorX (Fixed a) where
+  renderMessage f ls = renderMessage f ls . showFixed True
+
+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
+
+newtype MsgLanguage = MsgLanguage Lang
+  deriving stock (Eq, Ord, Show, Read)
+instance RenderMessage UniWorX MsgLanguage where
+  renderMessage foundation ls (MsgLanguage lang@(map mk . Text.splitOn "-" -> lang'))
+    | ("de" : "DE" : _) <- lang' = mr MsgGermanGermany
+    | ("de" : _)        <- lang' = mr MsgGerman
+    | ("en" : "EU" : _) <- lang' = mr MsgEnglishEurope
+    | ("en" : _)        <- lang' = mr MsgEnglish 
+    | otherwise = lang
+    where
+      mr = renderMessage foundation ls
+
+embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>)
+embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
+embedRenderMessage ''UniWorX ''StudyFieldType id
+embedRenderMessage ''UniWorX ''SheetFileType id
+embedRenderMessage ''UniWorX ''SubmissionFileType id
+embedRenderMessage ''UniWorX ''CorrectorState id
+embedRenderMessage ''UniWorX ''RatingException id
+embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>)
+embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
+embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
+embedRenderMessage ''UniWorX ''EncodedSecretBoxException id
+embedRenderMessage ''UniWorX ''LecturerType id
+embedRenderMessage ''UniWorX ''SubmissionModeDescr
+  $ let verbMap [_, _, "None"] = "NoSubmissions"
+        verbMap [_, _, v] = v <> "Submissions"
+        verbMap _ = error "Invalid number of verbs"
+     in verbMap . splitCamel
+embedRenderMessage ''UniWorX ''UploadModeDescr id
+embedRenderMessage ''UniWorX ''SecretJSONFieldException id
+embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel
+embedRenderMessage ''UniWorX ''SchoolFunction id
+embedRenderMessage ''UniWorX ''CsvPreset id
+embedRenderMessage ''UniWorX ''Quoting ("Csv" <>)
+embedRenderMessage ''UniWorX ''FavouriteReason id
+embedRenderMessage ''UniWorX ''Sex id
+
+embedRenderMessage ''UniWorX ''AuthenticationMode id
+
+newtype ShortSex = ShortSex Sex
+embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>)
+
+newtype SheetTypeHeader = SheetTypeHeader SheetType
+embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
+
+instance RenderMessage UniWorX SheetType where
+  renderMessage foundation ls sheetType = case sheetType of
+      NotGraded -> mr $ SheetTypeHeader NotGraded
+      other -> mr (grading other) <> ", " <> mr (SheetTypeHeader other)
+    where
+      mr :: RenderMessage UniWorX msg => msg -> Text
+      mr = renderMessage foundation ls
+
+instance RenderMessage UniWorX StudyDegree where
+  renderMessage _found _ls StudyDegree{..} = fromMaybe (tshow studyDegreeKey) (studyDegreeName <|> studyDegreeShorthand)
+
+newtype ShortStudyDegree = ShortStudyDegree StudyDegree
+
+instance RenderMessage UniWorX ShortStudyDegree where
+  renderMessage _found _ls (ShortStudyDegree StudyDegree{..}) = fromMaybe (tshow studyDegreeKey) studyDegreeShorthand
+
+instance RenderMessage UniWorX StudyTerms where
+  renderMessage _found _ls StudyTerms{..} = fromMaybe (tshow studyTermsKey) (studyTermsName <|> studyTermsShorthand)
+
+newtype ShortStudyTerms = ShortStudyTerms StudyTerms
+
+instance RenderMessage UniWorX ShortStudyTerms where
+  renderMessage _found _ls (ShortStudyTerms StudyTerms{..}) = fromMaybe (tshow studyTermsKey) studyTermsShorthand
+
+data StudyDegreeTerm = StudyDegreeTerm StudyDegree StudyTerms
+
+instance RenderMessage UniWorX StudyDegreeTerm where
+  renderMessage foundation ls (StudyDegreeTerm deg trm) = mr trm <> " (" <> mr (ShortStudyDegree deg) <> ")"
+    where
+      mr :: RenderMessage UniWorX msg => msg -> Text
+      mr = renderMessage foundation ls
+  
+newtype ShortStudyFieldType = ShortStudyFieldType StudyFieldType
+embedRenderMessageVariant ''UniWorX ''ShortStudyFieldType ("Short" <>)
+
+data StudyDegreeTermType = StudyDegreeTermType StudyDegree StudyTerms StudyFieldType
+
+instance RenderMessage UniWorX StudyDegreeTermType where
+  renderMessage foundation ls (StudyDegreeTermType deg trm typ) = mr trm <> " (" <> mr (ShortStudyDegree deg) <> ", " <> mr (ShortStudyFieldType typ) <> ")"
+    where
+      mr :: RenderMessage UniWorX msg => msg -> Text
+      mr = renderMessage foundation ls
+
+instance RenderMessage UniWorX ExamGrade where
+  renderMessage _ _ = pack . (showFixed False :: Deci -> String) . fromRational . review numberGrade
+
+instance RenderMessage UniWorX ExamPassed where
+  renderMessage foundation ls = \case
+    ExamPassed True  -> mr MsgExamPassed
+    ExamPassed False -> mr MsgExamNotPassed
+    where
+      mr :: RenderMessage UniWorX msg => msg -> Text
+      mr = renderMessage foundation ls
+
+instance RenderMessage UniWorX a => RenderMessage UniWorX (ExamResult' a) where
+  renderMessage foundation ls = \case
+    ExamAttended{..} -> mr examResult
+    ExamNoShow       -> mr MsgExamResultNoShow
+    ExamVoided       -> mr MsgExamResultVoided
+    where
+      mr :: RenderMessage UniWorX msg => msg -> Text
+      mr = renderMessage foundation ls
+
+instance RenderMessage UniWorX (Either ExamPassed ExamGrade) where
+  renderMessage foundation ls = either mr mr
+    where
+      mr :: RenderMessage UniWorX msg => msg -> Text
+      mr = renderMessage foundation ls
+
+-- ToMessage instances for converting raw numbers to Text (no internationalization)
+
+instance ToMessage Int where
+  toMessage = tshow
+instance ToMessage Int64 where
+  toMessage = tshow
+instance ToMessage Integer where
+  toMessage = tshow
+instance ToMessage Natural where
+  toMessage = tshow
+
+instance HasResolution a => ToMessage (Fixed a) where
+  toMessage = toMessage . showFixed True
+
+-- Do not use toMessage on Rationals and round them automatically. Instead, use rationalToFixed3 (declared in src/Utils.hs) to convert a Rational to Fixed E3!
+-- instance ToMessage Rational where
+--   toMessage = toMessage . fromRational'
+--     where fromRational' = fromRational :: Rational -> Fixed E3
+
+
+newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse
+embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>)
+
+newtype UniWorXMessages = UniWorXMessages [SomeMessage UniWorX]
+  deriving stock (Generic, Typeable)
+  deriving newtype (Semigroup, Monoid)
+
+instance IsList UniWorXMessages where
+  type Item UniWorXMessages = SomeMessage UniWorX
+  fromList = UniWorXMessages
+  toList (UniWorXMessages msgs) = msgs
+
+instance RenderMessage UniWorX UniWorXMessages where
+  renderMessage foundation ls (UniWorXMessages msgs) =
+    Text.unwords $ map (renderMessage foundation ls) msgs
+
+uniworxMessages :: [UniWorXMessage] -> UniWorXMessages
+uniworxMessages = UniWorXMessages . map SomeMessage

src/Foundation/Type.hs

@@ -0,0 +1,58 @@
+module Foundation.Type
+  ( UniWorX(..)
+  , SMTPPool
+  , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionKey, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport
+  ) where
+
+import Import.NoFoundation
+import Database.Persist.Sql (ConnectionPool)
+
+import qualified Web.ClientSession as ClientSession
+
+import Jobs.Types
+
+import Yesod.Core.Types (Logger)
+
+import Data.Set (Set)
+
+import qualified Crypto.Saltine.Core.SecretBox as SecretBox
+import qualified Jose.Jwk as Jose
+
+import qualified Database.Memcached.Binary.IO as Memcached
+
+
+type SMTPPool = Pool SMTPConnection
+
+-- | The foundation datatype for your application. This can be a good place to
+-- keep settings and values requiring initialization before your application
+-- starts running, such as database connections. Every handler will have
+-- access to the data present here.
+data UniWorX = UniWorX
+    { appSettings'       :: AppSettings
+    , appStatic          :: EmbeddedStatic -- ^ Settings for static file serving.
+    , appConnPool        :: ConnectionPool -- ^ Database connection pool.
+    , appSmtpPool        :: Maybe SMTPPool
+    , appLdapPool        :: Maybe LdapPool
+    , appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool
+    , appHttpManager     :: Manager
+    , appLogger          :: (ReleaseKey, TVar Logger)
+    , appLogSettings     :: TVar LogSettings
+    , appCryptoIDKey     :: CryptoIDKey
+    , appClusterID       :: ClusterId
+    , appInstanceID      :: InstanceId
+    , appJobState        :: TMVar JobState
+    , appSessionKey      :: ClientSession.Key
+    , appSecretBoxKey    :: SecretBox.Key
+    , appJSONWebKeySet   :: Jose.JwkSet
+    , appHealthReport    :: TVar (Set (UTCTime, HealthReport))
+    }
+
+makeLenses_ ''UniWorX
+instance HasInstanceID UniWorX InstanceId where
+  instanceID = _appInstanceID
+instance HasJSONWebKeySet UniWorX Jose.JwkSet where
+  jsonWebKeySet = _appJSONWebKeySet
+instance HasHttpManager UniWorX Manager where
+  httpManager = _appHttpManager
+instance HasAppSettings UniWorX where
+  appSettings = _appSettings'