diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 40b2eff15..7379ae4c0 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -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) diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 534cb49f2..8d70902bb 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -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 diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index a337f59d3..0bed9cd36 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -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 diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 1b6f19ba2..26acd65dc 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -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 ] diff --git a/templates/table/layout-standalone.hamlet b/templates/table/layout-standalone.hamlet new file mode 100644 index 000000000..34b53ce1f --- /dev/null +++ b/templates/table/layout-standalone.hamlet @@ -0,0 +1 @@ +^{pageBody tbl} diff --git a/templates/table/layout-wrapper.hamlet b/templates/table/layout-wrapper.hamlet index 34b53ce1f..bfa000765 100644 --- a/templates/table/layout-wrapper.hamlet +++ b/templates/table/layout-wrapper.hamlet @@ -1 +1,3 @@ -^{pageBody tbl} +$newline never +