sproxy: bump

This commit is contained in:
Shea Levy 2014-04-24 13:21:46 -04:00
parent c7f2d87a56
commit d4cb80eaf4
2 changed files with 240 additions and 13 deletions

View file

@ -1,33 +1,36 @@
{ cabal, aeson, attoparsec, caseInsensitive, certificate
, concurrentExtra, cryptoRandom, curl, dataDefault, hslogger, hspec
, HTTP, httpTypes, interpolatedstringPerl6, mtl, network
, optparseApplicative, postgresqlSimple, safe, SHA, split
, stringConversions, time, tls, unorderedContainers, utf8String
, x509, yaml, fetchurl
, concurrentExtra, conduit, connection, cryptoRandom, curl
, dataDefault, hslogger, hspec, httpConduit, httpKit, httpTypes
, interpolatedstringPerl6, mtl, network, optparseApplicative
, postgresqlSimple, safe, SHA, split, stringConversions, time, tls
, unorderedContainers, utf8String, wai, warp, x509, yaml, fetchurl
}:
cabal.mkDerivation (self: {
pname = "sproxy";
version = "0.7.4";
version = "0.8.0";
src = fetchurl {
url = "https://github.com/zalora/sproxy/archive/0.7.4.tar.gz";
sha256 = "1zlsln0ihg7p8jk5gdvm9as6gk4fs8vaa547iq2yvna4c1wb4amr";
url = "https://github.com/zalora/sproxy/archive/0.8.0.tar.gz";
sha256 = "11xn4k509ck73pacyz2kh0924n2vy8rwakwd42dwbvhhysf47rdx";
};
isLibrary = false;
isExecutable = true;
patches = [ ./new-http-kit.patch ];
doCheck = false;
buildDepends = [
aeson attoparsec caseInsensitive certificate concurrentExtra
cryptoRandom curl dataDefault hslogger HTTP httpTypes
cryptoRandom curl dataDefault hslogger httpKit httpTypes
interpolatedstringPerl6 mtl network optparseApplicative
postgresqlSimple safe SHA split stringConversions time tls
unorderedContainers utf8String x509 yaml
];
testDepends = [
aeson attoparsec caseInsensitive certificate concurrentExtra
cryptoRandom curl dataDefault hslogger hspec HTTP httpTypes
interpolatedstringPerl6 mtl network optparseApplicative
postgresqlSimple safe SHA split stringConversions time tls
unorderedContainers utf8String x509 yaml
conduit connection cryptoRandom curl dataDefault hslogger hspec
httpConduit httpKit httpTypes interpolatedstringPerl6 mtl network
optparseApplicative postgresqlSimple safe SHA split
stringConversions time tls unorderedContainers utf8String wai warp
x509 yaml
];
meta = {
license = self.stdenv.lib.licenses.mit;

View file

@ -0,0 +1,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