Job/Printer list

5 files changed, 144 insertions, 20 deletions

diff --git a/spec/src/Thermoprint/API.hs b/spec/src/Thermoprint/API.hs
index 3ffd239..5b9c266 100644
--- a/spec/src/Thermoprint/API.hs
+++ b/spec/src/Thermoprint/API.hs
@@ -7,7 +7,7 @@
 -- | A specification of an API for interacting with a set of printers
 module Thermoprint.API
        ( PrinterStatus(..)
-       , JobStatus(..)
+       , JobStatus(..), queueSort
        , PrintingError(..)
        , DraftTitle
        , Range(..), contains
@@ -25,6 +25,7 @@ import           Data.Aeson
 
 import           Data.Monoid
 import           Data.Maybe
+import           Data.Function (on)
 
 import           Data.Set (Set)
 import           Data.Map (Map)
@@ -70,6 +71,15 @@ data JobStatus = Queued PrinterId
                | Failed PrintingError
                deriving (Generic, Show, FromJSON, ToJSON)
 
+queueSort :: JobStatus -> JobStatus -> Ordering
+-- ^ Sort 'JobStatus' by their qualitative position in a printers queue
+queueSort = compare `on` index
+  where
+    index (Queued _) = -1
+    index (Printing _) = 0
+    index Done = 1
+    index (Failed _) = 1
+
 deriving instance Generic EncodingException
 deriving instance NFData EncodingException
 deriving instance FromJSON EncodingException
diff --git a/webgui/data/index.html b/webgui/data/index.html
index 3bdd047..e4a6c63 100644
--- a/webgui/data/index.html
+++ b/webgui/data/index.html
@@ -18,7 +18,7 @@
       <ul class="tab-links">
         <li class="active"><a href="#editor">Editor</a></li>
         <li><a href="#drafts">Drafts</a></li>
-        <li><a href="#queue">Queue</a></li>
+        <li><a href="#printers">Printers & Jobs</a></li>
         <li id="errors-tab" style="display:none;"><a href="#errors">Errors</a></li>
       </ul>
 
@@ -44,6 +44,7 @@
             </div>
           </div>
         </div>
+
         <div class="tab" id="drafts" style="text-align:center;">
           <table style="width:100%;" id="draftList">
             <thead>
@@ -65,8 +66,33 @@
           </table>
         </div>
 
-        <div class="tab" id="queue">
-          Blub.
+        <div class="tab" id="printers" style="text-align:center;">
+          <table style="width:100%;" id="printerList">
+            <thead>
+              <tr>
+                <td style="width:10em;">Printer Id</td>
+                <td style="width:10em;">Job Id</td>
+                <td style="width:20em;">Created</td>
+                <td>Status</td>
+                <td style="width:20em;">Actions</td>
+              </tr>
+            </thead>
+            <tbody id="printerListBody"></tbody>
+            <tfoot>
+              <tr>
+                <td colspan="4" style="border-style:none;"></td>
+                <td>
+                  <input id="autoselectPrinter" type="radio" name="printer" value="Nothing" checked="checked" /><label for="autoselectPrinter">Have server select printer</label>
+                </td>
+              </tr>
+              <tr>
+                <td colspan="4" style="border-style:none;"></td>
+                <td>
+                  <input id="allowAbortion" type="checkbox" /><label for="allowAbortion">Allow Abortion</label>
+                </td>
+              </tr>
+            </tfoot>
+          </table>
         </div>
 
         <ul class="tab" id="errors">
diff --git a/webgui/data/style.css b/webgui/data/style.css
index 9946208..6ab1704 100644
--- a/webgui/data/style.css
+++ b/webgui/data/style.css
@@ -89,6 +89,10 @@ tfoot tr:first-child td {
     width:6em;
 }
 
+tr.focused td {
+    background-color:#d0d0d0;
+}
+
 /*----- Tabs -----*/
 .tabs {
     display:block;
diff --git a/webgui/data/tabs.js b/webgui/data/tabs.js
index 1d178d9..d3263c6 100644
--- a/webgui/data/tabs.js
+++ b/webgui/data/tabs.js
@@ -7,6 +7,8 @@ jQuery(document).ready(function() {
  
         // Change/remove current tab to active
         jQuery(this).parent('li').addClass('active').siblings().removeClass('active');
+
+        jQuery('.focused').removeClass('focused');
  
         e.preventDefault();
     });
diff --git a/webgui/src/Main.hs b/webgui/src/Main.hs
index cbb1a75..dbf34bc 100644
--- a/webgui/src/Main.hs
+++ b/webgui/src/Main.hs
@@ -39,14 +39,19 @@ import           Control.Exception
 import           Control.Monad.Catch
 
 import           Control.Applicative
-import           Control.Monad
+import           Control.Monad hiding (sequence)
 import           Data.Maybe
 import           Data.Monoid
 import           Text.Read hiding (get)
 import           Data.Either
-import           Data.List (isPrefixOf)
+import           Data.List (isPrefixOf, sortBy)
+import           Data.Ord
+import qualified Data.Function as F
 import           Data.Bool
 
+import           Data.Traversable (sequence)
+import           Data.Foldable
+
 import           Paths_thermoprint_webgui
 
 import Debug.Trace
@@ -100,8 +105,10 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
   onEvent socketErr handleSocketErr
 
   getElementById window "javascriptError" >>= maybeM delete
+  
+  selectedPrinter <- handleJobTable
 
-  changeEditorStatus <- handleEditor
+  changeEditorStatus <- handleEditor selectedPrinter
 
   handleDraftTable changeEditorStatus
   
@@ -136,7 +143,7 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
 
     Client{..} = mkClient (Nat $ either (fatal . ("Error while communicating to Thermoprint.Server: " ++) . show) return <=< liftIO . runEitherT) server
 
-    handleEditor = do
+    handleEditor selectedPrinter = do
       title <- fatal' "Could not find editor title field" =<< getElementById window "editorTitle"
       text <- fatal' "Could not find editor text field" =<< getElementById window "editorText"
       status <- fatal' "Could not find editor status field" =<< getElementById window "editorStatus"
@@ -202,9 +209,9 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
             Right po -> case associatedDraft of
               Just dId -> do
                 saved <- saveAction False
-                when saved $ runFunction . focusJob =<< draftPrint dId Nothing -- FIXME
+                when saved $ runFunction . focusJob =<< draftPrint dId =<< currentValue selectedPrinter
               Nothing -> do
-                runFunction . focusJob =<< jobCreate Nothing po -- FIXME
+                runFunction . focusJob =<< 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)
@@ -214,6 +221,7 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
       return discardButton # sink UI.enabled (discardable <$> editorStatus)
 
       return discardButton # sink UI.text (bool "Discard" "Save & Clear" <$> saveDraft)
+      return printButton # sink UI.text (maybe "Print" (\(PrinterId i) -> "Print on " ++ show i) <$> selectedPrinter)
 
       on (whenE saveDraft . UI.click) saveButton . const . void $ saveAction False
       on UI.click printButton $ const printAction
@@ -268,17 +276,91 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
       initialContent <- toTable =<< drafts
       return table # set children initialContent
 
-      recheckTimer <- timer
-      return recheckTimer # set interval 5000
-      start recheckTimer
+      update <- do
+        -- recheckTimer <- timer
+        -- return recheckTimer # set interval 5000
+        -- start recheckTimer
+
+        -- return $ unionWith const (() <$ filterE concernsDrafts dataUpdate) (tick recheckTimer)
+        return $ filterE concernsDrafts dataUpdate
   
-      onEvent (unionWith const (() <$ filterE concernsDrafts dataUpdate) (tick recheckTimer)) . const $ drafts >>= toTable >>= (\c -> return table # set children c)
-      where
-        concernsDrafts :: URI -> Bool
-        concernsDrafts (uriPath -> p)
-          | p == "drafts" = True
-          | "draft/" `isPrefixOf` p = True
-          | otherwise = False
+      onEvent update . const $ drafts >>= toTable >>= (\c -> return table # set children c)
+      
+    concernsDrafts :: URI -> Bool
+    concernsDrafts (uriPath -> p)
+      | p == "drafts" = True
+      | "draft/" `isPrefixOf` p = True
+      | otherwise = False
+
+    concernsPrinters :: URI -> Bool
+    concernsPrinters (uriPath -> p)
+      | p == "printers" = True
+      | "jobs/" `isPrefixOf` p = True
+      | otherwise = False
+
+    handleJobTable = do
+      allowAbortion <- do
+        allowAbortion <- fatal' "Could not find abortion switch" =<< getElementById window "allowAbortion"
+        flip stepper (UI.checkedChange allowAbortion) =<< (allowAbortion # get UI.checked)
+
+      (selectedPrinter, updatePrinter) <- do
+        autoselectPrinter <- fatal' "Could not find printer autoselect switch" =<< getElementById window "autoselectPrinter"
+        (selectedPrinter, printerSelect) <- stepper' Nothing
+        return autoselectPrinter # sink UI.checked (isNothing <$> selectedPrinter)
+        let
+          -- getSelectedPrinter :: UI (Maybe PrinterId)
+          getSelectedPrinter = (fmap PrinterId . join . readMaybe) <$> callFunction (ffi "$('input[name=printer]:checked', '#printers').val()")
+          updatePrinterSelect = getSelectedPrinter >>= liftIO . printerSelect
+        on (domEvent "change") autoselectPrinter $ const updatePrinterSelect
+        return (selectedPrinter, updatePrinterSelect)
+
+      let
+        -- getServerState :: UI [(PrinterId, PrinterStatus, [(JobId, UTCTime, JobStatus)])]
+        getServerState = map mangleTuple . Map.toList <$> (Map.traverseWithKey (\pId status -> (,) status <$> getJobState pId) =<< printers)
+        -- getJobState :: PrinterId -> UI [(JobId, UTCTime, JobStatus)]
+        getJobState pId = toList <$> jobs (Just pId) Nothing Nothing
+        mangleTuple (a, (b, c)) = (a, b, c)
+        thrd (_, _, c) = c
+
+        -- toTable :: [(PrinterId, PrinterStatus, [(JobId, UTCTime, JobStatus)])] -> UI [Element]
+        toTable = fmap concat . mapM toSubTable
+        -- toSubTable :: (PrinterId, PrinterStatus, [(JobId, UTCTime, JobStatus)]) -> UI [Element]
+        toSubTable (rPId@(PrinterId pId), pStatus, (sortBy (queueSort `F.on` thrd) -> jobs)) = do
+          pId' <- UI.td # set UI.text (show pId)
+          pStatus' <- UI.td # set UI.text (show pStatus)
+          let selectId = "printer" ++ show pId
+          checked <- (== Just rPId) <$> currentValue selectedPrinter
+          pSelect <- UI.input # set UI.type_ "radio" # set UI.name "printer" # set UI.value (show $ Just pId) # set UI.id_ selectId # set UI.checked checked
+          on (domEvent "change") pSelect $ const updatePrinter
+          pSelectL <- UI.label # set UI.for selectId # set UI.text "Use for new jobs"
+          pSelect' <- UI.td # set children [pSelect, pSelectL]
+          pFiller <- UI.td # set UI.colspan 2
+          let
+            toLine ((JobId jId), time, status) = do
+              jPId <- UI.td
+              jId' <- UI.td # set UI.text (show jId)
+              jStatus' <- UI.td # set UI.text (show status)
+              abortButton <- UI.button # sink UI.enabled allowAbortion # set UI.text "Abort"
+              actions <- UI.td # set children [abortButton]
+              UI.tr # set UI.id_ ("job" ++ show jId) # set children [jPId, jId', jStatus', actions]
+          (:) <$> UI.tr # set children [pId', pFiller, pStatus', pSelect'] <*> mapM toLine jobs
+
+      update <- do
+        -- recheckTimer <- timer
+        -- return recheckTimer # set interval 5000
+        -- start recheckTimer
+
+        -- return $ unionWith const (() <$ filterE concernsPrinters dataUpdate) (tick recheckTimer)
+        return $ filterE concernsPrinters dataUpdate
+
+      table <- fatal' "Could not find printer table" =<< getElementById window "printerListBody"
+      initialContent <- toTable =<< getServerState
+      return table # set children initialContent
+      
+      onEvent update . const $ getServerState >>= toTable >>= (\c -> return table # set children c) >> updatePrinter
+
+      return selectedPrinter
+
 
 focusJob :: JobId -> JSFunction ()
 focusJob (JobId (fromInteger -> i)) = ffi "alert(%1)" (i :: Int) -- FIXME