Correction download

messages/de.msg

@@ -94,3 +94,7 @@ SheetMarking: Korrekturhinweise
 MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen)
 
 NrColumn: Nr
+SelectColumn: Auswahl
+
+CorrDownload: Herunterladen
+CorrSetCorrector: Korrektor zuweisen

routes

@@ -49,7 +49,7 @@
 /course/#TermId/#Text       CourseR                           !lecturer:
   /show                       CShowR          GET POST        !free
   /edit                       CEditR          GET POST
-  /corrections                CourseCorrectionsR   GET
+  /corrections                CourseCorrectionsR   GET POST
   /ex                         SheetListR      GET             !registered !materials
   !/ex/new                    SheetNewR       GET POST
   /ex/#Text SheetR:
@@ -61,7 +61,7 @@
     !/sub/own                   SubmissionOwnR GET             !free
     !/sub/#CryptoFileNameSubmission SubmissionR    GET POST        !owner !corrector
 
-/corrections  CorrectionsR GET !free
+/corrections  CorrectionsR GET POST !free
 
 -- TODO below
 !/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated

src/Handler/Corrections.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Handler.Corrections where
 
@@ -19,10 +20,13 @@ import Import
 -- import System.FilePath (takeFileName)
 
 import Handler.Utils
+import Handler.Utils.Submission
 -- import Handler.Utils.Zip
 
--- import qualified Data.Set as Set
+import Data.Set (Set)
--- import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Data.Map (Map)
+import qualified Data.Map as Map
 
 -- import Data.Time
 -- import qualified Data.Text as T
@@ -42,6 +46,8 @@ import Control.Lens
 
 -- import Network.Mime
 
+import Web.PathPieces
+
 
 
 type CorrectionsWhere = forall query expr backend . (E.Esqueleto query expr backend) =>
@@ -57,21 +63,21 @@ courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid
 
 type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (E.Value Text, E.Value Text, E.Value (Key Term), E.Value (Key School)))
 
-colTerm :: Colonnade _ CorrectionTableData _
+colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
-colTerm = widgetColonnade $ sortable (Just "term") (i18nCell MsgTerm)
+colTerm = sortable (Just "term") (i18nCell MsgTerm)
         $ \DBRow{ dbrOutput=(_, _, course) } ->
           -- cell [whamlet| _{untermKey $ course ^. _3}|]   -- lange, internationale Semester
           textCell $ termToText $ unTermKey $ E.unValue $ course ^. _3 -- kurze Semsterkürzel
 
-colCourse :: Colonnade _ CorrectionTableData _
+colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
-colCourse = widgetColonnade $ sortable (Just "course") (i18nCell MsgCourse)
+colCourse = sortable (Just "course") (i18nCell MsgCourse)
         $ \DBRow{ dbrOutput=(_, _, course) } -> cell $
           let tid = E.unValue $ course ^. _3
               csh = E.unValue $ course ^. _2
           in [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]
 
-colSheet :: Colonnade _ CorrectionTableData _
+colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
-colSheet = widgetColonnade $ sortable (Just "sheet") (i18nCell MsgSheet)
+colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
         $ \DBRow{ dbrOutput=(_, sheet, course) } -> cell $
           let tid = E.unValue $ course ^. _3
               csh = E.unValue $ course ^. _2
@@ -79,13 +85,13 @@ colSheet = widgetColonnade $ sortable (Just "sheet") (i18nCell MsgSheet)
           in [whamlet|<a href=@{CSheetR tid csh shn SShowR}>#{display shn}|]
           -- textCell $ sheetName $ entityVal sheet
 
-colCorrector :: Colonnade _ CorrectionTableData _
+colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
-colCorrector = widgetColonnade $ sortable (Just "corrector") (i18nCell MsgCorrector)
+colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector)
         $ \DBRow{ dbrOutput=(submission, _, _) } ->
           textCell $ display $ submissionRatingBy $ entityVal submission
 
