Merge branch 'master' into 'util-refactor'

# Conflicts:
#   src/Handler/Home.hs

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
+CourseRegisterOk: Anmeldung erfolgreich
-CourseDeregisterOk: Sie wurden abgemeldet
+CourseDeregisterOk: Erfolgreich abgemeldet
 CourseStudyFeature: Assoziiertes Hauptfach
 CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen
 CourseSecretWrong: Falsches Kennwort
@@ -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
@@ -273,6 +276,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
 
@@ -507,6 +513,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
@@ -581,6 +588,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.

package.yaml

@@ -218,6 +218,9 @@ executables:
     dependencies:
       - uniworx
     other-modules: []
+    when:
+      - condition: flag(library-only)
+        buildable: false
 
 # Test suite
 tests:

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

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 openldap ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]);
     shellHook = ''
       export PROMPT_INFO="${oldAttrs.name}"
 

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

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.
@@ -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
+            Right (Right (userDN, credsIdent)) ->
-              | [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] <- searchResults
+              lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
-              , Just [principalName] <- lookup userPrincipalName userAttrs
+            Right (Left searchResults) -> do
-              , Right credsIdent <- Text.decodeUtf8' principalName
+              $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults
-                -> do
+              loginErrorMessageI LoginR Msg.AuthError
-                  $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
     apDispatch _ _ = notFound
     apLogin toMaster = do
       (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm

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

src/Database/Esqueleto/Utils.hs

@@ -5,8 +5,9 @@ module Database.Esqueleto.Utils
   , isInfixOf, hasInfix
   , any, all
   , SqlIn(..)
-  , mkExactFilter, mkContainsFilter
+  , mkExactFilter, mkExactFilterWith
-  , anyFilter
+  , 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
 
-
+-- | Combine several filters, using logical or
-anyFilter :: (Foldable f) => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
+anyFilter :: (Foldable f)
-                   -> t -> Set.Set Text-> E.SqlExpr (E.Value Bool)
+  => 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
+    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

src/Foundation.hs

@@ -2223,12 +2223,9 @@ instance YesodMail UniWorX where
   mailT ctx mail = defMailT ctx $ do
     void setMailObjectId
     setDateCurrent
-    replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+    replaceMailHeader "Sender" . Just . addressEmail =<< getsYesod (appMailFrom . appSettings)
 
-    ret <- mail
+    mail <* setMailSmtpData
-
-    setMailSmtpData
-    return ret
 
 
 instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where

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 $ (,,)

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

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
 
@@ -705,7 +706,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) <-
         [
@@ -819,57 +820,100 @@ 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
-        -- , ("course-user-field" , error "TODO") -- TODO
-        , ("course-user-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
+instance Universe CourseUserAction
-getCUsersR tid ssh csh = do
+instance Finite CourseUserAction
-  (course, numParticipants, participantTable) <- runDB $ do
+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
+          , ("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
+          , 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 +923,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
+    table <- makeCourseUserTable cid colChoices psValidator
-    return (course, numParticipants, participantTable)
+    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

src/Handler/Help.hs

@@ -0,0 +1,70 @@
+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
+  , hfSubject :: Maybe Text
+  , hfRequest :: Text
+  }
+
+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)
+    <*> 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
+      (Just uid) -> (HIUser, pure $ Right uid):defaultActions
+      Nothing    -> defaultActions
+
+    defaultActions =
+      [ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslpI MsgName $ mr MsgName) Nothing <*> apreq emailField (fslpI MsgEMail $ mr 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
+  MsgRenderer mr <- getMsgRenderer
+
+  ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mr mReferer mUid
+
+  formResultModal res HelpR $ \HelpForm{..} -> do
+    now <- liftIO getCurrentTime
+    hfReferer' <- traverse toTextUrl hfReferer
+    queueJob' JobHelpRequest
+      { jSender      = hfUserId
+      , jHelpSubject = hfSubject
+      , jHelpRequest = hfRequest
+      , jRequestTime = now
+      , jReferer     = hfReferer'
+      }
+    tell . pure =<< messageI Success MsgHelpSent
+
+  defaultLayout $ do
+    setTitleI MsgHelpTitle
+    wrapForm $(widgetFile "help") def
+      { formAction = Just $ SomeRoute HelpR
+      , formEncoding = formEnctype
+      , formAttrs = [ ("data-ajax-submit", "") | isModal ]
+      }

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
+  defaultLayout $ do
-    Nothing   -> homeAnonymous
+    setTitleI MsgHomeHeading
-    Just uid  -> homeUser uid
+    maybe mempty homeUpcomingSheets muid
+    homeOpenCourses
 
 
-homeAnonymous :: Handler Html
+homeOpenCourses :: Widget
-homeAnonymous = do
+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")
+  $(widgetFile "home/openCourses")
-  -- addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen!"
-  defaultLayout
-    -- (widgetFile "dsgvDisclaimer")
-    $(widgetFile "home")
 
-homeUser :: Key User -> Handler Html
+homeUpcomingSheets :: UserId -> Widget
-homeUser uid = do
+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."
+  $(widgetFile "home/upcomingSheets")
-  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 <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>|]
-    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 = [ ("uw-async-form", "") | 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
-              <input type=hidden name=#{toPathPiece GetReferer} value=#{toPathPiece referer}>
-            ^{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")

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 <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>|]
+  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")
+

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
+              <input type=hidden name=#{toPathPiece GetReferer} value=#{toPathPiece referer}>
+            ^{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")

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
 

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
@@ -135,11 +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,
+-- For large files which are translated as a whole.
---   which contains a file for each language,
+--
---   eg. /templates/imprint/de.hamlet and /templates/imprint/en.hamlet
+-- 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 =
+i18nWidgetFile basename = do
-  -- TODO write code to distinguish languages here
+  -- Construct list of available translations (@de@, @en@, ...) at compile time
-  widgetFile . (</> "de")
+  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
+
+  -- 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' -- 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)|]

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
+                Submission{submissionRatingTime, submissionRatingBy} <- lift $ getJust submissionId
-                when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True }
+                when (submissionRatingBy == Just userId) $ do
-                lift $ update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
+                  when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True }
-                -- TODO: Should submissionRatingAssigned change here if userId changes?
+                  lift $ update submissionId [ SubmissionRatingTime =. Just now ]
             tellSt $ mempty{ sinkSubmissionTouched = Any True }
 
         finalize :: SubmissionSinkState -> YesodJobDB UniWorX ()

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

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
+    whenIsJust userAddress (_mailFrom .=)
-    setSubjectI MsgMailSubjectSupport
+    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))

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

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

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

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

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

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

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

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)

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 }

templates/help.hamlet

@@ -1,3 +1,3 @@
 <p>
   _{MsgHelpIntroduction}
-^{form}
+^{formWidget}

templates/home.hamlet

@@ -1,5 +0,0 @@
-<div .container>
-  <h2>
-    Kurse mit offener Registrierung
-  <div .container>
-    ^{courseTable}

templates/home/openCourses.hamlet

@@ -0,0 +1,3 @@
+<section>
+  <h2>_{MsgHomeOpenCourses}
+  ^{courseTable}

templates/home/upcomingSheets.hamlet

@@ -0,0 +1,3 @@
+<section>
+  <h2>_{MsgHomeUpcomingSheets}
+  ^{sheetTable}

templates/homeUser.hamlet

@@ -1,17 +0,0 @@
-<div .container>
-  <h2>
-    Anstehende Übungsblätter
-  <div .container>
-    ^{sheetTable}
-
-<!--
-<div .container>
-  <h1>
-    Anstehende Klausuren
-  TODO
-
-<div .container>
-  <h1>
-    Anstehende Kursanmeldungen
-  TODO
--->

templates/widgets/rating/rating.hamlet

@@ -1,8 +1,10 @@
 $# Display Rating, expects
+$#  sub :: Submission
+$#  submissionRatingDone :: Submission -> Bool
 $#  submissionRatingPoints :: Maybe points
 
-$maybe points <- submissionRatingPoints
+$if submissionRatingDone sub
-  $maybe grading <- preview _grading sheetType
+  $maybe (grading, points) <- mTuple (preview _grading sheetType) submissionRatingPoints
     $case grading
       $of Points{..}
         _{MsgAchievedOf points maxPoints}

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