1 files changed, 98 insertions, 16 deletions

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