Start work on SystemMessages

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

models

@@ -241,4 +241,18 @@ CronLastExec
     job                 Value
     time                UTCTime
     instance            InstanceId
-    UniqueCronLastExec job
+    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

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

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

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

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|
+              <a href=@{MessageR cID}>
+                #{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 _

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

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

src/Import.hs

@@ -4,3 +4,5 @@ module Import
 
 import Foundation            as Import
 import Import.NoFoundation   as Import
+
+import Utils.SystemMessage   as Import

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(..))

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:

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

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

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)
 

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)

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%);

templates/system-message.hamlet

@@ -0,0 +1,6 @@
+<section>
+  $maybe summary' <- summary
+    <h2>
+      #{summary'}
+  <p>
+    #{content}