Merge branch 'feat/corrections-upload' into 'live'
Minor fixes See merge request !58
This commit is contained in:
Gregor Kleen
commit
69f7ee806c
@ -195,7 +195,7 @@ data ActionCorrectionsData = CorrDownloadData
|
||||
correctionsR :: _ -> _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget)) -> Handler TypedContent
|
||||
correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
|
||||
tableForm <- makeCorrectionsTable whereClause displayColumns psValidator
|
||||
((actionRes, table), tableEncoding) <- runFormPost . identForm FIDcorrectorTable $ \csrf -> do
|
||||
((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)
|
||||
|
||||
@ -88,6 +88,7 @@ data SheetForm = SheetForm
|
||||
|
||||
makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
|
||||
makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
||||
-- TODO: SJ to refactor this; extract Code from getSEditR to joint code piece
|
||||
let oldFileIds fType
|
||||
| Just sId <- msId = fmap setFromList . fmap (map E.unValue) . runDB . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
|
||||
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
|
||||
|
||||
@ -186,7 +186,7 @@ instance Monoid SubmissionSinkState where
|
||||
data SubmissionSinkException = DuplicateFileTitle FilePath
|
||||
| DuplicateRating
|
||||
| RatingWithoutUpdate
|
||||
| ForeignRating
|
||||
| ForeignRating CryptoFileNameSubmission
|
||||
deriving (Typeable, Show)
|
||||
|
||||
instance Exception SubmissionSinkException
|
||||
@ -277,7 +277,9 @@ sinkSubmission userId mExists isUpdate = do
|
||||
Right (submissionId', Rating'{..}) -> do
|
||||
$logDebugS "sinkSubmission" $ tshow submissionId'
|
||||
|
||||
unless (submissionId' == submissionId) $ throwM ForeignRating
|
||||
unless (submissionId' == submissionId) $ do
|
||||
cID <- encrypt submissionId'
|
||||
throwM $ ForeignRating cID
|
||||
|
||||
alreadySeen <- gets $ getAny . sinkSeenRating
|
||||
when alreadySeen $ throwM DuplicateRating
|
||||
@ -373,6 +375,16 @@ sinkSubmission userId mExists isUpdate = do
|
||||
, SubmissionRatingComment =. Nothing
|
||||
]
|
||||
|
||||
data SubmissionMultiSinkException
|
||||
= SubmissionSinkException
|
||||
{ submissionSinkId :: CryptoFileNameSubmission
|
||||
, submissionSinkFedFile :: Maybe FilePath
|
||||
, submissionSinkException :: SubmissionSinkException
|
||||
}
|
||||
deriving (Typeable, Show)
|
||||
|
||||
instance Exception SubmissionMultiSinkException
|
||||
|
||||
sinkMultiSubmission :: UserId
|
||||
-> Bool {-^ Are these corrections -}
|
||||
-> Sink SubmissionContent (YesodDB UniWorX) (Set SubmissionId)
|
||||
@ -411,7 +423,10 @@ sinkMultiSubmission userId isUpdate = do
|
||||
Left _ -> error "sinkSubmission returned prematurely"
|
||||
Right nSink -> modify $ Map.insert sId nSink
|
||||
sinks <- execStateLC Map.empty . awaitForever $ \case
|
||||
v@(Right (sId, _)) -> lift $ feed sId v
|
||||
v@(Right (sId, _)) -> do
|
||||
cID <- encrypt sId
|
||||
handle (throwM . SubmissionSinkException cID Nothing) $
|
||||
lift $ feed sId v
|
||||
(Left f@File{..}) -> do
|
||||
let
|
||||
tryDecrypt :: FilePath -> _ (Either SomeException SubmissionId)
|
||||
@ -422,8 +437,15 @@ sinkMultiSubmission userId isUpdate = do
|
||||
return . either (const id) (set _1 . Just) msId $ (Nothing, fp)
|
||||
(msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle
|
||||
$logDebugS "sinkMultiSubmission" $ tshow (splitDirectories fileTitle, msId, fileTitle')
|
||||
lift . maybe (const $ return ()) feed msId $ Left f{ fileTitle = fileTitle' }
|
||||
fmap Map.keysSet . lift $ mapM (void . closeResumableSink) sinks
|
||||
case msId of
|
||||
Nothing -> $logDebugS "sinkMultiSubmission" "Dropped"
|
||||
Just sId -> do
|
||||
cID <- encrypt sId
|
||||
handle (throwM . SubmissionSinkException cID (Just fileTitle)) $
|
||||
lift . feed sId $ Left f{ fileTitle = fileTitle' }
|
||||
fmap Map.keysSet . lift . sequence $ flip Map.mapWithKey sinks $ \sId sink -> do
|
||||
cID <- encrypt sId
|
||||
handle (throwM . SubmissionSinkException cID Nothing) . void $ closeResumableSink sink
|
||||
|
||||
submissionMatchesSheet :: TermId -> Text -> Text -> CryptoFileNameSubmission -> DB ()
|
||||
submissionMatchesSheet tid csh shn cid = do
|
||||
|
||||
@ -204,7 +204,7 @@ instance Default (PSValidator m x) where
|
||||
l <- asks piLimit
|
||||
case l of
|
||||
Just l'
|
||||
| l' >= 0 -> tell . pure $ SomeMessage MsgPSLimitNonPositive
|
||||
| l' <= 0 -> tell . pure $ SomeMessage MsgPSLimitNonPositive
|
||||
| otherwise -> modify $ \ps -> ps { psLimit = l' }
|
||||
Nothing -> return ()
|
||||
|
||||
@ -242,10 +242,10 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *)
|
||||
cellContents :: DBCell m x -> WriterT x m Widget
|
||||
|
||||
cell :: Widget -> DBCell 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
|
||||
dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> DBResult m x -> m' Widget
|
||||
dbHandler :: forall m'. (MonadHandler m' , HandlerSite m' ~ UniWorX) => DBTable m x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
|
||||
runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)
|
||||
|
||||
instance IsDBTable (WidgetT UniWorX IO) () where
|
||||
@ -262,7 +262,8 @@ instance IsDBTable (WidgetT UniWorX IO) () where
|
||||
cell = WidgetCell []
|
||||
|
||||
-- dbWidget Proxy Proxy = iso (, ()) $ view _1
|
||||
dbWidget Proxy Proxy = return
|
||||
dbWidget _ = return
|
||||
dbHandler _ f x = return $ f x
|
||||
runDBTable = return . join . fmap (view _2)
|
||||
|
||||
instance Monoid (DBCell (WidgetT UniWorX IO) ()) where
|
||||
@ -282,7 +283,8 @@ instance IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) () where
|
||||
|
||||
cell = DBCell [] . return
|
||||
|
||||
dbWidget Proxy Proxy = return
|
||||
dbWidget _ = return
|
||||
dbHandler _ f x = return $ f x
|
||||
-- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
|
||||
runDBTable = fmap snd . mapReaderT liftHandlerT
|
||||
|
||||
@ -306,7 +308,8 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
|
||||
|
||||
-- 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
|
||||
dbWidget DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . identifyForm dbtIdent
|
||||
dbHandler DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } f form = return $ \csrf -> over _2 f <$> identifyForm dbtIdent form csrf
|
||||
-- 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))
|
||||
@ -413,16 +416,13 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
|
||||
pageNumbers = [0..pred pageCount]
|
||||
|
||||
return $(widgetFile "table/layout")
|
||||
|
||||
dbWidget' :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBResult m x -> m' Widget
|
||||
dbWidget' = dbWidget (Proxy :: Proxy m) (Proxy :: Proxy x)
|
||||
|
||||
bool return (sendResponse <=< tblLayout <=< dbWidget') psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
|
||||
bool (dbHandler dbtable $ \table -> $(widgetFile "table/layout-wrapper")) (sendResponse <=< tblLayout <=< dbWidget dbtable) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
|
||||
where
|
||||
tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
|
||||
tblLayout tbl' = do
|
||||
tbl <- liftHandlerT $ widgetToPageContent tbl'
|
||||
withUrlRenderer $(hamletFile "templates/table/layout-wrapper.hamlet")
|
||||
withUrlRenderer $(hamletFile "templates/table/layout-standalone.hamlet")
|
||||
|
||||
setParam :: Text -> Maybe Text -> QueryText -> QueryText
|
||||
setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]
|
||||
|
||||
1
templates/table/layout-standalone.hamlet
Normal file
1
templates/table/layout-standalone.hamlet
Normal file
@ -0,0 +1 @@
|
||||
^{pageBody tbl}
|
||||
@ -1 +1,3 @@
|
||||
^{pageBody tbl}
|
||||
$newline never
|
||||
<div ##{wIdent "table-wrapper"}>
|
||||
^{table}
|
||||
|
||||
@ -2,12 +2,11 @@ $newline never
|
||||
$if null wRows && (dbsEmptyStyle == DBESNoHeading)
|
||||
_{dbsEmptyMessage}
|
||||
$else
|
||||
<div ##{wIdent "table-wrapper"}>
|
||||
<div .scrolltable>
|
||||
^{table}
|
||||
$if pageCount > 1
|
||||
<ul ##{wIdent "pagination"} .pagination>
|
||||
$forall p <- pageNumbers
|
||||
<li .pagination-link :p == psPage:.current>
|
||||
<a href=#{tblLink $ setParam (wIdent "page") (Just $ tshow p)}>
|
||||
_{MsgPage (succ p)}
|
||||
<div .scrolltable>
|
||||
^{table}
|
||||
$if pageCount > 1
|
||||
<ul ##{wIdent "pagination"} .pagination>
|
||||
$forall p <- pageNumbers
|
||||
<li .pagination-link :p == psPage:.current>
|
||||
<a href=#{tblLink $ setParam (wIdent "page") (Just $ tshow p)}>
|
||||
_{MsgPage (succ p)}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user