path: root/webgui/src/Main.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

module Main (main) where

import qualified Graphics.UI.Threepenny       as UI
import           Graphics.UI.Threepenny.Timer
import qualified Graphics.UI.Threepenny.Core  as TP        (Config, text)
import           Graphics.UI.Threepenny.Core        hiding (Config, text)

import           Thermoprint.Client
import           Thermoprint.Printout.BBCode

import           Network.WebSockets
import           Network.Socket (withSocketsDo)
import           Network.URI

import qualified Options.Applicative as Opt
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

import           Data.Map        (Map)
import qualified Data.Map as Map
import           Data.Sequence        (Seq)
import qualified Data.Sequence as Seq
import           Data.Set        (Set)
import qualified Data.Set as Set

import           Data.Default.Class

import           Data.Time

import           Control.Concurrent
import           Control.Exception
import           Control.Monad.Catch
import           Control.Monad.Catch.Pure

import           Control.Applicative
import           Control.Monad hiding (sequence)
import           Data.Maybe
import           Data.Monoid
import           Text.Read hiding (get)
import           Data.Either
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

data Config = Config
  { tpConfig :: TP.Config
  , server   :: BaseUrl
  }

main :: IO ()
main = withSocketsDo $ config >>= Opt.execParser . opts >>= (\c -> startGUI (tpConfig c) $ (withWebSocket setup) c)
  where
    opts config = Opt.info (Opt.helper <*> config)
      ( Opt.fullDesc
        <> Opt.progDesc "Run a webgui to Thermoprint.Client"
      )

