HTTP-4000.3.3/0000755000000000000000000000000012656464615010725 5ustar0000000000000000HTTP-4000.3.3/LICENSE0000644000000000000000000000375312656464615011742 0ustar0000000000000000Copyright (c) 2002, Warrick Gray Copyright (c) 2002-2005, Ian Lynagh Copyright (c) 2003-2006, Bjorn Bringert Copyright (c) 2004, Andre Furtado Copyright (c) 2004-2005, Dominic Steinitz Copyright (c) 2007, Robin Bate Boerop Copyright (c) 2008-2010, Sigbjorn Finne Copyright (c) 2009, Eric Kow Copyright (c) 2010, Antoine Latter Copyright (c) 2004, 2010-2011, Ganesh Sittampalam Copyright (c) 2011, Duncan Coutts Copyright (c) 2011, Matthew Gruen Copyright (c) 2011, Jeremy Yallop Copyright (c) 2011, Eric Hesselink Copyright (c) 2011, Yi Huang Copyright (c) 2011, Tom Lokhorst All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * The names of contributors may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. HTTP-4000.3.3/HTTP.cabal0000644000000000000000000001227012656464615012472 0ustar0000000000000000Name: HTTP Version: 4000.3.3 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3 License-file: LICENSE Author: Warrick Gray Maintainer: Ganesh Sittampalam Homepage: https://github.com/haskell/HTTP Category: Network Synopsis: A library for client-side HTTP Description: The HTTP package supports client-side web programming in Haskell. It lets you set up HTTP connections, transmitting requests and processing the responses coming back, all from within the comforts of Haskell. It's dependent on the network package to operate, but other than that, the implementation is all written in Haskell. . A basic API for issuing single HTTP requests + receiving responses is provided. On top of that, a session-level abstraction is also on offer (the @BrowserAction@ monad); it taking care of handling the management of persistent connections, proxies, state (cookies) and authentication credentials required to handle multi-step interactions with a web server. . The representation of the bytes flowing across is extensible via the use of a type class, letting you pick the representation of requests and responses that best fits your use. Some pre-packaged, common instances are provided for you (@ByteString@, @String@). . Here's an example use: . > > do > rsp <- Network.HTTP.simpleHTTP (getRequest "http://www.haskell.org/") > -- fetch document and return it (as a 'String'.) > fmap (take 100) (getResponseBody rsp) > > do > (_, rsp) > <- Network.Browser.browse $ do > setAllowRedirects True -- handle HTTP redirects > request $ getRequest "http://www.haskell.org/" > return (take 100 (rspBody rsp)) Extra-Source-Files: CHANGES Source-Repository head type: git location: https://github.com/haskell/HTTP.git Flag mtl1 description: Use the old mtl version 1. default: False Flag warn-as-error default: False description: Build with warnings-as-errors manual: True Flag network23 description: Use version 2.3.x or below of the network package default: False Flag conduit10 description: Use version 1.0.x or below of the conduit package (for the test suite) default: False Flag warp-tests description: Test against warp default: True manual: True flag network-uri description: Get Network.URI from the network-uri package default: True Library Exposed-modules: Network.BufferType, Network.Stream, Network.StreamDebugger, Network.StreamSocket, Network.TCP, Network.HTTP, Network.HTTP.Headers, Network.HTTP.Base, Network.HTTP.Stream, Network.HTTP.Auth, Network.HTTP.Cookie, Network.HTTP.Proxy, Network.HTTP.HandleStream, Network.Browser Other-modules: Network.HTTP.Base64, Network.HTTP.MD5Aux, Network.HTTP.Utils Paths_HTTP GHC-options: -fwarn-missing-signatures -Wall -- note the test harness constraints should be kept in sync with these -- where dependencies are shared Build-depends: base >= 4.3.0.0 && < 4.10, parsec >= 2.0 && < 3.2 Build-depends: array >= 0.3.0.2 && < 0.6, bytestring >= 0.9.1.5 && < 0.11 Build-depends: time >= 1.1.2.3 && < 1.7 Extensions: FlexibleInstances if flag(mtl1) Build-depends: mtl >= 1.1.1.0 && < 1.2 CPP-Options: -DMTL1 else Build-depends: mtl >= 2.0 && < 2.3 if flag(network-uri) Build-depends: network-uri == 2.6.*, network == 2.6.* else Build-depends: network >= 2.2.1.8 && < 2.6 if flag(warn-as-error) ghc-options: -Werror if os(windows) Build-depends: Win32 >= 2.2.0.0 && < 2.4 Test-Suite test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: httpTests.hs other-modules: Httpd UnitTests -- note: version constraints for dependencies shared with the library -- should be the same build-depends: HTTP, HUnit >= 1.2.0.1 && < 1.4, httpd-shed >= 0.4 && < 0.5, mtl >= 1.1.1.0 && < 2.3, bytestring >= 0.9.1.5 && < 0.11, deepseq >= 1.3.0.0 && < 1.5, pureMD5 >= 0.2.4 && < 2.2, base >= 4.3.0.0 && < 4.10, split >= 0.1.3 && < 0.3, test-framework >= 0.2.0 && < 0.9, test-framework-hunit >= 0.3.0 && <0.4 if flag(network-uri) Build-depends: network-uri == 2.6.*, network == 2.6.* else Build-depends: network >= 2.2.1.5 && < 2.6 if flag(warp-tests) CPP-Options: -DWARP_TESTS build-depends: case-insensitive >= 0.4.0.1 && < 1.3, http-types >= 0.8.0 && < 1.0, wai >= 2.1.0 && < 3.3, warp >= 2.1.0 && < 3.3 if flag(conduit10) build-depends: conduit >= 1.0.8 && < 1.1 else build-depends: conduit >= 1.1 && < 1.3, conduit-extra >= 1.1 && < 1.2 HTTP-4000.3.3/CHANGES0000644000000000000000000001240012656464615011715 0ustar0000000000000000 * If the URI contains "user:pass@" part, use it for Basic Authorization * Add a test harness. * Don't leak a socket when getHostAddr throws an exception. * Send cookies in request format, not response format. * Moved BrowserAction to be a StateT IO, with instances for Applicative, MonadIO, MonadState. * Add method to control size of connection pool. * Consider both host and port when reusing connections. * Handle response code 304 "not modified" properly. * Fix digest authentication by fixing md5 output string rep. * Make the default user agent string follow the package version. * Document lack of HTTPS support and fail when clients try to use it instead of silently falling back to HTTP. * Add helper to set the request type and body. Version 4000.1.2: release 2011-08-11 * Turn off buffering for the debug log. * Update installation instructions. * Bump base dependency to support GHC 7.2. Version 4000.1.1: release 2010-11-28 * Be tolerant of LF (instead of CRLF which is the spec) in responses. Version 4000.1.0: release 2010-11-09 * Retroactively fixed CHANGES to refer to 4000.x.x instead of 4004.x.x. * Fix problem with close looping on certain URLs due to trying to munch the rest of the stream even on EOF. Modified from a fix by Daniel Wagner. * This involves a new class member for HStream and is thus an API change, but one that will only affect clients that define their own payload type to replace String/ByteString. * Applied patch by Antoine Latter to fix problem with 301 and 307 redirects. Version 4000.0.10: release 2010-10-29 * Bump base dependency to support GHC 7.0. * Stop using 'fail' from the Either monad and instead build Left values explicitly; the behaviour of fail is changing in GHC 7.0 and this avoids being sensitive to the change. Version 4000.0.9: release 2009-12-20 * Export headerMap from Network.HTTP.Headers (suggested by David Leuschner.) * Fix Network.TCP.{isTCPConnectedTo,isConnectedTo} to be useful. * Always delay closing non-persistent connections until we reach EOF. Delaying it until then is vital when reading the response out as a lazy ByteString; all of the I/O may not have happened by the time we were returning the HTTP response. Bug manifested itself occasionally with larger responses. Courtesy of Valery Vorotyntsev; both untiring bug hunt and fix. * drop unused type argument from Network.Browser.BrowserEvent; needlessly general. (patch provided by Daniel Wagner.) Version 4000.0.8: release 2009-08-05 * Incorporated proxy setting lookup and parsing contribution by Eric Kow; provided in Network.HTTP.Proxy * Factor out HTTP Cookies and Auth handling into separate modules Network.HTTP.Cookie, Network.HTTP.Auth * new Network.Browser functionality for hooking up the proxy detection code in Network.HTTP.Proxy: setCheckForProxy :: Bool -> BrowserAction t () getCheckForProxy :: BrowserAction t Bool If you do 'setCheckForProxy True' within a browser session, the proxy-checking code will be called upon. Use 'getCheckForProxy' to get the current setting for this flag. * Network.Browser: if HTTP Basic Auth is allowed and server doesn't 401-challenge with an WWW-Authenticate: header, simply assume / realm and proceed. Preferable than failing, even if server is the wrong. Version 4000.0.7: release 2009-05-22 * Minor release. * Added Network.TCP.openSocketStream :: (BufferType t) => String {-host-} -> Socket -> IO (HandleStream t) for interfacing to pre-existing @Socket@s. Contributed and suggested by . Version 4000.0.6: release 2009-04-21; changes from 4000.0.5 * Network.Browser: use HTTP.HandleStream.sendHTTP_notify, not HTTP.sendHTTP_notify when issuing requests. The latter runs the risk of undoing request normalization. * Network.HTTP.Base.normalizeRequest: when normalizing proxy-bound requests, insert a Host: header if none present. Set it to the destination server authority, not the proxy. * Network.Browser: don't fail on seeing invalid cookie values, but report them as errors and continue. Version 4000.0.5: release 2009-03-30; changes from 4000.0.4 * Get serious about comments and Haddock documentation. * Cleaned up normalization of requests, fixing bugs and bringing together previous disparate attempts at handling this. * RequestMethod now supports custom verbs; use the (Custom String) constructor * Beef up Network.HTTP.Base's support for normalizing requests and URIs: * added splitRequestURI which divides a URI into two; the Authority portion (as a String) and the input URI sans the authority portion. Useful when wanting to split up a request's URI into its Host: and abs_path pieces. * added normalizeRequest :: Bool -> Request ty -> Request ty, which fixes up a requests URI path and Host: info depending on whether it is destined for a proxy or not (controlled by the Bool.) * moved defaultRequest, defaultRequest_, libUA from Network.Browser to Network.HTTP.Base * added mkRequest :: RequestMethod -> URI -> Bool -> Request ty for constructing normalized&sane Request bases on top of which you can add custom headers, body payload etc. HTTP-4000.3.3/Setup.lhs0000644000000000000000000000015712656464615012540 0ustar0000000000000000#!/usr/bin/env runghc > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain HTTP-4000.3.3/test/0000755000000000000000000000000012656464615011704 5ustar0000000000000000HTTP-4000.3.3/test/Httpd.hs0000644000000000000000000001154412656464615013330 0ustar0000000000000000{-# LANGUAGE CPP #-} module Httpd ( Request, Response, Server , mkResponse , reqMethod, reqURI, reqHeaders, reqBody , shed #ifdef WARP_TESTS , warp #endif ) where import Control.Applicative import Control.Arrow ( (***) ) import Control.DeepSeq import Control.Monad import Control.Monad.Trans ( liftIO ) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy.Char8 as BLC #ifdef WARP_TESTS import qualified Data.CaseInsensitive as CI #endif import Data.Maybe ( fromJust ) import Network.URI ( URI, parseRelativeReference ) import Network.Socket ( getAddrInfo, AddrInfo, defaultHints, addrAddress, addrFamily , addrFlags, addrSocketType, AddrInfoFlag(AI_PASSIVE), socket, Family(AF_UNSPEC,AF_INET6) , defaultProtocol, SocketType(Stream), listen, setSocketOption, SocketOption(ReuseAddr) ) #ifdef WARP_TESTS #if MIN_VERSION_network(2,4,0) import Network.Socket ( bind ) #else import Network.Socket ( bindSocket, Socket, SockAddr ) #endif #endif import qualified Network.Shed.Httpd as Shed ( Request, Response(Response), initServer , reqMethod, reqURI, reqHeaders, reqBody ) #ifdef WARP_TESTS #if !MIN_VERSION_wai(3,0,0) import qualified Data.Conduit.Lazy as Warp #endif import qualified Network.HTTP.Types as Warp ( Status(..) ) import qualified Network.Wai as Warp import qualified Network.Wai.Handler.Warp as Warp ( runSettingsSocket, defaultSettings, setPort ) #endif data Request = Request { reqMethod :: String, reqURI :: URI, reqHeaders :: [(String, String)], reqBody :: String } data Response = Response { respStatus :: Int, respHeaders :: [(String, String)], respBody :: String } mkResponse :: Int -> [(String, String)] -> String -> Response mkResponse = Response type Server = Int -> (Request -> IO Response) -> IO () shed :: Server shed port handler = () <$ Shed.initServer port (liftM responseToShed . handler . requestFromShed) where responseToShed (Response status hdrs body) = Shed.Response status hdrs body chomp = reverse . strip '\r' . reverse strip c (c':str) | c == c' = str strip c str = str requestFromShed request = Request { reqMethod = Shed.reqMethod request, reqURI = Shed.reqURI request, reqHeaders = map (id *** chomp) $ Shed.reqHeaders request, reqBody = Shed.reqBody request } #if !MIN_VERSION_bytestring(0,10,0) instance NFData B.ByteString where rnf = rnf . B.length #endif #ifdef WARP_TESTS #if !MIN_VERSION_network(2,4,0) bind :: Socket -> SockAddr -> IO () bind = bindSocket #endif warp :: Bool -> Server warp ipv6 port handler = do addrinfos <- getAddrInfo (Just $ defaultHints { addrFamily = AF_UNSPEC, addrSocketType = Stream }) (Just $ if ipv6 then "::1" else "127.0.0.1") (Just . show $ port) case addrinfos of [] -> fail "Couldn't obtain address information in warp" (addri:_) -> do sock <- socket (addrFamily addri) Stream defaultProtocol setSocketOption sock ReuseAddr 1 bind sock (addrAddress addri) listen sock 5 #if MIN_VERSION_wai(3,0,0) Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest warpRespond -> do request <- requestFromWarp warpRequest response <- handler request warpRespond (responseToWarp response) #else Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest -> do request <- requestFromWarp warpRequest response <- handler request return (responseToWarp response) #endif where responseToWarp (Response status hdrs body) = Warp.responseLBS (Warp.Status status B.empty) (map headerToWarp hdrs) (BLC.pack body) headerToWarp (name, value) = (CI.mk (BC.pack name), BC.pack value) headerFromWarp (name, value) = (BC.unpack (CI.original name), BC.unpack value) requestFromWarp request = do #if MIN_VERSION_wai(3,0,1) body <- fmap BLC.unpack $ Warp.strictRequestBody request #else body <- fmap BLC.unpack $ Warp.lazyRequestBody request body `deepseq` return () #endif return $ Request { reqMethod = BC.unpack (Warp.requestMethod request), reqURI = fromJust . parseRelativeReference . BC.unpack . Warp.rawPathInfo $ request, reqHeaders = map headerFromWarp (Warp.requestHeaders request), reqBody = body } #endif HTTP-4000.3.3/test/UnitTests.hs0000644000000000000000000000177512656464615014214 0ustar0000000000000000module UnitTests ( unitTests ) where import Network.HTTP.Base import Network.URI import Data.Maybe ( fromJust ) import Test.Framework ( testGroup ) import Test.Framework.Providers.HUnit import Test.HUnit parseIPv4Address :: Assertion parseIPv4Address = assertEqual "127.0.0.1 address is recognised" (Just (URIAuthority {user = Nothing, password = Nothing, host = "127.0.0.1", port = Just 5313})) (parseURIAuthority (uriToAuthorityString (fromJust (parseURI "http://127.0.0.1:5313/foo")))) parseIPv6Address :: Assertion parseIPv6Address = assertEqual "::1 address" (Just (URIAuthority {user = Nothing, password = Nothing, host = "::1", port = Just 5313})) (parseURIAuthority (uriToAuthorityString (fromJust (parseURI "http://[::1]:5313/foo")))) unitTests = [testGroup "Unit tests" [ testGroup "URI parsing" [ testCase "Parse IPv4 address" parseIPv4Address , testCase "Parse IPv6 address" parseIPv6Address ] ] ] HTTP-4000.3.3/test/httpTests.hs0000644000000000000000000006632612656464615014257 0ustar0000000000000000{-# LANGUAGE ImplicitParams, ViewPatterns, NoMonomorphismRestriction, CPP #-} import Control.Concurrent import Control.Applicative ((<$)) import Control.Concurrent (threadDelay) import Control.Exception (try) import qualified Data.ByteString.Lazy.Char8 as BL (pack) import Data.Char (isSpace) import qualified Data.Digest.Pure.MD5 as MD5 (md5) import Data.List.Split (splitOn) import Data.Maybe (fromJust) import System.IO.Error (userError) import qualified Httpd import qualified UnitTests import Network.Browser import Network.HTTP import Network.HTTP.Base import Network.HTTP.Auth import Network.HTTP.Headers import Network.Stream (Result) import Network.URI (uriPath, parseURI) import System.Environment (getArgs) import System.Info (os) import System.IO (getChar) import Test.Framework (defaultMainWithArgs, testGroup) import Test.Framework.Providers.HUnit import Test.HUnit basicGetRequest :: (?testUrl :: ServerAddress) => Assertion basicGetRequest = do response <- simpleHTTP (getRequest (?testUrl "/basic/get")) code <- getResponseCode response assertEqual "HTTP status code" (2, 0, 0) code body <- getResponseBody response assertEqual "Receiving expected response" "It works." body basicGetRequestLBS :: (?testUrl :: ServerAddress) => Assertion basicGetRequestLBS = do response <- simpleHTTP (mkRequest GET (fromJust (parseURI (?testUrl ("/basic/get"))))) code <- getResponseCode response assertEqual "HTTP status code" (2, 0, 0) code body <- getResponseBody response assertEqual "Receiving expected response" (BL.pack "It works.") body basicHeadRequest :: (?testUrl :: ServerAddress) => Assertion basicHeadRequest = do response <- simpleHTTP (headRequest (?testUrl "/basic/head")) code <- getResponseCode response assertEqual "HTTP status code" (2, 0, 0) code body <- getResponseBody response -- the body should be empty, since this is a HEAD request assertEqual "Receiving expected response" "" body basicExample :: (?testUrl :: ServerAddress) => Assertion basicExample = do result <- -- sample code from Network.HTTP haddock, with URL changed -- Note there's also a copy of the example in the .cabal file simpleHTTP (getRequest (?testUrl "/basic/example")) >>= fmap (take 100) . getResponseBody assertEqual "Receiving expected response" (take 100 haskellOrgText) result secureGetRequest :: (?secureTestUrl :: ServerAddress) => Assertion secureGetRequest = do response <- try $ simpleHTTP (getRequest (?secureTestUrl "/anything")) assertEqual "Threw expected exception" (Left (userError "https not supported")) (fmap show response) -- fmap show because Response isn't in Eq basicPostRequest :: (?testUrl :: ServerAddress) => Assertion basicPostRequest = do let sendBody = "body" response <- simpleHTTP $ postRequestWithBody (?testUrl "/basic/post") "text/plain" sendBody code <- getResponseCode response assertEqual "HTTP status code" (2, 0, 0) code body <- getResponseBody response assertEqual "Receiving expected response" (show (Just "text/plain", Just "4", sendBody)) body userpwAuthFailure :: (?baduserpwUrl :: ServerAddress) => Assertion userpwAuthFailure = do response <- simpleHTTP (getRequest (?baduserpwUrl "/auth/basic")) code <- getResponseCode response body <- getResponseBody response assertEqual "HTTP status code" ((4, 0, 1), "Just \"Basic dGVzdDp3cm9uZ3B3ZA==\"") (code, body) -- in case of 401, the server returns the contents of the Authz header userpwAuthSuccess :: (?userpwUrl :: ServerAddress) => Assertion userpwAuthSuccess = do response <- simpleHTTP (getRequest (?userpwUrl "/auth/basic")) code <- getResponseCode response body <- getResponseBody response assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body) basicAuthFailure :: (?testUrl :: ServerAddress) => Assertion basicAuthFailure = do response <- simpleHTTP (getRequest (?testUrl "/auth/basic")) code <- getResponseCode response body <- getResponseBody response assertEqual "HTTP status code" ((4, 0, 1), "Nothing") (code, body) credentialsBasic :: (?testUrl :: ServerAddress) => Authority credentialsBasic = AuthBasic "Testing realm" "test" "password" (fromJust . parseURI . ?testUrl $ "/auth/basic") basicAuthSuccess :: (?testUrl :: ServerAddress) => Assertion basicAuthSuccess = do let req = getRequest (?testUrl "/auth/basic") let authString = withAuthority credentialsBasic req let reqWithAuth = req { rqHeaders = mkHeader HdrAuthorization authString:rqHeaders req } response <- simpleHTTP reqWithAuth code <- getResponseCode response body <- getResponseBody response assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body) utf8URLEncode :: Assertion utf8URLEncode = do assertEqual "Normal URL" (urlEncode "what-a_mess.com") "what-a_mess.com" assertEqual "Chinese URL" (urlEncode "好") "%E5%A5%BD" assertEqual "Russian URL" (urlEncode "ололо") "%D0%BE%D0%BB%D0%BE%D0%BB%D0%BE" utf8URLDecode :: Assertion utf8URLDecode = do assertEqual "Normal URL" (urlDecode "what-a_mess.com") "what-a_mess.com" assertEqual "Mixed URL" (urlDecode "UTFin进入-wow") "UTFin进入-wow" assertEqual "Chinese URL" (urlDecode "%E5%A5%BD") "好" assertEqual "Russian URL" (urlDecode "%D0%BE%D0%BB%D0%BE%D0%BB%D0%BE") "ололо" browserExample :: (?testUrl :: ServerAddress) => Assertion browserExample = do result <- -- sample code from Network.Browser haddock, with URL changed -- Note there's also a copy of the example in the .cabal file do (_, rsp) <- Network.Browser.browse $ do setAllowRedirects True -- handle HTTP redirects request $ getRequest (?testUrl "/browser/example") return (take 100 (rspBody rsp)) assertEqual "Receiving expected response" (take 100 haskellOrgText) result -- A vanilla HTTP request using Browser shouln't send a cookie header browserNoCookie :: (?testUrl :: ServerAddress) => Assertion browserNoCookie = do (_, response) <- browse $ do setOutHandler (const $ return ()) request $ getRequest (?testUrl "/browser/no-cookie") let code = rspCode response assertEqual "HTTP status code" (2, 0, 0) code -- Regression test -- * Browser sends vanilla request to server -- * Server sets one cookie "hello=world" -- * Browser sends a second request -- -- Expected: Server gets single cookie with "hello=world" -- Actual: Server gets 3 extra cookies, which are actually cookie attributes: -- "$Version=0;hello=world;$Domain=localhost:8080\r" browserOneCookie :: (?testUrl :: ServerAddress) => Assertion browserOneCookie = do (_, response) <- browse $ do setOutHandler (const $ return ()) -- This first requests returns a single Set-Cookie: hello=world _ <- request $ getRequest (?testUrl "/browser/one-cookie/1") -- This second request should send a single Cookie: hello=world request $ getRequest (?testUrl "/browser/one-cookie/2") let body = rspBody response assertEqual "Receiving expected response" "" body let code = rspCode response assertEqual "HTTP status code" (2, 0, 0) code browserTwoCookies :: (?testUrl :: ServerAddress) => Assertion browserTwoCookies = do (_, response) <- browse $ do setOutHandler (const $ return ()) -- This first request returns two cookies _ <- request $ getRequest (?testUrl "/browser/two-cookies/1") -- This second request should send them back request $ getRequest (?testUrl "/browser/two-cookies/2") let body = rspBody response assertEqual "Receiving expected response" "" body let code = rspCode response assertEqual "HTTP status code" (2, 0, 0) code browserFollowsRedirect :: (?testUrl :: ServerAddress) => Int -> Assertion browserFollowsRedirect n = do (_, response) <- browse $ do setOutHandler (const $ return ()) request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get") assertEqual "Receiving expected response from server" ((2, 0, 0), "It works.") (rspCode response, rspBody response) browserReturnsRedirect :: (?testUrl :: ServerAddress) => Int -> Assertion browserReturnsRedirect n = do (_, response) <- browse $ do setOutHandler (const $ return ()) request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get") assertEqual "Receiving expected response from server" ((n `div` 100, n `mod` 100 `div` 10, n `mod` 10), "") (rspCode response, rspBody response) authGenBasic _ "Testing realm" = return $ Just ("test", "password") authGenBasic _ realm = fail $ "Unexpected realm " ++ realm browserBasicAuth :: (?testUrl :: ServerAddress) => Assertion browserBasicAuth = do (_, response) <- browse $ do setOutHandler (const $ return ()) setAuthorityGen authGenBasic request $ getRequest (?testUrl "/auth/basic") assertEqual "Receiving expected response from server" ((2, 0, 0), "Here's the secret") (rspCode response, rspBody response) authGenDigest _ "Digest testing realm" = return $ Just ("test", "digestpassword") authGenDigest _ realm = fail $ "Unexpected digest realm " ++ realm browserDigestAuth :: (?testUrl :: ServerAddress) => Assertion browserDigestAuth = do (_, response) <- browse $ do setOutHandler (const $ return ()) setAuthorityGen authGenDigest request $ getRequest (?testUrl "/auth/digest") assertEqual "Receiving expected response from server" ((2, 0, 0), "Here's the digest secret") (rspCode response, rspBody response) browserAlt :: (?altTestUrl :: ServerAddress) => Assertion browserAlt = do (response) <- browse $ do setOutHandler (const $ return ()) (_, response1) <- request $ getRequest (?altTestUrl "/basic/get") return response1 assertEqual "Receiving expected response from alternate server" ((2, 0, 0), "This is the alternate server.") (rspCode response, rspBody response) -- test that requests to multiple servers on the same host -- don't get confused with each other browserBoth :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion browserBoth = do (response1, response2) <- browse $ do setOutHandler (const $ return ()) (_, response1) <- request $ getRequest (?testUrl "/basic/get") (_, response2) <- request $ getRequest (?altTestUrl "/basic/get") return (response1, response2) assertEqual "Receiving expected response from main server" ((2, 0, 0), "It works.") (rspCode response1, rspBody response1) assertEqual "Receiving expected response from alternate server" ((2, 0, 0), "This is the alternate server.") (rspCode response2, rspBody response2) -- test that requests to multiple servers on the same host -- don't get confused with each other browserBothReversed :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion browserBothReversed = do (response1, response2) <- browse $ do setOutHandler (const $ return ()) (_, response2) <- request $ getRequest (?altTestUrl "/basic/get") (_, response1) <- request $ getRequest (?testUrl "/basic/get") return (response1, response2) assertEqual "Receiving expected response from main server" ((2, 0, 0), "It works.") (rspCode response1, rspBody response1) assertEqual "Receiving expected response from alternate server" ((2, 0, 0), "This is the alternate server.") (rspCode response2, rspBody response2) browserSecureRequest :: (?secureTestUrl :: ServerAddress) => Assertion browserSecureRequest = do res <- try $ browse $ do setOutHandler (const $ return ()) request $ getRequest (?secureTestUrl "/anything") assertEqual "Threw expected exception" (Left (userError "https not supported")) (fmap show res) -- fmap show because Response isn't in Eq -- in case it tries to reuse the connection browserSecureRequestAfterInsecure :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Assertion browserSecureRequestAfterInsecure = do res <- try $ browse $ do setOutHandler (const $ return ()) request $ getRequest (?testUrl "/basic/get") request $ getRequest (?secureTestUrl "/anything") assertEqual "Threw expected exception" (Left (userError "https not supported")) (fmap show res) -- fmap show because Response isn't in Eq browserRedirectToSecure :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Assertion browserRedirectToSecure = do res <- try $ browse $ do setOutHandler (const $ return ()) setErrHandler fail request $ getRequest (?testUrl "/browser/redirect/secure/301/anything") assertEqual "Threw expected exception" (Left (userError $ "Unable to handle redirect, unsupported scheme: " ++ ?secureTestUrl "/anything")) (fmap show res) -- fmap show because Response isn't in Eq browserTwoRequests :: (?testUrl :: ServerAddress) => Assertion browserTwoRequests = do (response1, response2) <- browse $ do setOutHandler (const $ return ()) (_, response1) <- request $ getRequest (?testUrl "/basic/get") (_, response2) <- request $ getRequest (?testUrl "/basic/get2") return (response1, response2) assertEqual "Receiving expected response from main server" ((2, 0, 0), "It works.") (rspCode response1, rspBody response1) assertEqual "Receiving expected response from main server" ((2, 0, 0), "It works (2).") (rspCode response2, rspBody response2) browserTwoRequestsAlt :: (?altTestUrl :: ServerAddress) => Assertion browserTwoRequestsAlt = do (response1, response2) <- browse $ do setOutHandler (const $ return ()) (_, response1) <- request $ getRequest (?altTestUrl "/basic/get") (_, response2) <- request $ getRequest (?altTestUrl "/basic/get2") return (response1, response2) assertEqual "Receiving expected response from alternate server" ((2, 0, 0), "This is the alternate server.") (rspCode response1, rspBody response1) assertEqual "Receiving expected response from alternate server" ((2, 0, 0), "This is the alternate server (2).") (rspCode response2, rspBody response2) browserTwoRequestsBoth :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion browserTwoRequestsBoth = do (response1, response2, response3, response4) <- browse $ do setOutHandler (const $ return ()) (_, response1) <- request $ getRequest (?testUrl "/basic/get") (_, response2) <- request $ getRequest (?altTestUrl "/basic/get") (_, response3) <- request $ getRequest (?testUrl "/basic/get2") (_, response4) <- request $ getRequest (?altTestUrl "/basic/get2") return (response1, response2, response3, response4) assertEqual "Receiving expected response from main server" ((2, 0, 0), "It works.") (rspCode response1, rspBody response1) assertEqual "Receiving expected response from alternate server" ((2, 0, 0), "This is the alternate server.") (rspCode response2, rspBody response2) assertEqual "Receiving expected response from main server" ((2, 0, 0), "It works (2).") (rspCode response3, rspBody response3) assertEqual "Receiving expected response from alternate server" ((2, 0, 0), "This is the alternate server (2).") (rspCode response4, rspBody response4) hasPrefix :: String -> String -> Maybe String hasPrefix [] ys = Just ys hasPrefix (x:xs) (y:ys) | x == y = hasPrefix xs ys hasPrefix _ _ = Nothing maybeRead :: Read a => String -> Maybe a maybeRead s = case reads s of [(v, "")] -> Just v _ -> Nothing splitFields = map (toPair '=' . trim isSpace) . splitOn "," toPair c str = case break (==c) str of (left, _:right) -> (left, right) _ -> error $ "No " ++ show c ++ " in " ++ str trim f = dropWhile f . reverse . dropWhile f . reverse isSubsetOf xs ys = all (`elem` ys) xs -- first bits of result text from haskell.org (just to give some representative text) haskellOrgText = "\ \\t\ \\t\ \\t\t\ \\t\t\t\t" digestMatch username realm password nonce opaque method relativeURI makeAbsolute headers = common `isSubsetOf` headers && (relative `isSubsetOf` headers || absolute `isSubsetOf` headers) where common = [("username", show username), ("realm", show realm), ("nonce", show nonce), ("opaque", show opaque)] md5 = show . MD5.md5 . BL.pack ha1 = md5 (username++":"++realm++":"++password) ha2 uri = md5 (method++":"++uri) response uri = md5 (ha1 ++ ":" ++ nonce ++ ":" ++ ha2 uri) mkUncommon uri hash = [("uri", show uri), ("response", show hash)] relative = mkUncommon relativeURI (response relativeURI) absoluteURI = makeAbsolute relativeURI absolute = mkUncommon absoluteURI (response absoluteURI) processRequest :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Httpd.Request -> IO Httpd.Response processRequest req = do case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of ("GET", "/basic/get") -> return $ Httpd.mkResponse 200 [] "It works." ("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "It works (2)." ("GET", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head." ("HEAD", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head." ("POST", "/basic/post") -> let typ = lookup "Content-Type" (Httpd.reqHeaders req) len = lookup "Content-Length" (Httpd.reqHeaders req) body = Httpd.reqBody req in return $ Httpd.mkResponse 200 [] (show (typ, len, body)) ("GET", "/basic/example") -> return $ Httpd.mkResponse 200 [] haskellOrgText ("GET", "/auth/basic") -> case lookup "Authorization" (Httpd.reqHeaders req) of Just "Basic dGVzdDpwYXNzd29yZA==" -> return $ Httpd.mkResponse 200 [] "Here's the secret" x -> return $ Httpd.mkResponse 401 [("WWW-Authenticate", "Basic realm=\"Testing realm\"")] (show x) ("GET", "/auth/digest") -> case lookup "Authorization" (Httpd.reqHeaders req) of Just (hasPrefix "Digest " -> Just (splitFields -> items)) | digestMatch "test" "Digest testing realm" "digestpassword" "87e4" "057d" "GET" "/auth/digest" ?testUrl items -> return $ Httpd.mkResponse 200 [] "Here's the digest secret" x -> return $ Httpd.mkResponse 401 [("WWW-Authenticate", "Digest realm=\"Digest testing realm\", opaque=\"057d\", nonce=\"87e4\"")] (show x) ("GET", "/browser/example") -> return $ Httpd.mkResponse 200 [] haskellOrgText ("GET", "/browser/no-cookie") -> case lookup "Cookie" (Httpd.reqHeaders req) of Nothing -> return $ Httpd.mkResponse 200 [] "" Just s -> return $ Httpd.mkResponse 500 [] s ("GET", "/browser/one-cookie/1") -> return $ Httpd.mkResponse 200 [("Set-Cookie", "hello=world")] "" ("GET", "/browser/one-cookie/2") -> case lookup "Cookie" (Httpd.reqHeaders req) of Just "hello=world" -> return $ Httpd.mkResponse 200 [] "" Just s -> return $ Httpd.mkResponse 500 [] s Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req) ("GET", "/browser/two-cookies/1") -> return $ Httpd.mkResponse 200 [("Set-Cookie", "hello=world") ,("Set-Cookie", "goodbye=cruelworld")] "" ("GET", "/browser/two-cookies/2") -> case lookup "Cookie" (Httpd.reqHeaders req) of -- TODO generalise the cookie parsing to allow for whitespace/ordering variations Just "goodbye=cruelworld; hello=world" -> return $ Httpd.mkResponse 200 [] "" Just s -> return $ Httpd.mkResponse 500 [] s Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req) ("GET", hasPrefix "/browser/redirect/relative/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> return $ Httpd.mkResponse n [("Location", rest)] "" ("GET", hasPrefix "/browser/redirect/absolute/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> return $ Httpd.mkResponse n [("Location", ?testUrl rest)] "" ("GET", hasPrefix "/browser/redirect/secure/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> return $ Httpd.mkResponse n [("Location", ?secureTestUrl rest)] "" _ -> return $ Httpd.mkResponse 500 [] "Unknown request" altProcessRequest :: Httpd.Request -> IO Httpd.Response altProcessRequest req = do case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of ("GET", "/basic/get") -> return $ Httpd.mkResponse 200 [] "This is the alternate server." ("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "This is the alternate server (2)." _ -> return $ Httpd.mkResponse 500 [] "Unknown request" maybeTestGroup True name xs = testGroup name xs maybeTestGroup False name _ = testGroup name [] basicTests = testGroup "Basic tests" [ testCase "Basic GET request" basicGetRequest , testCase "Basic GET request (lazy bytestring)" basicGetRequestLBS , testCase "Network.HTTP example code" basicExample , testCase "Secure GET request" secureGetRequest , testCase "Basic POST request" basicPostRequest , testCase "Basic HEAD request" basicHeadRequest , testCase "URI user:pass Auth failure" userpwAuthFailure , testCase "URI user:pass Auth success" userpwAuthSuccess , testCase "Basic Auth failure" basicAuthFailure , testCase "Basic Auth success" basicAuthSuccess , testCase "UTF-8 urlEncode" utf8URLEncode , testCase "UTF-8 urlDecode" utf8URLDecode ] browserTests = testGroup "Browser tests" [ testGroup "Basic" [ testCase "Network.Browser example code" browserExample , testCase "Two requests" browserTwoRequests ] , testGroup "Secure" [ testCase "Secure request" browserSecureRequest , testCase "After insecure" browserSecureRequestAfterInsecure , testCase "Redirection" browserRedirectToSecure ] , testGroup "Cookies" [ testCase "No cookie header" browserNoCookie , testCase "One cookie" browserOneCookie , testCase "Two cookies" browserTwoCookies ] , testGroup "Redirection" [ -- See http://en.wikipedia.org/wiki/List_of_HTTP_status_codes#3xx_Redirection -- 300 Multiple Choices: client has to handle this testCase "300" (browserReturnsRedirect 300) -- 301 Moved Permanently: should follow , testCase "301" (browserFollowsRedirect 301) -- 302 Found: should follow , testCase "302" (browserFollowsRedirect 302) -- 303 See Other: should follow (directly for GETs) , testCase "303" (browserFollowsRedirect 303) -- 304 Not Modified: maybe Browser could do something intelligent based on -- being given locally cached content and sending If-Modified-Since, but it -- doesn't at the moment , testCase "304" (browserReturnsRedirect 304) -- 305 Use Proxy: test harness doesn't have a proxy (yet) -- 306 Switch Proxy: obsolete -- 307 Temporary Redirect: should follow , testCase "307" (browserFollowsRedirect 307) -- 308 Resume Incomplete: no support for Resumable HTTP so client has to handle this , testCase "308" (browserReturnsRedirect 308) ] , testGroup "Authentication" [ testCase "Basic" browserBasicAuth , testCase "Digest" browserDigestAuth ] ] port80Tests = testGroup "Multiple servers" [ testCase "Alternate server" browserAlt , testCase "Both servers" browserBoth , testCase "Both servers (reversed)" browserBothReversed , testCase "Two requests - alternate server" browserTwoRequestsAlt , testCase "Two requests - both servers" browserTwoRequestsBoth ] data InetFamily = IPv4 | IPv6 familyToLocalhost :: InetFamily -> String familyToLocalhost IPv4 = "127.0.0.1" familyToLocalhost IPv6 = "[::1]" urlRoot :: InetFamily -> String -> Int -> String urlRoot fam userpw 80 = "http://" ++ userpw ++ familyToLocalhost fam urlRoot fam userpw n = "http://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n secureRoot :: InetFamily -> String -> Int -> String secureRoot fam userpw 443 = "https://" ++ userpw ++ familyToLocalhost fam secureRoot fam userpw n = "https://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n type ServerAddress = String -> String httpAddress, httpsAddress :: InetFamily -> String -> Int -> ServerAddress httpAddress fam userpw port p = urlRoot fam userpw port ++ p httpsAddress fam userpw port p = secureRoot fam userpw port ++ p main :: IO () main = do args <- getArgs let servers = [ ("httpd-shed", Httpd.shed, IPv4) #ifdef WARP_TESTS , ("warp.v6", Httpd.warp True, IPv6) , ("warp.v4", Httpd.warp False, IPv4) #endif ] basePortNum, altPortNum :: Int basePortNum = 5812 altPortNum = 80 numberedServers = zip [basePortNum..] servers let setupNormalTests = do flip mapM numberedServers $ \(portNum, (serverName, server, family)) -> do let ?testUrl = httpAddress family "" portNum ?userpwUrl = httpAddress family "test:password@" portNum ?baduserpwUrl = httpAddress family "test:wrongpwd@" portNum ?secureTestUrl = httpsAddress family "" portNum _ <- forkIO $ server portNum processRequest return $ testGroup serverName [basicTests, browserTests] let setupAltTests = do let (portNum, (_, server,family)) = head numberedServers let ?testUrl = httpAddress family "" portNum ?altTestUrl = httpAddress family "" altPortNum _ <- forkIO $ server altPortNum altProcessRequest return port80Tests case args of ["server"] -> do -- run only the harness servers for diagnostic/debug purposes -- halt on any keypress _ <- setupNormalTests _ <- setupAltTests _ <- getChar return () ("--withport80":args) -> do normalTests <- setupNormalTests altTests <- setupAltTests _ <- threadDelay 1000000 -- Give the server time to start :-( defaultMainWithArgs (UnitTests.unitTests ++ normalTests ++ [altTests]) args args -> do -- run the test harness as normal normalTests <- setupNormalTests _ <- threadDelay 1000000 -- Give the server time to start :-( defaultMainWithArgs (UnitTests.unitTests ++ normalTests) args HTTP-4000.3.3/Network/0000755000000000000000000000000012656464615012356 5ustar0000000000000000HTTP-4000.3.3/Network/HTTP.hs0000644000000000000000000002674312656464615013505 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Network.HTTP -- Copyright : See LICENSE file -- License : BSD -- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) -- -- The 'Network.HTTP' module provides a simple interface for sending and -- receiving content over HTTP in Haskell. Here's how to fetch a document from -- a URL and return it as a String: -- -- > -- > simpleHTTP (getRequest "http://www.haskell.org/") >>= fmap (take 100) . getResponseBody -- > -- fetch document and return it (as a 'String'.) -- -- Other functions let you control the submission and transfer of HTTP -- 'Request's and 'Response's more carefully, letting you integrate the use -- of 'Network.HTTP' functionality into your application. -- -- The module also exports the main types of the package, 'Request' and 'Response', -- along with 'Header' and functions for working with these. -- -- The actual functionality is implemented by modules in the @Network.HTTP.*@ -- namespace, letting you either use the default implementation here -- by importing @Network.HTTP@ or, for more specific uses, selectively -- import the modules in @Network.HTTP.*@. To wit, more than one kind of -- representation of the bulk data that flows across a HTTP connection is -- supported. (see "Network.HTTP.HandleStream".) -- -- /NOTE:/ The 'Request' send actions will normalize the @Request@ prior to transmission. -- Normalization such as having the request path be in the expected form and, possibly, -- introduce a default @Host:@ header if one isn't already present. -- Normalization also takes the @"user:pass\@"@ portion out of the the URI, -- if it was supplied, and converts it into @Authorization: Basic$ header. -- If you do not -- want the requests tampered with, but sent as-is, please import and use the -- the "Network.HTTP.HandleStream" or "Network.HTTP.Stream" modules instead. They -- export the same functions, but leaves construction and any normalization of -- @Request@s to the user. -- -- /NOTE:/ This package only supports HTTP; it does not support HTTPS. -- Attempts to use HTTPS result in an error. ----------------------------------------------------------------------------- module Network.HTTP ( module Network.HTTP.Base , module Network.HTTP.Headers {- the functionality that the implementation modules, Network.HTTP.HandleStream and Network.HTTP.Stream, exposes: -} , simpleHTTP -- :: Request -> IO (Result Response) , simpleHTTP_ -- :: Stream s => s -> Request -> IO (Result Response) , sendHTTP -- :: Stream s => s -> Request -> IO (Result Response) , sendHTTP_notify -- :: Stream s => s -> Request -> IO () -> IO (Result Response) , receiveHTTP -- :: Stream s => s -> IO (Result Request) , respondHTTP -- :: Stream s => s -> Response -> IO () , module Network.TCP , getRequest -- :: String -> Request_String , headRequest -- :: String -> Request_String , postRequest -- :: String -> Request_String , postRequestWithBody -- :: String -> String -> String -> Request_String , getResponseBody -- :: Result (Request ty) -> IO ty , getResponseCode -- :: Result (Request ty) -> IO ResponseCode ) where ----------------------------------------------------------------- ------------------ Imports -------------------------------------- ----------------------------------------------------------------- import Network.HTTP.Headers import Network.HTTP.Base import qualified Network.HTTP.HandleStream as S -- old implementation: import Network.HTTP.Stream import Network.TCP import Network.Stream ( Result ) import Network.URI ( parseURI ) import Data.Maybe ( fromMaybe ) {- Note: if you switch over/back to using Network.HTTP.Stream here, you'll have to wrap the results from 'openStream' as Connections via 'hstreamToConnection' prior to delegating to the Network.HTTP.Stream functions. -} -- | @simpleHTTP req@ transmits the 'Request' @req@ by opening a /direct/, non-persistent -- connection to the HTTP server that @req@ is destined for, followed by transmitting -- it and gathering up the response as a 'Result'. Prior to sending the request, -- it is normalized (via 'normalizeRequest'). If you have to mediate the request -- via an HTTP proxy, you will have to normalize the request yourself. Or switch to -- using 'Network.Browser' instead. -- -- Examples: -- -- > simpleHTTP (getRequest "http://hackage.haskell.org/") -- > simpleHTTP (getRequest "http://hackage.haskell.org:8012/") simpleHTTP :: (HStream ty) => Request ty -> IO (Result (Response ty)) simpleHTTP r = do auth <- getAuth r failHTTPS (rqURI r) c <- openStream (host auth) (fromMaybe 80 (port auth)) let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r simpleHTTP_ c norm_r -- | Identical to 'simpleHTTP', but acting on an already opened stream. simpleHTTP_ :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) simpleHTTP_ s r = do let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r S.sendHTTP s norm_r -- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ (after normalization) over -- @hStream@, but does not alter the status of the connection, nor request it to be -- closed upon receiving the response. sendHTTP :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) sendHTTP conn rq = do let norm_r = normalizeRequest defaultNormalizeRequestOptions rq S.sendHTTP conn norm_r -- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but -- lets you supply an IO @action@ to execute once the request has been successfully -- transmitted over the connection. Useful when you want to set up tracing of -- request transmission and its performance. sendHTTP_notify :: HStream ty => HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty)) sendHTTP_notify conn rq onSendComplete = do let norm_r = normalizeRequest defaultNormalizeRequestOptions rq S.sendHTTP_notify conn norm_r onSendComplete -- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@ receiveHTTP :: HStream ty => HandleStream ty -> IO (Result (Request ty)) receiveHTTP conn = S.receiveHTTP conn -- | @respondHTTP hStream httpResponse@ transmits an HTTP 'Response' over -- the 'HandleStream' @hStream@. It could be used to implement simple web -- server interactions, performing the dual role to 'sendHTTP'. respondHTTP :: HStream ty => HandleStream ty -> Response ty -> IO () respondHTTP conn rsp = S.respondHTTP conn rsp -- | A convenience constructor for a GET 'Request'. -- -- If the URL isn\'t syntactically valid, the function raises an error. getRequest :: String -- ^URL to fetch -> Request_String -- ^The constructed request getRequest urlString = case parseURI urlString of Nothing -> error ("getRequest: Not a valid URL - " ++ urlString) Just u -> mkRequest GET u -- | A convenience constructor for a HEAD 'Request'. -- -- If the URL isn\'t syntactically valid, the function raises an error. headRequest :: String -- ^URL to fetch -> Request_String -- ^The constructed request headRequest urlString = case parseURI urlString of Nothing -> error ("headRequest: Not a valid URL - " ++ urlString) Just u -> mkRequest HEAD u -- | A convenience constructor for a POST 'Request'. -- -- If the URL isn\'t syntactically valid, the function raises an error. postRequest :: String -- ^URL to POST to -> Request_String -- ^The constructed request postRequest urlString = case parseURI urlString of Nothing -> error ("postRequest: Not a valid URL - " ++ urlString) Just u -> mkRequest POST u -- | A convenience constructor for a POST 'Request'. -- -- It constructs a request and sets the body as well as -- the Content-Type and Content-Length headers. The contents of the body -- are forced to calculate the value for the Content-Length header. -- -- If the URL isn\'t syntactically valid, the function raises an error. postRequestWithBody :: String -- ^URL to POST to -> String -- ^Content-Type of body -> String -- ^The body of the request -> Request_String -- ^The constructed request postRequestWithBody urlString typ body = case parseURI urlString of Nothing -> error ("postRequestWithBody: Not a valid URL - " ++ urlString) Just u -> setRequestBody (mkRequest POST u) (typ, body) -- | @getResponseBody response@ takes the response of a HTTP requesting action and -- tries to extricate the body of the 'Response' @response@. If the request action -- returned an error, an IO exception is raised. getResponseBody :: Result (Response ty) -> IO ty getResponseBody (Left err) = fail (show err) getResponseBody (Right r) = return (rspBody r) -- | @getResponseBody response@ takes the response of a HTTP requesting action and -- tries to extricate the status code of the 'Response' @response@. If the request action -- returned an error, an IO exception is raised. getResponseCode :: Result (Response ty) -> IO ResponseCode getResponseCode (Left err) = fail (show err) getResponseCode (Right r) = return (rspCode r) -- -- * TODO -- - request pipelining -- - https upgrade (includes full TLS, i.e. SSL, implementation) -- - use of Stream classes will pay off -- - consider C implementation of encryption\/decryption -- - comm timeouts -- - MIME & entity stuff (happening in separate module) -- - support \"*\" uri-request-string for OPTIONS request method -- -- -- * Header notes: -- -- [@Host@] -- Required by HTTP\/1.1, if not supplied as part -- of a request a default Host value is extracted -- from the request-uri. -- -- [@Connection@] -- If this header is present in any request or -- response, and it's value is "close", then -- the current request\/response is the last -- to be allowed on that connection. -- -- [@Expect@] -- Should a request contain a body, an Expect -- header will be added to the request. The added -- header has the value \"100-continue\". After -- a 417 \"Expectation Failed\" response the request -- is attempted again without this added Expect -- header. -- -- [@TransferEncoding,ContentLength,...@] -- if request is inconsistent with any of these -- header values then you may not receive any response -- or will generate an error response (probably 4xx). -- -- -- * Response code notes -- Some response codes induce special behaviour: -- -- [@1xx@] \"100 Continue\" will cause any unsent request body to be sent. -- \"101 Upgrade\" will be returned. -- Other 1xx responses are ignored. -- -- [@417@] The reason for this code is \"Expectation failed\", indicating -- that the server did not like the Expect \"100-continue\" header -- added to a request. Receipt of 417 will induce another -- request attempt (without Expect header), unless no Expect header -- had been added (in which case 417 response is returned). HTTP-4000.3.3/Network/StreamSocket.hs0000644000000000000000000000634712656464615015330 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Network.StreamSocket -- Copyright : See LICENSE file -- License : BSD -- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) -- -- Socket Stream instance. Originally part of Gray's\/Bringert's HTTP module. -- -- * Changes by Robin Bate Boerop : -- - Made dependencies explicit in import statements. -- - Removed false dependencies in import statements. -- - Created separate module for instance Stream Socket. -- -- * Changes by Simon Foster: -- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules -- ----------------------------------------------------------------------------- module Network.StreamSocket ( handleSocketError , myrecv ) where import Network.Stream ( Stream(..), ConnError(ErrorReset, ErrorMisc), Result ) import Network.Socket ( Socket, getSocketOption, shutdown, send, recv, sClose , ShutdownCmd(ShutdownBoth), SocketOption(SoError) ) import Network.HTTP.Base ( catchIO ) import Control.Monad (liftM) import Control.Exception as Exception (IOException) import System.IO.Error (isEOFError) -- | Exception handler for socket operations. handleSocketError :: Socket -> IOException -> IO (Result a) handleSocketError sk e = do se <- getSocketOption sk SoError case se of 0 -> ioError e 10054 -> return $ Left ErrorReset -- reset _ -> return $ Left $ ErrorMisc $ show se myrecv :: Socket -> Int -> IO String myrecv sock len = let handler e = if isEOFError e then return [] else ioError e in catchIO (recv sock len) handler instance Stream Socket where readBlock sk n = readBlockSocket sk n readLine sk = readLineSocket sk writeBlock sk str = writeBlockSocket sk str close sk = do -- This slams closed the connection (which is considered rude for TCP\/IP) shutdown sk ShutdownBoth sClose sk closeOnEnd _sk _ = return () -- can't really deal with this, so do run the risk of leaking sockets here. readBlockSocket :: Socket -> Int -> IO (Result String) readBlockSocket sk n = (liftM Right $ fn n) `catchIO` (handleSocketError sk) where fn x = do { str <- myrecv sk x ; let len = length str ; if len < x then ( fn (x-len) >>= \more -> return (str++more) ) else return str } -- Use of the following function is discouraged. -- The function reads in one character at a time, -- which causes many calls to the kernel recv() -- hence causes many context switches. readLineSocket :: Socket -> IO (Result String) readLineSocket sk = (liftM Right $ fn "") `catchIO` (handleSocketError sk) where fn str = do c <- myrecv sk 1 -- like eating through a straw. if null c || c == "\n" then return (reverse str++c) else fn (head c:str) writeBlockSocket :: Socket -> String -> IO (Result ()) writeBlockSocket sk str = (liftM Right $ fn str) `catchIO` (handleSocketError sk) where fn [] = return () fn x = send sk x >>= \i -> fn (drop i x) HTTP-4000.3.3/Network/Browser.hs0000644000000000000000000012274612656464615014351 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP, FlexibleContexts #-} {- | Module : Network.Browser Copyright : See LICENSE file License : BSD Maintainer : Ganesh Sittampalam Stability : experimental Portability : non-portable (not tested) Session-level interactions over HTTP. The "Network.Browser" goes beyond the basic "Network.HTTP" functionality in providing support for more involved, and real, request/response interactions over HTTP. Additional features supported are: * HTTP Authentication handling * Transparent handling of redirects * Cookie stores + transmission. * Transaction logging * Proxy-mediated connections. Example use: > do > (_, rsp) > <- Network.Browser.browse $ do > setAllowRedirects True -- handle HTTP redirects > request $ getRequest "http://www.haskell.org/" > return (take 100 (rspBody rsp)) -} module Network.Browser ( BrowserState , BrowserAction -- browser monad, effectively a state monad. , Proxy(..) , browse -- :: BrowserAction a -> IO a , request -- :: Request -> BrowserAction Response , getBrowserState -- :: BrowserAction t (BrowserState t) , withBrowserState -- :: BrowserState t -> BrowserAction t a -> BrowserAction t a , setAllowRedirects -- :: Bool -> BrowserAction t () , getAllowRedirects -- :: BrowserAction t Bool , setMaxRedirects -- :: Int -> BrowserAction t () , getMaxRedirects -- :: BrowserAction t (Maybe Int) , Authority(..) , getAuthorities , setAuthorities , addAuthority , Challenge(..) , Qop(..) , Algorithm(..) , getAuthorityGen , setAuthorityGen , setAllowBasicAuth , getAllowBasicAuth , setMaxErrorRetries -- :: Maybe Int -> BrowserAction t () , getMaxErrorRetries -- :: BrowserAction t (Maybe Int) , setMaxPoolSize -- :: Int -> BrowserAction t () , getMaxPoolSize -- :: BrowserAction t (Maybe Int) , setMaxAuthAttempts -- :: Maybe Int -> BrowserAction t () , getMaxAuthAttempts -- :: BrowserAction t (Maybe Int) , setCookieFilter -- :: (URI -> Cookie -> IO Bool) -> BrowserAction t () , getCookieFilter -- :: BrowserAction t (URI -> Cookie -> IO Bool) , defaultCookieFilter -- :: URI -> Cookie -> IO Bool , userCookieFilter -- :: URI -> Cookie -> IO Bool , Cookie(..) , getCookies -- :: BrowserAction t [Cookie] , setCookies -- :: [Cookie] -> BrowserAction t () , addCookie -- :: Cookie -> BrowserAction t () , setErrHandler -- :: (String -> IO ()) -> BrowserAction t () , setOutHandler -- :: (String -> IO ()) -> BrowserAction t () , setEventHandler -- :: (BrowserEvent -> BrowserAction t ()) -> BrowserAction t () , BrowserEvent(..) , BrowserEventType(..) , RequestID , setProxy -- :: Proxy -> BrowserAction t () , getProxy -- :: BrowserAction t Proxy , setCheckForProxy -- :: Bool -> BrowserAction t () , getCheckForProxy -- :: BrowserAction t Bool , setDebugLog -- :: Maybe String -> BrowserAction t () , getUserAgent -- :: BrowserAction t String , setUserAgent -- :: String -> BrowserAction t () , out -- :: String -> BrowserAction t () , err -- :: String -> BrowserAction t () , ioAction -- :: IO a -> BrowserAction a , defaultGETRequest , defaultGETRequest_ , formToRequest , uriDefaultTo -- old and half-baked; don't use: , Form(..) , FormVar ) where import Network.URI ( URI(..) , URIAuth(..) , parseURI, parseURIReference, relativeTo ) import Network.StreamDebugger (debugByteStream) import Network.HTTP hiding ( sendHTTP_notify ) import Network.HTTP.HandleStream ( sendHTTP_notify ) import Network.HTTP.Auth import Network.HTTP.Cookie import Network.HTTP.Proxy import Network.Stream ( ConnError(..), Result ) import Network.BufferType import Data.Char (toLower) import Data.List (isPrefixOf) import Data.Maybe (fromMaybe, listToMaybe, catMaybes ) import Control.Applicative (Applicative (..), (<$>)) #ifdef MTL1 import Control.Monad (filterM, forM_, when, ap) #else import Control.Monad (filterM, forM_, when) #endif import Control.Monad.State (StateT (..), MonadIO (..), modify, gets, withStateT, evalStateT, MonadState (..)) import qualified System.IO ( hSetBuffering, hPutStr, stdout, stdin, hGetChar , BufferMode(NoBuffering, LineBuffering) ) import Data.Time.Clock ( UTCTime, getCurrentTime ) ------------------------------------------------------------------ ----------------------- Cookie Stuff ----------------------------- ------------------------------------------------------------------ -- | @defaultCookieFilter@ is the initial cookie acceptance filter. -- It welcomes them all into the store @:-)@ defaultCookieFilter :: URI -> Cookie -> IO Bool defaultCookieFilter _url _cky = return True -- | @userCookieFilter@ is a handy acceptance filter, asking the -- user if he/she is willing to accept an incoming cookie before -- adding it to the store. userCookieFilter :: URI -> Cookie -> IO Bool userCookieFilter url cky = do do putStrLn ("Set-Cookie received when requesting: " ++ show url) case ckComment cky of Nothing -> return () Just x -> putStrLn ("Cookie Comment:\n" ++ x) let pth = maybe "" ('/':) (ckPath cky) putStrLn ("Domain/Path: " ++ ckDomain cky ++ pth) putStrLn (ckName cky ++ '=' : ckValue cky) System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering System.IO.hPutStr System.IO.stdout "Accept [y/n]? " x <- System.IO.hGetChar System.IO.stdin System.IO.hSetBuffering System.IO.stdin System.IO.LineBuffering System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering return (toLower x == 'y') -- | @addCookie c@ adds a cookie to the browser state, removing duplicates. addCookie :: Cookie -> BrowserAction t () addCookie c = modify (\b -> b{bsCookies = c : filter (/=c) (bsCookies b) }) -- | @setCookies cookies@ replaces the set of cookies known to -- the browser to @cookies@. Useful when wanting to restore cookies -- used across 'browse' invocations. setCookies :: [Cookie] -> BrowserAction t () setCookies cs = modify (\b -> b { bsCookies=cs }) -- | @getCookies@ returns the current set of cookies known to -- the browser. getCookies :: BrowserAction t [Cookie] getCookies = gets bsCookies -- ...get domain specific cookies... -- ... this needs changing for consistency with rfc2109... -- ... currently too broad. getCookiesFor :: String -> String -> BrowserAction t [Cookie] getCookiesFor dom path = do cks <- getCookies return (filter cookiematch cks) where cookiematch :: Cookie -> Bool cookiematch = cookieMatch (dom,path) -- | @setCookieFilter fn@ sets the cookie acceptance filter to @fn@. setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction t () setCookieFilter f = modify (\b -> b { bsCookieFilter=f }) -- | @getCookieFilter@ returns the current cookie acceptance filter. getCookieFilter :: BrowserAction t (URI -> Cookie -> IO Bool) getCookieFilter = gets bsCookieFilter ------------------------------------------------------------------ ----------------------- Authorisation Stuff ---------------------- ------------------------------------------------------------------ {- The browser handles 401 responses in the following manner: 1) extract all WWW-Authenticate headers from a 401 response 2) rewrite each as a Challenge object, using "headerToChallenge" 3) pick a challenge to respond to, usually the strongest challenge understood by the client, using "pickChallenge" 4) generate a username/password combination using the browsers "bsAuthorityGen" function (the default behaviour is to ask the user) 5) build an Authority object based upon the challenge and user data, store this new Authority in the browser state 6) convert the Authority to a request header and add this to a request using "withAuthority" 7) send the amended request Note that by default requests are annotated with authority headers before the first sending, based upon previously generated Authority objects (which contain domain information). Once a specific authority is added to a rejected request this predictive annotation is suppressed. 407 responses are handled in a similar manner, except a) Authorities are not collected, only a single proxy authority is kept by the browser b) If the proxy used by the browser (type Proxy) is NoProxy, then a 407 response will generate output on the "err" stream and the response will be returned. Notes: - digest authentication so far ignores qop, so fails to authenticate properly with qop=auth-int challenges - calculates a1 more than necessary - doesn't reverse authenticate - doesn't properly receive AuthenticationInfo headers, so fails to use next-nonce etc -} -- | Return authorities for a given domain and path. -- Assumes "dom" is lower case getAuthFor :: String -> String -> BrowserAction t [Authority] getAuthFor dom pth = getAuthorities >>= return . (filter match) where match :: Authority -> Bool match au@AuthBasic{} = matchURI (auSite au) match au@AuthDigest{} = or (map matchURI (auDomain au)) matchURI :: URI -> Bool matchURI s = (uriToAuthorityString s == dom) && (uriPath s `isPrefixOf` pth) -- | @getAuthorities@ return the current set of @Authority@s known -- to the browser. getAuthorities :: BrowserAction t [Authority] getAuthorities = gets bsAuthorities -- @setAuthorities as@ replaces the Browser's known set -- of 'Authority's to @as@. setAuthorities :: [Authority] -> BrowserAction t () setAuthorities as = modify (\b -> b { bsAuthorities=as }) -- @addAuthority a@ adds 'Authority' @a@ to the Browser's -- set of known authorities. addAuthority :: Authority -> BrowserAction t () addAuthority a = modify (\b -> b { bsAuthorities=a:bsAuthorities b }) -- | @getAuthorityGen@ returns the current authority generator getAuthorityGen :: BrowserAction t (URI -> String -> IO (Maybe (String,String))) getAuthorityGen = gets bsAuthorityGen -- | @setAuthorityGen genAct@ sets the auth generator to @genAct@. setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction t () setAuthorityGen f = modify (\b -> b { bsAuthorityGen=f }) -- | @setAllowBasicAuth onOff@ enables\/disables HTTP Basic Authentication. setAllowBasicAuth :: Bool -> BrowserAction t () setAllowBasicAuth ba = modify (\b -> b { bsAllowBasicAuth=ba }) getAllowBasicAuth :: BrowserAction t Bool getAllowBasicAuth = gets bsAllowBasicAuth -- | @setMaxAuthAttempts mbMax@ sets the maximum number of authentication attempts -- to do. If @Nothing@, rever to default max. setMaxAuthAttempts :: Maybe Int -> BrowserAction t () setMaxAuthAttempts mb | fromMaybe 0 mb < 0 = return () | otherwise = modify (\ b -> b{bsMaxAuthAttempts=mb}) -- | @getMaxAuthAttempts@ returns the current max auth attempts. If @Nothing@, -- the browser's default is used. getMaxAuthAttempts :: BrowserAction t (Maybe Int) getMaxAuthAttempts = gets bsMaxAuthAttempts -- | @setMaxErrorRetries mbMax@ sets the maximum number of attempts at -- transmitting a request. If @Nothing@, rever to default max. setMaxErrorRetries :: Maybe Int -> BrowserAction t () setMaxErrorRetries mb | fromMaybe 0 mb < 0 = return () | otherwise = modify (\ b -> b{bsMaxErrorRetries=mb}) -- | @getMaxErrorRetries@ returns the current max number of error retries. getMaxErrorRetries :: BrowserAction t (Maybe Int) getMaxErrorRetries = gets bsMaxErrorRetries -- TO BE CHANGED!!! pickChallenge :: Bool -> [Challenge] -> Maybe Challenge pickChallenge allowBasic [] | allowBasic = Just (ChalBasic "/") -- manufacture a challenge if one missing; more robust. pickChallenge _ ls = listToMaybe ls -- | Retrieve a likely looking authority for a Request. anticipateChallenge :: Request ty -> BrowserAction t (Maybe Authority) anticipateChallenge rq = let uri = rqURI rq in do { authlist <- getAuthFor (uriAuthToString $ reqURIAuth rq) (uriPath uri) ; return (listToMaybe authlist) } -- | Asking the user to respond to a challenge challengeToAuthority :: URI -> Challenge -> BrowserAction t (Maybe Authority) challengeToAuthority uri ch | not (answerable ch) = return Nothing | otherwise = do -- prompt user for authority prompt <- getAuthorityGen userdetails <- liftIO $ prompt uri (chRealm ch) case userdetails of Nothing -> return Nothing Just (u,p) -> return (Just $ buildAuth ch u p) where answerable :: Challenge -> Bool answerable ChalBasic{} = True answerable chall = (chAlgorithm chall) == Just AlgMD5 buildAuth :: Challenge -> String -> String -> Authority buildAuth (ChalBasic r) u p = AuthBasic { auSite=uri , auRealm=r , auUsername=u , auPassword=p } -- note to self: this is a pretty stupid operation -- to perform isn't it? ChalX and AuthX are so very -- similar. buildAuth (ChalDigest r d n o _stale a q) u p = AuthDigest { auRealm=r , auUsername=u , auPassword=p , auDomain=d , auNonce=n , auOpaque=o , auAlgorithm=a , auQop=q } ------------------------------------------------------------------ ------------------ Browser State Actions ------------------------- ------------------------------------------------------------------ -- | @BrowserState@ is the (large) record type tracking the current -- settings of the browser. data BrowserState connection = BS { bsErr, bsOut :: String -> IO () , bsCookies :: [Cookie] , bsCookieFilter :: URI -> Cookie -> IO Bool , bsAuthorityGen :: URI -> String -> IO (Maybe (String,String)) , bsAuthorities :: [Authority] , bsAllowRedirects :: Bool , bsAllowBasicAuth :: Bool , bsMaxRedirects :: Maybe Int , bsMaxErrorRetries :: Maybe Int , bsMaxAuthAttempts :: Maybe Int , bsMaxPoolSize :: Maybe Int , bsConnectionPool :: [connection] , bsCheckProxy :: Bool , bsProxy :: Proxy , bsDebug :: Maybe String , bsEvent :: Maybe (BrowserEvent -> BrowserAction connection ()) , bsRequestID :: RequestID , bsUserAgent :: Maybe String } instance Show (BrowserState t) where show bs = "BrowserState { " ++ shows (bsCookies bs) ("\n" {- ++ show (bsAuthorities bs) ++ "\n"-} ++ "AllowRedirects: " ++ shows (bsAllowRedirects bs) "} ") -- | @BrowserAction@ is the IO monad, but carrying along a 'BrowserState'. newtype BrowserAction conn a = BA { unBA :: StateT (BrowserState conn) IO a } #ifdef MTL1 deriving (Functor, Monad, MonadIO, MonadState (BrowserState conn)) instance Applicative (BrowserAction conn) where pure = return (<*>) = ap #else deriving (Functor, Applicative, Monad, MonadIO, MonadState (BrowserState conn)) #endif runBA :: BrowserState conn -> BrowserAction conn a -> IO a runBA bs = flip evalStateT bs . unBA -- | @browse act@ is the toplevel action to perform a 'BrowserAction'. -- Example use: @browse (request (getRequest yourURL))@. browse :: BrowserAction conn a -> IO a browse = runBA defaultBrowserState -- | The default browser state has the settings defaultBrowserState :: BrowserState t defaultBrowserState = res where res = BS { bsErr = putStrLn , bsOut = putStrLn , bsCookies = [] , bsCookieFilter = defaultCookieFilter , bsAuthorityGen = \ _uri _realm -> do bsErr res "No action for prompting/generating user+password credentials provided (use: setAuthorityGen); returning Nothing" return Nothing , bsAuthorities = [] , bsAllowRedirects = True , bsAllowBasicAuth = False , bsMaxRedirects = Nothing , bsMaxErrorRetries = Nothing , bsMaxAuthAttempts = Nothing , bsMaxPoolSize = Nothing , bsConnectionPool = [] , bsCheckProxy = defaultAutoProxyDetect , bsProxy = noProxy , bsDebug = Nothing , bsEvent = Nothing , bsRequestID = 0 , bsUserAgent = Nothing } {-# DEPRECATED getBrowserState "Use Control.Monad.State.get instead." #-} -- | @getBrowserState@ returns the current browser config. Useful -- for restoring state across 'BrowserAction's. getBrowserState :: BrowserAction t (BrowserState t) getBrowserState = get -- | @withBrowserAction st act@ performs @act@ with 'BrowserState' @st@. withBrowserState :: BrowserState t -> BrowserAction t a -> BrowserAction t a withBrowserState bs = BA . withStateT (const bs) . unBA -- | @nextRequest act@ performs the browser action @act@ as -- the next request, i.e., setting up a new request context -- before doing so. nextRequest :: BrowserAction t a -> BrowserAction t a nextRequest act = do let updReqID st = let rid = succ (bsRequestID st) in rid `seq` st{bsRequestID=rid} modify updReqID act -- | Lifts an IO action into the 'BrowserAction' monad. {-# DEPRECATED ioAction "Use Control.Monad.Trans.liftIO instead." #-} ioAction :: IO a -> BrowserAction t a ioAction = liftIO -- | @setErrHandler@ sets the IO action to call when -- the browser reports running errors. To disable any -- such, set it to @const (return ())@. setErrHandler :: (String -> IO ()) -> BrowserAction t () setErrHandler h = modify (\b -> b { bsErr=h }) -- | @setOutHandler@ sets the IO action to call when -- the browser chatters info on its running. To disable any -- such, set it to @const (return ())@. setOutHandler :: (String -> IO ()) -> BrowserAction t () setOutHandler h = modify (\b -> b { bsOut=h }) out, err :: String -> BrowserAction t () out s = do { f <- gets bsOut ; liftIO $ f s } err s = do { f <- gets bsErr ; liftIO $ f s } -- | @setAllowRedirects onOff@ toggles the willingness to -- follow redirects (HTTP responses with 3xx status codes). setAllowRedirects :: Bool -> BrowserAction t () setAllowRedirects bl = modify (\b -> b {bsAllowRedirects=bl}) -- | @getAllowRedirects@ returns current setting of the do-chase-redirects flag. getAllowRedirects :: BrowserAction t Bool getAllowRedirects = gets bsAllowRedirects -- | @setMaxRedirects maxCount@ sets the maxiumum number of forwarding hops -- we are willing to jump through. A no-op if the count is negative; if zero, -- the max is set to whatever default applies. Notice that setting the max -- redirects count does /not/ enable following of redirects itself; use -- 'setAllowRedirects' to do so. setMaxRedirects :: Maybe Int -> BrowserAction t () setMaxRedirects c | fromMaybe 0 c < 0 = return () | otherwise = modify (\b -> b{bsMaxRedirects=c}) -- | @getMaxRedirects@ returns the current setting for the max-redirect count. -- If @Nothing@, the "Network.Browser"'s default is used. getMaxRedirects :: BrowserAction t (Maybe Int) getMaxRedirects = gets bsMaxRedirects -- | @setMaxPoolSize maxCount@ sets the maximum size of the connection pool -- that is used to cache connections between requests setMaxPoolSize :: Maybe Int -> BrowserAction t () setMaxPoolSize c = modify (\b -> b{bsMaxPoolSize=c}) -- | @getMaxPoolSize@ gets the maximum size of the connection pool -- that is used to cache connections between requests. -- If @Nothing@, the "Network.Browser"'s default is used. getMaxPoolSize :: BrowserAction t (Maybe Int) getMaxPoolSize = gets bsMaxPoolSize -- | @setProxy p@ will disable proxy usage if @p@ is @NoProxy@. -- If @p@ is @Proxy proxyURL mbAuth@, then @proxyURL@ is interpreted -- as the URL of the proxy to use, possibly authenticating via -- 'Authority' information in @mbAuth@. setProxy :: Proxy -> BrowserAction t () setProxy p = -- Note: if user _explicitly_ sets the proxy, we turn -- off any auto-detection of proxies. modify (\b -> b {bsProxy = p, bsCheckProxy=False}) -- | @getProxy@ returns the current proxy settings. If -- the auto-proxy flag is set to @True@, @getProxy@ will -- perform the necessary getProxy :: BrowserAction t Proxy getProxy = do p <- gets bsProxy case p of -- Note: if there is a proxy, no need to perform any auto-detect. -- Presumably this is the user's explicit and preferred proxy server. Proxy{} -> return p NoProxy{} -> do flg <- gets bsCheckProxy if not flg then return p else do np <- liftIO $ fetchProxy True{-issue warning on stderr if ill-formed...-} -- note: this resets the check-proxy flag; a one-off affair. setProxy np return np -- | @setCheckForProxy flg@ sets the one-time check for proxy -- flag to @flg@. If @True@, the session will try to determine -- the proxy server is locally configured. See 'Network.HTTP.Proxy.fetchProxy' -- for details of how this done. setCheckForProxy :: Bool -> BrowserAction t () setCheckForProxy flg = modify (\ b -> b{bsCheckProxy=flg}) -- | @getCheckForProxy@ returns the current check-proxy setting. -- Notice that this may not be equal to @True@ if the session has -- set it to that via 'setCheckForProxy' and subsequently performed -- some HTTP protocol interactions. i.e., the flag return represents -- whether a proxy will be checked for again before any future protocol -- interactions. getCheckForProxy :: BrowserAction t Bool getCheckForProxy = gets bsCheckProxy -- | @setDebugLog mbFile@ turns off debug logging iff @mbFile@ -- is @Nothing@. If set to @Just fStem@, logs of browser activity -- is appended to files of the form @fStem-url-authority@, i.e., -- @fStem@ is just the prefix for a set of log files, one per host/authority. setDebugLog :: Maybe String -> BrowserAction t () setDebugLog v = modify (\b -> b {bsDebug=v}) -- | @setUserAgent ua@ sets the current @User-Agent:@ string to @ua@. It -- will be used if no explicit user agent header is found in subsequent requests. -- -- A common form of user agent string is @\"name\/version (details)\"@. For -- example @\"cabal-install/0.10.2 (HTTP 4000.1.2)\"@. Including the version -- of this HTTP package can be helpful if you ever need to track down HTTP -- compatability quirks. This version is available via 'httpPackageVersion'. -- For more info see . -- setUserAgent :: String -> BrowserAction t () setUserAgent ua = modify (\b -> b{bsUserAgent=Just ua}) -- | @getUserAgent@ returns the current @User-Agent:@ default string. getUserAgent :: BrowserAction t String getUserAgent = do n <- gets bsUserAgent return (maybe defaultUserAgent id n) -- | @RequestState@ is an internal tallying type keeping track of various -- per-connection counters, like the number of authorization attempts and -- forwards we've gone through. data RequestState = RequestState { reqDenies :: Int -- ^ number of 401 responses so far , reqRedirects :: Int -- ^ number of redirects so far , reqRetries :: Int -- ^ number of retries so far , reqStopOnDeny :: Bool -- ^ whether to pre-empt 401 response } type RequestID = Int -- yeah, it will wrap around. nullRequestState :: RequestState nullRequestState = RequestState { reqDenies = 0 , reqRedirects = 0 , reqRetries = 0 , reqStopOnDeny = True } -- | @BrowserEvent@ is the event record type that a user-defined handler, set -- via 'setEventHandler', will be passed. It indicates various state changes -- encountered in the processing of a given 'RequestID', along with timestamps -- at which they occurred. data BrowserEvent = BrowserEvent { browserTimestamp :: UTCTime , browserRequestID :: RequestID , browserRequestURI :: {-URI-}String , browserEventType :: BrowserEventType } -- | 'BrowserEventType' is the enumerated list of events that the browser -- internals will report to a user-defined event handler. data BrowserEventType = OpenConnection | ReuseConnection | RequestSent | ResponseEnd ResponseData | ResponseFinish {- not yet, you will have to determine these via the ResponseEnd event. | Redirect | AuthChallenge | AuthResponse -} -- | @setEventHandler onBrowserEvent@ configures event handling. -- If @onBrowserEvent@ is @Nothing@, event handling is turned off; -- setting it to @Just onEv@ causes the @onEv@ IO action to be -- notified of browser events during the processing of a request -- by the Browser pipeline. setEventHandler :: Maybe (BrowserEvent -> BrowserAction ty ()) -> BrowserAction ty () setEventHandler mbH = modify (\b -> b { bsEvent=mbH}) buildBrowserEvent :: BrowserEventType -> {-URI-}String -> RequestID -> IO BrowserEvent buildBrowserEvent bt uri reqID = do ct <- getCurrentTime return BrowserEvent { browserTimestamp = ct , browserRequestID = reqID , browserRequestURI = uri , browserEventType = bt } reportEvent :: BrowserEventType -> {-URI-}String -> BrowserAction t () reportEvent bt uri = do st <- get case bsEvent st of Nothing -> return () Just evH -> do evt <- liftIO $ buildBrowserEvent bt uri (bsRequestID st) evH evt -- if it fails, we fail. -- | The default number of hops we are willing not to go beyond for -- request forwardings. defaultMaxRetries :: Int defaultMaxRetries = 4 -- | The default number of error retries we are willing to perform. defaultMaxErrorRetries :: Int defaultMaxErrorRetries = 4 -- | The default maximum HTTP Authentication attempts we will make for -- a single request. defaultMaxAuthAttempts :: Int defaultMaxAuthAttempts = 2 -- | The default setting for auto-proxy detection. -- You may change this within a session via 'setAutoProxyDetect'. -- To avoid initial backwards compatibility issues, leave this as @False@. defaultAutoProxyDetect :: Bool defaultAutoProxyDetect = False -- | @request httpRequest@ tries to submit the 'Request' @httpRequest@ -- to some HTTP server (possibly going via a /proxy/, see 'setProxy'.) -- Upon successful delivery, the URL where the response was fetched from -- is returned along with the 'Response' itself. request :: HStream ty => Request ty -> BrowserAction (HandleStream ty) (URI,Response ty) request req = nextRequest $ do res <- request' nullVal initialState req reportEvent ResponseFinish (show (rqURI req)) case res of Right r -> return r Left e -> do let errStr = ("Network.Browser.request: Error raised " ++ show e) err errStr fail errStr where initialState = nullRequestState nullVal = buf_empty bufferOps -- | Internal helper function, explicitly carrying along per-request -- counts. request' :: HStream ty => ty -> RequestState -> Request ty -> BrowserAction (HandleStream ty) (Result (URI,Response ty)) request' nullVal rqState rq = do let uri = rqURI rq failHTTPS uri let uria = reqURIAuth rq -- add cookies to request cookies <- getCookiesFor (uriAuthToString uria) (uriPath uri) {- Not for now: (case uriUserInfo uria of "" -> id xs -> case chopAtDelim ':' xs of (_,[]) -> id (usr,pwd) -> withAuth AuthBasic{ auUserName = usr , auPassword = pwd , auRealm = "/" , auSite = uri }) $ do -} when (not $ null cookies) (out $ "Adding cookies to request. Cookie names: " ++ unwords (map ckName cookies)) -- add credentials to request rq' <- if not (reqStopOnDeny rqState) then return rq else do auth <- anticipateChallenge rq case auth of Nothing -> return rq Just x -> return (insertHeader HdrAuthorization (withAuthority x rq) rq) let rq'' = if not $ null cookies then insertHeaders [cookiesToHeader cookies] rq' else rq' p <- getProxy def_ua <- gets bsUserAgent let defaultOpts = case p of NoProxy -> defaultNormalizeRequestOptions{normUserAgent=def_ua} Proxy _ ath -> defaultNormalizeRequestOptions { normForProxy = True , normUserAgent = def_ua , normCustoms = maybe [] (\ authS -> [\ _ r -> insertHeader HdrProxyAuthorization (withAuthority authS r) r]) ath } let final_req = normalizeRequest defaultOpts rq'' out ("Sending:\n" ++ show final_req) e_rsp <- case p of NoProxy -> dorequest (reqURIAuth rq'') final_req Proxy str _ath -> do let notURI | null pt || null hst = URIAuth{ uriUserInfo = "" , uriRegName = str , uriPort = "" } | otherwise = URIAuth{ uriUserInfo = "" , uriRegName = hst , uriPort = pt } -- If the ':' is dropped from port below, dorequest will assume port 80. Leave it! where (hst, pt) = span (':'/=) str -- Proxy can take multiple forms - look for http://host:port first, -- then host:port. Fall back to just the string given (probably a host name). let proxyURIAuth = maybe notURI (\parsed -> maybe notURI id (uriAuthority parsed)) (parseURI str) out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth dorequest proxyURIAuth final_req mbMx <- getMaxErrorRetries case e_rsp of Left v | (reqRetries rqState < fromMaybe defaultMaxErrorRetries mbMx) && (v == ErrorReset || v == ErrorClosed) -> do --empty connnection pool in case connection has become invalid modify (\b -> b { bsConnectionPool=[] }) request' nullVal rqState{reqRetries=succ (reqRetries rqState)} rq | otherwise -> return (Left v) Right rsp -> do out ("Received:\n" ++ show rsp) -- add new cookies to browser state handleCookies uri (uriAuthToString $ reqURIAuth rq) (retrieveHeaders HdrSetCookie rsp) -- Deal with "Connection: close" in response. handleConnectionClose (reqURIAuth rq) (retrieveHeaders HdrConnection rsp) mbMxAuths <- getMaxAuthAttempts case rspCode rsp of (4,0,1) -- Credentials not sent or refused. | reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> do out "401 - credentials again refused; exceeded retry count (2)" return (Right (uri,rsp)) | otherwise -> do out "401 - credentials not supplied or refused; retrying.." let hdrs = retrieveHeaders HdrWWWAuthenticate rsp flg <- getAllowBasicAuth case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of Nothing -> do out "no challenge" return (Right (uri,rsp)) {- do nothing -} Just x -> do au <- challengeToAuthority uri x case au of Nothing -> do out "no auth" return (Right (uri,rsp)) {- do nothing -} Just au' -> do out "Retrying request with new credentials" request' nullVal rqState{ reqDenies = succ(reqDenies rqState) , reqStopOnDeny = False } (insertHeader HdrAuthorization (withAuthority au' rq) rq) (4,0,7) -- Proxy Authentication required | reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> do out "407 - proxy authentication required; max deny count exceeeded (2)" return (Right (uri,rsp)) | otherwise -> do out "407 - proxy authentication required" let hdrs = retrieveHeaders HdrProxyAuthenticate rsp flg <- getAllowBasicAuth case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of Nothing -> return (Right (uri,rsp)) {- do nothing -} Just x -> do au <- challengeToAuthority uri x case au of Nothing -> return (Right (uri,rsp)) {- do nothing -} Just au' -> do pxy <- gets bsProxy case pxy of NoProxy -> do err "Proxy authentication required without proxy!" return (Right (uri,rsp)) Proxy px _ -> do out "Retrying with proxy authentication" setProxy (Proxy px (Just au')) request' nullVal rqState{ reqDenies = succ(reqDenies rqState) , reqStopOnDeny = False } rq (3,0,x) | x `elem` [2,3,1,7] -> do out ("30" ++ show x ++ " - redirect") allow_redirs <- allowRedirect rqState case allow_redirs of False -> return (Right (uri,rsp)) _ -> do case retrieveHeaders HdrLocation rsp of [] -> do err "No Location: header in redirect response" return (Right (uri,rsp)) (Header _ u:_) -> case parseURIReference u of Nothing -> do err ("Parse of Location: header in a redirect response failed: " ++ u) return (Right (uri,rsp)) Just newURI | {-uriScheme newURI_abs /= uriScheme uri && -}(not (supportedScheme newURI_abs)) -> do err ("Unable to handle redirect, unsupported scheme: " ++ show newURI_abs) return (Right (uri, rsp)) | otherwise -> do out ("Redirecting to " ++ show newURI_abs ++ " ...") -- Redirect using GET request method, depending on -- response code. let toGet = x `elem` [2,3] method = if toGet then GET else rqMethod rq rq1 = rq { rqMethod=method, rqURI=newURI_abs } rq2 = if toGet then (replaceHeader HdrContentLength "0") (rq1 {rqBody = nullVal}) else rq1 request' nullVal rqState{ reqDenies = 0 , reqRedirects = succ(reqRedirects rqState) , reqStopOnDeny = True } rq2 where newURI_abs = uriDefaultTo newURI uri (3,0,5) -> case retrieveHeaders HdrLocation rsp of [] -> do err "No Location header in proxy redirect response." return (Right (uri,rsp)) (Header _ u:_) -> case parseURIReference u of Nothing -> do err ("Parse of Location header in a proxy redirect response failed: " ++ u) return (Right (uri,rsp)) Just newuri -> do out ("Retrying with proxy " ++ show newuri ++ "...") setProxy (Proxy (uriToAuthorityString newuri) Nothing) request' nullVal rqState{ reqDenies = 0 , reqRedirects = 0 , reqRetries = succ (reqRetries rqState) , reqStopOnDeny = True } rq _ -> return (Right (uri,rsp)) -- | The internal request handling state machine. dorequest :: (HStream ty) => URIAuth -> Request ty -> BrowserAction (HandleStream ty) (Result (Response ty)) dorequest hst rqst = do pool <- gets bsConnectionPool let uPort = uriAuthPort Nothing{-ToDo: feed in complete URL-} hst conn <- liftIO $ filterM (\c -> c `isTCPConnectedTo` EndPoint (uriRegName hst) uPort) pool rsp <- case conn of [] -> do out ("Creating new connection to " ++ uriAuthToString hst) reportEvent OpenConnection (show (rqURI rqst)) c <- liftIO $ openStream (uriRegName hst) uPort updateConnectionPool c dorequest2 c rqst (c:_) -> do out ("Recovering connection to " ++ uriAuthToString hst) reportEvent ReuseConnection (show (rqURI rqst)) dorequest2 c rqst case rsp of Right (Response a b c _) -> reportEvent (ResponseEnd (a,b,c)) (show (rqURI rqst)) ; _ -> return () return rsp where dorequest2 c r = do dbg <- gets bsDebug st <- get let onSendComplete = maybe (return ()) (\evh -> do x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st) runBA st (evh x) return ()) (bsEvent st) liftIO $ maybe (sendHTTP_notify c r onSendComplete) (\ f -> do c' <- debugByteStream (f++'-': uriAuthToString hst) c sendHTTP_notify c' r onSendComplete) dbg updateConnectionPool :: HStream hTy => HandleStream hTy -> BrowserAction (HandleStream hTy) () updateConnectionPool c = do pool <- gets bsConnectionPool let len_pool = length pool maxPoolSize <- fromMaybe defaultMaxPoolSize <$> gets bsMaxPoolSize when (len_pool > maxPoolSize) (liftIO $ close (last pool)) let pool' | len_pool > maxPoolSize = init pool | otherwise = pool when (maxPoolSize > 0) $ modify (\b -> b { bsConnectionPool=c:pool' }) return () -- | Default maximum number of open connections we are willing to have active. defaultMaxPoolSize :: Int defaultMaxPoolSize = 5 cleanConnectionPool :: HStream hTy => URIAuth -> BrowserAction (HandleStream hTy) () cleanConnectionPool uri = do let ep = EndPoint (uriRegName uri) (uriAuthPort Nothing uri) pool <- gets bsConnectionPool bad <- liftIO $ mapM (\c -> c `isTCPConnectedTo` ep) pool let tmp = zip bad pool newpool = map snd $ filter (not . fst) tmp toclose = map snd $ filter fst tmp liftIO $ forM_ toclose close modify (\b -> b { bsConnectionPool = newpool }) handleCookies :: URI -> String -> [Header] -> BrowserAction t () handleCookies _ _ [] = return () -- cut short the silliness. handleCookies uri dom cookieHeaders = do when (not $ null errs) (err $ unlines ("Errors parsing these cookie values: ":errs)) when (not $ null newCookies) (out $ foldl (\x y -> x ++ "\n " ++ show y) "Cookies received:" newCookies) filterfn <- getCookieFilter newCookies' <- liftIO (filterM (filterfn uri) newCookies) when (not $ null newCookies') (out $ "Accepting cookies with names: " ++ unwords (map ckName newCookies')) mapM_ addCookie newCookies' where (errs, newCookies) = processCookieHeaders dom cookieHeaders handleConnectionClose :: HStream hTy => URIAuth -> [Header] -> BrowserAction (HandleStream hTy) () handleConnectionClose _ [] = return () handleConnectionClose uri headers = do let doClose = any (== "close") $ map headerToConnType headers when doClose $ cleanConnectionPool uri where headerToConnType (Header _ t) = map toLower t ------------------------------------------------------------------ ----------------------- Miscellaneous ---------------------------- ------------------------------------------------------------------ allowRedirect :: RequestState -> BrowserAction t Bool allowRedirect rqState = do rd <- getAllowRedirects mbMxRetries <- getMaxRedirects return (rd && (reqRedirects rqState <= fromMaybe defaultMaxRetries mbMxRetries)) -- | Return @True@ iff the package is able to handle requests and responses -- over it. supportedScheme :: URI -> Bool supportedScheme u = uriScheme u == "http:" -- | @uriDefaultTo a b@ returns a URI that is consistent with the first -- argument URI @a@ when read in the context of the second URI @b@. -- If the second argument is not sufficient context for determining -- a full URI then anarchy reins. uriDefaultTo :: URI -> URI -> URI #if MIN_VERSION_network(2,4,0) uriDefaultTo a b = a `relativeTo` b #else uriDefaultTo a b = maybe a id (a `relativeTo` b) #endif -- This form junk is completely untested... type FormVar = (String,String) data Form = Form RequestMethod URI [FormVar] formToRequest :: Form -> Request_String formToRequest (Form m u vs) = let enc = urlEncodeVars vs in case m of GET -> Request { rqMethod=GET , rqHeaders=[ Header HdrContentLength "0" ] , rqBody="" , rqURI=u { uriQuery= '?' : enc } -- What about old query? } POST -> Request { rqMethod=POST , rqHeaders=[ Header HdrContentType "application/x-www-form-urlencoded", Header HdrContentLength (show $ length enc) ] , rqBody=enc , rqURI=u } _ -> error ("unexpected request: " ++ show m) HTTP-4000.3.3/Network/BufferType.hs0000644000000000000000000001435312656464615014773 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Network.BufferType -- Description : Abstract representation of request and response buffer types. -- Copyright : See LICENSE file -- License : BSD -- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) -- -- In order to give the user freedom in how request and response content -- is represented, a sufficiently abstract representation is needed of -- these internally. The "Network.BufferType" module provides this, defining -- the 'BufferType' class and its ad-hoc representation of buffer operations -- via the 'BufferOp' record. -- -- This module provides definitions for the standard buffer types that the -- package supports, i.e., for @String@ and @ByteString@ (strict and lazy.) -- ----------------------------------------------------------------------------- module Network.BufferType ( BufferType(..) , BufferOp(..) , strictBufferOp , lazyBufferOp , stringBufferOp ) where import qualified Data.ByteString as Strict hiding ( unpack, pack, span ) import qualified Data.ByteString.Char8 as Strict ( unpack, pack, span ) import qualified Data.ByteString.Lazy as Lazy hiding ( pack, unpack,span ) import qualified Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack, span ) import System.IO ( Handle ) import Data.Word ( Word8 ) import Network.HTTP.Utils ( crlf, lf ) -- | The @BufferType@ class encodes, in a mixed-mode way, the interface -- that the library requires to operate over data embedded in HTTP -- requests and responses. That is, we use explicit dictionaries -- for the operations, but overload the name of the dicts themselves. -- class BufferType bufType where bufferOps :: BufferOp bufType instance BufferType Lazy.ByteString where bufferOps = lazyBufferOp instance BufferType Strict.ByteString where bufferOps = strictBufferOp instance BufferType String where bufferOps = stringBufferOp -- | @BufferOp@ encodes the I/O operations of the underlying buffer over -- a Handle in an (explicit) dictionary type. May not be needed, but gives -- us flexibility in explicit overriding and wrapping up of these methods. -- -- Along with IO operations is an ad-hoc collection of functions for working -- with these abstract buffers, as needed by the internals of the code -- that processes requests and responses. -- -- We supply three default @BufferOp@ values, for @String@ along with the -- strict and lazy versions of @ByteString@. To add others, provide @BufferOp@ -- definitions for data BufferOp a = BufferOp { buf_hGet :: Handle -> Int -> IO a , buf_hGetContents :: Handle -> IO a , buf_hPut :: Handle -> a -> IO () , buf_hGetLine :: Handle -> IO a , buf_empty :: a , buf_append :: a -> a -> a , buf_concat :: [a] -> a , buf_fromStr :: String -> a , buf_toStr :: a -> String , buf_snoc :: a -> Word8 -> a , buf_splitAt :: Int -> a -> (a,a) , buf_span :: (Char -> Bool) -> a -> (a,a) , buf_isLineTerm :: a -> Bool , buf_isEmpty :: a -> Bool } instance Eq (BufferOp a) where _ == _ = False -- | @strictBufferOp@ is the 'BufferOp' definition over @ByteString@s, -- the non-lazy kind. strictBufferOp :: BufferOp Strict.ByteString strictBufferOp = BufferOp { buf_hGet = Strict.hGet , buf_hGetContents = Strict.hGetContents , buf_hPut = Strict.hPut , buf_hGetLine = Strict.hGetLine , buf_append = Strict.append , buf_concat = Strict.concat , buf_fromStr = Strict.pack , buf_toStr = Strict.unpack , buf_snoc = Strict.snoc , buf_splitAt = Strict.splitAt , buf_span = Strict.span , buf_empty = Strict.empty , buf_isLineTerm = \ b -> Strict.length b == 2 && p_crlf == b || Strict.length b == 1 && p_lf == b , buf_isEmpty = Strict.null } where p_crlf = Strict.pack crlf p_lf = Strict.pack lf -- | @lazyBufferOp@ is the 'BufferOp' definition over @ByteString@s, -- the non-strict kind. lazyBufferOp :: BufferOp Lazy.ByteString lazyBufferOp = BufferOp { buf_hGet = Lazy.hGet , buf_hGetContents = Lazy.hGetContents , buf_hPut = Lazy.hPut , buf_hGetLine = \ h -> Strict.hGetLine h >>= \ l -> return (Lazy.fromChunks [l]) , buf_append = Lazy.append , buf_concat = Lazy.concat , buf_fromStr = Lazy.pack , buf_toStr = Lazy.unpack , buf_snoc = Lazy.snoc , buf_splitAt = \ i x -> Lazy.splitAt (fromIntegral i) x , buf_span = Lazy.span , buf_empty = Lazy.empty , buf_isLineTerm = \ b -> Lazy.length b == 2 && p_crlf == b || Lazy.length b == 1 && p_lf == b , buf_isEmpty = Lazy.null } where p_crlf = Lazy.pack crlf p_lf = Lazy.pack lf -- | @stringBufferOp@ is the 'BufferOp' definition over @String@s. -- It is defined in terms of @strictBufferOp@ operations, -- unpacking/converting to @String@ when needed. stringBufferOp :: BufferOp String stringBufferOp =BufferOp { buf_hGet = \ h n -> buf_hGet strictBufferOp h n >>= return . Strict.unpack , buf_hGetContents = \ h -> buf_hGetContents strictBufferOp h >>= return . Strict.unpack , buf_hPut = \ h s -> buf_hPut strictBufferOp h (Strict.pack s) , buf_hGetLine = \ h -> buf_hGetLine strictBufferOp h >>= return . Strict.unpack , buf_append = (++) , buf_concat = concat , buf_fromStr = id , buf_toStr = id , buf_snoc = \ a x -> a ++ [toEnum (fromIntegral x)] , buf_splitAt = splitAt , buf_span = \ p a -> case Strict.span p (Strict.pack a) of (x,y) -> (Strict.unpack x, Strict.unpack y) , buf_empty = [] , buf_isLineTerm = \ b -> b == crlf || b == lf , buf_isEmpty = null } HTTP-4000.3.3/Network/Stream.hs0000644000000000000000000000532312656464615014150 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Network.Stream -- Copyright : See LICENSE file -- License : BSD -- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) -- -- An library for creating abstract streams. Originally part of Gray's\/Bringert's -- HTTP module. -- -- * Changes by Robin Bate Boerop : -- - Removed unnecessary import statements. -- - Moved Debug code to StreamDebugger.hs -- - Moved Socket-related code to StreamSocket.hs. -- -- * Changes by Simon Foster: -- - Split Network.HTTPmodule up into to separate -- Network.[Stream,TCP,HTTP] modules ----------------------------------------------------------------------------- module Network.Stream ( Stream(..) , ConnError(..) , Result , bindE , fmapE , failParse -- :: String -> Result a , failWith -- :: ConnError -> Result a , failMisc -- :: String -> Result a ) where import Control.Monad.Error data ConnError = ErrorReset | ErrorClosed | ErrorParse String | ErrorMisc String deriving(Show,Eq) instance Error ConnError where noMsg = strMsg "unknown error" strMsg x = ErrorMisc x -- in GHC 7.0 the Monad instance for Error no longer -- uses fail x = Left (strMsg x). failMisc is therefore -- used instead. failMisc :: String -> Result a failMisc x = failWith (strMsg x) failParse :: String -> Result a failParse x = failWith (ErrorParse x) failWith :: ConnError -> Result a failWith x = Left x bindE :: Result a -> (a -> Result b) -> Result b bindE (Left e) _ = Left e bindE (Right v) f = f v fmapE :: (a -> Result b) -> IO (Result a) -> IO (Result b) fmapE f a = do x <- a case x of Left e -> return (Left e) Right r -> return (f r) -- | This is the type returned by many exported network functions. type Result a = Either ConnError {- error -} a {- result -} -- | Streams should make layering of TLS protocol easier in future, -- they allow reading/writing to files etc for debugging, -- they allow use of protocols other than TCP/IP -- and they allow customisation. -- -- Instances of this class should not trim -- the input in any way, e.g. leave LF on line -- endings etc. Unless that is exactly the behaviour -- you want from your twisted instances ;) class Stream x where readLine :: x -> IO (Result String) readBlock :: x -> Int -> IO (Result String) writeBlock :: x -> String -> IO (Result ()) close :: x -> IO () closeOnEnd :: x -> Bool -> IO () -- ^ True => shutdown the connection when response has been read / end-of-stream -- has been reached. HTTP-4000.3.3/Network/TCP.hs0000644000000000000000000003732212656464615013347 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Network.TCP -- Copyright : See LICENSE file -- License : BSD -- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) -- -- Some utility functions for working with the Haskell @network@ package. Mostly -- for internal use by the @Network.HTTP@ code. -- ----------------------------------------------------------------------------- module Network.TCP ( Connection , EndPoint(..) , openTCPPort , isConnectedTo , openTCPConnection , socketConnection , isTCPConnectedTo , HandleStream , HStream(..) , StreamHooks(..) , nullHooks , setStreamHooks , getStreamHooks , hstreamToConnection ) where import Network.Socket ( Socket, SocketOption(KeepAlive) , SocketType(Stream), connect , shutdown, ShutdownCmd(..) , sClose, setSocketOption, getPeerName , socket, Family(AF_UNSPEC), defaultProtocol, getAddrInfo , defaultHints, addrFamily, withSocketsDo , addrSocketType, addrAddress ) import qualified Network.Stream as Stream ( Stream(readBlock, readLine, writeBlock, close, closeOnEnd) ) import Network.Stream ( ConnError(..) , Result , failWith , failMisc ) import Network.BufferType import Network.HTTP.Base ( catchIO ) import Network.Socket ( socketToHandle ) import Data.Char ( toLower ) import Data.Word ( Word8 ) import Control.Concurrent import Control.Exception ( onException ) import Control.Monad ( liftM, when ) import System.IO ( Handle, hFlush, IOMode(..), hClose ) import System.IO.Error ( isEOFError ) import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy ----------------------------------------------------------------- ------------------ TCP Connections ------------------------------ ----------------------------------------------------------------- -- | The 'Connection' newtype is a wrapper that allows us to make -- connections an instance of the Stream class, without GHC extensions. -- While this looks sort of like a generic reference to the transport -- layer it is actually TCP specific, which can be seen in the -- implementation of the 'Stream Connection' instance. newtype Connection = Connection (HandleStream String) newtype HandleStream a = HandleStream {getRef :: MVar (Conn a)} data EndPoint = EndPoint { epHost :: String, epPort :: Int } instance Eq EndPoint where EndPoint host1 port1 == EndPoint host2 port2 = map toLower host1 == map toLower host2 && port1 == port2 data Conn a = MkConn { connSock :: ! Socket , connHandle :: Handle , connBuffer :: BufferOp a , connInput :: Maybe a , connEndPoint :: EndPoint , connHooks :: Maybe (StreamHooks a) , connCloseEOF :: Bool -- True => close socket upon reaching end-of-stream. } | ConnClosed deriving(Eq) hstreamToConnection :: HandleStream String -> Connection hstreamToConnection h = Connection h connHooks' :: Conn a -> Maybe (StreamHooks a) connHooks' ConnClosed{} = Nothing connHooks' x = connHooks x -- all of these are post-op hooks data StreamHooks ty = StreamHooks { hook_readLine :: (ty -> String) -> Result ty -> IO () , hook_readBlock :: (ty -> String) -> Int -> Result ty -> IO () , hook_writeBlock :: (ty -> String) -> ty -> Result () -> IO () , hook_close :: IO () , hook_name :: String -- hack alert: name of the hook itself. } instance Eq ty => Eq (StreamHooks ty) where (==) _ _ = True nullHooks :: StreamHooks ty nullHooks = StreamHooks { hook_readLine = \ _ _ -> return () , hook_readBlock = \ _ _ _ -> return () , hook_writeBlock = \ _ _ _ -> return () , hook_close = return () , hook_name = "" } setStreamHooks :: HandleStream ty -> StreamHooks ty -> IO () setStreamHooks h sh = modifyMVar_ (getRef h) (\ c -> return c{connHooks=Just sh}) getStreamHooks :: HandleStream ty -> IO (Maybe (StreamHooks ty)) getStreamHooks h = readMVar (getRef h) >>= return.connHooks -- | @HStream@ overloads the use of 'HandleStream's, letting you -- overload the handle operations over the type that is communicated -- across the handle. It comes in handy for @Network.HTTP@ 'Request' -- and 'Response's as the payload representation isn't fixed, but overloaded. -- -- The library comes with instances for @ByteString@s and @String@, but -- should you want to plug in your own payload representation, defining -- your own @HStream@ instance _should_ be all that it takes. -- class BufferType bufType => HStream bufType where openStream :: String -> Int -> IO (HandleStream bufType) openSocketStream :: String -> Int -> Socket -> IO (HandleStream bufType) readLine :: HandleStream bufType -> IO (Result bufType) readBlock :: HandleStream bufType -> Int -> IO (Result bufType) writeBlock :: HandleStream bufType -> bufType -> IO (Result ()) close :: HandleStream bufType -> IO () closeQuick :: HandleStream bufType -> IO () closeOnEnd :: HandleStream bufType -> Bool -> IO () instance HStream Strict.ByteString where openStream = openTCPConnection openSocketStream = socketConnection readBlock c n = readBlockBS c n readLine c = readLineBS c writeBlock c str = writeBlockBS c str close c = closeIt c Strict.null True closeQuick c = closeIt c Strict.null False closeOnEnd c f = closeEOF c f instance HStream Lazy.ByteString where openStream = \ a b -> openTCPConnection_ a b True openSocketStream = \ a b c -> socketConnection_ a b c True readBlock c n = readBlockBS c n readLine c = readLineBS c writeBlock c str = writeBlockBS c str close c = closeIt c Lazy.null True closeQuick c = closeIt c Lazy.null False closeOnEnd c f = closeEOF c f instance Stream.Stream Connection where readBlock (Connection c) = Network.TCP.readBlock c readLine (Connection c) = Network.TCP.readLine c writeBlock (Connection c) = Network.TCP.writeBlock c close (Connection c) = Network.TCP.close c closeOnEnd (Connection c) f = Network.TCP.closeEOF c f instance HStream String where openStream = openTCPConnection openSocketStream = socketConnection readBlock ref n = readBlockBS ref n -- This function uses a buffer, at this time the buffer is just 1000 characters. -- (however many bytes this is is left to the user to decypher) readLine ref = readLineBS ref -- The 'Connection' object allows no outward buffering, -- since in general messages are serialised in their entirety. writeBlock ref str = writeBlockBS ref str -- (stringToBuf str) -- Closes a Connection. Connection will no longer -- allow any of the other Stream functions. Notice that a Connection may close -- at any time before a call to this function. This function is idempotent. -- (I think the behaviour here is TCP specific) close c = closeIt c null True -- Closes a Connection without munching the rest of the stream. closeQuick c = closeIt c null False closeOnEnd c f = closeEOF c f -- | @openTCPPort uri port@ establishes a connection to a remote -- host, using 'getHostByName' which possibly queries the DNS system, hence -- may trigger a network connection. openTCPPort :: String -> Int -> IO Connection openTCPPort uri port = openTCPConnection uri port >>= return.Connection -- Add a "persistent" option? Current persistent is default. -- Use "Result" type for synchronous exception reporting? openTCPConnection :: BufferType ty => String -> Int -> IO (HandleStream ty) openTCPConnection uri port = openTCPConnection_ uri port False openTCPConnection_ :: BufferType ty => String -> Int -> Bool -> IO (HandleStream ty) openTCPConnection_ uri port stashInput = do -- HACK: uri is sometimes obtained by calling Network.URI.uriRegName, and this includes -- the surrounding square brackets for an RFC 2732 host like [::1]. It's not clear whether -- it should, or whether all call sites should be using something different instead, but -- the simplest short-term fix is to strip any surrounding square brackets here. -- It shouldn't affect any as this is the only situation they can occur - see RFC 3986. let fixedUri = case uri of '[':(rest@(c:_)) | last rest == ']' -> if c == 'v' || c == 'V' then error $ "Unsupported post-IPv6 address " ++ uri else init rest _ -> uri -- use withSocketsDo here in case the caller hasn't used it, which would make getAddrInfo fail on Windows -- although withSocketsDo is supposed to wrap the entire program, in practice it is safe to use it locally -- like this as it just does a once-only installation of a shutdown handler to run at program exit, -- rather than actually shutting down after the action addrinfos <- withSocketsDo $ getAddrInfo (Just $ defaultHints { addrFamily = AF_UNSPEC, addrSocketType = Stream }) (Just fixedUri) (Just . show $ port) case addrinfos of [] -> fail "openTCPConnection: getAddrInfo returned no address information" (a:_) -> do s <- socket (addrFamily a) Stream defaultProtocol onException (do setSocketOption s KeepAlive 1 connect s (addrAddress a) socketConnection_ fixedUri port s stashInput ) (sClose s) -- | @socketConnection@, like @openConnection@ but using a pre-existing 'Socket'. socketConnection :: BufferType ty => String -> Int -> Socket -> IO (HandleStream ty) socketConnection hst port sock = socketConnection_ hst port sock False -- Internal function used to control the on-demand streaming of input -- for /lazy/ streams. socketConnection_ :: BufferType ty => String -> Int -> Socket -> Bool -> IO (HandleStream ty) socketConnection_ hst port sock stashInput = do h <- socketToHandle sock ReadWriteMode mb <- case stashInput of { True -> liftM Just $ buf_hGetContents bufferOps h; _ -> return Nothing } let conn = MkConn { connSock = sock , connHandle = h , connBuffer = bufferOps , connInput = mb , connEndPoint = EndPoint hst port , connHooks = Nothing , connCloseEOF = False } v <- newMVar conn return (HandleStream v) closeConnection :: HStream a => HandleStream a -> IO Bool -> IO () closeConnection ref readL = do -- won't hold onto the lock for the duration -- we are draining it...ToDo: have Connection -- into a shutting-down state so that other -- threads will simply back off if/when attempting -- to also close it. c <- readMVar (getRef ref) closeConn c `catchIO` (\_ -> return ()) modifyMVar_ (getRef ref) (\ _ -> return ConnClosed) where -- Be kind to peer & close gracefully. closeConn ConnClosed = return () closeConn conn = do let sk = connSock conn hFlush (connHandle conn) shutdown sk ShutdownSend suck readL hClose (connHandle conn) shutdown sk ShutdownReceive sClose sk suck :: IO Bool -> IO () suck rd = do f <- rd if f then return () else suck rd -- | Checks both that the underlying Socket is connected -- and that the connection peer matches the given -- host name (which is recorded locally). isConnectedTo :: Connection -> EndPoint -> IO Bool isConnectedTo (Connection conn) endPoint = isTCPConnectedTo conn endPoint isTCPConnectedTo :: HandleStream ty -> EndPoint -> IO Bool isTCPConnectedTo conn endPoint = do v <- readMVar (getRef conn) case v of ConnClosed -> return False _ | connEndPoint v == endPoint -> catchIO (getPeerName (connSock v) >> return True) (const $ return False) | otherwise -> return False readBlockBS :: HStream a => HandleStream a -> Int -> IO (Result a) readBlockBS ref n = onNonClosedDo ref $ \ conn -> do x <- bufferGetBlock ref n maybe (return ()) (\ h -> hook_readBlock h (buf_toStr $ connBuffer conn) n x) (connHooks' conn) return x -- This function uses a buffer, at this time the buffer is just 1000 characters. -- (however many bytes this is is left for the user to decipher) readLineBS :: HStream a => HandleStream a -> IO (Result a) readLineBS ref = onNonClosedDo ref $ \ conn -> do x <- bufferReadLine ref maybe (return ()) (\ h -> hook_readLine h (buf_toStr $ connBuffer conn) x) (connHooks' conn) return x -- The 'Connection' object allows no outward buffering, -- since in general messages are serialised in their entirety. writeBlockBS :: HandleStream a -> a -> IO (Result ()) writeBlockBS ref b = onNonClosedDo ref $ \ conn -> do x <- bufferPutBlock (connBuffer conn) (connHandle conn) b maybe (return ()) (\ h -> hook_writeBlock h (buf_toStr $ connBuffer conn) b x) (connHooks' conn) return x closeIt :: HStream ty => HandleStream ty -> (ty -> Bool) -> Bool -> IO () closeIt c p b = do closeConnection c (if b then readLineBS c >>= \ x -> case x of { Right xs -> return (p xs); _ -> return True} else return True) conn <- readMVar (getRef c) maybe (return ()) (hook_close) (connHooks' conn) closeEOF :: HandleStream ty -> Bool -> IO () closeEOF c flg = modifyMVar_ (getRef c) (\ co -> return co{connCloseEOF=flg}) bufferGetBlock :: HStream a => HandleStream a -> Int -> IO (Result a) bufferGetBlock ref n = onNonClosedDo ref $ \ conn -> do case connInput conn of Just c -> do let (a,b) = buf_splitAt (connBuffer conn) n c modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b}) return (return a) _ -> do catchIO (buf_hGet (connBuffer conn) (connHandle conn) n >>= return.return) (\ e -> if isEOFError e then do when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ()) return (return (buf_empty (connBuffer conn))) else return (failMisc (show e))) bufferPutBlock :: BufferOp a -> Handle -> a -> IO (Result ()) bufferPutBlock ops h b = catchIO (buf_hPut ops h b >> hFlush h >> return (return ())) (\ e -> return (failMisc (show e))) bufferReadLine :: HStream a => HandleStream a -> IO (Result a) bufferReadLine ref = onNonClosedDo ref $ \ conn -> do case connInput conn of Just c -> do let (a,b0) = buf_span (connBuffer conn) (/='\n') c let (newl,b1) = buf_splitAt (connBuffer conn) 1 b0 modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b1}) return (return (buf_append (connBuffer conn) a newl)) _ -> catchIO (buf_hGetLine (connBuffer conn) (connHandle conn) >>= return . return . appendNL (connBuffer conn)) (\ e -> if isEOFError e then do when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ()) return (return (buf_empty (connBuffer conn))) else return (failMisc (show e))) where -- yes, this s**ks.. _may_ have to be addressed if perf -- suggests worthiness. appendNL ops b = buf_snoc ops b nl nl :: Word8 nl = fromIntegral (fromEnum '\n') onNonClosedDo :: HandleStream a -> (Conn a -> IO (Result b)) -> IO (Result b) onNonClosedDo h act = do x <- readMVar (getRef h) case x of ConnClosed{} -> return (failWith ErrorClosed) _ -> act x HTTP-4000.3.3/Network/StreamDebugger.hs0000644000000000000000000000671712656464615015625 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Network.StreamDebugger -- Copyright : See LICENSE file -- License : BSD -- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) -- -- Implements debugging of @Stream@s. Originally part of Gray's\/Bringert's -- HTTP module. -- -- * Changes by Robin Bate Boerop : -- - Created. Made minor formatting changes. -- ----------------------------------------------------------------------------- module Network.StreamDebugger ( StreamDebugger , debugStream , debugByteStream ) where import Network.Stream (Stream(..)) import System.IO ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile, hSetBuffering, BufferMode(NoBuffering) ) import Network.TCP ( HandleStream, HStream, StreamHooks(..), setStreamHooks, getStreamHooks ) -- | Allows stream logging. Refer to 'debugStream' below. data StreamDebugger x = Dbg Handle x instance (Stream x) => Stream (StreamDebugger x) where readBlock (Dbg h x) n = do val <- readBlock x n hPutStrLn h ("--readBlock " ++ show n) hPutStrLn h (show val) return val readLine (Dbg h x) = do val <- readLine x hPutStrLn h ("--readLine") hPutStrLn h (show val) return val writeBlock (Dbg h x) str = do val <- writeBlock x str hPutStrLn h ("--writeBlock" ++ show str) hPutStrLn h (show val) return val close (Dbg h x) = do hPutStrLn h "--closing..." hFlush h close x hPutStrLn h "--closed." hClose h closeOnEnd (Dbg h x) f = do hPutStrLn h ("--close-on-end.." ++ show f) hFlush h closeOnEnd x f -- | Wraps a stream with logging I\/O. -- The first argument is a filename which is opened in @AppendMode@. debugStream :: (Stream a) => FilePath -> a -> IO (StreamDebugger a) debugStream file stream = do h <- openFile file AppendMode hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.") return (Dbg h stream) debugByteStream :: HStream ty => FilePath -> HandleStream ty -> IO (HandleStream ty) debugByteStream file stream = do sh <- getStreamHooks stream case sh of Just h | hook_name h == file -> return stream -- reuse the stream hooks. _ -> do h <- openFile file AppendMode hSetBuffering h NoBuffering hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.") setStreamHooks stream (debugStreamHooks h file) return stream debugStreamHooks :: HStream ty => Handle -> String -> StreamHooks ty debugStreamHooks h nm = StreamHooks { hook_readBlock = \ toStr n val -> do let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} hPutStrLn h ("--readBlock " ++ show n) hPutStrLn h (either show show eval) , hook_readLine = \ toStr val -> do let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} hPutStrLn h ("--readLine") hPutStrLn h (either show show eval) , hook_writeBlock = \ toStr str val -> do hPutStrLn h ("--writeBlock " ++ show val) hPutStrLn h (toStr str) , hook_close = do hPutStrLn h "--closing..." hFlush h hClose h , hook_name = nm } HTTP-4000.3.3/Network/HTTP/0000755000000000000000000000000012656464615013135 5ustar0000000000000000HTTP-4000.3.3/Network/HTTP/HandleStream.hs0000644000000000000000000002466212656464615016052 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.HandleStream -- Copyright : See LICENSE file -- License : BSD -- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) -- -- A 'HandleStream'-based version of "Network.HTTP" interface. -- -- For more detailed information about what the individual exports do, please consult -- the documentation for "Network.HTTP". /Notice/ however that the functions here do -- not perform any kind of normalization prior to transmission (or receipt); you are -- responsible for doing any such yourself, or, if you prefer, just switch to using -- "Network.HTTP" function instead. -- ----------------------------------------------------------------------------- module Network.HTTP.HandleStream ( simpleHTTP -- :: Request ty -> IO (Result (Response ty)) , simpleHTTP_ -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) , sendHTTP -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) , sendHTTP_notify -- :: HStream ty => HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty)) , receiveHTTP -- :: HStream ty => HandleStream ty -> IO (Result (Request ty)) , respondHTTP -- :: HStream ty => HandleStream ty -> Response ty -> IO () , simpleHTTP_debug -- :: FilePath -> Request DebugString -> IO (Response DebugString) ) where ----------------------------------------------------------------- ------------------ Imports -------------------------------------- ----------------------------------------------------------------- import Network.BufferType import Network.Stream ( fmapE, Result ) import Network.StreamDebugger ( debugByteStream ) import Network.TCP (HStream(..), HandleStream ) import Network.HTTP.Base import Network.HTTP.Headers import Network.HTTP.Utils ( trim, readsOne ) import Data.Char (toLower) import Data.Maybe (fromMaybe) import Control.Exception (onException) import Control.Monad (when) ----------------------------------------------------------------- ------------------ Misc ----------------------------------------- ----------------------------------------------------------------- -- | @simpleHTTP@ transmits a resource across a non-persistent connection. simpleHTTP :: HStream ty => Request ty -> IO (Result (Response ty)) simpleHTTP r = do auth <- getAuth r failHTTPS (rqURI r) c <- openStream (host auth) (fromMaybe 80 (port auth)) simpleHTTP_ c r -- | @simpleHTTP_debug debugFile req@ behaves like 'simpleHTTP', but logs -- the HTTP operation via the debug file @debugFile@. simpleHTTP_debug :: HStream ty => FilePath -> Request ty -> IO (Result (Response ty)) simpleHTTP_debug httpLogFile r = do auth <- getAuth r failHTTPS (rqURI r) c0 <- openStream (host auth) (fromMaybe 80 (port auth)) c <- debugByteStream httpLogFile c0 simpleHTTP_ c r -- | Like 'simpleHTTP', but acting on an already opened stream. simpleHTTP_ :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) simpleHTTP_ s r = sendHTTP s r -- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ over -- @hStream@, but does not alter the status of the connection, nor request it to be -- closed upon receiving the response. sendHTTP :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) sendHTTP conn rq = sendHTTP_notify conn rq (return ()) -- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but -- lets you supply an IO @action@ to execute once the request has been successfully -- transmitted over the connection. Useful when you want to set up tracing of -- request transmission and its performance. sendHTTP_notify :: HStream ty => HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty)) sendHTTP_notify conn rq onSendComplete = do when providedClose $ (closeOnEnd conn True) onException (sendMain conn rq onSendComplete) (close conn) where providedClose = findConnClose (rqHeaders rq) -- From RFC 2616, section 8.2.3: -- 'Because of the presence of older implementations, the protocol allows -- ambiguous situations in which a client may send "Expect: 100- -- continue" without receiving either a 417 (Expectation Failed) status -- or a 100 (Continue) status. Therefore, when a client sends this -- header field to an origin server (possibly via a proxy) from which it -- has never seen a 100 (Continue) status, the client SHOULD NOT wait -- for an indefinite period before sending the request body.' -- -- Since we would wait forever, I have disabled use of 100-continue for now. sendMain :: HStream ty => HandleStream ty -> Request ty -> (IO ()) -> IO (Result (Response ty)) sendMain conn rqst onSendComplete = do --let str = if null (rqBody rqst) -- then show rqst -- else show (insertHeader HdrExpect "100-continue" rqst) -- TODO review throwing away of result _ <- writeBlock conn (buf_fromStr bufferOps $ show rqst) -- write body immediately, don't wait for 100 CONTINUE -- TODO review throwing away of result _ <- writeBlock conn (rqBody rqst) onSendComplete rsp <- getResponseHead conn switchResponse conn True False rsp rqst -- Hmmm, this could go bad if we keep getting "100 Continue" -- responses... Except this should never happen according -- to the RFC. switchResponse :: HStream ty => HandleStream ty -> Bool {- allow retry? -} -> Bool {- is body sent? -} -> Result ResponseData -> Request ty -> IO (Result (Response ty)) switchResponse _ _ _ (Left e) _ = return (Left e) -- retry on connreset? -- if we attempt to use the same socket then there is an excellent -- chance that the socket is not in a completely closed state. switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = case matchResponse (rqMethod rqst) cd of Continue | not bdy_sent -> do {- Time to send the body -} writeBlock conn (rqBody rqst) >>= either (return . Left) (\ _ -> do rsp <- getResponseHead conn switchResponse conn allow_retry True rsp rqst) | otherwise -> do {- keep waiting -} rsp <- getResponseHead conn switchResponse conn allow_retry bdy_sent rsp rqst Retry -> do {- Request with "Expect" header failed. Trouble is the request contains Expects other than "100-Continue" -} -- TODO review throwing away of result _ <- writeBlock conn ((buf_append bufferOps) (buf_fromStr bufferOps (show rqst)) (rqBody rqst)) rsp <- getResponseHead conn switchResponse conn False bdy_sent rsp rqst Done -> do when (findConnClose hdrs) (closeOnEnd conn True) return (Right $ Response cd rn hdrs (buf_empty bufferOps)) DieHorribly str -> do close conn return (responseParseError "Invalid response:" str) ExpectEntity -> do r <- fmapE (\ (ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)) $ maybe (maybe (hopefulTransfer bo (readLine conn) []) (\ x -> readsOne (linearTransfer (readBlock conn)) (return$responseParseError "unrecognized content-length value" x) x) cl) (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn)) (uglyDeathTransfer "sendHTTP")) tc case r of Left{} -> do close conn return r Right (Response _ _ hs _) -> do when (findConnClose hs) (closeOnEnd conn True) return r where tc = lookupHeader HdrTransferEncoding hdrs cl = lookupHeader HdrContentLength hdrs bo = bufferOps -- reads and parses headers getResponseHead :: HStream ty => HandleStream ty -> IO (Result ResponseData) getResponseHead conn = fmapE (\es -> parseResponseHead (map (buf_toStr bufferOps) es)) (readTillEmpty1 bufferOps (readLine conn)) -- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@ receiveHTTP :: HStream bufTy => HandleStream bufTy -> IO (Result (Request bufTy)) receiveHTTP conn = getRequestHead >>= either (return . Left) processRequest where -- reads and parses headers getRequestHead :: IO (Result RequestData) getRequestHead = do fmapE (\es -> parseRequestHead (map (buf_toStr bufferOps) es)) (readTillEmpty1 bufferOps (readLine conn)) processRequest (rm,uri,hdrs) = fmapE (\ (ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)) $ maybe (maybe (return (Right ([], buf_empty bo))) -- hopefulTransfer "" (\ x -> readsOne (linearTransfer (readBlock conn)) (return$responseParseError "unrecognized Content-Length value" x) x) cl) (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn)) (uglyDeathTransfer "receiveHTTP")) tc where -- FIXME : Also handle 100-continue. tc = lookupHeader HdrTransferEncoding hdrs cl = lookupHeader HdrContentLength hdrs bo = bufferOps -- | @respondHTTP hStream httpResponse@ transmits an HTTP 'Response' over -- the 'HandleStream' @hStream@. It could be used to implement simple web -- server interactions, performing the dual role to 'sendHTTP'. respondHTTP :: HStream ty => HandleStream ty -> Response ty -> IO () respondHTTP conn rsp = do -- TODO: review throwing away of result _ <- writeBlock conn (buf_fromStr bufferOps $ show rsp) -- write body immediately, don't wait for 100 CONTINUE -- TODO: review throwing away of result _ <- writeBlock conn (rspBody rsp) return () ------------------------------------------------------------------------------ headerName :: String -> String headerName x = map toLower (trim x) ifChunked :: a -> a -> String -> a ifChunked a b s = case headerName s of "chunked" -> a _ -> b HTTP-4000.3.3/Network/HTTP/MD5Aux.hs0000644000000000000000000003105212656464615014535 0ustar0000000000000000module Network.HTTP.MD5Aux (md5, md5s, md5i, MD5(..), ABCD(..), Zord64, Str(..), BoolList(..), WordList(..)) where import Data.Char (ord, chr) import Data.Bits (rotateL, shiftL, shiftR, (.&.), (.|.), xor, complement) import Data.Word (Word32, Word64) rotL :: Word32 -> Int -> Word32 rotL x = rotateL x type Zord64 = Word64 -- ===================== TYPES AND CLASS DEFINTIONS ======================== type XYZ = (Word32, Word32, Word32) type Rotation = Int newtype ABCD = ABCD (Word32, Word32, Word32, Word32) deriving (Eq, Show) newtype Str = Str String newtype BoolList = BoolList [Bool] newtype WordList = WordList ([Word32], Word64) -- Anything we want to work out the MD5 of must be an instance of class MD5 class MD5 a where get_next :: a -> ([Word32], Int, a) -- get the next blocks worth -- \ \ \------ the rest of the input -- \ \--------- the number of bits returned -- \--------------- the bits returned in 32bit words len_pad :: Word64 -> a -> a -- append the padding and length finished :: a -> Bool -- Have we run out of input yet? -- Mainly exists because it's fairly easy to do MD5s on input where the -- length is not a multiple of 8 instance MD5 BoolList where get_next (BoolList s) = (bools_to_word32s ys, length ys, BoolList zs) where (ys, zs) = splitAt 512 s len_pad l (BoolList bs) = BoolList (bs ++ [True] ++ replicate (fromIntegral $ (447 - l) .&. 511) False ++ [l .&. (shiftL 1 x) > 0 | x <- (mangle [0..63])] ) where mangle [] = [] mangle xs = reverse ys ++ mangle zs where (ys, zs) = splitAt 8 xs finished (BoolList s) = s == [] -- The string instance is fairly straightforward instance MD5 Str where get_next (Str s) = (string_to_word32s ys, 8 * length ys, Str zs) where (ys, zs) = splitAt 64 s len_pad c64 (Str s) = Str (s ++ padding ++ l) where padding = '\128':replicate (fromIntegral zeros) '\000' zeros = shiftR ((440 - c64) .&. 511) 3 l = length_to_chars 8 c64 finished (Str s) = s == "" -- YA instance that is believed will be useful instance MD5 WordList where get_next (WordList (ws, l)) = (xs, fromIntegral taken, WordList (ys, l - taken)) where (xs, ys) = splitAt 16 ws taken = if l > 511 then 512 else l .&. 511 len_pad c64 (WordList (ws, l)) = WordList (beginning ++ nextish ++ blanks ++ size, newlen) where beginning = if length ws > 0 then start ++ lastone' else [] start = init ws lastone = last ws offset = c64 .&. 31 lastone' = [if offset > 0 then lastone + theone else lastone] theone = shiftL (shiftR 128 (fromIntegral $ offset .&. 7)) (fromIntegral $ offset .&. (31 - 7)) nextish = if offset == 0 then [128] else [] c64' = c64 + (32 - offset) num_blanks = (fromIntegral $ shiftR ((448 - c64') .&. 511) 5) blanks = replicate num_blanks 0 lowsize = fromIntegral $ c64 .&. (shiftL 1 32 - 1) topsize = fromIntegral $ shiftR c64 32 size = [lowsize, topsize] newlen = l .&. (complement 511) + if c64 .&. 511 >= 448 then 1024 else 512 finished (WordList (_, z)) = z == 0 instance Num ABCD where ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2) (-) = error "(-){ABCD}: no instance method defined" (*) = error "(*){ABCD}: no instance method defined" signum = error "signum{ABCD}: no instance method defined" fromInteger = error "fromInteger{ABCD}: no instance method defined" abs = error "abs{ABCD}: no instance method defined" -- ===================== EXPORTED FUNCTIONS ======================== -- The simplest function, gives you the MD5 of a string as 4-tuple of -- 32bit words. md5 :: (MD5 a) => a -> ABCD md5 m = md5_main False 0 magic_numbers m -- Returns a hex number ala the md5sum program md5s :: (MD5 a) => a -> String md5s = abcd_to_string . md5 -- Returns an integer equivalent to the above hex number md5i :: (MD5 a) => a -> Integer md5i = abcd_to_integer . md5 -- ===================== THE CORE ALGORITHM ======================== -- Decides what to do. The first argument indicates if padding has been -- added. The second is the length mod 2^64 so far. Then we have the -- starting state, the rest of the string and the final state. md5_main :: (MD5 a) => Bool -- Have we added padding yet? -> Word64 -- The length so far mod 2^64 -> ABCD -- The initial state -> a -- The non-processed portion of the message -> ABCD -- The resulting state md5_main padded ilen abcd m = if finished m && padded then abcd else md5_main padded' (ilen + 512) (abcd + abcd') m'' where (m16, l, m') = get_next m len' = ilen + fromIntegral l ((m16', _, m''), padded') = if not padded && l < 512 then (get_next $ len_pad len' m, True) else ((m16, l, m'), padded) abcd' = md5_do_block abcd m16' -- md5_do_block processes a 512 bit block by calling md5_round 4 times to -- apply each round with the correct constants and permutations of the -- block md5_do_block :: ABCD -- Initial state -> [Word32] -- The block to be processed - 16 32bit words -> ABCD -- Resulting state md5_do_block abcd0 w = abcd4 where (r1, r2, r3, r4) = rounds {- map (\x -> w !! x) [1,6,11,0,5,10,15,4,9,14,3,8,13,2,7,12] -- [(5 * x + 1) `mod` 16 | x <- [0..15]] map (\x -> w !! x) [5,8,11,14,1,4,7,10,13,0,3,6,9,12,15,2] -- [(3 * x + 5) `mod` 16 | x <- [0..15]] map (\x -> w !! x) [0,7,14,5,12,3,10,1,8,15,6,13,4,11,2,9] -- [(7 * x) `mod` 16 | x <- [0..15]] -} perm5 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] = [c1,c6,c11,c0,c5,c10,c15,c4,c9,c14,c3,c8,c13,c2,c7,c12] perm5 _ = error "broke at perm5" perm3 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] = [c5,c8,c11,c14,c1,c4,c7,c10,c13,c0,c3,c6,c9,c12,c15,c2] perm3 _ = error "broke at perm3" perm7 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] = [c0,c7,c14,c5,c12,c3,c10,c1,c8,c15,c6,c13,c4,c11,c2,c9] perm7 _ = error "broke at perm7" abcd1 = md5_round md5_f abcd0 w r1 abcd2 = md5_round md5_g abcd1 (perm5 w) r2 abcd3 = md5_round md5_h abcd2 (perm3 w) r3 abcd4 = md5_round md5_i abcd3 (perm7 w) r4 -- md5_round does one of the rounds. It takes an auxiliary function and foldls -- (md5_inner_function f) to repeatedly apply it to the initial state with the -- correct constants md5_round :: (XYZ -> Word32) -- Auxiliary function (F, G, H or I -- for those of you with a copy of -- the prayer book^W^WRFC) -> ABCD -- Initial state -> [Word32] -- The 16 32bit words of input -> [(Rotation, Word32)] -- The list of 16 rotations and -- additive constants -> ABCD -- Resulting state md5_round f abcd s ns = foldl (md5_inner_function f) abcd ns' where ns' = zipWith (\x (y, z) -> (y, x + z)) s ns -- Apply one of the functions md5_[fghi] and put the new ABCD together md5_inner_function :: (XYZ -> Word32) -- Auxiliary function -> ABCD -- Initial state -> (Rotation, Word32) -- The rotation and additive -- constant (X[i] + T[j]) -> ABCD -- Resulting state md5_inner_function f (ABCD (a, b, c, d)) (s, ki) = ABCD (d, a', b, c) where mid_a = a + f(b,c,d) + ki rot_a = rotL mid_a s a' = b + rot_a -- The 4 auxiliary functions md5_f :: XYZ -> Word32 md5_f (x, y, z) = z `xor` (x .&. (y `xor` z)) {- optimised version of: (x .&. y) .|. ((complement x) .&. z) -} md5_g :: XYZ -> Word32 md5_g (x, y, z) = md5_f (z, x, y) {- was: (x .&. z) .|. (y .&. (complement z)) -} md5_h :: XYZ -> Word32 md5_h (x, y, z) = x `xor` y `xor` z md5_i :: XYZ -> Word32 md5_i (x, y, z) = y `xor` (x .|. (complement z)) -- The magic numbers from the RFC. magic_numbers :: ABCD magic_numbers = ABCD (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476) -- The 4 lists of (rotation, additive constant) tuples, one for each round rounds :: ([(Rotation, Word32)], [(Rotation, Word32)], [(Rotation, Word32)], [(Rotation, Word32)]) rounds = (r1, r2, r3, r4) where r1 = [(s11, 0xd76aa478), (s12, 0xe8c7b756), (s13, 0x242070db), (s14, 0xc1bdceee), (s11, 0xf57c0faf), (s12, 0x4787c62a), (s13, 0xa8304613), (s14, 0xfd469501), (s11, 0x698098d8), (s12, 0x8b44f7af), (s13, 0xffff5bb1), (s14, 0x895cd7be), (s11, 0x6b901122), (s12, 0xfd987193), (s13, 0xa679438e), (s14, 0x49b40821)] r2 = [(s21, 0xf61e2562), (s22, 0xc040b340), (s23, 0x265e5a51), (s24, 0xe9b6c7aa), (s21, 0xd62f105d), (s22, 0x2441453), (s23, 0xd8a1e681), (s24, 0xe7d3fbc8), (s21, 0x21e1cde6), (s22, 0xc33707d6), (s23, 0xf4d50d87), (s24, 0x455a14ed), (s21, 0xa9e3e905), (s22, 0xfcefa3f8), (s23, 0x676f02d9), (s24, 0x8d2a4c8a)] r3 = [(s31, 0xfffa3942), (s32, 0x8771f681), (s33, 0x6d9d6122), (s34, 0xfde5380c), (s31, 0xa4beea44), (s32, 0x4bdecfa9), (s33, 0xf6bb4b60), (s34, 0xbebfbc70), (s31, 0x289b7ec6), (s32, 0xeaa127fa), (s33, 0xd4ef3085), (s34, 0x4881d05), (s31, 0xd9d4d039), (s32, 0xe6db99e5), (s33, 0x1fa27cf8), (s34, 0xc4ac5665)] r4 = [(s41, 0xf4292244), (s42, 0x432aff97), (s43, 0xab9423a7), (s44, 0xfc93a039), (s41, 0x655b59c3), (s42, 0x8f0ccc92), (s43, 0xffeff47d), (s44, 0x85845dd1), (s41, 0x6fa87e4f), (s42, 0xfe2ce6e0), (s43, 0xa3014314), (s44, 0x4e0811a1), (s41, 0xf7537e82), (s42, 0xbd3af235), (s43, 0x2ad7d2bb), (s44, 0xeb86d391)] s11 = 7 s12 = 12 s13 = 17 s14 = 22 s21 = 5 s22 = 9 s23 = 14 s24 = 20 s31 = 4 s32 = 11 s33 = 16 s34 = 23 s41 = 6 s42 = 10 s43 = 15 s44 = 21 -- ===================== CONVERSION FUNCTIONS ======================== -- Turn the 4 32 bit words into a string representing the hex number they -- represent. abcd_to_string :: ABCD -> String abcd_to_string (ABCD (a,b,c,d)) = concat $ map display_32bits_as_hex [a,b,c,d] -- Split the 32 bit word up, swap the chunks over and convert the numbers -- to their hex equivalents. display_32bits_as_hex :: Word32 -> String display_32bits_as_hex w = swap_pairs cs where cs = map (\x -> getc $ (shiftR w (4*x)) .&. 15) [0..7] getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n) swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs swap_pairs _ = [] -- Convert to an integer, performing endianness magic as we go abcd_to_integer :: ABCD -> Integer abcd_to_integer (ABCD (a,b,c,d)) = rev_num a * 2^(96 :: Int) + rev_num b * 2^(64 :: Int) + rev_num c * 2^(32 :: Int) + rev_num d rev_num :: Word32 -> Integer rev_num i = toInteger j `mod` (2^(32 :: Int)) -- NHC's fault ~~~~~~~~~~~~~~~~~~~~~ where j = foldl (\so_far next -> shiftL so_far 8 + (shiftR i next .&. 255)) 0 [0,8,16,24] -- Used to convert a 64 byte string to 16 32bit words string_to_word32s :: String -> [Word32] string_to_word32s "" = [] string_to_word32s ss = this:string_to_word32s ss' where (s, ss') = splitAt 4 ss this = foldr (\c w -> shiftL w 8 + (fromIntegral.ord) c) 0 s -- Used to convert a list of 512 bools to 16 32bit words bools_to_word32s :: [Bool] -> [Word32] bools_to_word32s [] = [] bools_to_word32s bs = this:bools_to_word32s rest where (bs1, bs1') = splitAt 8 bs (bs2, bs2') = splitAt 8 bs1' (bs3, bs3') = splitAt 8 bs2' (bs4, rest) = splitAt 8 bs3' this = boolss_to_word32 [bs1, bs2, bs3, bs4] bools_to_word8 = foldl (\w b -> shiftL w 1 + if b then 1 else 0) 0 boolss_to_word32 = foldr (\w8 w -> shiftL w 8 + bools_to_word8 w8) 0 -- Convert the size into a list of characters used by the len_pad function -- for strings length_to_chars :: Int -> Word64 -> String length_to_chars 0 _ = [] length_to_chars p n = this:length_to_chars (p-1) (shiftR n 8) where this = chr $ fromIntegral $ n .&. 255 HTTP-4000.3.3/Network/HTTP/Base.hs0000644000000000000000000010557412656464615014357 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Base -- Copyright : See LICENSE file -- License : BSD -- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) -- -- Definitions of @Request@ and @Response@ types along with functions -- for normalizing them. It is assumed to be an internal module; user -- code should, if possible, import @Network.HTTP@ to access the functionality -- that this module provides. -- -- Additionally, the module exports internal functions for working with URLs, -- and for handling the processing of requests and responses coming back. -- ----------------------------------------------------------------------------- module Network.HTTP.Base ( -- ** Constants httpVersion -- :: String -- ** HTTP , Request(..) , Response(..) , RequestMethod(..) , Request_String , Response_String , HTTPRequest , HTTPResponse -- ** URL Encoding , urlEncode , urlDecode , urlEncodeVars -- ** URI authority parsing , URIAuthority(..) , parseURIAuthority -- internal , uriToAuthorityString -- :: URI -> String , uriAuthToString -- :: URIAuth -> String , uriAuthPort -- :: Maybe URI -> URIAuth -> Int , reqURIAuth -- :: Request ty -> URIAuth , parseResponseHead -- :: [String] -> Result ResponseData , parseRequestHead -- :: [String] -> Result RequestData , ResponseNextStep(..) , matchResponse , ResponseData , ResponseCode , RequestData , NormalizeRequestOptions(..) , defaultNormalizeRequestOptions -- :: NormalizeRequestOptions ty , RequestNormalizer , normalizeRequest -- :: NormalizeRequestOptions ty -> Request ty -> Request ty , splitRequestURI , getAuth , normalizeRequestURI , normalizeHostHeader , findConnClose -- internal export (for the use by Network.HTTP.{Stream,ByteStream} ) , linearTransfer , hopefulTransfer , chunkedTransfer , uglyDeathTransfer , readTillEmpty1 , readTillEmpty2 , defaultGETRequest , defaultGETRequest_ , mkRequest , setRequestBody , defaultUserAgent , httpPackageVersion , libUA {- backwards compatibility, will disappear..soon -} , catchIO , catchIO_ , responseParseError , getRequestVersion , getResponseVersion , setRequestVersion , setResponseVersion , failHTTPS ) where import Network.URI ( URI(uriAuthority, uriPath, uriScheme) , URIAuth(URIAuth, uriUserInfo, uriRegName, uriPort) , parseURIReference ) import Control.Monad ( guard ) import Control.Monad.Error () import Data.Bits ( (.&.), (.|.), shiftL, shiftR ) import Data.Word ( Word8 ) import Data.Char ( digitToInt, intToDigit, toLower, isDigit, isAscii, isAlphaNum, ord, chr ) import Data.List ( partition, find ) import Data.Maybe ( listToMaybe, fromMaybe ) import Numeric ( readHex ) import Network.Stream import Network.BufferType ( BufferOp(..), BufferType(..) ) import Network.HTTP.Headers import Network.HTTP.Utils ( trim, crlf, sp, readsOne ) import qualified Network.HTTP.Base64 as Base64 (encode) import Text.Read.Lex (readDecP) import Text.ParserCombinators.ReadP ( ReadP, readP_to_S, char, (<++), look, munch, munch1 ) import Control.Exception as Exception (catch, IOException) import qualified Paths_HTTP as Self (version) import Data.Version (showVersion) ----------------------------------------------------------------- ------------------ URI Authority parsing ------------------------ ----------------------------------------------------------------- data URIAuthority = URIAuthority { user :: Maybe String, password :: Maybe String, host :: String, port :: Maybe Int } deriving (Eq,Show) -- | Parse the authority part of a URL. -- -- > RFC 1732, section 3.1: -- > -- > //:@:/ -- > Some or all of the parts ":@", ":", -- > ":", and "/" may be excluded. parseURIAuthority :: String -> Maybe URIAuthority parseURIAuthority s = listToMaybe (map fst (readP_to_S pURIAuthority s)) pURIAuthority :: ReadP URIAuthority pURIAuthority = do (u,pw) <- (pUserInfo `before` char '@') <++ return (Nothing, Nothing) h <- rfc2732host <++ munch (/=':') p <- orNothing (char ':' >> readDecP) look >>= guard . null return URIAuthority{ user=u, password=pw, host=h, port=p } -- RFC2732 adds support for '[literal-ipv6-address]' in the host part of a URL rfc2732host :: ReadP String rfc2732host = do _ <- char '[' res <- munch1 (/=']') _ <- char ']' return res pUserInfo :: ReadP (Maybe String, Maybe String) pUserInfo = do u <- orNothing (munch (`notElem` ":@")) p <- orNothing (char ':' >> munch (/='@')) return (u,p) before :: Monad m => m a -> m b -> m a before a b = a >>= \x -> b >> return x orNothing :: ReadP a -> ReadP (Maybe a) orNothing p = fmap Just p <++ return Nothing -- This function duplicates old Network.URI.authority behaviour. uriToAuthorityString :: URI -> String uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u) uriAuthToString :: URIAuth -> String uriAuthToString ua = concat [ uriUserInfo ua , uriRegName ua , uriPort ua ] uriAuthPort :: Maybe URI -> URIAuth -> Int uriAuthPort mbURI u = case uriPort u of (':':s) -> readsOne id (default_port mbURI) s _ -> default_port mbURI where default_port Nothing = default_http default_port (Just url) = case map toLower $ uriScheme url of "http:" -> default_http "https:" -> default_https -- todo: refine _ -> default_http default_http = 80 default_https = 443 failHTTPS :: Monad m => URI -> m () failHTTPS uri | map toLower (uriScheme uri) == "https:" = fail "https not supported" | otherwise = return () -- Fish out the authority from a possibly normalized Request, i.e., -- the information may either be in the request's URI or inside -- the Host: header. reqURIAuth :: Request ty -> URIAuth reqURIAuth req = case uriAuthority (rqURI req) of Just ua -> ua _ -> case lookupHeader HdrHost (rqHeaders req) of Nothing -> error ("reqURIAuth: no URI authority for: " ++ show req) Just h -> case toHostPort h of (ht,p) -> URIAuth { uriUserInfo = "" , uriRegName = ht , uriPort = p } where -- Note: just in case you're wondering..the convention is to include the ':' -- in the port part.. toHostPort h = break (==':') h ----------------------------------------------------------------- ------------------ HTTP Messages -------------------------------- ----------------------------------------------------------------- -- Protocol version httpVersion :: String httpVersion = "HTTP/1.1" -- | The HTTP request method, to be used in the 'Request' object. -- We are missing a few of the stranger methods, but these are -- not really necessary until we add full TLS. data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE | CONNECT | Custom String deriving(Eq) instance Show RequestMethod where show x = case x of HEAD -> "HEAD" PUT -> "PUT" GET -> "GET" POST -> "POST" DELETE -> "DELETE" OPTIONS -> "OPTIONS" TRACE -> "TRACE" CONNECT -> "CONNECT" Custom c -> c rqMethodMap :: [(String, RequestMethod)] rqMethodMap = [("HEAD", HEAD), ("PUT", PUT), ("GET", GET), ("POST", POST), ("DELETE", DELETE), ("OPTIONS", OPTIONS), ("TRACE", TRACE), ("CONNECT", CONNECT)] -- -- for backwards-ish compatibility; suggest -- migrating to new Req/Resp by adding type param. -- type Request_String = Request String type Response_String = Response String -- Hmm..I really want to use these for the record -- type, but it will upset codebases wanting to -- migrate (and live with using pre-HTTPbis versions.) type HTTPRequest a = Request a type HTTPResponse a = Response a -- | An HTTP Request. -- The 'Show' instance of this type is used for message serialisation, -- which means no body data is output. data Request a = Request { rqURI :: URI -- ^ might need changing in future -- 1) to support '*' uri in OPTIONS request -- 2) transparent support for both relative -- & absolute uris, although this should -- already work (leave scheme & host parts empty). , rqMethod :: RequestMethod , rqHeaders :: [Header] , rqBody :: a } -- Notice that request body is not included, -- this show function is used to serialise -- a request for the transport link, we send -- the body separately where possible. instance Show (Request a) where show req@(Request u m h _) = show m ++ sp ++ alt_uri ++ sp ++ ver ++ crlf ++ foldr (++) [] (map show (dropHttpVersion h)) ++ crlf where ver = fromMaybe httpVersion (getRequestVersion req) alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' then u { uriPath = '/' : uriPath u } else u instance HasHeaders (Request a) where getHeaders = rqHeaders setHeaders rq hdrs = rq { rqHeaders=hdrs } -- | For easy pattern matching, HTTP response codes @xyz@ are -- represented as @(x,y,z)@. type ResponseCode = (Int,Int,Int) -- | @ResponseData@ contains the head of a response payload; -- HTTP response code, accompanying text description + header -- fields. type ResponseData = (ResponseCode,String,[Header]) -- | @RequestData@ contains the head of a HTTP request; method, -- its URL along with the auxillary/supporting header data. type RequestData = (RequestMethod,URI,[Header]) -- | An HTTP Response. -- The 'Show' instance of this type is used for message serialisation, -- which means no body data is output, additionally the output will -- show an HTTP version of 1.1 instead of the actual version returned -- by a server. data Response a = Response { rspCode :: ResponseCode , rspReason :: String , rspHeaders :: [Header] , rspBody :: a } -- This is an invalid representation of a received response, -- since we have made the assumption that all responses are HTTP/1.1 instance Show (Response a) where show rsp@(Response (a,b,c) reason headers _) = ver ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf ++ foldr (++) [] (map show (dropHttpVersion headers)) ++ crlf where ver = fromMaybe httpVersion (getResponseVersion rsp) instance HasHeaders (Response a) where getHeaders = rspHeaders setHeaders rsp hdrs = rsp { rspHeaders=hdrs } ------------------------------------------------------------------ ------------------ Request Building ------------------------------ ------------------------------------------------------------------ -- | Deprecated. Use 'defaultUserAgent' libUA :: String libUA = "hs-HTTP-4000.0.9" {-# DEPRECATED libUA "Use defaultUserAgent instead (but note the user agent name change)" #-} -- | A default user agent string. The string is @\"haskell-HTTP/$version\"@ -- where @$version@ is the version of this HTTP package. -- defaultUserAgent :: String defaultUserAgent = "haskell-HTTP/" ++ httpPackageVersion -- | The version of this HTTP package as a string, e.g. @\"4000.1.2\"@. This -- may be useful to include in a user agent string so that you can determine -- from server logs what version of this package HTTP clients are using. -- This can be useful for tracking down HTTP compatibility quirks. -- httpPackageVersion :: String httpPackageVersion = showVersion Self.version defaultGETRequest :: URI -> Request_String defaultGETRequest uri = defaultGETRequest_ uri defaultGETRequest_ :: BufferType a => URI -> Request a defaultGETRequest_ uri = mkRequest GET uri -- | 'mkRequest method uri' constructs a well formed -- request for the given HTTP method and URI. It does not -- normalize the URI for the request _nor_ add the required -- Host: header. That is done either explicitly by the user -- or when requests are normalized prior to transmission. mkRequest :: BufferType ty => RequestMethod -> URI -> Request ty mkRequest meth uri = req where req = Request { rqURI = uri , rqBody = empty , rqHeaders = [ Header HdrContentLength "0" , Header HdrUserAgent defaultUserAgent ] , rqMethod = meth } empty = buf_empty (toBufOps req) -- set rqBody, Content-Type and Content-Length headers. setRequestBody :: Request_String -> (String, String) -> Request_String setRequestBody req (typ, body) = req' { rqBody=body } where req' = replaceHeader HdrContentType typ . replaceHeader HdrContentLength (show $ length body) $ req {- -- stub out the user info. updAuth = fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri) withHost = case uriToAuthorityString uri{uriAuthority=updAuth} of "" -> id h -> ((Header HdrHost h):) uri_req | forProxy = uri | otherwise = snd (splitRequestURI uri) -} toBufOps :: BufferType a => Request a -> BufferOp a toBufOps _ = bufferOps ----------------------------------------------------------------- ------------------ Parsing -------------------------------------- ----------------------------------------------------------------- -- Parsing a request parseRequestHead :: [String] -> Result RequestData parseRequestHead [] = Left ErrorClosed parseRequestHead (com:hdrs) = do (version,rqm,uri) <- requestCommand com (words com) hdrs' <- parseHeaders hdrs return (rqm,uri,withVer version hdrs') where withVer [] hs = hs withVer (h:_) hs = withVersion h hs requestCommand l _yes@(rqm:uri:version) = case (parseURIReference uri, lookup rqm rqMethodMap) of (Just u, Just r) -> return (version,r,u) (Just u, Nothing) -> return (version,Custom rqm,u) _ -> parse_err l requestCommand l _ | null l = failWith ErrorClosed | otherwise = parse_err l parse_err l = responseParseError "parseRequestHead" ("Request command line parse failure: " ++ l) -- Parsing a response parseResponseHead :: [String] -> Result ResponseData parseResponseHead [] = failWith ErrorClosed parseResponseHead (sts:hdrs) = do (version,code,reason) <- responseStatus sts (words sts) hdrs' <- parseHeaders hdrs return (code,reason, withVersion version hdrs') where responseStatus _l _yes@(version:code:reason) = return (version,match code,concatMap (++" ") reason) responseStatus l _no | null l = failWith ErrorClosed -- an assumption | otherwise = parse_err l parse_err l = responseParseError "parseResponseHead" ("Response status line parse failure: " ++ l) match [a,b,c] = (digitToInt a, digitToInt b, digitToInt c) match _ = (-1,-1,-1) -- will create appropriate behaviour -- To avoid changing the @RequestData@ and @ResponseData@ types -- just for this (and the upstream backwards compat. woes that -- will result in), encode version info as a custom header. -- Used by 'parseResponseData' and 'parseRequestData'. -- -- Note: the Request and Response types do not currently represent -- the version info explicitly in their record types. You have to use -- {get,set}{Request,Response}Version for that. withVersion :: String -> [Header] -> [Header] withVersion v hs | v == httpVersion = hs -- don't bother adding it if the default. | otherwise = (Header (HdrCustom "X-HTTP-Version") v) : hs -- | @getRequestVersion req@ returns the HTTP protocol version of -- the request @req@. If @Nothing@, the default 'httpVersion' can be assumed. getRequestVersion :: Request a -> Maybe String getRequestVersion r = getHttpVersion r -- | @setRequestVersion v req@ returns a new request, identical to -- @req@, but with its HTTP version set to @v@. setRequestVersion :: String -> Request a -> Request a setRequestVersion s r = setHttpVersion r s -- | @getResponseVersion rsp@ returns the HTTP protocol version of -- the response @rsp@. If @Nothing@, the default 'httpVersion' can be -- assumed. getResponseVersion :: Response a -> Maybe String getResponseVersion r = getHttpVersion r -- | @setResponseVersion v rsp@ returns a new response, identical to -- @rsp@, but with its HTTP version set to @v@. setResponseVersion :: String -> Response a -> Response a setResponseVersion s r = setHttpVersion r s -- internal functions for accessing HTTP-version info in -- requests and responses. Not exported as it exposes ho -- version info is represented internally. getHttpVersion :: HasHeaders a => a -> Maybe String getHttpVersion r = fmap toVersion $ find isHttpVersion $ getHeaders r where toVersion (Header _ x) = x setHttpVersion :: HasHeaders a => a -> String -> a setHttpVersion r v = setHeaders r $ withVersion v $ dropHttpVersion $ getHeaders r dropHttpVersion :: [Header] -> [Header] dropHttpVersion hs = filter (not.isHttpVersion) hs isHttpVersion :: Header -> Bool isHttpVersion (Header (HdrCustom "X-HTTP-Version") _) = True isHttpVersion _ = False ----------------------------------------------------------------- ------------------ HTTP Send / Recv ---------------------------------- ----------------------------------------------------------------- data ResponseNextStep = Continue | Retry | Done | ExpectEntity | DieHorribly String matchResponse :: RequestMethod -> ResponseCode -> ResponseNextStep matchResponse rqst rsp = case rsp of (1,0,0) -> Continue (1,0,1) -> Done -- upgrade to TLS (1,_,_) -> Continue -- default (2,0,4) -> Done (2,0,5) -> Done (2,_,_) -> ans (3,0,4) -> Done (3,0,5) -> Done (3,_,_) -> ans (4,1,7) -> Retry -- Expectation failed (4,_,_) -> ans (5,_,_) -> ans (a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised") where ans | rqst == HEAD = Done | otherwise = ExpectEntity ----------------------------------------------------------------- ------------------ A little friendly funtionality --------------- ----------------------------------------------------------------- {- I had a quick look around but couldn't find any RFC about the encoding of data on the query string. I did find an IETF memo, however, so this is how I justify the urlEncode and urlDecode methods. Doc name: draft-tiwari-appl-wxxx-forms-01.txt (look on www.ietf.org) Reserved chars: ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved. Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`" URI delims: "<" | ">" | "#" | "%" | <"> Unallowed ASCII: Also unallowed: any non-us-ascii character Escape method: char -> '%' a b where a, b :: Hex digits -} replacement_character :: Char replacement_character = '\xfffd' -- | Encode a single Haskell Char to a list of Word8 values, in UTF8 format. -- -- Shamelessly stolen from utf-8string-0.3.7 encodeChar :: Char -> [Word8] encodeChar = map fromIntegral . go . ord where go oc | oc <= 0x7f = [oc] | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6) , 0x80 + oc .&. 0x3f ] | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12) , 0x80 + ((oc `shiftR` 6) .&. 0x3f) , 0x80 + oc .&. 0x3f ] | otherwise = [ 0xf0 + (oc `shiftR` 18) , 0x80 + ((oc `shiftR` 12) .&. 0x3f) , 0x80 + ((oc `shiftR` 6) .&. 0x3f) , 0x80 + oc .&. 0x3f ] -- | Decode a UTF8 string packed into a list of Word8 values, directly to String -- -- Shamelessly stolen from utf-8string-0.3.7 decode :: [Word8] -> String decode [ ] = "" decode (c:cs) | c < 0x80 = chr (fromEnum c) : decode cs | c < 0xc0 = replacement_character : decode cs | c < 0xe0 = multi1 | c < 0xf0 = multi_byte 2 0xf 0x800 | c < 0xf8 = multi_byte 3 0x7 0x10000 | c < 0xfc = multi_byte 4 0x3 0x200000 | c < 0xfe = multi_byte 5 0x1 0x4000000 | otherwise = replacement_character : decode cs where multi1 = case cs of c1 : ds | c1 .&. 0xc0 == 0x80 -> let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|. fromEnum (c1 .&. 0x3f) in if d >= 0x000080 then toEnum d : decode ds else replacement_character : decode ds _ -> replacement_character : decode cs multi_byte :: Int -> Word8 -> Int -> [Char] multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask)) where aux 0 rs acc | overlong <= acc && acc <= 0x10ffff && (acc < 0xd800 || 0xdfff < acc) && (acc < 0xfffe || 0xffff < acc) = chr acc : decode rs | otherwise = replacement_character : decode rs aux n (r:rs) acc | r .&. 0xc0 == 0x80 = aux (n-1) rs $ shiftL acc 6 .|. fromEnum (r .&. 0x3f) aux _ rs _ = replacement_character : decode rs -- This function is a bit funny because potentially the input String could contain some actual Unicode -- characters (though this shouldn't happen for most use cases), so we have to preserve those characters -- while simultaneously decoding any UTF-8 data urlDecode :: String -> String urlDecode = go [] where go bs ('%':a:b:rest) = go (fromIntegral (16 * digitToInt a + digitToInt b) : bs) rest go bs (h:t) | fromEnum h < 256 = go (fromIntegral (fromEnum h) : bs) t -- Treat ASCII as just another byte of UTF-8 go [] [] = [] go [] (h:t) = h : go [] t -- h >= 256, so can't be part of any UTF-8 byte sequence go bs rest = decode (reverse bs) ++ go [] rest urlEncode :: String -> String urlEncode [] = [] urlEncode (ch:t) | (isAscii ch && isAlphaNum ch) || ch `elem` "-_.~" = ch : urlEncode t | not (isAscii ch) = foldr escape (urlEncode t) (encodeChar ch) | otherwise = escape (fromIntegral (fromEnum ch)) (urlEncode t) where escape b rs = '%':showH (b `div` 16) (showH (b `mod` 16) rs) showH :: Word8 -> String -> String showH x xs | x <= 9 = to (o_0 + x) : xs | otherwise = to (o_A + (x-10)) : xs where to = toEnum . fromIntegral fro = fromIntegral . fromEnum o_0 = fro '0' o_A = fro 'A' -- Encode form variables, useable in either the -- query part of a URI, or the body of a POST request. -- I have no source for this information except experience, -- this sort of encoding worked fine in CGI programming. urlEncodeVars :: [(String,String)] -> String urlEncodeVars ((n,v):t) = let (same,diff) = partition ((==n) . fst) t in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same) ++ urlEncodeRest diff where urlEncodeRest [] = [] urlEncodeRest diff = '&' : urlEncodeVars diff urlEncodeVars [] = [] -- | @getAuth req@ fishes out the authority portion of the URL in a request's @Host@ -- header. getAuth :: Monad m => Request ty -> m URIAuthority getAuth r = -- ToDo: verify that Network.URI functionality doesn't take care of this (now.) case parseURIAuthority auth of Just x -> return x Nothing -> fail $ "Network.HTTP.Base.getAuth: Error parsing URI authority '" ++ auth ++ "'" where auth = maybe (uriToAuthorityString uri) id (findHeader HdrHost r) uri = rqURI r {-# DEPRECATED normalizeRequestURI "Please use Network.HTTP.Base.normalizeRequest instead" #-} normalizeRequestURI :: Bool{-do close-} -> {-URI-}String -> Request ty -> Request ty normalizeRequestURI doClose h r = (if doClose then replaceHeader HdrConnection "close" else id) $ insertHeaderIfMissing HdrHost h $ r { rqURI = (rqURI r){ uriScheme = "" , uriAuthority = Nothing }} -- | @NormalizeRequestOptions@ brings together the various defaulting\/normalization options -- over 'Request's. Use 'defaultNormalizeRequestOptions' for the standard selection of option data NormalizeRequestOptions ty = NormalizeRequestOptions { normDoClose :: Bool , normForProxy :: Bool , normUserAgent :: Maybe String , normCustoms :: [RequestNormalizer ty] } -- | @RequestNormalizer@ is the shape of a (pure) function that rewrites -- a request into some normalized form. type RequestNormalizer ty = NormalizeRequestOptions ty -> Request ty -> Request ty defaultNormalizeRequestOptions :: NormalizeRequestOptions ty defaultNormalizeRequestOptions = NormalizeRequestOptions { normDoClose = False , normForProxy = False , normUserAgent = Just defaultUserAgent , normCustoms = [] } -- | @normalizeRequest opts req@ is the entry point to use to normalize your -- request prior to transmission (or other use.) Normalization is controlled -- via the @NormalizeRequestOptions@ record. normalizeRequest :: NormalizeRequestOptions ty -> Request ty -> Request ty normalizeRequest opts req = foldr (\ f -> f opts) req normalizers where --normalizers :: [RequestNormalizer ty] normalizers = ( normalizeHostURI : normalizeBasicAuth : normalizeConnectionClose : normalizeUserAgent : normCustoms opts ) -- | @normalizeUserAgent ua x req@ augments the request @req@ with -- a @User-Agent: ua@ header if @req@ doesn't already have a -- a @User-Agent:@ set. normalizeUserAgent :: RequestNormalizer ty normalizeUserAgent opts req = case normUserAgent opts of Nothing -> req Just ua -> case findHeader HdrUserAgent req of Just u | u /= defaultUserAgent -> req _ -> replaceHeader HdrUserAgent ua req -- | @normalizeConnectionClose opts req@ sets the header @Connection: close@ -- to indicate one-shot behavior iff @normDoClose@ is @True@. i.e., it then -- _replaces_ any an existing @Connection:@ header in @req@. normalizeConnectionClose :: RequestNormalizer ty normalizeConnectionClose opts req | normDoClose opts = replaceHeader HdrConnection "close" req | otherwise = req -- | @normalizeBasicAuth opts req@ sets the header @Authorization: Basic...@ -- if the "user:pass@" part is present in the "http://user:pass@host/path" -- of the URI. If Authorization header was present already it is not replaced. normalizeBasicAuth :: RequestNormalizer ty normalizeBasicAuth _ req = case getAuth req of Just uriauth -> case (user uriauth, password uriauth) of (Just u, Just p) -> insertHeaderIfMissing HdrAuthorization astr req where astr = "Basic " ++ base64encode (u ++ ":" ++ p) base64encode = Base64.encode . stringToOctets :: String -> String stringToOctets = map (fromIntegral . fromEnum) :: String -> [Word8] (_, _) -> req Nothing ->req -- | @normalizeHostURI forProxy req@ rewrites your request to have it -- follow the expected formats by the receiving party (proxy or server.) -- normalizeHostURI :: RequestNormalizer ty normalizeHostURI opts req = case splitRequestURI uri of ("",_uri_abs) | forProxy -> case findHeader HdrHost req of Nothing -> req -- no host/authority in sight..not much we can do. Just h -> req{rqURI=uri{ uriAuthority=Just URIAuth{uriUserInfo="", uriRegName=hst, uriPort=pNum} , uriScheme=if (null (uriScheme uri)) then "http" else uriScheme uri }} where hst = case span (/='@') user_hst of (as,'@':bs) -> case span (/=':') as of (_,_:_) -> bs _ -> user_hst _ -> user_hst (user_hst, pNum) = case span isDigit (reverse h) of (ds,':':bs) -> (reverse bs, ':':reverse ds) _ -> (h,"") | otherwise -> case findHeader HdrHost req of Nothing -> req -- no host/authority in sight..not much we can do...complain? Just{} -> req (h,uri_abs) | forProxy -> insertHeaderIfMissing HdrHost h req | otherwise -> replaceHeader HdrHost h req{rqURI=uri_abs} -- Note: _not_ stubbing out user:pass where uri0 = rqURI req -- stub out the user:pass uri = uri0{uriAuthority=fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri0)} forProxy = normForProxy opts {- Comments re: above rewriting: RFC 2616, section 5.1.2: "The most common form of Request-URI is that used to identify a resource on an origin server or gateway. In this case the absolute path of the URI MUST be transmitted (see section 3.2.1, abs_path) as the Request-URI, and the network location of the URI (authority) MUST be transmitted in a Host header field." We assume that this is the case, so we take the host name from the Host header if there is one, otherwise from the request-URI. Then we make the request-URI an abs_path and make sure that there is a Host header. -} splitRequestURI :: URI -> ({-authority-}String, URI) splitRequestURI uri = (uriToAuthorityString uri, uri{uriScheme="", uriAuthority=Nothing}) -- Adds a Host header if one is NOT ALREADY PRESENT.. {-# DEPRECATED normalizeHostHeader "Please use Network.HTTP.Base.normalizeRequest instead" #-} normalizeHostHeader :: Request ty -> Request ty normalizeHostHeader rq = insertHeaderIfMissing HdrHost (uriToAuthorityString $ rqURI rq) rq -- Looks for a "Connection" header with the value "close". -- Returns True when this is found. findConnClose :: [Header] -> Bool findConnClose hdrs = maybe False (\ x -> map toLower (trim x) == "close") (lookupHeader HdrConnection hdrs) -- | Used when we know exactly how many bytes to expect. linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a)) linearTransfer readBlk n = fmapE (\str -> Right ([],str)) (readBlk n) -- | Used when nothing about data is known, -- Unfortunately waiting for a socket closure -- causes bad behaviour. Here we just -- take data once and give up the rest. hopefulTransfer :: BufferOp a -> IO (Result a) -> [a] -> IO (Result ([Header],a)) hopefulTransfer bufOps readL strs = readL >>= either (\v -> return $ Left v) (\more -> if (buf_isEmpty bufOps more) then return (Right ([], buf_concat bufOps $ reverse strs)) else hopefulTransfer bufOps readL (more:strs)) -- | A necessary feature of HTTP\/1.1 -- Also the only transfer variety likely to -- return any footers. chunkedTransfer :: BufferOp a -> IO (Result a) -> (Int -> IO (Result a)) -> IO (Result ([Header], a)) chunkedTransfer bufOps readL readBlk = chunkedTransferC bufOps readL readBlk [] 0 chunkedTransferC :: BufferOp a -> IO (Result a) -> (Int -> IO (Result a)) -> [a] -> Int -> IO (Result ([Header], a)) chunkedTransferC bufOps readL readBlk acc n = do v <- readL case v of Left e -> return (Left e) Right line | size == 0 -> -- last chunk read; look for trailing headers.. fmapE (\ strs -> do ftrs <- parseHeaders (map (buf_toStr bufOps) strs) -- insert (computed) Content-Length header. let ftrs' = Header HdrContentLength (show n) : ftrs return (ftrs',buf_concat bufOps (reverse acc))) (readTillEmpty2 bufOps readL []) | otherwise -> do some <- readBlk size case some of Left e -> return (Left e) Right cdata -> do _ <- readL -- CRLF is mandated after the chunk block; ToDo: check that the line is empty.? chunkedTransferC bufOps readL readBlk (cdata:acc) (n+size) where size | buf_isEmpty bufOps line = 0 | otherwise = case readHex (buf_toStr bufOps line) of (hx,_):_ -> hx _ -> 0 -- | Maybe in the future we will have a sensible thing -- to do here, at that time we might want to change -- the name. uglyDeathTransfer :: String -> IO (Result ([Header],a)) uglyDeathTransfer loc = return (responseParseError loc "Unknown Transfer-Encoding") -- | Remove leading crlfs then call readTillEmpty2 (not required by RFC) readTillEmpty1 :: BufferOp a -> IO (Result a) -> IO (Result [a]) readTillEmpty1 bufOps readL = readL >>= either (return . Left) (\ s -> if buf_isLineTerm bufOps s then readTillEmpty1 bufOps readL else readTillEmpty2 bufOps readL [s]) -- | Read lines until an empty line (CRLF), -- also accepts a connection close as end of -- input, which is not an HTTP\/1.1 compliant -- thing to do - so probably indicates an -- error condition. readTillEmpty2 :: BufferOp a -> IO (Result a) -> [a] -> IO (Result [a]) readTillEmpty2 bufOps readL list = readL >>= either (return . Left) (\ s -> if buf_isLineTerm bufOps s || buf_isEmpty bufOps s then return (Right $ reverse (s:list)) else readTillEmpty2 bufOps readL (s:list)) -- -- Misc -- -- | @catchIO a h@ handles IO action exceptions throughout codebase; version-specific -- tweaks better go here. catchIO :: IO a -> (IOException -> IO a) -> IO a catchIO a h = Exception.catch a h catchIO_ :: IO a -> IO a -> IO a catchIO_ a h = Exception.catch a (\(_ :: IOException) -> h) responseParseError :: String -> String -> Result a responseParseError loc v = failWith (ErrorParse (loc ++ ' ':v)) HTTP-4000.3.3/Network/HTTP/Auth.hs0000644000000000000000000001653012656464615014377 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Auth -- Copyright : See LICENSE file -- License : BSD -- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) -- -- Representing HTTP Auth values in Haskell. -- Right now, it contains mostly functionality needed by 'Network.Browser'. -- ----------------------------------------------------------------------------- module Network.HTTP.Auth ( Authority(..) , Algorithm(..) , Challenge(..) , Qop(..) , headerToChallenge -- :: URI -> Header -> Maybe Challenge , withAuthority -- :: Authority -> Request ty -> String ) where import Network.URI import Network.HTTP.Base import Network.HTTP.Utils import Network.HTTP.Headers ( Header(..) ) import qualified Network.HTTP.MD5Aux as MD5 (md5s, Str(Str)) import qualified Network.HTTP.Base64 as Base64 (encode) import Text.ParserCombinators.Parsec ( Parser, char, many, many1, satisfy, parse, spaces, sepBy1 ) import Data.Char import Data.Maybe import Data.Word ( Word8 ) -- | @Authority@ specifies the HTTP Authentication method to use for -- a given domain/realm; @Basic@ or @Digest@. data Authority = AuthBasic { auRealm :: String , auUsername :: String , auPassword :: String , auSite :: URI } | AuthDigest{ auRealm :: String , auUsername :: String , auPassword :: String , auNonce :: String , auAlgorithm :: Maybe Algorithm , auDomain :: [URI] , auOpaque :: Maybe String , auQop :: [Qop] } data Challenge = ChalBasic { chRealm :: String } | ChalDigest { chRealm :: String , chDomain :: [URI] , chNonce :: String , chOpaque :: Maybe String , chStale :: Bool , chAlgorithm ::Maybe Algorithm , chQop :: [Qop] } -- | @Algorithm@ controls the digest algorithm to, @MD5@ or @MD5Session@. data Algorithm = AlgMD5 | AlgMD5sess deriving(Eq) instance Show Algorithm where show AlgMD5 = "md5" show AlgMD5sess = "md5-sess" -- | data Qop = QopAuth | QopAuthInt deriving(Eq,Show) -- | @withAuthority auth req@ generates a credentials value from the @auth@ 'Authority', -- in the context of the given request. -- -- If a client nonce was to be used then this function might need to be of type ... -> BrowserAction String withAuthority :: Authority -> Request ty -> String withAuthority a rq = case a of AuthBasic{} -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a) AuthDigest{} -> "Digest " ++ concat [ "username=" ++ quo (auUsername a) , ",realm=" ++ quo (auRealm a) , ",nonce=" ++ quo (auNonce a) , ",uri=" ++ quo digesturi , ",response=" ++ quo rspdigest -- plus optional stuff: , fromMaybe "" (fmap (\ alg -> ",algorithm=" ++ quo (show alg)) (auAlgorithm a)) , fromMaybe "" (fmap (\ o -> ",opaque=" ++ quo o) (auOpaque a)) , if null (auQop a) then "" else ",qop=auth" ] where quo s = '"':s ++ "\"" rspdigest = map toLower (kd (md5 a1) (noncevalue ++ ":" ++ md5 a2)) a1, a2 :: String a1 = auUsername a ++ ":" ++ auRealm a ++ ":" ++ auPassword a {- If the "qop" directive's value is "auth" or is unspecified, then A2 is: A2 = Method ":" digest-uri-value If the "qop" value is "auth-int", then A2 is: A2 = Method ":" digest-uri-value ":" H(entity-body) -} a2 = show (rqMethod rq) ++ ":" ++ digesturi digesturi = show (rqURI rq) noncevalue = auNonce a type Octet = Word8 -- FIXME: these probably only work right for latin-1 strings stringToOctets :: String -> [Octet] stringToOctets = map (fromIntegral . fromEnum) base64encode :: String -> String base64encode = Base64.encode . stringToOctets md5 :: String -> String md5 = MD5.md5s . MD5.Str kd :: String -> String -> String kd a b = md5 (a ++ ":" ++ b) -- | @headerToChallenge base www_auth@ tries to convert the @WWW-Authenticate@ header -- @www_auth@ into a 'Challenge' value. headerToChallenge :: URI -> Header -> Maybe Challenge headerToChallenge baseURI (Header _ str) = case parse challenge "" str of Left{} -> Nothing Right (name,props) -> case name of "basic" -> mkBasic props "digest" -> mkDigest props _ -> Nothing where challenge :: Parser (String,[(String,String)]) challenge = do { nme <- word ; spaces ; pps <- cprops ; return (map toLower nme,pps) } cprops = sepBy1 cprop comma comma = do { spaces ; _ <- char ',' ; spaces } cprop = do { nm <- word ; _ <- char '=' ; val <- quotedstring ; return (map toLower nm,val) } mkBasic, mkDigest :: [(String,String)] -> Maybe Challenge mkBasic params = fmap ChalBasic (lookup "realm" params) mkDigest params = -- with Maybe monad do { r <- lookup "realm" params ; n <- lookup "nonce" params ; return $ ChalDigest { chRealm = r , chDomain = (annotateURIs $ map parseURI $ words $ fromMaybe [] $ lookup "domain" params) , chNonce = n , chOpaque = lookup "opaque" params , chStale = "true" == (map toLower $ fromMaybe "" (lookup "stale" params)) , chAlgorithm= readAlgorithm (fromMaybe "MD5" $ lookup "algorithm" params) , chQop = readQop (fromMaybe "" $ lookup "qop" params) } } annotateURIs :: [Maybe URI] -> [URI] #if MIN_VERSION_network(2,4,0) annotateURIs = map (`relativeTo` baseURI) . catMaybes #else annotateURIs = (map (\u -> fromMaybe u (u `relativeTo` baseURI))) . catMaybes #endif -- Change These: readQop :: String -> [Qop] readQop = catMaybes . (map strToQop) . (splitBy ',') strToQop qs = case map toLower (trim qs) of "auth" -> Just QopAuth "auth-int" -> Just QopAuthInt _ -> Nothing readAlgorithm astr = case map toLower (trim astr) of "md5" -> Just AlgMD5 "md5-sess" -> Just AlgMD5sess _ -> Nothing word, quotedstring :: Parser String quotedstring = do { _ <- char '"' -- " ; str <- many (satisfy $ not . (=='"')) ; _ <- char '"' ; return str } word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':')) HTTP-4000.3.3/Network/HTTP/Stream.hs0000644000000000000000000002517012656464615014731 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Stream -- Copyright : See LICENSE file -- License : BSD -- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) -- -- Transmitting HTTP requests and responses holding @String@ in their payload bodies. -- This is one of the implementation modules for the "Network.HTTP" interface, representing -- request and response content as @String@s and transmitting them in non-packed form -- (cf. "Network.HTTP.HandleStream" and its use of @ByteString@s.) over 'Stream' handles. -- It is mostly here for backwards compatibility, representing how requests and responses -- were transmitted up until the 4.x releases of the HTTP package. -- -- For more detailed information about what the individual exports do, please consult -- the documentation for "Network.HTTP". /Notice/ however that the functions here do -- not perform any kind of normalization prior to transmission (or receipt); you are -- responsible for doing any such yourself, or, if you prefer, just switch to using -- "Network.HTTP" function instead. -- ----------------------------------------------------------------------------- module Network.HTTP.Stream ( module Network.Stream , simpleHTTP -- :: Request_String -> IO (Result Response_String) , simpleHTTP_ -- :: Stream s => s -> Request_String -> IO (Result Response_String) , sendHTTP -- :: Stream s => s -> Request_String -> IO (Result Response_String) , sendHTTP_notify -- :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) , receiveHTTP -- :: Stream s => s -> IO (Result Request_String) , respondHTTP -- :: Stream s => s -> Response_String -> IO () ) where ----------------------------------------------------------------- ------------------ Imports -------------------------------------- ----------------------------------------------------------------- import Network.Stream import Network.StreamDebugger (debugStream) import Network.TCP (openTCPPort) import Network.BufferType ( stringBufferOp ) import Network.HTTP.Base import Network.HTTP.Headers import Network.HTTP.Utils ( trim ) import Data.Char (toLower) import Data.Maybe (fromMaybe) import Control.Exception (onException) import Control.Monad (when) -- Turn on to enable HTTP traffic logging debug :: Bool debug = False -- File that HTTP traffic logs go to httpLogFile :: String httpLogFile = "http-debug.log" ----------------------------------------------------------------- ------------------ Misc ----------------------------------------- ----------------------------------------------------------------- -- | Simple way to transmit a resource across a non-persistent connection. simpleHTTP :: Request_String -> IO (Result Response_String) simpleHTTP r = do auth <- getAuth r c <- openTCPPort (host auth) (fromMaybe 80 (port auth)) simpleHTTP_ c r -- | Like 'simpleHTTP', but acting on an already opened stream. simpleHTTP_ :: Stream s => s -> Request_String -> IO (Result Response_String) simpleHTTP_ s r | not debug = sendHTTP s r | otherwise = do s' <- debugStream httpLogFile s sendHTTP s' r sendHTTP :: Stream s => s -> Request_String -> IO (Result Response_String) sendHTTP conn rq = sendHTTP_notify conn rq (return ()) sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) sendHTTP_notify conn rq onSendComplete = do when providedClose $ (closeOnEnd conn True) onException (sendMain conn rq onSendComplete) (close conn) where providedClose = findConnClose (rqHeaders rq) -- From RFC 2616, section 8.2.3: -- 'Because of the presence of older implementations, the protocol allows -- ambiguous situations in which a client may send "Expect: 100- -- continue" without receiving either a 417 (Expectation Failed) status -- or a 100 (Continue) status. Therefore, when a client sends this -- header field to an origin server (possibly via a proxy) from which it -- has never seen a 100 (Continue) status, the client SHOULD NOT wait -- for an indefinite period before sending the request body.' -- -- Since we would wait forever, I have disabled use of 100-continue for now. sendMain :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) sendMain conn rqst onSendComplete = do --let str = if null (rqBody rqst) -- then show rqst -- else show (insertHeader HdrExpect "100-continue" rqst) -- TODO review throwing away of result _ <- writeBlock conn (show rqst) -- write body immediately, don't wait for 100 CONTINUE -- TODO review throwing away of result _ <- writeBlock conn (rqBody rqst) onSendComplete rsp <- getResponseHead conn switchResponse conn True False rsp rqst -- reads and parses headers getResponseHead :: Stream s => s -> IO (Result ResponseData) getResponseHead conn = do lor <- readTillEmpty1 stringBufferOp (readLine conn) return $ lor >>= parseResponseHead -- Hmmm, this could go bad if we keep getting "100 Continue" -- responses... Except this should never happen according -- to the RFC. switchResponse :: Stream s => s -> Bool {- allow retry? -} -> Bool {- is body sent? -} -> Result ResponseData -> Request_String -> IO (Result Response_String) switchResponse _ _ _ (Left e) _ = return (Left e) -- retry on connreset? -- if we attempt to use the same socket then there is an excellent -- chance that the socket is not in a completely closed state. switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = case matchResponse (rqMethod rqst) cd of Continue | not bdy_sent -> {- Time to send the body -} do { val <- writeBlock conn (rqBody rqst) ; case val of Left e -> return (Left e) Right _ -> do { rsp <- getResponseHead conn ; switchResponse conn allow_retry True rsp rqst } } | otherwise -> {- keep waiting -} do { rsp <- getResponseHead conn ; switchResponse conn allow_retry bdy_sent rsp rqst } Retry -> {- Request with "Expect" header failed. Trouble is the request contains Expects other than "100-Continue" -} do { -- TODO review throwing away of result _ <- writeBlock conn (show rqst ++ rqBody rqst) ; rsp <- getResponseHead conn ; switchResponse conn False bdy_sent rsp rqst } Done -> do when (findConnClose hdrs) (closeOnEnd conn True) return (Right $ Response cd rn hdrs "") DieHorribly str -> do close conn return $ responseParseError "sendHTTP" ("Invalid response: " ++ str) ExpectEntity -> let tc = lookupHeader HdrTransferEncoding hdrs cl = lookupHeader HdrContentLength hdrs in do { rslt <- case tc of Nothing -> case cl of Just x -> linearTransfer (readBlock conn) (read x :: Int) Nothing -> hopefulTransfer stringBufferOp {-null (++) []-} (readLine conn) [] Just x -> case map toLower (trim x) of "chunked" -> chunkedTransfer stringBufferOp (readLine conn) (readBlock conn) _ -> uglyDeathTransfer "sendHTTP" ; case rslt of Left e -> close conn >> return (Left e) Right (ftrs,bdy) -> do when (findConnClose (hdrs++ftrs)) (closeOnEnd conn True) return (Right (Response cd rn (hdrs++ftrs) bdy)) } -- | Receive and parse a HTTP request from the given Stream. Should be used -- for server side interactions. receiveHTTP :: Stream s => s -> IO (Result Request_String) receiveHTTP conn = getRequestHead >>= processRequest where -- reads and parses headers getRequestHead :: IO (Result RequestData) getRequestHead = do { lor <- readTillEmpty1 stringBufferOp (readLine conn) ; return $ lor >>= parseRequestHead } processRequest (Left e) = return $ Left e processRequest (Right (rm,uri,hdrs)) = do -- FIXME : Also handle 100-continue. let tc = lookupHeader HdrTransferEncoding hdrs cl = lookupHeader HdrContentLength hdrs rslt <- case tc of Nothing -> case cl of Just x -> linearTransfer (readBlock conn) (read x :: Int) Nothing -> return (Right ([], "")) -- hopefulTransfer "" Just x -> case map toLower (trim x) of "chunked" -> chunkedTransfer stringBufferOp (readLine conn) (readBlock conn) _ -> uglyDeathTransfer "receiveHTTP" return $ do (ftrs,bdy) <- rslt return (Request uri rm (hdrs++ftrs) bdy) -- | Very simple function, send a HTTP response over the given stream. This -- could be improved on to use different transfer types. respondHTTP :: Stream s => s -> Response_String -> IO () respondHTTP conn rsp = do -- TODO review throwing away of result _ <- writeBlock conn (show rsp) -- write body immediately, don't wait for 100 CONTINUE -- TODO review throwing away of result _ <- writeBlock conn (rspBody rsp) return () HTTP-4000.3.3/Network/HTTP/Utils.hs0000644000000000000000000000641012656464615014572 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Utils -- Copyright : See LICENSE file -- License : BSD -- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) -- -- Set of utility functions and definitions used by package modules. -- module Network.HTTP.Utils ( trim -- :: String -> String , trimL -- :: String -> String , trimR -- :: String -> String , crlf -- :: String , lf -- :: String , sp -- :: String , split -- :: Eq a => a -> [a] -> Maybe ([a],[a]) , splitBy -- :: Eq a => a -> [a] -> [[a]] , readsOne -- :: Read a => (a -> b) -> b -> String -> b , dropWhileTail -- :: (a -> Bool) -> [a] -> [a] , chopAtDelim -- :: Eq a => a -> [a] -> ([a],[a]) ) where import Data.Char import Data.List ( elemIndex ) import Data.Maybe ( fromMaybe ) -- | @crlf@ is our beloved two-char line terminator. crlf :: String crlf = "\r\n" -- | @lf@ is a tolerated line terminator, per RFC 2616 section 19.3. lf :: String lf = "\n" -- | @sp@ lets you save typing one character. sp :: String sp = " " -- | @split delim ls@ splits a list into two parts, the @delim@ occurring -- at the head of the second list. If @delim@ isn't in @ls@, @Nothing@ is -- returned. split :: Eq a => a -> [a] -> Maybe ([a],[a]) split delim list = case delim `elemIndex` list of Nothing -> Nothing Just x -> Just $ splitAt x list -- | @trim str@ removes leading and trailing whitespace from @str@. trim :: String -> String trim xs = trimR (trimL xs) -- | @trimL str@ removes leading whitespace (as defined by 'Data.Char.isSpace') -- from @str@. trimL :: String -> String trimL xs = dropWhile isSpace xs -- | @trimL str@ removes trailing whitespace (as defined by 'Data.Char.isSpace') -- from @str@. trimR :: String -> String trimR str = fromMaybe "" $ foldr trimIt Nothing str where trimIt x (Just xs) = Just (x:xs) trimIt x Nothing | isSpace x = Nothing | otherwise = Just [x] -- | @splitMany delim ls@ removes the delimiter @delim@ from @ls@. splitBy :: Eq a => a -> [a] -> [[a]] splitBy _ [] = [] splitBy c xs = case break (==c) xs of (_,[]) -> [xs] (as,_:bs) -> as : splitBy c bs -- | @readsOne f def str@ tries to 'read' @str@, taking -- the first result and passing it to @f@. If the 'read' -- doesn't succeed, return @def@. readsOne :: Read a => (a -> b) -> b -> String -> b readsOne f n str = case reads str of ((v,_):_) -> f v _ -> n -- | @dropWhileTail p ls@ chops off trailing elements from @ls@ -- until @p@ returns @False@. dropWhileTail :: (a -> Bool) -> [a] -> [a] dropWhileTail f ls = case foldr chop Nothing ls of { Just xs -> xs; Nothing -> [] } where chop x (Just xs) = Just (x:xs) chop x _ | f x = Nothing | otherwise = Just [x] -- | @chopAtDelim elt ls@ breaks up @ls@ into two at first occurrence -- of @elt@; @elt@ is elided too. If @elt@ does not occur, the second -- list is empty and the first is equal to @ls@. chopAtDelim :: Eq a => a -> [a] -> ([a],[a]) chopAtDelim elt xs = case break (==elt) xs of (_,[]) -> (xs,[]) (as,_:bs) -> (as,bs) HTTP-4000.3.3/Network/HTTP/Cookie.hs0000644000000000000000000001072312656464615014705 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Cookie -- Copyright : See LICENSE file -- License : BSD -- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) -- -- This module provides the data types and functions for working with HTTP cookies. -- Right now, it contains mostly functionality needed by 'Network.Browser'. -- ----------------------------------------------------------------------------- module Network.HTTP.Cookie ( Cookie(..) , cookieMatch -- :: (String,String) -> Cookie -> Bool -- functions for translating cookies and headers. , cookiesToHeader -- :: [Cookie] -> Header , processCookieHeaders -- :: String -> [Header] -> ([String], [Cookie]) ) where import Network.HTTP.Headers import Data.Char import Data.List import Data.Maybe import Text.ParserCombinators.Parsec ( Parser, char, many, many1, satisfy, parse, option, try , (<|>), sepBy1 ) ------------------------------------------------------------------ ----------------------- Cookie Stuff ----------------------------- ------------------------------------------------------------------ -- | @Cookie@ is the Haskell representation of HTTP cookie values. -- See its relevant specs for authoritative details. data Cookie = MkCookie { ckDomain :: String , ckName :: String , ckValue :: String , ckPath :: Maybe String , ckComment :: Maybe String , ckVersion :: Maybe String } deriving(Show,Read) instance Eq Cookie where a == b = ckDomain a == ckDomain b && ckName a == ckName b && ckPath a == ckPath b -- | @cookieToHeaders ck@ serialises @Cookie@s to an HTTP request header. cookiesToHeader :: [Cookie] -> Header cookiesToHeader cs = Header HdrCookie (mkCookieHeaderValue cs) -- | Turn a list of cookies into a key=value pair list, separated by -- semicolons. mkCookieHeaderValue :: [Cookie] -> String mkCookieHeaderValue = intercalate "; " . map mkCookieHeaderValue1 where mkCookieHeaderValue1 c = ckName c ++ "=" ++ ckValue c -- | @cookieMatch (domain,path) ck@ performs the standard cookie -- match wrt the given domain and path. cookieMatch :: (String, String) -> Cookie -> Bool cookieMatch (dom,path) ck = ckDomain ck `isSuffixOf` dom && case ckPath ck of Nothing -> True Just p -> p `isPrefixOf` path -- | @processCookieHeaders dom hdrs@ processCookieHeaders :: String -> [Header] -> ([String], [Cookie]) processCookieHeaders dom hdrs = foldr (headerToCookies dom) ([],[]) hdrs -- | @headerToCookies dom hdr acc@ headerToCookies :: String -> Header -> ([String], [Cookie]) -> ([String], [Cookie]) headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) = case parse cookies "" val of Left{} -> (val:accErr, accCookie) Right x -> (accErr, x ++ accCookie) where cookies :: Parser [Cookie] cookies = sepBy1 cookie (char ',') cookie :: Parser Cookie cookie = do name <- word _ <- spaces_l _ <- char '=' _ <- spaces_l val1 <- cvalue args <- cdetail return $ mkCookie name val1 args cvalue :: Parser String spaces_l = many (satisfy isSpace) cvalue = quotedstring <|> many1 (satisfy $ not . (==';')) <|> return "" -- all keys in the result list MUST be in lower case cdetail :: Parser [(String,String)] cdetail = many $ try (do _ <- spaces_l _ <- char ';' _ <- spaces_l s1 <- word _ <- spaces_l s2 <- option "" (char '=' >> spaces_l >> cvalue) return (map toLower s1,s2) ) mkCookie :: String -> String -> [(String,String)] -> Cookie mkCookie nm cval more = MkCookie { ckName = nm , ckValue = cval , ckDomain = map toLower (fromMaybe dom (lookup "domain" more)) , ckPath = lookup "path" more , ckVersion = lookup "version" more , ckComment = lookup "comment" more } headerToCookies _ _ acc = acc word, quotedstring :: Parser String quotedstring = do _ <- char '"' -- " str <- many (satisfy $ not . (=='"')) _ <- char '"' return str word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':')) HTTP-4000.3.3/Network/HTTP/Headers.hs0000644000000000000000000002520512656464615015050 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Headers -- Copyright : See LICENSE file -- License : BSD -- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) -- -- This module provides the data types for representing HTTP headers, and -- operations for looking up header values and working with sequences of -- header values in 'Request's and 'Response's. To avoid having to provide -- separate set of operations for doing so, we introduce a type class 'HasHeaders' -- to facilitate writing such processing using overloading instead. -- ----------------------------------------------------------------------------- module Network.HTTP.Headers ( HasHeaders(..) -- type class , Header(..) , mkHeader -- :: HeaderName -> String -> Header , hdrName -- :: Header -> HeaderName , hdrValue -- :: Header -> String , HeaderName(..) , insertHeader -- :: HasHeaders a => HeaderName -> String -> a -> a , insertHeaderIfMissing -- :: HasHeaders a => HeaderName -> String -> a -> a , insertHeaders -- :: HasHeaders a => [Header] -> a -> a , retrieveHeaders -- :: HasHeaders a => HeaderName -> a -> [Header] , replaceHeader -- :: HasHeaders a => HeaderName -> String -> a -> a , findHeader -- :: HasHeaders a => HeaderName -> a -> Maybe String , lookupHeader -- :: HeaderName -> [Header] -> Maybe String , parseHeader -- :: parseHeader :: String -> Result Header , parseHeaders -- :: [String] -> Result [Header] , headerMap -- :: [(String, HeaderName)] , HeaderSetter ) where import Data.Char (toLower) import Network.Stream (Result, failParse) import Network.HTTP.Utils ( trim, split, crlf ) -- | The @Header@ data type pairs header names & values. data Header = Header HeaderName String hdrName :: Header -> HeaderName hdrName (Header h _) = h hdrValue :: Header -> String hdrValue (Header _ v) = v -- | Header constructor as a function, hiding above rep. mkHeader :: HeaderName -> String -> Header mkHeader = Header instance Show Header where show (Header key value) = shows key (':':' ':value ++ crlf) -- | HTTP @HeaderName@ type, a Haskell data constructor for each -- specification-defined header, prefixed with @Hdr@ and CamelCased, -- (i.e., eliding the @-@ in the process.) Should you require using -- a custom header, there's the @HdrCustom@ constructor which takes -- a @String@ argument. -- -- Encoding HTTP header names differently, as Strings perhaps, is an -- equally fine choice..no decidedly clear winner, but let's stick -- with data constructors here. -- data HeaderName -- Generic Headers -- = HdrCacheControl | HdrConnection | HdrDate | HdrPragma | HdrTransferEncoding | HdrUpgrade | HdrVia -- Request Headers -- | HdrAccept | HdrAcceptCharset | HdrAcceptEncoding | HdrAcceptLanguage | HdrAuthorization | HdrCookie | HdrExpect | HdrFrom | HdrHost | HdrIfModifiedSince | HdrIfMatch | HdrIfNoneMatch | HdrIfRange | HdrIfUnmodifiedSince | HdrMaxForwards | HdrProxyAuthorization | HdrRange | HdrReferer | HdrUserAgent -- Response Headers | HdrAge | HdrLocation | HdrProxyAuthenticate | HdrPublic | HdrRetryAfter | HdrServer | HdrSetCookie | HdrTE | HdrTrailer | HdrVary | HdrWarning | HdrWWWAuthenticate -- Entity Headers | HdrAllow | HdrContentBase | HdrContentEncoding | HdrContentLanguage | HdrContentLength | HdrContentLocation | HdrContentMD5 | HdrContentRange | HdrContentType | HdrETag | HdrExpires | HdrLastModified -- | MIME entity headers (for sub-parts) | HdrContentTransferEncoding -- | Allows for unrecognised or experimental headers. | HdrCustom String -- not in header map below. deriving(Eq) -- | @headerMap@ is a straight assoc list for translating between header names -- and values. headerMap :: [ (String,HeaderName) ] headerMap = [ p "Cache-Control" HdrCacheControl , p "Connection" HdrConnection , p "Date" HdrDate , p "Pragma" HdrPragma , p "Transfer-Encoding" HdrTransferEncoding , p "Upgrade" HdrUpgrade , p "Via" HdrVia , p "Accept" HdrAccept , p "Accept-Charset" HdrAcceptCharset , p "Accept-Encoding" HdrAcceptEncoding , p "Accept-Language" HdrAcceptLanguage , p "Authorization" HdrAuthorization , p "Cookie" HdrCookie , p "Expect" HdrExpect , p "From" HdrFrom , p "Host" HdrHost , p "If-Modified-Since" HdrIfModifiedSince , p "If-Match" HdrIfMatch , p "If-None-Match" HdrIfNoneMatch , p "If-Range" HdrIfRange , p "If-Unmodified-Since" HdrIfUnmodifiedSince , p "Max-Forwards" HdrMaxForwards , p "Proxy-Authorization" HdrProxyAuthorization , p "Range" HdrRange , p "Referer" HdrReferer , p "User-Agent" HdrUserAgent , p "Age" HdrAge , p "Location" HdrLocation , p "Proxy-Authenticate" HdrProxyAuthenticate , p "Public" HdrPublic , p "Retry-After" HdrRetryAfter , p "Server" HdrServer , p "Set-Cookie" HdrSetCookie , p "TE" HdrTE , p "Trailer" HdrTrailer , p "Vary" HdrVary , p "Warning" HdrWarning , p "WWW-Authenticate" HdrWWWAuthenticate , p "Allow" HdrAllow , p "Content-Base" HdrContentBase , p "Content-Encoding" HdrContentEncoding , p "Content-Language" HdrContentLanguage , p "Content-Length" HdrContentLength , p "Content-Location" HdrContentLocation , p "Content-MD5" HdrContentMD5 , p "Content-Range" HdrContentRange , p "Content-Type" HdrContentType , p "ETag" HdrETag , p "Expires" HdrExpires , p "Last-Modified" HdrLastModified , p "Content-Transfer-Encoding" HdrContentTransferEncoding ] where p a b = (a,b) instance Show HeaderName where show (HdrCustom s) = s show x = case filter ((==x).snd) headerMap of [] -> error "headerMap incomplete" (h:_) -> fst h -- | @HasHeaders@ is a type class for types containing HTTP headers, allowing -- you to write overloaded header manipulation functions -- for both 'Request' and 'Response' data types, for instance. class HasHeaders x where getHeaders :: x -> [Header] setHeaders :: x -> [Header] -> x -- Header manipulation functions type HeaderSetter a = HeaderName -> String -> a -> a -- | @insertHeader hdr val x@ inserts a header with the given header name -- and value. Does not check for existing headers with same name, allowing -- duplicates to be introduce (use 'replaceHeader' if you want to avoid this.) insertHeader :: HasHeaders a => HeaderSetter a insertHeader name value x = setHeaders x newHeaders where newHeaders = (Header name value) : getHeaders x -- | @insertHeaderIfMissing hdr val x@ adds the new header only if no previous -- header with name @hdr@ exists in @x@. insertHeaderIfMissing :: HasHeaders a => HeaderSetter a insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x) where newHeaders list@(h@(Header n _): rest) | n == name = list | otherwise = h : newHeaders rest newHeaders [] = [Header name value] -- | @replaceHeader hdr val o@ replaces the header @hdr@ with the -- value @val@, dropping any existing replaceHeader :: HasHeaders a => HeaderSetter a replaceHeader name value h = setHeaders h newHeaders where newHeaders = Header name value : [ x | x@(Header n _) <- getHeaders h, name /= n ] -- | @insertHeaders hdrs x@ appends multiple headers to @x@'s existing -- set. insertHeaders :: HasHeaders a => [Header] -> a -> a insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs) -- | @retrieveHeaders hdrNm x@ gets a list of headers with 'HeaderName' @hdrNm@. retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header] retrieveHeaders name x = filter matchname (getHeaders x) where matchname (Header n _) = n == name -- | @findHeader hdrNm x@ looks up @hdrNm@ in @x@, returning the first -- header that matches, if any. findHeader :: HasHeaders a => HeaderName -> a -> Maybe String findHeader n x = lookupHeader n (getHeaders x) -- | @lookupHeader hdr hdrs@ locates the first header matching @hdr@ in the -- list @hdrs@. lookupHeader :: HeaderName -> [Header] -> Maybe String lookupHeader _ [] = Nothing lookupHeader v (Header n s:t) | v == n = Just s | otherwise = lookupHeader v t -- | @parseHeader headerNameAndValueString@ tries to unscramble a -- @header: value@ pairing and returning it as a 'Header'. parseHeader :: String -> Result Header parseHeader str = case split ':' str of Nothing -> failParse ("Unable to parse header: " ++ str) Just (k,v) -> return $ Header (fn k) (trim $ drop 1 v) where fn k = case map snd $ filter (match k . fst) headerMap of [] -> (HdrCustom k) (h:_) -> h match :: String -> String -> Bool match s1 s2 = map toLower s1 == map toLower s2 -- | @parseHeaders hdrs@ takes a sequence of strings holding header -- information and parses them into a set of headers (preserving their -- order in the input argument.) Handles header values split up over -- multiple lines. parseHeaders :: [String] -> Result [Header] parseHeaders = catRslts [] . map (parseHeader . clean) . joinExtended "" where -- Joins consecutive lines where the second line -- begins with ' ' or '\t'. joinExtended old [] = [old] joinExtended old (h : t) | isLineExtension h = joinExtended (old ++ ' ' : tail h) t | otherwise = old : joinExtended h t isLineExtension (x:_) = x == ' ' || x == '\t' isLineExtension _ = False clean [] = [] clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t | otherwise = h : clean t -- tolerant of errors? should parse -- errors here be reported or ignored? -- currently ignored. catRslts :: [a] -> [Result a] -> Result [a] catRslts list (h:t) = case h of Left _ -> catRslts list t Right v -> catRslts (v:list) t catRslts list [] = Right $ reverse list HTTP-4000.3.3/Network/HTTP/Base64.hs0000644000000000000000000002666312656464615014532 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Codec.Binary.Base64 -- Copyright : (c) Dominic Steinitz 2005, Warrick Gray 2002 -- License : BSD-style (see the file ReadMe.tex) -- -- Maintainer : dominic.steinitz@blueyonder.co.uk -- Stability : experimental -- Portability : portable -- -- Base64 encoding and decoding functions provided by Warwick Gray. -- See -- and . -- ----------------------------------------------------------------------------- module Network.HTTP.Base64 ( encode , decode , chop72 , Octet ) where {------------------------------------------------------------------------ This is what RFC2045 had to say: 6.8. Base64 Content-Transfer-Encoding The Base64 Content-Transfer-Encoding is designed to represent arbitrary sequences of octets in a form that need not be humanly readable. The encoding and decoding algorithms are simple, but the encoded data are consistently only about 33 percent larger than the unencoded data. This encoding is virtually identical to the one used in Privacy Enhanced Mail (PEM) applications, as defined in RFC 1421. A 65-character subset of US-ASCII is used, enabling 6 bits to be represented per printable character. (The extra 65th character, "=", is used to signify a special processing function.) NOTE: This subset has the important property that it is represented identically in all versions of ISO 646, including US-ASCII, and all characters in the subset are also represented identically in all versions of EBCDIC. Other popular encodings, such as the encoding used by the uuencode utility, Macintosh binhex 4.0 [RFC-1741], and the base85 encoding specified as part of Level 2 PostScript, do not share these properties, and thus do not fulfill the portability requirements a binary transport encoding for mail must meet. The encoding process represents 24-bit groups of input bits as output strings of 4 encoded characters. Proceeding from left to right, a 24-bit input group is formed by concatenating 3 8bit input groups. These 24 bits are then treated as 4 concatenated 6-bit groups, each of which is translated into a single digit in the base64 alphabet. When encoding a bit stream via the base64 encoding, the bit stream must be presumed to be ordered with the most-significant-bit first. That is, the first bit in the stream will be the high-order bit in the first 8bit byte, and the eighth bit will be the low-order bit in the first 8bit byte, and so on. Each 6-bit group is used as an index into an array of 64 printable characters. The character referenced by the index is placed in the output string. These characters, identified in Table 1, below, are selected so as to be universally representable, and the set excludes characters with particular significance to SMTP (e.g., ".", CR, LF) and to the multipart boundary delimiters defined in RFC 2046 (e.g., "-"). Table 1: The Base64 Alphabet Value Encoding Value Encoding Value Encoding Value Encoding 0 A 17 R 34 i 51 z 1 B 18 S 35 j 52 0 2 C 19 T 36 k 53 1 3 D 20 U 37 l 54 2 4 E 21 V 38 m 55 3 5 F 22 W 39 n 56 4 6 G 23 X 40 o 57 5 7 H 24 Y 41 p 58 6 8 I 25 Z 42 q 59 7 9 J 26 a 43 r 60 8 10 K 27 b 44 s 61 9 11 L 28 c 45 t 62 + 12 M 29 d 46 u 63 / 13 N 30 e 47 v 14 O 31 f 48 w (pad) = 15 P 32 g 49 x 16 Q 33 h 50 y The encoded output stream must be represented in lines of no more than 76 characters each. All line breaks or other characters not found in Table 1 must be ignored by decoding software. In base64 data, characters other than those in Table 1, line breaks, and other white space probably indicate a transmission error, about which a warning message or even a message rejection might be appropriate under some circumstances. Special processing is performed if fewer than 24 bits are available at the end of the data being encoded. A full encoding quantum is always completed at the end of a body. When fewer than 24 input bits are available in an input group, zero bits are added (on the right) to form an integral number of 6-bit groups. Padding at the end of the data is performed using the "=" character. Since all base64 input is an integral number of octets, only the following cases can arise: (1) the final quantum of encoding input is an integral multiple of 24 bits; here, the final unit of encoded output will be an integral multiple of 4 characters with no "=" padding, (2) the final quantum of encoding input is exactly 8 bits; here, the final unit of encoded output will be two characters followed by two "=" padding characters, or (3) the final quantum of encoding input is exactly 16 bits; here, the final unit of encoded output will be three characters followed by one "=" padding character. Because it is used only for padding at the end of the data, the occurrence of any "=" characters may be taken as evidence that the end of the data has been reached (without truncation in transit). No such assurance is possible, however, when the number of octets transmitted was a multiple of three and no "=" characters are present. Any characters outside of the base64 alphabet are to be ignored in base64-encoded data. Care must be taken to use the proper octets for line breaks if base64 encoding is applied directly to text material that has not been converted to canonical form. In particular, text line breaks must be converted into CRLF sequences prior to base64 encoding. The important thing to note is that this may be done directly by the encoder rather than in a prior canonicalization step in some implementations. NOTE: There is no need to worry about quoting potential boundary delimiters within base64-encoded bodies within multipart entities because no hyphen characters are used in the base64 encoding. ----------------------------------------------------------------------------} {- The following properties should hold: decode . encode = id decode . chop72 . encode = id I.E. Both "encode" and "chop72 . encode" are valid methods of encoding input, the second variation corresponds better with the RFC above, but outside of MIME applications might be undesireable. But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only 8 significant bits, which is more than enough for US-ASCII. -} import Data.Array (Array, array, (!)) import Data.Bits (shiftL, shiftR, (.&.), (.|.)) import Data.Char (chr, ord) import Data.Word (Word8) type Octet = Word8 encodeArray :: Array Int Char encodeArray = array (0,64) [ (0,'A'), (1,'B'), (2,'C'), (3,'D'), (4,'E'), (5,'F') , (6,'G'), (7,'H'), (8,'I'), (9,'J'), (10,'K'), (11,'L') , (12,'M'), (13,'N'), (14,'O'), (15,'P'), (16,'Q'), (17,'R') , (18,'S'), (19,'T'), (20,'U'), (21,'V'), (22,'W'), (23,'X') , (24,'Y'), (25,'Z'), (26,'a'), (27,'b'), (28,'c'), (29,'d') , (30,'e'), (31,'f'), (32,'g'), (33,'h'), (34,'i'), (35,'j') , (36,'k'), (37,'l'), (38,'m'), (39,'n'), (40,'o'), (41,'p') , (42,'q'), (43,'r'), (44,'s'), (45,'t'), (46,'u'), (47,'v') , (48,'w'), (49,'x'), (50,'y'), (51,'z'), (52,'0'), (53,'1') , (54,'2'), (55,'3'), (56,'4'), (57,'5'), (58,'6'), (59,'7') , (60,'8'), (61,'9'), (62,'+'), (63,'/') ] -- Convert between 4 base64 (6bits ea) integers and 1 ordinary integer (32 bits) -- clearly the upmost/leftmost 8 bits of the answer are 0. -- Hack Alert: In the last entry of the answer, the upper 8 bits encode -- the integer number of 6bit groups encoded in that integer, ie 1, 2, 3. -- 0 represents a 4 :( int4_char3 :: [Int] -> [Char] int4_char3 (a:b:c:d:t) = let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d) in (chr (n `shiftR` 16 .&. 0xff)) : (chr (n `shiftR` 8 .&. 0xff)) : (chr (n .&. 0xff)) : int4_char3 t int4_char3 [a,b,c] = let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6) in [ (chr (n `shiftR` 16 .&. 0xff)) , (chr (n `shiftR` 8 .&. 0xff)) ] int4_char3 [a,b] = let n = (a `shiftL` 18 .|. b `shiftL` 12) in [ (chr (n `shiftR` 16 .&. 0xff)) ] int4_char3 [_] = error "Network.HTTP.Base64.int4_char3: impossible number of Ints." int4_char3 [] = [] -- Convert triplets of characters to -- 4 base64 integers. The last entries -- in the list may not produce 4 integers, -- a trailing 2 character group gives 3 integers, -- while a trailing single character gives 2 integers. char3_int4 :: [Char] -> [Int] char3_int4 (a:b:c:t) = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8 .|. ord c) in (n `shiftR` 18 .&. 0x3f) : (n `shiftR` 12 .&. 0x3f) : (n `shiftR` 6 .&. 0x3f) : (n .&. 0x3f) : char3_int4 t char3_int4 [a,b] = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8) in [ (n `shiftR` 18 .&. 0x3f) , (n `shiftR` 12 .&. 0x3f) , (n `shiftR` 6 .&. 0x3f) ] char3_int4 [a] = let n = (ord a `shiftL` 16) in [(n `shiftR` 18 .&. 0x3f),(n `shiftR` 12 .&. 0x3f)] char3_int4 [] = [] -- Retrieve base64 char, given an array index integer in the range [0..63] enc1 :: Int -> Char enc1 ch = encodeArray!ch -- | Cut up a string into 72 char lines, each line terminated by CRLF. chop72 :: String -> String chop72 str = let (bgn,end) = splitAt 70 str in if null end then bgn else "\r\n" ++ chop72 end -- Pads a base64 code to a multiple of 4 characters, using the special -- '=' character. quadruplets :: [Char] -> [Char] quadruplets (a:b:c:d:t) = a:b:c:d:quadruplets t quadruplets [a,b,c] = [a,b,c,'='] -- 16bit tail unit quadruplets [a,b] = [a,b,'=','='] -- 8bit tail unit quadruplets [_] = error "Network.HTTP.Base64.quadruplets: impossible number of characters." quadruplets [] = [] -- 24bit tail unit enc :: [Int] -> [Char] enc = quadruplets . map enc1 dcd :: String -> [Int] dcd [] = [] dcd (h:t) | h <= 'Z' && h >= 'A' = ord h - ord 'A' : dcd t | h >= '0' && h <= '9' = ord h - ord '0' + 52 : dcd t | h >= 'a' && h <= 'z' = ord h - ord 'a' + 26 : dcd t | h == '+' = 62 : dcd t | h == '/' = 63 : dcd t | h == '=' = [] -- terminate data stream | otherwise = dcd t -- Principal encoding and decoding functions. encode :: [Octet] -> String encode = enc . char3_int4 . (map (chr .fromIntegral)) {- prop_base64 os = os == (f . g . h) os where types = (os :: [Word8]) f = map (fromIntegral. ord) g = decode . encode h = map (chr . fromIntegral) -} decode :: String -> [Octet] decode = (map (fromIntegral . ord)) . int4_char3 . dcd HTTP-4000.3.3/Network/HTTP/Proxy.hs0000644000000000000000000001653412656464615014623 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Proxy -- Copyright : See LICENSE file -- License : BSD -- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) -- -- Handling proxy server settings and their resolution. -- ----------------------------------------------------------------------------- module Network.HTTP.Proxy ( Proxy(..) , noProxy -- :: Proxy , fetchProxy -- :: Bool -> IO Proxy , parseProxy -- :: String -> Maybe Proxy ) where {- #if !defined(WIN32) && defined(mingw32_HOST_OS) #define WIN32 1 #endif -} import Control.Monad ( when, mplus, join, liftM2 ) #if defined(WIN32) import Network.HTTP.Base ( catchIO ) import Control.Monad ( liftM ) import Data.List ( isPrefixOf ) #endif import Network.HTTP.Utils ( dropWhileTail, chopAtDelim ) import Network.HTTP.Auth import Network.URI ( URI(..), URIAuth(..), parseAbsoluteURI, unEscapeString ) import System.IO ( hPutStrLn, stderr ) import System.Environment {- #if !defined(WIN32) && defined(mingw32_HOST_OS) #define WIN32 1 #endif -} #if defined(WIN32) import System.Win32.Types ( DWORD, HKEY ) import System.Win32.Registry( hKEY_CURRENT_USER, regOpenKey, regCloseKey, regQueryValue, regQueryValueEx ) import Control.Exception ( bracket ) import Foreign ( toBool, Storable(peek, sizeOf), castPtr, alloca ) #endif -- | HTTP proxies (or not) are represented via 'Proxy', specifying if a -- proxy should be used for the request (see 'Network.Browser.setProxy') data Proxy = NoProxy -- ^ Don't use a proxy. | Proxy String (Maybe Authority) -- ^ Use the proxy given. Should be of the -- form "http:\/\/host:port", "host", "host:port", or "http:\/\/host". -- Additionally, an optional 'Authority' for authentication with the proxy. noProxy :: Proxy noProxy = NoProxy -- | @envProxyString@ locates proxy server settings by looking -- up env variable @HTTP_PROXY@ (or its lower-case equivalent.) -- If no mapping found, returns @Nothing@. envProxyString :: IO (Maybe String) envProxyString = do env <- getEnvironment return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env) -- | @proxyString@ tries to locate the user's proxy server setting. -- Consults environment variable, and in case of Windows, by querying -- the Registry (cf. @registryProxyString@.) proxyString :: IO (Maybe String) proxyString = liftM2 mplus envProxyString windowsProxyString windowsProxyString :: IO (Maybe String) #if !defined(WIN32) windowsProxyString = return Nothing #else windowsProxyString = liftM (>>= parseWindowsProxy) registryProxyString registryProxyLoc :: (HKEY,String) registryProxyLoc = (hive, path) where -- some sources say proxy settings should be at -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows -- \CurrentVersion\Internet Settings\ProxyServer -- but if the user sets them with IE connection panel they seem to -- end up in the following place: hive = hKEY_CURRENT_USER path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings" -- read proxy settings from the windows registry; this is just a best -- effort and may not work on all setups. registryProxyString :: IO (Maybe String) registryProxyString = catchIO (bracket (uncurry regOpenKey registryProxyLoc) regCloseKey $ \hkey -> do enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable" if enable then fmap Just $ regQueryValue hkey (Just "ProxyServer") else return Nothing) (\_ -> return Nothing) -- the proxy string is in the format "http=x.x.x.x:yyyy;https=...;ftp=...;socks=..." -- even though the following article indicates otherwise -- https://support.microsoft.com/en-us/kb/819961 -- -- to be sure, parse strings where each entry in the ';'-separated list above is -- either in the format "protocol=..." or "protocol://..." -- -- only return the first "http" of them, if it exists parseWindowsProxy :: String -> Maybe String parseWindowsProxy s = case proxies of x:_ -> Just x _ -> Nothing where parts = split ';' s pr x = case break (== '=') x of (p, []) -> p -- might be in format http:// (p, u) -> p ++ "://" ++ drop 1 u proxies = filter (isPrefixOf "http://") . map pr $ parts split :: Eq a => a -> [a] -> [[a]] split _ [] = [] split a xs = case break (a ==) xs of (ys, []) -> [ys] (ys, _:zs) -> ys:split a zs #endif -- | @fetchProxy flg@ gets the local proxy settings and parse the string -- into a @Proxy@ value. If you want to be informed of ill-formed proxy -- configuration strings, supply @True@ for @flg@. -- Proxy settings are sourced from the @HTTP_PROXY@ environment variable, -- and in the case of Windows platforms, by consulting IE/WinInet's proxy -- setting in the Registry. fetchProxy :: Bool -> IO Proxy fetchProxy warnIfIllformed = do mstr <- proxyString case mstr of Nothing -> return NoProxy Just str -> case parseProxy str of Just p -> return p Nothing -> do when warnIfIllformed $ System.IO.hPutStrLn System.IO.stderr $ unlines [ "invalid http proxy uri: " ++ show str , "proxy uri must be http with a hostname" , "ignoring http proxy, trying a direct connection" ] return NoProxy -- | @parseProxy str@ translates a proxy server string into a @Proxy@ value; -- returns @Nothing@ if not well-formed. parseProxy :: String -> Maybe Proxy parseProxy str = join . fmap uri2proxy $ parseHttpURI str `mplus` parseHttpURI ("http://" ++ str) where parseHttpURI str' = case parseAbsoluteURI str' of Just uri@URI{uriAuthority = Just{}} -> Just (fixUserInfo uri) _ -> Nothing -- Note: we need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@ -- which lack the @\"http://\"@ URI scheme. The problem is that -- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme -- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@. -- -- So our strategy is to try parsing as normal uri first and if it lacks the -- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix. -- -- | tidy up user portion, don't want the trailing "\@". fixUserInfo :: URI -> URI fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri } where f a@URIAuth{uriUserInfo=s} = a{uriUserInfo=dropWhileTail (=='@') s} -- uri2proxy :: URI -> Maybe Proxy uri2proxy uri@URI{ uriScheme = "http:" , uriAuthority = Just (URIAuth auth' hst prt) } = Just (Proxy (hst ++ prt) auth) where auth = case auth' of [] -> Nothing as -> Just (AuthBasic "" (unEscapeString usr) (unEscapeString pwd) uri) where (usr,pwd) = chopAtDelim ':' as uri2proxy _ = Nothing -- utilities #if defined(WIN32) regQueryValueDWORD :: HKEY -> String -> IO DWORD regQueryValueDWORD hkey name = alloca $ \ptr -> do -- TODO: this throws away the key type returned by regQueryValueEx -- we should check it's what we expect instead _ <- regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD)) peek ptr #endif