Time formatting in emails

db.hs

@@ -83,6 +83,7 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userMailLanguages = MailLanguages ["en"]
     , userNotificationSettings = def
     }
   fhamann <- insert User
@@ -98,6 +99,7 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userMailLanguages = MailLanguages ["de"]
     , userNotificationSettings = def
     }
   jost <- insert User
@@ -113,6 +115,7 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userMailLanguages = MailLanguages ["de"]
     , userNotificationSettings = def
     }
   void . insert $ User
@@ -128,6 +131,7 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userMailLanguages = MailLanguages ["de"]
     , userNotificationSettings = def
     }
   void . insert $ User
@@ -143,6 +147,7 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userMailLanguages = MailLanguages ["de"]
     , userNotificationSettings = def
     }
   void . repsert (TermKey summer2017) $ Term

messages/uniworx/de.msg

@@ -314,9 +314,23 @@ MailTestFormLanguages: Spracheinstellungen
 
 MailTestSubject: Uni2Work Test-Email
 MailTestContent: Dies ist eine Test-Email versandt von Uni2Work. Von Ihrer Seite ist keine Handlung notwendig.
+MailTestDateTime: Test der Datumsformattierung:
 
 German: Deutsch
 GermanGermany: Deutsch (Deutschland)
 
 MailSubjectSubmissionRated csh@CourseShorthand: Ihre #{csh}-Abgabe wurde bewertet
-MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{courseName} (#{termDesc}) wurde bewertet.
+MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{courseName} (#{termDesc}) wurde bewertet.
+
+SheetTypeBonus: Bonus
+SheetTypeNormal: Normal
+SheetTypePass: Bestehen
+SheetTypeNotGraded: Keine Wertung
+
+SheetTypeMaxPoints: Maximalpunktzahl
+SheetTypePassingPoints: Notwendig zum Bestehen
+
+SheetGroupArbitrary: Arbiträre Gruppen
+SheetGroupRegisteredGroups: Registrierte Gruppen
+SheetGroupNoGroups: Keine Gruppenabgabe
+SheetGroupMaxGroupsize: Maximale Gruppengröße

src/Data/Universe/Instances/Reverse/Hashable.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE NoImplicitPrelude
+           , ScopedTypeVariables
+  #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Universe.Instances.Reverse.Hashable
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Universe
+
+
+instance (Hashable a, Hashable b, Finite a) => Hashable (a -> b) where
+  hashWithSalt s f = s `hashWithSalt` [ (k, f k) | k <- universeF ]

src/Data/Universe/Instances/Reverse/JSON.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE NoImplicitPrelude
+           , ScopedTypeVariables
+  #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Universe.Instances.Reverse.JSON
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Aeson
+import Data.Aeson.Types (Parser)
+
+import qualified Data.HashSet as HashSet
+import qualified Data.HashMap.Strict as HashMap
+import Data.HashMap.Strict ((!))
+
+import Data.Universe
+
+
+instance (Eq a, Hashable a, Finite a, ToJSON b, ToJSONKey a) => ToJSON (a -> b) where
+  toJSON f = toJSON $ HashMap.fromList [(k, f k) | k <- universeF]
+
+instance (Eq a, Hashable a, Finite a, FromJSON b, FromJSONKey a) => FromJSON (a -> b) where
+  parseJSON val = do
+    vMap <- parseJSON val :: Parser (HashMap a b)
+    unless (HashSet.fromMap (HashMap.map (const ()) vMap) == HashSet.fromList universeF) $
+      fail "Not all required keys found"
+    return $ (vMap !)

src/Foundation.hs

@@ -1325,7 +1325,7 @@ instance YesodMail UniWorX where
   mailSmtp act = do
     pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
     withResource pool act
-  mailT ls mail = defMailT ls $ do 
+  mailT ctx mail = defMailT ctx $ do 
     setMailObjectId
     setDateCurrent
     replaceMailHeader "Auto-Submitted" $ Just "auto-generated"

src/Handler/Admin.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Handler.Admin where
 
@@ -44,11 +45,23 @@ instance Button UniWorX CreateButton where
   cssClass CreateInf  = BCPrimary
 -- END Button needed here
 
-emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailLanguages)
+emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext)
 emailTestForm = (,)
             <$> areq emailField (fslI MsgMailTestFormEmail) Nothing