-colSubmissionLink :: Colonnade _ CorrectionTableData _
+colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
-colSubmissionLink = widgetColonnade $ sortable Nothing (i18nCell MsgSubmission)
+colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
         $ \DBRow{ dbrOutput=(submission, sheet, course) } -> cell $ do
           let tid = E.unValue $ course ^. _3
               csh = E.unValue $ course ^. _2
@@ -93,6 +99,11 @@ colSubmissionLink = widgetColonnade $ sortable Nothing (i18nCell MsgSubmission)
           cid <- encrypt (entityKey submission :: SubmissionId)
           [whamlet|<a href=@{CSheetR tid csh shn (SubmissionR cid)}>#{display cid}|]
 
+colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
+colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _) } -> encrypt subId
+            
+makeCorrectionsTable :: ( IsDBTable m x, DBOutput CorrectionTableData r', ToSortable h, Functor h )
+                     => _ -> Colonnade h r' (DBCell m x) -> Handler (DBResult m x)
 makeCorrectionsTable whereClause colChoices = do
   let tableData :: E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity Course))
                                             (E.SqlExpr (Entity Sheet )))
@@ -129,36 +140,74 @@ makeCorrectionsTable whereClause colChoices = do
     , dbtIdent     = "corrections" :: Text
     }
 
+data ActionCorrections = CorrDownload
+                       | CorrSetCorrector
+  deriving (Eq, Ord, Read, Show, Enum, Bounded)
+instance PathPiece ActionCorrections where
+  fromPathPiece = readFromPathPiece
+  toPathPiece = showToPathPiece
 
