From a731346656810cf480a2b3bc89c6a0780426740b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 3 Apr 2019 14:47:33 +0200 Subject: [PATCH 01/14] pgadmin in nix environment --- shell.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/shell.nix b/shell.nix index e6178f7b0..69546ffbe 100644 --- a/shell.nix +++ b/shell.nix @@ -19,7 +19,7 @@ let ''; override = oldAttrs: { - nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]); + nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql pgadmin ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]); shellHook = '' export PROMPT_INFO="${oldAttrs.name}" From 37e4adc0db0b725b49480236c30f44149f272227 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 3 Apr 2019 16:02:44 +0200 Subject: [PATCH 02/14] Modularize & clean up homepage Fixes #306 --- messages/uniworx/de.msg | 3 + src/Application.hs | 2 + src/Data/List/NonEmpty/Instances.hs | 12 ++ src/Handler/Help.hs | 67 ++++++++++ src/Handler/Home.hs | 184 ++------------------------- src/Handler/Info.hs | 48 +++++++ src/Handler/Profile.hs | 43 ++++++- src/Handler/Utils.hs | 24 +++- src/Import/NoFoundation.hs | 3 +- templates/home.hamlet | 5 - templates/home/openCourses.hamlet | 3 + templates/home/upcomingSheets.hamlet | 3 + templates/homeUser.hamlet | 17 --- 13 files changed, 216 insertions(+), 198 deletions(-) create mode 100644 src/Data/List/NonEmpty/Instances.hs create mode 100644 src/Handler/Help.hs create mode 100644 src/Handler/Info.hs delete mode 100644 templates/home.hamlet create mode 100644 templates/home/openCourses.hamlet create mode 100644 templates/home/upcomingSheets.hamlet delete mode 100644 templates/homeUser.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 7d51240f3..da8e563fa 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -273,6 +273,9 @@ DataProtHeading: Datenschutzerklärung SystemMessageHeading: Uni2work Statusmeldung SystemMessageListHeading: Uni2work Statusmeldungen +HomeOpenCourses: Kurse mit offener Registrierung +HomeUpcomingSheets: Anstehende Übungsblätter + NumCourses num@Int64: #{display num} Kurse CloseAlert: Schliessen diff --git a/src/Application.hs b/src/Application.hs index 1dd037aba..20824d216 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -76,6 +76,8 @@ import qualified Database.Memcached.Binary.IO as Memcached -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.Common import Handler.Home +import Handler.Info +import Handler.Help import Handler.Profile import Handler.Users import Handler.Admin diff --git a/src/Data/List/NonEmpty/Instances.hs b/src/Data/List/NonEmpty/Instances.hs new file mode 100644 index 000000000..f151b6c18 --- /dev/null +++ b/src/Data/List/NonEmpty/Instances.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.List.NonEmpty.Instances + ( + ) where + +import Data.List.NonEmpty + +import Language.Haskell.TH.Syntax (Lift(..)) + +instance Lift a => Lift (NonEmpty a) where + lift (toList -> xs) = [e|fromList xs|] diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs new file mode 100644 index 000000000..39c1f5381 --- /dev/null +++ b/src/Handler/Help.hs @@ -0,0 +1,67 @@ +module Handler.Help where + +import Import +import Handler.Utils +import Jobs + +import qualified Data.Map as Map + +data HelpIdentOptions = HIUser | HIEmail | HIAnonymous + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +instance Universe HelpIdentOptions +instance Finite HelpIdentOptions + +nullaryPathPiece ''HelpIdentOptions (camelToPathPiece' 1) +embedRenderMessage ''UniWorX ''HelpIdentOptions (("Help" <>) . dropPrefix "HI") + +data HelpForm = HelpForm + { hfReferer:: Maybe (Route UniWorX) + , hfUserId :: Either (Maybe Address) UserId + , hfRequest:: Text + } + +helpForm :: Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm +helpForm mReferer mUid = HelpForm + <$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer) + <*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid) + <*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing) + where + identActions :: Map _ (AForm _ (Either (Maybe Address) UserId)) + identActions = Map.fromList $ case mUid of + (Just uid) -> (HIUser, pure $ Right uid):defaultActions + Nothing -> defaultActions + + defaultActions = + [ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslI MsgName) Nothing <*> apreq emailField (fslI MsgEMail) Nothing)) + , (HIAnonymous, pure $ Left Nothing) + ] + +getHelpR, postHelpR :: Handler Html +getHelpR = postHelpR +postHelpR = do + mUid <- maybeAuthId + mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField (toPathPiece GetReferer) + isModal <- hasCustomHeader HeaderIsModal + + ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid + let form = wrapForm formWidget def + { formAction = Just $ SomeRoute HelpR + , formEncoding = formEnctype + , formAttrs = [ ("data-ajax-submit", "") | isModal ] + } + + formResultModal res HelpR $ \HelpForm{..} -> do + now <- liftIO getCurrentTime + hfReferer' <- traverse toTextUrl hfReferer + queueJob' JobHelpRequest + { jSender = hfUserId + , jHelpRequest = hfRequest + , jRequestTime = now + , jReferer = hfReferer' + } + tell . pure =<< messageI Success MsgHelpSent + + defaultLayout $ do + setTitleI MsgHelpTitle + $(widgetFile "help") diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 7b60a6da3..dba365b9c 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -4,23 +4,20 @@ import Import import Handler.Utils import qualified Data.Map as Map -import qualified Data.Set as Set import qualified Database.Esqueleto as E -import Jobs -import Development.GitRev - getHomeR :: Handler Html getHomeR = do muid <- maybeAuthId - case muid of - Nothing -> homeAnonymous - Just uid -> homeUser uid + defaultLayout $ do + setTitleI MsgHomeHeading + maybe mempty homeUpcomingSheets muid + homeOpenCourses -homeAnonymous :: Handler Html -homeAnonymous = do +homeOpenCourses :: Widget +homeOpenCourses = do cTime <- liftIO getCurrentTime let tableData :: E.SqlExpr (Entity Course) -> E.SqlQuery (E.SqlExpr (Entity Course)) @@ -47,7 +44,7 @@ homeAnonymous = do , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget ] - courseTable <- runDB $ dbTableWidget' def DBTable + courseTable <- liftHandlerT . runDB $ dbTableWidget' def DBTable { dbtSQLQuery = tableData , dbtRowKey = (E.^. CourseId) , dbtColonnade = colonnade @@ -75,16 +72,12 @@ homeAnonymous = do , dbtFilterUI = mempty , dbtStyle = def , dbtParams = def - , dbtIdent = "upcomingdeadlines" :: Text + , dbtIdent = "open-courses" :: Text } - -- let features = $(widgetFile "featureList") - -- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!" - defaultLayout - -- (widgetFile "dsgvDisclaimer") - $(widgetFile "home") + $(widgetFile "home/openCourses") -homeUser :: Key User -> Handler Html -homeUser uid = do +homeUpcomingSheets :: UserId -> Widget +homeUpcomingSheets uid = do cTime <- liftIO getCurrentTime let tableData :: E.LeftOuterJoin (E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet))) @@ -140,7 +133,7 @@ homeUser uid = do (toWidget $ hasTickmark True) ] let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"] - sheetTable <- runDB $ dbTableWidget' validator DBTable + sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable { dbtSQLQuery = tableData , dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId , dbtColonnade = colonnade @@ -175,155 +168,6 @@ homeUser uid = do , dbtFilterUI = mempty , dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines } , dbtParams = def - , dbtIdent = "upcomingdeadlines" :: Text + , dbtIdent = "upcoming-sheets" :: Text } - -- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen." - defaultLayout $ - -- setTitle "Willkommen zum Uni2work Test!" - $(widgetFile "homeUser") - -- (widgetFile "dsgvDisclaimer") - --- | Versionsgeschichte -getVersionR :: Handler TypedContent -getVersionR = getInfoR -- TODO - --- | Impressum -getImpressumR :: Handler Html -getImpressumR = -- do - siteLayoutMsg' MsgMenuImpressum $ do - setTitleI MsgImpressumHeading - $(i18nWidgetFile "imprint") - - --- | Hinweise zu Datenschutz und Aufbewahrungspflichten -getDataProtR :: Handler Html -getDataProtR = -- do - siteLayoutMsg' MsgMenuDataProt $ do - setTitleI MsgDataProtHeading - $(i18nWidgetFile "data-protection") - - --- | Allgemeine Informationen -getInfoR :: Handler TypedContent -getInfoR = selectRep $ do - let infoHeading = [whamlet|Re-Implementierung von UniWorX|] - provideRep . siteLayout infoHeading $ do - let features = $(widgetFile "featureList") - gitInfo :: Text - gitInfo = $gitDescribe <> " (" <> $gitCommitDate <> ")" - changeLog <- withUrlRenderer $(textFile "ChangeLog.md") - $(widgetFile "versionHistory") - provideRep $ - return ($gitDescribe :: Text) - - - - -data HelpIdentOptions = HIUser | HIEmail | HIAnonymous - deriving (Eq, Ord, Bounded, Enum, Show, Read) - -instance Universe HelpIdentOptions -instance Finite HelpIdentOptions - -nullaryPathPiece ''HelpIdentOptions (camelToPathPiece' 1) -embedRenderMessage ''UniWorX ''HelpIdentOptions (("Help" <>) . dropPrefix "HI") - -data HelpForm = HelpForm - { hfReferer:: Maybe (Route UniWorX) - , hfUserId :: Either (Maybe Address) UserId - , hfRequest:: Text - } - -helpForm :: Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm -helpForm mReferer mUid = HelpForm - <$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer) - <*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid) - <*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing) - where - identActions :: Map _ (AForm _ (Either (Maybe Address) UserId)) - identActions = Map.fromList $ case mUid of - (Just uid) -> (HIUser, pure $ Right uid):defaultActions - Nothing -> defaultActions - - defaultActions = - [ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslI MsgName) Nothing <*> apreq emailField (fslI MsgEMail) Nothing)) - , (HIAnonymous, pure $ Left Nothing) - ] - -getHelpR, postHelpR :: Handler Html -getHelpR = postHelpR -postHelpR = do - mUid <- maybeAuthId - mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField (toPathPiece GetReferer) - isModal <- hasCustomHeader HeaderIsModal - - ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid - let form = wrapForm formWidget def - { formAction = Just $ SomeRoute HelpR - , formEncoding = formEnctype - , formAttrs = [ ("data-ajax-submit", "") | isModal ] - } - - formResultModal res HelpR $ \HelpForm{..} -> do - now <- liftIO getCurrentTime - hfReferer' <- traverse toTextUrl hfReferer - queueJob' JobHelpRequest - { jSender = hfUserId - , jHelpRequest = hfRequest - , jRequestTime = now - , jReferer = hfReferer' - } - tell . pure =<< messageI Success MsgHelpSent - - defaultLayout $ do - setTitleI MsgHelpTitle - $(widgetFile "help") - - -getInfoLecturerR :: Handler Html -getInfoLecturerR = - siteLayoutMsg' MsgInfoLecturerTitle $ do - setTitleI MsgInfoLecturerTitle - $(i18nWidgetFile "info-lecturer") - - -getAuthPredsR, postAuthPredsR :: Handler Html -getAuthPredsR = postAuthPredsR -postAuthPredsR = do - (AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags - - let - blacklist = Set.fromList [ AuthFree, AuthDevelopment, AuthDeprecated ] - taForm authTag - | authTag `Set.member` blacklist = aforced checkBoxField (fslI authTag) (authTagIsActive def authTag) - | otherwise = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag) - - ((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard - $ AuthTagActive <$> funcForm taForm (fslI MsgActiveAuthTags) True - - mReferer <- runMaybeT $ do - param <- MaybeT (lookupGetParam $ toPathPiece GetReferer) <|> MaybeT (lookupPostParam $ toPathPiece GetReferer) - MaybeT . return $ fromPathPiece param - - let authActiveForm = wrapForm authActiveWidget' def - { formAction = Just $ SomeRoute AuthPredsR - , formEncoding = authActiveEnctype - , formSubmit = FormDualSubmit - } - authActiveWidget' - = [whamlet| - $newline never - $maybe referer <- mReferer - - ^{authActiveWidget} - |] - - formResult authActiveRes $ \authTagActive -> do - setSessionJson SessionActiveAuthTags authTagActive - modifySessionJson SessionInactiveAuthTags . fmap $ Set.filter (not . authTagIsActive authTagActive) - addMessageI Success MsgAuthPredsActiveChanged - redirect $ fromMaybe AuthPredsR mReferer - - siteLayoutMsg MsgAuthPredsActive $ do - setTitleI MsgAuthPredsActive - $(widgetFile "authpreds") + $(widgetFile "home/upcomingSheets") diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs new file mode 100644 index 000000000..9790ed143 --- /dev/null +++ b/src/Handler/Info.hs @@ -0,0 +1,48 @@ +module Handler.Info where + +import Import +import Handler.Utils + +import Development.GitRev + +-- | Versionsgeschichte +getVersionR :: Handler TypedContent +getVersionR = selectRep $ do + provideRep $ + return ($gitDescribe :: Text) + provideRep getInfoR + +-- | Impressum +getImpressumR :: Handler Html +getImpressumR = -- do + siteLayoutMsg' MsgMenuImpressum $ do + setTitleI MsgImpressumHeading + $(i18nWidgetFile "imprint") + + +-- | Hinweise zu Datenschutz und Aufbewahrungspflichten +getDataProtR :: Handler Html +getDataProtR = -- do + siteLayoutMsg' MsgMenuDataProt $ do + setTitleI MsgDataProtHeading + $(i18nWidgetFile "data-protection") + + +-- | Allgemeine Informationen +getInfoR :: Handler Html +getInfoR = do + let infoHeading = [whamlet|Re-Implementierung von UniWorX|] + siteLayout infoHeading $ do + let features = $(widgetFile "featureList") + gitInfo :: Text + gitInfo = $gitDescribe <> " (" <> $gitCommitDate <> ")" + changeLog <- withUrlRenderer $(textFile "ChangeLog.md") + $(widgetFile "versionHistory") + + +getInfoLecturerR :: Handler Html +getInfoLecturerR = + siteLayoutMsg' MsgInfoLecturerTitle $ do + setTitleI MsgInfoLecturerTitle + $(i18nWidgetFile "info-lecturer") + diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index d582abf41..5de418a34 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -10,7 +10,7 @@ import Utils.Lens -- import Yesod.Colonnade import Data.Monoid (Any(..)) import qualified Data.Map as Map --- import qualified Data.Set as Set +import qualified Data.Set as Set import qualified Database.Esqueleto as E -- import Database.Esqueleto ((^.)) @@ -491,3 +491,44 @@ mkCorrectionsTable = in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in dbTableWidget' validator DBTable{..} + +getAuthPredsR, postAuthPredsR :: Handler Html +getAuthPredsR = postAuthPredsR +postAuthPredsR = do + (AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags + + let + blacklist = Set.fromList [ AuthFree, AuthDevelopment, AuthDeprecated ] + taForm authTag + | authTag `Set.member` blacklist = aforced checkBoxField (fslI authTag) (authTagIsActive def authTag) + | otherwise = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag) + + ((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard + $ AuthTagActive <$> funcForm taForm (fslI MsgActiveAuthTags) True + + mReferer <- runMaybeT $ do + param <- MaybeT (lookupGetParam $ toPathPiece GetReferer) <|> MaybeT (lookupPostParam $ toPathPiece GetReferer) + MaybeT . return $ fromPathPiece param + + let authActiveForm = wrapForm authActiveWidget' def + { formAction = Just $ SomeRoute AuthPredsR + , formEncoding = authActiveEnctype + , formSubmit = FormDualSubmit + } + authActiveWidget' + = [whamlet| + $newline never + $maybe referer <- mReferer + + ^{authActiveWidget} + |] + + formResult authActiveRes $ \authTagActive -> do + setSessionJson SessionActiveAuthTags authTagActive + modifySessionJson SessionInactiveAuthTags . fmap $ Set.filter (not . authTagIsActive authTagActive) + addMessageI Success MsgAuthPredsActiveChanged + redirect $ fromMaybe AuthPredsR mReferer + + siteLayoutMsg MsgAuthPredsActive $ do + setTitleI MsgAuthPredsActive + $(widgetFile "authpreds") diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 7683950d1..3d6f1d4d4 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -10,7 +10,8 @@ import qualified Data.Set as Set import Data.CaseInsensitive (original) -- import qualified Data.CaseInsensitive as CI -import Language.Haskell.TH (Q, Exp) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (qRunIO) -- import Language.Haskell.TH.Datatype import Text.Hamlet (shamletFile) @@ -26,6 +27,12 @@ import Handler.Utils.Rating as Handler.Utils hiding (extractRatings) import Handler.Utils.Sheet as Handler.Utils import Handler.Utils.Mail as Handler.Utils +import System.Directory (listDirectory) +import System.FilePath.Posix (takeBaseName) + +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty + downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool downloadFiles = do @@ -140,6 +147,15 @@ warnTermDays tid times = do -- which contains a file for each language, -- eg. /templates/imprint/de.hamlet and /templates/imprint/en.hamlet i18nWidgetFile :: FilePath -> Q Exp -i18nWidgetFile = - -- TODO write code to distinguish languages here - widgetFile . ( "de") +i18nWidgetFile basename = do + let i18nDirectory = "templates" basename + availableFiles <- qRunIO $ listDirectory i18nDirectory + let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . List.nub $ pack . takeBaseName <$> availableFiles + availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations + + ws <- newName "ws" + letE + [ funD ws $ [ clause [litP $ stringL l] (normalB . widgetFile $ basename l) [] + | l <- unpack <$> NonEmpty.toList availableTranslations' + ] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] + ] [e|selectLanguage availableTranslations' >>= $(varE ws)|] diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index dd0861ab9..457682087 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -42,7 +42,8 @@ import GHC.Exts as Import (IsList) import Data.Hashable as Import import Data.List.NonEmpty as Import (NonEmpty(..)) -import Data.Text.Encoding.Error as Import(UnicodeException(..)) +import Data.List.NonEmpty.Instances as Import () +import Data.Text.Encoding.Error as Import(UnicodeException(..)) import Data.Semigroup as Import (Semigroup) import Data.Monoid as Import (Last(..), First(..)) import Data.Monoid.Instances as Import () diff --git a/templates/home.hamlet b/templates/home.hamlet deleted file mode 100644 index 3995b864f..000000000 --- a/templates/home.hamlet +++ /dev/null @@ -1,5 +0,0 @@ -
-

