From 5364190a38a8d26efa8eca1832104b837e508800 Mon Sep 17 00:00:00 2001 From: SJost Date: Mon, 19 Mar 2018 22:57:24 +0100 Subject: [PATCH] Problem: getrennte get/post Handler funktionieren so nicht. Warum? --- FragenSJ.txt | 13 +++ messages/de.msg | 4 + routes | 13 ++- src/Handler/Sheet.hs | 167 +++++++++++++++++++++++++++------- src/Handler/Utils.hs | 29 +++++- src/Handler/Utils/Form.hs | 14 +-- templates/formPage.hamlet | 1 - templates/formPageI18n.hamlet | 15 +++ 8 files changed, 203 insertions(+), 53 deletions(-) create mode 100644 templates/formPageI18n.hamlet diff --git a/FragenSJ.txt b/FragenSJ.txt index c1d6833e9..793b2828b 100644 --- a/FragenSJ.txt +++ b/FragenSJ.txt @@ -1,3 +1,16 @@ +** Sicherheitsabfragen? + - SheetDelR tid csh sn : GET zeigt Sicherheitsabfrage + POST löscht. + Ist das so sinnvoll? + Sicherheitsabfrage als PopUpMessage? + + - Utils.getKeyBy404 effiziente Variante, welche nur den Key liefert? Esq? + (Sheet.hs -> fetchSheet) + + - Handler.Sheet.postSheetDelR: deleteCascade für Files? + + - Verständnis: Getrennte Handler get/post Handler in SheetEditR haben nicht funktioniert. Warum? + ** i18n: - i18n der Links -> MenuItems verwenden wie bisher diff --git a/messages/de.msg b/messages/de.msg index 85bc563f2..786f91b0c 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -9,6 +9,10 @@ CourseNewDupShort tid@TermIdentifier courseShortHand@Text: Kurs #{termToText ti CourseEditDupShort tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. SheetNewOk tid@TermIdentifier courseShortHand@Text sheetName@Text: Neues Übungsblatt #{sheetName} wurde im Kurs #{termToText tid}-#{courseShortHand} erfolgreich erstellt. SheetTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand} #{sheetName} +SheetTitleNew tid@TermIdentifier courseShortHand@Text : #{termToText tid}-#{courseShortHand}: Neues Übungsblatt SheetEditOk tid@TermIdentifier courseShortHand@Text sheetName@Text: Übungsblatt #{sheetName} aus Kurs #{termToText tid}-#{courseShortHand} wurde bearbeitet. SheetNameDup tid@TermIdentifier courseShortHand@Text sheetName@Text: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{termToText tid}-#{courseShortHand}. +SheetDelTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: Übungsblatt #{sheetName} wirklich aus Kurs #{termToText tid}-#{courseShortHand} herauslöschen? +SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{show submissionNo} Abgaben. +SheetDelOk tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht. diff --git a/routes b/routes index 8717ecd9b..2cdbe03fe 100644 --- a/routes +++ b/routes @@ -18,13 +18,12 @@ /course/#TermId/#Text/edit CourseEditR GET /course/#TermId/#Text/show CourseShowR GET POST -/course/#TermId/#Text/sheet/ SheetListR GET -/course/#TermId/#Text/sheet/#Text/show SheetShowR GET -/course/#TermId/#Text/sheet/#Text/#SheetFileType/#FilePath SheetFileR GET -/course/#TermId/#Text/sheet/new SheetNewR GET POST --- TODO: Change routes to #Text statt #SheetId -/course/#TermId/#Text/sheet/#SheetId/edit SheetEditR GET POST -/course/#TermId/#Text/sheet/#SheetId/delete SheetDelR GET POST +/course/#TermId/#Text/ex/ SheetListR GET +/course/#TermId/#Text/ex/#Text/show SheetShowR GET +/course/#TermId/#Text/ex/#Text/#SheetFileType/#FilePath SheetFileR GET +/course/#TermId/#Text/ex/new SheetNewR GET POST +/course/#TermId/#Text/ex/#Text/edit SheetEditR GET POST +/course/#TermId/#Text/ex/#Text/delete SheetDelR GET POST /submission SubmissionListR GET POST /submission/#CryptoUUIDSubmission SubmissionR GET POST diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 4b7560ac9..80da98640 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -20,7 +20,7 @@ import Handler.Utils.Zip import qualified Data.Text as T -- import Data.Function ((&)) -- -import Colonnade -- hiding (fromMaybe) +import Colonnade hiding (fromMaybe) import Yesod.Colonnade -- import qualified Data.UUID.Cryptographic as UUID @@ -59,8 +59,8 @@ data SheetForm = SheetForm } -makeSheetForm :: CourseId -> Maybe SheetForm -> Form SheetForm -makeSheetForm cid template = identForm FIDsheet $ \html -> do +makeSheetForm :: Maybe SheetForm -> Form SheetForm +makeSheetForm template = identForm FIDsheet $ \html -> do -- TODO: Yesod.Form.MassInput.inputList arbeitet Server-seitig :( -- Erstmal nur mit ZIP arbeiten (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm @@ -110,7 +110,8 @@ makeSheetForm cid template = identForm FIDsheet $ \html -> do fetchSheet :: TermId -> Text -> Text -> YesodDB UniWorX (Entity Sheet) fetchSheet tid csh shn = do -- TODO: More efficient with Esquleto? - (Entity cid _course) <- getBy404 $ CourseTermShort tid csh + -- (Entity cid _course) <- getBy404 $ CourseTermShort tid csh + cid <- getKeyBy404 $ CourseTermShort tid csh getBy404 $ CourseSheet cid shn -- List Sheets @@ -144,7 +145,7 @@ getSheetList courseEnt = do , headed "Korrigiert" $ toWgt . snd . trd3 , headed "Eingereicht" $ toWgt . fst . trd3 -- TODO: only show edit button for allowed course assistants - , headed "" $ \s -> linkButton "Edit" BCLink $ SheetEditR tid csh $ fst3 s + , headed "" $ \s -> linkButton "Edit" BCLink $ SheetEditR tid csh $ sheetName $ snd3 s ] let pageActions = [ NavbarLeft $ MenuItem @@ -208,6 +209,7 @@ getSheetFileR tid csh shn typ title = do [] -> notFound _other -> error "Multiple matching files found." +{- getSheetNewR :: TermId -> Text -> Handler Html getSheetNewR tid csh = do let tident = unTermKey tid @@ -321,43 +323,133 @@ getSheetEditR tid csh sid = do defaultLayout $ do setTitleI $ MsgSheetTitle tident csh sheetName $(widgetFile "formPage") +-} -postSheetEditR :: TermId -> Text -> SheetId -> Handler Html -postSheetEditR = getSheetEditR +getSheetNewR :: TermId -> Text -> Handler Html +getSheetNewR tid csh = do + let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days + handleSheetEdit tid csh Nothing (error "No DBActione expected") -- TODO +getSheetEditR :: TermId -> Text -> Text -> Handler Html +getSheetEditR tid csh shn = do + sheetEnt <- runDB $ fetchSheet tid csh shn + let sheet@(Sheet {..}) = entityVal sheetEnt + let template = Just $ SheetForm + { sfName = sheetName + , sfDescription = sheetDescription + , sfType = sheetType + , sfGrouping = sheetGrouping + , sfMarkingText = sheetMarkingText + , sfVisibleFrom = sheetVisibleFrom + , sfActiveFrom = sheetActiveFrom + , sfActiveTo = sheetActiveTo + , sfSheetF = Nothing -- TODO + , sfHintFrom = sheetHintFrom + , sfHintF = Nothing -- TODO + , sfSolutionFrom = sheetSolutionFrom + , sfSolutionF = Nothing -- TODO + } + handleSheetEdit tid csh Nothing (error "No DBActione expected") -- TODO -getSheetDelR :: TermId -> Text -> SheetId -> Handler Html -getSheetDelR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO - -- Sicherheitsabfrage +postSheetNewR :: TermId -> Text -> Handler Html +postSheetNewR tid csh = do + let action newSheet = insertUnique $ newSheet + -- More specific error message for new sheet could go here, if insertUnique returns Nothing + handleSheetEdit tid csh Nothing action -postSheetDelR :: TermId -> Text -> SheetId -> Handler Html -postSheetDelR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO - -- Tatsächlich löschen +postSheetEditR :: TermId -> Text -> Text -> Handler Html +postSheetEditR tid csh shn = do + let action newSheet = do + Entity { entityKey=sid, entityVal=oldSheet } <- fetchSheet tid csh shn + replaceRes <- myReplaceUnique sid $! newSheet + { sheetCourseId = sheetCourseId oldSheet + , sheetCreated = sheetCreated oldSheet + , sheetCreatedBy = sheetChangedBy oldSheet } + case replaceRes of + Nothing -> return $ Just sid + (Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here + handleSheetEdit tid csh Nothing action - -{- -getCourseShowR :: TermId -> Text -> Handler Html -getCourseShowR tid csh = do - mbAid <- maybeAuthId - (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do - courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort (TermKey tid) csh - dependent <- (,,) - <$> get (courseSchoolId course) -- join - <*> count [CourseParticipantCourseId ==. cid] -- join - <*> (case mbAid of -- TODO: Someone please refactor this late-night mess here! - Nothing -> return False - (Just aid) -> do - regL <- getBy (UniqueCourseParticipant cid aid) - return $ isJust regL) - return $ (courseEnt,dependent) - let course = entityVal courseEnt - (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered +handleSheetEdit :: TermId -> Text -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html +handleSheetEdit tid csh template dbAction = do + let tident = unTermKey tid + let mbshn = sfName <$> template + aid <- requireAuthId + ((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm template + case res of + (FormSuccess SheetForm{..}) -> do + saveOkay <- runDB $ do + cid <- getKeyBy404 $ CourseTermShort tid csh + actTime <- liftIO getCurrentTime + let newSheet = Sheet + { sheetCourseId = cid + , sheetName = sfName + , sheetDescription = sfDescription + , sheetType = sfType + , sheetGrouping = sfGrouping + , sheetMarkingText = sfMarkingText + , sheetVisibleFrom = sfVisibleFrom + , sheetActiveFrom = sfActiveFrom + , sheetActiveTo = sfActiveTo + , sheetHintFrom = sfHintFrom + , sheetSolutionFrom = sfSolutionFrom + , sheetCreated = actTime -- dbAction adjusts this for replacement + , sheetChanged = actTime + , sheetCreatedBy = aid -- dbAction adjusts this for replacement + , sheetChangedBy = aid + } + mbsid <- dbAction newSheet + case mbsid of + Nothing -> False <$ addMessageI "danger" (MsgSheetNameDup tident csh sfName) + (Just sid) -> do -- save files in DB: + whenIsJust sfSheetF $ insertSheetFile sid SheetExercise + whenIsJust sfHintF $ insertSheetFile sid SheetHint + whenIsJust sfSolutionF $ insertSheetFile sid SheetSolution + addMessageI "info" $ MsgSheetEditOk tident csh sfName + return True + when saveOkay $ redirect $ SheetShowR tid csh sfName -- redirect must happen outside of runDB + (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml + _ -> return () + let pageTitle = maybe (MsgSheetTitleNew tident csh) + (MsgSheetTitle tident csh) mbshn + let formTitle = pageTitle + let formText = Nothing :: Maybe UniWorXMessage + actionUrl <- fromMaybe (SheetNewR tid csh) <$> getCurrentRoute defaultLayout $ do - setTitle $ [shamlet| #{termToText tid} - #{csh}|] - $(widgetFile "course") --} + setTitleI pageTitle + $(widgetFile "formPageI18n") + +getSheetDelR :: TermId -> Text -> Text -> Handler Html +getSheetDelR tid csh shn = do + let tident = unTermKey tid + ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete ) + case result of + (FormSuccess BtnAbort) -> redirectBack + (FormSuccess BtnDelete) -> do + runDB $ do + -- (Entity cid _course) <- getBy404 $ CourseTermShort tid csh + cid <- getKeyBy404 $ CourseTermShort tid csh + -- deleteBy $ CourseSheet cid shn + -- TODO: deleteCascade um ggf. SheetFiles und Dateien zu löschen! + return () + setMessageI $ MsgSheetDelOk tident csh shn + redirect $ SheetListR tid csh + _other -> do + submissionno <- runDB $ do + Entity { entityKey = sid } <- fetchSheet tid csh shn + count [SubmissionSheetId ==. sid] + let formTitle = MsgSheetDelTitle tident csh shn + let formText = Just $ MsgSheetDelText submissionno + let actionUrl = SheetDelR tid csh shn + defaultLayout $ do + setTitleI $ MsgSheetTitle tident csh shn + $(widgetFile "formPageI18n") + +postSheetDelR :: TermId -> Text -> Text -> Handler Html +postSheetDelR = getSheetDelR + insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX () insertSheetFile sid ftype finfo = do runConduit $ (sourceFiles finfo) =$= C.mapM_ finsert @@ -367,5 +459,10 @@ insertSheetFile sid ftype finfo = do void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step - +-- TODO: Move below to utils, did not work somehow +redirectBack :: Handler Html +-- -- redirectBack :: HandlerT UniWorX IO Html +redirectBack = defaultLayout $ do + [whamlet| BACK |] +-- -- [julius| window.history.back(); |] diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 14e9d1271..bd20961ec 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -68,9 +68,32 @@ entities2map :: PersistEntity record => [Entity record] -> Map (Key record) reco entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty --------- --- DB -- --------- +------------ +-- Routes -- +------------ + +-- -- redirectBack :: Handler Html +-- -- redirectBack :: HandlerT UniWorX IO Html +-- redirectBack = defaultLayout $ do +-- [whamlet| BACK |] +-- -- [julius| window.history.back(); |] + + +-------------- +-- Database -- +-------------- + +-- getKeyBy :: PersistEntity val => Unique val -> ReaderT backend0 m0 (Maybe (Entity val)) +-- getKeyBy :: Unique a -> YesodDB site (Key a) + +getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m) + => Unique record -> ReaderT backend m (Maybe (Key record)) +getKeyBy u = (fmap entityKey) <$> getBy u -- TODO optimize this, so that DB does not deliver entire record! + +getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m) + => Unique record -> ReaderT backend m (Key record) +getKeyBy404 = (fmap entityKey) . getBy404 -- TODO optimize this, so that DB does not deliver entire record! + myReplaceUnique :: (MonadIO m diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 9ceadd8e7..e1e0670e0 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -75,19 +75,19 @@ class (Enum a, Bounded a, Ord a, PathPiece a) => Button a where -data BtnSaveCopy = BtnSave | BtnCopy +data BtnDelete = BtnDelete | BtnAbort deriving (Enum, Eq, Ord, Bounded, Read, Show) -instance PathPiece BtnSaveCopy where -- for displaying the button only, not really for paths +instance PathPiece BtnDelete where -- for displaying the button only, not really for paths toPathPiece = showToPathPiece fromPathPiece = readFromPathPiece -instance Button BtnSaveCopy where - label BtnSave = "Speichern" - label BtnCopy = "Kopieren" +instance Button BtnDelete where + label BtnDelete = "Löschen" + label BtnAbort = "Abrechen" - cssClass BtnSave = BCPrimary - cssClass BtnCopy = BCDefault + cssClass BtnDelete = BCDanger + cssClass BtnAbort = BCDefault data SubmitButton = BtnSubmit diff --git a/templates/formPage.hamlet b/templates/formPage.hamlet index aa2d687d1..395be247a 100644 --- a/templates/formPage.hamlet +++ b/templates/formPage.hamlet @@ -5,7 +5,6 @@

#{formTitle} -
diff --git a/templates/formPageI18n.hamlet b/templates/formPageI18n.hamlet new file mode 100644 index 000000000..e7b11f4a9 --- /dev/null +++ b/templates/formPageI18n.hamlet @@ -0,0 +1,15 @@ +
+
+
+
+
+

+ _{formTitle} + $maybe text <- formText + _{text} + +
+
+
+
+ ^{formWidget}