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

MessageClass → MessageStatus

Browse Source
This commit is contained in:
Gregor Kleen 2019-03-10 15:47:33 +01:00
parent 824a8e24e1
commit 101822fd21
6 changed files with 30 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
models/system-messages
View File

@ -2,7 +2,7 @@ SystemMessage
from UTCTime Maybe from UTCTime Maybe
to UTCTime Maybe to UTCTime Maybe
authenticatedOnly Bool authenticatedOnly Bool
severity MessageClass severity MessageStatus
defaultLanguage Lang defaultLanguage Lang
content Html content Html
summary Html Maybe summary Html Maybe

2
src/Foundation.hs
View File

@ -220,7 +220,7 @@ instance RenderMessage UniWorX MsgLanguage where
instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route) renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)
embedRenderMessage ''UniWorX ''MessageClass ("Message" <>) embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>)
embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
embedRenderMessage ''UniWorX ''StudyFieldType id embedRenderMessage ''UniWorX ''StudyFieldType id
embedRenderMessage ''UniWorX ''SheetFileType id embedRenderMessage ''UniWorX ''SheetFileType id

2
src/Handler/Utils/Form.hs
View File

@ -654,5 +654,5 @@ formResultModal res finalDest handler = maybeT_ $ do
if if
| isModal -> sendResponse $ toJSON messages | isModal -> sendResponse $ toJSON messages
| otherwise -> do | otherwise -> do
forM_ messages $ \Message{..} -> addMessage messageClass messageContent forM_ messages $ \Message{..} -> addMessage messageStatus messageContent
redirect finalDest redirect finalDest

2
src/Model.hs
View File

@ -19,7 +19,7 @@ import Data.Aeson (Value)
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import Data.CaseInsensitive.Instances () import Data.CaseInsensitive.Instances ()
import Utils.Message (MessageClass) import Utils.Message (MessageStatus)
import Settings.Cluster (ClusterSettingsKey) import Settings.Cluster (ClusterSettingsKey)
import Data.Binary (Binary) import Data.Binary (Binary)

2
src/Settings.hs
View File

@ -39,7 +39,7 @@ import qualified Data.Text.Encoding as Text
import qualified Ldap.Client as Ldap import qualified Ldap.Client as Ldap
import Utils hiding (MessageClass(..)) import Utils hiding (MessageStatus(..))
import Control.Lens import Control.Lens
import Data.Maybe (fromJust) import Data.Maybe (fromJust)

50
src/Utils/Message.hs
View File

