Problem: getrennte get/post Handler funktionieren so nicht. Warum?

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

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.
 

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/ex/                SheetListR   GET
-/course/#TermId/#Text/sheet/#Text/show      SheetShowR   GET
+/course/#TermId/#Text/ex/#Text/show      SheetShowR   GET
-/course/#TermId/#Text/sheet/#Text/#SheetFileType/#FilePath SheetFileR  GET
+/course/#TermId/#Text/ex/#Text/#SheetFileType/#FilePath SheetFileR  GET
-/course/#TermId/#Text/sheet/new             SheetNewR   GET POST
+/course/#TermId/#Text/ex/new             SheetNewR   GET POST
--- TODO: Change routes to #Text statt #SheetId
+/course/#TermId/#Text/ex/#Text/edit      SheetEditR  GET POST
-/course/#TermId/#Text/sheet/#SheetId/edit   SheetEditR  GET POST
+/course/#TermId/#Text/ex/#Text/delete    SheetDelR   GET POST
-/course/#TermId/#Text/sheet/#SheetId/delete SheetDelR   GET POST
 
 /submission                 SubmissionListR GET POST
 /submission/#CryptoUUIDSubmission SubmissionR GET POST

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 :: Maybe SheetForm -> Form SheetForm
-makeSheetForm cid template = identForm FIDsheet $ \html -> do
+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
+getSheetNewR :: TermId -> Text -> Handler Html
-postSheetEditR = getSheetEditR
+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
+postSheetNewR :: TermId -> Text -> Handler Html
-getSheetDelR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
+postSheetNewR tid csh = do
-  -- Sicherheitsabfrage
+  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
+postSheetEditR :: TermId -> Text -> Text -> Handler Html
-postSheetDelR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
+postSheetEditR tid csh shn = do
-  -- Tatsächlich löschen
+  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
 
-
+handleSheetEdit :: TermId -> Text -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
-{-
+handleSheetEdit tid csh template dbAction = do
-getCourseShowR :: TermId -> Text -> Handler Html
+  let tident = unTermKey tid
-getCourseShowR tid csh = do
+  let mbshn  = sfName <$> template
-  mbAid <- maybeAuthId
+  aid  <- requireAuthId
-  (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do
+  ((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm template
-      courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort (TermKey tid) csh
+  case res of
-      dependent <- (,,) 
+    (FormSuccess SheetForm{..}) -> do
-          <$> get (courseSchoolId course)               -- join
+      saveOkay <- runDB $ do
-          <*> count [CourseParticipantCourseId ==. cid] -- join 
+        cid <- getKeyBy404 $ CourseTermShort tid csh
-          <*> (case mbAid of -- TODO: Someone please refactor this late-night mess here!
+        actTime <- liftIO getCurrentTime
-                Nothing -> return False
+        let newSheet = Sheet
-                (Just aid) -> do
+              { sheetCourseId     = cid
-                                regL <- getBy (UniqueCourseParticipant cid aid)
+              , sheetName         = sfName
-                                return $ isJust regL)
+              , sheetDescription  = sfDescription
-      return $ (courseEnt,dependent)
+              , sheetType         = sfType
-  let course = entityVal courseEnt  
+              , sheetGrouping     = sfGrouping
-  (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered      
+              , 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}|]
+    setTitleI pageTitle
-    $(widgetFile "course")
+    $(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(); |]
 

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

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
+instance Button BtnDelete where
-  label BtnSave = "Speichern"
+  label BtnDelete = "Löschen"
-  label BtnCopy = "Kopieren"
+  label BtnAbort  = "Abrechen"
   
-  cssClass BtnSave = BCPrimary
+  cssClass BtnDelete = BCDanger
-  cssClass BtnCopy = BCDefault
+  cssClass BtnAbort  = BCDefault
 
 
 data SubmitButton = BtnSubmit

templates/formPage.hamlet

@@ -5,7 +5,6 @@
                 <div .page-header>
                     <h1 #forms>
                       #{formTitle}
-
         <div .row>
             <div .col-md-10 .col-lg-9>
                 <div .bs-callout bs-callout-info well>

templates/formPageI18n.hamlet

@@ -0,0 +1,15 @@
+<div .container>
+    <div .bs-docs-section>
+        <div .row>
+            <div .col-lg-12>
+                <div .page-header>
+                    <h1 #forms>
+                      _{formTitle}
+                    $maybe text <- formText
+                      _{text}
+
+        <div .row>
+            <div .col-md-10 .col-lg-9>
+                <div .bs-callout bs-callout-info well>
+                    <form .form-horizontal method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
+                        ^{formWidget}