-getCorrectionsR :: Handler Html
+instance RenderMessage UniWorX ActionCorrections where
-getCorrectionsR = do
+  renderMessage m ls CorrDownload = renderMessage m ls MsgCorrDownload
+  renderMessage m ls CorrSetCorrector = renderMessage m ls MsgCorrSetCorrector
+
+correctionsR :: _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult (Set CryptoFileNameSubmission -> Handler TypedContent), Widget)) -> Handler TypedContent
+correctionsR whereClause (formColonnade -> displayColumns) actions = do
+  tableForm <- makeCorrectionsTable whereClause displayColumns
+  ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
+    ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
+    (actionRes, action) <- multiAction actions
+    return (actionRes <*> selectionRes, table <> action)
+  let
+    defaultAction = fmap toTypedContent . defaultLayout $ do
+      setTitleI MsgCourseCorrectionsTitle
+      $(widgetFile "corrections")
+  case actionRes of
+    FormFailure errs -> mapM_ (addMessage "danger" . toHtml) errs >> defaultAction
+    FormMissing -> defaultAction
+    FormSuccess act -> act 
+
+  
+downloadAction :: (ActionCorrections, MForm (HandlerT UniWorX IO) (FormResult (Set CryptoFileNameSubmission -> Handler TypedContent), Widget))
+downloadAction = ( CorrDownload
+                 , return (pure downloadAction', mempty)
+                 )
+  where
+    downloadAction' subs = do
+      (Set.fromList -> ids) <- forM (Set.toList subs) decrypt
+      addHeader "Content-Disposition" "attachment; filename=\"corrections.zip\""
+      submissionMultiArchive ids
+  
+
+getCorrectionsR, postCorrectionsR :: Handler TypedContent
+getCorrectionsR = postCorrectionsR
+postCorrectionsR = do
   uid <- requireAuthId
-  let whereClause    = ratedBy uid
+  let whereClause = ratedBy uid
-      displayColumns = mconcat
+      colonnade = mconcat
-        [ dbRow
+        [ colSelect
+        , dbRow
         , colTerm
         , colCourse
         , colSheet
         , colSubmissionLink
         ] -- Continue here
-  table <- makeCorrectionsTable whereClause displayColumns
+  correctionsR whereClause colonnade $ Map.fromList
-  defaultLayout $ do
+    [ downloadAction
-    setTitleI MsgCourseCorrectionsTitle
+    ]
-    $(widgetFile "corrections")
 
-getCourseCorrectionsR ::  TermId -> Text -> Handler Html
+getCourseCorrectionsR, postCourseCorrectionsR ::  TermId -> Text -> Handler TypedContent
-getCourseCorrectionsR tid csh = do
+getCourseCorrectionsR = postCourseCorrectionsR
+postCourseCorrectionsR tid csh = do
   cid <- runDB $ getBy404 $ CourseTermShort tid csh
-  let whereClause    = courseIs $ entityKey cid
+  let whereClause = courseIs $ entityKey cid
-      displayColumns = mconcat
+      colonnade = mconcat
-        [ dbRow
+        [ colSelect
+        , dbRow
         , colSheet
         , colCorrector
         , colSubmissionLink
         ] -- Continue here
-  table <- makeCorrectionsTable whereClause displayColumns
+  correctionsR whereClause colonnade $ Map.fromList
-  defaultLayout $ do
+    [ downloadAction
-    setTitleI MsgCorrectionsTitle
+    ]
-    $(widgetFile "corrections")
-
-

src/Handler/Submission.hs

@@ -279,18 +279,6 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
 
 
 
-submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
-submissionFileSource = E.selectSource . E.from . submissionFileQuery
-
-submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File)
-                        -> E.SqlQuery (E.SqlExpr (Entity File))
-submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
-  E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
-  E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
-  E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion -- TODO@gk: won't work as intended! Fix with refactor
-  E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]  -- E.desc returns corrector updated data first
-  return f
-
 getSubmissionDownloadSingleR :: CryptoFileNameSubmission -> FilePath -> Handler TypedContent
 getSubmissionDownloadSingleR cID path = do
   submissionID <- decrypt cID
@@ -422,42 +410,7 @@ postSubmissionDownloadMultiArchiveR = do
   case selectResult of
     FormMissing -> invalidArgs ["Missing submission numbers"]
     FormFailure errs -> invalidArgs errs
-    FormSuccess ids -> do
+    FormSuccess ids -> submissionMultiArchive (Set.fromList ids)
-      (dbrunner, cleanup) <- getDBRunner
-
-      ratedSubmissions <- runDBRunner dbrunner $ do
-        submissions <- selectList [ SubmissionId <-. ids ] []
-        forM submissions $ \s@(Entity submissionId _) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s)) =<< getRating submissionId
-  
-      (<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do
-        let
-          fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File
-          fileEntitySource' (rating, Entity submissionID Submission{..}) = do
-            cID <- encrypt submissionID
-
-            let
-              directoryName = CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)
-              
-              fileEntitySource = do
-                submissionFileSource submissionID =$= Conduit.map entityVal
-                yieldM (ratingFile cID rating)
-
-              withinDirectory f@File{..} = f { fileTitle = directoryName </> fileTitle }
-
-            lastEditMb <- lift $ selectList [SubmissionEditSubmission ==. submissionID] [Desc SubmissionEditTime, LimitTo 1]
-            lastEditTime <- case lastEditMb of
-                [(submissionEditTime.entityVal -> time)] -> return time
-                _other -> liftIO getCurrentTime
-            yield $ File
-              { fileModified = lastEditTime
-              , fileTitle = directoryName
-              , fileContent = Nothing
-              }
-
-            fileEntitySource =$= mapC withinDirectory
-          
-        mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder
-
 
 
 

src/Handler/Utils/Form.hs

@@ -40,8 +40,12 @@ import qualified Data.Conduit.List as C
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Internal.Sql as E
 
+import Data.Set (Set)
 import qualified Data.Set as Set
 
+import Data.Map (Map)
+import qualified Data.Map as Map
+
 import Control.Monad.Writer.Class
 
 ------------------------------------------------
