fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into datepicker-focusout

Browse Source
This commit is contained in:
Sarah Vaupel 2019-11-14 15:33:10 +01:00
commit 976ea1206e
8 changed files with 390 additions and 328 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
.gitlab-ci.yml
View File

@ -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

4
CHANGELOG.md
View File

@ -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)

2
package-lock.json generated
View File

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

2
package.json
View File

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

2
package.yaml
View File

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

328
src/Foundation.hs
View File

@ -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)
=> 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
-- Requires `rendeRoute`, thus cannot currently be moved to Foundation.I18n
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

313
src/Foundation/I18n.hs Normal file
View File

@ -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

58
src/Foundation/Type.hs Normal file
View File

@ -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'