http - basic error hooks

src/Main.hs

@@ -92,7 +92,9 @@ mainView model =
 
 mainUpdate :: Action -> Model -> Effect Action Model
 mainUpdate NoAction m = noEff m
-mainUpdate (HaveLatest Client.Error) m = noEff m
+mainUpdate (HaveLatest Client.Error) m = m <# do
+    consoleLog "Getting Latest failed!"
+    return NoAction
 
 mainUpdate (HaveLatest (Client.HttpResponse {..})) m = m <# do
     case body of

src/Network/Client.hs

@@ -42,7 +42,7 @@ update
     -> Action
     -> Model
     -> Effect a Model
-update iface (Connect (_, resultVar)) m = effectSub m $
+update iface (Connect (abort, resultVar)) m = effectSub m $
     \sink -> void $ forkIO $ do
         result :: Http.HttpResult Text <- takeMVar resultVar
         sink $ (returnResult iface) result

src/Network/Http.hs

@@ -8,6 +8,7 @@ module Network.Http
     )
 where
 
+import Prelude hiding (error)
 import Data.Text (Text)
 import Control.Monad.IO.Class (liftIO)
 import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar)
@@ -24,7 +25,7 @@ import GHCJS.DOM.JSFFI.Generated.XMLHttpRequest (send)
 import GHCJS.DOM.Types (XMLHttpRequest)
 import Data.JSString.Text (textToJSString)
 import GHCJS.DOM.EventM (onAsync)
-import GHCJS.DOM.XMLHttpRequestEventTarget (load)
+import GHCJS.DOM.XMLHttpRequestEventTarget (load, abortEvent, error)
 
 -- What we actually want is to call send and not block the thread
 --   - so that we can put the request into our list of ongoing requests.
@@ -98,6 +99,12 @@ http url method payload = do
         result <- mkResult xhr
         putMVar resultVar result
 
+    _ <- onAsync xhr abortEvent $ liftIO $
+        putMVar resultVar Error
+
+    _ <- onAsync xhr error $ liftIO $
+        putMVar resultVar Error
+
     openSimple xhr (show method) url
     -- "/posts?limit=10"