config :: IO (Opt.Parser Config)
config = do
  p <- fromMaybe 8023 . (readMaybe =<<) <$> lookupEnv portEnv
  a <- fromMaybe "localhost" <$> lookupEnv hostEnv
  static <- getDataDir
  let
    config = defaultConfig
      { jsCustomHTML = Just "index.html"
      , jsStatic = Just static
      }
  return $ Config <$> ((\port addr -> config { jsPort = port, jsAddr = addr }) <$> optional (Opt.option Opt.auto $ port p) <*> optional (fmap CBS.pack $ Opt.strOption $ addr a))
    <*> (BaseUrl Http
         <$> Opt.strOption (Opt.long "target-addr" <> Opt.short 'A' <> Opt.metavar "HOST" <> Opt.help "Host to connect to" <> Opt.value "localhost" <> Opt.showDefault)
         <*> Opt.option Opt.auto (Opt.long "target-port" <> Opt.short 'P' <> Opt.metavar "PORT" <> Opt.help "Port to connect to" <> Opt.value 3000 <> Opt.showDefault)
         <*> Opt.strOption (Opt.long "target-path" <> Opt.short 'F' <> Opt.metavar "PATH" <> Opt.help "Path we expect to find Thermoprint.Server under" <> Opt.value "" <> Opt.showDefault)
        )
  where
    port def = Opt.long "port"
      <> Opt.short 'p'
      <> Opt.metavar "PORT"
      <> Opt.help ("Port to bind to; default read from $" <> portEnv) 
      <> Opt.value def
      <> Opt.showDefault
    addr def = Opt.long "addr"
      <> Opt.short 'a'
      <> Opt.metavar "HOST"
      <> Opt.help ("Host to listen on; default read from $" <> hostEnv)
      <> Opt.value def
      <> Opt.showDefault
    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

  getElementById window "javascriptError" >>= maybeM delete

  (focusedJobs, changeFocusedJobs) <- stepper' Set.empty
  let modifyFocusedJobs f = changeFocusedJobs . f =<< currentValue focusedJobs
      fJobs = (focusedJobs, liftIO . modifyFocusedJobs)
  
  selectedPrinter <- handleJobTable fJobs

  (editorStatus, changeEditorStatus) <- handleEditor selectedPrinter fJobs

  handleDraftTable (editorStatus, changeEditorStatus)
  
  where
    handleSocketErr InvalidMessage = emitError "Received unparseable message from server-side websocket"
    handleSocketErr ProcessDied = fatal "Thread handling server-side websocket died"
    handleSocketErr (Unhandled e') = fatal $ "Unhandled error from server-side websocket: " ++ show e'
    emitError str = void $ do
      debug str
      let
        errors = maybe (fatal "No container for nonfatal errors found") return =<< getElementById window "errors"
        errorsTab = maybe (fatal "Could not make nonfatal errors visible") return =<< getElementById window "errors-tab"
      errors #+ [UI.li # set TP.text str]
      errorsTab # set style [("display", "inline-block")]
      runFunction $ switchTab "errors"

    maybeM = maybe $ return ()

    fatal' :: String -> Maybe a -> UI a
    fatal' str = maybe (fatal str) return

    stepper' :: a -> UI (Behavior a, a -> IO ())
    stepper' init = do
      (statusEvent, triggerStatusChange) <- liftIO newEvent
      status <- stepper init statusEvent
      return (status, triggerStatusChange)

    Client{..} = (mkClient' server :: Client (CatchT UI))
    withFatal :: CatchT UI a -> UI a
    withFatal a = either (fatal . ("Error while communicating to Thermoprint.Server: " ++) . show) return =<< runCatchT a

    handleEditor selectedPrinter (_, modifyFocusedJobs) = 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"
      bbcodeStatus <- fatal' "Could not find editor bbcode status field" =<< getElementById window "bbcodeStatus"
  
      saveButton <- fatal' "Could not find editor save button" =<< getElementById window "saveButton"
      printButton <- fatal' "Could not find editor print button" =<< getElementById window "printButton"
      discardButton <- fatal' "Could not find editor discard button" =<< getElementById window "discardButton"

      (editorStatus, fmap liftIO -> changeEditorStatus) <- stepper' def

      saveDraft <- do
        saveDraft <- fatal' "Could not find save switch" =<< getElementById window "saveDraft"
        flip stepper (UI.checkedChange saveDraft) =<< saveDraft # get UI.checked
                  
      let
        modifyStatus f = changeEditorStatus . f =<< currentValue editorStatus

      on UI.valueChange title $ \str -> modifyStatus (\x -> x { eTitle = if null str then Nothing else Just str })
      on UI.valueChange text $ \str -> modifyStatus (\x -> x { eText = str })
      on UI.valueChange text $ \str -> modifyStatus (\x -> x { ePrintout = bbcode $ T.pack str })

      return title # sink UI.value (fromMaybe "" . eTitle <$> editorStatus)
      return text # sink UI.value (eText <$> editorStatus)
      return status # sink TP.text (toStatusString <$> editorStatus)
      return bbcodeStatus # sink TP.text (toStatusString' . ePrintout <$> editorStatus)

      autoSaveTimer <- timer # set interval 5000
      start autoSaveTimer

      let
        saveAction automatic = do
          s@(EditorState{..}) <- currentValue editorStatus
          r <- when' (not $ maybe True null eTitle && null eText) $ case ePrintout of
            Left err -> do
              when (not automatic) . emitError $ "Could not save draft due to error parsing bbcode: " ++ show err
              return False
            Right p -> do
              draftId <- case associatedDraft of
                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
          return $ fromMaybe False r
          where
            different s
              | Just (_, s') <- lastSaved s = not $ and [ eTitle s == eTitle s'
                                                        , eText s == eText s'
                                                        ]
              | otherwise = True
            when' :: Applicative m => Bool -> m a -> m (Maybe a)
            when' True = fmap Just
            when' False = const $ pure Nothing
        clearAction = do
          -- maybe (return ()) draftDelete . associatedDraft =<< currentValue editorStatus
          saved <- saveAction False
          when saved $ discardAction
        discardAction = modifyStatus $ const def
        printAction = do
          EditorState{..} <- currentValue editorStatus
          let
            reFocusJob jId = modifyFocusedJobs (const $ Set.singleton jId)
          case ePrintout of
            Right po -> case associatedDraft of
              Just dId -> do
                saved <- saveAction False
                when saved $ reFocusJob =<< withFatal . draftPrint dId =<< currentValue selectedPrinter
              Nothing -> do
                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)

      return saveButton # sink UI.enabled ((&&) <$> (saveable <$> editorStatus) <*> saveDraft)
      return printButton # sink UI.enabled (printable <$> editorStatus)
      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
      on (whenE (not <$> saveDraft) . UI.click) discardButton $ const discardAction
      on (whenE saveDraft . UI.click) discardButton $ const clearAction

      return (editorStatus, modifyStatus)

    saveable s@EditorState{..} = isRight ePrintout && discardable s
    printable EditorState{..} = isRight ePrintout && not (null eText)
    discardable EditorState{..} = not (maybe True null eTitle && null eText)

    handleDraftTable (editorState, changeEditorState) = do
      -- 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

      
      enactDeletion <- fatal' "Could not find deletion button" =<< getElementById window "enactDeletion"
      on UI.click enactDeletion . const $ do
        cMarking <- currentValue marking
        mapM_ (runCatchT . draftDelete) cMarking
        cDraft <- associatedDraft <$> currentValue editorState
        when (Set.member cDraft $ Set.map Just cMarking) $ changeEditorState (\s -> s { associatedDraft = Nothing } )
        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
          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 [mark', load]
          UI.tr # set children [id', title', actions]
        loadDraft id = do
          (title, po) <- withFatal $ draft id
          let
            t = cobbcode po
          case t of
            Left (show -> errStr) -> emitError $ "Could not load draft: " ++ errStr
            Right text -> do
              time <- liftIO $ getCurrentTime
              let newState = def
                    { eTitle = fmap T.unpack title
                    , eText = T.unpack text
                    , ePrintout = Right po
                    , associatedDraft = Just id
                    , lastSaved = Just (time, newState)
                    }
              changeEditorState (const newState)
              runFunction $ switchTab "editor"
      table <- fatal' "Could not find draft table" =<< getElementById window "draftListBody"
      initialContent <- toTable =<< withFatal drafts
      return table # set children initialContent

      update <- do
        -- recheckTimer <- timer
        -- return recheckTimer # set interval 5000
        -- start recheckTimer

        -- return $ unionWith const (() <$ filterE concernsDrafts dataUpdate) (tick recheckTimer)
        return $ filterE concernsDrafts dataUpdate
  
      onEvent update . const $ withFatal 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
      | p == "jobs" = True
      | 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)
      (marking, (liftIO .) -> updateMarking) <- stepper' $ Set.empty
      
      enactAbortion <- fatal' "Could not find deletion button" =<< getElementById window "enactAbortion"
      on UI.click enactAbortion . const $ currentValue marking >>= mapM_ (runCatchT . jobDelete) >> updateMarking Set.empty
        
      (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
        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) =<< withFatal printers)
        -- getJobState :: PrinterId -> UI [(JobId, UTCTime, JobStatus)]
        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'
          where
            compare' :: Ord a => a -> a -> Ordering
            compare'
              | (Queued _) <- status = compare
              | otherwise = flip compare

        -- 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 jobSort -> 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 (rJId@(JobId jId), time, status) = do
              jPId <- UI.td
              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)
              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 <- withFatal $ job rJId
                    let
                      text = cobbcode content
                    case text of
                      Left err -> emitError $ "Could not decode content of job #" ++ show jId ++ ": " ++ show err
                      Right (T.unpack -> text) -> void $ do
                        tabLink <- UI.a # set UI.href ("#viewJob" ++ show jId) # set UI.text ("Job #" ++ show jId)
                        tabLinkItem <- UI.li # set children [tabLink]
                        return tabLinkList #+ [ return tabLinkItem ]
                        closeLink <- UI.a # set UI.text "Close Tab" # set UI.class_ "close" # set UI.href "#printers"
                        tabContent <- UI.pre # set UI.text text
                        tab <- UI.new # set children [closeLink, tabContent] # set UI.id_ ("viewJob" ++ show jId) # set UI.class_ "tab"
                        return tabContainer #+ [ return tab ]
                        on UI.click closeLink . const $ mapM_ delete [tabLink, tabLinkItem, closeLink, tabContent, tab] >> runFunction (switchTab "printers")
                        runFunction . switchTab $ "viewJob" ++ show jId
              viewButton <- UI.button # set UI.text "View"
              on UI.click viewButton . const $ viewJob
              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'] # set UI.class_ "printer" <*> 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

