From 832c007027a632dc963f12d8136a4497ae032555 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 17 Oct 2018 10:38:56 +0200 Subject: [PATCH 1/7] User deletion implemented, but not tested --- src/Handler/Profile.hs | 43 +++++++++++++++++++++++++++++------- src/Utils/DB.hs | 2 +- templates/deletedUser.hamlet | 11 +++++++++ 3 files changed, 47 insertions(+), 9 deletions(-) create mode 100644 templates/deletedUser.hamlet diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 55092ff11..de1b22a7c 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -163,17 +163,44 @@ postProfileDataR = do case btnResult of (FormSuccess BtnDelete) -> do (uid, User{..}) <- requireAuthPair - addMessage Warning "Delete-Knopf gedrückt" - addMessage Error "Löschen der Daten wurde noch nicht implementiert." - -- first determine all submission that solely depend on this user: - -- SubmissionGroup / SubmissionGroupUser - -- Submission / SubmissionUser - -- runDB $ deleteCascade uid + (deletedSubmissions,groupSubmissions) <- runDB $ deleteUser uid + -- addMessageI Success $ MsgDeleteUser deletedSubmissions + -- when (groupSubmissions > 0) $ addMessageI Info $ MsgDeleteUserGroupSubmissions groupSubmissions + --TODO: LogOut user + defaultLayout $ do + $(widgetFile "deletedUser") + (FormSuccess BtnAbort ) -> do addMessageI Info MsgAborted redirect ProfileDataR - _other -> return () - getProfileDataR + _other -> getProfileDataR + + + +deleteUser :: UserId -> DB (Int,Int) -- TODO: Restrict deletions for lecturers, tutors and students in course that won't allow deregistration +deleteUser duid = do + -- E.deleteCount for submissions is not cascading, hence we first select and then delete manually + -- Submissions / SubmissionUser + -- TODO: SubmissionGroup / SubmissionGroupUser + -- TODO: SheetPseudonym ??? + groupSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.>. E.val (0::Int64)) + singleSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.==. E.val (0::Int64)) + deleteCascade duid + forM_ singleSubmissions $ \(E.Value submissionId) -> deleteCascade submissionId + return (length singleSubmissions, length groupSubmissions) + where + selectSubmissionsWhere :: (E.SqlExpr (E.Value Int64) -> E.SqlExpr (E.Value Bool)) + -> ReaderT SqlBackend (HandlerT UniWorX IO) [E.Value (Key Submission)] + selectSubmissionsWhere whereBuddies = + E.select $ E.from $ \(submission `E.InnerJoin` suser) -> do + E.on $ submission E.^. SubmissionId E.==. suser E.^. SubmissionUserSubmission + let numBuddies = E.sub_select $ E.from $ \subUsers -> do + E.where_ $ subUsers E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId + E.&&. subUsers E.^. SubmissionUserUser E.!=. E.val duid + return E.countRows + E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid + E.&&. (whereBuddies numBuddies) + return $ submission E.^. SubmissionId diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 380bb8b2a..69d230275 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -15,7 +15,7 @@ import qualified Data.Set as Set import qualified Database.Esqueleto as E -- import Database.Persist -- currently not needed here - +-- ezero = E.val (0 :: Int64) emptyOrIn :: PersistField typ => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool) diff --git a/templates/deletedUser.hamlet b/templates/deletedUser.hamlet new file mode 100644 index 000000000..04336132f --- /dev/null +++ b/templates/deletedUser.hamlet @@ -0,0 +1,11 @@ +
+

