diff --git a/messages/dummy/de.msg b/messages/dummy/de.msg
index f3ca7cae1..5a24922aa 100644
--- a/messages/dummy/de.msg
+++ b/messages/dummy/de.msg
@@ -1 +1,2 @@
-DummyIdent: Nutzer-Kennung
\ No newline at end of file
+DummyIdent: Nutzer-Kennung
+DummyNoFormData: Keine Formulardaten empfangen
\ No newline at end of file
diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 247b2a780..13055bc32 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -93,6 +93,7 @@ SheetEditOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetNa
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? 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.
+SheetDelHasSubmissions count@Int: Inkl. #{tshow count} #{pluralDE count "Abgabe" "Abgaben"}!
SheetDeleteQuestion: Wollen Sie das unten aufgeführte Übungsblatt und alle zugehörigen Abgaben wirklich löschen?
SheetDeleted: Übungsblatt gelöscht
diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs
index b8debc0ca..bb26aa344 100644
--- a/src/Auth/Dummy.hs
+++ b/src/Auth/Dummy.hs
@@ -13,6 +13,7 @@ import qualified Data.CaseInsensitive as CI
data DummyMessage = MsgDummyIdent
+ | MsgDummyNoFormData
dummyForm :: ( RenderMessage site FormMessage
@@ -48,7 +49,9 @@ dummyLogin = AuthPlugin{..}
FormFailure errs -> do
lift . forM_ errs $ addMessage Error . toHtml
redirect LoginR
- FormMissing -> redirect LoginR
+ FormMissing -> do
+ lift $ addMessageI Warning MsgDummyNoFormData
+ redirect LoginR
FormSuccess ident ->
lift . setCredsRedirect $ Creds "dummy" (CI.original ident) []
apDispatch _ _ = notFound
diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs
index 3ac565d92..59c898aab 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.Course
import Handler.Utils.Delete
-- import Data.Time
@@ -391,28 +392,10 @@ getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Ht
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
+ deleteR $ (courseDeleteRoute $ Set.singleton cId)
+ { drAbort = SomeRoute $ CourseR tid ssh csh CShowR
+ , drSuccess = SomeRoute $ TermSchoolCourseListR tid ssh
}
-{- TODO
- | False -- DELETE -- TODO: This no longer works that way!!! See new way in Handler.Term.termEditHandler
- , Just cid <- cfCourseId res -> do
- runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
- let cti = toPathPiece $ cfTerm res
- addMessage Info [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
- redirect $ TermCourseListR $ cfTerm res
--}
-- | Course Creation and Editing
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index 4f421ec3c..0058fee8e 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -106,9 +106,9 @@ postProfileDataR = do
defaultLayout
$(widgetFile "deletedUser")
- (FormSuccess BtnAbort ) -> do
- addMessageI Info MsgAborted
- redirect ProfileDataR
+ -- (FormSuccess BtnAbort ) -> do
+ -- addMessageI Info MsgAborted
+ -- redirect ProfileDataR
_other -> getProfileDataR
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index b14be5e43..0450740dc 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -533,20 +533,8 @@ getSDelR, postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Han
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
+ deleteR $ (sheetDeleteRoute $ Set.singleton sid)
+ { drAbort = SomeRoute $ CSheetR tid ssh csh shn SShowR
, drSuccess = SomeRoute $ CourseR tid ssh csh SheetListR
}
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index 8357e4023..9626ba382 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -20,7 +20,6 @@ import Network.Mime
import Data.Monoid (Any(..))
import Data.Maybe (fromJust)
-- import qualified Data.Maybe
-import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.CaseInsensitive (CI)
@@ -397,30 +396,7 @@ getSubDelR, postSubDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName ->
getSubDelR = postSubDelR
postSubDelR tid ssh csh shn cID = do
subId <- runDB $ submissionMatchesSheet tid ssh csh shn cID
- deleteR DeleteRoute
- { drRecords = Set.singleton subId
- , drRenderRecord = \(Entity subId' Submission{submissionSheet}) -> do
- Sheet{sheetName, sheetCourse} <- getJust submissionSheet
- Course{courseName, courseSchool, courseTerm} <- getJust sheetCourse
- School{schoolName} <- getJust courseSchool
- subUsers <- selectList [SubmissionUserSubmission ==. subId'] []
- subNames <- fmap (sortOn snd) . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> (userDisplayName &&& userSurname) <$> getJust submissionUserUser
- return [whamlet|
- $newline never
-
- $forall (dName, sName) <- subNames
- - ^{nameWidget dName sName}
- (_{ShortTermIdentifier (unTermKey courseTerm)}, #{schoolName}, #{courseName}, #{sheetName})
- |]
- , drRecordConfirmString = \(Entity subId' Submission{submissionSheet}) -> do
- Sheet{sheetName, sheetCourse} <- getJust submissionSheet
- Course{courseShorthand, courseSchool, courseTerm} <- getJust sheetCourse
- subUsers <- selectList [SubmissionUserSubmission ==. subId'] []
- subNames <- fmap sort . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> userSurname <$> getJust submissionUserUser
- let subNames' = Text.intercalate ", " subNames
- return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{sheetName}/#{subNames'}|]
- , drCaption = SomeMessage $ MsgSubmissionsDeleteQuestion 1
- , drSuccessMessage = SomeMessage $ MsgSubmissionsDeleted 1
- , drAbort = SomeRoute $ CSubmissionR tid ssh csh shn cID SubShowR
+ deleteR $ (submissionDeleteRoute $ Set.singleton subId)
+ { drAbort = SomeRoute $ CSubmissionR tid ssh csh shn cID SubShowR
, drSuccess = SomeRoute $ CSheetR tid ssh csh shn SShowR
}
diff --git a/src/Handler/Utils/Course.hs b/src/Handler/Utils/Course.hs
new file mode 100644
index 000000000..c95df004e
--- /dev/null
+++ b/src/Handler/Utils/Course.hs
@@ -0,0 +1,27 @@
+module Handler.Utils.Course where
+
+import Import
+import Handler.Utils.Delete
+
+import qualified Database.Esqueleto as E
+
+
+courseDeleteRoute :: Set CourseId -> DeleteRoute Course
+courseDeleteRoute drRecords = DeleteRoute
+ { drRecords
+ , drGetInfo = \(course `E.InnerJoin` school) -> do
+ E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
+ E.orderBy [E.asc $ course E.^. CourseName]
+ return (course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm)
+ , drUnjoin = \(course `E.InnerJoin` _) -> course
+ , drRenderRecord = \(E.Value cName, _, E.Value sName, E.Value tid') ->
+ return [whamlet|
+ #{cName} (_{ShortTermIdentifier (unTermKey tid')}, #{sName})
+ |]
+ , drRecordConfirmString = \(E.Value cName, E.Value ssh', _, E.Value tid') ->
+ return [st|#{termToText (unTermKey tid')}/#{ssh'}/#{cName}|]
+ , drCaption = SomeMessage MsgCourseDeleteQuestion
+ , drSuccessMessage = SomeMessage MsgCourseDeleted
+ , drAbort = error "drAbort undefined"
+ , drSuccess = error "drSuccess undefined"
+ }
diff --git a/src/Handler/Utils/Delete.hs b/src/Handler/Utils/Delete.hs
index 57877d2ed..3fa94d8dc 100644
--- a/src/Handler/Utils/Delete.hs
+++ b/src/Handler/Utils/Delete.hs
@@ -36,14 +36,11 @@ data DeleteRoute record = forall tables infoExpr info. (E.SqlSelect infoExpr inf
confirmForm :: ( MonadHandler m, HandlerSite m ~ UniWorX )
=> Text -- ^ Confirmation string
-> AForm m Bool
-confirmForm confirmString = flip traverseAForm aform $ \case
- (inpConfirmStr, BtnDelete)
- | ((==) `on` map (CI.mk . filter isAlphaNum) . Text.words) confirmString inpConfirmStr
- -> return $ pure True
- | otherwise
- -> formFailure [MsgDeleteConfirmationWrong]
- (_, BtnAbort)
- -> return $ pure False
+confirmForm confirmString = flip traverseAForm aform $ \(inpConfirmStr, BtnDelete) -> if
+ | ((==) `on` map (CI.mk . filter isAlphaNum) . Text.words) confirmString inpConfirmStr
+ -> return $ pure True
+ | otherwise
+ -> formFailure [MsgDeleteConfirmationWrong]
where
aform = (,)
<$> areq confirmField (fslI MsgDeleteConfirmation) Nothing
@@ -53,6 +50,14 @@ confirmForm confirmString = flip traverseAForm aform $ \case
| otherwise = textField
multiple = length (filter (not . Text.null . Text.strip) $ Text.lines confirmString) > 1
+confirmForm' :: PersistEntity record => Set (Key record) -> Text -> Form Bool
+confirmForm' drRecords confirmString = addDeleteTargets . identForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString
+ where
+ addDeleteTargets :: Form a -> Form a
+ addDeleteTargets form csrf = do
+ (_, fvTargets) <- mreq secretJsonField ("" & addName (toPathPiece PostDeleteTarget)) (Just drRecords)
+ over _2 (mappend $ fvInput fvTargets) <$> form csrf
+
postDeleteR :: ( DeleteCascade record SqlBackend )
=> (Set (Key record) -> DeleteRoute record) -- ^ Construct `DeleteRoute` based on incoming record keys
@@ -64,13 +69,7 @@ postDeleteR mkRoute = do
void . for drResult $ \DeleteRoute{..} -> do
confirmString <- fmap Text.unlines . runDB $ mapM drRecordConfirmString <=< E.select . E.from $ \t -> drGetInfo t <* E.where_ (drUnjoin t E.^. persistIdField `E.in_` E.valList (Set.toList drRecords))
- let
- addDeleteTargets :: Form a -> Form a
- addDeleteTargets form csrf = do
- (_, fvTargets) <- mreq secretJsonField ("" & addName (toPathPiece PostDeleteTarget)) (Just drRecords)
- over _2 (mappend $ fvInput fvTargets) <$> form csrf
-
- ((confirmRes, _), _) <- runFormPost . identForm FIDDelete . addDeleteTargets . renderAForm FormStandard $ confirmForm confirmString
+ ((confirmRes, _), _) <- runFormPost $ confirmForm' drRecords confirmString
formResult confirmRes $ \case
True -> do
@@ -88,7 +87,7 @@ getDeleteR DeleteRoute{..} = do
let confirmString = Text.unlines $ view _2 <$> targets
- ((_, deleteFormWdgt), deleteFormEnctype) <- runFormPost . identForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString
+ ((_, deleteFormWdgt), deleteFormEnctype) <- runFormPost $ confirmForm' drRecords confirmString
Just targetRoute <- getCurrentRoute
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 57d0d223a..f5e88ba29 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -23,8 +23,6 @@ import qualified Data.Text as T
import Yesod.Form.Functions (parseHelper)
import Yesod.Form.Bootstrap3
-import Web.PathPieces (showToPathPiece, readFromPathPiece)
-
import Handler.Utils.Zip
import qualified Data.Conduit.List as C
@@ -53,29 +51,26 @@ import Data.Aeson.Text (encodeToLazyText)
-- Buttons (new version ) --
----------------------------
-data BtnDelete = BtnDelete | BtnAbort
+data BtnDelete = BtnDelete
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
+nullaryPathPiece ''BtnDelete $ camelToPathPiece' 1
instance Button UniWorX BtnDelete where
label BtnDelete = [whamlet|_{MsgBtnDelete}|]
- label BtnAbort = [whamlet|_{MsgBtnAbort}|]
cssClass BtnDelete = BCDanger
- cssClass BtnAbort = BCDefault
data RegisterButton = BtnRegister | BtnDeregister
deriving (Enum, Eq, Ord, Bounded, Read, Show)
-instance PathPiece RegisterButton where
- toPathPiece = showToPathPiece
- fromPathPiece = readFromPathPiece
+instance Universe RegisterButton
+instance Finite RegisterButton
+
+nullaryPathPiece ''RegisterButton $ camelToPathPiece' 1
instance Button UniWorX RegisterButton where
label BtnRegister = [whamlet|_{MsgBtnRegister}|]
@@ -87,9 +82,10 @@ instance Button UniWorX RegisterButton where
data AdminHijackUserButton = BtnHijack
deriving (Enum, Eq, Ord, Bounded, Read, Show)
-instance PathPiece AdminHijackUserButton where
- toPathPiece = showToPathPiece
- fromPathPiece = readFromPathPiece
+instance Universe AdminHijackUserButton
+instance Finite AdminHijackUserButton
+
+nullaryPathPiece ''AdminHijackUserButton $ camelToPathPiece' 1
instance Button UniWorX AdminHijackUserButton where
label BtnHijack = [whamlet|_{MsgBtnHijack}|]
@@ -109,7 +105,10 @@ instance Button UniWorX BtnSubmitDelete where
cssClass BtnSubmit' = BCPrimary
cssClass BtnDelete' = BCDanger
-nullaryPathPiece ''BtnSubmitDelete (camelToPathPiece' 1 . dropSuffix "'")
+ btnValidate _ BtnSubmit' = True
+ btnValidate _ BtnDelete' = False
+
+nullaryPathPiece ''BtnSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'"
-- -- Looks like a button, but is just a link (e.g. for create course, etc.)
diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs
index e535eab8b..baea1b6a4 100644
--- a/src/Handler/Utils/Sheet.hs
+++ b/src/Handler/Utils/Sheet.hs
@@ -1,13 +1,12 @@
module Handler.Utils.Sheet where
import Import
+import Handler.Utils.Delete
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E
-
-
fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
, E.SqlSelect b a
, Typeable a, MonadHandler m, IsPersistBackend backend
@@ -41,3 +40,31 @@ fetchSheetId tid ssh cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid ss
fetchSheetIdCourseId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course)
fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid ssh cid shn
+
+
+sheetDeleteRoute :: Set SheetId -> DeleteRoute Sheet
+sheetDeleteRoute drRecords = DeleteRoute
+ { drRecords
+ , drGetInfo = \(sheet `E.InnerJoin` course `E.InnerJoin` school) -> do
+ E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
+ E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+ let submissions = E.sub_select . E.from $ \submission -> do
+ E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
+ return E.countRows
+ E.orderBy [E.asc $ sheet E.^. SheetName]
+ return (submissions, sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm)
+ , drUnjoin = \(sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet
+ , drRenderRecord = \(E.Value submissions, E.Value shn', _, E.Value cName, _, E.Value sName, E.Value tid') ->
+ return [whamlet|
+ $newline never
+ #{shn'} (_{SomeMessage $ ShortTermIdentifier (unTermKey tid')}, #{sName}, #{cName})
+ $if submissions /= 0
+ _{SomeMessage $ MsgSheetDelHasSubmissions submissions}
+ |]
+ , drRecordConfirmString = \(E.Value submissions, E.Value shn', E.Value csh', _, E.Value ssh', _, E.Value tid') ->
+ return $ [st|#{termToText (unTermKey tid')}/#{ssh'}/#{csh'}/#{shn'}|] <> bool mempty [st| + #{tshow submissions} Subs|] (submissions /= 0)
+ , drCaption = SomeMessage MsgSheetDeleteQuestion
+ , drSuccessMessage = SomeMessage MsgSheetDeleted
+ , drAbort = error "drAbort undefined"
+ , drSuccess = error "drSuccess undefined"
+ }
diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs
index 0730f157d..b58abab92 100644
--- a/src/Handler/Utils/Submission.hs
+++ b/src/Handler/Utils/Submission.hs
@@ -8,6 +8,7 @@ module Handler.Utils.Submission
, msgSubmissionErrors -- wrap around sinkSubmission/sinkMultiSubmission, but outside of runDB!
, sinkSubmission, sinkMultiSubmission
, submissionMatchesSheet
+ , submissionDeleteRoute
) where
import Import hiding (joinPath)
@@ -37,11 +38,10 @@ import Data.Ratio
import Data.Monoid (Monoid, Any(..), Sum(..))
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
-import Handler.Utils.Rating hiding (extractRatings)
+import Handler.Utils
import qualified Handler.Utils.Rating as Rating (extractRatings)
-import Handler.Utils.Zip
-import Handler.Utils.Sheet
import Handler.Utils.Submission.TH
+import Handler.Utils.Delete
import qualified Database.Esqueleto as E
@@ -601,3 +601,40 @@ submissionMatchesSheet tid ssh csh shn cid = do
Submission{..} <- get404 sid
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
return sid
+
+
+submissionDeleteRoute :: Set SubmissionId -> DeleteRoute Submission
+submissionDeleteRoute drRecords = DeleteRoute
+ { drRecords
+ , drUnjoin = \(submission `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> submission
+ , drGetInfo = \(submission `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` school) -> do
+ E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
+ E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+ E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
+ let lastEdit = E.sub_select . E.from $ \submissionEdit -> do
+ E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
+ E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
+ E.limit 1
+ return $ submissionEdit E.^. SubmissionEditTime
+ E.orderBy [E.desc lastEdit]
+ return (submission E.^. SubmissionId, sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm)
+ , drRenderRecord = \(E.Value subId', E.Value shn', _, E.Value cName, _, E.Value sName, E.Value tid') -> do
+ subUsers <- selectList [SubmissionUserSubmission ==. subId'] []
+ subNames <- fmap (sortOn snd) . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> (userDisplayName &&& userSurname) <$> getJust submissionUserUser
+ return [whamlet|
+ $newline never
+
+ $forall (dName, sName) <- subNames
+ - ^{nameWidget dName sName}
+ (_{ShortTermIdentifier (unTermKey tid')}, #{sName}, #{cName}, #{shn'})
+ |]
+ , drRecordConfirmString = \(E.Value subId', E.Value shn', E.Value csh', _, E.Value ssh', _, E.Value tid') -> do
+ subUsers <- selectList [SubmissionUserSubmission ==. subId'] []
+ subNames <- fmap sort . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> userSurname <$> getJust submissionUserUser
+ let subNames' = Text.intercalate ", " subNames
+ return [st|#{termToText (unTermKey tid')}/#{ssh'}/#{csh'}/#{shn'}/#{subNames'}|]
+ , drCaption = SomeMessage $ MsgSubmissionsDeleteQuestion 1
+ , drSuccessMessage = SomeMessage $ MsgSubmissionsDeleted 1
+ , drAbort = error "drAbort undefined"
+ , drSuccess = error "drSuccess undefined"
+ }
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index 4fa122282..ec42373ad 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-deprecations #-}
+
module Utils.Form where
import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..))
@@ -26,6 +28,7 @@ import Web.PathPieces
import Data.UUID
import Utils.Message
+import Utils.PathPiece
import Data.Proxy
@@ -206,6 +209,9 @@ class (Enum a, Bounded a, Ord a, PathPiece a) => Button site a where
label :: a -> WidgetT site IO ()
label = toWidget . toPathPiece
+ btnValidate :: forall p. p site -> a -> Bool
+ btnValidate _ _ = True
+
cssClass :: a -> ButtonCssClass site
data ButtonMessage = MsgAmbiguousButtons
@@ -218,9 +224,7 @@ data SubmitButton = BtnSubmit
instance Universe SubmitButton
instance Finite SubmitButton
-instance PathPiece SubmitButton where
- toPathPiece = showToPathPiece
- fromPathPiece = readFromPathPiece
+nullaryPathPiece ''SubmitButton $ camelToPathPiece' 1
buttonField :: forall a m.
( Button (HandlerSite m) a
@@ -229,7 +233,7 @@ buttonField :: forall a m.
, Monad m
) => a -> Field m a
-- | Already validates that the correct button press was received (result only neccessary for combinedButtonField)
-buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
+buttonField btn = Field{..}
where
fieldEnctype = UrlEncoded
@@ -237,13 +241,15 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
fieldView fid name attrs _val _ = let
cssClass' :: ButtonCssClass (HandlerSite m)
cssClass' = cssClass btn
+ validate = btnValidate (Proxy @(HandlerSite m)) btn
in [whamlet|
-