switchTab :: String -> JSFunction ()
switchTab = ffi "$(%1).first().trigger(\"click\")" . (\p -> "a[href='#" ++ p ++ "']")

data EditorState = EditorState
  { eTitle :: Maybe String
  , eText :: String
  , ePrintout :: Either BBCodeError Printout
  , lastSaved :: Maybe (UTCTime, EditorState)
  , associatedDraft :: Maybe DraftId
  }
  deriving (Show)

instance Default EditorState where
  def = EditorState
    { eTitle          = Nothing
    , eText           = ""
    , ePrintout       = Right mempty
    , lastSaved       = Nothing
    , associatedDraft = Nothing
    }

toStatusString :: EditorState -> String
toStatusString EditorState{..}
  | null eTitle
  , null eText               = "Draft is empty"
  | Just (DraftId (show -> id)) <- associatedDraft
  , Just (t, _) <- lastSaved = "Last saved: " ++ formatTime defaultTimeLocale "%F %X" t ++ " as #" ++ id
  | otherwise                = "Draft was never saved successfully"

toStatusString' :: Either BBCodeError a -> String
toStatusString' (Right _) = ""
toStatusString' (Left e)  = show e
  
data WebSocketException = ProcessDied | InvalidMessage | Unhandled SomeException
  deriving (Show)

instance Exception WebSocketException

withWebSocket :: (Config -> Window -> Event (Either WebSocketException URI) -> UI void) -> Config -> Window -> UI ()
withWebSocket setup c@(Config{..}) w = do
  (dataUpdate, triggerData) <- liftIO newEvent
  let
    rcvEvents = runClient (baseUrlHost server) (baseUrlPort server) (baseUrlPath server) $ forever . (triggerData . maybe (Left InvalidMessage) Right . parseURIReference . T.unpack <=< receiveData)
  liftIOLater . void $ forkFinally rcvEvents (triggerData . Left . either Unhandled (const ProcessDied))
  void $ setup c w dataUpdate