+ Account für ^{nameWidget userDisplayName userSurname} wurde gelöscht +
+ #{display deletedSubmissions} Abgaben wurden unwiederruflich gelöscht. +
+ #{display groupSubmissions} Gruppenabgaben verbleiben in der Datenbank, + aber die Zuordnung zum Benutzer wurden gelöscht. + Gruppenabgaben können dadurch zu Einzelabgaben werden, + welche dann vom letzten Benutzer gelöscht werden können. + From 2634774eefff2e3d437f53a6cdd62cdb3b762619 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 17 Oct 2018 10:53:53 +0200 Subject: [PATCH 2/7] =?UTF-8?q?L=C3=B6schen=20von=20festen=20Abgabegruppen?= =?UTF-8?q?=20implementiert.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Handler/Profile.hs | 18 +++++++++++++++--- templates/deletedUser.hamlet | 3 +++ 2 files changed, 18 insertions(+), 3 deletions(-) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index de1b22a7c..701248d42 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -163,7 +163,7 @@ postProfileDataR = do case btnResult of (FormSuccess BtnDelete) -> do (uid, User{..}) <- requireAuthPair - (deletedSubmissions,groupSubmissions) <- runDB $ deleteUser uid + ((deletedSubmissions,groupSubmissions),deletedSubmissionGroups) <- runDB $ deleteUser uid -- addMessageI Success $ MsgDeleteUser deletedSubmissions -- when (groupSubmissions > 0) $ addMessageI Info $ MsgDeleteUserGroupSubmissions groupSubmissions --TODO: LogOut user @@ -177,7 +177,7 @@ postProfileDataR = do -deleteUser :: UserId -> DB (Int,Int) -- TODO: Restrict deletions for lecturers, tutors and students in course that won't allow deregistration +deleteUser :: UserId -> DB ((Int,Int),Int64) -- TODO: Restrict deletions for lecturers, tutors and students in course that won't allow deregistration deleteUser duid = do -- E.deleteCount for submissions is not cascading, hence we first select and then delete manually -- Submissions / SubmissionUser @@ -187,7 +187,8 @@ deleteUser duid = do singleSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.==. E.val (0::Int64)) deleteCascade duid forM_ singleSubmissions $ \(E.Value submissionId) -> deleteCascade submissionId - return (length singleSubmissions, length groupSubmissions) + deletedSubmissionGroups <- deleteSingleSubmissionGroups + return ((length singleSubmissions, length groupSubmissions),deletedSubmissionGroups) where selectSubmissionsWhere :: (E.SqlExpr (E.Value Int64) -> E.SqlExpr (E.Value Bool)) -> ReaderT SqlBackend (HandlerT UniWorX IO) [E.Value (Key Submission)] @@ -202,6 +203,17 @@ deleteUser duid = do E.&&. (whereBuddies numBuddies) return $ submission E.^. SubmissionId + deleteSingleSubmissionGroups = E.deleteCount $ E.from $ \submissionGroup -> do + E.where_ $ E.exists $ E.from $ \subGroupUser -> do + E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId + E.&&. subGroupUser E.^. SubmissionGroupUserUser E.==. E.val duid + E.where_ $ E.notExists $ E.from $ \subGroupUser -> do + E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId + E.&&. subGroupUser E.^. SubmissionGroupUserUser E.!=. E.val duid + + + + getProfileDataR :: Handler Html diff --git a/templates/deletedUser.hamlet b/templates/deletedUser.hamlet index 04336132f..142d317f1 100644 --- a/templates/deletedUser.hamlet +++ b/templates/deletedUser.hamlet @@ -8,4 +8,7 @@ aber die Zuordnung zum Benutzer wurden gelöscht. Gruppenabgaben können dadurch zu Einzelabgaben werden, welche dann vom letzten Benutzer gelöscht werden können. + $if deletedSubmissionGroups > 0 +
+ #{display deletedSubmissionGroups} benannte Abgabengruppen wurden gelöscht, da diese dadurch leer wurden. From f556d158ccd23e2b980416d53da476eda9488baa Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 17 Oct 2018 12:11:31 +0200 Subject: [PATCH 3/7] Stub for Help-Button via Modal added --- routes | 1 + src/Foundation.hs | 9 ++++++++- src/Handler/Home.hs | 15 +++++++++++++++ 3 files changed, 24 insertions(+), 1 deletion(-) diff --git a/routes b/routes index 2e8f1dd75..f7131c69f 100644 --- a/routes +++ b/routes @@ -37,6 +37,7 @@ /admin/user/#CryptoUUIDUser AdminUserR GET /admin/user/#CryptoUUIDUser/hijack AdminHijackUserR POST /info VersionR GET !free +/help HelpR GET POST !free /profile ProfileR GET POST !free !free /profile/data ProfileDataR GET POST !free !free diff --git a/src/Foundation.hs b/src/Foundation.hs index a8ebf44b8..e32503b44 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -156,7 +156,7 @@ pattern CSubmissionR tid ssh csh shn cid ptn -- Menus and Favourites data MenuItem = MenuItem { menuItemLabel :: Text - , menuItemIcon :: Maybe Text + , menuItemIcon :: Maybe Text -- currently from: https://fontawesome.com/icons?d=gallery , menuItemRoute :: Route UniWorX , menuItemAccessCallback' :: Handler Bool -- Check whether action is shown in ADDITION to authorization (which is always checked) , menuItemModal :: Bool @@ -809,6 +809,13 @@ defaultLinks = -- Define the menu items of the header. , menuItemModal = False , menuItemAccessCallback' = return True } + , NavbarRight $ MenuItem + { menuItemLabel = "Hilfe" + , menuItemIcon = Just "question" + , menuItemRoute = HelpR + , menuItemModal = True + , menuItemAccessCallback' = return True + } , NavbarRight $ MenuItem { menuItemLabel = "Profil" , menuItemIcon = Just "cogs" diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 73aa370d2..92d9b8e1e 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -224,3 +224,18 @@ getVersionR = selectRep $ do $(widgetFile "versionHistory") provideRep $ return ($gitDescribe :: Text) + + +getHelpR :: Handler Html +getHelpR = do + -- can we get the previous route? + --who <- maybeAuth + --now <- getCurrentTime + --where <- getCurrentRoute + -- TODO: form for free input + defaultLayout $ do + [whamlet|TODO|] + +postHelpR :: Handler Html +postHelpR = getHelpR + From 83c4210f8b9bc21683a1007cd9c59418958956a1 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 17 Oct 2018 14:05:45 +0200 Subject: [PATCH 4/7] Minor: delete as message --- messages/uniworx/de.msg | 5 ++++- src/Handler/Home.hs | 4 ++++ src/Handler/Profile.hs | 5 +++-- templates/deletedUser.hamlet | 16 +++++++++------- 4 files changed, 20 insertions(+), 10 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 5be0e189a..ff6b1fd3a 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -378,4 +378,7 @@ SheetNoRegisteredGroup sheetGroupDesc@Text: "#{sheetGroupDesc}" sind nicht als G SheetAmbiguousRegisteredGroup sheetGroupDesc@Text: "#{sheetGroupDesc}" enthält Mitglieder aus verschiedenen registrierten Gruppen SheetNoGroupSubmission sheetGroupDesc@Text: Gruppenabgabe ist für dieses Blatt nicht vorgesehen (#{sheetGroupDesc}) SheetDuplicatePseudonym: Folgende Pseudonyme kamen mehrfach vor; alle Vorkommen außer dem Ersten wurden ignoriert: -SheetCreateExisting: Folgende Pseudonyme haben bereits abgegeben: \ No newline at end of file +SheetCreateExisting: Folgende Pseudonyme haben bereits abgegeben: + + +UserAccountDeleted name@Text: Konto für #{name} wurde gelöscht! diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 92d9b8e1e..f0fbb4171 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -226,14 +226,18 @@ getVersionR = selectRep $ do return ($gitDescribe :: Text) +-- helpForm + getHelpR :: Handler Html getHelpR = do -- can we get the previous route? --who <- maybeAuth --now <- getCurrentTime --where <- getCurrentRoute + -- WAI getReferer -- TODO: form for free input defaultLayout $ do + setTitle "Hilfe" [whamlet|TODO|] postHelpR :: Handler Html diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 701248d42..11e7510eb 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -163,10 +163,12 @@ postProfileDataR = do case btnResult of (FormSuccess BtnDelete) -> do (uid, User{..}) <- requireAuthPair + clearCreds False -- Logout-User ((deletedSubmissions,groupSubmissions),deletedSubmissionGroups) <- runDB $ deleteUser uid + -- addMessageIHamlet + $(addMessageFile Success "templates/deletedUser.hamlet") -- USE THIS ONE -- addMessageI Success $ MsgDeleteUser deletedSubmissions -- when (groupSubmissions > 0) $ addMessageI Info $ MsgDeleteUserGroupSubmissions groupSubmissions - --TODO: LogOut user defaultLayout $ do $(widgetFile "deletedUser") @@ -181,7 +183,6 @@ deleteUser :: UserId -> DB ((Int,Int),Int64) -- TODO: Restrict deletions for lec deleteUser duid = do -- E.deleteCount for submissions is not cascading, hence we first select and then delete manually -- Submissions / SubmissionUser - -- TODO: SubmissionGroup / SubmissionGroupUser -- TODO: SheetPseudonym ??? groupSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.>. E.val (0::Int64)) singleSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.==. E.val (0::Int64)) diff --git a/templates/deletedUser.hamlet b/templates/deletedUser.hamlet index 142d317f1..69b723987 100644 --- a/templates/deletedUser.hamlet +++ b/templates/deletedUser.hamlet @@ -1,14 +1,16 @@

