From 5532ffc9604a5135a61433ec1588fee830802910 Mon Sep 17 00:00:00 2001
From: towards-a-new-leftypol <paul_cockshott@protonmail.com>
Date: Fri, 12 Jan 2024 19:25:01 -0500
Subject: [PATCH] http - basic error hooks

---
 src/Main.hs           | 4 +++-
 src/Network/Client.hs | 2 +-
 src/Network/Http.hs   | 9 ++++++++-
 3 files changed, 12 insertions(+), 3 deletions(-)

diff --git a/src/Main.hs b/src/Main.hs
index f4d5872..60db15c 100644
--- a/src/Main.hs
+++ b/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
diff --git a/src/Network/Client.hs b/src/Network/Client.hs
index da72b4b..8d68db0 100644
--- a/src/Network/Client.hs
+++ b/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
diff --git a/src/Network/Http.hs b/src/Network/Http.hs
index 96c5d23..c87964b 100644
--- a/src/Network/Http.hs
+++ b/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"