@@ -513,3 +517,16 @@ mforced Field{..} FieldSettings{..} val = do
 aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
         => Field m a -> FieldSettings site -> a -> AForm m a
 aforced field settings val = formToAForm $ second pure <$> mforced field settings val
+
+multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
+            => Map action (MForm (HandlerT UniWorX IO) (FormResult a, Widget))
+            -> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
+multiAction acts = do
+  mr <- getMessageRender
+  let
+    options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
+  (actionRes, actionView) <- mreq (selectField $ return options) "" Nothing
+  results <- mapM id acts
+  let actionWidgets = Map.foldrWithKey (\(toPathPiece -> act) (_, w) -> ($(widgetFile "widgets/multiAction") :)) [] results
+      actionResults = Map.map fst results
+  return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect"))

src/Handler/Utils/Submission.hs

@@ -8,10 +8,15 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
+{-# LANGUAGE TypeOperators #-}
 
 
 module Handler.Utils.Submission
-  ( SubmissionSinkException(..)
+  ( AssignSubmissionException(..)
+  , assignSubmissions
+  , submissionFileSource, submissionFileQuery
+  , submissionMultiArchive 
+  , SubmissionSinkException(..)
   , sinkSubmission
   ) where
 
@@ -21,7 +26,7 @@ import Control.Lens
 import Control.Lens.Extras (is)
 import Utils.Lens
 
-import Control.Monad.State hiding (forM_)
+import Control.Monad.State hiding (forM_, mapM_)
 import qualified Control.Monad.Random as Rand
 
 import Data.Maybe
@@ -32,11 +37,14 @@ import qualified Data.Set as Set
 import Data.Map (Map, (!?))
 import qualified Data.Map as Map
 
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
 
 import Data.Monoid (Monoid, Any(..))
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 
 import Handler.Utils.Rating
+import Handler.Utils.Zip
 
 import qualified Database.Esqueleto as E
 
@@ -105,6 +113,57 @@ assignSubmissions sid = do
       hasTutorialLoad = isJust . byTutorial   . sheetCorrectorLoad . entityVal
 
 
+submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
+submissionFileSource = E.selectSource . E.from . submissionFileQuery
+
+submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File)
+                        -> E.SqlQuery (E.SqlExpr (Entity File))
+submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
+  E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
+  E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
+  E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion -- TODO@gk: won't work as intended! Fix with refactor
+  E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]  -- E.desc returns corrector updated data first
+  return f
+
+submissionMultiArchive :: Set SubmissionId -> Handler TypedContent
+submissionMultiArchive (Set.toList -> ids) = do
+  (dbrunner, cleanup) <- getDBRunner
+
+  ratedSubmissions <- runDBRunner dbrunner $ do
+    submissions <- selectList [ SubmissionId <-. ids ] []
+    forM submissions $ \s@(Entity submissionId _) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s)) =<< getRating submissionId
+  
+  (<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do
+    let
+      fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File
+      fileEntitySource' (rating, Entity submissionID Submission{..}) = do
+        cID <- encrypt submissionID
+
+        let
+          directoryName = CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)
+              
+          fileEntitySource = do
+            submissionFileSource submissionID =$= Conduit.map entityVal
+            yieldM (ratingFile cID rating)
+
+          withinDirectory f@File{..} = f { fileTitle = directoryName </> fileTitle }
+
+        lastEditMb <- lift $ selectList [SubmissionEditSubmission ==. submissionID] [Desc SubmissionEditTime, LimitTo 1]
+        lastEditTime <- case lastEditMb of
+          [(submissionEditTime.entityVal -> time)] -> return time
+          _other -> liftIO getCurrentTime
+        yield $ File
+          { fileModified = lastEditTime
+          , fileTitle = directoryName
+          , fileContent = Nothing
+          }
+
+        fileEntitySource =$= mapC withinDirectory
+          
+    mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder
+
+
+
 
 
 data SubmissionSinkState = SubmissionSinkState

