From 2c55c6f2afabde93a3579d1042f189f34e821753 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 22 Feb 2016 23:30:28 +0000 Subject: First work on integrating websockets into webgui --- webgui/src/Main.hs | 67 +++++++++++++++++++++++++++++++++-------- webgui/thermoprint-webgui.cabal | 5 +++ webgui/thermoprint-webgui.nix | 10 +++--- 3 files changed, 66 insertions(+), 16 deletions(-) diff --git a/webgui/src/Main.hs b/webgui/src/Main.hs index d96083e..7ead572 100644 --- a/webgui/src/Main.hs +++ b/webgui/src/Main.hs @@ -1,9 +1,16 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + module Main (main) where import qualified Graphics.UI.Threepenny as UI -import Graphics.UI.Threepenny.Core +import qualified Graphics.UI.Threepenny.Core as TP (Config) +import Graphics.UI.Threepenny.Core hiding (Config) import Thermoprint.Client +import Network.WebSockets +import Network.Socket (withSocketsDo) +import Network.URI import qualified Options.Applicative as Opt import System.Environment @@ -12,14 +19,26 @@ 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 Control.Concurrent +import Control.Exception +import Control.Monad.Catch + import Control.Applicative import Control.Monad import Data.Maybe import Data.Monoid import Text.Read +data Config = Config + { tpConfig :: TP.Config + , server :: BaseUrl + } + main :: IO () -main = config >>= Opt.execParser . opts >>= flip startGUI setup +main = withSocketsDo $ config >>= Opt.execParser . opts >>= (\c -> startGUI (tpConfig c) $ (withWebSocket setup) c) where opts config = Opt.info (Opt.helper <*> config) ( Opt.fullDesc @@ -30,9 +49,11 @@ config :: IO (Opt.Parser Config) config = do p <- fromMaybe 8023 . (readMaybe =<<) <$> lookupEnv portEnv a <- fromMaybe "localhost" <$> lookupEnv hostEnv - return $ (\port addr -> defaultConfig { jsPort = port, jsAddr = addr }) - <$> optional (Opt.option Opt.auto $ port p) - <*> optional (fmap CBS.pack $ Opt.strOption $ addr a) + return $ Config <$> ((\port addr -> defaultConfig { 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' @@ -49,8 +70,10 @@ config = do hostEnv = "ADDR" portEnv = "PORT" -setup :: Window -> UI () -setup window = void $ do +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 @@ -64,11 +87,11 @@ setup window = void $ do 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 + , row [UI.label # set text "Title" # set UI.for "title", element title # set style [("width", "100%")]] + , element content # set style [("width", "100%")] + , row [ element saveBtn # set style [("width", "100%")] + , element prntBtn # set style [("width", "100%")] + , element discBtn # set style [("width", "100%")] ] ] , column [ UI.h1 #+ [string "Saved drafts"] @@ -76,3 +99,23 @@ setup window = void $ do ] ] ] + + where + handleSocketErr InvalidMessage = debug "Received unparseable message from websocket" + handleSocketErr e@(UnknownException e') = void $ do + getBody window #+ [UI.p # set text (show e') # set UI.id_ "error"] + liftIO $ throwIO e + +data WebSocketException = InvalidMessage | UnknownException 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 . parseURI . T.unpack <=< receiveData) + liftIO . forkIO $ rcvEvents `catchAll` (triggerData . Left . UnknownException) + void $ setup c w dataUpdate + diff --git a/webgui/thermoprint-webgui.cabal b/webgui/thermoprint-webgui.cabal index 51a302a..c1f4d19 100644 --- a/webgui/thermoprint-webgui.cabal +++ b/webgui/thermoprint-webgui.cabal @@ -26,5 +26,10 @@ executable thermoprint-webgui , threepenny-gui >=0.6.0 && <1 , optparse-applicative >=0.12.1 && <1 , bytestring >=0.10.6 && <1 + , websockets >=0.9.5 && <1 + , network >=2.6.2 && <3 + , network-uri >=2.6.0 && <3 + , text >=1.2.2 && <2 + , exceptions >=0.8.2 && <1 hs-source-dirs: src default-language: Haskell2010 \ No newline at end of file diff --git a/webgui/thermoprint-webgui.nix b/webgui/thermoprint-webgui.nix index 0450eae..5eb5912 100644 --- a/webgui/thermoprint-webgui.nix +++ b/webgui/thermoprint-webgui.nix @@ -1,5 +1,6 @@ -{ mkDerivation, base, bytestring, optparse-applicative, stdenv -, thermoprint-bbcode, thermoprint-client, threepenny-gui +{ mkDerivation, base, bytestring, exceptions, network, network-uri +, optparse-applicative, stdenv, text, thermoprint-bbcode +, thermoprint-client, threepenny-gui, websockets }: mkDerivation { pname = "thermoprint-webgui"; @@ -8,8 +9,9 @@ mkDerivation { isLibrary = false; isExecutable = true; executableHaskellDepends = [ - base bytestring optparse-applicative thermoprint-bbcode - thermoprint-client threepenny-gui + base bytestring exceptions network network-uri optparse-applicative + text thermoprint-bbcode thermoprint-client threepenny-gui + websockets ]; homepage = "http://dirty-haskell.org/tags/thermoprint.html"; description = "Threepenny interface for thermoprint-spec compliant servers"; -- cgit v1.2.3