Correction download
This commit is contained in:
Gregor Kleen
parent
3c8f13b4dc
commit
7aaaa1691c
@ -93,4 +93,8 @@ SheetMarking: Korrekturhinweise
|
||||
|
||||
MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen)
|
||||
|
||||
NrColumn: Nr
|
||||
NrColumn: Nr
|
||||
SelectColumn: Auswahl
|
||||
|
||||
CorrDownload: Herunterladen
|
||||
CorrSetCorrector: Korrektor zuweisen
|
||||
4
routes
4
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
|
||||
|
||||
@ -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|<a href=@{CourseR tid csh CShowR}>#{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|<a href=@{CSheetR tid csh shn SShowR}>#{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|<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
|
||||
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
|
||||
]
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
|
||||
|
||||
@ -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"))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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}|])
|
||||
|
||||
@ -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 --
|
||||
|
||||
@ -1,2 +1,5 @@
|
||||
<div .container>
|
||||
^{table}
|
||||
<form method=POST enctype=#{tableEncoding}>
|
||||
^{table}
|
||||
<button type=submit>
|
||||
Do stuff
|
||||
|
||||
2
templates/widgets/multiAction.hamlet
Normal file
2
templates/widgets/multiAction.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
<div data-conditional="#{fvId actionView}-#{act}">
|
||||
^{w}
|
||||
4
templates/widgets/multiActionCollect.hamlet
Normal file
4
templates/widgets/multiActionCollect.hamlet
Normal file
@ -0,0 +1,4 @@
|
||||
^{fvInput actionView}
|
||||
|
||||
$forall w <- actionWidgets
|
||||
^{w}
|
||||
Loading…
Reference in New Issue
Block a user