- Account für ^{nameWidget userDisplayName userSurname} wurde gelöscht + _{MsgUserAccountDeleted userDisplayName}
#{display deletedSubmissions} Abgaben wurden unwiederruflich gelöscht. -
- #{display groupSubmissions} Gruppenabgaben verbleiben in der Datenbank, - aber die Zuordnung zum Benutzer wurden gelöscht. - Gruppenabgaben können dadurch zu Einzelabgaben werden, - welche dann vom letzten Benutzer gelöscht werden können. + $if groupSubmissions > 0 +
+ #{display groupSubmissions} Gruppenabgaben verbleiben in der Datenbank, + aber die Zuordnung zum Benutzer wurden gelöscht. + Gruppenabgaben können dadurch zu Einzelabgaben werden, + welche dann vom letzten Benutzer gelöscht werden können. $if deletedSubmissionGroups > 0
#{display deletedSubmissionGroups} benannte Abgabengruppen wurden gelöscht, da diese dadurch leer wurden. - +
+ Good Bye! From 5a349f9b85d2a510411db4961bfb884e53018876 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 17 Oct 2018 14:49:53 +0200 Subject: [PATCH 5/7] Bugfix: deletion deletes files now. --- db.hs | 8 +++++++- src/Handler/Profile.hs | 25 ++++++++++++++++++------- testdata/AbgabeH10-1.hs | 3 +++ 3 files changed, 28 insertions(+), 8 deletions(-) create mode 100644 testdata/AbgabeH10-1.hs diff --git a/db.hs b/db.hs index a58d443fa..e2d130fe7 100755 --- a/db.hs +++ b/db.hs @@ -118,7 +118,7 @@ fillDb = do , userMailLanguages = MailLanguages ["de"] , userNotificationSettings = def } - void . insert $ User + maxMuster <- insert User { userIdent = "max@campus.lmu.de" , userAuthentication = AuthLDAP , userMatrikelnummer = Nothing @@ -319,6 +319,12 @@ fillDb = do void . insert $ SheetFile sh1 h102 SheetHint void . insert $ SheetFile sh1 h103 SheetSolution void . insert $ SheetFile sh1 pdf10 SheetExercise + -- + sub1 <- insert $ Submission sh1 Nothing Nothing Nothing Nothing Nothing + void . insert $ SubmissionEdit maxMuster (nominalDay `addUTCTime` now) sub1 + void . insert $ SubmissionUser maxMuster sub1 + sub1fid1 <- insertFile "AbgabeH10-1.hs" + void . insert $ SubmissionFile sub1 sub1fid1 False False -- datenbanksysteme dbs <- insert' Course { courseName = "Datenbanksysteme" diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 11e7510eb..f1969b9dd 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -182,19 +182,24 @@ postProfileDataR = do deleteUser :: UserId -> DB ((Int,Int),Int64) -- TODO: Restrict deletions for lecturers, tutors and students in course that won't allow deregistration deleteUser duid = do -- E.deleteCount for submissions is not cascading, hence we first select and then delete manually - -- Submissions / SubmissionUser - -- TODO: SheetPseudonym ??? + -- We delete all files tied to submissions where the user is the lone submissionUser + + -- Do not deleteCascade submissions where duid is the corrector: + updateWhere [SubmissionRatingBy ==. Just duid] [SubmissionRatingBy =. Nothing] + groupSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.>. E.val (0::Int64)) singleSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.==. E.val (0::Int64)) deleteCascade duid - forM_ singleSubmissions $ \(E.Value submissionId) -> deleteCascade submissionId + forM_ singleSubmissions $ \(E.Value submissionId) -> do + deleteFileIds <- map E.unValue <$> getSubmissionFiles submissionId + deleteCascade submissionId + deleteWhere [FileId <-. deleteFileIds] -- TODO: throws exception for de-duplicated files + deletedSubmissionGroups <- deleteSingleSubmissionGroups return ((length singleSubmissions, length groupSubmissions),deletedSubmissionGroups) where - selectSubmissionsWhere :: (E.SqlExpr (E.Value Int64) -> E.SqlExpr (E.Value Bool)) - -> ReaderT SqlBackend (HandlerT UniWorX IO) [E.Value (Key Submission)] - selectSubmissionsWhere whereBuddies = - E.select $ E.from $ \(submission `E.InnerJoin` suser) -> do + selectSubmissionsWhere :: (E.SqlExpr (E.Value Int64) -> E.SqlExpr (E.Value Bool)) -> DB [E.Value (Key Submission)] + selectSubmissionsWhere whereBuddies = E.select $ E.from $ \(submission `E.InnerJoin` suser) -> do E.on $ submission E.^. SubmissionId E.==. suser E.^. SubmissionUserSubmission let numBuddies = E.sub_select $ E.from $ \subUsers -> do E.where_ $ subUsers E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId @@ -204,6 +209,12 @@ deleteUser duid = do E.&&. (whereBuddies numBuddies) return $ submission E.^. SubmissionId + getSubmissionFiles :: SubmissionId -> DB [E.Value (Key File)] + getSubmissionFiles subId = E.select $ E.from $ \file -> do + E.where_ $ E.exists $ E.from $ \submissionFile -> do + E.where_ $ submissionFile E.^. SubmissionFileSubmission E.==. E.val subId + return $ file E.^. FileId + deleteSingleSubmissionGroups = E.deleteCount $ E.from $ \submissionGroup -> do E.where_ $ E.exists $ E.from $ \subGroupUser -> do E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId diff --git a/testdata/AbgabeH10-1.hs b/testdata/AbgabeH10-1.hs new file mode 100644 index 000000000..07a3d0124 --- /dev/null +++ b/testdata/AbgabeH10-1.hs @@ -0,0 +1,3 @@ +Abgabe zu H10-1: + + Ich habe keine Ahnung wie ich die H10-1 lösen soll, sorry! From adde4ccdf64f2bab95e0bff41d180b7c77da724f Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 17 Oct 2018 18:07:04 +0200 Subject: [PATCH 6/7] Bugfix: delete user cd /home/jost/programming/Haskell/Yesod/uniworx/templates --- config/settings.yml | 3 ++ messages/uniworx/de.msg | 4 ++ src/Handler/Home.hs | 91 +++++++++++++++++++++++++++++------ src/Handler/Profile.hs | 3 +- src/Handler/Utils/Form.hs | 27 +++++++++++ src/Jobs.hs | 15 ++++++ src/Jobs/Types.hs | 5 +- src/Mail.hs | 14 ++++-- src/Model/Types.hs | 5 +- src/Settings.hs | 1 + src/Utils/DateTime.hs | 9 ++++ templates/help.hamlet | 5 ++ templates/mail/support.hamlet | 29 +++++++++++ 13 files changed, 187 insertions(+), 24 deletions(-) create mode 100644 templates/help.hamlet create mode 100644 templates/mail/support.hamlet diff --git a/config/settings.yml b/config/settings.yml index 02598c3f6..0d6855fa5 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -15,6 +15,9 @@ mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost" mail-verp: separator: "+" at-replacement: "=" +mail-support: + name: null + email: "uni2work@ifi.lmu.de" job-workers: "_env:JOB_WORKERS:10" job-flush-interval: "_env:JOB_FLUSH:30" diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index ff6b1fd3a..091e95dd3 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -340,6 +340,8 @@ MailSheetActiveIntro courseName@Text termDesc@Text sheetName@SheetName: Sie kön MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} kann nur noch kurze Zeit abgegeben werden MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Dia Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) endet in Kürze. +MailSubjectSupport: Supportanfrage + SheetTypeBonus: Bonus SheetTypeNormal: Normal SheetTypePass: Bestehen @@ -382,3 +384,5 @@ SheetCreateExisting: Folgende Pseudonyme haben bereits abgegeben: UserAccountDeleted name@Text: Konto für #{name} wurde gelöscht! + +Dummy: TODO Message not defined! diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index f0fbb4171..cd82660fe 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -2,6 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE IncoherentInstances #-} -- why is this needed? Instance for "display deadline" ought to be clear @@ -16,7 +17,14 @@ import Handler.Utils import qualified Data.Map as Map +import qualified Data.Text as Text +import Data.Text.Encoding (decodeUtf8') import Data.Time hiding (formatTime) +import Data.Universe +import Data.Universe.Helpers + +import Network.Wai (requestHeaderReferer) + -- import qualified Data.Text as T -- import Yesod.Form.Bootstrap3 @@ -27,6 +35,8 @@ import Data.Time hiding (formatTime) -- import Yesod.Colonnade import qualified Database.Esqueleto as E +import Jobs + -- import Text.Shakespeare.Text import Development.GitRev @@ -117,10 +127,10 @@ homeUser uid = do cTime <- liftIO getCurrentTime let fTime = addUTCTime (offSheetDeadlines * nominalDay) cTime - tableData :: -- E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) - -- (E.SqlExpr (Entity Course ))) - -- (E.SqlExpr (Entity Sheet )) - _ -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term)) + tableData :: E.LeftOuterJoin + (E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet))) + (E.InnerJoin (E.SqlExpr (Maybe (Entity Submission))) (E.SqlExpr (Maybe (Entity SubmissionUser)))) + -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term)) , E.SqlExpr (E.Value SchoolId) , E.SqlExpr (E.Value CourseShorthand) , E.SqlExpr (E.Value SheetName) @@ -226,20 +236,69 @@ getVersionR = selectRep $ do return ($gitDescribe :: Text) --- helpForm + + +data HelpIdentOptions = HIAnonymous | HIUser | HIEmail + deriving (Eq, Ord, Bounded, Enum, Show, Read) + +$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813 +instance Universe HelpIdentOptions where universe = universeDef +instance Finite HelpIdentOptions + +instance PathPiece HelpIdentOptions where + toPathPiece = $(nullaryToPathPiece ''HelpIdentOptions [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel]) + fromPathPiece = finiteFromPathPiece + +instance RenderMessage UniWorX HelpIdentOptions where + renderMessage _ _ opt = tshow opt -- TODO + +data HelpForm = HelpForm + { hfReferer:: Maybe Text + , hfUserId :: Either (Maybe Email) UserId + , hfRequest:: Text + } + +helpForm :: Maybe Text -> Maybe UserId -> AForm _ HelpForm +helpForm mReferer mUid = HelpForm + <$> maybe (pure Nothing) (fmap Just . aforced textField (fslI MsgDummy)) mReferer + <*> multiActionA (fslI MsgDummy) identActions (HIUser <$ mUid) + <*> (unTextarea <$> areq textareaField (fslI MsgDummy) Nothing) + <* submitButton + where + identActions :: Map _ (AForm _ (Either (Maybe Email) UserId)) + identActions = Map.fromList . catMaybes $ + [ ( HIUser,) . pure . Right <$> mUid + , Just (HIAnonymous, pure (Left Nothing)) + , Just (HIEmail, Left . Just <$> apreq emailField (fslI MsgDummy) Nothing) + ] getHelpR :: Handler Html -getHelpR = do - -- can we get the previous route? - --who <- maybeAuth - --now <- getCurrentTime - --where <- getCurrentRoute - -- WAI getReferer - -- TODO: form for free input - defaultLayout $ do - setTitle "Hilfe" - [whamlet|TODO|] +getHelpR = postHelpR postHelpR :: Handler Html -postHelpR = getHelpR +postHelpR = do + mUid <- maybeAuthId + mRefererBS <- requestHeaderReferer <$> waiRequest + let mReferer = maybeRight . decodeUtf8' =<< mRefererBS + + ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid + + case res of + FormSuccess (HelpForm{..}) -> do + now <- liftIO getCurrentTime + queueJob' $ JobHelpRequest { jSender = hfUserId + , jHelpRequest = hfRequest + , jRequestTime = now + , jReferer = hfReferer } + redirect $ HelpR + {-selectRep $ do + provideJson () + provideRep (redirect $ HelpR :: Handler Html) -} + FormMissing -> return () + FormFailure errs -> mapM_ (addMessage Error . toHtml) errs + + defaultLayout $ do + setTitle "Hilfe" -- TODO: International + $(widgetFile "help") + diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index f1969b9dd..43f0702a9 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -193,7 +193,7 @@ deleteUser duid = do forM_ singleSubmissions $ \(E.Value submissionId) -> do deleteFileIds <- map E.unValue <$> getSubmissionFiles submissionId deleteCascade submissionId - deleteWhere [FileId <-. deleteFileIds] -- TODO: throws exception for de-duplicated files + deleteCascadeWhere [FileId <-. deleteFileIds] -- TODO: throws exception for de-duplicated files deletedSubmissionGroups <- deleteSingleSubmissionGroups return ((length singleSubmissions, length groupSubmissions),deletedSubmissionGroups) @@ -213,6 +213,7 @@ deleteUser duid = do getSubmissionFiles subId = E.select $ E.from $ \file -> do E.where_ $ E.exists $ E.from $ \submissionFile -> do E.where_ $ submissionFile E.^. SubmissionFileSubmission E.==. E.val subId + E.&&. submissionFile E.^. SubmissionFileFile E.==. file E.^. FileId return $ file E.^. FileId deleteSingleSubmissionGroups = E.deleteCount $ E.from $ \submissionGroup -> do diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index ac246b4e9..46ac21f6b 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -566,3 +566,30 @@ multiAction acts defAction = do accWidget act (Just w) = cons $(widgetFile "widgets/multiAction") actionResults = Map.map fst results return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect")) + +multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) + => FieldSettings UniWorX + -> Map action (AForm (HandlerT UniWorX IO) a) + -> Maybe action + -> AForm (HandlerT UniWorX IO) a +multiActionA FieldSettings{..} acts defAction = formToAForm $ do + (res, selView) <- multiAction acts defAction + + fvId <- maybe newIdent return fsId + MsgRenderer mr <- getMsgRenderer + + return (res, + [ FieldView + { fvLabel = toHtml $ mr fsLabel + , fvTooltip = toHtml . mr <$> fsTooltip + , fvId + , fvInput = selView + , fvErrors = case res of + FormFailure [e] -> Just $ toHtml e + _ -> Nothing + , fvRequired = True + } + ]) + + + diff --git a/src/Jobs.hs b/src/Jobs.hs index 302736570..9f2d8bd23 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -40,6 +40,7 @@ import Database.Persist.Sql (executeQQ, fromSqlKey, transactionSave) import Data.Monoid (Last(..)) import Data.Semigroup (Max(..)) +import Data.Bitraversable import Utils.Lens import Utils.Sql @@ -515,3 +516,17 @@ performJob JobSendTestEmail{..} = mailT jMailContext $ do * #{nD} * #{nT} |] :: TextUrl (Route UniWorX)) +performJob JobHelpRequest{..} = do + supportAddress <- getsYesod $ appMailSupport . appSettings + userInfo <- bitraverse return (runDB . getEntity) jSender + let userAddress = either (fmap $ Address Nothing) + (fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail)) + userInfo + mailT def $ do + _mailTo .= [supportAddress] + whenIsJust userAddress $ addMailHeader "Reply-To" . renderAddress + setSubjectI MsgMailSubjectSupport + setDate jRequestTime + rtime <- formatTimeMail SelFormatDateTime jRequestTime + addPart ($(ihamletFile "templates/mail/support.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 59ad06e2f..9cb800c4d 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -19,8 +19,11 @@ import Data.List.NonEmpty (NonEmpty) data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification } - | JobSendTestEmail { jEmail :: Text, jMailContext :: MailContext } + | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext } | JobQueueNotification { jNotification :: Notification } + | JobHelpRequest { jSender :: Either (Maybe Email) UserId + , jRequestTime :: UTCTime + , jHelpRequest :: Text, jReferer :: Maybe Text } deriving (Eq, Ord, Show, Read, Generic, Typeable) data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } | NotificationSheetActive { nSheet :: SheetId } diff --git a/src/Mail.hs b/src/Mail.hs index a035cc6ad..c812bc583 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -42,7 +42,7 @@ module Mail , replaceMailHeader, addMailHeader, removeMailHeader , replaceMailHeaderI, addMailHeaderI , setSubjectI, setMailObjectId, setMailObjectId' - , setDateCurrent + , setDate, setDateCurrent , setMailSmtpData , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts , _partType, _partEncoding, _partFilename, _partHeaders, _partContent @@ -163,6 +163,10 @@ deriveJSON defaultOptions } ''MailContext instance Hashable MailContext +instance Default MailContext where + def = MailContext { mcLanguages = def + , mcDateTimeFormat = def + } makeLenses_ ''MailContext @@ -450,10 +454,12 @@ setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m () -setDateCurrent = do - now <- liftIO getCurrentTime +setDateCurrent = setDate =<< liftIO getCurrentTime + +setDate :: (MonadHandler m, YesodMail (HandlerSite m)) => UTCTime -> MailT m () +setDate time = do tz <- mailDateTZ - let timeStr = formatTime defaultTimeLocale "%a, %d %b %Y %T %z" $ ZonedTime (utcToLocalTimeTZ tz now) (timeZoneForUTCTime tz now) + let timeStr = formatTime defaultTimeLocale "%a, %d %b %Y %T %z" $ ZonedTime (utcToLocalTimeTZ tz time) (timeZoneForUTCTime tz time) replaceMailHeader "Date" . Just $ pack timeStr diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 19ff99f5b..b7b4fc76a 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -124,8 +124,9 @@ fromPoints = round instance DisplayAble Points data SheetType - = Bonus { maxPoints :: Points } - | Normal { maxPoints :: Points } + = Bonus { maxPoints :: Points } -- Erhöht nicht das Maximum, wird gutgeschrieben + | Normal { maxPoints :: Points } -- Erhöht das Maximum, wird gutgeschrieben +-- | Informational { maxPoints :: Points } -- Erhöht nicht das Maximum Keine Gutschrift | Pass { maxPoints, passingPoints :: Points } | NotGraded deriving (Show, Read, Eq) diff --git a/src/Settings.hs b/src/Settings.hs index 79a3a8be4..ba9515646 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -82,6 +82,7 @@ data AppSettings = AppSettings , appMailFrom :: Address , appMailObjectDomain :: Text , appMailVerp :: VerpMode + , appMailSupport :: Address , appJobWorkers :: Int , appJobFlushInterval :: Maybe NominalDiffTime , appJobCronInterval :: NominalDiffTime diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index 90a4059f6..2d58788e3 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -8,6 +8,7 @@ , DeriveGeneric , GeneralizedNewtypeDeriving , OverloadedStrings + , FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -27,6 +28,7 @@ import System.Locale.Read import Data.Time (TimeZone(..), TimeLocale(..)) import Data.Time.Zones (TZ) import Data.Time.Zones.TH (includeSystemTZ) +import Data.Time.Clock.POSIX import Language.Haskell.TH import Language.Haskell.TH.Syntax (Lift(..)) @@ -47,6 +49,8 @@ import Utils.PathPiece deriving instance Lift TimeZone deriving instance Lift TimeLocale +instance Hashable UTCTime where + hashWithSalt s = hashWithSalt s . toRational . utcTimeToPOSIXSeconds -- $(timeLocaleMap _) :: [Lang] -> TimeLocale timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default @@ -105,3 +109,8 @@ instance ToJSONKey SelDateTimeFormat where toJSONKey = toJSONKeyText $ \v -> let String txt = toJSON v in txt instance FromJSONKey SelDateTimeFormat where fromJSONKey = FromJSONKeyTextParser $ parseJSON . String + +instance {-# OVERLAPPING #-} Default (SelDateTimeFormat -> DateTimeFormat) where + def SelFormatDateTime = "%c" + def SelFormatDate = "%F" + def SelFormatTime = "%T" diff --git a/templates/help.hamlet b/templates/help.hamlet new file mode 100644 index 000000000..532e588cb --- /dev/null +++ b/templates/help.hamlet @@ -0,0 +1,5 @@ + +Bitte beschreiben Sie Ihr Problem: + +
+ ^{formWidget} diff --git a/templates/mail/support.hamlet b/templates/mail/support.hamlet new file mode 100644 index 000000000..d37ca5a8d --- /dev/null +++ b/templates/mail/support.hamlet @@ -0,0 +1,29 @@ +$newline never +\ + + + + +
+ $case userInfo + $of Left (Just email) +
E-Mail +
#{email} + $of Left Nothing + $of Right Nothing +
Ungültige UserId erhalten! + $of Right (Just (Entity _ User{..})) +
Name +
#{userDisplayName} +
E-Mail +
#{userEmail} + $maybe matrnr <- userMatrikelnummer +
Matrikelnummer +
#{matrnr} +
E-Mail Sprachen + $forall lang <- mailLanguages userMailLanguages +
#{lang} +
Zeit +
#{rtime} +

+ #{jHelpRequest} From 033e3a8ad8cbd3a0af9d9c79be90b5039367bf5f Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 17 Oct 2018 18:10:18 +0200 Subject: [PATCH 7/7] Bugfix: delete user; Help Widget (MsgMissing) --- ChangeLog.md | 6 ++++++ src/Settings.hs | 1 + 2 files changed, 7 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index 401601e10..ad60db498 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,9 @@ + * Version 19.10.2018 + + Benutzer können sich in der Testphase komplett selbst löschen + + Hilfe Widget + * Version 18.09.2018 Tooltips funktionieren auch ohne JavaScript diff --git a/src/Settings.hs b/src/Settings.hs index ba9515646..455839b13 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -275,6 +275,7 @@ instance FromJSON AppSettings where appMailFrom <- o .: "mail-from" appMailObjectDomain <- o .: "mail-object-domain" appMailVerp <- o .: "mail-verp" + appMailSupport <- o .: "mail-support" appJobWorkers <- o .: "job-workers" appJobFlushInterval <- o .:? "job-flush-interval"