1+ module Test.HTTP where
2+
3+ import Prelude
4+
5+ import Data.Either (Either (..))
6+ import Data.Foldable (foldMap )
7+ import Data.Maybe (Maybe (..), fromMaybe )
8+ import Data.Options (Options , options , (:=))
9+ import Data.Tuple (Tuple (..))
10+ import Effect (Effect )
11+ import Effect.Console (log , logShow )
12+ import Effect.Exception (Error )
13+ import Foreign.Object (fromFoldable , lookup )
14+ import Node.Encoding (Encoding (..))
15+ import Node.HTTP (Request , Response , close , createServer , listen , onRequest , onUpgrade , requestAsStream , requestHeaders , requestMethod , requestURL , responseAsStream , setHeader , setStatusCode )
16+ import Node.HTTP.Client as Client
17+ import Node.HTTP.Secure as HTTPS
18+ import Node.Net.Socket as Socket
19+ import Node.Process as Node.Process
20+ import Node.Stream (end , pipe , writeString )
21+ import Partial.Unsafe (unsafeCrashWith )
22+ import Test.MockCert (cert , key )
23+ import Unsafe.Coerce (unsafeCoerce )
24+
25+ respond :: Request -> Response -> Effect Unit
26+ respond req res = do
27+ setStatusCode res 200
28+ let
29+ inputStream = requestAsStream req
30+ outputStream = responseAsStream res
31+ log (requestMethod req <> " "
32+ case requestMethod req of
33+ " GET" -> do
34+ let
35+ html = foldMap (_ <> " \n "
36+ [ " <form method='POST' action='/'>"
37+ , " <input name='text' type='text'>"
38+ , " <input type='submit'>"
39+ , " </form>"
40+ ]
41+ setHeader res " Content-Type" " text/html"
42+ _ <- writeString outputStream UTF8 html mempty
43+ end outputStream (const $ pure unit)
44+ " POST" -> void $ pipe inputStream outputStream
45+ _ -> unsafeCrashWith " Unexpected HTTP method"
46+
47+ testBasic :: (Either Error Unit -> Effect Unit ) -> Effect Unit
48+ testBasic complete = do
49+ server <- createServer \_ _ -> pure unit
50+ onRequest server \req res -> do
51+ respond req res
52+ close server $ complete (Right unit)
53+ listen server { hostname: " localhost" 8080 Nothing } do
54+ log " Listening on port 8080."
55+ simpleReq " http://localhost:8080"
56+
57+ testHttpsServer :: Effect Unit
58+ testHttpsServer = do
59+ server <- HTTPS .createServer sslOpts respond
60+ listen server { hostname: " localhost" 8081 Nothing } $ void do
61+ log " Listening on port 8081."
62+ complexReq $
63+ Client .protocol := " https:"
64+ <> Client .method := " GET"
65+ <> Client .hostname := " localhost"
66+ <> Client .port := 8081
67+ <> Client .path := " /"
68+ <>
69+ Client .rejectUnauthorized := false
70+ where
71+ sslOpts =
72+ HTTPS .key := HTTPS .keyString key <>
73+ HTTPS .cert := HTTPS .certString cert
74+
75+ testHttps :: Effect Unit
76+ testHttps =
77+ simpleReq " https://pursuit.purescript.org/packages/purescript-node-http/badge"
78+
79+ testCookies :: Effect Unit
80+ testCookies =
81+ simpleReq
82+ " https://httpbin.org/cookies/set?cookie1=firstcookie&cookie2=secondcookie"
83+
84+ simpleReq :: String -> Effect Unit
85+ simpleReq uri = do
86+ log (" GET " " :"
87+ req <- Client .requestFromURI uri logResponse
88+ end (Client .requestAsStream req) (const $ pure unit)
89+
90+ complexReq :: Options Client.RequestOptions -> Effect Unit
91+ complexReq opts = do
92+ log $ optsR.method <> " " " //" " :" " :"
93+ req <- Client .request opts logResponse
94+ end (Client .requestAsStream req) (const $ pure unit)
95+ where
96+ optsR = unsafeCoerce $ options opts
97+
98+ logResponse :: Client.Response -> Effect Unit
99+ logResponse response = void do
100+ log " Headers:"
101+ logShow $ Client .responseHeaders response
102+ log " Cookies:"
103+ logShow $ Client .responseCookies response
104+ log " Response:"
105+ let responseStream = Client .responseAsStream response
106+ pipe responseStream Node.Process .stdout
107+
108+ testUpgrade :: Effect Unit
109+ testUpgrade = do
110+ server <- createServer respond
111+ onUpgrade server handleUpgrade
112+ listen server { hostname: " localhost" 3000 Nothing }
113+ $ void do
114+ log " Listening on port 3000."
115+ sendRequests
116+ where
117+ handleUpgrade req socket _ = do
118+ let upgradeHeader = fromMaybe " " " upgrade"
119+ if upgradeHeader == " websocket" then
120+ void
121+ $ Socket .writeString
122+ socket
123+ " HTTP/1.1 101 Switching Protocols\r\n Content-Length: 0\r\n\r\n "
124+ UTF8
125+ $ pure unit
126+ else
127+ void
128+ $ Socket .writeString
129+ socket
130+ " HTTP/1.1 426 Upgrade Required\r\n Content-Length: 0\r\n\r\n "
131+ UTF8
132+ $ pure unit
133+
134+ sendRequests = do
135+ -- This tests that the upgrade callback is not called when the request is not an HTTP upgrade
136+ reqSimple <- Client .request (Client .port := 3000 -> do
137+ if (Client .statusCode response /= 200 then
138+ unsafeCrashWith " Unexpected response to simple request on `testUpgrade`"
139+ else
140+ pure unit
141+ end (Client .requestAsStream reqSimple) (const $ pure unit)
142+ {-
143+ These two requests test that the upgrade callback is called and that it has
144+ access to the original request and can write to the underlying TCP socket
145+ -}
146+ let
147+ headers = Client.RequestHeaders $ fromFoldable
148+ [ Tuple " Connection" " upgrade"
149+ , Tuple " Upgrade" " something"
150+ ]
151+ reqUpgrade <- Client .request
152+ (Client .port := 3000 Client .headers := headers)
153+ \response -> do
154+ if (Client .statusCode response /= 426 then
155+ unsafeCrashWith " Unexpected response to upgrade request on `testUpgrade`"
156+ else
157+ pure unit
158+ end (Client .requestAsStream reqUpgrade) (const $ pure unit)
159+
160+ let
161+ wsHeaders = Client.RequestHeaders $ fromFoldable
162+ [ Tuple " Connection" " upgrade"
163+ , Tuple " Upgrade" " websocket"
164+ ]
165+
166+ reqWSUpgrade <- Client .request
167+ (Client .port := 3000 Client .headers := wsHeaders)
168+ \response -> do
169+ if (Client .statusCode response /= 101 then
170+ unsafeCrashWith " Unexpected response to websocket upgrade request on `testUpgrade`"
171+ else
172+ pure unit
173+ end (Client .requestAsStream reqWSUpgrade) (const $ pure unit)
174+ pure unit
0 commit comments