{-# 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 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)
        )
  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
  
  selectedPrinter <- handleJobTable

  changeEditorStatus <- handleEditor selectedPrinter

  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 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"
      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 -> 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
        clearAction = do
          -- maybe (return ()) draftDelete . associatedDraft =<< currentValue editorStatus
          saved <- saveAction False
          when saved $ discardAction
        discardAction = 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 =<< currentValue selectedPrinter
              Nothing -> do
                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)

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

      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 $ 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

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