http-enumerator (empty) → 0.0.0
raw patch · 5 files changed
+508/−0 lines, 5 filesdep +HsOpenSSLdep +attoparsecdep +attoparsec-enumeratorsetup-changed
Dependencies added: HsOpenSSL, attoparsec, attoparsec-enumerator, base, bytestring, enumerator, failure, network, network-bytestring, transformers
Files
- LICENSE +25/−0
- Network/HTTP/Enumerator.hs +304/−0
- Network/HTTP/Enumerator/HttpParser.hs +144/−0
- Setup.hs +2/−0
- http-enumerator.cabal +33/−0
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2010, Michael Snoyman. 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.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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.
+ Network/HTTP/Enumerator.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+module Network.HTTP.Enumerator+ ( Request (..)+ , Response (..)+ , http+ , parseUrl+ , httpLbs+ , simpleHttp+ , withHttpEnumerator+ ) where++import qualified OpenSSL.Session as SSL+import Network.Socket+import qualified Network.Socket.ByteString as B+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Char8 as S8+import Data.Enumerator hiding (head, map, break)+import qualified Data.Enumerator as E+import Network.HTTP.Enumerator.HttpParser+import Control.Exception (throwIO, Exception)+import Control.Arrow (first)+import Data.Char (toLower)+import Control.Monad (forM_)+import Control.Monad.IO.Class (liftIO)+import Control.Failure+import Data.Typeable (Typeable)+import Data.Word (Word8)+import Data.Bits+import Data.Maybe (fromMaybe)+import OpenSSL++-- | The OpenSSL library requires some initialization of variables to be used,+-- and therefore you must call 'withOpenSSL' before using any of its functions.+-- As this library uses OpenSSL, you must use 'withOpenSSL' as well. (As a side+-- note, you'll also want to use the withSocketsDo function for network+-- activity.)+--+-- To future-proof this package against switching to different SSL libraries,+-- we re-export 'withOpenSSL' under this name. You can call this function as+-- early as you like; in fact, simply wrapping the do block of your main+-- function is probably best.+withHttpEnumerator :: IO a -> IO a+withHttpEnumerator = withOpenSSL++getSocket :: String -> Int -> IO Socket+getSocket host' port' = do+ addrs <- getAddrInfo Nothing (Just host') (Just $ show port')+ let addr = head addrs+ sock <- socket (addrFamily addr) Stream defaultProtocol+ connect sock (addrAddress addr)+ return sock++withSocketConn :: String -> Int -> (HttpConn -> IO a) -> IO a+withSocketConn host' port' f = do+ sock <- getSocket host' port'+ a <- f HttpConn+ { hcRead = B.recv sock+ , hcWrite = B.sendAll sock+ }+ sClose sock+ return a++withOpenSslConn :: String -> Int -> (HttpConn -> IO a) -> IO a+withOpenSslConn host' port' f = do+ ctx <- SSL.context+ sock <- getSocket host' port'+ ssl <- SSL.connection ctx sock+ SSL.connect ssl+ a <- f HttpConn+ { hcRead = SSL.read ssl+ , hcWrite = SSL.write ssl+ }+ SSL.shutdown ssl SSL.Unidirectional+ return a++data HttpConn = HttpConn+ { hcRead :: Int -> IO S.ByteString+ , hcWrite :: S.ByteString -> IO ()+ }++connToEnum :: HttpConn -> Enumerator S.ByteString IO a+connToEnum (HttpConn r _) =+ Iteratee . loop+ where+ loop (Continue k) = do+ bs <- r 2 -- FIXME better size+ if S.null bs+ then return $ Continue k+ else do+ runIteratee (k $ Chunks [bs]) >>= loop+ loop step = return step++data Request = Request+ { host :: S.ByteString+ , port :: Int+ , secure :: Bool+ , requestHeaders :: [(S.ByteString, S.ByteString)]+ , path :: S.ByteString+ , queryString :: [(S.ByteString, S.ByteString)]+ , requestBody :: L.ByteString+ , method :: S.ByteString+ }+ deriving Show++data Response a = Response+ { statusCode :: Int+ , responseHeaders :: [(S.ByteString, S.ByteString)]+ , responseBody :: a+ }++http :: Request -> Iteratee S.ByteString IO a -> IO (Response a)+http req@(Request {..}) bodyIter = do+ let h' = S8.unpack host+ res <- (if secure then withOpenSslConn else withSocketConn) h' port go+ case res of+ Left e -> throwIO e+ Right x -> return x+ where+ hh+ | port == 80 && not secure = host+ | port == 443 && secure = host+ | otherwise = host `S.append` S8.pack (':' : show port)+ go hc = do+ hcWrite hc $ S.concat+ $ method+ : " "+ : path+ : renderQS queryString [" HTTP/1.1\r\n"]+ let headers' = ("Host", hh)+ : ("Content-Length", S8.pack $ show+ $ L.length requestBody)+ : requestHeaders+ forM_ headers' $ \(k, v) -> hcWrite hc $ S.concat+ [ k+ , ": "+ , v+ , "\r\n"+ ]+ hcWrite hc "\r\n"+ mapM_ (hcWrite hc) $ L.toChunks requestBody+ run $ connToEnum hc $$ do+ ((_, sc, _), hs) <- iterHeaders+ let hs' = map (first $ S8.map toLower) hs+ let mcl = lookup "content-length" hs'+ body' <-+ if ("transfer-encoding", "chunked") `elem` hs'+ then iterChunks+ else case mcl >>= readMay . S8.unpack of+ Just len -> takeLBS len+ Nothing -> return [] -- FIXME read in body anyways?+ ebody'' <- liftIO $ run $ enumList 1 body' $$ bodyIter+ case ebody'' of+ Left err -> liftIO $ throwIO err+ Right body'' ->+ return $ Response+ { statusCode = sc+ , responseHeaders = hs+ , responseBody = body''+ }++takeLBS :: Monad m => Int -> Iteratee S.ByteString m [S.ByteString]+takeLBS 0 = return []+takeLBS len = do+ mbs <- E.head+ case mbs of+ Nothing -> return []+ Just bs -> do+ let len' = len - S.length bs+ rest <- takeLBS len'+ return $ bs : rest++renderQS :: [(S.ByteString, S.ByteString)]+ -> [S.ByteString]+ -> [S.ByteString]+renderQS [] x = x+renderQS (p:ps) x =+ go "?" p ++ concatMap (go "&") ps ++ x+ where+ go sep (k, v) = [sep, escape k, "=", escape v]+ escape = S8.concatMap (S8.pack . encodeUrlChar)++encodeUrlChar :: Char -> String+encodeUrlChar c+ -- List of unreserved characters per RFC 3986+ -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding+ | 'A' <= c && c <= 'Z' = [c]+ | 'a' <= c && c <= 'z' = [c]+ | '0' <= c && c <= '9' = [c]+encodeUrlChar c@'-' = [c]+encodeUrlChar c@'_' = [c]+encodeUrlChar c@'.' = [c]+encodeUrlChar c@'~' = [c]+encodeUrlChar ' ' = "+"+encodeUrlChar y =+ let (a, c) = fromEnum y `divMod` 16+ b = a `mod` 16+ showHex' x -- FIXME just use Numeric version?+ | x < 10 = toEnum $ x + (fromEnum '0')+ | x < 16 = toEnum $ x - 10 + (fromEnum 'A')+ | otherwise = error $ "Invalid argument to showHex: " ++ show x+ in ['%', showHex' b, showHex' c]++data InvalidUrlException = InvalidUrlException String String+ deriving (Show, Typeable)+instance Exception InvalidUrlException++parseUrl :: Failure InvalidUrlException m => String -> m Request+parseUrl s@('h':'t':'t':'p':':':'/':'/':rest) = parseUrl1 s False rest+parseUrl s@('h':'t':'t':'p':'s':':':'/':'/':rest) = parseUrl1 s True rest+parseUrl x = failure $ InvalidUrlException x "Invalid scheme"++parseUrl1 :: Failure InvalidUrlException m+ => String -> Bool -> String -> m Request+parseUrl1 full sec s = do+ port' <- mport+ return Request+ { host = S8.pack hostname -- FIXME check chars+ , port = port'+ , secure = sec+ , requestHeaders = []+ , path = S8.pack $ if null path' then "/" else path' -- FIXME check chars+ , queryString = parseQueryString $ S8.pack qstring -- FIXME check chars+ , requestBody = L.empty+ , method = "GET"+ }+ where+ (beforeSlash, afterSlash) = break (== '/') s+ (hostname, portStr) = break (== ':') beforeSlash+ (path', qstring') = break (== '?') afterSlash+ qstring'' = case qstring' of+ '?':x -> x+ _ -> qstring'+ qstring = takeWhile (/= '#') qstring''+ mport =+ case (portStr, sec) of+ ("", False) -> return 80+ ("", True) -> return 443+ (':':rest, _) ->+ case readMay rest of+ Just i -> return i+ Nothing -> failure $ InvalidUrlException full "Invalid port"+ x -> error $ "parseUrl1: this should never happen: " ++ show x++parseQueryString :: S.ByteString -> [(S.ByteString, S.ByteString)]+parseQueryString = parseQueryString' . dropQuestion+ where+ dropQuestion q | S.null q || S.head q /= 63 = q+ dropQuestion q | otherwise = S.tail q+ parseQueryString' q | S.null q = []+ parseQueryString' q =+ let (x, xs) = breakDiscard 38 q -- ampersand+ in parsePair x : parseQueryString' xs+ where+ parsePair x =+ let (k, v) = breakDiscard 61 x -- equal sign+ in (qsDecode k, qsDecode v)+++qsDecode :: S.ByteString -> S.ByteString+qsDecode z = fst $ S.unfoldrN (S.length z) go z+ where+ go bs =+ case uncons bs of+ Nothing -> Nothing+ Just (43, ws) -> Just (32, ws) -- plus to space+ Just (37, ws) -> Just $ fromMaybe (37, ws) $ do -- percent+ (x, xs) <- uncons ws+ x' <- hexVal x+ (y, ys) <- uncons xs+ y' <- hexVal y+ Just $ (combine x' y', ys)+ Just (w, ws) -> Just (w, ws)+ hexVal w+ | 48 <= w && w <= 57 = Just $ w - 48 -- 0 - 9+ | 65 <= w && w <= 70 = Just $ w - 55 -- A - F+ | 97 <= w && w <= 102 = Just $ w - 87 -- a - f+ | otherwise = Nothing+ combine :: Word8 -> Word8 -> Word8+ combine a b = shiftL a 4 .|. b++uncons :: S.ByteString -> Maybe (Word8, S.ByteString)+uncons s+ | S.null s = Nothing+ | otherwise = Just (S.head s, S.tail s)++breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)+breakDiscard w s =+ let (x, y) = S.break (== w) s+ in (x, S.drop 1 y)++httpLbs :: Request -> IO (Response L.ByteString)+httpLbs = flip http (L.fromChunks `fmap` consume)++simpleHttp :: String -> IO (Response L.ByteString)+simpleHttp url = parseUrl url >>= httpLbs++readMay :: Read a => String -> Maybe a+readMay s = case reads s of+ [] -> Nothing+ (x, _):_ -> Just x
+ Network/HTTP/Enumerator/HttpParser.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.HTTP.Enumerator.HttpParser+ ( iterHeaders+ , iterChunks+ ) where++import Prelude hiding (take)+import Data.Attoparsec+import Data.Attoparsec.Enumerator+import Data.Enumerator (Iteratee)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import Control.Applicative+import Data.Word (Word8)++type Header = (S.ByteString, S.ByteString)++parseHeader :: Parser Header+parseHeader = do+ k <- takeWhile1 notNewlineColon+ _ <- word8 58 -- colon+ skipWhile isSpace+ v <- takeWhile1 notNewline+ newline+ return (k, v)++notNewlineColon, isSpace, notNewline :: Word8 -> Bool++notNewlineColon 10 = False -- LF+notNewlineColon 13 = False -- CR+notNewlineColon 58 = False -- colon+notNewlineColon _ = True++isSpace 32 = True+isSpace _ = False++notNewline 10 = False+notNewline 13 = False+notNewline _ = True++newline :: Parser ()+newline =+ lf <|> (cr >> lf)+ where+ word8' x = word8 x >> return ()+ lf = word8' 10+ cr = word8' 13++parseHeaders :: Parser (Status, [Header])+parseHeaders = do+ s <- parseStatus+ h <- manyTill parseHeader newline+ return (s, h)++iterHeaders :: Monad m => Iteratee S.ByteString m (Status, [Header])+iterHeaders = iterParser parseHeaders++type Status = (S.ByteString, Int, S.ByteString)++parseStatus :: Parser Status+parseStatus = do+ _ <- string "HTTP/"+ ver <- takeWhile1 $ not . isSpace+ _ <- word8 32 -- space+ statCode <- takeWhile1 $ not . isSpace+ statCode' <-+ case reads $ S8.unpack statCode of+ [] -> fail $ "Invalid status code: " ++ S8.unpack statCode+ (x, _):_ -> return x+ _ <- word8 32+ statMsg <- takeWhile1 $ notNewline+ newline+ if (statCode == "100")+ then newline >> parseStatus+ else return (ver, statCode', statMsg)++iterChunks :: Monad m => Iteratee S.ByteString m [S.ByteString]+iterChunks = iterParser parseChunks++parseChunks :: Parser [S.ByteString]+parseChunks = manyTill parseChunk zeroChunk++zeroChunk :: Parser ()+zeroChunk = word8 48 >> (newline <|> attribs) -- 0++parseChunk :: Parser S.ByteString+parseChunk = do+ len <- hexs+ newline <|> attribs+ bs <- take len+ newline+ return bs++attribs :: Parser ()+attribs = do+ _ <- word8 59 -- colon+ skipWhile notNewline+ newline++hexs :: Parser Int+hexs = do+ ws <- many1 hex+ return $ foldl1 (\a b -> a * 16 + b) $ map fromIntegral ws++hex :: Parser Word8+hex =+ (digit <|> upper <|> lower) <?> "Hexadecimal digit"+ where+ digit = do+ d <- satisfy $ \w -> (w >= 48 && w <= 57)+ return $ d - 48+ upper = do+ d <- satisfy $ \w -> (w >= 65 && w <= 70)+ return $ d - 55+ lower = do+ d <- satisfy $ \w -> (w >= 97 && w <= 102)+ return $ d - 87++{-+iterParserTill :: Monad m+ => Parser a+ -> Parser end+ -> E.Enumeratee a S.ByteString m b+iterParserTill p pend =+ E.continue $ step $ parse p+ where+ step parse (E.Chunks xs) = parseLoop parse xs+ step parse E.EOF = case parse S.empty of+ Done extra a -> E.yield a $ if S.null extra+ then E.Chunks []+ else E.Chunks [extra]+ Partial _ -> err [] "iterParser: divergent parser"+ Fail _ ctx msg -> err ctx msg++ parseLoop parse [] = E.continue (step parse)+ parseLoop parse (x:xs) = case parse x of+ Done extra a -> E.yield a $ if S.null extra+ then E.Chunks xs+ else E.Chunks (extra:xs)+ Partial parse' -> parseLoop parse' xs+ Fail _ ctx msg -> err ctx msg++ err ctx msg = E.throwError (ParseError ctx msg)+-}
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ http-enumerator.cabal view
@@ -0,0 +1,33 @@+name: http-enumerator+version: 0.0.0+license: BSD3+license-file: LICENSE+author: Michael Snoyman <michael@snoyman.com>+maintainer: Michael Snoyman <michael@snoyman.com>+synopsis: HTTP client package with enumerator interface and HTTPS support.+description:+ This package uses attoparsec for parsing the actual contents of the HTTP connection. The only gotcha is the withHttpEnumerator function, otherwise should do exactly what you expect.+category: Web+stability: Experimental+cabal-version: >= 1.6+build-type: Simple+homepage: http://github.com/snoyberg/http-enumerator++library+ build-depends: base >= 4 && < 5+ , bytestring >= 0.9.1.4 && < 0.10+ , transformers >= 0.2 && < 0.3+ , HsOpenSSL >= 0.8 && < 0.9+ , failure >= 0.1 && < 0.2+ , enumerator >= 0.4 && < 0.5+ , network >= 2.2.1.7 && < 2.3+ , network-bytestring >= 0.1.3 && < 0.2+ , attoparsec >= 0.8.0.2 && < 0.9+ , attoparsec-enumerator >= 0.2 && < 0.3+ exposed-modules: Network.HTTP.Enumerator+ other-modules: Network.HTTP.Enumerator.HttpParser+ ghc-options: -Wall++source-repository head+ type: git+ location: git://github.com/snoyberg/http-enumerator.git