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           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.Default.Class

import           Data.Time

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

import           Control.Applicative
import           Control.Monad
import           Data.Maybe
import           Data.Monoid
import           Text.Read hiding (get)
import           Data.Either
import           Data.List (isPrefixOf)

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)
        )
  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"

setup :: Config -> Window -> Event (Either WebSocketException URI) -> UI ()
setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
  onEvent socketErr handleSocketErr

  getElementById window "javascriptError" >>= maybeM delete

  changeEditorStatus <- handleEditor

  handleDraftTable 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"
    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 ()

    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 (Nat $ either (fatal . ("Error while communicating to Thermoprint.Server: " ++) . show) return <=< liftIO . runEitherT) server

    handleEditor = 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

      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 -> draftCreate (T.pack <$> eTitle) p
                Just i -> i <$ when (different s) (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
        discardAction = do
          -- maybe (return ()) draftDelete . associatedDraft =<< currentValue editorStatus
          saved <- saveAction False
          when saved $ modifyStatus $ const def
        printAction = do
          EditorState{..} <- currentValue editorStatus
          case ePrintout of
            Right po -> case associatedDraft of
              Just dId -> do
                saved <- saveAction False
                when saved $ runFunction . focusJob =<< draftPrint dId Nothing -- FIXME
              Nothing -> do
                runFunction . focusJob =<< jobCreate Nothing po -- FIXME
            Left err -> emitError $ "Could not print draft due to error parsing bbcode: " ++ show err

      onEvent (tick autoSaveTimer) (const . void $ saveAction True)

      return saveButton # sink UI.enabled (saveable <$> editorStatus)
      return printButton # sink UI.enabled (printable <$> editorStatus)
      return discardButton # sink UI.enabled (discardable <$> editorStatus)

      on UI.click saveButton . const . void $ saveAction False
      on UI.click printButton $ const printAction
      on UI.click discardButton $ const discardAction

      return 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 changeEditorState = do
      allowDeletion <- fatal' "Could not find deletion switch" =<< getElementById window "allowDeletion"
      deletion' <- allowDeletion # get UI.checked

      deletion <- stepper deletion' $ UI.checkedChange allowDeletion
      let
        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)
          load <- UI.button
            # set TP.text "Load"
          on UI.click load . const $ loadDraft id
          actions <- UI.td # set children [load, delete]
          UI.tr # set children [id', title', actions]
        loadDraft id = do
          (title, po) <- 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 =<< drafts
      return table # set children initialContent

      recheckTimer <- timer
      return recheckTimer # set interval 5000
      start recheckTimer
  
      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

focusJob :: JobId -> JSFunction ()
focusJob (JobId (fromInteger -> i)) = ffi "alert(%1)" (i :: Int) -- FIXME

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) "/" $ 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