From 2c55c6f2afabde93a3579d1042f189f34e821753 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 22 Feb 2016 23:30:28 +0000
Subject: First work on integrating websockets into webgui

---
 webgui/src/Main.hs | 67 ++++++++++++++++++++++++++++++++++++++++++++----------
 1 file changed, 55 insertions(+), 12 deletions(-)

(limited to 'webgui/src/Main.hs')

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
+  
-- 
cgit v1.2.3