- Kurse mit offener Registrierung -
- ^{courseTable} diff --git a/templates/home/openCourses.hamlet b/templates/home/openCourses.hamlet new file mode 100644 index 000000000..d578cf404 --- /dev/null +++ b/templates/home/openCourses.hamlet @@ -0,0 +1,3 @@ +
+

_{MsgHomeOpenCourses} + ^{courseTable} diff --git a/templates/home/upcomingSheets.hamlet b/templates/home/upcomingSheets.hamlet new file mode 100644 index 000000000..d109294c9 --- /dev/null +++ b/templates/home/upcomingSheets.hamlet @@ -0,0 +1,3 @@ +
+

_{MsgHomeUpcomingSheets} + ^{sheetTable} diff --git a/templates/homeUser.hamlet b/templates/homeUser.hamlet deleted file mode 100644 index 479d27ab9..000000000 --- a/templates/homeUser.hamlet +++ /dev/null @@ -1,17 +0,0 @@ -
-

- Anstehende Übungsblätter -
- ^{sheetTable} - - From 8bedeeffa790849c0364111a4b44142c87384df9 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 3 Apr 2019 18:51:34 +0200 Subject: [PATCH 03/14] Enhance documentation --- src/Handler/Utils.hs | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 3d6f1d4d4..46abeddd5 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -142,20 +142,30 @@ warnTermDays tid times = do forM_ outoftermdays $ warnI MsgDayIsOutOfTerm -- | Add language dependent template files --- For large files which are translated as a whole. --- Argument musst be a directory under templates, --- which contains a file for each language, --- eg. /templates/imprint/de.hamlet and /templates/imprint/en.hamlet +-- +-- For large files which are translated as a whole. +-- +-- Argument musst be a directory under @/templates@, +-- which contains a file for each language, +-- eg. @imprint@ for choosing between +-- @/templates/imprint/de.hamlet@, @/templates/imprint/de-at.hamlet@, +-- and @/templates/imprint/en.hamlet@ +-- +-- Dependency detection cannot work properly (no `addDependentFile`-equivalent +-- for directories) +-- @$ stack clean@ is required so new translations show up i18nWidgetFile :: FilePath -> Q Exp i18nWidgetFile basename = do + -- Construct list of available translations (@de@, @en@, ...) at compile time let i18nDirectory = "templates" basename availableFiles <- qRunIO $ listDirectory i18nDirectory let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . List.nub $ pack . takeBaseName <$> availableFiles availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations - ws <- newName "ws" + -- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time + ws <- newName "ws" -- Name for dispatch function letE [ funD ws $ [ clause [litP $ stringL l] (normalB . widgetFile $ basename l) [] - | l <- unpack <$> NonEmpty.toList availableTranslations' - ] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] + | l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language + ] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match ] [e|selectLanguage availableTranslations' >>= $(varE ws)|] From 8bf9e44c8222f7248009b54e84800709dac557d5 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 3 Apr 2019 20:26:30 +0200 Subject: [PATCH 04/14] Fix login troubles and make it behave as advertised --- shell.nix | 2 +- src/Auth/LDAP.hs | 24 ++++++++++++------------ 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/shell.nix b/shell.nix index 69546ffbe..f98506e41 100644 --- a/shell.nix +++ b/shell.nix @@ -19,7 +19,7 @@ let ''; override = oldAttrs: { - nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql pgadmin ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]); + nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql pgadmin openldap ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]); shellHook = '' export PROMPT_INFO="${oldAttrs.name}" diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 76f12ce89..5233faaf3 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -88,9 +88,14 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..} FormMissing -> redirect LoginR FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do ldapResult <- withLdap pool $ \ldap -> do - Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword) Ldap.bind ldap ldapDn ldapPassword - findUser conf ldap campusIdent [userPrincipalName] + searchResults <- findUser conf ldap campusIdent [userPrincipalName] + case searchResults of + [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] + | Just [principalName] <- lookup userPrincipalName userAttrs + , Right credsIdent <- Text.decodeUtf8' principalName + -> Right (userDN, credsIdent) <$ Ldap.bind ldap (Ldap.Dn credsIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword) + other -> return $ Left other case ldapResult of Left err | LdapError (Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _)) <- err @@ -100,16 +105,11 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..} | otherwise -> do $logErrorS "LDAP" $ "Error during login: " <> tshow err loginErrorMessageI LoginR Msg.AuthError - Right searchResults - | [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] <- searchResults - , Just [principalName] <- lookup userPrincipalName userAttrs - , Right credsIdent <- Text.decodeUtf8' principalName - -> do - $logDebugS "LDAP" $ tshow searchResults - lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)] - | otherwise -> do - $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults - loginErrorMessageI LoginR Msg.AuthError + Right (Right (userDN, credsIdent)) -> + lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)] + Right (Left searchResults) -> do + $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults + loginErrorMessageI LoginR Msg.AuthError apDispatch _ _ = notFound apLogin toMaster = do (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm From 90c18b50cd81edf2859074ac7a836d47b3456dcd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 4 Apr 2019 10:50:55 +0200 Subject: [PATCH 05/14] minor --- messages/uniworx/de.msg | 4 ++-- src/Handler/Admin.hs | 2 -- src/Handler/Course.hs | 6 +++--- 3 files changed, 5 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index da8e563fa..93ab4b266 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -65,8 +65,8 @@ CourseCapacity: Kapazität CourseCapacityTip: Anzahl erlaubter Kursanmeldungen, leer lassen für unbeschränkte Kurskapazität CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei. CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet. -CourseRegisterOk: Sie wurden angemeldet -CourseDeregisterOk: Sie wurden abgemeldet +CourseRegisterOk: Anmeldung erfolgreich +CourseDeregisterOk: Erfolgreich abgemeldet CourseStudyFeature: Assoziiertes Hauptfach CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen CourseSecretWrong: Falsches Kennwort diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 19b84adf3..4d53f5eed 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -305,7 +305,6 @@ postAdminFeaturesR = do unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant let newKeys = map (StudyTermsKey' . fst) infAccepted setSessionJson sessionKeyNewStudyTerms newKeys - -- addMessageI Error $ MsgPrintDebugForStupid $ tshow newKeys if | null infAccepted -> addMessageI Info MsgNoCandidatesInferred | otherwise @@ -324,7 +323,6 @@ postAdminFeaturesR = do _other -> runDB Candidates.conflicts newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson sessionKeyNewStudyTerms - -- addMessageI Error $ MsgPrintDebugForStupid $ tshow newStudyTermKeys ( (degreeResult,degreeTable) , (studyTermsResult,studytermsTable) , ((), candidateTable)) <- runDB $ (,,) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index fd7ae019e..aa9e37fde 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -705,7 +705,7 @@ validateCourse CourseForm{..} = do uid <- liftHandlerT requireAuthId userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid cfSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route MsgRenderer mr <- getMsgRenderer - + return [ mr msg | (False, msg) <- [ @@ -852,8 +852,8 @@ makeCourseUserTable cid colChoices psValidator = , fltrUserMatriclenr queryUser , fltrUserNameEmail queryUser -- , ("course-user-degree", error "TODO") -- TODO - -- , ("course-user-field" , error "TODO") -- TODO - , ("course-user-semesternr", FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) + -- , ("field" , FilterColumn $ queryFeaturesField error "TODO") -- TODO + , ("semesternr", FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) -- , ("course-registration", error "TODO") -- TODO -- , ("course-user-note", error "TODO") -- TODO ] From 431affe6ec06f9bad6307212fdc079b7cba0456a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 4 Apr 2019 14:20:20 +0200 Subject: [PATCH 06/14] Course User Deregister --- messages/uniworx/de.msg | 3 + routes | 2 +- src/Handler/Course.hs | 141 +++++++++++++++++++++++++--------------- 3 files changed, 94 insertions(+), 52 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 93ab4b266..e5eed4900 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -112,6 +112,9 @@ CourseUserNote: Notiz CourseUserNoteTooltip: Nur für Dozenten dieses Kurses einsehbar CourseUserNoteSaved: Notizänderungen gespeichert CourseUserNoteDeleted: Teilnehmernotiz gelöscht +CourseUserDeregister: Abmelden +CourseUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet + CourseLecturers: Kursverwalter CourseLecturer: Dozent CourseAssistant: Assistent diff --git a/routes b/routes index f76fd47b7..d558de967 100644 --- a/routes +++ b/routes @@ -75,7 +75,7 @@ /register CRegisterR POST !timeANDcapacity /edit CEditR GET POST /delete CDeleteR GET POST !lecturerANDempty - /users CUsersR GET + /users CUsersR GET POST /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant /correctors CHiWisR GET /notes CNotesR GET POST !corrector diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index aa9e37fde..5d4ec2bf9 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -14,6 +14,7 @@ import Handler.Utils.Delete import Handler.Utils.Database import Handler.Utils.Table.Cells import Handler.Utils.Table.Columns +import Database.Persist.Sql (deleteWhereCount) import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -819,57 +820,87 @@ colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $ foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just) -makeCourseUserTable :: CourseId -> _ -> _ -> DB Widget -makeCourseUserTable cid colChoices psValidator = - -- -- psValidator has default sorting and filtering - let dbtIdent = "courseUsers" :: Text - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtSQLQuery = userTableQuery cid - dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms)) - dbtColonnade = colChoices - dbtSorting = Map.fromList - [ sortUserNameLink queryUser -- slower sorting through clicking name column header - , sortUserSurname queryUser -- needed for initial sorting - , sortUserDisplayName queryUser -- needed for initial sorting - , sortUserEmail queryUser - , sortUserMatriclenr queryUser - , ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName)) - , ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)) - , ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName)) - , ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) - , ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) - , ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration)) - , ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date - E.sub_select . E.from $ \edit -> do - E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote) - return . E.max_ $ edit E.^. CourseUserNoteEditTime - ) - ] - dbtFilter = Map.fromList - [ fltrUserNameLink queryUser - , fltrUserEmail queryUser - , fltrUserMatriclenr queryUser - , fltrUserNameEmail queryUser - -- , ("course-user-degree", error "TODO") -- TODO - -- , ("field" , FilterColumn $ queryFeaturesField error "TODO") -- TODO - , ("semesternr", FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) - -- , ("course-registration", error "TODO") -- TODO - -- , ("course-user-note", error "TODO") -- TODO - ] - dbtFilterUI mPrev = mconcat - [ fltrUserNameEmailUI mPrev - , fltrUserMatriclenrUI mPrev - ] - dbtParams = def - in dbTableWidget' psValidator DBTable{..} +data CourseUserAction = CourseUserDeregister + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCUsersR tid ssh csh = do - (course, numParticipants, participantTable) <- runDB $ do +instance Universe CourseUserAction +instance Finite CourseUserAction +nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''CourseUserAction id + +makeCourseUserTable :: CourseId -> _ -> _ -> DB (FormResult (CourseUserAction, Set UserId), Widget) +makeCourseUserTable cid colChoices psValidator = do + Just currentRoute <- liftHandlerT getCurrentRoute + -- -- psValidator has default sorting and filtering + let dbtIdent = "courseUsers" :: Text + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtSQLQuery = userTableQuery cid + dbtRowKey = queryUser >>> (E.^. UserId) + dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms)) + dbtColonnade = colChoices + dbtSorting = Map.fromList + [ sortUserNameLink queryUser -- slower sorting through clicking name column header + , sortUserSurname queryUser -- needed for initial sorting + , sortUserDisplayName queryUser -- needed for initial sorting + , sortUserEmail queryUser + , sortUserMatriclenr queryUser + , ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName)) + , ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)) + , ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName)) + , ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) + , ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) + , ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration)) + , ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date + E.sub_select . E.from $ \edit -> do + E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote) + return . E.max_ $ edit E.^. CourseUserNoteEditTime + ) + ] + dbtFilter = Map.fromList + [ fltrUserNameLink queryUser + , fltrUserEmail queryUser + , fltrUserMatriclenr queryUser + , fltrUserNameEmail queryUser + -- , ("course-user-degree", error "TODO") -- TODO + -- , ("field" , FilterColumn $ queryFeaturesField error "TODO") -- TODO + , ("semesternr", FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) + -- , ("course-registration", error "TODO") -- TODO + -- , ("course-user-note", error "TODO") -- TODO + ] + dbtFilterUI mPrev = mconcat + [ fltrUserNameEmailUI mPrev + , fltrUserMatriclenrUI mPrev + ] + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Just $ SomeRoute currentRoute + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional = \csrf -> do + (res,vw) <- mreq (selectField optionsFinite) "" Nothing + let formWgt = toWidget csrf <> fvInput vw + formRes = (, mempty) . First . Just <$> res + return (formRes,formWgt) + , dbParamsFormEvaluate = liftHandlerT . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } + over _1 postprocess <$> dbTable psValidator DBTable{..} + where + postprocess :: FormResult (First CourseUserAction, DBFormResult UserId Bool UserTableData) -> FormResult (CourseUserAction, Set UserId) + postprocess inp = do + (First (Just act), usrMap) <- inp + let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap + return (act, usrSet) + +getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCUsersR = postCUsersR +postCUsersR tid ssh csh = do + (Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do let colChoices = mconcat - [ colUserNameLink (CourseR tid ssh csh . CUserR) + [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) + , colUserNameLink (CourseR tid ssh csh . CUserR) , colUserEmail , colUserMatriclenr , colUserDegreeShort @@ -879,10 +910,18 @@ getCUsersR tid ssh csh = do , colUserComment tid ssh csh ] psValidator = def & defaultSortingByName - Entity cid course <- getBy404 $ TermSchoolCourseShort tid ssh csh + ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh numParticipants <- count [CourseParticipantCourse ==. cid] - participantTable <- makeCourseUserTable cid colChoices psValidator - return (course, numParticipants, participantTable) + table <- makeCourseUserTable cid colChoices psValidator + return (ent, numParticipants, table) + formResult participantRes $ \case + (CourseUserDeregister,selectedUsers) -> do + nrDel <- runDB $ deleteWhereCount + [ CourseParticipantCourse ==. cid + , CourseParticipantUser <-. Set.toList selectedUsers + ] + addMessageI Success $ MsgCourseUsersDeregistered nrDel + redirect $ CourseR tid ssh csh CUsersR let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|] headingShort = prependCourseTitle tid ssh csh MsgCourseMembers siteLayout headingLong $ do From 6da0850add13840203ac7d4eec71a5ce90262099 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 4 Apr 2019 18:01:46 +0200 Subject: [PATCH 07/14] Filter-UI course participants improved --- src/Database/Esqueleto/Utils.hs | 41 +++++++++++++++++++++++++-------- src/Handler/Course.hs | 19 ++++++++++++--- 2 files changed, 48 insertions(+), 12 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index f3aec73aa..6c89e6c96 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -5,8 +5,9 @@ module Database.Esqueleto.Utils , isInfixOf, hasInfix , any, all , SqlIn(..) - , mkExactFilter, mkContainsFilter - , anyFilter + , mkExactFilter, mkExactFilterWith + , mkContainsFilter + , anyFilter, allFilter ) where import ClassyPrelude.Yesod hiding (isInfixOf, any, all) @@ -74,13 +75,22 @@ _queryFeaturesDegree = $(sqlIJproj 3 2) -- Given a lens-like function, make filter for exact matches in a collection -- (Generalizing from Set to Foldable ok here, but gives ambigouus types elsewhere) mkExactFilter :: (PersistField a) - => (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element + => (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element -> t -- ^ query row -> Set.Set a -- ^ needle collection -> E.SqlExpr (E.Value Bool) -mkExactFilter lenslike row criterias +mkExactFilter = mkExactFilterWith id + +-- | like @mkExactFiler@ but allows for conversion; convenient in conjunction with @anyFilter@ and @allFilter@ +mkExactFilterWith :: (PersistField b) + => (a -> b) -- ^ type conversion + -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element + -> t -- ^ query row + -> Set.Set a -- ^ needle collection + -> E.SqlExpr (E.Value Bool) +mkExactFilterWith cast lenslike row criterias | Set.null criterias = true - | otherwise = lenslike row `E.in_` E.valList (Set.toList criterias) + | otherwise = lenslike row `E.in_` E.valList (cast <$> Set.toList criterias) -- | generic filter creation for dbTable -- Given a lens-like function, make filter searching for needles in String-like elements @@ -94,9 +104,22 @@ mkContainsFilter lenslike row criterias | Set.null criterias = true | otherwise = any (hasInfix $ lenslike row) criterias - -anyFilter :: (Foldable f) => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool)) - -> t -> Set.Set Text-> E.SqlExpr (E.Value Bool) +-- | Combine several filters, using logical or +anyFilter :: (Foldable f) + => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool)) + -> t + -> Set.Set Text + -> E.SqlExpr (E.Value Bool) anyFilter fltrs needle criterias = F.foldr aux false fltrs where - aux fltr acc = fltr needle criterias E.||. acc \ No newline at end of file + aux fltr acc = fltr needle criterias E.||. acc + +-- | Combine several filters, using logical and +allFilter :: (Foldable f) + => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool)) + -> t + -> Set.Set Text + -> E.SqlExpr (E.Value Bool) +allFilter fltrs needle criterias = F.foldr aux true fltrs + where + aux fltr acc = fltr needle criterias E.&&. acc \ No newline at end of file diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 5d4ec2bf9..98016ca8e 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -862,15 +862,28 @@ makeCourseUserTable cid colChoices psValidator = do , fltrUserEmail queryUser , fltrUserMatriclenr queryUser , fltrUserNameEmail queryUser - -- , ("course-user-degree", error "TODO") -- TODO - -- , ("field" , FilterColumn $ queryFeaturesField error "TODO") -- TODO - , ("semesternr", FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) + , ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName)) + , ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) + , ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey)) + , ("field" , FilterColumn $ E.anyFilter + [ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName) + , E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand) + , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey) + ] ) + , ("degree" , FilterColumn $ E.anyFilter + [ E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeName) + , E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand) + , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey) + ] ) + , ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) -- , ("course-registration", error "TODO") -- TODO -- , ("course-user-note", error "TODO") -- TODO ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailUI mPrev , fltrUserMatriclenrUI mPrev + , prismAForm (singletonFilter "degree") mPrev $ aopt (searchField False) (fslI MsgStudyFeatureDegree) + , prismAForm (singletonFilter "field") mPrev $ aopt (searchField False) (fslI MsgCourseStudyFeature) ] dbtParams = DBParamsForm { dbParamsFormMethod = POST From 40c6f1296860b20945472bb6afc0a926cf8bd0e6 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 5 Apr 2019 13:31:01 +0200 Subject: [PATCH 08/14] Only set submission rated if it was assigned to uploader Fixes #330 --- src/Handler/Utils/Submission.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 124da1b83..67c8fab75 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -462,10 +462,10 @@ sinkSubmission userId mExists isUpdate = do case isUpdate of False -> lift . insert_ $ SubmissionEdit userId now submissionId True -> do - Submission{submissionRatingTime} <- lift $ getJust submissionId - when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True } - lift $ update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ] - -- TODO: Should submissionRatingAssigned change here if userId changes? + Submission{submissionRatingTime, submissionRatingBy} <- lift $ getJust submissionId + when (submissionRatingBy == Just userId) $ do + when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True } + lift $ update submissionId [ SubmissionRatingTime =. Just now ] tellSt $ mempty{ sinkSubmissionTouched = Any True } finalize :: SubmissionSinkState -> YesodJobDB UniWorX () From eedd4714f994b27f16370b34447583aef8c6a778 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 5 Apr 2019 13:56:32 +0200 Subject: [PATCH 09/14] Fix `colRated` to use `submissionRatingDone`, as it should --- src/Handler/Corrections.hs | 1 + src/Handler/Sheet.hs | 3 ++- templates/widgets/rating/rating.hamlet | 6 ++++-- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 9381e0829..42c21d62a 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -161,6 +161,7 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(E mkRoute = do cid <- encrypt subId return $ CSubmissionR tid ssh csh sheetName cid CorrectionR + mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this in mconcat [ anchorCellM mkRoute $(widgetFile "widgets/rating/rating") , writerCell $ do diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 7faa02e29..cc5bc7718 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -199,11 +199,12 @@ getSheetListR tid ssh csh = do let stats = sheetTypeSum sheetType in -- for statistics over all shown rows case mbSub of Nothing -> cellTell mempty $ stats Nothing - (Just (Entity sid Submission{..})) -> + (Just (Entity sid sub@Submission{..})) -> let mkCid = encrypt sid mkRoute = do cid' <- mkCid return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR + mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this acell = anchorCellM mkRoute $(widgetFile "widgets/rating/rating") in cellTell acell $ stats submissionRatingPoints diff --git a/templates/widgets/rating/rating.hamlet b/templates/widgets/rating/rating.hamlet index 5c42595e2..a2fb74fe0 100644 --- a/templates/widgets/rating/rating.hamlet +++ b/templates/widgets/rating/rating.hamlet @@ -1,8 +1,10 @@ $# Display Rating, expects +$# sub :: Submission +$# submissionRatingDone :: Submission -> Bool $# submissionRatingPoints :: Maybe points -$maybe points <- submissionRatingPoints - $maybe grading <- preview _grading sheetType +$if submissionRatingDone sub + $maybe (grading, points) <- mTuple (preview _grading sheetType) submissionRatingPoints $case grading $of Points{..} _{MsgAchievedOf points maxPoints} From 819ec36073700913549d63117214998b641ff0a8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 5 Apr 2019 20:48:31 +0200 Subject: [PATCH 10/14] autofocus on campus login --- src/Auth/LDAP.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 5233faaf3..2131bf527 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -66,7 +66,7 @@ campusForm :: ( RenderMessage site FormMessage , Button site ButtonSubmit ) => AForm (HandlerT site IO) CampusLogin campusForm = CampusLogin - <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing + <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote & addAttr "autofocus" "") Nothing <*> areq passwordField (fslI MsgCampusPassword) Nothing campusLogin :: forall site. From bc76d858f8a6efa41cf148e335b4546b7d6e39c7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 7 Apr 2019 16:17:10 +0200 Subject: [PATCH 11/14] More standard-conform emails --- messages/uniworx/de.msg | 2 ++ src/Foundation.hs | 2 +- src/Handler/Help.hs | 20 +++++++++++-------- src/Jobs/Handler/HelpRequest.hs | 8 +++++--- .../SendNotification/CorrectionsAssigned.hs | 1 + .../CorrectionsNotDistributed.hs | 1 + .../Handler/SendNotification/SheetActive.hs | 1 + .../Handler/SendNotification/SheetInactive.hs | 2 ++ .../SendNotification/SubmissionRated.hs | 1 + .../SendNotification/UserRightsUpdate.hs | 1 + src/Jobs/Handler/SendTestEmail.hs | 1 + src/Jobs/Types.hs | 5 ++++- src/Mail.hs | 16 +++++++++++++-- 13 files changed, 46 insertions(+), 15 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index e5eed4900..5786e1f13 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -510,6 +510,7 @@ MailLecturerRights n@Int: Als Dozent dürfen Sie Veranstaltungen innerhalb #{plu MailEditNotifications: Benachrichtigungen ein-/ausschalten MailSubjectSupport: Supportanfrage +MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject} SheetGrading: Bewertung SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte @@ -584,6 +585,7 @@ HelpAnswer: Antworten an HelpUser: Meinen Benutzeraccount HelpAnonymous: Keine Antwort (Anonym) HelpEmail: E-Mail +HelpSubject: Betreff HelpRequest: Supportanfrage / Verbesserungsvorschlag HelpProblemPage: Problematische Seite HelpIntroduction: Wenn Ihnen die Benutzung dieser Webseite Schwierigkeiten bereitet oder Sie einen verbesserbaren Umstand entdecken bitten wir Sie uns das zu melden, auch wenn Sie Ihr Problem bereits selbst lösen konnten. Wir passen die Seite ständig an und versuchen sie auch für zukünftige Benutzer so einsichtig wie möglich zu halten. diff --git a/src/Foundation.hs b/src/Foundation.hs index 0d8e5d909..0599f7b32 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -2221,7 +2221,7 @@ instance YesodMail UniWorX where mailT ctx mail = defMailT ctx $ do void setMailObjectId setDateCurrent - replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + replaceMailHeader "Sender" . Just . addressEmail =<< getsYesod (view _appMailFrom) ret <- mail diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs index 39c1f5381..a1547b4c1 100644 --- a/src/Handler/Help.hs +++ b/src/Handler/Help.hs @@ -16,16 +16,18 @@ nullaryPathPiece ''HelpIdentOptions (camelToPathPiece' 1) embedRenderMessage ''UniWorX ''HelpIdentOptions (("Help" <>) . dropPrefix "HI") data HelpForm = HelpForm - { hfReferer:: Maybe (Route UniWorX) - , hfUserId :: Either (Maybe Address) UserId - , hfRequest:: Text + { hfReferer :: Maybe (Route UniWorX) + , hfUserId :: Either (Maybe Address) UserId + , hfSubject :: Maybe Text + , hfRequest :: Text } -helpForm :: Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm -helpForm mReferer mUid = HelpForm +helpForm :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm +helpForm mr mReferer mUid = HelpForm <$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer) <*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid) - <*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing) + <*> aopt textField (fslpI MsgHelpSubject $ mr MsgHelpSubject) Nothing + <*> (unTextarea <$> areq textareaField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing) where identActions :: Map _ (AForm _ (Either (Maybe Address) UserId)) identActions = Map.fromList $ case mUid of @@ -33,7 +35,7 @@ helpForm mReferer mUid = HelpForm Nothing -> defaultActions defaultActions = - [ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslI MsgName) Nothing <*> apreq emailField (fslI MsgEMail) Nothing)) + [ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslpI MsgName $ mr MsgName) Nothing <*> apreq emailField (fslpI MsgEMail $ mr MsgEMail) Nothing)) , (HIAnonymous, pure $ Left Nothing) ] @@ -43,8 +45,9 @@ postHelpR = do mUid <- maybeAuthId mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField (toPathPiece GetReferer) isModal <- hasCustomHeader HeaderIsModal + MsgRenderer mr <- getMsgRenderer - ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid + ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mr mReferer mUid let form = wrapForm formWidget def { formAction = Just $ SomeRoute HelpR , formEncoding = formEnctype @@ -56,6 +59,7 @@ postHelpR = do hfReferer' <- traverse toTextUrl hfReferer queueJob' JobHelpRequest { jSender = hfUserId + , jHelpSubject = hfSubject , jHelpRequest = hfRequest , jRequestTime = now , jReferer = hfReferer' diff --git a/src/Jobs/Handler/HelpRequest.hs b/src/Jobs/Handler/HelpRequest.hs index 1ec904e2b..2b92c0e2b 100644 --- a/src/Jobs/Handler/HelpRequest.hs +++ b/src/Jobs/Handler/HelpRequest.hs @@ -16,10 +16,11 @@ import Data.Bitraversable dispatchJobHelpRequest :: Either (Maybe Address) UserId -> UTCTime + -> Maybe Text -- ^ Help Subject -> Text -- ^ Help Request -> Maybe Text -- ^ Referer -> Handler () -dispatchJobHelpRequest jSender jRequestTime jHelpRequest jReferer = do +dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer = do supportAddress <- getsYesod $ appMailSupport . appSettings userInfo <- bitraverse return (runDB . getEntity) jSender let userAddress = either @@ -28,8 +29,9 @@ dispatchJobHelpRequest jSender jRequestTime jHelpRequest jReferer = do userInfo mailT def $ do _mailTo .= [supportAddress] - whenIsJust userAddress $ addMailHeader "Reply-To" . renderAddress - setSubjectI MsgMailSubjectSupport + whenIsJust userAddress (_mailFrom .=) + replaceMailHeader "Auto-Submitted" $ Just "no" + setSubjectI $ maybe MsgMailSubjectSupport MsgMailSubjectSupportCustom jHelpSubject setDate jRequestTime rtime <- formatTimeMail SelFormatDateTime jRequestTime addPart ($(ihamletFile "templates/mail/support.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) diff --git a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs index 51ec02f77..6a9e6ace9 100644 --- a/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs +++ b/src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs @@ -22,6 +22,7 @@ dispatchNotificationCorrectionsAssigned nUser nSheet jRecipient = do ] return (course, sheet, nbrSubs) when (nbrSubs > 0) . userMailT jRecipient $ do + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectCorrectionsAssigned courseShorthand sheetName MsgRenderer mr <- getMailMsgRenderer diff --git a/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs b/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs index cb24f7e04..959cedad0 100644 --- a/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs +++ b/src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs @@ -19,6 +19,7 @@ dispatchNotificationCorrectionsNotDistributed nSheet jRecipient = do ] return (course, sheet, nbrSubs) when (nbrSubs > 0) . userMailT jRecipient $ do + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectSubmissionsUnassigned courseShorthand sheetName MsgRenderer mr <- getMailMsgRenderer let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm diff --git a/src/Jobs/Handler/SendNotification/SheetActive.hs b/src/Jobs/Handler/SendNotification/SheetActive.hs index 91a8fc716..fc2c5a185 100644 --- a/src/Jobs/Handler/SendNotification/SheetActive.hs +++ b/src/Jobs/Handler/SendNotification/SheetActive.hs @@ -17,6 +17,7 @@ dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do sheet <- getJust nSheet course <- belongsToJust sheetCourse sheet return (course, sheet) + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName MsgRenderer mr <- getMailMsgRenderer diff --git a/src/Jobs/Handler/SendNotification/SheetInactive.hs b/src/Jobs/Handler/SendNotification/SheetInactive.hs index 7112e5c39..ed76be1b3 100644 --- a/src/Jobs/Handler/SendNotification/SheetInactive.hs +++ b/src/Jobs/Handler/SendNotification/SheetInactive.hs @@ -20,6 +20,7 @@ dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $ sheet <- getJust nSheet course <- belongsToJust sheetCourse sheet return (course, sheet) + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectSheetSoonInactive courseShorthand sheetName MsgRenderer mr <- getMailMsgRenderer @@ -45,6 +46,7 @@ dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do -- E.distinctOn [E.don (subUser E.^. SubmissionUserUser)] -- Not necessary due to UniqueSubmisionUser return (E.countRows :: E.SqlExpr (E.Value Int64)) return (course, sheet, nrSubs, nrSubmitters) + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectSheetInactive courseShorthand sheetName MsgRenderer mr <- getMailMsgRenderer diff --git a/src/Jobs/Handler/SendNotification/SubmissionRated.hs b/src/Jobs/Handler/SendNotification/SubmissionRated.hs index 78083d83f..1cb3e1d50 100644 --- a/src/Jobs/Handler/SendNotification/SubmissionRated.hs +++ b/src/Jobs/Handler/SendNotification/SubmissionRated.hs @@ -22,6 +22,7 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien course <- belongsToJust sheetCourse sheet corrector <- traverse getJust submissionRatingBy return (course, sheet, submission, corrector) + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand csid <- encrypt nSubmission diff --git a/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs b/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs index aaf50ac72..3e9d2c4a8 100644 --- a/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs +++ b/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs @@ -19,6 +19,7 @@ dispatchNotificationUserRightsUpdate nUser _originalRights jRecipient = userMai adminSchools <- getSchoolsOf nUser UserAdminSchool UserAdminUser lecturerSchools <- getSchoolsOf nUser UserLecturerSchool UserLecturerUser return (user,adminSchools,lecturerSchools) + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectUserRightsUpdate userDisplayName -- MsgRenderer mr <- getMailMsgRenderer addAlternatives $ do diff --git a/src/Jobs/Handler/SendTestEmail.hs b/src/Jobs/Handler/SendTestEmail.hs index 5c5cd0900..979ec218d 100644 --- a/src/Jobs/Handler/SendTestEmail.hs +++ b/src/Jobs/Handler/SendTestEmail.hs @@ -13,6 +13,7 @@ import Utils.Lens dispatchJobSendTestEmail :: Email -> MailContext -> Handler () dispatchJobSendTestEmail jEmail jMailContext = mailT jMailContext $ do _mailTo .= [Address Nothing jEmail] + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI MsgMailTestSubject now <- liftIO getCurrentTime nDT <- formatTimeMail SelFormatDateTime now diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 151d0e404..dc29a9e7a 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -17,7 +17,10 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica | JobQueueNotification { jNotification :: Notification } | JobHelpRequest { jSender :: Either (Maybe Address) UserId , jRequestTime :: UTCTime - , jHelpRequest :: Text, jReferer :: Maybe Text } + , jHelpSubject :: Maybe Text + , jHelpRequest :: Text + , jReferer :: Maybe Text + } | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings } | JobDistributeCorrections { jSheet :: SheetId } deriving (Eq, Ord, Show, Read, Generic, Typeable) diff --git a/src/Mail.hs b/src/Mail.hs index c125bf88d..008af9987 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -27,7 +27,7 @@ module Mail , setSubjectI, setMailObjectId, setMailObjectId' , setDate, setDateCurrent , setMailSmtpData - , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts + , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailHeader, _mailParts , _partType, _partEncoding, _partFilename, _partHeaders, _partContent ) where @@ -99,9 +99,18 @@ import Data.Universe.Instances.Reverse.Hashable () import GHC.Exts (IsList) +import Control.Monad.Trans.Maybe (MaybeT(..)) + +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + + makeLenses_ ''Mail makeLenses_ ''Part +_mailHeader :: CI ByteString -> Traversal' Mail Text +_mailHeader hdrName = _mailHeaders . traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2 + newtype MailT m a = MailT { _unMailT :: RWST MailContext MailSmtpData Mail m a } deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus @@ -443,7 +452,10 @@ setDate time = do setMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m () setMailSmtpData = do - Address _ from <- use _mailFrom + Just (Address _ from) <- runMaybeT $ asum + [ MaybeT . preuses (_mailHeader "Sender") $ fromString . unpack + , use _mailFrom + ] recps <- Set.fromList . map addressEmail . concat <$> forM [_mailTo, _mailCc, _mailBcc] use tell $ mempty { smtpRecipients = recps } From f158735dd68d9dc51e774a3c13bdc64262f06d0a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 7 Apr 2019 16:38:26 +0200 Subject: [PATCH 12/14] Fix build & minor cleanup --- src/Foundation.hs | 7 ++----- src/Handler/Help.hs | 11 +++++------ templates/help.hamlet | 2 +- 3 files changed, 8 insertions(+), 12 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 0599f7b32..e689643da 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -2221,12 +2221,9 @@ instance YesodMail UniWorX where mailT ctx mail = defMailT ctx $ do void setMailObjectId setDateCurrent - replaceMailHeader "Sender" . Just . addressEmail =<< getsYesod (view _appMailFrom) + replaceMailHeader "Sender" . Just . addressEmail =<< getsYesod (appMailFrom . appSettings) - ret <- mail - - setMailSmtpData - return ret + mail <* setMailSmtpData instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs index a1547b4c1..d29b7f214 100644 --- a/src/Handler/Help.hs +++ b/src/Handler/Help.hs @@ -48,11 +48,6 @@ postHelpR = do MsgRenderer mr <- getMsgRenderer ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mr mReferer mUid - let form = wrapForm formWidget def - { formAction = Just $ SomeRoute HelpR - , formEncoding = formEnctype - , formAttrs = [ ("data-ajax-submit", "") | isModal ] - } formResultModal res HelpR $ \HelpForm{..} -> do now <- liftIO getCurrentTime @@ -68,4 +63,8 @@ postHelpR = do defaultLayout $ do setTitleI MsgHelpTitle - $(widgetFile "help") + wrapForm $(widgetFile "help") def + { formAction = Just $ SomeRoute HelpR + , formEncoding = formEnctype + , formAttrs = [ ("data-ajax-submit", "") | isModal ] + } diff --git a/templates/help.hamlet b/templates/help.hamlet index 4e1beb4cd..073bac477 100644 --- a/templates/help.hamlet +++ b/templates/help.hamlet @@ -1,3 +1,3 @@

_{MsgHelpIntroduction} -^{form} +^{formWidget} From c3b0ffe582f5a0bf42ef7c5deeb65ef28842952b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 7 Apr 2019 22:08:39 +0200 Subject: [PATCH 13/14] Collect coverage during tests --- test.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test.sh b/test.sh index 09d4b3a53..7db64f3c6 100755 --- a/test.sh +++ b/test.sh @@ -1,3 +1,3 @@ #!/usr/bin/env bash -exec -- stack build --test --fast --flag uniworx:dev --flag uniworx:library-only ${@} +exec -- stack build --test --coverage --fast --flag uniworx:dev --flag uniworx:library-only ${@} From 957f911f33d6bef65915b0df358803d3d48318cf Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 7 Apr 2019 22:47:42 +0200 Subject: [PATCH 14/14] don't build uniworxdb when library-only --- package.yaml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/package.yaml b/package.yaml index 339ecff3e..c2a1ebf61 100644 --- a/package.yaml +++ b/package.yaml @@ -218,6 +218,9 @@ executables: dependencies: - uniworx other-modules: [] + when: + - condition: flag(library-only) + buildable: false # Test suite tests: