Merge branch 'master' into 'util-refactor'
# Conflicts: # src/Handler/Home.hs
This commit is contained in:
Gregor Kleen
commit
db8e527bbc
@ -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
|
||||
@ -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.
|
||||
|
||||
@ -218,6 +218,9 @@ executables:
|
||||
dependencies:
|
||||
- uniworx
|
||||
other-modules: []
|
||||
when:
|
||||
- condition: flag(library-only)
|
||||
buildable: false
|
||||
|
||||
# Test suite
|
||||
tests:
|
||||
|
||||
2
routes
2
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
|
||||
|
||||
@ -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}"
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
| [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
|
||||
|
||||
12
src/Data/List/NonEmpty/Instances.hs
Normal file
12
src/Data/List/NonEmpty/Instances.hs
Normal file
@ -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|]
|
||||
@ -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
|
||||
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
|
||||
@ -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
|
||||
|
||||
setMailSmtpData
|
||||
return ret
|
||||
mail <* setMailSmtpData
|
||||
|
||||
|
||||
instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
|
||||
|
||||
@ -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 $ (,,)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
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
|
||||
, ("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
|
||||
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
|
||||
|
||||
70
src/Handler/Help.hs
Normal file
70
src/Handler/Help.hs
Normal file
@ -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 ]
|
||||
}
|
||||
@ -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 <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")
|
||||
$(widgetFile "home/upcomingSheets")
|
||||
48
src/Handler/Info.hs
Normal file
48
src/Handler/Info.hs
Normal file
@ -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")
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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,
|
||||
-- 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 =
|
||||
-- TODO write code to distinguish languages here
|
||||
widgetFile . (</> "de")
|
||||
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
|
||||
|
||||
-- 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)|]
|
||||
|
||||
@ -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 ()
|
||||
|
||||
@ -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 ()
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
16
src/Mail.hs
16
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 }
|
||||
|
||||
@ -1,3 +1,3 @@
|
||||
<p>
|
||||
_{MsgHelpIntroduction}
|
||||
^{form}
|
||||
^{formWidget}
|
||||
|
||||
@ -1,5 +0,0 @@
|
||||
<div .container>
|
||||
<h2>
|
||||
Kurse mit offener Registrierung
|
||||
<div .container>
|
||||
^{courseTable}
|
||||
3
templates/home/openCourses.hamlet
Normal file
3
templates/home/openCourses.hamlet
Normal file
@ -0,0 +1,3 @@
|
||||
<section>
|
||||
<h2>_{MsgHomeOpenCourses}
|
||||
^{courseTable}
|
||||
3
templates/home/upcomingSheets.hamlet
Normal file
3
templates/home/upcomingSheets.hamlet
Normal file
@ -0,0 +1,3 @@
|
||||
<section>
|
||||
<h2>_{MsgHomeUpcomingSheets}
|
||||
^{sheetTable}
|
||||
@ -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
|
||||
-->
|
||||
@ -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}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user