diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 19ba3fb20..9057a6839 100644 --- a/.gitlab-ci.yml +++ b/.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 =4.9.1.0 && <5 diff --git a/src/Foundation.hs b/src/Foundation.hs index 501c7b22b..2470d2088 100644 --- a/src/Foundation.hs +++ b/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) - => 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 diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs new file mode 100644 index 000000000..99406decd --- /dev/null +++ b/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 diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs new file mode 100644 index 000000000..5b63b9080 --- /dev/null +++ b/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'