From a23841e4f8999b7303d2e7cdb644f9f178964294 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 17 Oct 2018 22:30:47 +0200 Subject: [PATCH] Start work on SystemMessages --- messages/uniworx/de.msg | 3 ++ models | 16 +++++++- routes | 3 ++ src/Application.hs | 1 + src/CryptoID.hs | 1 + src/Foundation.hs | 63 ++++++++++++++++++++++++++---- src/Handler/Admin.hs | 2 +- src/Handler/SystemMessage.hs | 19 +++++++++ src/Import.hs | 2 + src/Import/NoFoundation.hs | 1 + src/Model.hs | 2 + src/Utils.hs | 18 +++++++++ src/Utils/Lang.hs | 39 ++++++++++++++++++ src/Utils/Message.hs | 14 +++++-- src/Utils/SystemMessage.hs | 26 ++++++++++++ templates/standalone/alerts.lucius | 4 ++ templates/system-message.hamlet | 6 +++ 17 files changed, 208 insertions(+), 12 deletions(-) create mode 100644 src/Handler/SystemMessage.hs create mode 100644 src/Utils/Lang.hs create mode 100644 src/Utils/SystemMessage.hs create mode 100644 templates/system-message.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 5be0e189a..ea7f457ac 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -165,6 +165,8 @@ DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen. UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben. MaterialFree: Kursmaterialien ohne Anmeldung zugänglich UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung +UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar. +UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar. UnsupportedAuthPredicate tag@String shownRoute@String: "!#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute} EMail: E-Mail @@ -198,6 +200,7 @@ LoginTitle: Authentifizierung ProfileHeading: Benutzereinstellungen ProfileDataHeading: Gespeicherte Benutzerdaten ImpressumHeading: Impressum +SystemMessageHeading: Uni2Work Statusmeldung NumCourses n@Int64: #{display n} Kurse CloseAlert: Schliessen diff --git a/models b/models index d53603dd1..1398a65a5 100644 --- a/models +++ b/models @@ -241,4 +241,18 @@ CronLastExec job Value time UTCTime instance InstanceId - UniqueCronLastExec job \ No newline at end of file + UniqueCronLastExec job +SystemMessage + from UTCTime Maybe + to UTCTime Maybe + authenticatedOnly Bool + severity MessageClass + defaultLanguage Lang + content Html + summary Html Maybe +SystemMessageTranslation + message SystemMessageId + language Lang + content Html + summary Html Maybe + UniqueSystemMessageTranslation message language \ No newline at end of file diff --git a/routes b/routes index 2e8f1dd75..50d77226a 100644 --- a/routes +++ b/routes @@ -89,5 +89,8 @@ /corrections/create CorrectionsCreateR GET POST !corrector !lecturer +/msg/#{CryptoUUIDSystemMessage} MessageR GET POST !timeANDisReadANDauthentication + + !/#UUID CryptoUUIDDispatchR GET !free -- just redirect -- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists diff --git a/src/Application.hs b/src/Application.hs index 4f07f3de0..c0a92d695 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -78,6 +78,7 @@ import Handler.Sheet import Handler.Submission import Handler.Corrections import Handler.CryptoIDDispatch +import Handler.SystemMessage -- This line actually creates our YesodDispatch instance. It is the second half diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 4dc744228..9f555ef3e 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -39,6 +39,7 @@ decCryptoIDs [ ''SubmissionId , ''FileId , ''UserId , ''SheetId + , ''SystemMessageId ] instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where diff --git a/src/Foundation.hs b/src/Foundation.hs index a8ebf44b8..4223c7fe7 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -56,6 +56,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map, (!?)) import qualified Data.Map as Map +import Data.List (findIndex) import Data.Monoid (Any(..)) @@ -82,6 +83,7 @@ import Control.Lens import Utils import Utils.Form import Utils.Lens +import Utils.SystemMessage import Data.Aeson hiding (Error) import Data.Aeson.TH @@ -92,6 +94,8 @@ import Text.Shakespeare.Text (st) import Yesod.Form.I18n.German import qualified Yesod.Auth.Message as Auth +import qualified Data.Conduit.List as C + instance DisplayAble b => DisplayAble (E.CryptoID a b) where display = display . ciphertext @@ -272,20 +276,21 @@ getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8")]) appTZ :: TZ appTZ = $(includeSystemTZ "Europe/Berlin") -appLanguages :: ( MonadHandler m - , HandlerSite m ~ UniWorX - ) => m (OptionList Lang) +appLanguages :: NonEmpty Lang +appLanguages = "de-DE" :| [] + +appLanguagesOpts :: ( MonadHandler m + , HandlerSite m ~ UniWorX + ) => m (OptionList Lang) -- ^ Authoritive list of supported Languages -appLanguages = do +appLanguagesOpts = do mr <- getsYesod renderMessage let mkOption l = Option { optionDisplay = mr (l : filter (/= l) (optionInternalValue <$> langOptions)) (MsgLanguage l) , optionInternalValue = l , optionExternalValue = l } - langOptions = map mkOption - [ "de-DE" - ] + langOptions = map mkOption $ toList appLanguages return $ mkOptionList langOptions @@ -435,6 +440,14 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req && NTop courseRegisterTo >= cTime return Authorized + MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do + smId <- decrypt cID + SystemMessage{..} <- MaybeT $ get smId + cTime <- (NTop . Just) <$> liftIO getCurrentTime + guard $ NTop systemMessageFrom <= cTime + && NTop systemMessageTo >= cTime + return Authorized + r -> $unsupportedAuthPredicate "time" r ) ,("registered", APDB $ \route _ -> case route of @@ -498,6 +511,15 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req return Authorized r -> $unsupportedAuthPredicate "corrector-submissions" r ) + ,("authentication", APDB $ \route _ -> case route of + MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do + smId <- decrypt cID + SystemMessage{..} <- MaybeT $ get smId + isAuthenticated <- isJust <$> liftHandlerT maybeAuthId + guard $ not systemMessageAuthenticatedOnly || isAuthenticated + return Authorized + r -> $unsupportedAuthPredicate "authentication" r + ) ,("isRead", APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)) ,("isWrite", APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)) ] @@ -599,6 +621,8 @@ instance Yesod UniWorX where defaultLayout widget = do master <- getYesod let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master + + applySystemMessages mmsgs <- getMessages mcurrentRoute <- getCurrentRoute @@ -732,6 +756,29 @@ instance Yesod UniWorX where makeLogger = return . appLogger +applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m () +applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage + where + applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do + cID <- encrypt smId + let sessionKey = "sm-" <> tshow (ciphertext cID) + assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False + assertM isNothing (lookupSessionJson sessionKey :: MaybeT (YesodDB UniWorX) (Maybe ())) + setSessionJson sessionKey () + (SystemMessage{..}, smTrans) <- MaybeT $ getSystemMessage appLanguages smId + let + (summary, content) = case smTrans of + Nothing -> (systemMessageSummary, systemMessageContent) + Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent) + case summary of + Just s -> do + html <- withUrlRenderer [hamlet| + + #{s} + |] + addMessage systemMessageSeverity html + Nothing -> addMessage systemMessageSeverity content + -- Define breadcrumbs. instance YesodBreadcrumbs UniWorX where breadcrumb (AuthR _) = return ("Login" , Just HomeR) @@ -1177,6 +1224,8 @@ pageHeading CorrectionsUploadR = Just $ i18nHeading MsgCorrUpload pageHeading CorrectionsCreateR = Just $ i18nHeading MsgCorrCreate +pageHeading (MessageR _) + = Just $ i18nHeading MsgSystemMessageHeading -- TODO: add headings for more single course- and single term-pages pageHeading _ diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 6de79e526..1b5c3ae9d 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -49,7 +49,7 @@ emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext) emailTestForm = (,) <$> areq emailField (fslI MsgMailTestFormEmail) Nothing <*> ( MailContext - <$> (MailLanguages <$> areq (reorderField appLanguages) (fslI MsgMailTestFormLanguages) Nothing) + <$> (MailLanguages <$> areq (reorderField appLanguagesOpts) (fslI MsgMailTestFormLanguages) Nothing) <*> (toMailDateTimeFormat <$> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) Nothing <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs new file mode 100644 index 000000000..5558d7f32 --- /dev/null +++ b/src/Handler/SystemMessage.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , TemplateHaskell + #-} + +module Handler.SystemMessage where + +import Import + +getMessageR, postMessageR :: CryptoUUIDSystemMessage -> Handler Html +getMessageR = postMessageR +postMessageR cID = do + smId <- decrypt cID + (SystemMessage{..}, translation) <- runDB $ maybe notFound return =<< getSystemMessage appLanguages smId + let (summary, content) = case translation of + Nothing -> (systemMessageSummary, systemMessageContent) + Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent) + defaultLayout $ do + $(widgetFile "system-message") diff --git a/src/Import.hs b/src/Import.hs index a10200156..27dc6e5df 100644 --- a/src/Import.hs +++ b/src/Import.hs @@ -4,3 +4,5 @@ module Import import Foundation as Import import Import.NoFoundation as Import + +import Utils.SystemMessage as Import diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index e337b361f..9268563f8 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -36,3 +36,4 @@ import Data.Typeable as Import (Typeable) import GHC.Generics as Import (Generic) import Data.Hashable as Import +import Data.List.NonEmpty as Import (NonEmpty(..)) diff --git a/src/Model.hs b/src/Model.hs index 5d3b51e3f..70f66d5d9 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -32,6 +32,8 @@ import Data.Aeson.TH (deriveJSON, defaultOptions) import Data.CaseInsensitive (CI) import Data.CaseInsensitive.Instances () +import Utils.Message (MessageClass) + -- You can define all of your database entities in the entities file. -- You can find more information on persistent and how to declare entities -- at: diff --git a/src/Utils.hs b/src/Utils.hs index 08343ec80..17795138c 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -21,11 +21,14 @@ import Data.Foldable as Fold hiding (length) import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI +import qualified Data.ByteString.Lazy as LBS + import Utils.DB as Utils import Utils.TH as Utils import Utils.DateTime as Utils import Utils.PathPiece as Utils import Utils.Message as Utils +import Utils.Lang as Utils import Text.Blaze (Markup, ToMarkup) @@ -53,6 +56,8 @@ import Instances.TH.Lift () import Text.Shakespeare.Text (st) +import qualified Data.Aeson as Aeson + ----------- @@ -312,6 +317,9 @@ maybeM dft act mb = mb >>= maybe dft act maybeT :: Monad m => m a -> MaybeT m a -> m a maybeT x m = runMaybeT m >>= maybe x return +maybeT_ :: Monad m => MaybeT m () -> m () +maybeT_ = void . runMaybeT + catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a catchIfMaybeT p act = catchIf p (lift act) (const mzero) @@ -434,3 +442,13 @@ orM = Fold.foldr or2M (return False) anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool anyM xs f = orM $ fmap f xs + +-------------- +-- Sessions -- +-------------- + +setSessionJson :: (PathPiece k, ToJSON v, MonadHandler m) => k -> v -> m () +setSessionJson (toPathPiece -> key) (LBS.toStrict . Aeson.encode -> val) = setSessionBS key val + +lookupSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v) +lookupSessionJson (toPathPiece -> key) = (Aeson.decode' . LBS.fromStrict =<<) <$> lookupSessionBS key diff --git a/src/Utils/Lang.hs b/src/Utils/Lang.hs new file mode 100644 index 000000000..6556cede3 --- /dev/null +++ b/src/Utils/Lang.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Utils.Lang where + +import ClassyPrelude.Yesod + +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty (NonEmpty(..)) + +import qualified Data.Text as Text + + +selectLanguage :: MonadHandler m + => NonEmpty Lang -- ^ Available translations, first is default + -> m Lang +selectLanguage avL = selectLanguage' avL <$> languages + +selectLanguage' :: NonEmpty Lang -- ^ Available translations, first is default + -> [Lang] -- ^ Languages in preference order + -> Lang +selectLanguage' (defL :| _) [] = defL +selectLanguage' avL (l:ls) + | not $ null l + , Just l' <- find (== l) (NonEmpty.toList avL) + = l' + | not $ null l + , Just lParts <- NonEmpty.nonEmpty $ Text.splitOn "-" l + , found <- find ((NonEmpty.toList lParts `isPrefixOf`) . Text.splitOn "-") avL + = case found of + Just l' -> l' + Nothing -> selectLanguage' avL $ Text.intercalate "-" (NonEmpty.tail lParts) : ls + | otherwise = selectLanguage' avL ls + +langMatches :: Lang -- ^ Needle + -> Lang -- ^ Haystack + -> Bool +langMatches = isPrefixOf `on` Text.splitOn "-" diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index b716e1a49..d0d61e68a 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -11,9 +11,10 @@ module Utils.Message ) where -import Data.Text as Text (toLower) import Data.Universe import Utils.PathPiece (finiteFromPathPiece, nullaryToPathPiece) +import Data.Aeson +import Data.Aeson.TH import qualified ClassyPrelude.Yesod (addMessage, addMessageI) import ClassyPrelude.Yesod hiding (addMessage, addMessageI) @@ -25,17 +26,24 @@ import Language.Haskell.TH.Syntax (Lift) data MessageClass = Error | Warning | Info | Success - deriving (Eq,Ord,Enum,Bounded,Show,Read,Lift) + deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift) instance Universe MessageClass instance Finite MessageClass $( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813 +deriveJSON defaultOptions + { constructorTagModifier = toLower + } ''MessageClass + instance PathPiece MessageClass where - toPathPiece = $(nullaryToPathPiece ''MessageClass [Text.toLower]) + toPathPiece = $(nullaryToPathPiece ''MessageClass [toLower]) fromPathPiece = finiteFromPathPiece +derivePersistField "MessageClass" + + addMessage :: MonadHandler m => MessageClass-> Html -> m () addMessage mc = ClassyPrelude.Yesod.addMessage (toPathPiece mc) diff --git a/src/Utils/SystemMessage.hs b/src/Utils/SystemMessage.hs new file mode 100644 index 000000000..163722a66 --- /dev/null +++ b/src/Utils/SystemMessage.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + #-} + +module Utils.SystemMessage where + +import Import.NoFoundation +import Utils + +import qualified Data.List.NonEmpty as NonEmpty +import Data.List (findIndex) + +import Control.Monad.Trans.Maybe (MaybeT(..)) + + +getSystemMessage :: MonadHandler m + => NonEmpty Lang -- ^ `appLanguages` + -> SystemMessageId + -> ReaderT SqlBackend m (Maybe (SystemMessage, Maybe SystemMessageTranslation)) +getSystemMessage appLanguages smId = 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) diff --git a/templates/standalone/alerts.lucius b/templates/standalone/alerts.lucius index c1660b903..c2479508d 100644 --- a/templates/standalone/alerts.lucius +++ b/templates/standalone/alerts.lucius @@ -82,6 +82,10 @@ transition: margin-bottom .2s ease-out; } +.alert a { + color: var(--color-lightwhite); +} + @keyframes slide-in-alert { from { transform: translateY(120%); diff --git a/templates/system-message.hamlet b/templates/system-message.hamlet new file mode 100644 index 000000000..728de8597 --- /dev/null +++ b/templates/system-message.hamlet @@ -0,0 +1,6 @@ +
+ $maybe summary' <- summary +

+ #{summary'} +

+ #{content}