57 lines
2.3 KiB
Haskell
57 lines
2.3 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Utils.SystemMessage where
|
|
|
|
import Import.NoFoundation
|
|
|
|
import qualified Data.List.NonEmpty as NonEmpty
|
|
import Data.List (findIndex)
|
|
|
|
|
|
getSystemMessage :: (MonadHandler m, BackendCompatible SqlReadBackend backend)
|
|
=> SystemMessageId
|
|
-> ReaderT backend m (Maybe (SystemMessage, Maybe SystemMessageTranslation))
|
|
getSystemMessage smId = withReaderT (projectBackend @SqlReadBackend) . runMaybeT $ do
|
|
SystemMessage{..} <- MaybeT $ get smId
|
|
translations <- lift $ selectList [SystemMessageTranslationMessage ==. smId] []
|
|
let
|
|
avL = NonEmpty.sortWith (\l -> NTop $ findIndex (langMatches l) $ NonEmpty.toList appLanguages) $ systemMessageDefaultLanguage :| map (systemMessageTranslationLanguage . entityVal) translations
|
|
lang <- selectLanguage avL
|
|
return (SystemMessage{..}, find (langMatches lang . systemMessageTranslationLanguage) $ map entityVal translations)
|
|
|
|
systemMessageToTranslation :: SystemMessageId
|
|
-> (SystemMessage, Maybe SystemMessageTranslation)
|
|
-> SystemMessageTranslation
|
|
systemMessageToTranslation systemMessageTranslationMessage (SystemMessage{..}, Nothing)
|
|
= SystemMessageTranslation
|
|
{ systemMessageTranslationMessage
|
|
, systemMessageTranslationLanguage = systemMessageDefaultLanguage
|
|
, systemMessageTranslationContent = systemMessageContent
|
|
, systemMessageTranslationSummary = systemMessageSummary
|
|
}
|
|
systemMessageToTranslation _ (_, Just t) = t
|
|
|
|
|
|
|
|
data UserSystemMessageState = UserSystemMessageState
|
|
{ userSystemMessageShown
|
|
, userSystemMessageHidden
|
|
, userSystemMessageUnhidden :: Maybe UTCTime
|
|
} deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
deriveJSON defaultOptions
|
|
{ fieldLabelModifier = camelToPathPiece' 3
|
|
, omitNothingFields = True
|
|
} ''UserSystemMessageState
|
|
|
|
instance Semigroup UserSystemMessageState where
|
|
a <> b = UserSystemMessageState
|
|
{ userSystemMessageShown = (max `on` userSystemMessageShown ) a b
|
|
, userSystemMessageHidden = (max `on` userSystemMessageHidden) a b
|
|
, userSystemMessageUnhidden = (max `on` userSystemMessageUnhidden) a b
|
|
}
|
|
instance Monoid UserSystemMessageState where
|
|
mempty = UserSystemMessageState Nothing Nothing Nothing
|