diff --git a/messages/de.msg b/messages/de.msg index 561b1a5da..6dd0a5196 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -93,4 +93,8 @@ SheetMarking: Korrekturhinweise MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen) -NrColumn: Nr \ No newline at end of file +NrColumn: Nr +SelectColumn: Auswahl + +CorrDownload: Herunterladen +CorrSetCorrector: Korrektor zuweisen \ No newline at end of file diff --git a/routes b/routes index 3cfd1e43d..016e15340 100644 --- a/routes +++ b/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 diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index ecee27274..2eb34aad1 100644 --- a/src/Handler/Corrections.hs +++ b/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 qualified Data.Map as Map +import Data.Set (Set) +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 = widgetColonnade $ sortable (Just "term") (i18nCell MsgTerm) +colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +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 = widgetColonnade $ sortable (Just "course") (i18nCell MsgCourse) +colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colCourse = sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(_, _, course) } -> cell $ let tid = E.unValue $ course ^. _3 csh = E.unValue $ course ^. _2 in [whamlet|#{display csh}|] -colSheet :: Colonnade _ CorrectionTableData _ -colSheet = widgetColonnade $ sortable (Just "sheet") (i18nCell MsgSheet) +colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +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|#{display shn}|] -- textCell $ sheetName $ entityVal sheet -colCorrector :: Colonnade _ CorrectionTableData _ -colCorrector = widgetColonnade $ sortable (Just "corrector") (i18nCell MsgCorrector) +colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \DBRow{ dbrOutput=(submission, _, _) } -> textCell $ display $ submissionRatingBy $ entityVal submission -colSubmissionLink :: Colonnade _ CorrectionTableData _ -colSubmissionLink = widgetColonnade $ sortable Nothing (i18nCell MsgSubmission) +colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +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|#{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 -getCorrectionsR = do +instance RenderMessage UniWorX ActionCorrections where + 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 - displayColumns = mconcat - [ dbRow + let whereClause = ratedBy uid + colonnade = mconcat + [ colSelect + , dbRow , colTerm , colCourse , colSheet , colSubmissionLink ] -- Continue here - table <- makeCorrectionsTable whereClause displayColumns - defaultLayout $ do - setTitleI MsgCourseCorrectionsTitle - $(widgetFile "corrections") + correctionsR whereClause colonnade $ Map.fromList + [ downloadAction + ] -getCourseCorrectionsR :: TermId -> Text -> Handler Html -getCourseCorrectionsR tid csh = do +getCourseCorrectionsR, postCourseCorrectionsR :: TermId -> Text -> Handler TypedContent +getCourseCorrectionsR = postCourseCorrectionsR +postCourseCorrectionsR tid csh = do cid <- runDB $ getBy404 $ CourseTermShort tid csh - let whereClause = courseIs $ entityKey cid - displayColumns = mconcat - [ dbRow + let whereClause = courseIs $ entityKey cid + colonnade = mconcat + [ colSelect + , dbRow , colSheet , colCorrector , colSubmissionLink ] -- Continue here - table <- makeCorrectionsTable whereClause displayColumns - defaultLayout $ do - setTitleI MsgCorrectionsTitle - $(widgetFile "corrections") - - + correctionsR whereClause colonnade $ Map.fromList + [ downloadAction + ] diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index f48f79b59..d0f89786b 100644 --- a/src/Handler/Submission.hs +++ b/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 - (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 - + FormSuccess ids -> submissionMultiArchive (Set.fromList ids) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 63d5c4bd2..9e70fbfc5 100644 --- a/src/Handler/Utils/Form.hs +++ b/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")) diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 7cfc97f4e..27f88daf7 100644 --- a/src/Handler/Utils/Submission.hs +++ b/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 diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 4203f4029..6e7444051 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/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 - } - -dbRow :: (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a) -dbRow = Colonnade.singleton (headednessPure $ textCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex + { dbrOutput :: r + , dbrIndex, dbrCount :: Int64 + } deriving (Show, Read, Eq, Ord) 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) - runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (Widget, x) -> m' (DBResult m x) + -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, 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 - runDBTable = return . join . fmap (view _1) + -- dbWidget Proxy Proxy = iso (, ()) $ 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, 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) = 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)) - ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2)) - -- runDBTable :: MForm (HandlerT UniWorX IO) (Widget, FormResult a) -> m ((FormResult a, Widget), Enctype) - runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) . swap <$> form + -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2)) + -- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2)) + dbWidget Proxy Proxy = liftHandlerT . fmap (view $ _1 . _2) . runFormPost + -- 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}|]) diff --git a/src/Utils.hs b/src/Utils.hs index 4c3a4a0e6..263966369 100644 --- a/src/Utils.hs +++ b/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 -- diff --git a/templates/corrections.hamlet b/templates/corrections.hamlet index 2d2943787..6739d0a9e 100644 --- a/templates/corrections.hamlet +++ b/templates/corrections.hamlet @@ -1,2 +1,5 @@
- ^{table} +
+ ^{table} +