First work on integrating websockets into webgui

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