224 lines
10 KiB
Diff
224 lines
10 KiB
Diff
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
|
|
|