@@ -3,7 +3,7 @@ module Test.FetchSpec where
33import Prelude
44
55import Data.ArrayBuffer.Types (Uint8Array)
6−import Data.Maybe (Maybe(..))
6+import Data.Maybe (Maybe(..), isNothing)
77import Fetch (Method(..), Referrer(..), RequestMode(..), fetch)
88import Fetch as Fetch
99import JS.Fetch.Duplex (Duplex(..))
@@ -11,9 +11,30 @@ import Foreign (unsafeFromForeign)
1111import Test.Spec (Spec, describe, it)
1212import Test.Spec.Assertions (shouldEqual, shouldSatisfy)
1313import Web.Streams.ReadableStream (ReadableStream)
14−import Effect.Aff (attempt)
15−import Data.Either (Either(Left), isLeft)
16−import Data.Bifunctor (bimap)
14+import Effect.Aff (attempt, forkAff, launchAff_)
15+import Data.Either (blush)
16+import Effect.Aff (delay, joinFiber, killFiber) as Aff
17+import Data.Time.Duration (Milliseconds(Milliseconds))
18+import Effect.Exception (Error, error)
19+import Effect.Exception (message) as Exception
20+import Effect.Ref (new, read, write) as Ref
21+import Effect.Class (liftEffect)
22+import Node.HTTP as HTTP
23+import Node.EventEmitter (once_)
24+import Node.HTTP.Server as Server
25+import Node.Net.Server (listenTcp)
26+import Node.HTTP.OutgoingMessage as OM
27+import Node.Net.Server as NetServer
28+import Node.HTTP.IncomingMessage as IM
29+import Node.HTTP.ServerResponse as ServerResponse
30+import Partial.Unsafe (unsafeCrashWith)
31+import Node.Encoding (Encoding(UTF8))
32+import Node.Stream as Stream
33+import Node.HTTP.Types (HttpServer', IMServer, IncomingMessage, ServerResponse)
34+import Effect (Effect)
35+import Node.HTTP.Server (closeAllConnections)
36+import Effect.Ref (Ref)
37+
1738
1839-- | Returns a new ReadableStream that allows the content of the Blob to be read.
1940foreign import helloWorldStream :: ReadableStream Uint8Array
@@ -69,6 +90,62 @@ spec =
6990 Fetch.contains "Content-Length" headers `shouldEqual` true
7091 status `shouldEqual` 200
7192
72− it "should catch errors" do
73− res <- attempt $ fetch "https://google.com/404" {}
74− (res # bimap show (const unit)) `shouldEqual` Left "NetworkError"
93+ it "can be cancelled" do
94+ requestCancelledRef <- Ref.new Nothing # liftEffect
95+ -- Start a server that records our cancellation
96+ server requestCancelledRef # liftEffect
97+ requestFiber <- forkAff $ fetch "http://localhost:54045/" {}
98+ Aff.delay (40.0 # Milliseconds)
99+ requestCancelled <- Ref.read requestCancelledRef # liftEffect
100+ requestCancelled `shouldSatisfy` isNothing
101+ -- Cancel the request
102+ Aff.killFiber (error "Fetch Abort Test") requestFiber
103+ result <- attempt $ Aff.joinFiber requestFiber
104+ (Exception.message <$> blush result) `shouldEqual` (Just "Fetch Abort Test")
105+ Aff.delay (80.0 # Milliseconds)
106+ requestCancelled <- Ref.read requestCancelledRef # liftEffect
107+ (Exception.message <$> requestCancelled) `shouldEqual` (Just "aborted")
108+ where
109+
110+ -- | A server that will respond to a request after 100ms
111+ -- | it records the first error on the request stream in the ref
112+ -- | Adapted from: [node-http](https://github.com/purescript-node/purescript-node-http/blob/master/test/Main.purs)
113+ server ref = do
114+ server <- HTTP.createServer
115+ server # once_ Server.requestH (respond ref (killServer server))
116+ let netServer = Server.toNetServer server
117+ listenTcp netServer { host: "localhost", port: 54045 }
118+ where
119+
120+ respond :: Ref (Maybe Error) -> Effect Unit -> IncomingMessage IMServer -> ServerResponse -> Effect Unit
121+ respond ref closeServer req res = do
122+ ServerResponse.setStatusCode 200 res
123+ let
124+ im = IM.toReadable req
125+ om = ServerResponse.toOutgoingMessage res
126+ outputStream = OM.toWriteable om
127+
128+ -- Handle errors on the input stream
129+ -- and save them to the ref
130+ im # once_ Stream.errorH \err -> do
131+ whenM (Stream.destroyed im) do
132+ Ref.write (Just err) ref # liftEffect
133+
134+ case IM.method req of
135+ "GET" -> launchAff_ do
136+ -- Let's pretend this is answering slowly
137+ Aff.delay (100.0 # Milliseconds)
138+ void $ Stream.writeString outputStream UTF8 "ok" # liftEffect
139+ Stream.end outputStream # liftEffect
140+ _ ->
141+ unsafeCrashWith "Unexpected HTTP method"
142+ launchAff_ do
143+ Aff.delay (110.0 # Milliseconds)
144+ closeServer # liftEffect
145+
146+
147+ killServer :: forall transmissionType. HttpServer' transmissionType -> Effect Unit
148+ killServer s = do
149+ let ns = Server.toNetServer s
150+ closeAllConnections s
151+ NetServer.close ns