Merge branch 'feat/corrections-upload' into 'live'

Minor fixes

See merge request !58

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)

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

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' }
+      case msId of
-  fmap Map.keysSet . lift $ mapM (void . closeResumableSink) sinks
+        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

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 ]

templates/table/layout-standalone.hamlet

@@ -0,0 +1 @@
+^{pageBody tbl}

templates/table/layout-wrapper.hamlet

@@ -1 +1,3 @@
-^{pageBody tbl}
+$newline never
+<div ##{wIdent "table-wrapper"}>
+  ^{table}

templates/table/layout.hamlet

@@ -2,12 +2,11 @@ $newline never
 $if null wRows && (dbsEmptyStyle == DBESNoHeading)
   _{dbsEmptyMessage}
 $else
-  <div ##{wIdent "table-wrapper"}>
+  <div .scrolltable>
-    <div .scrolltable>
+    ^{table}
-      ^{table}
+  $if pageCount > 1
-    $if pageCount > 1
+    <ul ##{wIdent "pagination"} .pagination>
-      <ul ##{wIdent "pagination"} .pagination>
+      $forall p <- pageNumbers
-        $forall p <- pageNumbers
+        <li .pagination-link :p == psPage:.current>
-          <li .pagination-link :p == psPage:.current>
+          <a href=#{tblLink $ setParam (wIdent "page") (Just $ tshow p)}>
-            <a href=#{tblLink $ setParam (wIdent "page") (Just $ tshow p)}>
+            _{MsgPage (succ p)}
-              _{MsgPage (succ p)}