diff --git a/Data/IterIO.hs b/Data/IterIO.hs --- a/Data/IterIO.hs +++ b/Data/IterIO.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE CPP #-} +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702) +{-# LANGUAGE Safe #-} +#endif {- | @@ -121,7 +125,7 @@ {- $Tutorial -#tutorial# + #tutorial# The iterIO library performs IO by hooking up sources of data, called /enumerators/, to data sinks, called /iteratees/, in a manner diff --git a/Data/IterIO/Extra.hs b/Data/IterIO/Extra.hs --- a/Data/IterIO/Extra.hs +++ b/Data/IterIO/Extra.hs @@ -219,5 +219,5 @@ traceI :: (ChunkData t, Monad m) => String -> Iter t m () traceI msg = Iter $ \c -> inlinePerformIO $ do tid <- myThreadId - putTraceMsg $ show tid ++ ": " ++ msg + traceIO $ show tid ++ ": " ++ msg return $ Done () c diff --git a/Data/IterIO/Http.hs b/Data/IterIO/Http.hs --- a/Data/IterIO/Http.hs +++ b/Data/IterIO/Http.hs @@ -1,27 +1,35 @@ +{-# LANGUAGE CPP #-} +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702) +{-# LANGUAGE Trustworthy #-} +#endif {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module Data.IterIO.Http (-- * HTTP Request support - HttpReq(..), reqNormalPath + HttpReq(..), defaultHttpReq, reqNormalPath , httpReqI, inumHttpBody , inumToChunks, inumFromChunks , http_fmt_time, dateI , FormField(..), foldForm + , enumHttpReq -- , urlencodedFormI, multipartI, inumMultipart -- , foldUrlencoded, foldMultipart, foldQuery -- * HTTP Response support , HttpStatus(..) - , stat100, stat200, stat301, stat302, stat303, stat304 + , stat100, stat200 + , stat301, stat302, stat303, stat304, stat307 , stat400, stat401, stat403, stat404, stat405 , stat500, stat501 - , HttpResp(..), defaultHttpResp + , HttpResp(..), defaultHttpResp, respAddHeader , mkHttpHead, mkHtmlResp, mkContentLenResp, mkOnumResp , resp301, resp303, resp403, resp404, resp405, resp500 - , enumHttpResp + , enumHttpResp, httpRespI -- * HTTP connection handling , HttpRequestHandler , HttpServerConf(..), nullHttpServer, ioHttpServer , inumHttpServer + -- * URI parsers + , absUri, uri, path2list -- -- * For debugging -- , postReq, encReq, mptest, mptest' -- , formTestMultipart, formTestUrlencoded @@ -56,6 +64,7 @@ import Data.IterIO.Parse import Data.IterIO.Search + -- import System.IO type L = L8.ByteString @@ -64,6 +73,10 @@ strictify :: L -> S strictify = S.concat . L.toChunks +lazyfy :: S -> L +lazyfy = L.pack . S.unpack + + -- -- Basic pieces -- @@ -105,7 +118,7 @@ text_except except = concat1I (while1I ok <|> lws) where except' = fmap c2w except - ok c = c >= 0x20 && c < 0x7f && not (c `elem` except') + ok c = c >= 0x20 && c < 0x7f && c `notElem` except' -- | Parse one hex digit and return its value from 0-15. hex :: (Monad m) => Iter L m Int @@ -138,7 +151,7 @@ where tokenTab :: UArray Word8 Bool tokenTab = listArray (0,127) $ fmap isTokenChar [0..127] - isTokenChar c = c > 0x20 && c < 0x7f && not (elem (chr c) separators) + isTokenChar c = c > 0x20 && c < 0x7f && chr c `notElem` separators separators = "()<>@,;:\\\"/[]?={} \t\177" -- | Percent-decode input for as long as the non percent-escaped @@ -362,7 +375,7 @@ qpcharslash c = rfc3986_test rfc3986_pcharslash c || c == eord '?' || c == eord '%' --- | Returns (scheme, host, path, query) +-- | Parses an absoluteURI, returning (scheme, host, path, query) absUri :: (Monad m) => Iter L m (S, S, Maybe Int, S, S) absUri = do scheme <- strictify <$> satisfy (isAlpha . w2c) @@ -377,7 +390,8 @@ rfc3986_test (rfc3986_unreserved .|. rfc3986_sub_delims) c || c == eord ':' --- | Returns (scheme, host, path, query). +-- | Parses a Request-URI, defined by RFC2616, and +-- returns (scheme, host, path, query). uri :: (Monad m) => Iter L m (S, S, Maybe Int, S, S) uri = absUri <|> path @@ -387,7 +401,8 @@ path = do (p, q) <- ensureI (== eord '/') *> pathI return (S.empty, S.empty, Nothing, p, q) --- | Turn a path into a list of components +-- | Turn a path into a list of components. Used to set the +-- 'reqPathLst' field in a request. path2list :: S -> [S] path2list path = runIdentity $ inumPure path |$ (slash [] "absolute path") where @@ -406,7 +421,9 @@ -- | Data structure representing an HTTP request message. data HttpReq s = HttpReq { - reqMethod :: !S.ByteString + reqScheme :: !S.ByteString + -- ^ Scheme (e.g., \'http\', \'https\', ...) + , reqMethod :: !S.ByteString -- ^ Method (e.g., GET, POST, ...). , reqPath :: !S.ByteString -- ^ Raw path from the URL (not needed if you use @reqPathList@ @@ -444,8 +461,8 @@ -- type. , reqContentLength :: !(Maybe Int) -- ^ Value of the content-Length header, if any. - , reqTransferEncoding :: ![S.ByteString] - -- ^ A list of the encodings in the Transfer-Encoding header. + , reqTransferEncoding :: !S.ByteString + -- ^ The Transfer-Encoding header. , reqIfModifiedSince :: !(Maybe UTCTime) -- ^ Time from the If-Modified-Since header (if present) , reqSession :: s @@ -453,7 +470,8 @@ } deriving (Typeable, Show) defaultHttpReq :: HttpReq () -defaultHttpReq = HttpReq { reqMethod = S.empty +defaultHttpReq = HttpReq { reqScheme = S.empty + , reqMethod = S.empty , reqPath = S.empty , reqPathLst = [] , reqPathParams = [] @@ -466,7 +484,7 @@ , reqCookies = [] , reqContentType = Nothing , reqContentLength = Nothing - , reqTransferEncoding = [] + , reqTransferEncoding = S.empty , reqIfModifiedSince = Nothing , reqSession = () } @@ -496,13 +514,14 @@ request_line = do method <- strictify <$> while1I (isUpper . w2c) spaces - (_, host, mport, path, query) <- uri + (scheme, host, mport, path, query) <- uri spaces (major, minor) <- hTTPvers optionalI spaces skipI crlf return defaultHttpReq { - reqMethod = method + reqScheme = scheme + , reqMethod = method , reqPath = path , reqPathLst = path2list path , reqQuery = query @@ -550,7 +569,7 @@ transfer_encoding_hdr :: (Monad m) => HttpReq s -> Iter L m (HttpReq s) transfer_encoding_hdr req = do - tclist <- many tc + tclist <- tc return req { reqTransferEncoding = tclist } where tc = do @@ -579,11 +598,9 @@ let req' = req { reqHeaders = (field, val) : reqHeaders req } case Map.lookup field request_headers of Nothing -> return req' - Just f -> do - r <- inumPure (L.fromChunks [val]) .|$ - (f req' <* (optionalI spaces >> eofI) - (S8.unpack field ++ " header")) - return r + Just f -> inumPure (L.fromChunks [val]) .|$ + (f req' <* (optionalI spaces >> eofI) + (S8.unpack field ++ " header")) -- | Parse an HTTP header, returning an 'HttpReq' data structure. httpReqI :: Monad m => Iter L.ByteString m (HttpReq ()) @@ -618,17 +635,9 @@ -- | An HTTP Chunk decoder (as specified by RFC 2616). inumFromChunks :: (Monad m) => Inum L.ByteString L.ByteString m a -inumFromChunks = mkInumM $ getchunk - where - osp = skipWhileI $ \c -> c == eord ' ' || c == eord '\t' - chunk_ext_val = do char '='; osp; token <|> quoted_string; osp - chunk_ext = do char ';'; osp; token; osp; optionalI chunk_ext_val - getchunk = do - size <- hexInt <* (osp >> skipMany chunk_ext >> crlf) - if size > 0 then ipipe (inumTakeExact size) >> getchunk - else do - skipMany (noctl >> crlf) - skipI crlf +inumFromChunks = mkInum $ do + eof <- atEOFI + if eof then return L.empty else chunkedBodyI -- | This 'Inum' reads to the end of an HTTP message body (and not -- beyond) and decodes the Transfer-Encoding. It handles straight @@ -637,20 +646,14 @@ inumHttpBody :: (Monad m) => HttpReq s -> Inum L.ByteString L.ByteString m a inumHttpBody req = case reqTransferEncoding req of - lst | null lst || lst == [S8.pack "identity"] -> + enc | S.null enc || enc == S8.pack "identity" -> if hasclen then inumTakeExact (fromJust $ reqContentLength req) else inumNull -- No message body present - lst | lst == [S8.pack "chunked"] -> inumFromChunks - lst -> inumFromChunks |. tcfold (reverse lst) + enc | enc == S8.pack "chunked" -> inumFromChunks + enc -> inumFromChunks |. tcInum enc where hasclen = isJust $ reqContentLength req - tcfold [] = inumNop - tcfold (h:t) - | h == S8.pack "identity" = tcfold t - | h == S8.pack "chunked" = tcfold t -- Has to be first one - --- | h == S8.pack "gzip" = inumGunzip |. tcfold t - | otherwise = mkInum $ - fail $ "unknown Transfer-Coding " ++ chunkShow h + tcInum e = mkInum $ fail $ "unknown Transfer-Coding " ++ chunkShow e {- -- | This 'Inum' reads to the end of an HTTP message body (and not @@ -855,7 +858,7 @@ lookup (S8.pack "boundary") parms _ -> Nothing -multipartI :: (Monad m) => HttpReq s -> Iter L m (Maybe (FormField)) +multipartI :: (Monad m) => HttpReq s -> Iter L m (Maybe FormField) multipartI req = case reqBoundary req of Just b -> findpart $ S8.pack "--" `S8.append` b Nothing -> return Nothing @@ -876,7 +879,7 @@ hdrs <- many hdr_field_val crlf return FormField { - ffName = maybe S.empty id $ lookup (S8.pack "name") parms + ffName = fromMaybe S.empty $ lookup (S8.pack "name") parms , ffParams = parms , ffHeaders = cdhdr:hdrs } @@ -911,6 +914,9 @@ -- 'stat500', etc. data HttpStatus = HttpStatus !Int !S.ByteString deriving Show +instance Eq HttpStatus where + HttpStatus c0 _ == HttpStatus c1 _ = c0 == c1 + mkStat :: Int -> String -> HttpStatus mkStat n s = HttpStatus n $ S8.pack s @@ -920,7 +926,7 @@ , s, S8.pack "\r\n"] stat100, stat200 - , stat301, stat302, stat303, stat304 + , stat301, stat302, stat303, stat304, stat307 , stat400, stat401, stat403, stat404, stat405 , stat500, stat501 :: HttpStatus stat100 = mkStat 100 "Continue" @@ -929,6 +935,7 @@ stat302 = mkStat 302 "Found" stat303 = mkStat 303 "See Other" stat304 = mkStat 304 "Not Modified" +stat307 = mkStat 307 "Temporary Redirect" stat400 = mkStat 400 "Bad Request" stat401 = mkStat 401 "Unauthorized" stat403 = mkStat 403 "Forbidden" @@ -943,7 +950,7 @@ data HttpResp m = HttpResp { respStatus :: !HttpStatus -- ^ The response status. - , respHeaders :: ![S.ByteString] + , respHeaders :: ![(S.ByteString, S.ByteString)] -- ^ Headers to send back , respChunk :: !Bool -- ^ True if the message body should be passed through @@ -958,7 +965,8 @@ -- not contain a body. } -respAddHeader :: S.ByteString -> HttpResp m -> HttpResp m +-- | Add header to the HTTP response. +respAddHeader :: (S.ByteString, S.ByteString) -> HttpResp m -> HttpResp m respAddHeader hdr resp = resp { respHeaders = hdr : respHeaders resp } instance Show (HttpResp m) where @@ -988,8 +996,8 @@ -> HttpResp m mkHtmlResp stat html = resp where resp0 = mkHttpHead stat `asTypeOf` resp - ctype = S8.pack "Content-Type: text/html" - len = S8.pack $ "Content-Length: " ++ show (L8.length html) + ctype = (S8.pack "Content-Type", S8.pack"text/html") + len = (S8.pack "Content-Length", S8.pack $ show (L8.length html)) resp = resp0 { respHeaders = respHeaders resp0 ++ [ctype, len] , respBody = inumPure html } @@ -1009,8 +1017,8 @@ , respChunk = False , respBody = inumPure body } where - contentType = S8.pack $ "Content-Type: " ++ ctype - contentLength = S8.pack $ "Content-Length: " ++ show (L8.length body) + contentType = (S8.pack "Content-Type", S8.pack ctype) + contentLength = (S8.pack "Content-Length", S8.pack . show . L8.length $ body) -- | Make an 'HttpResp' of an arbitrary content-type based on an -- 'Onum' that will dynamically generate the message body. Since the @@ -1029,7 +1037,7 @@ , respChunk = True , respBody = body } where - contentType = S8.pack $ "Content-Type: " ++ ctype + contentType = (S8.pack "Content-Type", S8.pack ctype) htmlEscapeChar :: Char -> Maybe String htmlEscapeChar '<' = Just "<" @@ -1050,7 +1058,7 @@ -- | Generate a 301 (redirect) response. resp301 :: (Monad m) => String -> HttpResp m resp301 target = - respAddHeader (S8.pack $ "Location: " ++ target) $ mkHtmlResp stat301 html + respAddHeader (S8.pack "Location", S8.pack target) $ mkHtmlResp stat301 html where html = L8.concat [L8.pack "\n\ @@ -1065,7 +1073,7 @@ -- | Generate a 303 (see other) response. resp303 :: (Monad m) => String -> HttpResp m resp303 target = - respAddHeader (S8.pack $ "Location: " ++ target) $ mkHtmlResp stat303 html + respAddHeader (S8.pack "Location", S8.pack target) $ mkHtmlResp stat303 html where html = L8.concat [L8.pack "\n\ @@ -1141,19 +1149,19 @@ -- | Format and enumerate a response header and body. enumHttpResp :: (Monad m) => HttpResp m - -> Maybe UTCTime -- ^ Time for @Date:@ header (if desired) -> Onum L.ByteString m () -enumHttpResp resp mdate = inumPure fmtresp `cat` (respBody resp |. maybeChunk) +enumHttpResp resp = inumPure fmtresp `cat` (respBody resp |. maybeChunk) where - fmtresp = L.append (fmtStat $ respStatus resp) hdrs - hdrs = foldr (L.append . hdr) (L8.pack "\r\n") $ - (if respChunk resp - then ((S8.pack "Transfer-Encoding: chunked") :) - else id) $ - (maybe id (\t -> (S8.pack ("Date: " ++ http_fmt_time t) :)) mdate) - (respHeaders resp) - hdr h = L.fromChunks [h, S8.pack "\r\n"] + fmtresp = (fmtStat $ respStatus resp) `L.append` hdrsL + hdrsS = if respChunk resp + then (transferEncoding, S8.pack "chunked") : + (filter ((/= transferEncoding) . fst) $ respHeaders resp) + else respHeaders resp + hdrsL = (L.concat $ map mkHeader hdrsS) `L8.append` L8.pack "\r\n" maybeChunk = if respChunk resp then inumToChunks else inumNop + mkHeader (k, v) = lazyfy k `L8.append` L8.pack ": " + `L8.append` lazyfy v `L8.append` L8.pack "\r\n" + transferEncoding = S8.pack "Transfer-Encoding" -- | Given the headers of an HTTP request, provides an iteratee that -- will process the request body (if any) and return a response. @@ -1202,7 +1210,8 @@ resp <- liftI $ inumHttpBody req .| (catchI handler errHandler <* nullI) now <- liftI $ srvDate server - tryI (irun $ enumHttpResp resp now) >>= + let respWithDate = maybe resp (addDate resp) now + tryI (irun $ enumHttpResp respWithDate) >>= either (fatal . fst) (const loop) errHandler e@(SomeException _) _ = do srvLogger server $ "Response error: " ++ show e @@ -1210,6 +1219,189 @@ fatal e@(SomeException _) = do liftI $ srvLogger server $ "Reply error: " ++ show e return () + addDate resp t = respAddHeader (S8.pack "Date" + , S8.pack . http_fmt_time $ t) resp + +-- +-- HTTP Client support +-- + +-- | Enumerate a request, and body. +enumHttpReq :: (Monad m) => HttpReq s -> L -> Onum L m a +enumHttpReq req body = + enumNoBody |. inumStoL + `lcat` (enumPure body |. maybeChunk) + where enumNoBody = enumPure $ S.concat [ mkHttpRequest_Line req False + , mkHttpReqHeaders req + , S8.pack "\r\n" + ] + maybeChunk = case lookup transferEncoding (reqHeaders req) of + Just v | v == S8.pack "chunked" -> inumToChunks + _ -> inumNop + transferEncoding = S8.pack "Transfer-Encoding" + + +-- | Create HTTP request line, defined by RFC2616 as: +-- +-- > Request-Line = Method SP Request-URI SP HTTP-Version CRLF +-- +-- Set the @absURI@ flag to true if you wish to use an absolute-URI +-- when in the request line. Note: if the flag is set to false then +-- the \"Host\" header must be set. +mkHttpRequest_Line :: HttpReq s -> Bool -> S +mkHttpRequest_Line req absURI = S.concat [ + reqMethod req + , sp + , mkReqURI req absURI + , sp + , let (major, minor) = reqVers req + in S8.pack $ "HTTP/" ++ show major ++ "." ++ show minor + , S8.pack "\r\n" + ] + where sp = S8.singleton ' ' + +-- | Given a request, create the Request-URI. +-- If @absURI@ flag is True and the 'reqHost' field is not set, the +-- port and scheme are ignored. +-- The 'reqPathLst' is used (instead of the raw 'reqPath') when available. +mkReqURI :: HttpReq s -> Bool -> S +mkReqURI req absURI = S.concat + [ if absURI then authorization else S.empty + , if null $ reqPathLst req + then reqPath req + else reqNormalPath req + , emptyIfNull reqQuery $ \q -> S8.append (S8.singleton '?') q + ] + where emptyIfNull rF g = let r = (rF req) + in if S.null r then S.empty else g r + authorization = emptyIfNull reqHost $ \h -> S.concat + [ emptyIfNull reqScheme $ \s -> S8.append s (S8.pack "://") + , h + , maybe S.empty (S8.pack . (":"++) . show) $ reqPort req + ] + +-- | Given a request, emit all the headers. +-- Namely, this function returns : +-- *(( general-header | request-header | entity-header) CRLF) +-- It does not, howerver, check that that headers are well-formed. +mkHttpReqHeaders :: HttpReq s -> S +mkHttpReqHeaders req = S.concat . nub . filter (not . S.null) $ + hostHeader + : contentTypeHeader + : contentLengthHeader + : cookieHeader + : transferEncodingHeader + : ifModifiedSinceHeader + : allHeaders + where mkHeader (k,v) = + if S.null v + then S.empty + else k `S8.append` S8.pack ": " + `S8.append` v `S8.append` S8.pack "\r\n" + -- + hostHeader = mkHeader (S8.pack "Host", reqHost req) + -- + transferEncodingHeader = + mkHeader (S8.pack "Transfer-Encoding", reqTransferEncoding req) + -- + contentLengthHeader = + mkHeader (S8.pack "Content-Length" + , maybe S.empty (S8.pack . show) $ reqContentLength req) + -- + ifModifiedSinceHeader = + mkHeader (S8.pack "If-Modified-Since" + , maybe S.empty (S8.pack . http_fmt_time) + $ reqIfModifiedSince req) + -- + cookieHeader = + mkHeader (S8.pack "Cookie" + , S8.intercalate (S8.singleton ';') $ map p $ reqCookies req) + p (k, v) = k `S8.append` S8.singleton '=' `S8.append` v + -- + contentTypeHeader = + mkHeader (S8.pack "Content-Type" + , maybe S.empty ctF $ reqContentType req) + ctF (mt,params) = mt `S8.append` + (S8.intercalate (S8.singleton ';') $ map p params) + -- + allHeaders = map mkHeader $ reqHeaders req + +-- Status-Line = HTTP-Version SP Status-Code SP Reason-Phrase CRLF +httpStatusI :: (Monad m) => Iter L m HttpStatus +httpStatusI = do + _ <- hTTPvers + spaces + status <- whileMinMaxI 3 3 (isDigit . w2c) >>= readI "Status code" + spaces + phrase <- L8.unpack <$> text_except "\r\n" + skipI crlf + return $ mkStat status phrase + +-- | Return a response. If the \'Trasnfer-Encoding\' header is set to +-- \'chunked\', it is removed from the headers and the 'respChunk' +-- field is set. +-- 'enumHttpResp' to enumerate the headers and body. +httpRespI :: (MonadIO m) => Iter L m (HttpResp m) +httpRespI = do + stat <- httpStatusI + hdrs <- many hdr_field_val + chunked <- maybe (return False) (isChunked . L8.map toLower . lazyfy) $ + lookup (S8.pack "transfer-encoding") hdrs + let hdrs' = if chunked + then filter ((/= S8.pack "transfer-encoding") . fst) hdrs + else hdrs + skipI crlf + body <- httpBodyI hdrs' chunked + let resp = HttpResp { respStatus = stat + , respHeaders = hdrs' + , respChunk = chunked + , respBody = enumPure body } + return resp + where isChunked v = enumPure v |$ (cI <|> return False) + cI = do optionalI spaces + match $ L8.pack "chunked" + optionalI spaces + return True + +-- | This 'Inum' reads to the end of an HTTP message body (and not +-- beyond) and decodes the Transfer-Encoding. It handles straight +-- content of a size specified by the Content-Length header and +-- chunk-encoded content. If neither headers are set, it reads the +-- body lazyly (with 'pureI'). +httpBodyI :: (Monad m) => [(S,S)] -> Bool -> Iter L m L +httpBodyI hdrs isChunked = + if isChunked + then chunkedBodyI + else let mLen = do lenS <- lookup (S8.pack "content-length") hdrs + maybeRead . S8.unpack $ lenS + in maybe pureI takeI mLen + where maybeRead = fmap fst . listToMaybe . reads + +-- | This 'Iter' decodes \'chunk\' encoded body. Specifically, +-- it implements \'chunked-body\' of RFC2616. Note: the +-- entity-headers in the trailer are ignored. +chunkedBodyI :: Monad m => Iter L m L +chunkedBodyI = do + r <- many chunk_ + skipMany trailer + skipI crlf + return $ L.concat r + where chunk_ = do size <- chunk_size + chunk_ext + crlf + b <- if size > 0 + then takeI size <* crlf + else return L.empty -- last-chunk + return b + chunk_size = hexInt + chunk_ext = skipMany $ do char ';' + osp + chunk_ext_name + optionalI $ char '=' >> chunk_ext_val + chunk_ext_name = token + chunk_ext_val = token <|> quoted_string + trailer = hdr_field_val + osp = skipWhileI $ \c -> c == eord ' ' || c == eord '\t' {- diff --git a/Data/IterIO/HttpClient.hs b/Data/IterIO/HttpClient.hs new file mode 100644 --- /dev/null +++ b/Data/IterIO/HttpClient.hs @@ -0,0 +1,304 @@ +module Data.IterIO.HttpClient ( -- * Simple interface + simpleHttp, genSimpleHttp + , headRequest, getRequest, postRequest + -- * GET, HEAD wrappers + , simpleGetHttp, simpleGetHttps + , simpleHeadHttp, simpleHeadHttps + -- * Advanced interface + , HttpClient(..) + , mkHttpClient + , httpConnect + , inumHttpClient + , HttpResponseHandler + -- * Internal + , userAgent + , maxNrRedirects + , mkRequestToAbsUri + ) where + +import Prelude hiding (catch, head, div) + +import Control.Monad (when, unless) +import Control.Exception +import Control.Monad.Trans + +import Data.Maybe ( isNothing, fromJust) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L8 + +import qualified Network.Socket as Net +import qualified Network.BSD as Net +import qualified OpenSSL.Session as SSL + +import Data.IterIO +import Data.IterIO.Http +import Data.IterIO.SSL + +import Data.Version (showVersion) +import Paths_iterIO (version) + +import Data.IORef + +type L = L.ByteString +type S = S.ByteString + + +lazyfy :: S -> L +lazyfy = L.pack . S.unpack + +catchIO :: IO a -> (IOException -> IO a) -> IO a +catchIO = catch + +-- | User agent corresponding to this library. +userAgent :: String +userAgent = "haskell-iterIO/" ++ showVersion version + +-- | An HTTP client. +data HttpClient = HttpClient { + hcSock :: !Net.Socket + -- ^ Socket + , hcSockAddr :: !Net.SockAddr + -- ^ Socket address + , hcSslCtx :: !(Maybe SSL.SSLContext) + -- ^ SSL context + , hcIsHttps :: !Bool + -- ^ Use SSL + } + +-- | Maximum number of redirects. Defult: no redirect (0). +maxNrRedirects :: Int +maxNrRedirects = 0 + +-- | Given an HTTP client configuration, make the actual connection to +-- server. +httpConnect :: MonadIO m => HttpClient -> IO (Iter L m (), Onum L m a) +httpConnect hc = do + let s = hcSock hc + isHttps = hcIsHttps hc + when (isHttps && isNothing (hcSslCtx hc)) $ + throwIO (userError "Need SSL context for HTTPS") + Net.connect s (hcSockAddr hc) + if hcIsHttps hc + then iterSSL (fromJust $ hcSslCtx hc) s False + else iterStream s + + +-- | Given the host, port, context, and \"is-https\" flag, create +-- a client value. The returned value can be used with 'httpConnect' +-- to get raw pipes to/from the server. +-- +-- /Note:/ Some of this code is from the "HTTP" package. +mkHttpClient :: S -- ^ Host + -> Int -- ^ Port + -> Maybe SSL.SSLContext -- ^ SSL context + -> Bool -- ^ Is HTTPS + -> IO HttpClient +mkHttpClient host port ctx isHttps = withSocket $ \s -> do + Net.setSocketOption s Net.KeepAlive 1 + hostA <- getHostAddr (S8.unpack host) + let a = Net.SockAddrInet (toEnum port) hostA + return HttpClient { hcSock = s + , hcSockAddr = a + , hcSslCtx = ctx + , hcIsHttps = isHttps } + where withSocket action = do + s <- Net.socket Net.AF_INET Net.Stream 6 + catchIO (action s) (\e -> Net.sClose s >> ioError e) + getHostAddr h = + catchIO (Net.inet_addr h) $ \_ -> do + h' <- getHostByName_safe h + case Net.hostAddresses h' of + [] -> err $ "No addresses in host entry for " ++ show h + (ha:_) -> return ha + getHostByName_safe h = + catchIO (Net.getHostByName h) $ \_ -> + err $ "Failed to lookup " ++ show h + err = throwIO . userError + +-- +-- Simple interface wrappers +-- + +-- | Perform a simple HTTP GET request. No SSL support. +simpleGetHttp :: MonadIO m + => String -- ^ URL + -> m (HttpResp m) +simpleGetHttp url = simpleHttp (getRequest url) L.empty Nothing + +-- | Perform a simple HTTPS GET request. +simpleGetHttps :: MonadIO m + => String -- ^ URL + -> SSL.SSLContext -- ^ SSL Context + -> m (HttpResp m) +simpleGetHttps url ctx = simpleHttp (getRequest url) L.empty (Just ctx) + +-- | Perform a simple HTTP HEAD request. No SSL support. +simpleHeadHttp :: MonadIO m + => String -- ^ URL + -> m (HttpResp m) +simpleHeadHttp url = simpleHttp (headRequest url) L.empty Nothing + +-- | Perform a simple HTTPS HEAD request. +simpleHeadHttps :: MonadIO m + => String -- ^ URL + -> SSL.SSLContext -- ^ SSL Context + -> m (HttpResp m) +simpleHeadHttps url ctx = simpleHttp (headRequest url) L.empty (Just ctx) + + +-- +-- Simple interface +-- + +-- | Perform a simple HTTP request, given the the request header, body +-- and SSL context, if any. +simpleHttp :: MonadIO m + => HttpReq () -- ^ Request header + -> L -- ^ Request body + -> Maybe SSL.SSLContext -- ^ SSL Context + -> m (HttpResp m) +simpleHttp req body ctx = genSimpleHttp req body ctx maxNrRedirects True + +-- | Make a general HTTP request to host specified in the request. +-- If the request is over HTTPS, the SSL context must be provided. +-- The redirect count is used to limit the number of redirects +-- followed (when receiving a 3xx response); use 0 to return the +-- direct response. The @passCookies@ flag is used to guard cookies +-- on redirects: because @genSimpleHttp@ performs a \"single request\" +-- it does not parse \"Set-Cookie\" headers and so is unaware of the +-- cookie domain. Hence, the flag is used for the decision in passing +-- the cookie to the location of a redirect. +genSimpleHttp :: MonadIO m + => HttpReq () -- ^ Request header + -> L -- ^ Message body + -> Maybe SSL.SSLContext -- ^ SSL Context + -> Int -- ^ Redirect count + -> Bool -- ^ Pass cookies + -> m (HttpResp m) +genSimpleHttp req body ctx redirectCount passCookies = do + let scheme = reqScheme req + isHttps = scheme == (S8.pack "https") + port <- maybe (defaultPort scheme) return $ reqPort req + client <- liftIO $ mkHttpClient (reqHost req) port ctx isHttps + (sIter,sOnum) <- liftIO $ httpConnect client + refResp <- liftIO $ newIORef Nothing + count <- liftIO $ newIORef 0 + sOnum |$ inumHttpClient (req, body) (handler count refResp) .| sIter + mresp <- liftIO $ readIORef refResp + maybe err return mresp + where handler countRef refResp resp = do + liftIO $ writeIORef refResp (Just resp) + count <- liftIO $ do c <- readIORef countRef + writeIORef countRef (c+1) + return c + if count < redirectCount + then handleRedirect (req, body) passCookies resp + else return Nothing + defaultPort s | s == S8.pack "http" = return 80 + | s == S8.pack "https" = return 443 + | otherwise = liftIO . throwIO . userError $ + "Unrecognized scheme" ++ S8.unpack s + err = liftIO . throwIO . userError $ "Request failed" + +-- | Given a 3xx response and original request, handle the redirect. +-- Currently, only reponses with status codes 30[1237] and set +-- \"Location\" header are handled. Note that the request is made to +-- the same host, so a redirect to a different host will result in a +-- 4xx response. +handleRedirect :: MonadIO m + => (HttpReq s, L ) -- ^ Original request + -> Bool -- ^ Pass cookies + -> HttpResp m -- ^ Response + -> Iter L m (Maybe (HttpReq s, L)) +handleRedirect (req, body) passCookies resp = + if (respStatus resp `notElem` s300s) || (reqMethod req `notElem` meths) + then return Nothing + else doRedirect $ lookup (S8.pack "location") $ respHeaders resp + where s300s = [stat301, stat302, stat303, stat307] + meths = [S8.pack "GET", S8.pack "HEAD"] + doRedirect Nothing = return Nothing + doRedirect (Just url) = do + newReq <- mkRequestToAbsUri (lazyfy url) (reqMethod req) + let req' = newReq { reqHeaders = reqHeaders req + , reqCookies = if passCookies + then reqCookies req + else [] + , reqContentType = reqContentType req + , reqContentLength = reqContentLength req + , reqTransferEncoding = reqTransferEncoding req + , reqIfModifiedSince = reqIfModifiedSince req + , reqSession = reqSession req } + return $ Just (req', body) + +-- +-- Create requests +-- + +-- | Create a simple HEAD request. +-- The @url@ must be an @absoluteURI@. +headRequest :: String -> HttpReq () +headRequest url = fromJust $ mkRequestToAbsUri (L8.pack url) $ S8.pack "HEAD" + +-- | Create a simple GET request. +-- The @url@ must be an @absoluteURI@. +getRequest :: String -> HttpReq () +getRequest url = fromJust $ mkRequestToAbsUri (L8.pack url) $ S8.pack "GET" + +-- | Given a URL, Content-Type, and message body, perform a simple +-- POST request. Note: message body must be properly encoded (e.g., +-- URL-encoded if the Content-Type is +-- \"application\/x-www-form-urlencoded\"). +postRequest :: String -- ^ URL + -> String -- ^ Content-Type header + -> L -- ^ Message body + -> HttpReq () +postRequest url ct body = + let req = fromJust $ mkRequestToAbsUri (L8.pack url) $ S8.pack "POST" + in req { reqContentType = Just (S8.pack ct, []) + , reqContentLength = Just . fromIntegral . L8.length $ body } + +-- | Createa generic HTTP request, given an absoluteURI: +-- If the URI is not absolute, the parser will fail. +mkRequestToAbsUri :: Monad m => L -> S -> m (HttpReq ()) +mkRequestToAbsUri urlString method = do + (scheme, host, mport, path, query) <- enumPure urlString |$ absUri + return defaultHttpReq { reqScheme = scheme + , reqMethod = method + , reqPath = path + , reqPathLst = path2list path + , reqQuery = query + , reqHost = host + , reqPort = mport + , reqContentLength = Just 0 + , reqVers = (1,1) + , reqHeaders = [hostHeader host, uaHeader] + } + where uaHeader = (S8.pack "User-Agent", S8.pack userAgent) + hostHeader host = (S8.pack "Host", host) + +-- | An HTTP response handler used by HTTP clients. +type HttpResponseHandler m s = + HttpResp m -> Iter L m (Maybe (HttpReq s, L)) + +-- | Given an initial request, and a response handler, +-- create an inum that provides underlying functionality of an http +-- client. +inumHttpClient :: MonadIO m + => (HttpReq s, L) + -> HttpResponseHandler m s -> Inum L L m a +inumHttpClient (req,body) respHandler = mkInumM $ + tryI (irun $ enumHttpReq req body) >>= + either (fatal . fst) (const loop) + where loop = do eof <- atEOFI + unless eof doresp + doresp = do + resp <- liftI $ httpRespI + mreq <- catchI (liftI $ respHandler resp) errH + maybe (return ()) + (\(req', body') -> + tryI (irun $ enumHttpReq req' body') >>= + either (fatal . fst) (const loop)) mreq + fatal (SomeException _) = return () + errH (SomeException _) = return . return $ Nothing diff --git a/Data/IterIO/HttpRoute.hs b/Data/IterIO/HttpRoute.hs --- a/Data/IterIO/HttpRoute.hs +++ b/Data/IterIO/HttpRoute.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE CPP #-} +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702) +{-# LANGUAGE Trustworthy #-} +#endif module Data.IterIO.HttpRoute (HttpRoute(..) @@ -91,10 +95,11 @@ -- cache static data for an hour, you might use: -- -- @ --- addHeader ('S8.pack' \"Cache-control: max-age=3600\") $ +-- addHeader ('S8.pack' \"Cache-control\", 'S8.pack' \"max-age=3600\") $ -- 'routeFileSys' mime ('dirRedir' \"index.html\") \"\/var\/www\/htdocs\" -- @ -addHeader :: (Monad m) => S8.ByteString -> HttpRoute m s -> HttpRoute m s +addHeader :: (Monad m) => + (S8.ByteString, S8.ByteString) -> HttpRoute m s -> HttpRoute m s addHeader h (HttpRoute r) = HttpRoute $ \req -> liftM (liftM addit) (r req) where addit resp = resp { respHeaders = h : respHeaders resp } @@ -220,7 +225,7 @@ -- | Parses @mime.types@ file data. Returns a function mapping file -- suffixes to mime types. The argument is a default mime type for --- suffixes to do not match any in the mime.types data. (Reasonable +-- suffixes that do not match any in the mime.types data. (Reasonable -- defaults might be @\"text\/html\"@, @\"text\/plain\"@, or, more -- pedantically but less usefully, @\"application\/octet-stream\"@.) -- @@ -366,9 +371,9 @@ , respHeaders = mkHeaders req st } mkHeaders req st = - [ S8.pack $ "Last-Modified: " ++ (http_fmt_time $ modTimeUTC st) - , S8.pack $ "Content-Length: " ++ (show $ fileSize st) - , S8.pack "Content-Type: " `S8.append` typemap (fileExt req) ] + [ (S8.pack "Last-Modified", S8.pack . http_fmt_time $ modTimeUTC st) + , (S8.pack "Content-Length", S8.pack . show $ fileSize st) + , (S8.pack "Content-Type", typemap (fileExt req)) ] fileExt req = drop 1 $ takeExtension $ case reqPathLst req of [] -> dir diff --git a/Data/IterIO/Inum.hs b/Data/IterIO/Inum.hs --- a/Data/IterIO/Inum.hs +++ b/Data/IterIO/Inum.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE CPP #-} +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702) +{-# LANGUAGE Trustworthy #-} +#endif {-# LANGUAGE DeriveDataTypeable #-} module Data.IterIO.Inum @@ -19,10 +23,14 @@ , runIterM, runIterMC, runInum -- * Some basic Inums , inumNop, inumNull, inumPure, enumPure, inumRepeat + , inumTee + -- * Enumerator construction from Codecs + , Codec, runCodec, runCodecC -- * Enumerator construction monad -- $mkInumMIntro , InumM, mkInumM, mkInumAutoM - , setCtlHandler, setAutoEOF, setAutoDone, addCleanup, withCleanup + , setCtlHandler, setAutoEOF, setAutoDone + , addCleanup, withCleanup , ifeed, ifeed1, ipipe, irun, irepeat, ipopresid, idone ) where @@ -734,6 +742,53 @@ (_, Left r) -> reRunIter r -- +-- Codec-based Inum creation +-- + +-- | A @Codec@ produces some input to feed to an 'Iter', and +-- optionally returns an 'Inum' that will produce the rest of the +-- input. The funciton 'runCodec' can be used to build an 'Inum' out +-- of a 'Codec'. Using 'runCodec' is much simpler than 'mkInumM', but +-- more expressive than 'mkInum'. For example, a possible +-- implementation of 'mkInum' would be: +-- +-- @ +-- mkInum :: ('ChunkData' tIn, 'ChunkData' tOut, 'Monad' m) => +-- 'Iter' tIn m tOut -> 'Inum' tIn tOut m a +-- mkInum trans = inum +-- where inum = 'runCodec' 'id' $ +-- 'tryEOFI' trans >>= 'maybe' (return (mempty, Nothing)) doinput +-- doinput input = do +-- eof <- if null input then return False else 'atEOFI' +-- return (input, if eof then Nothing else Just inum) +-- @ +type Codec tIn tOut m a = Iter tIn m (tOut, Maybe (Inum tIn tOut m a)) + +-- | A generalized version of 'runCodec' that allows a 'CtlHandler' to +-- be specified. +-- +-- @ +-- runCodec adj = runCodecC adj (passCtl adj) +-- @ +runCodecC :: (ChunkData tIn, ChunkData tOut, Monad m) => + ResidHandler tIn tOut + -> CtlHandler (Iter tIn m) tOut m a + -> Codec tIn tOut m a + -> Inum tIn tOut m a +runCodecC adj ch codec iter = do + (tOut, minum) <- codec + r <- runIterMC ch iter $ chunk tOut + case (minum, r) of + (Just inum, IterF i) -> inum i + _ | isIterActive r -> return r + _ -> withResidHandler adj (getResid r) $ return . setResid r + +-- | Build an 'Inum' from a 'Codec'. +runCodec :: (ChunkData tIn, ChunkData tOut, Monad m) => + ResidHandler tIn tOut -> Codec tIn tOut m a -> Inum tIn tOut m a +runCodec adj = runCodecC adj (passCtl adj) + +-- -- Complex Inum creation -- @@ -909,6 +964,15 @@ , insCleaning = False } +-- | An InumState that passes all control messages up and pulls up all +-- residual data at the end. Requires the input and output types to +-- be the same. +nopInumState :: (ChunkData t, Monad m) => InumState t t m a +nopInumState = s + where s = (defaultInumState `asTypeOf` s) { + insCtl = passCtl pullupResid + , insCleanup = ipopresid >>= ungetI } + -- | A monad in which to define the actions of an @'Inum' tIn tOut m -- a@. Note @InumM tIn tOut m a@ is a 'Monad' of kind @* -> *@, where -- @a@ is the (almost always parametric) return type of the 'Inum'. A @@ -1005,6 +1069,7 @@ getErr (Fail (IterEOFErr _) _ _, s) | insAutoEOF s = return (Nothing, s) getErr (Fail e _ _, s) = return (Just e, s) getErr (_, s) = return (Nothing, s) + -- | A variant of 'mkInumM' that sets /AutoEOF/ and /AutoDone/ to -- 'True' by default. (Equivalent to calling @'setAutoEOF' 'True' >> @@ -1128,3 +1193,38 @@ -- @'throwI' ...@ for an unsuccessful exit.) idone :: (ChunkData tIn, Monad m) => InumM tIn tOut m a b idone = setAutoEOF True >> throwEOFI "idone" + +-- | An 'Inum' that acts like 'inumNop', except that before passing +-- data on, it feeds a copy to a \"tee\" 'Iter' (by analogy with the +-- Unix @tee@ utility), which may, for instance, transform and log the +-- data. +-- +-- The tee `Iter`'s return value is ignored. If the tee 'Iter' +-- returns before an EOF is received and before the target 'Iter' has +-- finished processing input, then @inumTee@ will continue to pass +-- data to the target 'Iter'. However, if the tee 'Iter' fails, then +-- this will cause @inumTee@ to fail immediately. +-- +-- As an example, one could implement something close to +-- @'inumStderr'@ (from "Data.IterIO.ListLike") as follows: +-- +-- > inumStderr = inumTee $ handleI stderr +-- +-- (Except note that the real @'inumStderr'@ does not close its file +-- descriptor, while the above implementation will send an EOF to +-- @'handleI'@, causing @stderr@ to be closed.) +inumTee :: (ChunkData t, Monad m) => + Iter t m b -> Inum t t m a +inumTee tee0 iter0 = runInumM (chunk0I >>= loop tee0) + nopInumState { insIter = IterF iter0 } + where chunk0I = Iter $ \c@(Chunk _ eof) -> Done c (Chunk mempty eof) + loop tee c = liftI (runIterMC (passCtl pullupResid) tee c) >>= feed c + feed (Chunk d False) (IterF tee) = do + done <- ifeed d `onExceptionI` liftI (runI tee) + if done then liftI (runI tee) >> return () else chunkI >>= loop tee + feed (Chunk d True) (IterF _) = ifeed d >> return () + feed _ (Fail r _ c) = reRunIter $ Fail r Nothing c + feed (Chunk d eof) (Done _ _) = do + done <- ifeed d + unless (done || eof) $ ipipe inumNop >> return () + feed _ _ = error "inumTee" diff --git a/Data/IterIO/Iter.hs b/Data/IterIO/Iter.hs --- a/Data/IterIO/Iter.hs +++ b/Data/IterIO/Iter.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE CPP #-} +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702) +{-# LANGUAGE Trustworthy #-} +#endif {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -278,7 +282,9 @@ ++ shows c rest) iterTc :: TyCon -iterTc = mkTyCon "Iter" +iterTc = mkTyCon3 "iterIO" "Data.IterIO.Iter" "Iter" +-- iterTc = mkTyCon "Iter" + instance (Typeable t, Typeable1 m) => Typeable1 (Iter t m) where typeOf1 iter = mkTyConApp iterTc [typeOf $ t iter, typeOf1 $ m iter] where t :: Iter t m a -> t; t _ = undefined @@ -717,7 +723,7 @@ -- @b@ concurrently as input chunks arrive. If @a@ throws a parse -- error, then the result of executing @b@ is returned. If @a@ -- either succeeds or throws an exception that is not a parse --- error/EOF/'mzero', then the result of running @a@ is returned. +-- error\/EOF\/'mzero', then the result of running @a@ is returned. -- -- * With @multiParse a b@, if @b@ returns a value, executes a -- monadic action via 'lift', or issues a control request via @@ -791,6 +797,8 @@ where check ra@(Done _ _) _ = ra check (IterF ia) (IterF ib) = IterF $ multiParse ia ib + check (IterF ia) (Fail e ma _) = IterF $ multiParse ia + (Iter $ const $ Fail e ma Nothing) check (IterF ia) rb = IterF $ onDoneInput (\ra c -> check ra (runIterR rb c)) ia check ra rb = stepR ra (flip check rb) $ case ra of diff --git a/Data/IterIO/ListLike.hs b/Data/IterIO/ListLike.hs --- a/Data/IterIO/ListLike.hs +++ b/Data/IterIO/ListLike.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE CPP #-} +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702) +{-# LANGUAGE Trustworthy #-} +#endif {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} diff --git a/Data/IterIO/Parse.hs b/Data/IterIO/Parse.hs --- a/Data/IterIO/Parse.hs +++ b/Data/IterIO/Parse.hs @@ -1,4 +1,7 @@ - +{-# LANGUAGE CPP #-} +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702) +{-# LANGUAGE Safe #-} +#endif -- | This module contains functions to help parsing input from within -- 'Iter's. Many of the operators are either imported from -- "Data.Applicative" or inspired by "Text.Parsec". diff --git a/Data/IterIO/SSL.hs b/Data/IterIO/SSL.hs --- a/Data/IterIO/SSL.hs +++ b/Data/IterIO/SSL.hs @@ -1,12 +1,14 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} module Data.IterIO.SSL where import Control.Exception (throwIO, ErrorCall(..), finally, onException) +import qualified Control.Exception as E import Control.Monad import Control.Monad.Trans -import Data.ByteString as S +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.Internal as L (defaultChunkSize) import Data.Typeable @@ -15,6 +17,8 @@ import System.Cmd import System.Exit +import Foreign.C.Error (errnoToIOError, eOK) + import Data.IterIO.Iter import Data.IterIO.Inum import Data.IterIO.ListLike @@ -71,7 +75,10 @@ (if server then SSL.accept ssl else SSL.connect ssl) `onException` Net.sClose sock liftIO $ pairFinalizer (sslI ssl) (enumSsl ssl) $ - SSL.shutdown ssl SSL.Bidirectional `finally` Net.sClose sock + SSL.shutdown ssl SSL.Bidirectional + `E.catch` \(e::IOError) -> unless (notErr e) (ioError e) + `finally` Net.sClose sock + where notErr = (== errnoToIOError "SSL_shutdown" eOK Nothing Nothing) -- | Simplest possible SSL context, loads cert and unencrypted private -- key from a single file. diff --git a/Data/IterIO/Trans.hs b/Data/IterIO/Trans.hs --- a/Data/IterIO/Trans.hs +++ b/Data/IterIO/Trans.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE CPP #-} +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702) +{-# LANGUAGE Trustworthy #-} +#endif {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} @@ -75,8 +79,6 @@ import qualified Control.Monad.RWS.Lazy as Lazy import qualified Control.Monad.State.Lazy as Lazy import qualified Control.Monad.Writer.Lazy as Lazy -import Control.Monad -import Control.Monad.Trans import Data.IterIO.Iter diff --git a/Data/IterIO/ZlibInt.hsc b/Data/IterIO/ZlibInt.hsc --- a/Data/IterIO/ZlibInt.hsc +++ b/Data/IterIO/ZlibInt.hsc @@ -7,7 +7,8 @@ module Data.IterIO.ZlibInt where import Data.Word -import Foreign +import System.IO.Unsafe (unsafePerformIO) +import Foreign hiding (unsafePerformIO) import Foreign.C #include "zlib.h" diff --git a/Examples/httptest.hs b/Examples/httptest.hs --- a/Examples/httptest.hs +++ b/Examples/httptest.hs @@ -74,7 +74,7 @@ , ("favicon.ico" -- serve /favicon.ico from file ./static/favicon.ico, -- but tell browser to cache it for 1 day - , addHeader "Cache-Control: max-age=86400" $ + , addHeader ("Cache-Control", "max-age=86400") $ routeFS "static/favicon.ico") ] , routePath cabal_dir $ routeFS cabal_dir diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,4 +1,10 @@ +Added the Codec type and runCodec, runCodecC functions. + +Fixed multiParse to avoid buffering when second 'Iter' fails + +Added inumTee function + * Changes in release 0.2 Updated to compile with HsOpenSSL 0.10.1, which has incompatible diff --git a/iterIO.cabal b/iterIO.cabal --- a/iterIO.cabal +++ b/iterIO.cabal @@ -1,13 +1,13 @@ Name: iterIO Homepage: http://www.scs.stanford.edu/~dm/iterIO -Version: 0.2 +Version: 0.2.2 Cabal-version: >= 1.6 build-type: Simple License: BSD3 License-file: LICENSE -Author: David Mazieres +Author: David Mazieres, Deian Stefan, Amit Levy Stability: experimental -Maintainer: http://www.scs.stanford.edu/~dm/addr/ +Maintainer: levya@cs.stanford.edu, deian@cs.stanford.edu Category: System, Data, Enumerator Synopsis: Iteratee-based IO with pipe operators Extra-source-files: @@ -56,11 +56,11 @@ Source-repository head Type: git - Location: http://www.scs.stanford.edu/~dm/repos/iterIO.git + Location: http://github.com/scs/iterIO.git Library Build-depends: array >= 0.3.0.1 && < 2, - base >= 4.3 && < 6, + base >= 4.4 && < 6, bytestring >= 0.9 && < 2, containers >= 0.3 && < 2, filepath >= 1.2 && < 2, @@ -75,13 +75,14 @@ time >= 1.1.4 && < 2, unix >= 2.4 && < 3 - ghc-options: -Wall + ghc-options: -Wall -pgmP cpphs -optP --cpp Exposed-modules: Data.IterIO, Data.IterIO.Atto, Data.IterIO.Iter, Data.IterIO.Extra, Data.IterIO.Http, + Data.IterIO.HttpClient, Data.IterIO.HttpRoute, Data.IterIO.Inum, Data.IterIO.ListLike, @@ -92,6 +93,7 @@ Data.IterIO.Zlib Other-modules: Data.IterIO.ZlibInt + Paths_iterIO Extensions: ForeignFunctionInterface, DeriveDataTypeable, ExistentialQuantification, MultiParamTypeClasses,