src/Handler/Utils/Table/Pagination.hs

@@ -19,15 +19,16 @@
 module Handler.Utils.Table.Pagination
   ( SortColumn(..), SortDirection(..)
   , FilterColumn(..), IsFilterColumn
-  , DBRow(..), dbRow, DBOutput
+  , DBRow(..), DBOutput
   , DBTable(..), IsDBTable(..)
   , PaginationSettings(..)
   , PSValidator(..)
-  , Sortable(..), sortable
+  , ToSortable(..), Sortable(..), sortable
   , dbTable
   , widgetColonnade, formColonnade
   , textCell, stringCell, i18nCell, anchorCell
   , formCell, DBFormResult, getDBFormResult
+  , dbRow, dbSelect
   ) where
 
 import Handler.Utils.Table.Pagination.Types
@@ -110,12 +111,9 @@ instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, Mon
 
 
 data DBRow r = DBRow
-  { dbrIndex, dbrCount :: Int64
+  { dbrOutput :: r
-  , dbrOutput :: r
+  , dbrIndex, dbrCount :: Int64
-  }
+  } deriving (Show, Read, Eq, Ord)
-
-dbRow :: (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
-dbRow = Colonnade.singleton (headednessPure $ textCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
 
 class DBOutput r r' where
   dbProj :: r -> r'
@@ -172,7 +170,7 @@ instance Default (PSValidator m x) where
 
 class (MonadHandler m, Monoid x) => IsDBTable (m :: * -> *) (x :: *) where
   type DBResult m x :: *
-  type DBResult' m x :: *
+  -- type DBResult' m x :: *
 
   data DBCell m x :: *
   cellAttrs :: Lens' (DBCell m x) [(Text, Text)]
@@ -181,12 +179,13 @@ class (MonadHandler m, Monoid x) => IsDBTable (m :: * -> *) (x :: *) where
   cell :: Widget -> DBCell m x
 
     
-  dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
+  -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
-  runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (Widget, x) -> m' (DBResult m x)
+  dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Proxy m -> Proxy x -> DBResult m x -> m' Widget
+  runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> m' (DBResult m x)
 
 instance IsDBTable (WidgetT UniWorX IO) () where
   type DBResult (WidgetT UniWorX IO) () = Widget
-  type DBResult' (WidgetT UniWorX IO) () = ()
+  -- type DBResult' (WidgetT UniWorX IO) () = ()
 
   data DBCell (WidgetT UniWorX IO) () = WidgetCell
     { dbCellAttrs :: [(Text, Text)]
@@ -197,12 +196,14 @@ instance IsDBTable (WidgetT UniWorX IO) () where
 
   cell = WidgetCell []
   
-  dbWidget Proxy Proxy = iso (, ()) $ view _1
+  -- dbWidget Proxy Proxy = iso (, ()) $ view _1
-  runDBTable = return . join . fmap (view _1)
+  dbWidget Proxy Proxy = return
+  runDBTable = return . join . fmap (view _2)
 
 instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) where
-  type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = ((FormResult a, Widget), Enctype)
+  -- type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = ((FormResult a, Widget), Enctype)
-  type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype)
+  type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = Form a
+  -- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype)
 
   data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = FormCell
     { formCellAttrs :: [(Text, Text)]
@@ -213,10 +214,13 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
 
   cell widget = FormCell [] $ return (mempty, widget)
   
-  dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
+  -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
-                             ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
+  --                            ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
-  -- runDBTable :: MForm (HandlerT UniWorX IO) (Widget, FormResult a) -> m ((FormResult a, Widget), Enctype)
+  dbWidget Proxy Proxy = liftHandlerT . fmap (view $ _1 . _2) . runFormPost
-  runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) . swap <$> form
+  -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
+  -- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
+  -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
+  runDBTable form = return $ \html -> over _2 (<> toWidget html) <$> form
 
 instance IsDBTable m a => IsString (DBCell m a) where
   fromString = cell . fromString
