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/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/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/messages/uniworx/de.msg b/messages/uniworx/de.msg index ea7f457ac..3083b5b20 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -343,6 +343,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 @@ -381,4 +383,9 @@ 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! + +Dummy: TODO Message not defined! diff --git a/routes b/routes index 50d77226a..dbe76f4d9 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 4223c7fe7..fd28bd230 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -160,7 +160,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 @@ -856,6 +856,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..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) @@ -224,3 +234,71 @@ getVersionR = selectRep $ do $(widgetFile "versionHistory") provideRep $ return ($gitDescribe :: Text) + + + + +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 = postHelpR + +postHelpR :: Handler Html +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 55092ff11..43f0702a9 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -163,17 +163,69 @@ 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 + 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 + defaultLayout $ do + $(widgetFile "deletedUser") + (FormSuccess BtnAbort ) -> do addMessageI Info MsgAborted redirect ProfileDataR - _other -> return () - getProfileDataR + _other -> getProfileDataR + + + +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 + -- 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) -> do + deleteFileIds <- map E.unValue <$> getSubmissionFiles submissionId + deleteCascade submissionId + deleteCascadeWhere [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)) -> 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 + 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 + + 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 + E.&&. submissionFile E.^. SubmissionFileFile E.==. file E.^. FileId + 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 + 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 + + + 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..455839b13 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 @@ -274,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" 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/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/deletedUser.hamlet b/templates/deletedUser.hamlet new file mode 100644 index 000000000..69b723987 --- /dev/null +++ b/templates/deletedUser.hamlet @@ -0,0 +1,16 @@ +