Problem: getrennte get/post Handler funktionieren so nicht. Warum?
This commit is contained in:
SJost
parent
037c0cce20
commit
5364190a38
13
FragenSJ.txt
13
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
|
||||
|
||||
@ -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.
|
||||
|
||||
|
||||
13
routes
13
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
|
||||
|
||||
@ -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(); |]
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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>
|
||||
|
||||
15
templates/formPageI18n.hamlet
Normal file
15
templates/formPageI18n.hamlet
Normal file
@ -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}
|
||||
Loading…
Reference in New Issue
Block a user