diff --git a/db.hs b/db.hs index 3aa4fded0..adf008619 100755 --- a/db.hs +++ b/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 diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 5cb71f00b..b2527d71f 100644 --- a/messages/uniworx/de.msg +++ b/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. \ No newline at end of file +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 \ No newline at end of file diff --git a/src/Data/Universe/Instances/Reverse/Hashable.hs b/src/Data/Universe/Instances/Reverse/Hashable.hs new file mode 100644 index 000000000..e7459f613 --- /dev/null +++ b/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 ] diff --git a/src/Data/Universe/Instances/Reverse/JSON.hs b/src/Data/Universe/Instances/Reverse/JSON.hs new file mode 100644 index 000000000..60b7ba6ae --- /dev/null +++ b/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 !) diff --git a/src/Foundation.hs b/src/Foundation.hs index fe678c169..e5bf9302b 100644 --- a/src/Foundation.hs +++ b/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" diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index bb21c60d0..6de79e526 100644 --- a/src/Handler/Admin.hs +++ b/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| +
+ ^{emailWidget} + |] defaultLayout $ do -- setTitle "Uni2work Admin Testpage" diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 5cbe19078..4a0c819b1 100644 --- a/src/Handler/Corrections.hs +++ b/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 diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 30c56d2c3..83064f530 100644 --- a/src/Handler/Submission.hs +++ b/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 ] diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 679539202..67acd6a32 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 6236c1194..0bede325e 100644 --- a/src/Handler/Utils/Form.hs +++ b/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 -sheetTypeAFormReq d Nothing = - -- 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 +data SheetType' = Bonus' | Normal' | Pass' | NotGraded' + deriving (Eq, Ord, Read, Show, Enum, Bounded) +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 = - -- TODO, offer options to choose between Arbitrary/Registered/NoGroups - Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just n) -sheetGroupAFormReq d _other = -- TODO - -- TODO, offer options to choose between Arbitrary/Registered/NoGroups - Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just 1) +sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do + let + selOptions = Map.fromList + [ ( Arbitrary', renderAForm' $ Arbitrary + <$> areq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template) + ) + , ( 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 diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 9196e8816..96ef448e0 100644 --- a/src/Handler/Utils/Mail.hs +++ b/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 - let addr = Address (Just userDisplayName) $ CI.original userEmail - mailT userMailLanguages $ do + User + { userEmail + , 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 diff --git a/src/Jobs.hs b/src/Jobs.hs index 52f596fae..e3cd8f31b 100644 --- a/src/Jobs.hs +++ b/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 - submission <- getJust nSubmission + (Course{..}, Sheet{..}, Submission{..}, corrector) <- liftHandlerT . runDB $ do + submission@Submission{submissionRatingBy} <- getJust nSubmission sheet <- belongsToJust submissionSheet submission course <- belongsToJust sheetCourse sheet - return (course, sheet, submission) - csId <- encrypt nSubmission + corrector <- traverse getJust submissionRatingBy + 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)) diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index db052c52d..099a3d67d 100644 --- a/src/Jobs/Types.hs +++ b/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 } diff --git a/src/Mail.hs b/src/Mail.hs index d1c0e4e01..38d8ff5bb 100644 --- a/src/Mail.hs +++ b/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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index ecc10e1e4..48c60a44c 100644 --- a/src/Model/Types.hs +++ b/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) diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index 1b82dbe12..90a4059f6 100644 --- a/src/Utils/DateTime.hs +++ b/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 diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index ed359d3cf..0ccc1da6f 100644 --- a/src/Utils/Form.hs +++ b/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 diff --git a/templates/adminTest.hamlet b/templates/adminTest.hamlet index b4e6b18f4..0693ea1cc 100644 --- a/templates/adminTest.hamlet +++ b/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")}
  • - - ^{emailWidget} + ^{modal "Email-Test" (Right emailWidget')} diff --git a/templates/correction-user.cassius b/templates/correction-user.cassius new file mode 100644 index 000000000..2b7b13b7a --- /dev/null +++ b/templates/correction-user.cassius @@ -0,0 +1,3 @@ +.comment + white-space: pre-wrap + font-family: monospace \ No newline at end of file diff --git a/templates/correction-user.hamlet b/templates/correction-user.hamlet index d0b8976e2..a3036193f 100644 --- a/templates/correction-user.hamlet +++ b/templates/correction-user.hamlet @@ -36,4 +36,4 @@ $maybe comment <- ratingComment _{MsgRatingComment} - #{comment} + #{comment} diff --git a/templates/mail/submissionRated.hamlet b/templates/mail/submissionRated.hamlet index a77616eaa..2695705c8 100644 --- a/templates/mail/submissionRated.hamlet +++ b/templates/mail/submissionRated.hamlet @@ -1,4 +1,62 @@ + +