@@ -277,7 +281,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
     rowCount
       | ((_, E.Value n), _):_ <- rows' = n
       | otherwise = 0
-    rows = map (\((E.Value i, E.Value n), r) -> DBRow i n r) rows'
+    rows = map (\((E.Value dbrIndex, E.Value dbrCount), dbrOutput) -> DBRow{..}) rows'
 
     table' :: WriterT x m Widget
     table' = do
@@ -311,10 +315,10 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
 
       return $(widgetFile "table/layout")
 
-    dbWidget' :: Iso' (DBResult m x) (Widget, DBResult' m x)
+    dbWidget' :: DBResult m x -> Handler Widget
     dbWidget' = dbWidget (Proxy :: Proxy m) (Proxy :: Proxy x)
 
-  bool return (sendResponse <=< tblLayout . view (dbWidget' . _1)) psShortcircuit <=< runDBTable $ runWriterT table'
+  bool return (sendResponse <=< tblLayout <=< dbWidget') psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
   where
     tblLayout :: Widget -> Handler Html
     tblLayout tbl' = do
@@ -356,18 +360,30 @@ instance Ord i => Monoid (DBFormResult r i a) where
   mempty = DBFormResult Map.empty
   (DBFormResult m1) `mappend` (DBFormResult m2) = DBFormResult $ Map.unionWith (\(r, f1) (_, f2) -> (r, f2 . f1)) m1 m2
 
-getDBFormResult :: Ord i => (r -> a) -> DBFormResult r i a -> Map i a
+getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult r i a -> Map i a
 getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
 
-formCell :: Ord i
+formCell :: forall r i a. Ord i
          => (r -> MForm (HandlerT UniWorX IO) i)
-         -> (r -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget))
+         -> (r -> i -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget))
          -> (r -> DBCell ((RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO))) (FormResult (DBFormResult r i a)))
 formCell genIndex genForm input = FormCell
   { formCellAttrs    = []
   , formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
       i <- genIndex input
-      (edit, w) <- genForm input
+      (edit, w) <- genForm input i
       return (DBFormResult . Map.singleton i . (input,) <$> edit, w)
   }
 
+-- Predefined colonnades
+
+dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
+dbRow = Colonnade.singleton (headednessPure $ textCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
+
+dbSelect :: forall h r i a. (Headedness h, Ord i, PathPiece i)
+         => Setter' a Bool
+         -> (r -> MForm (HandlerT UniWorX IO) i)
+         -> Colonnade h r (DBCell ((RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO))) (FormResult (DBFormResult r i a)))
+dbSelect resLens genIndex = Colonnade.singleton (headednessPure $ textCell MsgSelectColumn) $ \r -> flip (formCell genIndex) r $ \_ i -> do
+  (selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False)
+  return (set resLens <$> selResult, [whamlet|^{fvInput selWidget}|])

src/Utils.hs

@@ -42,6 +42,10 @@ getMsgRenderer = do
   mr <- getMessageRender
   return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text)
 
+instance Monad FormResult where
+  FormMissing        >>= _ = FormMissing
+  (FormFailure errs) >>= _ = FormFailure errs
+  (FormSuccess a)    >>= f = f a
 
 ---------------------
 -- Text and String --

templates/corrections.hamlet

@@ -1,2 +1,5 @@
 <div .container>
-  ^{table}
+  <form method=POST enctype=#{tableEncoding}>
+    ^{table}
+    <button type=submit>
+      Do stuff

templates/widgets/multiAction.hamlet

@@ -0,0 +1,2 @@
+<div data-conditional="#{fvId actionView}-#{act}">
+  ^{w}

templates/widgets/multiActionCollect.hamlet

@@ -0,0 +1,4 @@
+^{fvInput actionView}
+
+$forall w <- actionWidgets
+  ^{w}