@ -1,6 +1,6 @@
module Utils.Message module Utils.Message
( MessageClass(..) ( MessageStatus(..)
, UnknownMessageClass(..) , UnknownMessageStatus(..)
, addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget
, Message(..) , Message(..)
, messageI, messageIHamlet, messageFile, messageWidget , messageI, messageIHamlet, messageFile, messageWidget
@ -25,64 +25,64 @@ import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.HTML.SanitizeXSS (sanitizeBalance) import Text.HTML.SanitizeXSS (sanitizeBalance)
data MessageClass = Error | Warning | Info | Success data MessageStatus = Error | Warning | Info | Success
deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift) deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift)
instance Universe MessageClass instance Universe MessageStatus
instance Finite MessageClass instance Finite MessageStatus
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece { constructorTagModifier = camelToPathPiece
} ''MessageClass } ''MessageStatus
nullaryPathPiece ''MessageClass camelToPathPiece nullaryPathPiece ''MessageStatus camelToPathPiece
derivePersistField "MessageClass" derivePersistField "MessageStatus"
newtype UnknownMessageClass = UnknownMessageClass Text newtype UnknownMessageStatus = UnknownMessageStatus Text
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Exception UnknownMessageClass instance Exception UnknownMessageStatus
data Message = Message data Message = Message
{ messageClass :: MessageClass { messageStatus :: MessageStatus
, messageContent :: Html , messageContent :: Html
} }
instance Eq Message where instance Eq Message where
a == b = ((==) `on` messageClass) a b && ((==) `on` renderHtml . messageContent) a b a == b = ((==) `on` messageStatus) a b && ((==) `on` renderHtml . messageContent) a b
instance Ord Message where instance Ord Message where
a `compare` b = (compare `on` messageClass) a b `mappend` (compare `on` renderHtml . messageContent) a b a `compare` b = (compare `on` messageStatus) a b `mappend` (compare `on` renderHtml . messageContent) a b
instance ToJSON Message where instance ToJSON Message where
toJSON Message{..} = object toJSON Message{..} = object
[ "class" .= messageClass [ "status" .= messageStatus
, "content" .= renderHtml messageContent , "content" .= renderHtml messageContent
] ]
instance FromJSON Message where instance FromJSON Message where
parseJSON = withObject "Message" $ \o -> do parseJSON = withObject "Message" $ \o -> do
messageClass <- o .: "class" messageStatus <- o .: "status"
messageContent <- preEscapedText . sanitizeBalance <$> o .: "content" messageContent <- preEscapedText . sanitizeBalance <$> o .: "content"
return Message{..} return Message{..}
addMessage :: MonadHandler m => MessageClass -> Html -> m () addMessage :: MonadHandler m => MessageStatus -> Html -> m ()
addMessage mc = ClassyPrelude.Yesod.addMessage (toPathPiece mc) addMessage mc = ClassyPrelude.Yesod.addMessage (toPathPiece mc)
addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m () addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m ()
addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc) addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc)
messageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m Message messageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageStatus -> msg -> m Message
messageI messageClass msg = do messageI messageStatus msg = do
messageContent <- toHtml . ($ msg) <$> getMessageRender messageContent <- toHtml . ($ msg) <$> getMessageRender
return Message{..} return Message{..}
addMessageIHamlet :: ( MonadHandler m addMessageIHamlet :: ( MonadHandler m
, RenderMessage (HandlerSite m) msg , RenderMessage (HandlerSite m) msg
, HandlerSite m ~ site , HandlerSite m ~ site
) => MessageClass -> HtmlUrlI18n msg (Route site) -> m () ) => MessageStatus -> HtmlUrlI18n msg (Route site) -> m ()
addMessageIHamlet mc iHamlet = do addMessageIHamlet mc iHamlet = do
mr <- getMessageRender mr <- getMessageRender
ClassyPrelude.Yesod.addMessage (toPathPiece mc) =<< withUrlRenderer (iHamlet $ toHtml . mr) ClassyPrelude.Yesod.addMessage (toPathPiece mc) =<< withUrlRenderer (iHamlet $ toHtml . mr)
@ -90,22 +90,22 @@ addMessageIHamlet mc iHamlet = do
messageIHamlet :: ( MonadHandler m messageIHamlet :: ( MonadHandler m
, RenderMessage (HandlerSite m) msg , RenderMessage (HandlerSite m) msg
, HandlerSite m ~ site , HandlerSite m ~ site
) => MessageClass -> HtmlUrlI18n msg (Route site) -> m Message ) => MessageStatus -> HtmlUrlI18n msg (Route site) -> m Message
messageIHamlet mc iHamlet = do messageIHamlet mc iHamlet = do
mr <- getMessageRender mr <- getMessageRender
Message mc <$> withUrlRenderer (iHamlet $ toHtml . mr) Message mc <$> withUrlRenderer (iHamlet $ toHtml . mr)
addMessageFile :: MessageClass -> FilePath -> ExpQ addMessageFile :: MessageStatus -> FilePath -> ExpQ
addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|] addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|]
messageFile :: MessageClass -> FilePath -> ExpQ messageFile :: MessageStatus -> FilePath -> ExpQ
messageFile mc tPath = [e|messageIHamlet mc $(ihamletFile tPath)|] messageFile mc tPath = [e|messageIHamlet mc $(ihamletFile tPath)|]
addMessageWidget :: forall m site. addMessageWidget :: forall m site.
( MonadHandler m ( MonadHandler m
, HandlerSite m ~ site , HandlerSite m ~ site
, Yesod site , Yesod site
) => MessageClass -> WidgetT site IO () -> m () ) => MessageStatus -> WidgetT site IO () -> m ()
-- ^ _Note_: `addMessageWidget` ignores `pageTitle` and `pageHead` -- ^ _Note_: `addMessageWidget` ignores `pageTitle` and `pageHead`
addMessageWidget mc wgt = do addMessageWidget mc wgt = do
PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt
@ -115,7 +115,7 @@ messageWidget :: forall m site.
( MonadHandler m ( MonadHandler m
, HandlerSite m ~ site , HandlerSite m ~ site
, Yesod site , Yesod site
) => MessageClass -> WidgetT site IO () -> m Message ) => MessageStatus -> WidgetT site IO () -> m Message
messageWidget mc wgt = do messageWidget mc wgt = do
PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt
messageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site)) messageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site))