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