From 383d2cbe240600a86ab99fdefcea4e913d171ec6 Mon Sep 17 00:00:00 2001 From: Simon Hengel 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