1 files changed, 86 insertions, 35 deletions

diff --git a/webgui/src/Main.hs b/webgui/src/Main.hs
index 018e59b..a295fd9 100644
--- a/webgui/src/Main.hs
+++ b/webgui/src/Main.hs
@@ -21,6 +21,7 @@ import           System.Environment
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as CBS
+import qualified Data.ByteString.Lazy.Char8 as CLBS
 
 import           Data.Text (Text)
 import qualified Data.Text as T
@@ -102,6 +103,13 @@ config = do
     hostEnv = "ADDR"
     portEnv = "PORT"
 
+fatal :: String -> UI a
+fatal str = do
+  window <- askWindow
+  (getBody window #) . set children =<< sequence [UI.p # set TP.text str # set UI.class_ "fatal"]
+  liftIO (throwIO $ ErrorCall str)
+  return undefined
+
 setup :: Config -> Window -> Event (Either WebSocketException URI) -> UI ()
 setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
   onEvent socketErr handleSocketErr
@@ -130,11 +138,6 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
       errors #+ [UI.li # set TP.text str]
       errorsTab # set style [("display", "inline-block")]
       runFunction $ switchTab "errors"
-    fatal :: String -> UI a
-    fatal str = do
-      (getBody window #) . set children =<< sequence [UI.p # set TP.text str # set UI.class_ "fatal"]
-      liftIO (throwIO $ ErrorCall str)
-      return undefined
 
     maybeM = maybe $ return ()
 
@@ -147,7 +150,9 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
       status <- stepper init statusEvent
       return (status, triggerStatusChange)
 
-    Client{..} = mkClient (Nat $ either (fatal . ("Error while communicating to Thermoprint.Server: " ++) . show) return <=< liftIO . runEitherT) server
+    Client{..} = mkClient (hoistNat $ Nat liftIO) server
+    withFatal :: EitherT ServantError UI a -> UI a
+    withFatal a = either (fatal . ("Error while communicating to Thermoprint.Server: " ++) . show) return =<< runEitherT a
 
     handleEditor selectedPrinter (_, modifyFocusedJobs) = do
       title <- fatal' "Could not find editor title field" =<< getElementById window "editorTitle"
@@ -189,8 +194,8 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
               return False
             Right p -> do
               draftId <- case associatedDraft of
-                Nothing -> draftCreate (T.pack <$> eTitle) p
-                Just i -> i <$ when (different s) (draftReplace i (T.pack <$> eTitle) p)
+                Nothing -> withFatal $ draftCreate (T.pack <$> eTitle) p
+                Just i -> i <$ when (different s) (withFatal $ draftReplace i (T.pack <$> eTitle) p)
               time <- liftIO getCurrentTime
               modifyStatus (\x -> x { associatedDraft = Just draftId, lastSaved = Just (time, s) })
               return True
@@ -217,9 +222,9 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
             Right po -> case associatedDraft of
               Just dId -> do
                 saved <- saveAction False
-                when saved $ reFocusJob =<< draftPrint dId =<< currentValue selectedPrinter
+                when saved $ reFocusJob =<< withFatal . draftPrint dId =<< currentValue selectedPrinter
               Nothing -> do
-                reFocusJob =<< flip jobCreate po =<< currentValue selectedPrinter
+                reFocusJob =<< withFatal . flip jobCreate po =<< currentValue selectedPrinter
             Left err -> emitError $ "Could not print draft due to error parsing bbcode: " ++ show err
 
       onEvent (whenE saveDraft $ tick autoSaveTimer) (const . void $ saveAction True)
@@ -243,28 +248,52 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
     discardable EditorState{..} = not (maybe True null eTitle && null eText)
 
     handleDraftTable changeEditorState = do
-      allowDeletion <- fatal' "Could not find deletion switch" =<< getElementById window "allowDeletion"
-      deletion' <- allowDeletion # get UI.checked
+      -- allowDeletion <- fatal' "Could not find deletion switch" =<< getElementById window "allowDeletion"
+      -- deletion' <- allowDeletion # get UI.checked
+
+      -- deletion <- stepper deletion' $ UI.checkedChange allowDeletion
+      (marking, (liftIO .) -> updateMarking) <- stepper' $ Set.empty
 
-      deletion <- stepper deletion' $ UI.checkedChange allowDeletion
+      
+      enactDeletion <- fatal' "Could not find deletion button" =<< getElementById window "enactDeletion"
+      on UI.click enactDeletion . const $ currentValue marking >>= mapM_ (runEitherT . draftDelete) >> updateMarking Set.empty
+      -- deletion' <- allowDeletion # get UI.checked
       let
+        updateMarking' = callFunction (mangle <$> ffi getChecked) >>= updateMarking
+          where mangle = Set.fromList . map DraftId . fromMaybe [] . parse
+                getChecked = "$.makeArray($('input[name=draftMark]:checked').map(function() {return $(this).val()}))"
+                parse str
+                  | [(i, rs)] <- [ (i, rs) | (i, ',' : rs) <- reads str ] = (:) <$> Just i <*> parse rs
+                  | r@([_]) <- [ i | (i, "") <- reads str ] = Just r
+                  | otherwise = Nothing
+
         toTable :: Map DraftId (Maybe DraftTitle) -> UI [Element]
         toTable = mapM toLine . Map.toList
   
         toLine (id@(DraftId (show -> tId)), fromMaybe "" . fmap T.unpack -> title) = do
           id' <- UI.td # set TP.text tId
           title' <- UI.td # set TP.text title
-          delete <- UI.button
-            # set TP.text "Delete"
-            # sink UI.enabled deletion
-          on UI.click delete . const $ draftDelete id >> changeEditorState (\s@(EditorState{..}) -> if associatedDraft == Just id then def else s)
+          mark <- UI.input
+            # set UI.type_ "checkbox"
+            # set UI.name "draftMark"
+            # set UI.id_ ("draftMark" ++ tId)
+            # set UI.value tId
+            # sink UI.checked (Set.member id <$> marking)
+          on UI.checkedChange mark . const $ updateMarking'
+          mark' <- UI.span #+ [ return mark
+                              , UI.label # set UI.for ("draftMark" ++ tId) # set UI.text "Mark"
+                              ] # set UI.class_ "mark"
+          -- delete <- UI.button
+          --   # set TP.text "Delete"
+          --   # sink UI.enabled deletion
+          -- on UI.click delete . const $ draftDelete id >> changeEditorState (\s@(EditorState{..}) -> if associatedDraft == Just id then def else s)
           load <- UI.button
             # set TP.text "Load"
           on UI.click load . const $ loadDraft id
-          actions <- UI.td # set children [load, delete]
+          actions <- UI.td # set children [mark', load]
           UI.tr # set children [id', title', actions]
         loadDraft id = do
-          (title, po) <- draft id
+          (title, po) <- withFatal $ draft id
           let
             t = cobbcode po
           case t of
@@ -281,7 +310,7 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
               changeEditorState (const newState)
               runFunction $ switchTab "editor"
       table <- fatal' "Could not find draft table" =<< getElementById window "draftListBody"
-      initialContent <- toTable =<< drafts
+      initialContent <- toTable =<< withFatal drafts
       return table # set children initialContent
 
       update <- do
@@ -292,7 +321,7 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
         -- return $ unionWith const (() <$ filterE concernsDrafts dataUpdate) (tick recheckTimer)
         return $ filterE concernsDrafts dataUpdate
   
-      onEvent update . const $ drafts >>= toTable >>= (\c -> return table # set children c)
+      onEvent update . const $ withFatal drafts >>= toTable >>= (\c -> return table # set children c)
       
     concernsDrafts :: URI -> Bool
     concernsDrafts (uriPath -> p)
@@ -307,10 +336,14 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
       | otherwise = False
 
     handleJobTable (focusedJobs, _) = do
-      allowAbortion <- do
-        allowAbortion <- fatal' "Could not find abortion switch" =<< getElementById window "allowAbortion"
-        flip stepper (UI.checkedChange allowAbortion) =<< (allowAbortion # get UI.checked)
-
+      -- allowAbortion <- do
+      --   allowAbortion <- fatal' "Could not find abortion switch" =<< getElementById window "allowAbortion"
+      --   flip stepper (UI.checkedChange allowAbortion) =<< (allowAbortion # get UI.checked)
+      (marking, (liftIO .) -> updateMarking) <- stepper' $ Set.empty
+      
+      enactAbortion <- fatal' "Could not find deletion button" =<< getElementById window "enactAbortion"
+      on UI.click enactAbortion . const $ currentValue marking >>= mapM_ (runEitherT . jobDelete) >> updateMarking Set.empty
+        
       (selectedPrinter, updatePrinter) <- do
         autoselectPrinter <- fatal' "Could not find printer autoselect switch" =<< getElementById window "autoselectPrinter"
         (selectedPrinter, printerSelect) <- stepper' Nothing
@@ -323,14 +356,22 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
         return (selectedPrinter, updatePrinterSelect)
 
       let
+        updateMarking' = callFunction (mangle <$> ffi getChecked) >>= updateMarking
+          where mangle = Set.fromList . map JobId . fromMaybe [] . parse
+                getChecked = "$.makeArray($('input[name=jobMark]:checked').map(function() {return $(this).val()}))"
+                parse str
+                  | [(i, rs)] <- [ (i, rs) | (i, ',' : rs) <- reads str ] = (:) <$> Just i <*> parse rs
+                  | r@([_]) <- [ i | (i, "") <- reads str ] = Just r
+                  | otherwise = Nothing
+
         -- getServerState :: UI [(PrinterId, PrinterStatus, [(JobId, UTCTime, JobStatus)])]
-        getServerState = map mangleTuple . Map.toList <$> (Map.traverseWithKey (\pId status -> (,) status <$> getJobState pId) =<< printers)
+        getServerState = map mangleTuple . Map.toList <$> (Map.traverseWithKey (\pId status -> (,) status <$> getJobState pId) =<< withFatal printers)
         -- getJobState :: PrinterId -> UI [(JobId, UTCTime, JobStatus)]
-        getJobState pId = toList <$> jobs (Just pId) Nothing Nothing
+        getJobState pId = toList <$> withFatal (jobs (Just pId) Nothing Nothing)
         mangleTuple (a, (b, c)) = (a, b, c)
 
         -- jobSort :: (JobId, UTCTime, JobStatus) -> (JobId, UTCTime, JobStatus) -> Ordering
-        jobSort (id, time, status) (id', time', status') = queueSort status status' <> compare time' time <> compare id' id
+        jobSort (id, time, status) (id', time', status') = queueSort status status' <> compare time' time <> compare id id'
           where
             compare' :: Ord a => a -> a -> Ordering
             compare'
@@ -356,15 +397,25 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
               jId' <- UI.td # set UI.text (show jId)
               jStatus' <- UI.td # set UI.text (show status)
               time' <- UI.td # set UI.text (formatTime defaultTimeLocale "%F %X" time)
-              abortButton <- UI.button # sink UI.enabled allowAbortion # set UI.text "Abort"
-              on UI.click abortButton . const $ jobDelete rJId
-              let abortButton' = case status of
-                    Queued _ -> [abortButton]
+              mark <- UI.input
+                # set UI.type_ "checkbox"
+                # set UI.name "jobMark"
+                # set UI.id_ ("jobMark" ++ show jId)
+                # set UI.value (show jId)
+                # sink UI.checked (Set.member rJId <$> marking)
+              on UI.checkedChange mark . const $ updateMarking'
+              mark' <- UI.span #+ [ return mark
+                                  , UI.label # set UI.for ("jobMark" ++ show jId) # set UI.text "Mark"
+                                  ] # set UI.class_ "mark"
+              -- abortButton <- UI.button # sink UI.enabled allowAbortion # set UI.text "Abort"
+              -- on UI.click abortButton . const $ jobDelete rJId
+              let mark'' = case status of
+                    (Queued _) -> [mark']
                     _ -> []
                   viewJob = do
                     tabLinkList <- fatal' "Could not find tab link list" =<< getElementById window "tabLinks"
                     tabContainer <- fatal' "Could not find tab container" =<< getElementById window "tabContent"
-                    content <- job rJId
+                    content <- withFatal $ job rJId
                     let
                       text = cobbcode content
                     case text of
@@ -381,9 +432,9 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
                         runFunction . switchTab $ "viewJob" ++ show jId
               viewButton <- UI.button # set UI.text "View"
               on UI.click viewButton . const $ viewJob
-              actions <- UI.td # set children (viewButton : abortButton')
+              actions <- UI.td # set children (mark'' ++ [viewButton])
               UI.tr # set UI.id_ ("job" ++ show jId) # set children [jPId, jId', time', jStatus', actions] # sink UI.class_ (bool "" "focused" . Set.member rJId <$> focusedJobs)
-          (:) <$> UI.tr # set children [pId', pFiller, pStatus', pSelect'] <*> mapM toLine jobs
+          (:) <$> UI.tr # set children [pId', pFiller, pStatus', pSelect'] # set UI.class_ "printer" <*> mapM toLine jobs
 
       update <- do
         -- recheckTimer <- timer