diff --git a/Data/IterIO.hs b/Data/IterIO.hs --- a/Data/IterIO.hs +++ b/Data/IterIO.hs @@ -177,7 +177,7 @@ the lazy @'ByteString'@ format, which is more efficient than plain 'String's. ('enumFile' supports multiple types, but in this example there is not enough information for Haskell to choose one of them, so -we must use 'enumfile'' or use @::@ to specify a type explicitly.) +we must use 'enumFile'' or use @::@ to specify a type explicitly.) Once again, '|$' is used to execute the IO actions, but, this time, the return value is just @()@; the interesting action lies in the side effects of writing data to standard output while iterating over the @@ -355,7 +355,7 @@ inumGrep :: (Monad m) => String -> 'Inum' [S.ByteString] [S.ByteString] m a inumGrep re = `mkInum` $ do line <- 'headI' - if line =~ packedRe then return [line] else inumGrep re + if line =~ packedRe then return [line] else return [] where packedRe = S8.pack re @ @@ -369,19 +369,6 @@ Just _ -> count (n+1) Nothing -> return n @ - -Notice that when a line doesn't match, @inumGrep@ calls itself -recursively. This is necessary because returning an empty list of -lines signals to 'mkInum' that there is no more input. Thus, the -following code would cause our grep implementation to exit at the -first non-matching line: - -@ - return $ if line =~ packedRe then [line] else [] -- Incorrect -@ - -(If you don't like this 'mempty'-means-EOF behavior, you can also wrap -the argument to 'mkInum' in the function 'whileNullI'.) Now we are almost ready to assemble all the pieces. But recall that the '|$' operator applies one 'Onum' to one 'Iter', yet now we have diff --git a/Data/IterIO/Atto.hs b/Data/IterIO/Atto.hs --- a/Data/IterIO/Atto.hs +++ b/Data/IterIO/Atto.hs @@ -1,12 +1,9 @@ -{-# LANGUAGE DeriveDataTypeable #-} -- | This module contains an adapter function to run attoparsec -- 'Parser's from within the 'Iter' monad. module Data.IterIO.Atto where -import Control.Exception import Data.Attoparsec as A -import Data.Typeable import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S diff --git a/Data/IterIO/Http.hs b/Data/IterIO/Http.hs --- a/Data/IterIO/Http.hs +++ b/Data/IterIO/Http.hs @@ -359,7 +359,8 @@ <|> return (S8.pack "/") query <- char '?' *> (strictify <$> whileI qpcharslash) <|> nil return (path, query) - qpcharslash c = rfc3986_test rfc3986_pcharslash c || c == eord '?' + qpcharslash c = rfc3986_test rfc3986_pcharslash c + || c == eord '?' || c == eord '%' -- | Returns (scheme, host, path, query) absUri :: (Monad m) => Iter L m (S, S, Maybe Int, S, S) @@ -404,7 +405,7 @@ -- -- | Data structure representing an HTTP request message. -data HttpReq = HttpReq { +data HttpReq s = HttpReq { reqMethod :: !S.ByteString -- ^ Method (e.g., GET, POST, ...). , reqPath :: !S.ByteString @@ -446,9 +447,12 @@ , reqTransferEncoding :: ![S.ByteString] -- ^ A list of the encodings in the Transfer-Encoding header. , reqIfModifiedSince :: !(Maybe UTCTime) + -- ^ Time from the If-Modified-Since header (if present) + , reqSession :: s + -- ^ Application-specific session information } deriving (Typeable, Show) -defaultHttpReq :: HttpReq +defaultHttpReq :: HttpReq () defaultHttpReq = HttpReq { reqMethod = S.empty , reqPath = S.empty , reqPathLst = [] @@ -464,6 +468,7 @@ , reqContentLength = Nothing , reqTransferEncoding = [] , reqIfModifiedSince = Nothing + , reqSession = () } -- | Returns a normalized version of the full requested path @@ -471,7 +476,7 @@ -- has been eliminated, @\"..\"@ has been processed, there is exactly -- one @\'/\'@ between each directory component, and the query has -- been stripped off). -reqNormalPath :: HttpReq -> S.ByteString +reqNormalPath :: HttpReq s -> S.ByteString reqNormalPath rq = S.intercalate slash $ S.empty : reqPathCtx rq ++ reqPathLst rq where slash = S8.singleton '/' @@ -487,7 +492,7 @@ -- | HTTP request line, defined by RFC2616 as: -- -- > Request-Line = Method SP Request-URI SP HTTP-Version CRLF -request_line :: (Monad m) => Iter L m HttpReq +request_line :: (Monad m) => Iter L m (HttpReq ()) request_line = do method <- strictify <$> while1I (isUpper . w2c) spaces @@ -506,7 +511,7 @@ , reqVers = (major, minor) } -request_headers :: (Monad m) => Map S (HttpReq -> Iter L m HttpReq) +request_headers :: (Monad m) => Map S (HttpReq a -> Iter L m (HttpReq a)) request_headers = Map.fromList $ map (\(a, b) -> (S8.map toLower $ S8.pack a, b)) $ [ @@ -518,13 +523,13 @@ , ("If-Modified-Since", if_modified_since_hdr) ] -host_hdr :: (Monad m) => HttpReq -> Iter L m HttpReq +host_hdr :: (Monad m) => HttpReq s -> Iter L m (HttpReq s) host_hdr req = do (host, mport) <- hostI return req { reqHost = host, reqPort = mport } -- Cookie header (RFC 6265) -cookie_hdr :: (Monad m) => HttpReq -> Iter L m HttpReq +cookie_hdr :: (Monad m) => HttpReq s -> Iter L m (HttpReq s) cookie_hdr req = ifParse cookiesI setCookies ignore where cookiesI = sepBy1 parameter sep <* eofI @@ -532,18 +537,18 @@ setCookies cookies = return $ req { reqCookies = cookies } ignore = nullI >> return req -content_type_hdr :: (Monad m) => HttpReq -> Iter L m HttpReq +content_type_hdr :: (Monad m) => HttpReq s -> Iter L m (HttpReq s) content_type_hdr req = do typ <- token <++> char '/' <:> token parms <- many $ olws >> char ';' >> parameter return req { reqContentType = Just (typ, parms) } -content_length_hdr :: (Monad m) => HttpReq -> Iter L m HttpReq +content_length_hdr :: (Monad m) => HttpReq s -> Iter L m (HttpReq s) content_length_hdr req = do len <- olws >> (while1I (isDigit . w2c) >>= readI) <* olws return req { reqContentLength = Just len } -transfer_encoding_hdr :: (Monad m) => HttpReq -> Iter L m HttpReq +transfer_encoding_hdr :: (Monad m) => HttpReq s -> Iter L m (HttpReq s) transfer_encoding_hdr req = do tclist <- many tc return req { reqTransferEncoding = tclist } @@ -554,7 +559,7 @@ skipMany $ olws >> char ';' >> parameter return coding -if_modified_since_hdr :: (Monad m) => HttpReq -> Iter L m HttpReq +if_modified_since_hdr :: (Monad m) => HttpReq s -> Iter L m (HttpReq s) if_modified_since_hdr req = do modtime <- dateI return req { reqIfModifiedSince = Just modtime } @@ -568,7 +573,7 @@ crlf return (field, val) -any_hdr :: (Monad m) => HttpReq -> Iter L m HttpReq +any_hdr :: (Monad m) => HttpReq s -> Iter L m (HttpReq s) any_hdr req = do (field, val) <- hdr_field_val let req' = req { reqHeaders = (field, val) : reqHeaders req } @@ -581,7 +586,7 @@ return r -- | Parse an HTTP header, returning an 'HttpReq' data structure. -httpReqI :: Monad m => Iter L.ByteString m HttpReq +httpReqI :: Monad m => Iter L.ByteString m (HttpReq ()) httpReqI = do -- Section 4.1 of RFC 2616: "In the interest of robustness, servers -- SHOULD ignore any empty line(s) received where a Request-Line is @@ -629,7 +634,7 @@ -- beyond) and decodes the Transfer-Encoding. It handles straight -- content of a size specified by the Content-Length header and -- chunk-encoded content. -inumHttpBody :: (Monad m) => HttpReq -> Inum L.ByteString L.ByteString m a +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"] -> @@ -727,7 +732,7 @@ -- called from within an 'inumHttpBody' enumerator (which is -- guaranteed by 'inumHttpServer'). foldForm :: (Monad m) => - HttpReq + HttpReq s -> (a -> FormField -> Iter L.ByteString m a) -> a -> Iter L.ByteString m a @@ -813,11 +818,11 @@ char '&' \/ return a $ \_ -> foldControls f a foldUrlencoded :: (Monad m) => - HttpReq -> (a -> FormField -> Iter L m a) -> a -> Iter L m a + HttpReq s -> (a -> FormField -> Iter L m a) -> a -> Iter L m a foldUrlencoded _req f z = foldControls f z foldQuery :: (Monad m) => - HttpReq -> (a -> FormField -> Iter L m a) -> a -> Iter L m a + HttpReq s -> (a -> FormField -> Iter L m a) -> a -> Iter L m a foldQuery req f z = inumPure (L.fromChunks [reqQuery req]) .| foldControls f z -- @@ -844,13 +849,13 @@ multipart :: S multipart = S8.pack "multipart/form-data" -reqBoundary :: HttpReq -> Maybe S +reqBoundary :: HttpReq s -> Maybe S reqBoundary req = case reqContentType req of Just (typ, parms) | typ == multipart -> lookup (S8.pack "boundary") parms _ -> Nothing -multipartI :: (Monad m) => HttpReq -> 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 +881,7 @@ , ffHeaders = cdhdr:hdrs } -inumMultipart :: (Monad m) => HttpReq -> Inum L L m a +inumMultipart :: (Monad m) => HttpReq s -> Inum L L m a inumMultipart req iter = flip mkInumM (iter <* nullI) $ do b <- bstr ipipe $ inumStopString b @@ -887,7 +892,7 @@ Nothing -> throwParseI "inumMultipart: no parts" foldMultipart :: (Monad m) => - HttpReq -> (a -> FormField -> Iter L m a) -> a -> Iter L m a + HttpReq s -> (a -> FormField -> Iter L m a) -> a -> Iter L m a foldMultipart req f z = multipartI req >>= doPart where doPart Nothing = return z @@ -1073,7 +1078,7 @@ , L8.pack "\">here.

\n"] -- | Generate a 403 (forbidden) response. -resp403 :: (Monad m) => HttpReq -> HttpResp m +resp403 :: (Monad m) => HttpReq s -> HttpResp m resp403 req = mkHtmlResp stat403 html where html = L8.concat [L8.pack @@ -1088,7 +1093,7 @@ \\n"] -- | Generate a 404 (not found) response. -resp404 :: (Monad m) => HttpReq -> HttpResp m +resp404 :: (Monad m) => HttpReq s -> HttpResp m resp404 req = mkHtmlResp stat404 html where html = L8.concat [L8.pack @@ -1103,7 +1108,7 @@ \\n"] -- | Generate a 405 (method not allowed) response. -resp405 :: (Monad m) => HttpReq -> HttpResp m +resp405 :: (Monad m) => HttpReq s -> HttpResp m resp405 req = mkHtmlResp stat405 html where html = L8.concat [L8.pack @@ -1152,19 +1157,19 @@ -- | Given the headers of an HTTP request, provides an iteratee that -- will process the request body (if any) and return a response. -type HttpRequestHandler m = HttpReq -> Iter L.ByteString m (HttpResp m) +type HttpRequestHandler m s = HttpReq s -> Iter L.ByteString m (HttpResp m) -- | Data structure describing the configuration of an HTTP server for -- 'inumHttpServer'. data HttpServerConf m = HttpServerConf { srvLogger :: !(String -> Iter L.ByteString m ()) , srvDate :: !(Iter L.ByteString m (Maybe UTCTime)) - , srvHandler :: !(HttpRequestHandler m) + , srvHandler :: !(HttpRequestHandler m ()) } -- | Generate a null 'HttpServerConf' structure with no logging and no -- Date header. -nullHttpServer :: (Monad m) => HttpRequestHandler m -> HttpServerConf m +nullHttpServer :: (Monad m) => HttpRequestHandler m () -> HttpServerConf m nullHttpServer handler = HttpServerConf { srvLogger = const $ return () , srvDate = return Nothing @@ -1173,7 +1178,7 @@ -- | Generate an 'HttpServerConf' structure that uses IO calls to log to -- standard error and get the current time for the Date header. -ioHttpServer :: (MonadIO m) => HttpRequestHandler m -> HttpServerConf m +ioHttpServer :: (MonadIO m) => HttpRequestHandler m () -> HttpServerConf m ioHttpServer handler = HttpServerConf { srvLogger = liftIO . hPutStrLn stderr , srvDate = liftIO $ Just `liftM` getCurrentTime diff --git a/Data/IterIO/HttpRoute.hs b/Data/IterIO/HttpRoute.hs --- a/Data/IterIO/HttpRoute.hs +++ b/Data/IterIO/HttpRoute.hs @@ -4,7 +4,7 @@ , runHttpRoute, addHeader , routeConst, routeFn, routeReq , routeMethod, routeHost, routeTop - , HttpMap, routeMap, routeMap', routeName, routePath, routeVar + , HttpMap, routeMap, routeAlwaysMap, routeName, routePath, routeVar , mimeTypesI, dirRedir, routeFileSys, FileSystemCalls(..), routeGenFileSys ) where @@ -64,19 +64,19 @@ -- be served out of the file system under the @\"\/var\/www\/htdocs\"@ -- directory. (This example assumes @mimeMap@ has been constructed as -- discussed for 'mimeTypesI'.) -newtype HttpRoute m = - HttpRoute (HttpReq -> Maybe (Iter L.ByteString m (HttpResp m))) +newtype HttpRoute m s = + HttpRoute (HttpReq s -> Maybe (Iter L.ByteString m (HttpResp m))) runHttpRoute :: (Monad m) => - HttpRoute m -> HttpReq -> Iter L.ByteString m (HttpResp m) + HttpRoute m s -> HttpReq s -> Iter L.ByteString m (HttpResp m) runHttpRoute (HttpRoute route) rq = fromMaybe (return $ resp404 rq) $ route rq -instance Monoid (HttpRoute m) where +instance Monoid (HttpRoute m s) where mempty = HttpRoute $ const Nothing mappend (HttpRoute a) (HttpRoute b) = HttpRoute $ \req -> a req `mplus` b req -popPath :: Bool -> HttpReq -> HttpReq +popPath :: Bool -> HttpReq s -> HttpReq s popPath isParm req = case reqPathLst req of h:t -> req { reqPathLst = t @@ -94,19 +94,19 @@ -- addHeader ('S8.pack' \"Cache-control: max-age=3600\") $ -- 'routeFileSys' mime ('dirRedir' \"index.html\") \"\/var\/www\/htdocs\" -- @ -addHeader :: (Monad m) => S8.ByteString -> HttpRoute m -> HttpRoute m +addHeader :: (Monad m) => 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 } -- | Route all requests to a constant response action that does not -- depend on the request. This route always succeeds, so anything -- 'mappend'ed will never be used. -routeConst :: (Monad m) => HttpResp m -> HttpRoute m +routeConst :: (Monad m) => HttpResp m -> HttpRoute m s routeConst resp = HttpRoute $ const $ Just $ return resp -- | Route all requests to a particular function. This route always -- succeeds, so anything 'mappend'ed will never be used. -routeFn :: (HttpReq -> Iter L.ByteString m (HttpResp m)) -> HttpRoute m +routeFn :: (HttpReq s -> Iter L.ByteString m (HttpResp m)) -> HttpRoute m s routeFn fn = HttpRoute $ Just . fn -- | Select a route based on some arbitrary function of the request. @@ -131,14 +131,14 @@ -- to rest of myRoute -} -- _ -> 'routeConst' $ 'resp405' req {- reject request -} -- @ -routeReq :: (HttpReq -> HttpRoute m) -> HttpRoute m +routeReq :: (HttpReq s -> HttpRoute m s) -> HttpRoute m s routeReq fn = HttpRoute $ \req -> let (HttpRoute route) = fn req in route req -- | Route the root directory (/). -routeTop :: HttpRoute m -> HttpRoute m +routeTop :: HttpRoute m s -> HttpRoute m s routeTop (HttpRoute route) = HttpRoute $ \req -> if null $ reqPathLst req then route req else Nothing @@ -146,8 +146,8 @@ -- | Route requests whose \"Host:\" header matches a particular -- string. routeHost :: String -- ^ String to compare against host (must be lower-case) - -> HttpRoute m -- ^ Target route to follow if host matches - -> HttpRoute m + -> HttpRoute m s -- ^ Target route to follow if host matches + -> HttpRoute m s routeHost host (HttpRoute route) = HttpRoute check where shost = S8.pack $ map toLower host check req | reqHost req /= shost = Nothing @@ -155,30 +155,22 @@ -- | Route based on the method (GET, POST, HEAD, etc.) in a request. routeMethod :: String -- ^ String method should match - -> HttpRoute m -- ^ Target route to take if method matches - -> HttpRoute m + -> HttpRoute m s -- ^ Target route to take if method matches + -> HttpRoute m s routeMethod method (HttpRoute route) = HttpRoute check where smethod = S8.pack method check req | reqMethod req /= smethod = Nothing | otherwise = route req -- | Type alias for the argument of 'routeMap'. -type HttpMap m = [(String, HttpRoute m)] +type HttpMap m s = [(String, HttpRoute m s)] -- | @routeMap@ builds an efficient map out of a list of --- @(directory_name, 'HttpRoute')@ pairs. It matches all requests and --- returns a 404 error if there is a request for a name not present in --- the map. -routeMap :: (Monad m) => HttpMap m -> HttpRoute m -routeMap lst = routeMap' lst `mappend` routeFn (return . resp404) - --- | @routeMap'@ is like @routeMap@, but only matches names that exist --- in the map. Thus, multiple @routeMap'@ results can be combined --- with 'mappend'. By contrast, combining @routeMap@ results with --- 'mappend' is useless--the first one will match all requests (and --- return a 404 error for names that do not appear in the map). -routeMap' :: HttpMap m -> HttpRoute m -routeMap' lst = HttpRoute check +-- @(directory_name, 'HttpRoute')@ pairs. If a name is not in the +-- map, the request is not matched. Note that only the next directory +-- component in the URL is matched. +routeMap :: HttpMap m s -> HttpRoute m s +routeMap lst = HttpRoute check where check req = case reqPathLst req of h:_ -> maybe Nothing @@ -189,9 +181,14 @@ rmap = Map.fromListWithKey nocombine $ map packfirst lst nocombine k _ _ = error $ "routeMap: duplicate key for " ++ S8.unpack k +-- | @routeAlwaysMap@ is like @routeMap@, but matches all requests and +-- returns a 404 error for names that do not appear in the map. +routeAlwaysMap :: (Monad m) => HttpMap m s -> HttpRoute m s +routeAlwaysMap lst = routeMap lst `mappend` routeFn (return . resp404) + -- | Routes a specific directory name, like 'routeMap' for a singleton -- map. -routeName :: String -> HttpRoute m -> HttpRoute m +routeName :: String -> HttpRoute m s -> HttpRoute m s routeName name (HttpRoute route) = HttpRoute check where sname = S8.pack name headok (h:_) | h == sname = True @@ -201,7 +198,7 @@ -- | Routes a specific path, like 'routeName', except that the path -- can include several directories. -routePath :: String -> HttpRoute m -> HttpRoute m +routePath :: String -> HttpRoute m s -> HttpRoute m s routePath path route = foldr routeName route dirs where dirs = case splitDirectories path of "/":t -> t @@ -211,7 +208,7 @@ -- front of the 'reqPathParams' list in the 'HttpReq' structure. This -- allows the name to serve as a variable argument to the eventual -- handling function. -routeVar :: HttpRoute m -> HttpRoute m +routeVar :: HttpRoute m s -> HttpRoute m s routeVar (HttpRoute route) = HttpRoute check where check req = case reqPathLst req of _:_ -> route $ popPath True req @@ -293,7 +290,7 @@ -- | @dirRedir indexFileName@ redirects requests to the URL formed by -- appending @\"/\" ++ indexFileName@ to the requested URL. -dirRedir :: (Monad m) => FilePath -> FilePath -> HttpRoute m +dirRedir :: (Monad m) => FilePath -> FilePath -> HttpRoute m s dirRedir index _path = routeFn $ \req -> return $ resp301 $ S8.unpack (reqNormalPath req) ++ '/':index @@ -307,7 +304,7 @@ routeFileSys :: (MonadIO m) => (String -> S8.ByteString) -- ^ Map of file suffixes to mime types (see 'mimeTypesI') - -> (FilePath -> HttpRoute m) + -> (FilePath -> HttpRoute m s) -- ^ Handler to invoke when the URL maps to a directory -- in the file system. Reasonable options include: -- @@ -322,7 +319,7 @@ -- request directly to an index file. -> FilePath -- ^ Pathname of directory to serve from file system - -> HttpRoute m + -> HttpRoute m s routeFileSys = routeGenFileSys defaultFileSystemCalls -- | A generalized version of 'routeFileSys' that takes a @@ -332,9 +329,9 @@ routeGenFileSys :: (Monad m) => FileSystemCalls h m -> (String -> S8.ByteString) - -> (FilePath -> HttpRoute m) + -> (FilePath -> HttpRoute m s) -> FilePath - -> HttpRoute m + -> HttpRoute m s routeGenFileSys fs typemap index dir0 = HttpRoute $ Just . check where dir = if null dir0 then "." else dir0 diff --git a/Data/IterIO/Inum.hs b/Data/IterIO/Inum.hs --- a/Data/IterIO/Inum.hs +++ b/Data/IterIO/Inum.hs @@ -91,7 +91,12 @@ -- 'mkInumM' functions, which hide most of the error handling details -- and ensure the above rules are obeyed. Most @Inum@s are -- polymorphic in the last type, @a@, in order to work with iteratees --- returning any type. +-- returning any type. There isn't much reason for an @Inum@ to care +-- about the type @a@. Had this module used the Rank2Types Haskell +-- extension, it would define @Inum@ as: +-- +-- > type Inum tIn tOut m = forall a. Iter tOut m a +-- > -> Iter tIn m (IterR tOut m a) type Inum tIn tOut m a = Iter tOut m a -> Iter tIn m (IterR tOut m a) -- | An @Onum t m a@ is just an 'Inum' in which the input is @@ -493,7 +498,7 @@ -> CtlHandler (Iter tIn mIn) t m a -> CtlHandler (Iter tIn mIn) t m a consCtl fn fallback ca@(CtlArg a0 n c) = maybe (fallback ca) runfn $ cast a0 - where runfn a = fn a (n . fromJust . cast) c + where runfn a = fn a (n . CtlDone . fromJust . cast) c `catchI` \e _ -> return $ runIter (n $ CtlFail e) c infixr 9 `consCtl` @@ -575,12 +580,22 @@ -- | Create a stateless 'Inum' from a \"codec\" 'Iter' that transcodes -- the input type to the output type. The codec is invoked repeately --- until one of the following occurs: The codec returns 'null' data, --- the codec throws an exception, or the underlying target 'Iter' is --- no longer active. If the codec throws an exception of type --- 'IterEOF', this is considered normal termination and the error is --- not further propagated. +-- until one of the following occurs: -- +-- 1. The input is at an EOF marker AND the codec returns 'null' +-- data. ('Onum's are always fed EOF, but other 'Inum's might +-- have reason to return 'mempty' data.) +-- +-- 2. The codec throws an exception. If the exception is an EOF +-- exception--thrown either by 'throwEOFI', or by some IO action +-- inside 'liftIO'--this is considered normal termination, and is +-- the normal way for a codec to cause the 'Inum' to return. If +-- the exception is of any other type, then the 'Inum' will +-- further propagate the exception as an 'Inum' failure. +-- +-- 3. The underlying target 'Iter' either returns a result or throws +-- an exception. +-- -- @mkInumC@ requires two other arguments before the codec. First, a -- 'ResidHandler' allows residual data to be adjusted between the -- input and output 'Iter' monads. Second, a 'CtlHandler' specifies a @@ -606,8 +621,9 @@ doIter iter = tryEOFI codec >>= maybe (return $ IterF iter) (doInput iter) doInput iter input = do r <- runIterMC ch iter (Chunk input False) + eof <- Iter $ \c@(Chunk t eof) -> Done (eof && null t) c case r of - (IterF i) | not (null input) -> doIter i + (IterF i) | not (eof && null input) -> doIter i _ | isIterActive r -> return r _ -> withResidHandler adj (getResid r) $ return . setResid r diff --git a/Data/IterIO/Iter.hs b/Data/IterIO/Iter.hs --- a/Data/IterIO/Iter.hs +++ b/Data/IterIO/Iter.hs @@ -16,13 +16,13 @@ , IterCUnsupp(..) -- * Exception-related functions , throwI, throwEOFI, throwParseI - , catchI, tryI, tryFI, tryRI, tryEOFI + , catchI, catchPI, tryI, tryFI, tryRI, tryEOFI , finallyI, onExceptionI , tryBI, tryFBI , ifParse, ifNoParse, multiParse -- * Some basic Iters , nullI, data0I, dataI, pureI, chunkI - , whileNullI, peekI, atEOFI, ungetI + , someI, whileNullI, peekI, atEOFI, ungetI , safeCtlI, ctlI -- * Internal functions , onDone, fmapI @@ -564,6 +564,18 @@ {-# INLINE catchI #-} catchI iter handler = genCatchI iter handler id +-- | Like catchI, but catches only what are considered to be parse +-- errors--that is, every constructor of 'IterFail' except +-- 'IterException'. +catchPI :: (ChunkData t, Monad m) => + Iter t m a + -> (IterFail -> Iter t m a) + -> Iter t m a +catchPI iter handler = tryRI iter >>= either failed return + where failed r@(Fail (IterException _) _ _) = reRunIter r + failed (Fail ifail _ _) = handler ifail + failed _ = error "catchPI" + -- | If an 'Iter' succeeds and returns @a@, returns @'Right' a@. If -- the 'Iter' fails and throws an exception @e@ (of type @e@), returns -- @'Left' (e, r)@ where @r@ is the state of the failing 'Iter'. @@ -762,8 +774,8 @@ -- use: -- -- @ --- total = parseAndSumIntegerList ``catchI`` handler --- where handler \('IterNoParse' _) _ = return -1 +-- total = parseAndSumIntegerList ``catchPI`` handler +-- where handler _ = return -1 -- @ -- -- This last definition of @total@ may leave the input in some @@ -856,6 +868,21 @@ chunkI :: (Monad m, ChunkData t) => Iter t m (Chunk t) {-# INLINE chunkI #-} chunkI = iterF $ \c@(Chunk _ eof) -> Done c (Chunk mempty eof) + +-- | Run an 'Iter' returning data of class 'ChunkData' and throw an +-- EOF exception if the data is 'null'. (Note that this is different +-- from the @'some'@ method of the @'Alternative'@ class in +-- "Control.Applicative", which executes a computation one /or more/ +-- times. The iterIO library does not use @'Alternative'@, in part +-- because @`Alternative`@'s @\<|\>@ operator has left rather than +-- right fixity, which would make parsing less efficient. See +-- "Data.IterIO.Parse" for information about iterIO's @\<|\>@ +-- operator.) +someI :: (ChunkData tOut, Monad m) => + Iter tIn m tOut -> Iter tIn m tOut +someI = (>>= check) + where check tOut | null tOut = throwEOFI "someI" + | otherwise = return tOut -- | Keep running an 'Iter' until either its output is not 'null' or -- we have reached EOF. Return the the `Iter`'s value on the last diff --git a/Data/IterIO/ListLike.hs b/Data/IterIO/ListLike.hs --- a/Data/IterIO/ListLike.hs +++ b/Data/IterIO/ListLike.hs @@ -472,7 +472,9 @@ -- reading) and an 'Iter' (for writing). Uses 'pairFinalizer' to -- 'hClose' the 'Handle' when both the 'Iter' and 'Onum' are finished. -- Puts the handle into binary mode, but does not change the --- buffering. +-- buffering. As mentioned for 'handleI', Haskell's default buffering +-- can cause problems for many network protocols. Hence, you may wish +-- to call @'hSetBuffering' h 'NoBuffering'@ before @iterHandle h@. iterHandle :: (LL.ListLikeIO t e, ChunkData t, MonadIO m) => Handle -> IO (Iter t m (), Onum t m a) iterHandle h = do diff --git a/Data/IterIO/Parse.hs b/Data/IterIO/Parse.hs --- a/Data/IterIO/Parse.hs +++ b/Data/IterIO/Parse.hs @@ -5,7 +5,7 @@ module Data.IterIO.Parse (-- * Iteratee combinators (<|>), (\/), orEmpty, (), expectedI - , someI, foldrI, foldr1I, foldrMinMaxI + , foldrI, foldr1I, foldrMinMaxI , foldlI, foldl1I, foldMI, foldM1I , skipI, optionalI, ensureI , eord @@ -187,18 +187,6 @@ -> Iter t m a expectedI saw target = Iter $ \_ -> Fail (IterExpected [(saw, target)]) Nothing Nothing - --- | Takes an 'Iter' returning a 'LL.ListLike' type, executes the --- 'Iter' once, and throws a parse error if the returned value is --- 'LL.null'. (Note that this is quite different from the @'some'@ --- method of the @'Alternative'@ class in "Control.Applicative", which --- executes a computation one /or more/ times. This library does not --- use @'Alternative'@ because @`Alternative`@'s @\<|\>@ operator has --- left instead of right fixity.) -someI :: (ChunkData t, Monad m, LL.ListLike a e) => Iter t m a -> Iter t m a -someI iter = ( "someI") $ do - a <- iter - if LL.null a then mzero else return a -- | Repeatedly invoke an 'Iter' and right-fold a function over the -- results. diff --git a/Data/IterIO/SSL.hs b/Data/IterIO/SSL.hs --- a/Data/IterIO/SSL.hs +++ b/Data/IterIO/SSL.hs @@ -33,7 +33,7 @@ enumSsl :: (MonadIO m) => SSL.SSL -> Onum L.ByteString m a enumSsl ssl = mkInumC id ch codec where ch = mkCtl (\SslC -> return $ SslConnection ssl) - `consCtl` (socketCtl $ SSL.sslSocket ssl) + `consCtl` (maybe noCtl socketCtl $ SSL.sslSocket ssl) codec = do buf <- liftIO (SSL.read ssl L.defaultChunkSize) if S.null buf then return L.empty diff --git a/Data/IterIO/Search.hs b/Data/IterIO/Search.hs --- a/Data/IterIO/Search.hs +++ b/Data/IterIO/Search.hs @@ -60,9 +60,11 @@ where (ltmap, ma, _) = Map.splitLookup t mp (k, v) = Map.findMax ltmap + kIsGood = not (Map.null ltmap) && k `LL.isPrefixOf` t p = longestCommonPrefix k t ckprefix | Map.null mp || LL.null t = Nothing - | k `LL.isPrefixOf` t = Just (k, v) + -- XXX LL.null t case above is redundant, maybe remove? + | kIsGood = Just (k, v) | otherwise = findLongestPrefix ltmap p -- | Reads input until it can uniquely determine the longest key in a diff --git a/Examples/fgrep.hs b/Examples/fgrep.hs --- a/Examples/fgrep.hs +++ b/Examples/fgrep.hs @@ -19,7 +19,7 @@ filterLines s = mkInum loop where loop = do line <- lineI - if match line then return [line] else loop + if match line then return [line] else return [] ls = L8.pack s match l | L.null l = False | otherwise = L.isPrefixOf ls l || match (L.tail l) diff --git a/Examples/httptest.hs b/Examples/httptest.hs --- a/Examples/httptest.hs +++ b/Examples/httptest.hs @@ -60,16 +60,16 @@ if exist then return h else findMimeTypes t findMimeTypes [] = return "mime.types" -- cause error -routeFS :: (MonadIO m) => FilePath -> HttpRoute m +routeFS :: (MonadIO m) => FilePath -> HttpRoute m s routeFS = routeFileSys mimeMap (dirRedir "index.html") cabal_dir :: String cabal_dir = (unsafePerformIO $ getAppUserDataDirectory "cabal") ++ "/share/doc" -route :: (MonadIO m) => HttpRoute m +route :: (MonadIO m) => HttpRoute m () route = mconcat [ routeTop $ routeConst $ resp301 "/cabal" - , routeMap' [ ("cabal", routeConst $ resp301 cabal_dir) + , routeMap [ ("cabal", routeConst $ resp301 cabal_dir) , ("static", routeFS "static") -- directory ./static , ("favicon.ico" -- serve /favicon.ico from file ./static/favicon.ico, diff --git a/NEWS b/NEWS new file mode 100644 --- /dev/null +++ b/NEWS @@ -0,0 +1,16 @@ + +* Changes in release 0.2 + +Updated to compile with HsOpenSSL 0.10.1, which has incompatible +sslSocket function. + +A few bugs were fixed, including one in ctlCons, and another in HTTP +cookie parsing. + +The HTTPReq type is now parameterized by session state. + +mkInumC (and mkInum, mkInumP) no longer consider a null codec result +to terminate the 'Inum' unless the input is at an EOF condition. This +allows inums to propagate mempty Chunks inwards, which could +conceivably be useful for situations in which inumNull lets an Iter +call liftIO to unblock an enclosing Onum. diff --git a/iterIO.cabal b/iterIO.cabal --- a/iterIO.cabal +++ b/iterIO.cabal @@ -1,6 +1,6 @@ Name: iterIO Homepage: http://www.scs.stanford.edu/~dm/iterIO -Version: 0.1 +Version: 0.2 Cabal-version: >= 1.6 build-type: Simple License: BSD3 @@ -11,7 +11,7 @@ Category: System, Data, Enumerator Synopsis: Iteratee-based IO with pipe operators Extra-source-files: - GNUmakefile, README, + GNUmakefile, README, NEWS, Examples/fgrep.hs, Examples/zpipe.hs, Examples/httptest.hs Description: @@ -64,7 +64,7 @@ bytestring >= 0.9 && < 2, containers >= 0.3 && < 2, filepath >= 1.2 && < 2, - HsOpenSSL >= 0.8 && < 2, + HsOpenSSL >= 0.10.1 && < 2, ListLike >= 1.0 && < 4, mtl >= 1.1.0.2 && < 3, network >= 2.3 && < 3,