-            <*> (MailLanguages <$> areq (reorderField appLanguages) (fslI MsgMailTestFormLanguages) Nothing)
+            <*> ( MailContext
+                  <$> (MailLanguages <$> areq (reorderField appLanguages) (fslI MsgMailTestFormLanguages) Nothing)
+                  <*> (toMailDateTimeFormat
+                        <$> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) Nothing
+                        <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing
+                        <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) Nothing
+                      )
+                )
             <*  submitButton
+  where
+    toMailDateTimeFormat dt d t = \case
+      SelFormatDateTime -> dt
+      SelFormatDate -> d
+      SelFormatTime -> t
 
 
 getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
@@ -71,6 +84,11 @@ postAdminTestR = do
       writeJobCtl $ JobCtlPerform jId
     FormMissing -> return ()
     (FormFailure errs) -> forM_ errs $ addMessage Error . toHtml
+
+  let emailWidget' = [whamlet|
+        <form method=post action=@{AdminTestR} enctype=#{emailEnctype}>
+          ^{emailWidget}
+      |]
   
   defaultLayout $ do
     -- setTitle "Uni2work Admin Testpage"

src/Handler/Corrections.hs

@@ -254,7 +254,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
   tableForm <- makeCorrectionsTable whereClause displayColumns psValidator
   ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
     ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
-    (actionRes, action) <- multiAction actions
+    (actionRes, action) <- multiAction actions Nothing
     return ((,) <$> actionRes <*> selectionRes, table <> action)
 
   Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler

src/Handler/Submission.hs

@@ -72,7 +72,7 @@ makeSubmissionForm msmid uploadMode grouping buddies = identForm FIDsubmission $
     flip (renderAForm FormStandard) html $ (,)
       <$> fileUpload
       <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
-                                    | g <- [1..(max groupNr $ length buddies)]             -- groupNr might have decreased meanwhile
+                                    | g <- [1..(max (fromIntegral groupNr) $ length buddies)] -- groupNr might have decreased meanwhile
                                     | buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
                                     ])
       <*  submitButton
@@ -215,7 +215,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
                   (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh
                   (Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email
                   _other             -> mempty
-              , case length participants `compare` maxParticipants of
+              , case fromIntegral (length participants) `compare` maxParticipants of
                   LT -> mempty
                   _  -> pure $ mr MsgTooManyParticipants
               ]

src/Handler/Utils/DateTime.hs

@@ -11,6 +11,7 @@ module Handler.Utils.DateTime
   , formatTime, formatTime', formatTimeW
   , getTimeLocale, getDateTimeFormat
   , validDateTimeFormats, dateTimeFormatOptions
+  , formatTimeMail
   , addOneWeek
   ) where
 
@@ -26,6 +27,8 @@ import qualified Data.Time.Format as Time
 import Data.Set (Set)
 import qualified Data.Set as Set
 
+import Mail
+
 utcToLocalTime :: UTCTime -> LocalTime
 utcToLocalTime = TZ.utcToLocalTimeTZ appTZ
 
@@ -58,6 +61,9 @@ formatTime proj t = flip formatTime' t =<< (unDateTimeFormat <$> getDateTimeForm
 formatTimeW :: (HasLocalTime t) => SelDateTimeFormat -> t -> Widget
 formatTimeW s t = toWidget =<< formatTime s t
 
