Bugfix: delete user cd /home/jost/programming/Haskell/Yesod/uniworx/templates

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"

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!

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))
+      tableData :: E.LeftOuterJoin
-                   --                         (E.SqlExpr (Entity Course           )))
+                        (E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet)))
-                   --                         (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.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
+getHelpR = postHelpR
-  -- 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
-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")
+
 

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

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
+      }
+    ])
+
+
+

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

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 }

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
+setDateCurrent = setDate =<< liftIO getCurrentTime
-  now <- 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
 
 

src/Model/Types.hs

@@ -124,8 +124,9 @@ fromPoints = round
 instance DisplayAble Points
 
 data SheetType
-  = Bonus  { maxPoints :: Points }
+  = Bonus  { maxPoints :: Points } -- Erhöht nicht das Maximum, wird gutgeschrieben
-  | Normal { maxPoints :: Points }
+  | 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)

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

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"

templates/help.hamlet

@@ -0,0 +1,5 @@
+
+Bitte beschreiben Sie Ihr Problem:
+
+<form method=post action=@{HelpR} enctype=#{formEnctype}>
+   ^{formWidget}

templates/mail/support.hamlet

@@ -0,0 +1,29 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+  <body>
+    <dl>
+      $case userInfo
+        $of Left (Just email)
+          <dt> E-Mail
+          <dd> #{email}
+        $of Left  Nothing
+        $of Right Nothing
+          <dt> Ungültige UserId erhalten!
+        $of Right (Just (Entity _ User{..}))
+          <dt> Name
+          <dd> #{userDisplayName}
+          <dt> E-Mail
+          <dd> #{userEmail}
+          $maybe matrnr <- userMatrikelnummer
+            <dt> Matrikelnummer
+            <dd> #{matrnr}
+          <dt> E-Mail Sprachen
+          $forall lang <- mailLanguages userMailLanguages
+            <dd> #{lang}
+      <dt> Zeit
+      <dd> #{rtime}
+    <p>
+      #{jHelpRequest}