Added stability to websockets

2 files changed, 11 insertions, 11 deletions

diff --git a/server/src/Thermoprint/Server/Push.hs b/server/src/Thermoprint/Server/Push.hs
index b2eca6b..07b81fb 100644
--- a/server/src/Thermoprint/Server/Push.hs
+++ b/server/src/Thermoprint/Server/Push.hs
@@ -40,6 +40,7 @@ protocolSpec = CBS.pack $ "thermoprint-server.notification." ++ showVersion vers
 handleClient :: TChan Notification -> Connection -> IO ()
 handleClient chan conn = do
   cChan <- atomically $ dupTChan chan
+  forkPingThread conn 10
   forever . void $ atomically (readTChan cChan) >>= sendTextData conn . packNotification
 
 packNotification :: Notification -> Text
diff --git a/webgui/src/Main.hs b/webgui/src/Main.hs
index 7ead572..92aba0e 100644
--- a/webgui/src/Main.hs
+++ b/webgui/src/Main.hs
@@ -87,11 +87,11 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = 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 # 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%")]
+                                   , 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"]
@@ -102,11 +102,10 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = 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
+    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"]
 
-data WebSocketException = InvalidMessage | UnknownException SomeException
+data WebSocketException = ProcessDied | InvalidMessage | Unhandled SomeException
   deriving (Show)
 
 instance Exception WebSocketException
@@ -115,7 +114,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)
-  liftIO . forkIO $ rcvEvents `catchAll` (triggerData . Left . UnknownException)
+    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)
   void $ setup c w dataUpdate