diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 78f999ee3..fd07e0ad8 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -74,6 +74,8 @@ CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein CourseFilterSearch: Volltext-Suche CourseFilterRegistered: Registriert +CourseDeleteQuestion: Wollen Sie den unten aufgeführten Kurs wirklich löschen? +CourseDeleted: Kurs gelöscht NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht. NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht. @@ -89,10 +91,12 @@ SheetTitleNew tid@TermId ssh@SchoolId csh@CourseShorthand SheetEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} editieren SheetEditOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{csh} wurde gespeichert. SheetNameDup tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh}. -SheetDelHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen? -SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben. +SheetDelHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen? Alle assoziierten Abgaben und Korrekturen gehen ebenfalls verloren! SheetDelOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht. +SheetDeleteQuestion: Wollen Sie das unten aufgeführte Übungsblatt und alle zugehörigen Abgaben wirklich löschen? +SheetDeleted: Übungsblatt gelöscht + SheetUploadMode: Abgabe von Dateien SheetSubmissionMode: Abgabe-Modus SheetExercise: Aufgabenstellung @@ -545,17 +549,19 @@ MenuCorrections: Abgaben MenuSheetNew: Neues Übungsblatt anlegen MenuCourseEdit: Kurs editieren MenuCourseNewTemplate: Als neuen Kurs klonen +MenuCourseDelete: Kurs löschen MenuSubmissionNew: Abgabe anlegen MenuSubmissionOwn: Abgabe MenuCorrectors: Korrektoren MenuSheetEdit: Übungsblatt editieren +MenuSheetDelete: Übungsblatt löschen MenuCorrectionsUpload: Korrekturen hochladen MenuCorrectionsCreate: Abgaben registrieren MenuCorrectionsGrade: Abgaben bewerten AuthPredsActive: Aktive Authorisierungsprädikate AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert -AuthTagFree: Seite ist generell zugänglich +AuthTagFree: Seite ist universell zugänglich AuthTagAdmin: Nutzer ist Administrator AuthTagNoEscalation: Nutzer-Rechte werden nicht erweitert AuthTagDeprecated: Seite ist nicht überholt @@ -573,4 +579,8 @@ AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren AuthTagAuthentication: Authentifizierung erfüllt Anforderungen AuthTagRead: Zugriff ist nur lesend -AuthTagWrite: Zugriff ist i.A. schreibend \ No newline at end of file +AuthTagWrite: Zugriff ist i.A. schreibend + +DeleteCopyStringIfSure count@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE count "das obige Objekt" "obige Objekte"} unwiderbringlich löschen möchten, schreiben Sie bitte zunächst den angezeigten Text ab. +DeleteConfirmation: Bestätigung +DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen. \ No newline at end of file diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index c9e7f0c5d..bfc2790ff 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -13,6 +13,7 @@ import qualified Data.CaseInsensitive as CI import Database.Persist.Sql import Text.Blaze (ToMarkup(..)) +import Text.Shakespeare.Text (ToText(..)) import Data.Text (Text) import qualified Data.Text.Encoding as Text @@ -63,6 +64,9 @@ instance ToMarkup a => ToMarkup (CI a) where toMarkup = toMarkup . CI.original preEscapedToMarkup = preEscapedToMarkup . CI.original +instance ToText a => ToText (CI a) where + toText = toText . CI.original + instance ToWidget site a => ToWidget site (CI a) where toWidget = toWidget . CI.original diff --git a/src/Foundation.hs b/src/Foundation.hs index 080d9e2d5..9ec2efe26 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -146,6 +146,15 @@ pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Cr pattern CSubmissionR tid ssh csh shn cid ptn = CSheetR tid ssh csh shn (SubmissionR cid ptn) + +pluralDE :: Int -- ^ Count + -> Text -- ^ Singular + -> Text -- ^ Plural + -> Text +pluralDE num singularForm pluralForm + | num == 1 = singularForm + | otherwise = pluralForm + -- Messages creates type UniWorXMessage and RenderMessage UniWorX instance mkMessage "UniWorX" "messages/uniworx" "de" mkMessageVariant "UniWorX" "Campus" "messages/campus" "de" @@ -1197,6 +1206,14 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuCourseDelete + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR + , menuItemModal = False + , menuItemAccessCallback' = return True + } ] pageActions (CourseR tid ssh csh SheetListR) = [ MenuItem @@ -1257,6 +1274,14 @@ pageActions (CSheetR tid ssh csh shn SShowR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuSheetDelete + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SDelR + , menuItemModal = False + , menuItemAccessCallback' = return True + } ] pageActions (CSheetR tid ssh csh shn SSubsR) = [ MenuItem diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 45cfcaa35..3ac565d92 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -6,6 +6,7 @@ import Utils.Lens -- import Utils.DB import Handler.Utils import Handler.Utils.Table.Cells +import Handler.Utils.Delete -- import Data.Time import qualified Data.Text as T @@ -386,10 +387,24 @@ pgCEditR isGetReq tid ssh csh = do courseEditHandler isGetReq $ courseToForm <$> course -getCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCDeleteR = error "TODO: implement getCDeleteR" -postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -postCDeleteR = error "TODO: implement getCDeleteR" +getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCDeleteR = postCDeleteR +postCDeleteR tid ssh csh = do + Entity cId _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh + deleteR DeleteRoute + { drRecords = Set.singleton cId + , drRenderRecord = \(Entity _ Course{courseName, courseTerm, courseSchool}) -> do + School{schoolName} <- getJust courseSchool + return [whamlet| + #{courseName} (_{SomeMessage $ ShortTermIdentifier (unTermKey courseTerm)}, #{schoolName}) + |] + , drRecordConfirmString = \(Entity _ Course{courseShorthand, courseTerm, courseSchool}) -> + return [st|#{unSchoolKey courseSchool}/#{termToText (unTermKey courseTerm)}/#{courseShorthand}|] + , drCaption = SomeMessage MsgCourseDeleteQuestion + , drSuccessMessage = SomeMessage MsgCourseDeleted + , drAbort = SomeRoute $ CourseR tid ssh csh CShowR + , drSuccess = SomeRoute CourseListR + } {- TODO | False -- DELETE -- TODO: This no longer works that way!!! See new way in Handler.Term.termEditHandler , Just cid <- cfCourseId res -> do diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 090fefcd5..b14be5e43 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -7,6 +7,7 @@ import Handler.Utils -- import Handler.Utils.Zip import Handler.Utils.Table.Cells import Handler.Utils.SheetType +import Handler.Utils.Delete -- import Data.Time -- import qualified Data.Text as T @@ -528,30 +529,26 @@ handleSheetEdit tid ssh csh msId template dbAction = do $(widgetFile "formPageI18n") - -getSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html -getSDelR tid ssh csh shn = do - ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete) - case result of - (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid ssh csh shn SShowR - (FormSuccess BtnDelete) -> do - runDB $ fetchSheetId tid ssh csh shn >>= deleteCascade - -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!! - addMessageI Info $ MsgSheetDelOk tid ssh csh shn - redirect $ CourseR tid ssh csh SheetListR - _other -> do - submissionno <- runDB $ do - sid <- fetchSheetId tid ssh csh shn - count [SubmissionSheet ==. sid] - let formText = Just $ MsgSheetDelText submissionno - let actionUrl = CSheetR tid ssh csh shn SDelR - defaultLayout $ do - setTitleI $ MsgSheetTitle tid ssh csh shn - $(widgetFile "formPageI18n") - -postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html -postSDelR = getSDelR - +getSDelR, postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html +getSDelR = postSDelR +postSDelR tid ssh csh shn = do + sid <- runDB $ fetchSheetId tid ssh csh shn + deleteR DeleteRoute + { drRecords = Set.singleton sid + , drRenderRecord = \(Entity _ Sheet{sheetName, sheetCourse}) -> do + Course{courseTerm, courseSchool, courseName} <- getJust sheetCourse + School{schoolName} <- getJust courseSchool + return [whamlet| + #{sheetName} (_{ShortTermIdentifier (unTermKey courseTerm)}, #{schoolName}, #{courseName}) + |] + , drRecordConfirmString = \(Entity _ Sheet{sheetName, sheetCourse}) -> do + Course{courseTerm, courseSchool, courseShorthand} <- getJust sheetCourse + return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{sheetName}|] + , drCaption = SomeMessage MsgSheetDeleteQuestion + , drSuccessMessage = SomeMessage MsgSheetDeleted + , drAbort = SomeRoute $ CSheetR tid ssh csh shn SShowR + , drSuccess = SomeRoute $ CourseR tid ssh csh SheetListR + } insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX () diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 07c0e919c..2f23745e2 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -59,7 +59,7 @@ postMessageR cID = do <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent) <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary) ) - <*> combinedButtonField (universeF :: [BtnSubmitDelete]) + <*> combinedButtonFieldF "" let modifyTranss = Map.map (view $ _1._1) modifyTranss' diff --git a/src/Handler/Utils/Delete.hs b/src/Handler/Utils/Delete.hs new file mode 100644 index 000000000..68cdb13d9 --- /dev/null +++ b/src/Handler/Utils/Delete.hs @@ -0,0 +1,73 @@ +module Handler.Utils.Delete + ( DeleteRoute(..) + , deleteR + ) where + +import Import +import Handler.Utils.Form + +import Utils.Lens + +import qualified Data.Text as Text +import qualified Data.Set as Set + +import qualified Data.CaseInsensitive as CI + +import Control.Monad.Trans.Random +import System.Random (mkStdGen) +import System.Random.Shuffle (shuffleM) +import qualified Crypto.Hash as Crypto (hash) +import Crypto.Hash (Digest, SHAKE128) + +import qualified Data.ByteArray as ByteArray + + +data DeleteRoute = forall record. (DeleteCascade record SqlBackend, Hashable (Key record)) => DeleteRoute + { drRecords :: Set (Key record) + , drRenderRecord :: Entity record -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget + , drRecordConfirmString :: Entity record -> ReaderT SqlBackend (HandlerT UniWorX IO) Text + , drCaption + , drSuccessMessage :: SomeMessage UniWorX + , drAbort + , drSuccess :: SomeRoute UniWorX + } + + +deleteR :: DeleteRoute -> Handler Html +deleteR DeleteRoute{..} = do + targets <- runDB . mconcatForM drRecords $ \rKey -> do + ent <- Entity rKey <$> get404 rKey + recordWdgt <- drRenderRecord ent + recordConfirmString <- drRecordConfirmString ent + return $ pure (recordWdgt, recordConfirmString) + + cIDKey <- hash . (ByteArray.convert :: Digest (SHAKE128 64) -> ByteString) . Crypto.hash <$> getsYesod appCryptoIDKey + + let sTargets = evalRand (shuffleM targets) . mkStdGen . hashWithSalt cIDKey $ Set.toList drRecords + confirmString = Text.unlines $ map (Text.strip . view _2) sTargets + confirmField + | Set.size drRecords <= 1 = textField + | otherwise = convertField unTextarea Textarea textareaField + + ((deleteFormRes, deleteFormWdgt), deleteFormEnctype) <- runFormPost . identForm FIDDelete . renderAForm FormStandard $ (,) + <$> areq confirmField (fslI MsgDeleteConfirmation) Nothing + <*> combinedButtonFieldF "" + + formResult deleteFormRes $ \case + (_, catMaybes -> [BtnAbort]) -> + redirect drAbort + (inpConfirmStr, catMaybes -> [BtnDelete]) + | ((==) `on` map CI.mk . Text.words) confirmString inpConfirmStr + -> do + runDB $ do + forM_ drRecords deleteCascade + addMessageI Success drSuccessMessage + redirect drSuccess + | otherwise + -> addMessageI Error MsgDeleteConfirmationWrong + _other -> return () + + Just targetRoute <- getCurrentRoute + + defaultLayout + $(widgetFile "widgets/delete-confirmation") diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index bbb8d157c..57d0d223a 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -56,6 +56,9 @@ import Data.Aeson.Text (encodeToLazyText) data BtnDelete = BtnDelete | BtnAbort deriving (Enum, Eq, Ord, Bounded, Read, Show) +instance Universe BtnDelete +instance Finite BtnDelete + instance PathPiece BtnDelete where -- for displaying the button only, not really for paths toPathPiece = showToPathPiece fromPathPiece = readFromPathPiece diff --git a/src/Utils.hs b/src/Utils.hs index 7c99ca13c..045d4d19c 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -498,6 +498,12 @@ partitionM crit = ofoldlM dist mempty | okay -> acc `mappend` (opoint x, mempty) | otherwise -> acc `mappend` (mempty, opoint x) +mconcatMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b +mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList + +mconcatForM :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b +mconcatForM = flip mconcatMapM + -------------- -- Sessions -- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 921c82ec5..6f2b9b078 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -172,6 +172,7 @@ data FormIdentifier | FIDSystemMessageAddTranslation | FIDDBTableFilter | FIDDBTablePagesize + | FIDDelete deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where @@ -230,13 +231,30 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype} | otherwise = return $ Left "Wrong button value" fieldParse _ _ = return $ Left "Multiple button values" -combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a] -combinedButtonField = traverse b2f - where - b2f b = aopt (buttonField b) "" Nothing +combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> FieldSettings site -> AForm (HandlerT site IO) [Maybe a] +combinedButtonField bs FieldSettings{..} = formToAForm $ do + mr <- getMessageRender + fvId <- maybe newIdent return fsId + name <- maybe newIdent return fsName + (ress, fvs) <- fmap unzip . for bs $ \b -> mopt (buttonField b) ("" { fsId = Just $ fvId <> "__" <> toPathPiece b + , fsName = Just $ name <> "__" <> toPathPiece b + }) Nothing + return ( sequenceA ress + , pure FieldView + { fvLabel = toHtml $ mr fsLabel + , fvTooltip = fmap (toHtml . mr) fsTooltip + , fvId + , fvInput = foldMap fvInput fvs + , fvErrors = bool Nothing (Just $ foldMap (fromMaybe mempty . fvErrors) fvs) $ any (isJust . fvErrors) fvs + , fvRequired = False + } + ) + +combinedButtonFieldF :: forall site a. (Button site a, Show (ButtonCssClass site), Finite a) => FieldSettings site -> AForm (HandlerT site IO) [Maybe a] +combinedButtonFieldF = combinedButtonField (universeF :: [a]) submitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) () -submitButton = void $ combinedButtonField [BtnSubmit] +submitButton = void $ combinedButtonField [BtnSubmit] "" autosubmitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) () autosubmitButton = void $ aopt (buttonField BtnSubmit) ("" & addAutosubmit) Nothing diff --git a/templates/widgets/delete-confirmation.hamlet b/templates/widgets/delete-confirmation.hamlet new file mode 100644 index 000000000..7f2e070b0 --- /dev/null +++ b/templates/widgets/delete-confirmation.hamlet @@ -0,0 +1,13 @@ +

_{drCaption} +