nixpkgs/pkgs/tools/networking/sproxy/new-http-kit.patch

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