1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
|
From 383d2cbe240600a86ab99fdefcea4e913d171ec6 Mon Sep 17 00:00:00 2001
From: Simon Hengel <sol@typeful.net>
Date: Thu, 24 Apr 2014 22:51:02 +0800
Subject: [PATCH] Depend on http-kit >= 0.2
---
sproxy.cabal | 2 +-
src/Authenticate.hs | 17 ++++++++---------
src/HTTP.hs | 47 +++++++++--------------------------------------
src/Proxy.hs | 32 ++++++++++++++------------------
4 files changed, 32 insertions(+), 66 deletions(-)
diff --git a/sproxy.cabal b/sproxy.cabal
index 08e1d61..91adf5d 100644
--- a/sproxy.cabal
+++ b/sproxy.cabal
@@ -49,7 +49,7 @@ executable sproxy
unix,
utf8-string,
x509,
- http-kit,
+ http-kit >= 0.2,
yaml >= 0.8
default-language: Haskell2010
ghc-options: -Wall -threaded -O2
diff --git a/src/Authenticate.hs b/src/Authenticate.hs
index 7d4c218..15a69a9 100644
--- a/src/Authenticate.hs
+++ b/src/Authenticate.hs
@@ -30,8 +30,7 @@ import System.Posix.Types (EpochTime)
import System.Posix.Time (epochTime)
import Data.Digest.Pure.SHA (hmacSha1, showDigest)
-import Network.HTTP.Toolkit.Header
-import Network.HTTP.Toolkit.Request
+import Network.HTTP.Toolkit
import Type
import Cookies
@@ -90,19 +89,19 @@ instance FromJSON UserInfo where
-- https://wiki.zalora.com/Main_Page -> https://wiki.zalora.com/
-- Note that this always uses https:
-rootURI :: RequestHeader -> URI.URI
-rootURI (MessageHeader _ headers) =
+rootURI :: Request a -> URI.URI
+rootURI (Request _ _ headers _) =
let host = cs $ fromMaybe (error "Host header not found") $ lookup "Host" headers
in URI.URI "https:" (Just $ URI.URIAuth "" host "") "/" "" ""
-redirectForAuth :: AuthConfig -> RequestHeader -> SendData -> IO ()
-redirectForAuth c request@(MessageHeader (_, path_) _) send = do
+redirectForAuth :: AuthConfig -> Request a -> SendData -> IO ()
+redirectForAuth c request@(Request _ path_ _ _) send = do
let redirectUri = rootURI request
path = urlEncode True path_
authURL = "https://accounts.google.com/o/oauth2/auth?scope=https%3A%2F%2Fwww.googleapis.com%2Fauth%2Fuserinfo.email+https%3A%2F%2Fwww.googleapis.com%2Fauth%2Fuserinfo.profile&state=" ++ cs path ++ "&redirect_uri=" ++ (cs $ show $ redirectUri) ++ "&response_type=code&client_id=" ++ authConfigClientID c ++ "&approval_prompt=force&access_type=offline"
- sendResponse send found302 [("Location", UTF8.fromString $ authURL)] ""
+ sendResponse_ send found302 [("Location", UTF8.fromString $ authURL)] ""
-authenticate :: AuthConfig -> SendData -> RequestHeader -> ByteString -> ByteString -> IO ()
+authenticate :: AuthConfig -> SendData -> Request a -> ByteString -> ByteString -> IO ()
authenticate config send request path code = do
tokenRes <- post "https://accounts.google.com/o/oauth2/token" ["code=" ++ UTF8.toString code, "client_id=" ++ clientID, "client_secret=" ++ clientSecret, "redirect_uri=" ++ (cs $ show $ rootURI request), "grant_type=authorization_code"]
case tokenRes of
@@ -121,7 +120,7 @@ authenticate config send request path code = do
Just userInfo -> do
clientToken <- authToken authTokenKey (userEmail userInfo) (userGivenName userInfo, userFamilyName userInfo)
let cookie = setCookie cookieDomain cookieName (show clientToken) authShelfLife
- sendResponse send found302 [("Location", cs $ (show $ (rootURI request) {URI.uriPath = ""}) ++ cs (urlDecode False path)), ("Set-Cookie", UTF8.fromString cookie)] ""
+ sendResponse_ send found302 [("Location", cs $ (show $ (rootURI request) {URI.uriPath = ""}) ++ cs (urlDecode False path)), ("Set-Cookie", UTF8.fromString cookie)] ""
where
cookieDomain = authConfigCookieDomain config
cookieName = authConfigCookieName config
diff --git a/src/HTTP.hs b/src/HTTP.hs
index 07038a0..dbcae71 100644
--- a/src/HTTP.hs
+++ b/src/HTTP.hs
@@ -1,19 +1,14 @@
{-# LANGUAGE OverloadedStrings #-}
module HTTP (
- sendRequest
-, sendResponse
-, sendResponse_
+ sendResponse_
, internalServerError
) where
-import Data.Foldable (forM_)
import Data.ByteString (ByteString)
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Char8 as B8
-import qualified Data.ByteString.UTF8 as UTF8
-import qualified Data.CaseInsensitive as CI
+import qualified Data.ByteString.Char8 as B
import Network.HTTP.Types
-import Network.HTTP.Toolkit.Body
+import Network.HTTP.Toolkit
+import qualified Network.HTTP.Toolkit.Body as Body
import Type
import qualified Log
@@ -21,34 +16,10 @@ import qualified Log
internalServerError :: SendData -> String -> IO ()
internalServerError send err = do
Log.debug $ show err
- sendResponse send internalServerError500 [] "Internal Server Error"
+ sendResponse_ send internalServerError500 [] "Internal Server Error"
-sendRequest :: SendData -> Method -> ByteString -> [Header] -> BodyReader -> IO ()
-sendRequest send method path headers body = do
- sendHeader send startLine headers
- sendBody send body
+sendResponse_ :: SendData -> Status -> [Header] -> ByteString -> IO ()
+sendResponse_ send status headers_ body = do
+ Body.fromByteString body >>= sendResponse send . Response status headers
where
- startLine = B8.unwords [method, path, "HTTP/1.1"]
-
-sendResponse :: SendData -> Status -> [Header] -> ByteString -> IO ()
-sendResponse send status headers_ body = do
- sendHeader send (statusLine status) headers
- send body
- where
- headers = ("Content-Length", UTF8.fromString $ show $ B.length body) : headers_
-
-sendResponse_ :: SendData -> Status -> [Header] -> BodyReader -> IO ()
-sendResponse_ send status headers body = do
- sendHeader send (statusLine status) headers
- sendBody send body
-
-statusLine :: Status -> ByteString
-statusLine status = B.concat ["HTTP/1.1 ", UTF8.fromString $ show (statusCode status), " ", statusMessage status]
-
-sendHeader :: SendData -> ByteString -> [Header] -> IO ()
-sendHeader send startLine headers = do
- send startLine
- send "\r\n"
- forM_ headers $ \(k, v) -> do
- send $ B.concat [CI.original k, ": ", v, "\r\n"]
- send "\r\n"
+ headers = ("Content-Length", B.pack . show . B.length $ body) : headers_
diff --git a/src/Proxy.hs b/src/Proxy.hs
index aa320af..88b95d9 100644
--- a/src/Proxy.hs
+++ b/src/Proxy.hs
@@ -32,11 +32,7 @@ import qualified Network.URI as URI
import Options.Applicative hiding (action)
import System.IO
-import Network.HTTP.Toolkit.Body
-import Network.HTTP.Toolkit.Header
-import Network.HTTP.Toolkit.Connection
-import Network.HTTP.Toolkit.Request
-import Network.HTTP.Toolkit.Response
+import Network.HTTP.Toolkit
import Type
import Util
@@ -142,10 +138,10 @@ runProxy port config authConfig authorize = (listen port (serve config authConfi
redirectToHttps :: SockAddr -> Socket -> IO ()
redirectToHttps _ sock = do
conn <- makeConnection (Socket.recv sock 4096)
- (request, _) <- readRequest conn
- sendResponse (Socket.sendAll sock) seeOther303 [("Location", cs $ show $ requestURI request)] ""
+ request <- readRequest conn
+ sendResponse_ (Socket.sendAll sock) seeOther303 [("Location", cs $ show $ requestURI request)] ""
where
- requestURI (MessageHeader (_, path) headers) =
+ requestURI (Request _ path headers _) =
let host = fromMaybe (error "Host header not found") $ lookup "Host" headers
in fromJust $ URI.parseURI $ "https://" ++ cs host ++ cs path
@@ -171,8 +167,8 @@ serve config authConfig withAuthorizeAction addr sock = do
serve_ send conn authorize = go
where
go :: IO ()
- go = forever $ readRequest conn >>= \(request, body) -> case request of
- MessageHeader (_, url) headers -> do
+ go = forever $ readRequest conn >>= \request -> case request of
+ Request _ url headers _ -> do
-- TODO: Don't loop for more input on Connection: close header.
-- Check if this is an authorization response.
case URI.parseURIReference $ BU.toString url of
@@ -192,17 +188,17 @@ serve config authConfig withAuthorizeAction addr sock = do
case auth of
Nothing -> redirectForAuth authConfig request send
Just token -> do
- forwardRequest config send authorize cookies addr request body token
+ forwardRequest config send authorize cookies addr request token
-- Check our access control list for this user's request and forward it to the backend if allowed.
-forwardRequest :: Config -> SendData -> AuthorizeAction -> [(Name, Cookies.Value)] -> SockAddr -> RequestHeader -> BodyReader -> AuthToken -> IO ()
-forwardRequest config send authorize cookies addr (MessageHeader (method, path) headers) body token = do
+forwardRequest :: Config -> SendData -> AuthorizeAction -> [(Name, Cookies.Value)] -> SockAddr -> Request BodyReader -> AuthToken -> IO ()
+forwardRequest config send authorize cookies addr request@(Request method path headers _) token = do
groups <- authorize (authEmail token) (maybe (error "No Host") cs $ lookup "Host" headers) path method
ip <- formatSockAddr addr
case groups of
[] -> do
-- TODO: Send back a page that allows the user to request authorization.
- sendResponse send forbidden403 [] "Access Denied"
+ sendResponse_ send forbidden403 [] "Access Denied"
_ -> do
-- TODO: Reuse connections to the backend server.
let downStreamHeaders =
@@ -216,10 +212,10 @@ forwardRequest config send authorize cookies addr (MessageHeader (method, path)
setCookies $
fromList headers
bracket (connectTo host port) hClose $ \h -> do
- sendRequest (B.hPutStr h) method path downStreamHeaders body
- conn <- makeConnection (B.hGetSome h 4096)
- (MessageHeader status responseHeaders, responseBody) <- readResponse method conn
- sendResponse_ send status (removeConnectionHeader responseHeaders) responseBody
+ sendRequest (B.hPutStr h) request{requestHeaders = downStreamHeaders}
+ conn <- connectionFromHandle h
+ response <- readResponse method conn
+ sendResponse send response{responseHeaders = removeConnectionHeader (responseHeaders response)}
where
host = configBackendAddress config
port = PortNumber (configBackendPort config)
--
1.9.1
|