From c09c2786d0654f144dab103292c47411ff1afa9a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 24 Feb 2016 04:18:03 +0000 Subject: Partial GUI prototype --- webgui/src/Main.hs | 237 +++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 203 insertions(+), 34 deletions(-) (limited to 'webgui/src/Main.hs') diff --git a/webgui/src/Main.hs b/webgui/src/Main.hs index 92aba0e..44bcb88 100644 --- a/webgui/src/Main.hs +++ b/webgui/src/Main.hs @@ -4,10 +4,13 @@ module Main (main) where import qualified Graphics.UI.Threepenny as UI -import qualified Graphics.UI.Threepenny.Core as TP (Config) -import Graphics.UI.Threepenny.Core hiding (Config) +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 @@ -22,6 +25,15 @@ 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 @@ -30,7 +42,13 @@ import Control.Applicative import Control.Monad import Data.Maybe import Data.Monoid -import Text.Read +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 @@ -49,7 +67,13 @@ config :: IO (Opt.Parser Config) config = do p <- fromMaybe 8023 . (readMaybe =<<) <$> lookupEnv portEnv a <- fromMaybe "localhost" <$> lookupEnv hostEnv - return $ Config <$> ((\port addr -> defaultConfig { jsPort = port, jsAddr = addr }) <$> optional (Opt.option Opt.auto $ port p) <*> optional (fmap CBS.pack $ Opt.strOption $ addr a)) + 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) @@ -74,37 +98,182 @@ setup :: Config -> Window -> Event (Either WebSocketException URI) -> UI () setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do onEvent socketErr handleSocketErr - return window # set UI.title "Thermoprint" - - title <- UI.input - # set UI.id_ "title" - content <- UI.textarea - # set UI.id_ "content" - draftTable <- UI.table - - saveBtn <- UI.button #+ [string "Save"] - discBtn <- UI.button #+ [string "Discard"] - prntBtn <- UI.button #+ [string "Print"] - - getBody window #+ [ row [ column [ UI.h1 #+ [string "Current draft"] - , row [UI.label # set text "Title" # set UI.for "title", element title] - , element content - , row [ element saveBtn - , element prntBtn - , element discBtn - ] - ] - , column [ UI.h1 #+ [string "Saved drafts"] - , element draftTable - ] - ] - ] + getElementById window "javascriptError" >>= maybeM delete + + changeEditorStatus <- handleEditor + + handleDraftTable changeEditorStatus where - handleSocketErr InvalidMessage = debug "Received unparseable message from websocket" - handleSocketErr e@(Unhandled e') = void $ fatalError (show e') >> liftIO (throwIO e) - fatalError str = (getBody window #) . set children =<< sequence [UI.p # set text str # set UI.id_ "fatal-error"] + 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")] + 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.text (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 + when (not $ maybe True null eTitle && null eText) $ case ePrintout of + Left err -> when (not automatic) . emitError $ "Could not save draft due to error parsing bbcode: " ++ show err + 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) }) + where + different s + | Just (_, s') <- lastSaved s = not $ and [ eTitle s == eTitle s' + , eText s == eText s' + ] + | otherwise = True + discardAction = do + maybe (return ()) draftDelete . associatedDraft =<< currentValue editorStatus + modifyStatus $ const def + printAction = do + emitError "Printing not implemented" + + onEvent (tick autoSaveTimer) (const $ 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 $ saveAction False + on UI.click printButton $ const printAction + on UI.click discardButton $ const discardAction + + return changeEditorStatus + + 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@(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 + 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 + time <- liftIO $ getCurrentTime + let newState = def + { eTitle = fmap T.unpack title + , eText = "unimplemented" -- TODO: implement -- drops data as it is + , ePrintout = Right po + , associatedDraft = Just id + , lastSaved = Just (time, newState) + } + changeEditorState newState + table <- fatal' "Could not find draft table" =<< getElementById window "draftListBody" + initialContent <- toTable =<< drafts + return table # set children initialContent + + onEvent (filterE concernsDrafts dataUpdate) . 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 + + +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 (t, _) <- lastSaved = "Last saved: " ++ formatTime defaultTimeLocale "%F %X" t + | otherwise = "Draft was never saved" + +toStatusString' :: Either BBCodeError a -> String +toStatusString' (Right _) = "" +toStatusString' (Left e) = show e + data WebSocketException = ProcessDied | InvalidMessage | Unhandled SomeException deriving (Show) @@ -114,7 +283,7 @@ withWebSocket :: (Config -> Window -> Event (Either WebSocketException URI) -> U withWebSocket setup c@(Config{..}) w = do (dataUpdate, triggerData) <- liftIO newEvent let - rcvEvents = runClient (baseUrlHost server) (baseUrlPort server) "/" $ forever . (triggerData . maybe (Left InvalidMessage) Right . parseURI . T.unpack <=< receiveData) - liftIOLater . void $ forkFinally (rcvEvents `catchAll` (triggerData . Left . Unhandled)) (triggerData $ Left ProcessDied) + 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 -- cgit v1.2.3