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

Time formatting in emails

Browse Source
This commit is contained in:
Gregor Kleen 2018-10-12 19:40:52 +02:00
parent f98939885b
commit d743fd6536
23 changed files with 428 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
db.hs
View File

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

16
messages/uniworx/de.msg
View File

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

16
src/Data/Universe/Instances/Reverse/Hashable.hs Normal file
View File

@ -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 ]

30
src/Data/Universe/Instances/Reverse/JSON.hs Normal file
View File

@ -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 !)

2
src/Foundation.hs
View File

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

22
src/Handler/Admin.hs
View File

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

2
src/Handler/Corrections.hs
View File

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

4
src/Handler/Submission.hs
View File

@ -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
]

6
src/Handler/Utils/DateTime.hs
View File

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

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

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

22
src/Handler/Utils/Mail.hs
View File

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

37
src/Jobs.hs
View File

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

2
src/Jobs/Types.hs
View File

@ -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 }

34
src/Mail.hs
View File

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

18
src/Model/Types.hs
View File

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

42
src/Utils/DateTime.hs
View File

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

5
src/Utils/Form.hs
View File

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

3
templates/adminTest.hamlet
View File

@ -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}>
^{emailWidget}
^{modal "Email-Test" (Right emailWidget')}

3
templates/correction-user.cassius Normal file
View File

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

2
templates/correction-user.hamlet
View File

@ -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}

58
templates/mail/submissionRated.hamlet
View File

@ -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}

1
templates/widgets/form.julius
View File

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

18
templates/widgets/form.lucius
View File

@ -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;
}