+formatTimeMail :: (MonadMail m, HasLocalTime t) => SelDateTimeFormat -> t -> m Text
+formatTimeMail sel t = fmap fromString $ Time.formatTime <$> (getTimeLocale' . mailLanguages <$> askMailLanguages) <*> (unDateTimeFormat <$> askMailDateTimeFormat sel) <*> pure (toLocalTime t)
+
 getTimeLocale :: (MonadHandler m, HandlerSite m ~ UniWorX) => m TimeLocale
 getTimeLocale = getTimeLocale' <$> languages
 

src/Handler/Utils/Form.hs

@@ -59,6 +59,10 @@ import Data.Scientific (Scientific)
 import Data.Ratio
 import Text.Read (readMaybe)
 
+import Data.Maybe (fromJust)
+
+import Utils.Lens
+
 ----------------------------
 -- Buttons (new version ) --
 ----------------------------
@@ -310,23 +314,126 @@ multiFileField permittedFiles' = Field{..}
       Right _ -> return ()
       Left  r -> yield r
 
-sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
+data SheetType' = Bonus' | Normal' | Pass' | NotGraded'
-sheetTypeAFormReq d Nothing =
+  deriving (Eq, Ord, Read, Show, Enum, Bounded)
-  -- TODO, offer options to choose between Normal/Bonus/Pass
-  (Normal . toPoints) <$> areq (natField "Punkte") d Nothing
-sheetTypeAFormReq d (Just (Normal p)) =
-  -- TODO, offer options to choose between Normal/Bonus/Pass
-  (Normal . toPoints) <$> areq (natField "Punkte") d (Just $ fromPoints p)
-sheetTypeAFormReq d (Just (NotGraded)) = pure NotGraded
 
+instance Universe SheetType'
+instance Finite SheetType'
+
+$(return [])
+
+instance PathPiece SheetType' where
+  toPathPiece = $(nullaryToPathPiece ''SheetType' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"])
+  fromPathPiece = finiteFromPathPiece
+
+instance RenderMessage UniWorX SheetType' where
+  renderMessage f ls = \case
+    Bonus' -> render MsgSheetTypeBonus
+    Normal' -> render MsgSheetTypeNormal
+    Pass' -> render MsgSheetTypePass
+    NotGraded' -> render MsgSheetTypeNotGraded
+    where
+      render = renderMessage f ls
+
+data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups'
+  deriving (Eq, Ord, Read, Show, Enum, Bounded)
+
+instance Universe SheetGroup'
+instance Finite SheetGroup'
+
+$(return [])
+
+instance PathPiece SheetGroup' where
+  toPathPiece = $(nullaryToPathPiece ''SheetGroup' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"])
+  fromPathPiece = finiteFromPathPiece
+
+instance RenderMessage UniWorX SheetGroup' where
+  renderMessage f ls = \case
+    Arbitrary' -> render MsgSheetGroupArbitrary
+    RegisteredGroups' -> render MsgSheetGroupRegisteredGroups
+    NoGroups' -> render MsgSheetGroupNoGroups
+    where
+      render = renderMessage f ls
+
+sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
+sheetTypeAFormReq FieldSettings{..} template = formToAForm $ do
+  let
+    selOptions = Map.fromList
+      [ ( Bonus', renderAForm' $ Bonus <$> maxPointsReq )
+      , ( Normal', renderAForm' $ Normal <$> maxPointsReq )
+      , ( Pass', renderAForm' $ Pass
+          <$> maxPointsReq
+          <*> areq pointsField (fslpI MsgSheetTypePassingPoints "Punkte" & noValidate) (preview _passingPoints =<< template)
+        )
+      , ( NotGraded', return (FormSuccess NotGraded, Nothing) )
+      ]
+  (res, selView) <- multiAction selOptions (classify' <$> template)
+
+  fvId <- maybe newIdent return fsId
+  MsgRenderer mr <- getMsgRenderer
+
+  return (res,
+    [ FieldView
+      { fvLabel = toHtml $ mr fsLabel
+      , fvTooltip = toHtml . mr <$> fsTooltip
+      , fvId
+      , fvInput = selView
+      , fvErrors = case res of
+          FormFailure [e] -> Just $ toHtml e
+          _ -> Nothing
+      , fvRequired = True
+      }
+    ])
+
+  where
+    renderAForm' = fmap (over _2 Just) . ($ mempty) . renderAForm FormStandard
+
+    maxPointsReq = areq pointsField (fslpI MsgSheetTypeMaxPoints "Punkte" & noValidate) (preview _maxPoints =<< template)
+    
+    classify' :: SheetType -> SheetType'
+    classify' = \case
+      Bonus _ -> Bonus'
+      Normal _ -> Normal'
+      Pass _ _ -> Pass'
+      NotGraded -> NotGraded'
 
 sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
-sheetGroupAFormReq d (Just (Arbitrary n)) | n >= 1 =
+sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do
-  -- TODO, offer options to choose between Arbitrary/Registered/NoGroups
+  let
-  Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just n)
+    selOptions = Map.fromList
-sheetGroupAFormReq d _other = -- TODO
+      [ ( Arbitrary', renderAForm' $ Arbitrary
-  -- TODO, offer options to choose between Arbitrary/Registered/NoGroups
+          <$> areq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
-  Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just 1)
+        )
+      , ( RegisteredGroups', return (FormSuccess RegisteredGroups, Nothing) )
+      , ( NoGroups', return (FormSuccess NoGroups, Nothing) )
+      ]
+  (res, selView) <- multiAction selOptions (classify' <$> template)
+
+  fvId <- maybe newIdent return fsId
+  MsgRenderer mr <- getMsgRenderer
+
+  return (res,
+    [ FieldView
+      { fvLabel = toHtml $ mr fsLabel
+      , fvTooltip = toHtml . mr <$> fsTooltip
+      , fvId
+      , fvInput = selView
+      , fvErrors = case res of
+          FormFailure [e] -> Just $ toHtml e
+          _ -> Nothing
+      , fvRequired = True
+      }
+    ])
+
+  where
+    renderAForm' = fmap (over _2 Just) . ($ mempty) . renderAForm FormStandard
+    
+    classify' :: SheetGroup -> SheetGroup'
+    classify' = \case
+      Arbitrary _ -> Arbitrary'
+      RegisteredGroups -> RegisteredGroups'
+      NoGroups -> NoGroups'
+
 
 {-
 dayTimeField :: FieldSettings UniWorX -> Maybe UTCTime -> Form Handler UTCTime
@@ -440,12 +547,13 @@ aforced field settings val = formToAForm $ second pure <$> mforced field setting
 
 multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
             => Map action (MForm (HandlerT UniWorX IO) (FormResult a, Maybe Widget))
+            -> Maybe action
             -> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
-multiAction acts = do
+multiAction acts defAction = do
   mr <- getMessageRender
   let
     options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
-  (actionRes, actionView) <- mreq (selectField $ return options) "" Nothing
+  (actionRes, actionView) <- mreq (selectField $ return options) "" defAction
   results <- sequence acts
   let actionWidgets = Map.foldrWithKey (\act -> \case (_, Just w) -> ($(widgetFile "widgets/multiAction") :); (_, Nothing) -> id) [] results
       actionResults = Map.map fst results

src/Handler/Utils/Mail.hs

@@ -3,6 +3,7 @@
            , TypeFamilies
            , FlexibleContexts
            , ViewPatterns
+           , LambdaCase
   #-}
 
 module Handler.Utils.Mail
@@ -44,9 +45,24 @@ userMailT :: ( MonadHandler m
              , MonadLogger m
              ) => UserId -> MailT m a -> m a
 userMailT uid mAct = do
-  User{userEmail, userDisplayName, userMailLanguages} <- liftHandlerT . runDB $ getJust uid
+  User
-  let addr = Address (Just userDisplayName) $ CI.original userEmail
+    { userEmail
-  mailT userMailLanguages $ do
+    , userDisplayName
+    , userMailLanguages
+    , userDateTimeFormat
+    , userDateFormat
+    , userTimeFormat
+    } <- liftHandlerT . runDB $ getJust uid
+  let
+    addr = Address (Just userDisplayName) $ CI.original userEmail
+    ctx = MailContext
+      { mcLanguages = userMailLanguages
+      , mcDateTimeFormat = \case
+          SelFormatDateTime -> userDateTimeFormat
+          SelFormatDate -> userDateFormat
+          SelFormatTime -> userTimeFormat
+      }
+  mailT ctx $ do
     _mailTo .= pure addr
     mAct
 

src/Jobs.hs

@@ -20,6 +20,7 @@ module Jobs
 
 import Import hiding ((.=))
 import Handler.Utils.Mail
+import Handler.Utils.DateTime
 
 import Jobs.Types
 
@@ -43,6 +44,7 @@ import qualified Database.Esqueleto as E
 
 import qualified Data.CaseInsensitive as CI
 
+import Text.Shakespeare.Text
 import Text.Hamlet
 
   
@@ -161,24 +163,32 @@ performJob JobQueueNotification{ jNotification = n@NotificationSubmissionRated{.
     forM recipients $ queueJobUnsafe . flip JobSendNotification n
   forM_ jIds $ writeJobCtl . JobCtlPerform
 performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, jRecipient } = userMailT jRecipient $ do
-  (Course{..}, Sheet{..}, Submission{..}) <- liftHandlerT . runDB $ do
+  (Course{..}, Sheet{..}, Submission{..}, corrector) <- liftHandlerT . runDB $ do
-    submission <- getJust nSubmission
+    submission@Submission{submissionRatingBy} <- getJust nSubmission
     sheet <- belongsToJust submissionSheet submission
     course <- belongsToJust sheetCourse sheet
-    return (course, sheet, submission)
+    corrector <- traverse getJust submissionRatingBy
-  csId <- encrypt nSubmission
+    return (course, sheet, submission, corrector)
   setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand
 
+  csid <- encrypt nSubmission
   MsgRenderer mr <- getMailMsgRenderer
   let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
+  submissionRatingTime' <- traverse (formatTimeMail SelFormatDateTime) submissionRatingTime
+  let tid = courseTerm
+      ssh = courseSchool
+      csh = courseShorthand
+      shn = sheetName
 
   -- TODO: provide convienience template-haskell for `addAlternatives`
   addAlternatives $ do
     provideAlternative $ Aeson.object
-      [ "submission" Aeson..= (ciphertext csId :: UUID)
+      [ "submission" Aeson..= ciphertext csid
       , "submission-rating-points" Aeson..= submissionRatingPoints
       , "submission-rating-comment" Aeson..= submissionRatingComment
       , "submission-rating-time" Aeson..= submissionRatingTime
+      , "submission-rating-by" Aeson..= (userDisplayName <$> corrector)
+      , "submission-rating-passed" Aeson..= ((>=) <$> submissionRatingPoints <*> preview _passingPoints sheetType)
       , "sheet-name" Aeson..= sheetName
       , "sheet-type" Aeson..= sheetType
       , "course-name" Aeson..= courseName
@@ -186,9 +196,20 @@ performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..},
       , "course-term" Aeson..= courseTerm
       , "course-school" Aeson..= courseSchool
       ]
-    provideAlternative $ \(MsgRenderer mr) -> ($(textFile "templates/mail/submissionRated.txt") :: TextUrl (Route UniWorX))
+    -- provideAlternative $ \(MsgRenderer mr) -> ($(textFile "templates/mail/submissionRated.txt") :: TextUrl (Route UniWorX)) -- textFile does not support control statements
     providePreferredAlternative $ \(MsgRenderer mr) -> ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
-performJob JobSendTestEmail{..} = mailT jLanguages $ do
+performJob JobSendTestEmail{..} = mailT jMailContext $ do
   _mailTo .= [Address Nothing jEmail]
   setSubjectI MsgMailTestSubject
-  addPart $ \(MsgRenderer mr) -> mr MsgMailTestContent
+  now <- liftIO getCurrentTime
+  nDT <- formatTimeMail SelFormatDateTime now
+  nD <- formatTimeMail SelFormatDate now
+  nT <- formatTimeMail SelFormatTime now
+  addPart $ \(MsgRenderer mr) -> ([text|
+    #{mr MsgMailTestContent}
+
+    #{mr MsgMailTestDateTime}
+      * #{nDT}
+      * #{nD}
+      * #{nT}
+    |] :: TextUrl (Route UniWorX))

src/Jobs/Types.hs

@@ -16,7 +16,7 @@ import Data.Aeson.TH (deriveJSON)
 
 
 data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
-         | JobSendTestEmail { jEmail :: Text, jLanguages :: MailLanguages }
+         | JobSendTestEmail { jEmail :: Text, jMailContext :: MailContext }
          | JobQueueNotification { jNotification :: Notification }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }

src/Mail.hs

@@ -16,6 +16,7 @@
            , QuasiQuotes
            , RankNTypes
            , ScopedTypeVariables
+           , DeriveDataTypeable
   #-}
 
 module Mail
@@ -23,7 +24,7 @@ module Mail
     module Network.Mail.Mime
     -- * MailT
   , MailT, defMailT
-  , MailSmtpData(..), MailLanguages(..)
+  , MailSmtpData(..), MailContext(..), MailLanguages(..)
   , MonadMail(..)
   , getMailMessageRender, getMailMsgRenderer
     -- * YesodMail
@@ -66,6 +67,8 @@ import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 import Data.Sequence (Seq)
 import qualified Data.Sequence as Seq
 
+import Data.Data (Data)
+
 import Data.Set (Set)
 import qualified Data.Set as Set
 
@@ -112,16 +115,20 @@ import Data.Aeson (Options(..))
 import Data.Aeson.TH
 import Utils (MsgRendererS(..))
 import Utils.PathPiece (splitCamel)
+import Utils.DateTime
 
+import Data.Universe.Instances.Reverse ()
+import Data.Universe.Instances.Reverse.JSON ()
+import Data.Universe.Instances.Reverse.Hashable ()
 
 makeLenses_ ''Mail
 makeLenses_ ''Part
 
 
-newtype MailT m a = MailT { unMailT :: RWST MailLanguages MailSmtpData Mail m a }
+newtype MailT m a = MailT { unMailT :: RWST MailContext MailSmtpData Mail m a }
   deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus
                    , MonadIO, MonadHandler, MonadCatch, MonadThrow, MonadMask, MonadResource, MonadBase b
-                   , MonadState Mail, MonadWriter MailSmtpData, MonadReader MailLanguages
+                   , MonadState Mail, MonadWriter MailSmtpData, MonadReader MailContext
                    )
 
 instance {-# OVERLAPPING #-} (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => MonadCrypto (MailT m) where
@@ -146,12 +153,27 @@ instance Default MailLanguages where
 
 instance Hashable MailLanguages
 
+data MailContext = MailContext
+  { mcLanguages :: MailLanguages
+  , mcDateTimeFormat :: SelDateTimeFormat -> DateTimeFormat
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  } ''MailContext
+
+instance Hashable MailContext
+
+makeLenses_ ''MailContext
+
 class (MonadHandler m, MonadState Mail m) => MonadMail m where
   askMailLanguages :: m MailLanguages
+  askMailDateTimeFormat :: SelDateTimeFormat -> m DateTimeFormat
   tellMailSmtpData :: MailSmtpData -> m ()
 
 instance MonadHandler m => MonadMail (MailT m) where
-  askMailLanguages = ask
+  askMailLanguages = view _mcLanguages
+  askMailDateTimeFormat = (view _mcDateTimeFormat ??)
   tellMailSmtpData = tell
 
 data VerpMode = VerpNone
@@ -212,7 +234,7 @@ class Yesod site => YesodMail site where
            , HandlerSite m ~ site
            , MonadBaseControl IO m
            , MonadLogger m
-           ) => MailLanguages -> MailT m a -> m a
+           ) => MailContext -> MailT m a -> m a
   mailT = defMailT
 
   defaultMailLayout :: ( MonadHandler m
@@ -238,7 +260,7 @@ defMailT :: ( MonadHandler m
             , YesodMail (HandlerSite m)
             , MonadBaseControl IO m
             , MonadLogger m
-            ) => MailLanguages -- ^ Languages in priority order
+            ) => MailContext
               -> MailT m a
               -> m a
 defMailT ls (MailT mail) = do

src/Model/Types.hs

@@ -13,12 +13,15 @@
 
 module Model.Types
   ( module Model.Types
+  , module Numeric.Natural
   , module Mail
+  , module Utils.DateTime
   ) where
 
 import ClassyPrelude
 import Utils
 import Control.Lens
+import Utils.Lens.TH
 
 import Data.Set (Set)
 import qualified Data.Set as Set
@@ -68,6 +71,9 @@ import Data.Universe.Instances.Reverse ()
 import qualified Yesod.Auth.Util.PasswordStore as PWStore
 
 import Mail (MailLanguages(..))
+import Utils.DateTime (DateTimeFormat(..), SelDateTimeFormat(..))
+
+import Numeric.Natural
 
 
 instance PathPiece UUID where
@@ -123,6 +129,8 @@ instance DisplayAble SheetType where
 deriveJSON defaultOptions ''SheetType
 derivePersistFieldJSON ''SheetType
 
+makeLenses_ ''SheetType
+
 data SheetTypeSummary = SheetTypeSummary
   { sumBonusPoints  :: Sum Points
   , sumNormalPoints :: Sum Points
@@ -145,13 +153,15 @@ sheetTypeSum (NotGraded,  _       ) = mempty { numNotGraded = Sum 1 }
 
 
 data SheetGroup
-  = Arbitrary { maxParticipants :: Int }
+  = Arbitrary { maxParticipants :: Natural }
   | RegisteredGroups
   | NoGroups
   deriving (Show, Read, Eq)
 deriveJSON defaultOptions ''SheetGroup
 derivePersistFieldJSON ''SheetGroup
 
+makeLenses_ ''SheetGroup
+
 data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 derivePersistField "SheetFileType"
@@ -416,12 +426,6 @@ instance PathPiece obj => PathPiece (ZIPArchiveName obj) where
     fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip"
     toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName
 
-newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
-  deriving (Eq, Ord, Read, Show, ToJSON, FromJSON, PersistField, PersistFieldSql, IsString)
-
-data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
-  deriving (Eq, Ord, Read, Show, Enum, Bounded)
-
 
 data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
   deriving (Eq, Ord, Read, Show, Enum, Bounded)

src/Utils/DateTime.hs

@@ -2,7 +2,12 @@
            , TemplateHaskell
            , QuasiQuotes
            , StandaloneDeriving
+           , DerivingStrategies
            , DeriveLift
+           , DeriveDataTypeable
+           , DeriveGeneric
+           , GeneralizedNewtypeDeriving
+           , OverloadedStrings
   #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -10,6 +15,8 @@ module Utils.DateTime
   ( timeLocaleMap
   , TimeLocale(..)
   , currentYear
+  , DateTimeFormat(..)
+  , SelDateTimeFormat(..)
   , module Data.Time.Zones
   , module Data.Time.Zones.TH
   ) where
@@ -25,6 +32,18 @@ import Language.Haskell.TH
 import Language.Haskell.TH.Syntax (Lift(..))
 import Instances.TH.Lift ()
 
+import Data.Data (Data)
+import Data.Typeable (Typeable)
+import Data.Universe
+
+import Database.Persist.Sql (PersistField, PersistFieldSql)
+
+import Data.Aeson.Types (toJSONKeyText)
+import Data.Aeson
+import Data.Aeson.TH
+
+import Utils.PathPiece
+
 deriving instance Lift TimeZone
 deriving instance Lift TimeLocale
 
@@ -63,3 +82,26 @@ currentYear = do
   now <- runIO getCurrentTime
   let (year, _, _) = toGregorian $ utctDay now
   [e|year|]
+
+
+newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
+  deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
+  deriving newtype (ToJSON, FromJSON, PersistField, PersistFieldSql, IsString)
+
+instance Hashable DateTimeFormat
+
+data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Data, Generic, Typeable)
+
+instance Universe SelDateTimeFormat
+instance Finite SelDateTimeFormat
+instance Hashable SelDateTimeFormat
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel
+  } ''SelDateTimeFormat
+
+instance ToJSONKey SelDateTimeFormat where
+  toJSONKey = toJSONKeyText $ \v -> let String txt = toJSON v in txt
+instance FromJSONKey SelDateTimeFormat where
+  fromJSONKey = FromJSONKeyTextParser $ parseJSON . String

src/Utils/Form.hs

@@ -143,6 +143,9 @@ addDatalist field mValues = field
       |]
   }
 
+noValidate :: FieldSettings site -> FieldSettings site
+noValidate = addAttr "formnovalidate" ""
+
 ------------------------------------------------
 -- Unique Form Identifiers to avoid accidents --
 ------------------------------------------------
@@ -239,7 +242,7 @@ reorderField optList = Field{..}
       OptionList{..} <- liftHandlerT optList
       let
         olNum = fromIntegral $ length olOptions
-        selOptions = traceShowId . Map.fromList $ do
+        selOptions = Map.fromList $ do
           i <- [1..olNum]
           (readMay -> Just (n :: Word), ('.' : extVal)) <- break (== '.') . unpack <$> optlist
           guard $ i == n

templates/adminTest.hamlet

@@ -35,5 +35,4 @@
       ^{modal "Klick mich für Ajax-Test" (Left UsersR)}
       ^{modal "Klick mich für Content-Test" (Right "Test Inhalt für Modal")}
     <li>
-      <form method=post action=@{AdminTestR} enctype=#{emailEnctype}>
+      ^{modal "Email-Test" (Right emailWidget')}
-        ^{emailWidget}

templates/correction-user.cassius

@@ -0,0 +1,3 @@
+.comment
+  white-space: pre-wrap
+  font-family: monospace

templates/correction-user.hamlet

@@ -36,4 +36,4 @@
     $maybe comment <- ratingComment
       <tr .table__row>
         <th .table__th>_{MsgRatingComment}
-        <td .table__td style="white-space: pre;">#{comment}
+        <td .table__td .comment>#{comment}

templates/mail/submissionRated.hamlet

@@ -1,4 +1,62 @@
 <html>
+  <head>
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+
+      .comment {
+        white-space: pre-wrap;
+        font-family: monospace;
+      }
   <body>
     <h1>
       _{MsgMailSubmissionRatedIntro (CI.original courseName) termDesc}
+    <dl>
+      <dt>
+        _{MsgSubmission}
+      <dd>
+        <a href=@{CSubmissionR tid ssh csh shn csid SubShowR}>
+          #{display csid}
+      $maybe User{..} <- corrector
+        <dt>
+          _{MsgRatingBy}
+        <dd>
+          #{display userDisplayName}
+      $maybe time <- submissionRatingTime'
+        <dt>
+          _{MsgRatingTime}
+        <dd>
+          #{time}
+      $maybe points <- submissionRatingPoints
+        $case sheetType
+          $of Bonus{..}
+            <dt>
+              _{MsgAchievedBonusPoints}
+            <dd>
+              _{MsgAchievedOf points maxPoints}
+          $of Normal{..}
+            <dt>
+              _{MsgAchievedNormalPoints}
+            <dd>
+              _{MsgAchievedOf points maxPoints}
+          $of Pass{..}
+            <dt>
+              _{MsgPassedResult}
+            <dd>
+              $if points >= passingPoints
+                _{MsgPassed}
+              $else
+                _{MsgNotPassed}
+            <dt>
+              _{MsgAchievedPassPoints}
+            <dd>
+              _{MsgPassAchievedOf points passingPoints maxPoints}
+          $of NotGraded
+      $maybe comment <- submissionRatingComment
+        <dt>
+          _{MsgRatingComment}
+        <dd .comment>
+          #{comment}

templates/widgets/form.julius

@@ -36,7 +36,6 @@
   };
 
   window.utils.interactiveFieldset = function(form, fieldSets) {
-
     var fields = fieldSets.map(function(fs) {
       return {
         fieldSet: fs,

templates/widgets/form.lucius

@@ -1,10 +1,3 @@
-.hidden {
-  visibility: hidden;
-  height: 0;
-  opacity: 0;
-}
-
-
 fieldset {
   border: 0;
   margin: 20px 0 30px;
@@ -13,3 +6,14 @@ fieldset {
     display: none;
   }
 }
+
+.form-group__input > fieldset {
+  margin-bottom: 0;
+}
+
+.hidden {
+  visibility: hidden;
+  height: 0;
+  opacity: 0;
+  margin: 0;
+}