The document has moved here.
\n"] + +-- | Generate a 303 (see other) response. +resp303 :: (Monad m) => String -> HttpResp m +resp303 target = + respAddHeader (S8.pack $ "Location: " ++ target) $ mkHtmlResp stat303 html + where html = L8.concat + [L8.pack + "\n\ + \\n\ + \The document has moved here.
\n"] + +-- | Generate a 403 (forbidden) response. +resp403 :: (Monad m) => HttpReq -> HttpResp m +resp403 req = mkHtmlResp stat403 html + where html = L8.concat + [L8.pack + "\n\ + \\n\ + \You don't have permission to access " + , htmlEscape $ S8.unpack (reqNormalPath req) + , L8.pack " on this server.
\n\ + \\n"] + +-- | Generate a 404 (not found) response. +resp404 :: (Monad m) => HttpReq -> HttpResp m +resp404 req = mkHtmlResp stat404 html + where html = L8.concat + [L8.pack + "\n\ + \\n\ + \The requested URL " + , htmlEscape $ S8.unpack (reqNormalPath req) + , L8.pack " was not found on this server.
\n\ + \\n"] + +-- | Generate a 405 (method not allowed) response. +resp405 :: (Monad m) => HttpReq -> HttpResp m +resp405 req = mkHtmlResp stat405 html + where html = L8.concat + [L8.pack + "\n\ + \\n\ + \The requested method " + , L.fromChunks [reqMethod req] + , L8.pack " is not allowed for the URL " + , htmlEscape $ S8.unpack (reqNormalPath req) + , L8.pack ".
\n\ + \\n"] + +-- | Generate a 500 (internal server error) response. +resp500 :: (Monad m) => String -> HttpResp m +resp500 msg = mkHtmlResp stat500 html + where html = L8.concat + [L8.pack + "\n\ + \\n\ + \" + , htmlEscape msg + , L8.pack "
\n\n"] + +-- | 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) + 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"] + maybeChunk = if respChunk resp then inumToChunks else inumNop + +-- | 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) + +-- | 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) + } + +-- | Generate a null 'HttpServerConf' structure with no logging and no +-- Date header. +nullHttpServer :: (Monad m) => HttpRequestHandler m -> HttpServerConf m +nullHttpServer handler = HttpServerConf { + srvLogger = const $ return () + , srvDate = return Nothing + , srvHandler = handler + } + +-- | 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 handler = HttpServerConf { + srvLogger = liftIO . hPutStrLn stderr + , srvDate = liftIO $ Just `liftM` getCurrentTime + , srvHandler = handler + } + +-- | An 'Inum' that behaves like an HTTP server. The file +-- @Examples/httptest.hs@ that comes with the iterIO distribution +-- gives an example of how to use this function. +inumHttpServer :: (Monad m) => + HttpServerConf m -- ^ Server configuration + -> Inum L.ByteString L.ByteString m () +inumHttpServer server = mkInumM loop + where + loop = do + eof <- atEOFI + unless eof doreq + doreq = do + req <- httpReqI + let handler = srvHandler server req + resp <- liftI $ inumHttpBody req .| + (catchI handler errHandler <* nullI) + now <- liftI $ srvDate server + tryI (irun $ enumHttpResp resp now) >>= + either (fatal . fst) (const loop) + errHandler e@(SomeException _) _ = do + srvLogger server $ "Response error: " ++ show e + return $ resp500 $ show e + fatal e@(SomeException _) = do + liftI $ srvLogger server $ "Reply error: " ++ show e + return () + + +{- + +-- +-- Everything below here is crap for testing +-- + +formTest :: L -> IO () +formTest b = inumPure b |$ handleReq + where + handleReq = do + req <- httpReqI + parts <- foldForm req getPart [] + liftIO $ putStrLn $ "### Summary\n" ++ show parts + getPart result mp = do + liftIO $ do putStrLn $ "### Part " ++ show (length result); print mp; putStrLn "" + stdoutI + liftIO $ putStr "\n\n" + return (mp:result) + +formTestMultipart :: IO () +formTestMultipart = formTest postReq + +formTestUrlencoded :: IO () +formTestUrlencoded = formTest postReqUrlencoded + +{- +dumpCtl :: () -> Multipart -> Iter L IO () +dumpCtl () mp = do + liftIO $ S.putStr (ffName mp) >> putStrLn ":" + stdoutI + liftIO $ putStrLn "\n" + +x :: L +x = L8.pack "p1=v1&p2=v2" +-} + +mptest :: IO () +mptest = inumPure postReq |$ (httpReqI >>= getHead) + where + getHead req = do + mmp <- multipartI req + case mmp of + Nothing -> return () + Just mp -> do liftIO $ print mp + (inumMultipart req ) .| stdoutI + (inumMultipart req ) .| nullI + (inumMultipart req ) .| nullI + (inumMultipart req ) .| nullI + (inumMultipart req ) .| nullI + crlf + liftIO $ putStr "\n\n" + getHead req + +mptest' :: IO () +mptest' = inumPure postReq |$ (httpReqI >>= getParts 0) + where + getParts :: (MonadIO m) => Integer -> HttpReq -> Iter L m () + getParts n req = do + mmp <- multipartI req + case mmp of + Nothing -> return () + Just mp -> do liftIO $ do + putStrLn $ "### Part " ++ show n + print mp + putStrLn "" + (inumMultipart req) .| stdoutI + liftIO $ putStr "\n\n" + getParts (n+1) req + + +postReq :: L +postReq = L8.pack + "POST /testSubmit HTTP/1.1\n\ + \Host: localhost:8000\n\ + \User-Agent: Mozilla/5.0 (X11; U; Linux i686 (x86_64); en-US; rv:1.9.2.8) Gecko/20100722 Firefox/3.6.8\n\ + \Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8\n\ + \Accept-Language: en-us,en;q=0.5\n\ + \Accept-Encoding: gzip,deflate\n\ + \Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7\n\ + \Keep-Alive: 115\n\ + \Connection: keep-alive\n\ + \Content-Type: multipart/form-data; boundary=---------------------------28986267117678495841915281966\n\ + \Content-Length: 561\n\ + \\n\ + \-----------------------------28986267117678495841915281966\n\ + \Content-Disposition: form-data; name=\"justatestkey\"\n\ + \\n\ + \nothing\r\n\ + \-----------------------------28986267117678495841915281966\n\ + \Content-Disposition: form-data; name=\"hate\"\n\ + \\n\ + \666\r\n\ + \-----------------------------28986267117678495841915281966\n\ + \Content-Disposition: form-data; name=\"file1\"; filename=\"x\"\n\ + \Content-Type: application/octet-stream\n\ + \\n\ + \search scs.stanford.edu uun.org\n\ + \nameserver 127.0.0.1\n\ + \nameserver 64.81.79.2\n\ + \nameserver 216.231.41.2\n\ + \\r\n\ + \-----------------------------28986267117678495841915281966--\n" + +postReqUrlencoded :: L +postReqUrlencoded = L8.pack + "POST /testSubmit HTTP/1.1\n\ + \Host: localhost:8000\n\ + \User-Agent: Mozilla/5.0 (X11; U; Linux i686 (x86_64); en-US; rv:1.9.2.8) Gecko/20100722 Firefox/3.6.8\n\ + \Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8\n\ + \Accept-Language: en-us,en;q=0.5\n\ + \Accept-Encoding: gzip,deflate\n\ + \Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7\n\ + \Keep-Alive: 115\n\ + \Connection: keep-alive\n\ + \Content-Type: application/x-www-form-urlencoded\n\ + \Content-Length: 11\n\ + \\n\ + \p1=v1&p2=v2" + + +encReq :: L +encReq = L8.pack "justatestkey=nothing&hate=666&file1=mtab" + +-} diff --git a/Data/IterIO/HttpRoute.hs b/Data/IterIO/HttpRoute.hs new file mode 100644 --- /dev/null +++ b/Data/IterIO/HttpRoute.hs @@ -0,0 +1,380 @@ + +module Data.IterIO.HttpRoute + (HttpRoute(..) + , runHttpRoute, addHeader + , routeConst, routeFn, routeReq + , routeMethod, routeHost, routeTop + , HttpMap, routeMap, routeMap', routeName, routePath, routeVar + , mimeTypesI, dirRedir, routeFileSys, FileSystemCalls(..), routeGenFileSys + ) where + +import Control.Monad +import Control.Monad.Trans +import Data.Char (toLower) +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import qualified Data.Map as Map +import Data.Maybe +import Data.Monoid +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import System.FilePath +import System.IO +import System.IO.Error (isDoesNotExistError) +import System.Posix.Files +import System.Posix.IO +import System.Posix.Types + +import Data.IterIO +import Data.IterIO.Http +import Data.IterIO.Parse + +-- +-- Request routing +-- + +-- | Simple HTTP request routing structure for 'inumHttpServer'. This +-- is a wrapper around a function on 'HttpReq' structures. If the +-- function accepts the 'HttpReq', it returns 'Just' a response +-- action. Otherwise it returns 'Nothing'. +-- +-- @HttpRoute@ is a 'Monoid', and hence can be concatenated with +-- 'mappend' or 'mconcat'. For example, you can say something like: +-- +-- > simpleServer :: Iter L.ByteString IO () -- Output to web browser +-- > -> Onum L.ByteString IO () -- Input from web browser +-- > -> IO () +-- > simpleServer iter enum = enum |$ inumHttpServer server .| iter +-- > where htdocs = "/var/www/htdocs" +-- > server = ioHttpServer $ runHttpRoute routing +-- > routing = mconcat [ routeTop $ routeConst $ resp301 "/start.html" +-- > , routeName "apps" $ routeMap apps +-- > , routeFileSys mimeMap "index.html" htdocs +-- > ] +-- > apps = [ ("app1", routeFn app1) +-- > , ("app2", routeFn app2) ] +-- > +-- > app1 :: (Monad m) => HttpReq -> Iter L.ByteString m (HttpResp m) +-- > app1 = ... +-- +-- The above function will redirect requests for @/@ to the URL +-- @/start.html@ using an HTTP 301 (Moved Permanently) response. Any +-- request for a path under @/apps/@ will be redirected to the +-- functions @app1@, @app2@, etc. Finally, any other file name will +-- 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))) + +runHttpRoute :: (Monad m) => + HttpRoute m -> HttpReq -> Iter L.ByteString m (HttpResp m) +runHttpRoute (HttpRoute route) rq = fromMaybe (return $ resp404 rq) $ route rq + +instance Monoid (HttpRoute m) where + mempty = HttpRoute $ const Nothing + mappend (HttpRoute a) (HttpRoute b) = + HttpRoute $ \req -> a req `mplus` b req + +popPath :: Bool -> HttpReq -> HttpReq +popPath isParm req = + case reqPathLst req of + h:t -> req { reqPathLst = t + , reqPathCtx = reqPathCtx req ++ [h] + , reqPathParams = if isParm then h : reqPathParams req + else reqPathParams req + } + _ -> error "Data.IterIO.Http.popPath: empty path" + +-- | Prepend a header field to the response produced by an 'HttpRoute' +-- if that 'HttpRoute' is successful. For example, to let clients +-- cache static data for an hour, you might use: +-- +-- @ +-- 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 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 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 fn = HttpRoute $ Just . fn + +-- | Select a route based on some arbitrary function of the request. +-- For most purposes, the existing predicates ('routeName', +-- 'routePath', etc.) should be fine, but occationally you might want +-- to define a custom predicate. For example, to reject methods other +-- then \"GET\" or \"POST\" at the top of your route, you could say: +-- +-- @ +-- myRoute = 'mconcat' [ rejectBadMethod +-- , otherRoute1 +-- , ... +-- ] +-- ... +-- +--rejectBadMethod :: 'HttpRoute' m +--rejectBadMethod = +-- routeReq $ \req -> +-- case 'reqMethod' req of +-- s | s == 'S8.pack' \"GET\" || s == 'S8.pack' \"PUT\" -> +-- 'mempty' {- reject route, falling through +-- to rest of myRoute -} +-- _ -> 'routeConst' $ 'resp405' req {- reject request -} +-- @ +routeReq :: (HttpReq -> HttpRoute m) -> HttpRoute m +routeReq fn = HttpRoute $ \req -> + let (HttpRoute route) = fn req + in route req + + +-- | Route the root directory (/). +routeTop :: HttpRoute m -> HttpRoute m +routeTop (HttpRoute route) = HttpRoute $ \req -> + if null $ reqPathLst req then route req + else Nothing + +-- | 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 +routeHost host (HttpRoute route) = HttpRoute check + where shost = S8.pack $ map toLower host + check req | reqHost req /= shost = Nothing + | otherwise = route req + +-- | 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 +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)] + +-- | @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 + where + check req = case reqPathLst req of + h:_ -> maybe Nothing + (\(HttpRoute route) -> route $ popPath False req) + (Map.lookup h rmap) + _ -> Nothing + packfirst (a, b) = (S8.pack a, b) + rmap = Map.fromListWithKey nocombine $ map packfirst lst + nocombine k _ _ = error $ "routeMap: duplicate key for " ++ S8.unpack k + +-- | Routes a specific directory name, like 'routeMap' for a singleton +-- map. +routeName :: String -> HttpRoute m -> HttpRoute m +routeName name (HttpRoute route) = HttpRoute check + where sname = S8.pack name + headok (h:_) | h == sname = True + headok _ = False + check req | headok (reqPathLst req) = route $ popPath False req + check _ = Nothing + +-- | Routes a specific path, like 'routeName', except that the path +-- can include several directories. +routePath :: String -> HttpRoute m -> HttpRoute m +routePath path route = foldr routeName route dirs + where dirs = case splitDirectories path of + "/":t -> t + t -> t + +-- | Matches any directory name, but additionally pushes it onto the +-- 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 route) = HttpRoute check + where check req = case reqPathLst req of + _:_ -> route $ popPath True req + _ -> Nothing + +-- +-- Routing to Filesystem +-- + +-- | 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 +-- defaults might be @\"text\/html\"@, @\"text\/plain\"@, or, more +-- pedantically but less usefully, @\"application\/octet-stream\"@.) +-- +-- Since this likely doesn't change, it is convenient just to define +-- it once in your program, for instance with something like: +-- +-- > mimeMap :: String -> S8.ByteString +-- > mimeMap = unsafePerformIO $ do +-- > path <- findMimeTypes ["mime.types" +-- > , "/etc/mime.types" +-- > , "/var/www/conf/mime.types"] +-- > enumFile path |$ mimeTypesI "application/octet-stream" +-- > where +-- > findMimeTypes (h:t) = do exist <- fileExist h +-- > if exist then return h else findMimeTypes t +-- > findMimeTypes [] = return "mime.types" -- cause error +mimeTypesI :: (Monad m) => + String + -> Iter S8.ByteString m (String -> S8.ByteString) +mimeTypesI deftype = do + mmap <- Map.fromList <$> concatI ((mimeLine <|> nil) <* eol) + return $ \suffix -> maybe (S8.pack deftype) id $ Map.lookup suffix mmap + where + mimeLine = do + typ <- word + many $ do space; ext <- word; return (S8.unpack ext, typ) + word = while1I $ \c -> c > eord ' ' && c <= eord '~' + space = skipWhile1I $ \c -> c == eord ' ' || c == eord '\t' + comment = char '#' >> skipWhileI (/= eord '\n') + eol = do + optionalI space + optionalI comment + optionalI (char '\r'); char '\n' + +-- | An abstract representation of file system calls returning an +-- opaque handle type @h@ in an 'Iter' parameterized by an arbitrary +-- 'Monad' @m@. This representation allows one to use +-- 'routeGenFileSys' in a monad that is not an instance of 'MonadIO'. +data FileSystemCalls h m = FileSystemCalls { + fs_stat :: !(FilePath -> Iter L.ByteString m FileStatus) + -- ^ Return file attributes. + , fs_open :: !(FilePath -> Iter L.ByteString m h) + -- ^ Open file and return an opaque handle of type @h@. + , fs_close :: !(h -> Iter L.ByteString m ()) + -- ^ Close an open file. You must call this unless you apply the + -- enumerator returned by @fs_enum@. + , fs_fstat :: !(h -> Iter L.ByteString m FileStatus) + -- ^ Return the attributes of an open file. + , fs_enum :: !(h -> Iter L.ByteString m + (Onum L.ByteString m (IterR L.ByteString m ()))) + -- ^ Enumerate the contents of an open file, then close the file. + -- If you apply the 'Onum' returned by @fs_enum@, you do not need + -- to call @fs_close@. + } + +-- | Default file system calls for instances of the @MonadIO@ class. +defaultFileSystemCalls :: (MonadIO m) => FileSystemCalls Fd m +defaultFileSystemCalls = FileSystemCalls { fs_stat = liftIO . getFileStatus + , fs_open = liftIO . pathToFd + , fs_close = liftIO . closeFd + , fs_fstat = liftIO . getFdStatus + , fs_enum = liftIO . fdToOnum + } + where pathToFd path = openFd path ReadOnly Nothing defaultFileFlags + fdToOnum fd = do h <- fdToHandle fd + return $ enumHandle h `inumFinally` liftIO (hClose h) + +-- | @dirRedir indexFileName@ redirects requests to the URL formed by +-- appending @\"/\" ++ indexFileName@ to the requested URL. +dirRedir :: (Monad m) => FilePath -> FilePath -> HttpRoute m +dirRedir index _path = routeFn $ \req -> return $ + resp301 $ S8.unpack (reqNormalPath req) ++ '/':index + +modTimeUTC :: FileStatus -> UTCTime +modTimeUTC = posixSecondsToUTCTime . realToFrac . modificationTime + +-- | Route a request to a directory tree in the file system. It gets +-- the Content-Length from the target file's attributes (after opening +-- the file). Thus, overwriting files on an active server could cause +-- problems, while renaming new files into place should be safe. +routeFileSys :: (MonadIO m) => + (String -> S8.ByteString) + -- ^ Map of file suffixes to mime types (see 'mimeTypesI') + -> (FilePath -> HttpRoute m) + -- ^ Handler to invoke when the URL maps to a directory + -- in the file system. Reasonable options include: + -- + -- * @('const' 'mempty')@ to do nothing, which results in a + -- 403 forbidden, + -- + -- * @('dirRedir' \"index.html\")@ to redirect directory + -- accesses to an index file, and + -- + -- * a recursive invocation such as @(routeFileSys + -- typemap . (++ \"/index.html\"))@ to re-route the + -- request directly to an index file. + -> FilePath + -- ^ Pathname of directory to serve from file system + -> HttpRoute m +routeFileSys = routeGenFileSys defaultFileSystemCalls + +-- | A generalized version of 'routeFileSys' that takes a +-- 'FileSystemCalls' object and can therefore work outside of the +-- 'MonadIO' monad. Other than the 'FileSystemCalls' object, the +-- arguments and their meaning are identical to 'routeFileSys'. +routeGenFileSys :: (Monad m) => + FileSystemCalls h m + -> (String -> S8.ByteString) + -> (FilePath -> HttpRoute m) + -> FilePath + -> HttpRoute m +routeGenFileSys fs typemap index dir0 = HttpRoute $ Just . check + where + dir = if null dir0 then "." else dir0 + checkErr req e _ | isDoesNotExistError e = return $ resp404 req + | otherwise = return $ resp500 (show e) + check req = flip catchI (checkErr req) $ do + let path = dir ++ concatMap (('/' :) . S8.unpack) (reqPathLst req) + st <- fs_stat fs path + case () of + _ | isRegularFile st -> doFile req path st + | not (isDirectory st) -> return $ resp404 req + | otherwise -> runHttpRoute + (index path `mappend` routeConst (resp403 req)) req + doFile req path st + | reqMethod req == S8.pack "GET" + && maybe True (< (modTimeUTC st)) (reqIfModifiedSince req) = do + fd <- fs_open fs path + -- Use attributes from opened file in case file name changes + st' <- fs_fstat fs fd `onExceptionI` fs_close fs fd + if isRegularFile st' + then do body <- fs_enum fs fd `onExceptionI` fs_close fs fd + return $ resp { respHeaders = mkHeaders req st' + , respBody = body } + else do fs_close fs fd -- File no longer file -- re-try + check req + | reqMethod req == S8.pack "GET" = + return $ resp { respStatus = stat304 } + | reqMethod req == S8.pack "HEAD" = + return $ resp { respStatus = stat200 } + | otherwise = return $ resp405 req + where resp = defaultHttpResp { respChunk = False + , 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) ] + fileExt req = + drop 1 $ takeExtension $ case reqPathLst req of + [] -> dir + l -> S8.unpack $ last l + + diff --git a/Data/IterIO/Inum.hs b/Data/IterIO/Inum.hs new file mode 100644 --- /dev/null +++ b/Data/IterIO/Inum.hs @@ -0,0 +1,1114 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Data.IterIO.Inum + (-- * Base types + Inum, Onum + -- * Concatenation and fusing operators + , (|$), (.|$), cat, lcat, (|.), (.|) + -- * Exception functions + , inumCatch, inumFinally, inumOnException + , resumeI, verboseResumeI + -- * Simple enumerator construction function + -- $mkInumIntro + , ResidHandler, CtlHandler + , mkInumC, mkInum, mkInumP + , inumBracket + -- * Utilities + , pullupResid + , noCtl, passCtl, consCtl, mkCtl, mkFlushCtl + , runIterM, runIterMC, runInum + -- * Some basic Inums + , inumNop, inumNull, inumPure, enumPure, inumRepeat + -- * Enumerator construction monad + -- $mkInumMIntro + , InumM, mkInumM, mkInumAutoM + , setCtlHandler, setAutoEOF, setAutoDone, addCleanup, withCleanup + , ifeed, ifeed1, ipipe, irun, irepeat, ipopresid, idone + ) where + +import Prelude hiding (null) +import Control.Exception (Exception(..)) +import Control.Monad +import Control.Monad.Trans +import Data.Maybe +import Data.Monoid +import Data.Typeable +import System.Environment (getProgName) +import System.IO + +import Data.IterIO.Iter +import Data.IterIO.Trans + +-- +-- Enumerator types +-- + +-- | The type of an /iterator-enumerator/, which transcodes data from +-- some input type @tIn@ to some output type @tOut@. An @Inum@ acts +-- as an 'Iter' when consuming data, then acts as an enumerator when +-- feeding transcoded data to another 'Iter'. +-- +-- At a high level, one can think of an @Inum@ as a function from +-- 'Iter's to 'IterR's, where an @Inum@'s input and output types are +-- different. A simpler-seeming alternative to @Inum@ might have +-- been: +-- +-- > type Inum' tIn tOut m a = Iter tOut m a -> Iter tIn m a +-- +-- In fact, given an @Inum@ object @inum@, it is possible to construct +-- a function of type @Inum'@ with @(inum '.|')@. But sometimes one +-- might like to concatenate @Inum@s. For instance, consider a +-- network protocol that changes encryption or compression modes +-- midstream. Transcoding is done by @Inum@s. To change transcoding +-- methods after applying an @Inum@ to an iteratee requires the +-- ability to \"pop\" the iteratee back out of the @Inum@ so as to be +-- able to hand it to another @Inum@. @Inum@'s return type (@Iter tIn +-- m (IterR tOut m a)@ as opposed to @Iter tIn m a@) allows the +-- monadic bind operator '>>=' to accomplish this popping in +-- conjunction with the 'tryRI' and 'reRunIter' functions. +-- +-- All @Inum@s must obey the following two rules. +-- +-- 1. /An/ @Inum@ /may never feed a chunk with the EOF flag set to/ +-- /it's target/ 'Iter'. Instead, upon receiving EOF, the @Inum@ +-- should simply return the state of the inner 'Iter' (this is how +-- \"popping\" the iteratee back out works--If the @Inum@ passed +-- the EOF through to the 'Iter', the 'Iter' would stop requesting +-- more input and could not be handed off to a new @Inum@). +-- +-- 2. /An/ @Inum@ /must always return the state of its target/ 'Iter'. +-- This is true even when the @Inum@ fails, and is why the 'Fail' +-- state contains a @'Maybe' a@ field. +-- +-- In addition to returning when it receives an EOF or fails, an +-- @Inum@ should return when the target 'Iter' returns a result or +-- fails. An @Inum@ may also unilaterally return the state of the +-- iteratee at any earlier point, for instance if it has reached some +-- logical message boundary (e.g., many protocols finish processing +-- headers upon reading a blank line). +-- +-- @Inum@s are generally constructed with one of the 'mkInum' or +-- '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. +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 +-- @()@--i.e., @'Inum' () t m a@--so that there is no meaningful input +-- data to transcode. Such an enumerator is called an +-- /outer enumerator/, because it must produce the data it feeds to +-- 'Iter's by either executing actions in monad @m@, or from its own +-- internal pure state (as for 'enumPure'). +-- +-- As with 'Inum's, an @Onum@ should under no circumstances ever feed +-- a chunk with the EOF bit set to its 'Iter' argument. When the +-- @Onum@ runs out of data, it must simply return the current state of +-- the 'Iter'. This way more data from another source can still be +-- fed to the iteratee, as happens when enumerators are concatenated +-- with the 'cat' function. +-- +-- @Onum@s should generally be constructed using the 'mkInum' or +-- 'mkInumM' function, just like 'Inum's, the only difference being +-- that for an @Onum@ the input type is @()@, so executing 'Iter's to +-- consume input will be of little use. +type Onum t m a = Inum () t m a + +-- Concatenation and fusing functions + +-- | Run an 'Onum' on an 'Iter'. This is the main way of actually +-- executing IO with 'Iter's. @|$@ is a type-restricted version of +-- the following code, in which @inum@ must be an 'Onum': +-- +-- @ +-- inum |$ iter = 'run' (inum .| iter) +-- infixr 2 |$ +-- @ +(|$) :: (ChunkData t, Monad m) => Onum t m a -> Iter t m a -> m a +(|$) inum iter = run (inum .| iter) +infixr 2 |$ + +-- | @.|$@ is a variant of '|$' that allows you to apply an 'Onum' +-- from within an 'Iter' monad. This is often useful in conjuction +-- with 'enumPure', if you want to parse at some coarse-granularity +-- (such as lines), and then re-parse the contents of some +-- coarser-grained parse unit. For example: +-- +-- > rawcommand <- lineI +-- > command <- enumPure rawcommand .|$ parseCommandI +-- > return Request { cmd = command, rawcmd = rawcommand } +-- +-- @.|$@ has the same fixity as @|$@, namely: +-- +-- > infixr 2 .|$ +-- +-- Note the important distinction between @(.|$)@ and @('.|')@. +-- @(.|$)@ runs an 'Onum' and does not touch the current input, while +-- ('.|') pipes the current input through an 'Inum'. For instance, to +-- send the contents of a file to standard output (regardless of the +-- current input), you must say @'enumFile' \".signature\" .|$ +-- 'stdoutI'@. But to take the current input, compress it, and send +-- the result to standard output, you must use '.|', as in @'inumGzip' +-- '.|' 'stdoutI'@. +-- +-- As suggested by the types, @enum .|$ iter@ is sort of equivalent to +-- @'lift' (enum |$ iter)@, except that the latter will call 'throw' +-- on failures, causing language-level exceptions that cannot be +-- caught within the outer 'Iter'. Thus, it is better to use @.|$@ +-- than @'lift' (... '|$' ...)@, though in the less general case of +-- the IO monad, @enum .|$ iter@ is equivalent to @'liftIO' (enum '|$' +-- iter)@ as illustrated by the following examples: +-- +-- > -- Catches exception, because .|$ propagates failure through the outer +-- > -- Iter Monad, where it can still be caught. +-- > apply1 :: IO String +-- > apply1 = enumPure "test1" |$ iter `catchI` handler +-- > where +-- > iter = enumPure "test2" .|$ fail "error" +-- > handler (SomeException _) _ = return "caught error" +-- > +-- > -- Does not catch error. |$ turns the Iter failure into a language- +-- > -- level exception, which can only be caught in the IO Monad. +-- > apply2 :: IO String +-- > apply2 = enumPure "test1" |$ iter `catchI` handler +-- > where +-- > iter = lift (enumPure "test2" |$ fail "error") +-- > handler (SomeException _) _ = return "caught error" +-- > +-- > -- Catches the exception, because liftIO uses the IO catch function to +-- > -- turn language-level exceptions into monadic Iter failures. (By +-- > -- contrast, lift works in any Monad, so cannot do this in apply2.) +-- > -- This example illustrates how liftIO is not equivalent to lift. +-- > apply3 :: IO String +-- > apply3 = enumPure "test1" |$ iter `catchI` handler +-- > where +-- > iter = liftIO (enumPure "test2" |$ fail "error") +-- > handler (SomeException _) _ = return "caught error" +(.|$) :: (ChunkData tIn, ChunkData tOut, Monad m) => + Onum tOut m a -> Iter tOut m a -> Iter tIn m a +(.|$) enum iter = runI (enum .| iter) +infixr 2 .|$ + +-- | Concatenate the outputs of two enumerators. For example, +-- @'enumFile' \"file1\" \`cat\` 'enumFile' \"file2\"@ produces an +-- 'Onum' that outputs the concatenation of files \"file1\" and +-- \"file2\". Unless the first 'Inum' fails, @cat@ always invokes the +-- second 'Inum', as the second 'Inum' may have monadic side-effects +-- that must be executed even when the 'Iter' has already finished. +-- See 'lcat' if you want to stop when the 'Iter' no longer requires +-- input. If you want to continue executing even in the event of an +-- 'InumFail' condition, you can wrap the first 'Inum' with +-- 'inumCatch' and invoke 'resumeI' from within the exception handler. +-- +-- @cat@ (and 'lcat', described below) are useful in right folds. +-- Say, for instance, that @files@ is a list of files you wish to +-- concatenate. You can use a construct such as: +-- +-- @ +-- catFiles :: ('MonadIO' m) => ['FilePath'] -> 'Onum' 'L.ByteString' m a +-- catFiles files = 'foldr' ('cat' . 'enumFile') 'inumNull' files +-- @ +-- +-- Note the use of 'inumNull' as the starting value for 'foldr'. This +-- is not to be confused with 'inumNop'. 'inumNull' acts as a no-op +-- for concatentation, producing no output analogously to +-- @\/dev\/null@. By contrast 'inumNop' is the no-op for fusing (see +-- '|.' and '.|' below) because it passes all data through untouched. +-- +-- @cat@ has fixity: +-- +-- > infixr 3 `cat` +cat :: (ChunkData tIn, ChunkData tOut, Monad m) => + Inum tIn tOut m a -- ^ + -> Inum tIn tOut m a + -> Inum tIn tOut m a +cat a b iter = tryRI (runInum a iter) >>= either reRunIter (b . reRunIter) +-- Note this was carefully constructed to preserve the return value in +-- errors. Something like: cat a b iter = a iter >>= b . reRunIter +-- would turn a @('Fail' e ('Just' r) c)@ result from @a@ into +-- @('Fail' e 'Nothing' c)@; since the input and output types of >>= +-- do not have to be the same, >>= must convert error results to +-- 'Nothing'. +infixr 3 `cat` + +-- | Lazy cat. Like 'cat', except that it does not run the second +-- 'Inum' if the 'Iter' is no longer active after completion of the +-- first 'Inum'. Also has fixity @infixr 3 \`lcat\`@. +lcat :: (ChunkData tIn, ChunkData tOut, Monad m) => + Inum tIn tOut m a -- ^ + -> Inum tIn tOut m a + -> Inum tIn tOut m a +lcat a b iter = tryRI (runInum a iter) >>= either reRunIter check + where check r = if isIterActive r then b $ reRunIter r else return r +infixr 3 `lcat` + +-- | Transforms the result of an 'Inum' into the result of the 'Iter' +-- that it contains. Used by '|.' and '.|' to collapse their result +-- types. +-- +-- Note that because the input type if the inner 'Iter', @tMid@, gets +-- squeezed out of the return type, @joinR@ will feed an EOF to the +-- inner 'Iter' if it is still active. This is what ensures that +-- active 'Iter's end up seeing an EOF, even though 'Inum's themselves +-- are never supposed to feed an EOF to the underlying 'Iter'. All +-- 'Iter's in right-hand arguments of '.|' and '|.' get fed an EOF by +-- @joinR@ (if they don't finish on their own), while the outermost +-- 'Inum' is fed an iter by the 'run' function (or by '|$' which +-- invokes 'run' internally). +joinR :: (ChunkData tIn, ChunkData tMid, Monad m) => + IterR tIn m (IterR tMid m a) + -> IterR tIn m a +joinR (Done i c) = runIterR (runR i) c +joinR (Fail e Nothing c) = Fail e Nothing c +-- +-- Note that 'runR' in the following function is serving two purposes, +-- one of them subtle. The obvious purpose is to preserve the state +-- of the non-failed target 'Iter' when an 'Inum' has failed. +-- However, a subtler, more important purpose is to guarantee that all +-- (non-failed) 'Iter's eventually receive EOF even when 'Inum's fail. +-- This is critical for things like EOF transmission and file +-- descriptor closing, and is how functions such as 'pairFinalizer' +-- can make sense. +joinR (Fail e (Just i) c) = flip onDoneR (runR i) $ \r -> + case r of + Done a _ -> Fail e (Just a) c + Fail e' a _ -> Fail e' a c + _ -> error "joinR" +joinR _ = error "joinR: not done" + +-- | Left-associative pipe operator. Fuses two 'Inum's when the +-- output type of the first 'Inum' is the same as the input type of +-- the second. More specifically, if @inum1@ transcodes type @tIn@ to +-- @tOut@ and @inum2@ transcodes @tOut@ to @tOut2@, then @inum1 +-- |. inum2@ produces a new 'Inum' that transcodes from @tIn@ to +-- @tOut2@. +-- +-- Typically types @i@ and @iR@ are @'Iter' tOut2 m a@ and @'IterR' +-- tOut2 m a@, respectively, in which case the second argument and +-- result of @|.@ are also 'Inum's. +-- +-- This function is equivalent to: +-- +-- @ +-- outer |. inner = \\iter -> outer '.|' inner iter +-- infixl 4 |. +-- @ +-- +-- But if you like point-free notation, think of it as @outer |. inner +-- = (outer '.|') . inner@, or better yet @(|.) = (.) . ('.|')@. +(|.) :: (ChunkData tIn, ChunkData tOut, Monad m) => + Inum tIn tOut m iR -- ^ + -> (i -> Iter tOut m iR) + -> (i -> Iter tIn m iR) +(|.) outer inner = \iter -> onDone joinR $ outer $ inner iter +infixl 4 |. + +-- | Right-associative pipe operator. Fuses an 'Inum' that transcodes +-- @tIn@ to @tOut@ with an 'Iter' taking input type @tOut@ to produce +-- an 'Iter' taking input type @tIn@. If the 'Iter' is still active +-- when the 'Inum' terminates (either normally or through an +-- exception), then @.|@ sends it an EOF. +-- +-- Has fixity: +-- +-- > infixr 4 .| +(.|) :: (ChunkData tIn, ChunkData tOut, Monad m) => + Inum tIn tOut m a -- ^ + -> Iter tOut m a + -> Iter tIn m a +(.|) inum iter = onDone joinR $ inum iter +infixr 4 .| + +-- +-- Exception functions +-- + +-- | Catches errors thrown by an 'Inum', or a set of fused 'Inum's. +-- Note that only errors in 'Inum's that are lexically within the +-- scope of the argument to 'inumCatch' will be caught. For example: +-- +-- > inumBad :: (ChunkData t, Monad m) => Inum t t m a +-- > inumBad = mkInum $ fail "inumBad" +-- > +-- > skipError :: (ChunkData tIn, MonadIO m) => +-- > SomeException +-- > -> IterR tIn m (IterR tOut m a) +-- > -> Iter tIn m (IterR tOut m a) +-- > skipError e iter = do +-- > liftIO $ hPutStrLn stderr $ "skipping error: " ++ show e +-- > resumeI iter +-- > +-- > -- Throws an exception, because inumBad was fused outside the argument +-- > -- to inumCatch. +-- > test1 :: IO () +-- > test1 = inumCatch (enumPure "test") skipError |. inumBad |$ nullI +-- > +-- > -- Does not throw an exception, because inumBad fused within the +-- > -- argument to inumCatch. +-- > test2 :: IO () +-- > test2 = inumCatch (enumPure "test" |. inumBad) skipError |$ nullI +-- > +-- > -- Again no exception, because inumCatch is wrapped around inumBad. +-- > test3 :: IO () +-- > test3 = enumPure "test" |. inumCatch inumBad skipError |$ nullI +-- +-- Note that @\`inumCatch\`@ has the default infix precedence (@infixl +-- 9 \`inumcatch\`@), which binds more tightly than any concatenation +-- or fusing operators. +-- +-- As noted for 'catchI', exception handlers receive both the +-- exception thrown and the failed 'IterR'. Particularly in the case +-- of @inumCatch@, it is important to re-throw exceptions by +-- re-executing the failed 'Iter' with 'reRunIter', not passing the +-- exception itself to 'throwI'. That way, if the exception is +-- re-caught, 'resumeI' will continue to work properly. For example, +-- to copy two files to standard output and ignore file not found +-- errors but re-throw any other kind of error, you could use the +-- following: +-- +-- @ +-- resumeTest :: IO () +-- resumeTest = doFile \"file1\" ``cat`` doFile \"file2\" |$ 'stdoutI' +-- where +-- doFile path = inumCatch (`enumFile'` path) $ \\err r -> +-- if 'isDoesNotExistError' err +-- then 'verboseResumeI' r +-- else 'reRunIter' r +-- @ +-- +inumCatch :: (Exception e, ChunkData tIn, Monad m) => + Inum tIn tOut m a + -- ^ 'Inum' that might throw an exception + -> (e -> IterR tIn m (IterR tOut m a) -> Iter tIn m (IterR tOut m a)) + -- ^ Exception handler + -> Inum tIn tOut m a +inumCatch enum handler iter = catchI (enum iter) check + where check e r@(Fail _ (Just _) _) = handler e r + check _ r = reRunIter r + +-- | Execute some cleanup action when an 'Inum' finishes. +inumFinally :: (ChunkData tIn, Monad m) => + Inum tIn tOut m a -> Iter tIn m b -> Inum tIn tOut m a +inumFinally inum cleanup iter = inum iter `finallyI` cleanup + +-- | Execute some cleanup action if an 'Inum' fails. Does not execute +-- the action if the 'Iter' (or some inner 'Inum') fails. Has the +-- same scoping rules as 'inumCatch'. +inumOnException :: (ChunkData tIn, Monad m) => + Inum tIn tOut m a -> Iter tIn m b -> Inum tIn tOut m a +inumOnException inum cleanup iter = inum iter `onExceptionI` cleanup + +-- | Used in an exception handler, after an 'Inum' failure, to resume +-- processing of the 'Iter' by the next enumerator in a 'cat'ed +-- series. See 'inumCatch' for an example. +resumeI :: (ChunkData tIn, Monad m) => + IterR tIn m (IterR tOut m a) -> Iter tIn m (IterR tOut m a) +resumeI (Fail _ (Just a) _) = return a +resumeI _ = error "resumeI: not an Inum failure" + +-- | Like 'resumeI', but if the 'Iter' is resumable, also prints an +-- error message to standard error before resuming. +verboseResumeI :: (ChunkData tIn, MonadIO m) => + IterR tIn m (IterR tOut m a) -> Iter tIn m (IterR tOut m a) +verboseResumeI (Fail e (Just a) _) = do + liftIO $ do prog <- liftIO getProgName + hPutStrLn stderr $ prog ++ ": " ++ show e + return a +verboseResumeI _ = error "verboseResumeI: not an Inum failure" + +-- +-- Control handlers +-- + +-- | A @ResidHandler@ specifies how to handle residual data in an +-- 'Inum'. Typically, when an 'Inum' finishes executing, there are +-- two kinds of residual data. First, the 'Inum' itself (in its role +-- as an iteratee) may have left some unconsumed data. Second, the +-- target 'Iter' being fed by the 'Inum' may have some resitual data, +-- and this data may be of a different type. A @ResidHandler@ allows +-- this residual data to be adjusted by untranslating the residual +-- data of the target 'Iter' and sticking the result back into the +-- `Inum`'s residual data. +-- +-- The two most common @ResidHandler@s are 'pullupResid' (to pull the +-- target `Iter`'s residual data back up to the 'Inum' as is), and +-- 'id' (to do no adjustment of residual data). +-- +-- @ResidHandler@s are used by the 'mkInumC' function, and by the +-- 'passCtl' 'CtlHandler'. +type ResidHandler tIn tOut = (tIn, tOut) -> (tIn, tOut) + +withResidHandler :: ResidHandler tIn tOut + -> Chunk tOut + -> (Chunk tOut -> Iter tIn mIn a) + -> Iter tIn mIn a +withResidHandler adjust (Chunk tOut0 eofOut) cont = + Iter $ \(Chunk tIn0 eofIn) -> + case adjust (tIn0, tOut0) of + (tIn, tOut) -> runIter (cont $ Chunk tOut eofOut) $ Chunk tIn eofIn + +-- | A control handler maps control requests to 'IterR' results. +-- Generally the type parameter @m1@ is @'Iter' t' m@. +type CtlHandler m1 t m a = CtlArg t m a -> m1 (IterR t m a) + +-- | Reject all control requests. +noCtl :: (Monad m1) => CtlHandler m1 t m a +noCtl (CtlArg _ n c) = return $ runIter (n CtlUnsupp) c + +-- | Pass all control requests through to the enclosing 'Iter' monad. +-- The 'ResidHandler' argument says how to adjust residual data, in +-- case some enclosing 'CtlHandler' decides to flush pending input +-- data, it is advisable to un-translate any data in the output type +-- @tOut@ back to the input type @tIn@. +passCtl :: (Monad mIn) => + ResidHandler tIn tOut + -> CtlHandler (Iter tIn mIn) tOut m a +passCtl adj (CtlArg a n c0) = withResidHandler adj c0 runn + where runn c = do mcr <- safeCtlI a + return $ runIter (n mcr) c + +-- | Create a 'CtlHandler' given a function of a particular control +-- argument type and a fallback 'CtlHandler' to run if the argument +-- type does not match. @consCtl@ is used to chain handlers, with the +-- rightmost handler being either 'noCtl' or 'passCtl'. +-- +-- For example, to create a control handler that implements seek on +-- @'SeekC'@ requests, returns the size of the file on @'SizeC'@ +-- requests, and passes everything else out to the enclosing +-- enumerator (if any), you could use the following: +-- +-- @ +-- fileCtl :: (ChunkData t, MonadIO m) => Handle -> CtlHandler (Iter () m) t m a +-- fileCtl h = ('mkFlushCtl' $ \(SeekC mode pos) -> liftIO (hSeek h mode pos)) +-- \`consCtl\` ('mkCtl' $ \SizeC -> liftIO (hFileSize h)) +-- \`consCtl\` 'passCtl' 'id' +-- @ +-- +-- Has fixity: +-- +-- > infixr 9 `consCtl` +consCtl :: (CtlCmd carg cres, ChunkData tIn, Monad mIn) => + (carg -> (cres -> Iter t m a) -> Chunk t + -> Iter tIn mIn (IterR t m a)) + -> 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 + `catchI` \e _ -> return $ runIter (n $ CtlFail e) c +infixr 9 `consCtl` + +-- | Make a control function suitable for use as the first argument to +-- 'consCtl'. +mkCtl :: (CtlCmd carg cres, Monad m1) => + (carg -> Iter t1 m1 cres) + -> carg -> (cres -> Iter t m a) -> Chunk t -> Iter t1 m1 (IterR t m a) +mkCtl f a n c = do cres <- f a; return $ runIter (n cres) c + +-- | Like 'mkCtl', except that it flushes all input and clears the EOF +-- flag in both 'Iter' monads after executing the control function. +mkFlushCtl :: (CtlCmd carg cres, Monad mIn, ChunkData tIn, ChunkData t) => + (carg -> Iter tIn mIn cres) + -> carg -> (cres -> Iter t m a) -> Chunk t + -> Iter tIn mIn (IterR t m a) +mkFlushCtl f a n _ = do cres <- onDone (flip setResid mempty) $ f a + return $ runIter (n cres) mempty + +-- +-- Basic tools +-- + +-- $mkInumIntro +-- +-- The 'mkInum' function allows you to create stateless 'Inum's out of +-- simple transcoding 'Iter's. As an example, suppose you are +-- processing a list of @L.ByteString@s representing packets, and want +-- to concatenate them all into one continuous stream of bytes. You +-- could implement an 'Inum' called @inumConcat@ to do this as +-- follows: +-- +-- #mkInumExample# +-- +-- @ +--iterConcat :: (Monad m) => 'Iter' [L.ByteString] m L.ByteString +--iterConcat = L.concat ``liftM`` 'dataI' +-- +--inumConcat :: (Monad m) => 'Inum' [L.ByteString] L.ByteString m a +--inumConcat = 'mkInum' iterConcat +-- @ +-- + +-- | Like 'runIterMC', but only for 'IterM'--may return 'IterC'. +runIterM :: (Monad m, MonadTrans mt, Monad (mt m)) => + Iter t m a -> Chunk t -> mt m (IterR t m a) +runIterM iter c = check $ runIter iter c + where check (IterM m) = lift m >>= check + check r = return r + +runIterRMC :: (Monad m) => + CtlHandler (Iter tIn m) tOut m a + -> IterR tOut m a -> Iter tIn m (IterR tOut m a) +runIterRMC ch = check + where check (IterM m) = lift m >>= check + check (IterC ca) = ch ca >>= check + check r = return r + +-- | Run an 'Iter' just like 'runIter', but then keep stepping the +-- result for as long as it is in the 'IterM' or 'IterC' state (using +-- the supplied 'CtlHandler' for 'IterC' states). 'Inum's should +-- generally use this function or 'runIterM' in preference to +-- 'runIter', as it is convenient if 'Inum's avoid ever returning +-- 'IterR's in the 'IterM' state. +runIterMC :: (Monad m) => + CtlHandler (Iter tIn m) tOut m a + -> Iter tOut m a -> Chunk tOut -> Iter tIn m (IterR tOut m a) +runIterMC ch iter c = runIterRMC ch $ runIter iter c + +-- | Takes an 'Inum' that might return 'IterR's in the 'IterM' state +-- (which is considered impolite--see 'runIterMC') and transforms it +-- into an 'Inum' that never returns 'IterR's in the 'IterM' state. +runInum :: (ChunkData tIn, Monad m) => + Inum tIn tOut m a -> Inum tIn tOut m a +runInum inum = onDone check . inum + where + check (Done (IterM m) c) = IterM $ m >>= \r -> return $ check $ Done r c + check r = r + +-- | 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. +-- +-- @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 +-- handler for control requests. For example, to pass up control +-- requests and ensure no residual data is lost when the 'Inum' is +-- fused to an 'Iter', the @inumConcat@ function given previously for +-- 'mkInum' at <#mkInumExample> could be re-written: +-- +-- > inumConcat :: (Monad m) => Inum [L.ByteString] L.ByteString m a +-- > inumConcat = mkInumC reList (passCtl reList) iterConcat +-- > where reList (a, b) = (b:a, mempty) +mkInumC :: (ChunkData tIn, ChunkData tOut, Monad m) => + ResidHandler tIn tOut + -- ^ Adjust residual data (use 'id' for no adjustment) + -> CtlHandler (Iter tIn m) tOut m a + -- ^ Handle control requests (use 'noCtl' or 'passCtl' if + -- 'Inum' shouldn't implement any specific control functions). + -> Iter tIn m tOut + -- ^ Generate transcoded data chunks + -> Inum tIn tOut m a +mkInumC adj ch codec iter0 = doIter iter0 + where + doIter iter = tryEOFI codec >>= maybe (return $ IterF iter) (doInput iter) + doInput iter input = do + r <- runIterMC ch iter (Chunk input False) + case r of + (IterF i) | not (null input) -> doIter i + _ | isIterActive r -> return r + _ -> withResidHandler adj (getResid r) $ return . setResid r + +-- | Create an 'Inum' based on an 'Iter' that transcodes the input to +-- the output type. This is a simplified version of 'mkInumC' that +-- rejects all control requests and does not adjust residual data. +-- +-- > mkInum = mkInumC id noCtl +mkInum :: (ChunkData tIn, ChunkData tOut, Monad m) => + Iter tIn m tOut -> Inum tIn tOut m a +mkInum = mkInumC id noCtl + +-- | A simplified version of 'mkInum' that passes all control requests +-- to enclosing enumerators. It requires a 'ResidHandler' to describe +-- how to adjust residual data. (E.g., use 'pullupResid' when @tIn@ +-- and @tOut@ are the same type.) +-- +-- > mkInumP adj = mkInumC adj (passCtl adj) +mkInumP :: (ChunkData tIn, ChunkData tOut, Monad m) => + ResidHandler tIn tOut -> Iter tIn m tOut -> Inum tIn tOut m a +mkInumP adj = mkInumC adj (passCtl adj) + +-- | @pullupResid (a, b) = (mappend a b, mempty)@. See 'ResidHandler'. +pullupResid :: (ChunkData t) => (t, t) -> (t, t) +pullupResid (a, b) = (mappend a b, mempty) + +-- | Bracket an 'Inum' with a start and end function, which can be +-- used to acquire and release a resource, must like the IO monad's +-- @'bracket'@ function. For example: +-- +-- > enumFile :: (MonadIO m, ChunkData t, LL.ListLikeIO t e) => +-- > FilePath -> Onum t m a +-- > enumFile path = inumBracket (liftIO $ openBinaryFile path ReadMode) +-- > (liftIO . hClose) +-- > enumHandle +inumBracket :: (ChunkData tIn, Monad m) => + Iter tIn m b + -- ^ Computation to run first + -> (b -> Iter tIn m c) + -- ^ Computation to run last + -> (b -> Inum tIn tOut m a) + -- ^ Inum to bracket + -> Inum tIn tOut m a +inumBracket start end inum iter = tryFI start >>= check + where check (Left e) = Iter $ Fail e (Just $ IterF iter) . Just + check (Right b) = inum b iter `finallyI` end b + +-- +-- Basic Inums +-- + +-- | @inumNop@ passes all data through to the underlying 'Iter'. It +-- acts as a no-op when fused to other 'Inum's with '|.' or when fused +-- to 'Iter's with '.|'. +-- +-- @inumNop@ is particularly useful for conditionally fusing 'Inum's +-- together. Even though most 'Inum's are polymorphic in the return +-- type, this library does not use the Rank2Types extension, which +-- means any given 'Inum' must have a specific return type. Here is +-- an example of incorrect code: +-- +-- @ +-- let enum = if debug then base_enum '|.' 'inumStderr' else base_enum -- Error +-- @ +-- +-- This doesn't work because @base_enum@ cannot have the same type as +-- @(base_enum |. inumStderr)@. Instead, you can use the following: +-- +-- @ +-- let enum = base_enum '|.' if debug then 'inumStderr' else inumNop +-- @ +inumNop :: (ChunkData t, Monad m) => Inum t t m a +inumNop = mkInumP pullupResid dataI + +-- | @inumNull@ feeds empty data to the underlying 'Iter'. It pretty +-- much acts as a no-op when concatenated to other 'Inum's with 'cat' +-- or 'lcat'. +-- +-- There may be cases where @inumNull@ is required to avoid deadlock. +-- In an expression such as @enum '|$' iter@, if @enum@ immediately +-- blocks waiting for some event, and @iter@ immediately starts out +-- triggering that event before reading any input, then to break the +-- deadlock you can re-write the code as @cat inumNull enum '|$' +-- iter@. +inumNull :: (ChunkData tOut, Monad m) => Inum tIn tOut m a +inumNull = inumPure mempty + +-- | Feed pure data to an 'Iter'. +inumPure :: (Monad m) => tOut -> Inum tIn tOut m a +inumPure t iter = runIterM iter $ chunk t + +-- | Type-restricted version of 'inumPure'. +enumPure :: (Monad m) => tOut -> Onum tOut m a +enumPure = inumPure + +-- | Repeat an 'Inum' until the input receives an EOF condition, the +-- 'Iter' no longer requires input, or the 'Iter' is in an unhandled +-- 'IterC' state (which presumably will continue to be unhandled by +-- the same 'Inum', so no point in executing it again). +inumRepeat :: (ChunkData tIn, Monad m) => + Inum tIn tOut m a -> Inum tIn tOut m a +inumRepeat inum iter0 = do + er <- tryRI $ runInum inum iter0 + stop <- atEOFI + case (stop, er) of + (False, Right (IterF iter)) -> inumRepeat inum iter + (_, Right r) -> return r + (_, Left r) -> reRunIter r + +-- +-- Complex Inum creation +-- + +{- $mkInumMIntro + +Complex 'Inum's that need state and non-trivial control flow can be +constructed using the 'mkInumM' function to produce an 'Inum' out of a +computation in the 'InumM' monad. The 'InumM' monad implicitly keeps +track of the state of the 'Iter' to which the 'Inum' is feeding data, +which we call the \"target\" 'Iter'. + +'InumM' is an 'Iter' monad, and so can consume input by invoking +ordinary 'Iter' actions. However, to keep track of the state of the +target 'Iter', 'InumM' wraps its inner monadic type with an +'IterStateT' transformer. Specifically, when creating an enumerator +of type @'Inum' tIn tOut m a@, the 'InumM' action is of a type like +@'Iter' tIn ('IterStateT' (InumState ...) m) ()@. That means that to +execute actions of type @'Iter' tIn m a@ that are not polymorphic in +@m@, you have to transform them with the 'liftI' function. + +Output can be fed to the target 'Iter' by means of the 'ifeed' +function. As an example, here is another version of the @inumConcat@ +function given previously for 'mkInum' at <#mkInumExample>: + +@ +inumConcat :: (Monad m) => 'Inum' [L.ByteString] L.ByteString m a +inumConcat = 'mkInumM' loop + where loop = do + 'Chunk' t eof <- 'chunkI' + done <- 'ifeed' $ L.concat t + if not (eof || done) + then loop + else do resid <- 'ipopresid' + 'ungetI' [resid] +@ + +There are several points to note about this function. It reads data +in 'Chunk's using 'chunkI', rather than just inputting data with +'dataI'. The choice of 'chunkI' rather than 'dataI' allows +@inumConcat@ to see the @eof@ flag and know when there is no more +input. 'chunkI' also avoids throwing an 'IterEOF' exception on end of +file, as 'dataI' would. In contrast to 'mkInum', which gracefully +interprets 'IterEOF' exceptions as an exit request, 'mkInumM' by +default treats such exceptions as an 'Inum' failure. + +As previously mentioned, data is fed to the target 'Iter', which here +is of type @'Iter' L.ByteString m a@, using 'ifeed'. 'ifeed' returns +a 'Bool' that is @'True'@ when the 'Iter' is no longer active. This +brings us to another point--there is no implicit looping or +repetition. We explicitly loop via a tail-recursive call to @loop@ so +long as the @eof@ flag is clear and 'ifeed' returned @'False'@ +indicating the target 'Iter' has not finished. + +What happens when @eof@ or @done@ is set? One possibility is to do +nothing. This is often correct. Falling off the end of the 'InumM' +do-block causes the 'Inum' to return the current state of the 'Iter'. +However, it may be that the 'Inum' has been fused to the target +'Iter', in which case any left-over residual data fed to, but not +consumed by, the target 'Iter' will be discarded. We may instead want +to put the data back onto the input stream. The 'ipopresid' function +extracts any left-over data from the target 'Iter', while 'ungetI' +places data back in the input stream. Since here the input stream is +a list of @L.ByteString@s, we have to place @resid@ in a list. (After +doing this, the list element boundaries may be different, but all the +input bytes will be there.) Note that the version of @inumConcat@ +implemented with 'mkInum' at <#mkInumExample> does not have this +input-restoring feature. + +The code above looks much clumsier than the version based on 'mkInum', +but several of these steps can be made implicit. There is an +/AutoEOF/ flag, controlable with the 'setAutoEOF' function, that +causes 'IterEOF' exceptions to produce normal termination of the +'Inum', rather than failure (just as 'mkInum' handles such +exceptions). Another flag, /AutoDone/, is controlable with the +'setAutoDone' function and causes the 'Inum' to exit immediately when +the underlying 'Iter' is no longer active (i.e., the 'ifeed' function +returns @'True'@). Both of these flags are set at once by the +'mkInumAutoM' function, which yields the following simpler +implementation of @inumConcat@: + +@ +inumConcat = 'mkInumAutoM' $ do 'addCleanup' $ 'ipopresid' >>= 'ungetI' . (: []) + loop + where loop = do + t <- 'dataI' -- AutoEOF flag will handle IterEOF err + 'ifeed' $ L.concat t -- AutoDone flag will catch True result + loop +@ + +The 'addCleanup' function registers actions that should always be +executed when the 'Inum' finishes. Here we use it to place residual +data from the target 'Iter' back into the `Inum`'s input stream. + +Finally, there is a function 'irepeat' that automatically sets the +/AutoEOF/ and /AutoDone/ flags and then loops forever on an 'InumM' +computation. Using 'irepeat' to simplify further, we have: + +@ +'inumConcat' = 'mkInumM' $ 'withCleanup' ('ipopresid' >>= 'ungetI' . (: [])) $ + 'irepeat' $ 'dataI' >>= 'ifeed' . L.concat +@ + +'withCleanup', demonstrated here, is a variant of 'addCleanup' that +cleans up after a particular action, rather than at the end of the +`Inum`'s whole execution. (At the outermost level, as used here, +`withCleanup`'s effects are identical to `addCleanup`'s.) + +In addition to 'ifeed', the 'ipipe' function invokes a different +'Inum' from within the 'InumM' monad, piping its output directly to +the target 'Iter'. As an example, consider an 'Inum' that processes a +mail message and appends a signature line, implemented as follows: + +@ +inumAddSig :: (Monad m) => 'Inum' L.ByteString L.ByteString m a +inumAddSig = 'mkInumM' $ do + 'ipipe' 'inumNop' + 'ifeed' $ L8.pack \"\\n--\\nSent from my Haskell interpreter.\\n\" +@ + +Here we start by using 'inumNop' to \"pipe\" all input to the target +'Iter' unmodified. On reading an end of file, 'inumNop' returns, at +which point we use 'ifeed' to append our signature. + +A similar function 'irun' runs an 'Onum' (or 'Inum' of a different +type) on the target 'Iter'. For instance, to read the signature from +a file called @\".signature\"@, one could use: + +@ +inumAddSig :: ('MonadIO' m) => 'Inum' L.ByteString L.ByteString m a +inumAddSig = 'mkInumM' $ do + 'ipipe' 'inumNop' + 'irun' $ 'enumFile' \".signature\" +@ + +Of course, these examples are a bit contrived. An even simpler +implementation is: + +@ +inumAddSig = 'inumNop' ``cat`` 'runI' . 'enumFile' \".signature\" +@ + +The @.@ between 'runI' and @'enumFile'@ is because 'Inum's are +functions from 'Iter's to 'IterR's; we want to apply 'runI' to the +result of applying @'enumFile' \".signature\"@ to an 'Iter'. Spelled +out, the type of @'enumFile'@ is: + +@ +enumFile :: (MonadIO m, ChunkData t, ListLikeIO t e) => + FilePath + -> 'Iter' t m a + -> 'Iter' () m a ('IterR' t m a) +@ + +-} + +-- | Internal data structure for the 'InumM' monad's state. +data InumState tIn tOut m a = InumState { + insAutoEOF :: !Bool + , insAutoDone :: !Bool + , insCtl :: !(CtlHandler (Iter tIn m) tOut m a) + , insIter :: !(IterR tOut m a) + , insCleanup :: !(InumM tIn tOut m a ()) + , insCleaning :: !Bool + } + +defaultInumState :: (ChunkData tIn, Monad m) => InumState tIn tOut m a +defaultInumState = InumState { + insAutoEOF = False + , insAutoDone = False + , insCtl = noCtl + , insIter = IterF $ Iter $ const $ error "insIter" + , insCleanup = return () + , insCleaning = False + } + +-- | 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 +-- fifth type argument is required for monadic computations of kind +-- @*@, e.g.: +-- +-- > seven :: InumM tIn tOut m a Int +-- > seven = return 7 +-- +-- Another important thing to note about the 'InumM' monad, as +-- described in the documentation for 'mkInumM', is that you must call +-- @'lift'@ twice to execute actions in monad @m@, and you must use +-- the 'liftI' function to execute actions in monad @'Iter' t m a@. +type InumM tIn tOut m a = Iter tIn (IterStateT (InumState tIn tOut m a) m) + +-- | Set the control handler an 'Inum' should use from within an +-- 'InumM' computation. (The default is 'noCtl'.) +setCtlHandler :: (ChunkData tIn, Monad m) => + CtlHandler (Iter tIn m) tOut m a + -> InumM tIn tOut m a () +setCtlHandler ch = imodify $ \s -> s { insCtl = ch } + +-- | Set the /AutoEOF/ flag within an 'InumM' computation. If this +-- flag is 'True', handle 'IterEOF' exceptions like a normal but +-- immediate termination of the 'Inum'. If this flag is @'False'@ +-- (the default), then 'IterEOF' exceptions must be manually caught or +-- they will terminate the thread. +setAutoEOF :: (ChunkData tIn, Monad m) => Bool -> InumM tIn tOut m a () +setAutoEOF val = imodify $ \s -> s { insAutoEOF = val } + +-- | Set the /AutoDone/ flag within an 'InumM' computation. When +-- @'True'@, the 'Inum' will immediately terminate as soon as the +-- 'Iter' it is feeding enters a non-active state (i.e., 'Done' or a +-- failure state). If this flag is @'False'@ (the default), the +-- 'InumM' computation will need to monitor the results of the +-- 'ifeed', 'ipipe', and 'irun' functions to ensure the 'Inum' +-- terminates when one of these functions returns @'False'@. +setAutoDone :: (ChunkData tIn, Monad m) => Bool -> InumM tIn tOut m a () +setAutoDone val = imodify $ \s -> s { insAutoDone = val } + +-- | Like imodify, but throws an error if the insCleaning flag is set. +ncmodify :: (ChunkData tIn, Monad m) => + (InumState tIn tOut m a -> InumState tIn tOut m a) + -> InumM tIn tOut m a () +ncmodify fn = imodify $ \s -> if insCleaning s + then error "illegal call within Cleanup function" + else fn s + +-- | Add a cleanup action to be executed when the 'Inum' finishes, or, +-- if used in conjunction with the 'withCleanup' function, when the +-- innermost enclosing 'withCleanup' action finishes. +addCleanup :: (ChunkData tIn, Monad m) => + InumM tIn tOut m a () -> InumM tIn tOut m a () +addCleanup clean = ncmodify $ \s -> s { insCleanup = clean >> insCleanup s } + +-- | Run an 'InumM' with some cleanup action in effect. The cleanup +-- action specified will be executed when the main action returns, +-- whether normally, through an exception, because of the /AutoDone/ +-- or /AutoEOF/ flags, or because 'idone' is invoked. +-- +-- Note @withCleanup@ also defines the scope of actions added by the +-- 'addCleanup' function. In other words, given a call such as +-- @withCleanup cleaner1 main@, if @main@ invokes @'addCleanup' +-- cleaner2@, then both @cleaner1@ and @cleaner2@ will be executed +-- upon @main@'s return, even if the overall 'Inum' has not finished +-- yet. +withCleanup :: (ChunkData tIn, Monad m) => + InumM tIn tOut m a () -- ^ Cleanup action + -> InumM tIn tOut m a b -- ^ Main action to execute + -> InumM tIn tOut m a b +withCleanup clean action = do + old <- igets insCleanup + ncmodify $ \s -> s { insCleanup = clean } + action `finallyI` do + newclean <- igets insCleanup + imodify $ \s -> s { insCleanup = old } + newclean + +-- | Convert an 'InumM' computation into an 'Inum', given some +-- @'InumState'@ to run on. +runInumM :: (ChunkData tIn, ChunkData tOut, Monad m) => + InumM tIn tOut m a b + -- ^ Monadic computation defining the 'Inum'. + -> InumState tIn tOut m a + -- ^ State to run on + -> Iter tIn m (IterR tOut m a) +runInumM inumm s0 = do + (err1, s1) <- getErr =<< runIterStateT inumm s0 + (err2, s2) <- getErr =<< runIterStateT (insCleanup s1) + s1 { insAutoDone = False, insCleaning = True } + let r = insIter s2 + Iter $ maybe (Done r) (\e -> Fail e (Just r) . Just) $ mplus err2 err1 + where + 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' >> +-- 'setAutoDone' 'True'@ as the first thing inside 'mkInumM'.) +mkInumAutoM :: (ChunkData tIn, ChunkData tOut, Monad m) => + InumM tIn tOut m a b -> Inum tIn tOut m a +mkInumAutoM inumm iter0 = + runInumM inumm defaultInumState { insIter = IterF iter0 + , insAutoEOF = True + , insAutoDone = True + } + + +-- | Build an 'Inum' out of an 'InumM' computation. If you run +-- 'mkInumM' inside the @'Iter' tIn m@ monad (i.e., to create an +-- enumerator of type @'Inum' tIn tOut m a@), then the 'InumM' +-- computation will be in a Monad of type @'Iter' t tm@ where @tm@ is +-- a transformed version of @m@. This has the following two +-- consequences: +-- +-- - If you wish to execute actions in monad @m@ from within your +-- 'InumM' computation, you will have to apply @'lift'@ twice (as +-- in @'lift' $ 'lift' action_in_m@) rather than just once. +-- +-- - If you need to execute actions in the @'Iter' t m@ monad, you +-- will have to lift them with the 'liftI' function. +-- +-- The 'InumM' computation you construct can feed output of type +-- @tOut@ to the target 'Iter' (which is implicitly contained in the +-- monad state), using the 'ifeed', 'ipipe', and 'irun' functions. +mkInumM :: (ChunkData tIn, ChunkData tOut, Monad m) => + InumM tIn tOut m a b -> Inum tIn tOut m a +mkInumM inumm iter0 = + runInumM inumm defaultInumState { insIter = IterF iter0 } + +-- | Used from within the 'InumM' monad to feed data to the target +-- 'Iter'. Returns @'False'@ if the target 'Iter' is still active and +-- @'True'@ if the iter has finished and the 'Inum' should also +-- return. (If the @autoDone@ flag is @'True'@, then @ifeed@, +-- @ipipe@, and @irun@ will never actually return @'True'@, but +-- instead just immediately run cleanup functions and exit the +-- 'Inum' when the target 'Iter' stops being active.) +ifeed :: (ChunkData tIn, ChunkData tOut, Monad m) => + tOut -> InumM tIn tOut m a Bool +ifeed = ipipe . inumPure + +-- | A variant of 'ifeed' that throws an exception of type 'IterEOF' +-- if the data being fed is 'null'. Convenient when reading input +-- with a function (such as "Data.ListLike"'s @hget@) that returns 0 +-- bytes instead of throwing an EOF exception to indicate end of file. +-- For instance, the main loop of @'enumFile'@ could be implemented +-- as: +-- +-- @ +-- 'irepeat' $ 'liftIO' ('LL.hGet' h 'defaultChunkSize') >>= 'ifeed1' +-- @ +ifeed1 :: (ChunkData tIn, ChunkData tOut, Monad m) => + tOut -> InumM tIn tOut m a Bool +ifeed1 dat = if null dat then throwEOFI "ifeed1" else ifeed dat + +-- | Apply another 'Inum' to the target 'Iter' from within the 'InumM' +-- monad. As with 'ifeed', returns @'True'@ when the 'Iter' is +-- finished. +-- +-- Note that the applied 'Inum' must handle all control requests. (In +-- other words, ones it passes on are not caught by whatever handler +-- is installed by 'setCtlHandler', but if the 'Inum' returns the +-- 'IterR' in the 'IterC' state, as 'inumPure' does, then requests +-- will be handled.) +ipipe :: (ChunkData tIn, ChunkData tOut, Monad m) => + Inum tIn tOut m a -> InumM tIn tOut m a Bool +ipipe inum = do + s <- iget + r <- tryRI (liftI (inum $ reRunIter $ insIter s)) >>= getIter + >>= liftI . runIterRMC (insCtl s) + iput s { insIter = r } + let done = not $ isIterActive r + if done && insAutoDone s then idone else return done + where + getIter (Right i) = return i + getIter (Left r@(Fail _ (Just i) _)) = do + imodify $ \s -> s { insIter = i } + reRunIter r + getIter (Left r) = reRunIter r + +-- | Apply an 'Onum' (or 'Inum' of an arbitrary, unused input type) to +-- the 'Iter' from within the 'InumM' monad. As with 'ifeed', returns +-- @'True'@ when the 'Iter' is finished. +irun :: (ChunkData tAny, ChunkData tIn, ChunkData tOut, Monad m) => + Inum tAny tOut m a -> InumM tIn tOut m a Bool +irun onum = ipipe $ runI . onum + +-- | Repeats an action until the 'Iter' is done or an EOF error is +-- thrown. (Also stops if a different kind of exception is thrown, in +-- which case the exception propagates further and may cause the +-- 'Inum' to fail.) @irepeat@ sets both the /AutoEOF/ and +-- /AutoDone/ flags to @'True'@. +irepeat :: (ChunkData tIn, Monad m) => + InumM tIn tOut m a b -> InumM tIn tOut m a () +irepeat action = do + imodify $ \s -> s { insAutoEOF = True, insAutoDone = True } + let loop = action >> loop in loop + +-- | If the target 'Iter' being fed by the 'Inum' is no longer active +-- (i.e., if it is in the 'Done' state or in an error state), this +-- funciton pops the residual data out of the 'Iter' and returns it. +-- If the target is in any other state, returns 'mempty'. +ipopresid :: (ChunkData tIn, ChunkData tOut, Monad m) => + InumM tIn tOut m a tOut +ipopresid = do + s <- iget + case insIter s of + r | isIterActive r -> return mempty + | otherwise -> do let (Chunk t _) = getResid r + iput s { insIter = setResid r mempty } + return t + +-- | Immediately perform a successful exit from an 'InumM' monad, +-- terminating the 'Inum' and returning the current state of the +-- target 'Iter'. Can be used to end an 'irepeat' loop. (Use +-- @'throwI' ...@ for an unsuccessful exit.) +idone :: (ChunkData tIn, Monad m) => InumM tIn tOut m a b +idone = setAutoEOF True >> throwEOFI "idone" diff --git a/Data/IterIO/Iter.hs b/Data/IterIO/Iter.hs new file mode 100644 --- /dev/null +++ b/Data/IterIO/Iter.hs @@ -0,0 +1,1020 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} + +module Data.IterIO.Iter + (-- * Base types + ChunkData(..), Chunk(..), chunk, chunkEOF + , Iter(..), CtlCmd, CtlRes(..), CtlArg(..), IterFail(..) + , IterR(..), iterF + , isIterActive, iterShows, iterShow + -- * Execution + , run, runI + -- * Exception types + , mkIterEOF + , IterCUnsupp(..) + -- * Exception-related functions + , throwI, throwEOFI, throwParseI + , catchI, tryI, tryFI, tryRI, tryEOFI + , finallyI, onExceptionI + , tryBI, tryFBI + , ifParse, ifNoParse, multiParse + -- * Some basic Iters + , nullI, data0I, dataI, pureI, chunkI + , whileNullI, peekI, atEOFI, ungetI + , safeCtlI, ctlI + -- * Internal functions + , onDone, fmapI + , onDoneR, stepR, stepR', runR, fmapR, reRunIter, runIterR + , getResid, setResid + ) where + +import Prelude hiding (null) +import qualified Prelude +import Control.Applicative (Applicative(..), (<$), (<$>)) +import Control.Exception (SomeException(..), ErrorCall(..), Exception(..) + , try, throw) +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Trans +import Data.IORef +import Data.Maybe +import Data.Monoid +import Data.Typeable +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 System.IO.Error (mkIOError, eofErrorType, isEOFError) +import System.IO.Unsafe + +-- +-- Iteratee types and instances +-- + +-- | @ChunkData@ is the class of data types that can be output by an +-- enumerator and iterated on with an iteratee. A @ChunkData@ type +-- must be a 'Monoid', but must additionally provide a predicate, +-- @null@, for testing whether an object is equal to 'mempty'. +-- Feeding a @null@ chunk to an iteratee followed by any other chunk +-- should have the same effect as just feeding the second chunk. To +-- simplify debugging, there is an additional requirement that +-- @ChunkData@ be convertable to a String with the @chunkShow@ method. +-- +-- Note that because the "Prelude" contains a function 'Prelude.null' +-- for lists, you may wish to include the import: +-- +-- > import Prelude hiding (null) +-- +class (Monoid t) => ChunkData t where + null :: t -> Bool + chunkShow :: t -> String +instance (Show a) => ChunkData [a] where + {-# INLINE null #-} + null = Prelude.null + chunkShow = show +instance ChunkData L.ByteString where + {-# INLINE null #-} + null = L.null + chunkShow = show . L8.unpack +instance ChunkData S.ByteString where + {-# INLINE null #-} + null = S.null + chunkShow = show . S8.unpack +instance ChunkData () where + {-# INLINE null #-} + null _ = True + chunkShow _ = "()" + +-- | @Chunk@ is a wrapper around a 'ChunkData' type that also includes +-- an EOF flag that is 'True' if the data is followed by an +-- end-of-file condition. An 'Iter' that receives a @Chunk@ with EOF +-- 'True' must return a result (or failure); it is an error to demand +-- more data (return 'IterF') after an EOF. +data Chunk t = Chunk !t !Bool deriving (Eq, Typeable) + +instance (ChunkData t) => Show (Chunk t) where + showsPrec _ (Chunk t eof) rest = + chunkShow t ++ if eof then "+EOF" ++ rest else rest + +instance Functor Chunk where + {-# INLINE fmap #-} + fmap f (Chunk t eof) = Chunk (f t) eof + +instance (ChunkData t) => Monoid (Chunk t) where + {-# INLINE mempty #-} + mempty = Chunk mempty False + + {-# INLINABLE mappend #-} + mappend ca@(Chunk a eofa) cb@(Chunk b eofb) + | eofa = error $ "mappend to EOF: " ++ show ca + ++ " `mappend` " ++ show cb + | null b = Chunk a eofb -- Just an optimization for case below + | otherwise = Chunk (mappend a b) eofb + +-- | A 'Chunk' is 'null' when its data is 'null' and its EOF flag is +-- 'False'. +instance (ChunkData t) => ChunkData (Chunk t) where + {-# INLINE null #-} + null (Chunk t False) = null t + null (Chunk _ True) = False + chunkShow = show + +-- | Constructor function that builds a chunk containing data and a +-- 'False' EOF flag. +chunk :: t -> Chunk t +{-# INLINE chunk #-} +chunk t = Chunk t False + +-- | An chunk with 'mempty' data and the EOF flag 'True'. +chunkEOF :: (Monoid t) => Chunk t +{-# INLINE chunkEOF #-} +chunkEOF = Chunk mempty True + +-- | The basic Iteratee type is @Iter t m a@, where @t@ is the type of +-- input (in class 'ChunkData'), @m@ is a monad in which the iteratee +-- may execute actions (using the 'MonadTrans' 'lift' method), and @a@ +-- is the result type of the iteratee. +-- +-- Internally, an @Iter@ is a function from an input 'Chunk' to a +-- result of type 'IterR'. +newtype Iter t m a = Iter { runIter :: Chunk t -> IterR t m a } + +-- | Builds an 'Iter' that keeps requesting input until it receives a +-- non-'null' 'Chunk'. In other words, the 'Chunk' fed to the +-- argument function is guaranteed either to contain data or to have +-- the EOF flag true (or both). +iterF :: (ChunkData t) => (Chunk t -> IterR t m a) -> Iter t m a +{-# INLINE iterF #-} +iterF f = loop + where loop = Iter $ \c -> if null c then IterF $ loop else f c + +-- | Class of control commands for enclosing enumerators. The class +-- binds each control argument type to a unique result type. +class (Typeable carg, Typeable cres) => CtlCmd carg cres | carg -> cres + +-- | The outcome of an 'IterC' request. +data CtlRes a = CtlUnsupp + -- ^ The request type was not supported by the enumerator. + | CtlFail !SomeException + -- ^ The request was supported, and executing it caused + -- an exception to be thrown. + | CtlDone !a + -- ^ The result of the control operation. + deriving (Typeable) + +-- | Used when an 'Iter' is issuing a control request to an enclosing +-- enumerator. Note that unlike 'IterF' or 'IterM', control requests +-- expose the residual data, which is ordinarily fed right back to the +-- continuation upon execution of the request. This allows certain +-- control operations (such as seek and tell) to flush, check the +-- length of, or adjust the residual data. +data CtlArg t m a = forall carg cres. (CtlCmd carg cres) => + CtlArg !carg (CtlRes cres -> Iter t m a) (Chunk t) + +-- | Contains information about a failed 'Iter'. Failures of type +-- 'IterException' must be caught by 'catchI' (or 'tryI', etc.). +-- However, any other type of failure is considered a parse error, and +-- will be caught by 'multiParse', 'ifParse', and 'mplus'. +data IterFail = IterException !SomeException + -- ^ An actual error occured that is not a parse error, + -- EOF, etc. + | IterExpected [(String, String)] + -- ^ List of @(input_seen, input_expected)@ pairs. + | IterEOFErr IOError + -- ^ An EOF error occurred, either in some IO action + -- wrapped by 'liftIO', or in some 'Iter' that called + -- 'throwEOFI'. + | IterParseErr String + -- ^ A miscellaneous parse error occured. + | IterMzero + -- ^ What you get from 'mzero'. Useful if you don't + -- want to specify any information about the failure. + deriving (Typeable) + +instance Show IterFail where + showsPrec _ (IterException e) rest = shows e rest + showsPrec _ (IterExpected swl) rest = + "Input failed to match all expectations\n" ++ fmt swl + where fmt [] = rest + fmt ((saw, expected):t) = + " expected " ++ show expected ++ ", saw " + ++ (take 50 $ show saw) ++ "\n" ++ fmt t + showsPrec _ (IterEOFErr e) rest = "IterEOFErr: " ++ shows e rest + showsPrec _ (IterParseErr e) rest = "IterParseErr: " ++ e ++ rest + showsPrec _ IterMzero rest = "IterMZero" ++ rest + +instance Exception IterFail where + {-# INLINE toException #-} + toException (IterException e) = e + toException (IterEOFErr e) = toException e + toException e = SomeException e + +-- | An @IterR@ is the result of feeding a chunk of data to an 'Iter'. +-- An @IterR@ is in one of several states: it may require more input +-- ('IterF'), it may wish to execute monadic actions in the +-- transformed monad ('IterM'), it may have a control request for an +-- enclosing enumerator ('IterC'), it may have produced a result +-- ('Done'), or it may have failed ('Fail'). +data IterR t m a = IterF !(Iter t m a) + -- ^ The iteratee requires more input. + | IterM !(m (IterR t m a)) + -- ^ The iteratee must execute monadic bind in monad @m@ + | IterC !(CtlArg t m a) + -- ^ A control request (see 'CtlArg'). + | Done a (Chunk t) + -- ^ Sufficient input was received; the 'Iter' is + -- returning a result of type @a@. In adition, the + -- 'IterR' has a 'Chunk' containing any residual + -- input that was not consumed in producing the + -- result. + | Fail !IterFail !(Maybe a) !(Maybe (Chunk t)) + -- ^ The 'Iter' failed. If it was an enumerator, the + -- target 'Iter' that the enumerator was feeding + -- likely has not failed, in which case its current + -- state is returned in the @Maybe a@. If it makes + -- sense to preserve the state of the input stream + -- (which it does for most errors except parse + -- errors), then the third parameter includes the + -- residual 'Chunk' at the time of the failure. + +-- | True if an 'IterR' is requesting something from an +-- enumerator--i.e., the 'IterR' is not 'Done' or 'Fail'. +isIterActive :: IterR t m a -> Bool +{-# INLINE isIterActive #-} +isIterActive (IterF _) = True +isIterActive (IterM _) = True +isIterActive (IterC _) = True +isIterActive _ = False + +-- | Show the current state of an 'IterR', prepending it to some +-- remaining input (the standard 'ShowS' optimization), when 'a' is in +-- class 'Show'. Note that if @a@ is not in 'Show', you can simply +-- use the 'shows' function. +iterShows :: (ChunkData t, Show a) => IterR t m a -> ShowS +iterShows (IterC (CtlArg a _ c)) rest = + "IterC " ++ (shows (typeOf a) $ " _ " ++ shows c rest) +iterShows (Done a c) rest = "Done " ++ (shows a $ " " ++ shows c rest) +iterShows (Fail e a c) rest = + "Fail " ++ (shows e $ " (" ++ (shows a $ ") " ++ shows c rest)) +iterShows iter rest = shows iter rest + +-- | Show the current state of an 'Iter' if type @a@ is in the 'Show' +-- class. (Otherwise, you can simply use the ordinary 'show' +-- function.) +iterShow :: (ChunkData t, Show a) => IterR t m a -> String +iterShow iter = iterShows iter "" + +instance (ChunkData t) => Show (IterR t m a) where + showsPrec _ (IterF _) rest = "IterF _" ++ rest + showsPrec _ (IterM _) rest = "IterM _" ++ rest + showsPrec _ (IterC (CtlArg a _ c)) rest = + "IterC " ++ (shows (typeOf a) $ " _" ++ shows c rest) + showsPrec _ (Done _ c) rest = "Done _ " ++ shows c rest + showsPrec _ (Fail e a c) rest = + "Fail " ++ (shows e $ + (if isJust a then " Just _ " else " Nothing ") + ++ shows c rest) + +iterTc :: TyCon +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 + m :: Iter t m a -> m (); m _ = undefined + +instance (Typeable t, Typeable1 m, Typeable a) => Typeable (Iter t m a) where + typeOf = typeOfDefault + +instance (Monad m) => Functor (Iter t m) where + {-# INLINE fmap #-} + fmap = fmapI + +-- | @fmapI@ is like 'liftM', but differs in one important respect: +-- it preserves the failed result of an enumerator (and in fact +-- applies the function to the non-failed target 'Iter' state). By +-- contrast, 'liftM', which is equivalent to @'liftM' f i = i '>>=' +-- 'return' . f@, transforms the @'Maybe' a@ component of all 'Fail' +-- states to 'Nothing' because of its use of '>>='. +fmapI :: (Monad m) => (a -> b) -> Iter t m a -> Iter t m b +{-# INLINE fmapI #-} +fmapI = onDone . fmapR + +-- | Maps the result of an 'IterR' like 'fmap', but only if the +-- 'IterR' is no longer active. It is an error to call this function +-- on an 'IterR' in the 'IterF', 'IterM', or 'IterC' state. Because +-- of this restriction, @fmapR@ does not require the input and output +-- 'Monad' types (@m1@ and @m2@) to be the same. +fmapR :: (a -> b) -> IterR t m1 a -> IterR t m2 b +{-# INLINE fmapR #-} +fmapR f (Done a c) = Done (f a) c +fmapR f (Fail e a c) = Fail e (fmap f a) c +fmapR _ (IterF _) = error "fmapR (IterF)" +fmapR _ (IterM _) = error "fmapR (IterM)" +fmapR _ (IterC _) = error "fmapR (IterC)" + +instance (Monad m) => Functor (IterR t m) where + fmap = onDoneR . fmapR + +instance (Monad m) => Applicative (Iter t m) where + pure = return + (<*>) = ap + (*>) = (>>) + a <* b = do r <- a; b >> return r + +instance (Monad m) => Monad (Iter t m) where + {-# INLINE return #-} + return a = Iter $ Done a + + {-# INLINE (>>=) #-} + -- Because check calls itself and (>>=) recursively, IterF and + -- IterM likely cannot be inlined. However, inlining Done and + -- Fail (which can occur quite often for parsing failures) in the + -- first part of this function seems to give about a 1-2% speedup. + m >>= k = Iter $ \c0 -> case runIter m c0 of + (Done a c) -> runIter (k a) c + (Fail e _ c) -> Fail e Nothing c + r -> check r + where check (IterM mm) = IterM $ mm >>= return . check + check (IterF i) = IterF $ i >>= k + check (IterC (CtlArg a n c)) = IterC $ CtlArg a (n >=> k) c + check (Fail e _ c) = Fail e Nothing c + check (Done a c) = runIter (k a) c + + fail msg = Iter $ Fail (IterException $ toException $ ErrorCall msg) + Nothing . Just + +instance (ChunkData t, Monad m) => MonadPlus (Iter t m) where + {-# INLINE mzero #-} + mzero = Iter $ const $ Fail IterMzero Nothing Nothing + mplus a b = ifParse a return b + +instance MonadTrans (Iter t) where + {-# INLINE lift #-} + lift m = Iter $ \c -> IterM $ m >>= \a -> return $ Done a c + +-- | The 'Iter' instance of 'MonadIO' handles errors specially. If +-- the lifted operation throws an exception, 'liftIO' catches the +-- exception and returns it as an 'IterFail' failure. If the +-- exception is an 'IOError' satisfying 'isEOFError', then the +-- exception is wrapped in the 'IterEOFErr' constructor; otherwise, it +-- is wrapped in 'IterException' otherwise. This approach allows +-- efficient testing for EOF errors without the need to invoke the +-- expensive 'cast' or 'fromException' operations. (Yes @liftIO@ uses +-- these expensive operations, but 'Iter's that invoke 'throwEOFI' do +-- not.) +-- +-- One consequence of this exception handling is that with 'Iter', +-- unlike with most monad transformers, 'liftIO' is /not/ equivalent +-- to some number of nested calls to 'lift'. See the documentation of +-- '.|$' for an example. +instance (MonadIO m) => MonadIO (Iter t m) where + liftIO m = Iter $ \c -> IterM $ liftIO $ do + result <- try m + case result of + Right ok -> return $ Done ok c + Left se -> return $ case fromException se of + Just e | isEOFError e -> Fail (IterEOFErr e) Nothing (Just c) + _ -> Fail (IterException se) Nothing (Just c) + +-- | This is a generalization of 'fixIO' for arbitrary members of the +-- 'MonadIO' class. +fixMonadIO :: (MonadIO m) => (a -> m a) -> m a +fixMonadIO f = do + ref <- liftIO $ newIORef $ throw $ toException + $ ErrorCall "fixMonadIO: non-termination" + a <- liftIO $ unsafeInterleaveIO $ readIORef ref + r <- f a + liftIO $ writeIORef ref r + return r + +instance (MonadIO m) => MonadFix (Iter t m) where + mfix = fixMonadIO + +-- +-- Core functions +-- + +-- | Feed an EOF to an 'Iter' and return the result. Throws an +-- exception if there has been a failure. +run :: (ChunkData t, Monad m) => Iter t m a -> m a +run i0 = check $ runIter i0 chunkEOF + where check (Done a _) = return a + check (IterF i) = run i + check (IterM m) = m >>= check + check (IterC (CtlArg _ n c)) = check $ runIter (n CtlUnsupp) c + check (Fail (IterException e) _ _) = throw e + check (Fail e _ _) = throw e + +-- | The equivalent for 'runI' for 'IterR's. +runR :: (ChunkData t1, ChunkData t2, Monad m) => IterR t1 m a -> IterR t2 m a +{-# INLINABLE runR #-} +runR (Done a _) = Done a mempty +runR (IterF i) = runR $ runIter i chunkEOF +runR (IterM m) = IterM $ liftM runR m +runR (IterC (CtlArg _ n c)) = runR $ runIter (n CtlUnsupp) c +runR (Fail e a c) = Fail e a $ mempty <$ c + +-- | Runs an 'Iter' from within a different 'Iter' monad. If +-- successful, @runI iter@ will produce the same result as @'lift' +-- ('run' iter)@. However, if @iter@ fails, 'run' throws a +-- language-level exception, which cannot be caught within other +-- 'Iter' monads. By contrast, @runI@ throws a monadic exception that +-- can be caught. In short, use @runI@ in preference to @run@ in +-- situations where both are applicable. See a more detailed +-- discussion of the same issue with examples in the documentation for +-- @'.|$'@ in "Data.IterIO.Inum". +runI :: (ChunkData t1, ChunkData t2, Monad m) => Iter t1 m a -> Iter t2 m a +{-# INLINABLE runI #-} +runI i = Iter $ runIterR (runR $ runIter i chunkEOF) + +-- +-- Exceptions +-- + +-- | Make an 'IterEOFErr' from a String. +mkIterEOF :: String -> IterFail +mkIterEOF loc = IterEOFErr $ mkIOError eofErrorType loc Nothing Nothing + +-- | Exception thrown by 'CtlI' when the type of the control request +-- is not supported by the enclosing enumerator. +data IterCUnsupp = forall carg cres. (CtlCmd carg cres) => + IterCUnsupp carg deriving (Typeable) +instance Show IterCUnsupp where + showsPrec _ (IterCUnsupp carg) rest = + "Unsupported control request " ++ shows (typeOf carg) rest +instance Exception IterCUnsupp + + +-- +-- Exception functions +-- +-- | Throw an exception from an Iteratee. The exception will be +-- propagated properly through nested Iteratees, which will allow it +-- to be categorized properly and avoid situations in which resources +-- such as file handles are not released. (Most iteratee code does +-- not assume the Monad parameter @m@ is in the 'MonadIO' class, and +-- hence cannot use 'catch' or @'onException'@ to clean up after +-- exceptions.) Use 'throwI' in preference to 'throw' whenever +-- possible. +-- +-- Do not use @throwI@ to throw parse errors or EOF errors. Use +-- 'throwEOFI' and 'throwParseI' instead. For performance reasons, +-- the 'IterFail' type segregates EOF and parse errors from other +-- types of failures. +throwI :: (Exception e) => e -> Iter t m a +throwI e = Iter $ Fail (IterException $ toException e) Nothing . Just + +-- | Throw an exception of type 'IterEOF'. This will be interpreted +-- by 'mkInum' as an end of file chunk when thrown by the codec. It +-- will also be interpreted by 'ifParse' and 'multiParse' as parsing +-- failure. If not caught within the 'Iter' monad, the exception will +-- be rethrown by 'run' (and hence '|$') as an 'IOError' of type EOF. +throwEOFI :: String -> Iter t m a +{-# INLINE throwEOFI #-} +throwEOFI s = Iter $ Fail (mkIterEOF s) Nothing . Just + +-- | Throw a miscellaneous parse error (after which input is assumed +-- to be unsynchronized and thus is discarded). Parse errors may be +-- caught as exception type 'IterFail', but they can also be caught +-- more efficiently by the functions 'multiParse', 'ifParse', and +-- 'mplus'. +throwParseI :: String -> Iter t m a +{-# INLINE throwParseI #-} +throwParseI s = Iter $ \_ -> Fail (IterParseErr s) Nothing Nothing + +-- | Run an 'Iter'. Catch any exception it throws (and return the +-- failing iter state). Transform successful results with a function. +-- +-- This function is slightly more general than 'catchI'. For +-- instance, we can't implement 'tryI' in terms of just 'catchI'. +-- Something like +-- +-- > tryI iter = catchI (iter >>= return . Right) ... +-- +-- would remove the possibly unfailed 'Iter' state from failed 'Inum' +-- results, because the '>>=' operator has this effect. (I.e., if +-- @iter@ is @'Fail' e ('Just' i) c@, the expression @iter >>= return +-- . Right@ will be @'Fail' e Nothing c@.) This could be particularly +-- bad in cases where the exception is not even of a type caught by +-- the 'tryI' expression. +-- +-- Similarly, trying to implement 'catchI' in terms of 'tryI' doesn't +-- quite work. Something like +-- +-- > catchI iter handler = tryI iter >>= either (uncurry handler) return +-- +-- would erase state from 'Inum' failures /not/ caught by the handler. +genCatchI :: (ChunkData t, Monad m, Exception e) => + Iter t m a + -- ^ 'Iter' that might throw an exception + -> (e -> IterR t m a -> Iter t m b) + -- ^ Exception handler + -> (a -> b) + -- ^ Conversion function for result and 'InumFail' errors. + -> Iter t m b +genCatchI iter0 handler conv = onDone check iter0 + where check (Done a c) = Done (conv a) c + check r@(Fail e0 _ _) = + case fromException $ toException e0 of + Just e -> runIter (handler e $ setResid r mempty) (getResid r) + Nothing -> fmap conv r + check _ = error "genCatchI" + +-- | Catch an exception thrown by an 'Iter', including exceptions +-- thrown by any 'Inum's fused to the 'Iter' (or applied to it with +-- '.|$'). If you wish to catch just errors thrown within 'Inum's, +-- see the function @'inumCatch'@ in "Data.IterIO.Inum". +-- +-- On exceptions, @catchI@ invokes a handler passing it both the +-- exception thrown and the state of the failing 'IterR', which may +-- contain more information than just the exception. In particular, +-- if the exception occured in an 'Inum', the returned 'IterR' will +-- also contain the 'IterR' being fed by that 'Inum', which likely +-- will not have failed. To avoid discarding this extra information, +-- you should not re-throw exceptions with 'throwI'. Rather, you +-- should re-throw an exception by re-executing the failed 'IterR' +-- with 'reRunIter'. For example, a possible definition of +-- 'onExceptionI' is: +-- +-- @ +-- onExceptionI iter cleanup = +-- iter \`catchI\` \\('SomeException' _) r -> cleanup >> 'reRunIter' r +-- @ +-- +-- Note that @catchI@ only works for /synchronous/ exceptions, such as +-- IO errors (thrown within 'liftIO' blocks), the monadic 'fail' +-- operation, and exceptions raised by 'throwI'. It is not possible +-- to catch /asynchronous/ exceptions, such as lazily evaluated +-- divide-by-zero errors, the 'throw' function, or exceptions raised +-- by other threads using @'throwTo'@ if those exceptions might arrive +-- anywhere outside of a 'liftIO' call. +-- +-- @\`catchI\`@ has the default infix precedence (@infixl 9 +-- \`catchI\`@), which binds more tightly than any concatenation or +-- fusing operators. +catchI :: (Exception e, ChunkData t, Monad m) => + Iter t m a + -- ^ 'Iter' that might throw an exception + -> (e -> IterR t m a -> Iter t m a) + -- ^ Exception handler, which gets as arguments both the + -- exception and the failing 'Iter' state. + -> Iter t m a +{-# INLINE catchI #-} +catchI iter handler = genCatchI iter handler id + +-- | 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'. +tryI :: (ChunkData t, Monad m, Exception e) => + Iter t m a -> Iter t m (Either (e, IterR t m a) a) +{-# INLINE tryI #-} +tryI iter = genCatchI iter (curry $ return . Left) Right + +-- | A version of 'tryI' that catches all exceptions. Instead of +-- returning the exception caught, it returns the failing 'IterR' +-- (from which you can extract the exception if you really want it). +-- The main use of this is for doing some kind of clean-up action, +-- then re-throwing the exception with 'reRunIter'. +-- +-- For example, the following is a possible implementation of 'finallyI': +-- +-- > finallyI iter cleanup = do +-- > er <- tryRI iter +-- > cleanup +-- > either reRunIter return er +tryRI :: (ChunkData t, Monad m) => + Iter t m a -> Iter t m (Either (IterR t m a) a) +tryRI = onDone check + where check (Fail e a c) = Done (Left $ Fail e a $ Just mempty) $ + fromMaybe mempty c + check r = Right <$> r + +-- | A variant of 'tryI' that just catches EOF errors. Returns +-- 'Nothing' after an EOF error, and 'Just' the result otherwise. +-- Should be much faster than trying to catch an EOF error of type +-- 'Exception'. +tryEOFI :: (ChunkData t, Monad m) => + Iter t m a -> Iter t m (Maybe a) +tryEOFI = onDone check + where check (Fail (IterEOFErr _) _ c) = Done Nothing $ fromMaybe mempty c + check r = Just <$> r + +-- | A varient of 'tryI' that returns the 'IterFail' state rather than +-- trying to match a particular exception. +tryFI :: (ChunkData t, Monad m) => + Iter t m a -> Iter t m (Either IterFail a) +tryFI = onDone check + where check (Fail e _ c) = Done (Left e) $ fromMaybe mempty c + check r = Right <$> r + +-- | Execute an 'Iter', then perform a cleanup action regardless of +-- whether the 'Iter' threw an exception or not. Analogous to the +-- standard library function @'finally'@. +finallyI :: (ChunkData t, Monad m) => + Iter t m a -> Iter t m b -> Iter t m a +finallyI iter cleanup = do er <- tryRI iter + cleanup >> either reRunIter return er + +-- | Execute an 'Iter' and perform a cleanup action if the 'Iter' +-- threw an exception. Analogous to the standard library function +-- @'onException'@. +onExceptionI :: (ChunkData t, Monad m) => + Iter t m a -> Iter t m b -> Iter t m a +onExceptionI iter cleanup = + catchI iter $ \(SomeException _) r -> cleanup >> reRunIter r + +-- | Simlar to 'tryI', but saves all data that has been fed to the +-- 'Iter', and rewinds the input if the 'Iter' fails. (The @B@ in +-- @tryBI@ stands for \"backtracking\".) Thus, if @tryBI@ returns +-- @'Left' exception@, the next 'Iter' to be invoked will see the same +-- input that caused the previous 'Iter' to fail. (For this reason, +-- it makes no sense ever to call @'resumeI'@ on the 'Iter' you get +-- back from @tryBI@, which is why @tryBI@ does not return the failing +-- Iteratee the way 'tryI' does.) +-- +-- Because @tryBI@ saves a copy of all input, it can consume a lot of +-- memory and should only be used when the 'Iter' argument is known to +-- consume a bounded amount of data. +tryBI :: (ChunkData t, Monad m, Exception e) => + Iter t m a -> Iter t m (Either e a) +tryBI = onDoneInput errToEither + where errToEither (Done a c) _ = Done (Right a) c + errToEither r@(Fail ie _ _) c = + case fromException $ toException ie of + Just e -> Done (Left e) c + Nothing -> Right <$> r + errToEither _ _ = error "tryBI" + +-- | A variant of 'tryBI' that, also rewinds input on failure, but +-- returns the raw 'IterFail' structure, rather than mapping it to a +-- particular exception. This is much faster because it requires no +-- dynamic casts. However, the same warning applies that @tryFBI@ +-- should not be applied to 'Iter's that could take unbounded input. +tryFBI :: (ChunkData t, Monad m) => + Iter t m a -> Iter t m (Either IterFail a) +tryFBI = onDoneInput check + where check (Done a c) _ = Done (Right a) c + check (Fail e _ _) c = Done (Left e) c + check _ _ = error "tryFBI" + +{- +mapIterFail :: (ChunkData t, Monad m) => + (IterFail -> IterFail) -> Iter t m a -> Iter t m a +mapIterFail f = onDone check + where check (Fail e a c) = Fail (f e) a c + check r = r +-} + +-- | Run an Iteratee, and if it throws a parse error by calling +-- 'expectedI', then combine the exptected tokens with those of a +-- previous parse error. +combineExpected :: (ChunkData t, Monad m) => + IterFail + -- ^ Previous parse error + -> IterR t m a + -- ^ Result of second 'Iter'--if it fails the error + -- should be combined with the first error + -> IterR t m a +combineExpected _ r@(Done _ _) = r +combineExpected (IterExpected l1) (Fail (IterExpected l2) _ _) = + Fail (IterExpected $ l1 ++ l2) Nothing Nothing +combineExpected _ r@(Fail (IterExpected _) _ _) = r +combineExpected e _ = Fail e Nothing Nothing + +-- | Try two Iteratees and return the result of executing the second +-- if the first one throws a parse, EOF, or 'mzero' error. Note that +-- "Data.IterIO.Parse" defines @'<|>'@ as an infix synonym for this +-- function. +-- +-- The statement @multiParse a b@ is similar to @'ifParse' a return +-- b@, but the two functions operate differently. Depending on the +-- situation, only one of the two formulations may be correct. +-- Specifically: +-- +-- * @'ifParse' a f b@ works by first executing @a@, saving a copy of +-- all input consumed by @a@. If @a@ throws a parse error, the +-- saved input is used to backtrack and execute @b@ on the same +-- input that @a@ just rejected. If @a@ succeeds, @b@ is never +-- run; @a@'s result is fed to @f@, and the resulting action is +-- executed without backtracking (so any error thrown within @f@ +-- will not be caught by this 'ifParse' expression). +-- +-- * Instead of saving input, @multiParse a b@ executes both @a@ and +-- @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. +-- +-- * With @multiParse a b@, if @b@ returns a value, executes a +-- monadic action via 'lift', or issues a control request via +-- 'ctlI', then further processing of @b@ will be suspended until +-- @a@ experiences a parse error, and thus the behavior will be +-- equivalent to @'ifParse' a return b@. +-- +-- The main restriction on 'ifParse' is that @a@ must not consume +-- unbounded amounts of input, or the program may exhaust memory +-- saving the input for backtracking. Note that the second argument +-- to 'ifParse' (i.e., 'return' in @ifParse a return b@) is a +-- continuation for @a@ when @a@ succeeds. +-- +-- The advantage of @multiParse@ is that it can avoid storing +-- unbounded amounts of input for backtracking purposes if both +-- 'Iter's consume data. Another advantage is that with an expression +-- such as @'ifParse' a f b@, sometimes it is not convenient to break +-- the parse target into an action to execute with backtracking (@a@) +-- and a continuation to execute without backtracking (@f@). The +-- equivalent @multiParse (a >>= f) b@ avoids the need to do this, +-- since it does not do backtracking. +-- +-- However, it is important to note that it is still possible to end +-- up storing unbounded amounts of input with @multiParse@. For +-- example, consider the following code: +-- +-- > total :: (Monad m) => Iter String m Int +-- > total = multiParse parseAndSumIntegerList (return -1) -- Bad +-- +-- Here the intent is for @parseAndSumIntegerList@ to parse a +-- (possibly huge) list of integers and return their sum. If there is +-- a parse error at any point in the input, then the result is +-- identical to having defined @total = return -1@. But @return -1@ +-- succeeds immediately, consuming no input, which means that @total@ +-- must return all left-over input for the next action (i.e., @next@ +-- in @total >>= next@). Since @total@ has to look arbitrarily far +-- into the input to determine that @parseAndSumIntegerList@ fails, in +-- practice @total@ will have to save all input until it knows that +-- @parseAndSumIntegerList@ succeeds. +-- +-- A better approach might be: +-- +-- @ +-- total = multiParse parseAndSumIntegerList ('nullI' >> return -1) +-- @ +-- +-- Here 'nullI' discards all input until an EOF is encountered, so +-- there is no need to keep a copy of the input around. This makes +-- sense so long as @total@ is the last or only Iteratee run on the +-- input stream. (Otherwise, 'nullI' would have to be replaced with +-- an Iteratee that discards input up to some end-of-list marker.) +-- +-- Another approach might be to avoid parsing combinators entirely and +-- use: +-- +-- @ +-- total = parseAndSumIntegerList ``catchI`` handler +-- where handler \('IterNoParse' _) _ = return -1 +-- @ +-- +-- This last definition of @total@ may leave the input in some +-- partially consumed state. This is fine so long as @total@ is the +-- last 'Iter' executed on the input stream. Otherwise, before +-- throwing the parse error, @parseAndSumIntegerList@ would need to +-- ensure the input is at some reasonable boundary point for whatever +-- comes next. (The 'ungetI' function is sometimes helpful for this +-- purpose.) +multiParse :: (ChunkData t, Monad m) => + Iter t m a -> Iter t m a -> Iter t m a +multiParse a b = Iter $ \c -> check (runIter a c) (runIter b c) + where + check ra@(Done _ _) _ = ra + check (IterF ia) (IterF ib) = IterF $ multiParse ia ib + 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 + (Fail (IterException _) _ _) -> ra + (Fail e _ _) -> onDoneR (combineExpected e) rb + _ -> error "multiParse" + +-- | @ifParse iter success failure@ runs @iter@, but saves a copy of +-- all input consumed using 'tryFBI'. (This means @iter@ must not +-- consume unbounded amounts of input! See 'multiParse' for such +-- cases.) If @iter@ succeeds, its result is passed to the function +-- @success@. If @iter@ throws a parse error (with 'throwParseI'), +-- throws an EOF error (with 'throwEOFI'), or executes 'mzero', then +-- @failure@ is executed with the input re-wound (so that @failure@ is +-- fed the same input that @iter@ was). If @iter@ throws any other +-- type of exception, @ifParse@ passes the exception back and does not +-- execute @failure@. +-- +-- See "Data.IterIO.Parse" for a discussion of this function and the +-- related infix operator @\\/@ (which is a synonym for 'ifNoParse'). +ifParse :: (ChunkData t, Monad m) => + Iter t m a + -- ^ Iteratee @iter@ to run with backtracking + -> (a -> Iter t m b) + -- ^ @success@ function + -> Iter t m b + -- ^ @failure@ action + -> Iter t m b + -- ^ result +ifParse iter yes no = tryFBI iter >>= check + where check (Right a) = yes a + check (Left (IterException e)) = throwI e + check (Left e) = onDone (combineExpected e) no + + +-- | @ifNoParse@ is just 'ifParse' with the second and third arguments +-- reversed. +ifNoParse :: (ChunkData t, Monad m) => + Iter t m a -> Iter t m b -> (a -> Iter t m b) -> Iter t m b +{-# INLINE ifNoParse #-} +ifNoParse iter no yes = ifParse iter yes no + + +-- +-- Some super-basic Iteratees +-- + +-- | Sinks data like @\/dev\/null@, returning @()@ on EOF. +nullI :: (Monad m, ChunkData t) => Iter t m () +nullI = Iter $ \(Chunk _ eof) -> + if eof then Done () chunkEOF else IterF nullI + +-- | Returns a non-empty amount of input data if there is any input +-- left. Returns 'mempty' on an EOF condition. +data0I :: (ChunkData t) => Iter t m t +{-# INLINE data0I #-} +data0I = iterF $ \(Chunk d eof) -> Done d (Chunk mempty eof) + +-- | Like 'data0I', but always returns non-empty data. Throws an +-- exception on an EOF condition. +dataI :: (ChunkData t) => Iter t m t +{-# INLINE dataI #-} +dataI = iterF nextChunk + where nextChunk c@(Chunk d True) | null d = Fail eoferr Nothing (Just c) + nextChunk (Chunk d eof) = Done d (Chunk mempty eof) + eoferr = mkIterEOF "dataI" + +-- | A variant of 'data0I' that reads the whole input up to an EOF and +-- returns it. +pureI :: (Monad m, ChunkData t) => Iter t m t +pureI = do peekI nullI; Iter $ \(Chunk t _) -> Done t chunkEOF + +-- | Returns the next 'Chunk' that either contains non-'null' data or +-- has the EOF bit set. +chunkI :: (Monad m, ChunkData t) => Iter t m (Chunk t) +{-# INLINE chunkI #-} +chunkI = iterF $ \c@(Chunk _ eof) -> Done c (Chunk mempty eof) + +-- | 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 +-- (i.e., usually non-'null') iteration. +whileNullI :: (ChunkData tIn, ChunkData tOut, Monad m) => + Iter tIn m tOut -> Iter tIn m tOut +whileNullI iter = loop + where loop = do buf <- iter + if null buf + then do eof <- atEOFI + if eof then return buf else loop + else return buf + +-- | Runs an 'Iter' then rewinds the input state, so that the effect +-- is to parse lookahead data. (See 'tryBI' if you want to rewind the +-- input only when the 'Iter' fails.) +peekI :: (ChunkData t, Monad m) => Iter t m a -> Iter t m a +peekI = onDoneInput setResid + +-- | Does not actually consume any input, but returns 'True' if there +-- is no more input data to be had. +atEOFI :: (Monad m, ChunkData t) => Iter t m Bool +atEOFI = iterF $ \c@(Chunk t _) -> Done (null t) c + +-- | Place data back onto the input stream, where it will be the next +-- data consumed by subsequent 'Iter's. +ungetI :: (ChunkData t) => t -> Iter t m () +{-# INLINE ungetI #-} +ungetI t = Iter $ \c -> Done () (mappend (chunk t) c) + +-- | Issue a control request. Returns 'CtlUnsupp' if the request type +-- is unsupported. Otherwise, returns 'CtlDone' with the result if +-- the request succeeds, or return @'CtlFail'@ if the request type is +-- supported but attempting to execute the request caused an +-- exception. +safeCtlI :: (CtlCmd carg cres, Monad m) => + carg -> Iter t m (CtlRes cres) +safeCtlI carg = Iter $ IterC . CtlArg carg return + +-- | Issue a control request and return the result. Throws an +-- exception of type 'IterCUnsupp' if the operation type was not +-- supported by an enclosing enumerator. +ctlI :: (CtlCmd carg cres, ChunkData t, Monad m) => + carg -> Iter t m cres +ctlI carg = do + res <- safeCtlI carg + case res of + CtlUnsupp -> throwI $ IterCUnsupp carg + CtlFail e -> throwI e + CtlDone cres -> return cres + +-- +-- Iter manipulation functions +-- + +-- | A variant of 'stepR' that only works for the 'IterF' and 'IterC' +-- states, not the 'IterM' state. (Because of this additional +-- restriction, the input and output 'Monad' types @m1@ and @m2@ do +-- not need to be the same.) +stepR' :: IterR t m1 a + -- ^ The 'IterR' that needs to be stepped. + -> (IterR t m1 a -> IterR t m2 b) + -- ^ Transformation function if the 'IterR' is in the 'IterF' + -- or 'IterC' state. + -> IterR t m2 b + -- ^ Fallback if the 'IterR' is no longer active. + -> IterR t m2 b +{-# INLINE stepR' #-} +stepR' (IterF (Iter i)) f _ = IterF $ Iter $ f . i +stepR' (IterC (CtlArg a n c)) f _ = + IterC $ CtlArg a (Iter . (f .) . runIter . n) c +stepR' (IterM _) _ _ = error "stepR' (IterM)" +stepR' _ _ notActive = notActive + +-- | Step an active 'IterR' (i.e., one in the 'IterF', 'IterM', or +-- 'IterC' state) to its next state, and pass the result through a +-- function. +stepR :: (Monad m) => + IterR t m a + -- ^ The 'Iter' that needs to be stepped + -> (IterR t m a -> IterR t m b) + -- ^ Function to pass the 'Iter' to after stepping it. + -> IterR t m b + -- ^ Fallback if the 'Iter' can no longer be stepped + -> IterR t m b +{-# INLINE stepR #-} +stepR (IterM m) f _ = IterM $ liftM f m +stepR r f notActive = stepR' r f notActive + +-- | The equivalent of 'onDone' for 'IterR's. +onDoneR :: (Monad m) => + (IterR t m a -> IterR t m b) -> IterR t m a -> IterR t m b +{-# INLINE onDoneR #-} +onDoneR f = check + where check r = stepR r check $ f r + +-- | Run an 'Iter' until it enters the 'Done' or 'Fail' state, then +-- use a function to transform the 'IterR'. +{-# INLINE onDone #-} +onDone :: (Monad m) => + (IterR t m a -> IterR t m b) -> Iter t m a -> Iter t m b +onDone f i = Iter $ onDoneR f . runIter i + +-- | Like 'onDone', but also keeps a copy of all input consumed. (The +-- residual input on the 'IterR' returned will be a suffix of the +-- input returned.) +onDoneInput :: (ChunkData t, Monad m) => + (IterR t m a -> Chunk t -> IterR t m b) + -> Iter t m a + -> Iter t m b +{-# INLINABLE onDoneInput #-} +onDoneInput f = Iter . next id + where next acc iter c = + let check (IterF i) = IterF $ Iter $ next (acc . mappend c) i + check r = stepR r check $ f r (acc c) + in check $ runIter iter c + + + +-- | Get the residual data for an 'IterR' that is in no longer active +-- or that is in the 'IterC' state. (It is an error to call this +-- function on an 'IterR' in the 'IterF' or 'IterM' state.) +getResid :: (ChunkData t) => IterR t m a -> Chunk t +{-# INLINABLE getResid #-} +getResid (Done _ c) = c +getResid (Fail _ _ c) = fromMaybe mempty c +getResid (IterC (CtlArg _ _ c)) = c +getResid (IterF _) = error "getResid (IterF)" +getResid (IterM _) = error "getResid (IterM)" + +-- | Set residual data for an 'IterR' that is not active. (It is an +-- error to call this on an 'IterR' in the 'Done', 'IterM', or 'IterC' +-- states.) +setResid :: IterR t1 m1 a -> Chunk t2 -> IterR t2 m2 a +{-# INLINABLE setResid #-} +setResid (Done a _) = Done a +setResid (Fail e a _) = Fail e a . Just +setResid (IterF _) = error "setResid (IterF)" +setResid (IterM _) = error "setResid (IterM)" +setResid (IterC _) = error "setResid (IterC)" + +-- | Feed more input to an 'Iter' that has already been run (and hence +-- is already an 'IterR'). In the event that the 'IterR' is +-- requesting more input (i.e., is in the 'IterF' state), this is +-- straight forward. However, if the 'Iter' is in some other state +-- such as 'IterM', this function needs to save the input until such +-- time as the 'IterR' is stepped to a new state (e.g., with 'stepR' +-- or 'reRunIter'). +runIterR :: (ChunkData t, Monad m) => IterR t m a -> Chunk t -> IterR t m a +{-# INLINABLE runIterR #-} +runIterR r c = if null c then r else check r + where check (Done a c0) = Done a (mappend c0 c) + check (IterF i) = runIter i c + check (IterM m) = IterM $ liftM check m + check (IterC (CtlArg a n c0)) = IterC $ CtlArg a n (mappend c0 c) + check (Fail e a c0) = Fail e a $ fmap (`mappend` c) c0 + +-- | Turn an 'IterR' back into an 'Iter'. +reRunIter :: (ChunkData t, Monad m) => IterR t m a -> Iter t m a +{-# INLINE reRunIter #-} +reRunIter (IterF i) = i +reRunIter r = Iter $ runIterR r diff --git a/Data/IterIO/ListLike.hs b/Data/IterIO/ListLike.hs new file mode 100644 --- /dev/null +++ b/Data/IterIO/ListLike.hs @@ -0,0 +1,487 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | This module contains basic iteratees and enumerators for working +-- with strings, 'LL.ListLike' objects, file handles, and stream and +-- datagram sockets. +module Data.IterIO.ListLike + ( -- * Iteratees + putI, sendI + , headLI, safeHeadLI + , headI, safeHeadI + , lineI, safeLineI + , dataMaxI, data0MaxI, takeI + , handleI, sockDgramI, sockStreamI + , stdoutI + -- * Control requests + , SeekMode(..) + , SizeC(..), SeekC(..), TellC(..), fileCtl + , GetSocketC(..), socketCtl + -- * Onums + , enumDgram, enumDgramFrom, enumStream + , enumHandle, enumHandle', enumNonBinHandle + , enumFile, enumFile' + , enumStdin + -- * Inums + , inumMax, inumTakeExact + , inumLog, inumhLog, inumStderr + , inumLtoS, inumStoL + -- * Functions for Iter-Inum pairs + , pairFinalizer, iterHandle, iterStream + ) where + +import Prelude hiding (null) +import Control.Concurrent +import Control.Exception (onException) +import Control.Monad +import Control.Monad.Trans +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as L + (defaultChunkSize, chunk, ByteString(..)) +import Data.Char +import Data.Monoid +import Data.Typeable +import Network.Socket +import System.IO + +import qualified Data.ListLike as LL + +import Data.IterIO.Iter +import Data.IterIO.Inum +import Data.IterIO.Extra + + +echr :: (Enum e) => Char -> e +echr = toEnum . ord + +-- +-- Iters +-- + +-- | An Iteratee that puts data to a consumer function, then calls an +-- eof function. For instance, @'handleI'@ could be defined as: +-- +-- @ +-- handleI :: (MonadIO m) => 'Handle' -> 'Iter' 'L.ByteString' m () +-- handleI h = putI ('liftIO' . 'L.hPut' h) ('liftIO' $ 'hShutdown' h 1) +-- @ +putI :: (ChunkData t, Monad m) => + (t -> Iter t m a) + -> Iter t m b + -> Iter t m () +putI putfn eoffn = doput `finallyI` eoffn + where doput = do Chunk t eof <- chunkI + unless (null t) $ putfn t >> return () + if eof then return () else doput + +-- | Send datagrams using a supplied function. The datagrams are fed +-- as a list of packets, where each element of the list should be a +-- separate datagram. For example, to create an 'Iter' from a +-- connected UDP socket: +-- +-- @ +-- udpI :: ('SendRecvString' s, 'MonadIO' m) => 'Socket' -> 'Iter' s m () +-- udpI sock = sendI $ 'liftIO' . 'genSend' sock +-- @ +sendI :: (Show t, Monad m) => + (t -> Iter [t] m a) + -> Iter [t] m () +sendI sendfn = do + dgram <- safeHeadI + case dgram of + Just pkt -> sendfn pkt >> sendI sendfn + Nothing -> return () + +-- | Return the first element when the Iteratee data type is a list. +headLI :: (Show a, Monad m) => Iter [a] m a +{-# INLINABLE headLI #-} +headLI = iterF dohead + where dohead (Chunk (a:as) eof) = Done a $ Chunk as eof + dohead c = Fail err Nothing $ Just c + err = mkIterEOF "headLI" + +-- | Return 'Just' the first element when the Iteratee data type +-- is a list, or 'Nothing' on EOF. +safeHeadLI :: (Show a, Monad m) => Iter [a] m (Maybe a) +{-# INLINABLE safeHeadLI #-} +safeHeadLI = iterF $ dohead + where dohead (Chunk (a:as) eof) = Done (Just a) $ Chunk as eof + dohead _ = Done Nothing chunkEOF + + +-- | Like 'headLI', but works for any 'LL.ListLike' data type. +headI :: (ChunkData t, LL.ListLike t e, Monad m) => Iter t m e +{-# INLINABLE headI #-} +headI = iterF $ \c@(Chunk t eof) -> + if LL.null t then Fail err Nothing $ Just c + else Done (LL.head t) $ Chunk (LL.tail t) eof + where err = mkIterEOF "headI" + +-- | Like 'safeHeadLI', but works for any 'LL.ListLike' data type. +safeHeadI :: (ChunkData t, LL.ListLike t e, Monad m) => Iter t m (Maybe e) +{-# INLINABLE safeHeadI #-} +safeHeadI = iterF $ \c@(Chunk t eof) -> + if LL.null t then Done Nothing c + else Done (Just $ LL.head t) $ Chunk (LL.tail t) eof + +-- | Like 'lineI', but returns 'Nothing' on EOF. +safeLineI :: (ChunkData t, Monad m, LL.ListLike t e, Eq t, Enum e, Eq e) => + Iter t m (Maybe t) +safeLineI = iterF $ doline LL.empty + where + cr = LL.singleton $ echr '\r' + nl = LL.singleton $ echr '\n' + crnl = LL.append cr nl + eol c = c == echr '\n' || c == echr '\r' + doline acc (Chunk t eof) = + let acc' = LL.append acc t + (l, r) = LL.break eol acc' + result = dolr eof l r + in case result of + Just (l', r') -> Done (Just l') (Chunk r' eof) + Nothing | eof -> Done Nothing (Chunk acc' True) + _ -> IterF $ iterF $ doline acc' + dolr eof l r + | LL.isPrefixOf nl r = Just (l, LL.drop (LL.length nl) r) + | LL.isPrefixOf crnl r = Just (l, LL.drop (LL.length crnl) r) + | LL.isPrefixOf cr r && (eof || r /= cr) = + Just (l, LL.drop (LL.length cr) r) + | otherwise = Nothing + +-- | Return a line delimited by \\r, \\n, or \\r\\n. +lineI :: (Monad m, ChunkData t, LL.ListLike t e, Eq t, Enum e, Eq e) => + Iter t m t +lineI = do + mline <- safeLineI + case mline of + Nothing -> throwEOFI "lineI" + Just line -> return line + +-- | Return 'LL.ListLike' data that is at most the number of elements +-- specified by the first argument, and at least one element unless +-- EOF is encountered or 0 elements are requested, in which case +-- 'mempty' is returned. +data0MaxI :: (ChunkData t, LL.ListLike t e, Monad m) => Int -> Iter t m t +data0MaxI maxlen | maxlen <= 0 = return mempty + | otherwise = iterF $ \(Chunk s eof) -> + case LL.splitAt maxlen s of + (h, t) -> Done h $ Chunk t eof + +-- | Return 'LL.ListLike' data that is at most the number of elements +-- specified by the first argument, and at least one element (as long +-- as a positive number is requested). Throws an exception if a +-- positive number of items is requested and an EOF is encountered. +dataMaxI :: (ChunkData t, LL.ListLike t e, Monad m) => Int -> Iter t m t +dataMaxI maxlen | maxlen <= 0 = return mempty + | otherwise = iterF $ \c@(Chunk s eof) -> + if LL.null s then Fail err Nothing $ Just c + else case LL.splitAt maxlen s of + (h, t) -> Done h $ Chunk t eof + where err = mkIterEOF "dataMaxI" + +-- | Return the next @len@ elements of a 'LL.ListLike' data stream, +-- unless an EOF is encountered, in which case fewer may be returned. +-- Note the difference from 'data0MaxI': @'takeI' n@ will keep +-- reading input until it has accumulated @n@ elements or seen an EOF, +-- then return the data; @'data0MaxI' n@ will keep reading only until +-- it has received any non-empty amount of data, even if the amount +-- received is less than @n@ elements and there is no EOF. +takeI :: (ChunkData t, LL.ListLike t e, Monad m) => Int -> Iter t m t +takeI len | len <= 0 = return mempty + | otherwise = do + t <- data0MaxI len + let tlen = LL.length t + if tlen == len || tlen == 0 + then return t + else LL.append t `liftM` takeI (len - tlen) + +-- | Puts strings (or 'LL.ListLikeIO' data) to a file 'Handle', then +-- writes an EOF to the handle. +-- +-- Note that this does not put the handle into binary mode. To do +-- this, you may need to call @'hSetBinaryMode' h 'True'@ on the +-- handle before using it with @handleI@. Otherwise, Haskell by +-- default will treat the data as UTF-8. (On the other hand, if the +-- 'Handle' corresponds to a socket and the socket is being read in +-- another thread, calling 'hSetBinaryMode' can cause deadlock, so in +-- this case it is better to have the thread handling reads call +-- 'hSetBinaryMode'.) +-- +-- Also note that Haskell by default buffers data written to +-- 'Handle's. For many network protocols this is a problem. Don't +-- forget to call @'hSetBuffering' h 'NoBuffering'@ before passing a +-- handle to 'handleI'. +handleI :: (MonadIO m, ChunkData t, LL.ListLikeIO t e) => + Handle + -> Iter t m () +handleI h = putI (liftIO . LL.hPutStr h) (liftIO $ hShutdown h 1) + +-- | Sends a list of packets to a datagram socket. +sockDgramI :: (MonadIO m, SendRecvString t) => + Socket + -> Maybe SockAddr + -> Iter [t] m () +sockDgramI s mdest = loop + where sendit = case mdest of Nothing -> liftIO . genSend s + Just dest -> liftIO . flip (genSendTo s) dest + loop = safeHeadI >>= maybe (return ()) (\str -> sendit str >> loop) + +-- | Sends output to a stream socket. Calls shutdown (e.g., to send a +-- TCP FIN packet) upon receiving EOF. +sockStreamI :: (ChunkData t, SendRecvString t, MonadIO m) => + Socket -> Iter t m () +sockStreamI sock = putI (liftIO . genSend sock) + (liftIO $ shutdown sock ShutdownSend) + +-- | An 'Iter' that uses 'LL.hPutStr' to write all output to 'stdout'. +stdoutI :: (LL.ListLikeIO t e, ChunkData t, MonadIO m) => Iter t m () +stdoutI = putI (liftIO . LL.hPutStr stdout) (return ()) + +-- +-- Control functions +-- + +-- | A control command (issued with @'ctlI' SizeC@) requesting the +-- size of the current file being enumerated. +data SizeC = SizeC deriving (Typeable) +instance CtlCmd SizeC Integer + +-- | A control command for seeking within a file, when a file is being +-- enumerated. Flushes the residual input data. +data SeekC = SeekC !SeekMode !Integer deriving (Typeable) +instance CtlCmd SeekC () + +-- | A control command for determining the current offset within a +-- file. Note that this subtracts the size of the residual input data +-- from the offset in the file. Thus, it will only be accurate when +-- all left-over input data is from the current file. +data TellC = TellC deriving (Typeable) +instance CtlCmd TellC Integer + +-- | A handler function for the 'SizeC', 'SeekC', and 'TellC' control +-- requests. @fileCtl@ is used internally by 'enumFile' and +-- 'enumHandle', and is exposed for similar enumerators to use. +fileCtl :: (ChunkData t, LL.ListLike t e, MonadIO m) => + Handle + -> CtlHandler (Iter () m) t m a +fileCtl h = (mkFlushCtl $ \(SeekC mode pos) -> liftIO (hSeek h mode pos)) + `consCtl` tryTellC + `consCtl` (mkCtl $ \SizeC -> liftIO (hFileSize h)) + `consCtl` passCtl id + where tryTellC TellC n c@(Chunk t _) = do + offset <- liftIO $ hTell h + return $ runIter (n $ offset - LL.genericLength t) c + +-- | A control request that returns the 'Socket' from an enclosing +-- socket enumerator. +data GetSocketC = GetSocketC deriving (Typeable) +instance CtlCmd GetSocketC Socket + +-- | A handler for the 'GetSocketC' control request. +socketCtl :: (ChunkData t, MonadIO m) => + Socket -> CtlHandler (Iter () m) t m a +socketCtl s = (mkCtl $ \GetSocketC -> return s) + `consCtl` passCtl id + +-- +-- Onums +-- + +-- | Read datagrams (of up to 64KiB in size) from a socket and feed a +-- list of strings (one for each datagram) into an Iteratee. +enumDgram :: (MonadIO m, SendRecvString t) => + Socket + -> Onum [t] m a +enumDgram sock = mkInumC id (socketCtl sock) $ + liftIO $ liftM (: []) $ genRecv sock 0x10000 + +-- | Read datagrams from a socket and feed a list of (Bytestring, +-- SockAddr) pairs (one for each datagram) into an Iteratee. +enumDgramFrom :: (MonadIO m, SendRecvString t) => + Socket + -> Onum [(t, SockAddr)] m a +enumDgramFrom sock = mkInumC id (socketCtl sock) $ + liftIO $ liftM (: []) $ genRecvFrom sock 0x10000 + +-- | Read data from a stream (e.g., TCP) socket. +enumStream :: (MonadIO m, ChunkData t, SendRecvString t) => + Socket -> Onum t m a +enumStream sock = mkInumC id (socketCtl sock) $ + liftIO (genRecv sock L.defaultChunkSize) + +-- | A variant of 'enumHandle' type restricted to input in the Lazy +-- 'L.ByteString' format. +enumHandle' :: (MonadIO m) => Handle -> Onum L.ByteString m a +enumHandle' = enumHandle + +-- | Puts a handle into binary mode with 'hSetBinaryMode', then +-- enumerates data read from the handle to feed an 'Iter' with any +-- 'LL.ListLikeIO' input type. +enumHandle :: (MonadIO m, ChunkData t, LL.ListLikeIO t e) => + Handle + -> Onum t m a +enumHandle h iter = tryFI (liftIO $ hSetBinaryMode h True) >>= check + where check (Left e) = Iter $ Fail e (Just $ IterF iter) . Just + check (Right _) = enumNonBinHandle h iter + +-- | Feeds an 'Iter' with data from a file handle, using any input +-- type in the 'LL.ListLikeIO' class. Note that @enumNonBinHandle@ +-- uses the handle as is, unlike 'enumHandle', and so can be used if +-- you want to read the data in non-binary form. +enumNonBinHandle :: (MonadIO m, ChunkData t, LL.ListLikeIO t e) => + Handle + -> Onum t m a +enumNonBinHandle h = + mkInumC id (fileCtl h) $ + liftIO (hWaitForInput h (-1) >> LL.hGetNonBlocking h L.defaultChunkSize) +-- Note that hGet can block when there is some (but not enough) data +-- available. Thus, we use hWaitForInput followed by hGetNonBlocking. +-- ByteString introduced the call hGetSome for this purpose, but it is +-- not supported by the ListLike package yet. + +-- | Enumerate the contents of a file as a series of lazy +-- 'L.ByteString's. (This is a type-restricted version of +-- 'enumFile'.) +enumFile' :: (MonadIO m) => FilePath -> Onum L.ByteString m a +enumFile' = enumFile + +-- | Enumerate the contents of a file for an 'Iter' taking input in +-- any 'LL.ListLikeIO' type. Note that the file is opened with +-- 'openBinaryFile' to ensure binary mode. +enumFile :: (MonadIO m, ChunkData t, LL.ListLikeIO t e) => + FilePath -> Onum t m a +enumFile path = inumBracket (liftIO $ openBinaryFile path ReadMode) + (liftIO . hClose) enumNonBinHandle + +-- | Enumerate standard input. +enumStdin :: (MonadIO m, ChunkData t, LL.ListLikeIO t e) => Onum t m a +enumStdin = enumHandle stdin + +-- +-- Inums +-- + +-- | Feed exactly some number of bytes to an 'Iter'. Throws an error +-- if that many bytes are not available. +inumTakeExact :: (ChunkData t, LL.ListLike t e, Monad m) => Int -> Inum t t m a +inumTakeExact = mkInumM . loop + where loop n | n <= 0 = return () + | otherwise = do + t <- dataI + let (h, r) = LL.splitAt n t + ungetI r + _ <- ifeed h -- Keep feeding even if Done + loop $ n - LL.length h + +-- | Feed up to some number of list elements (bytes in the case of +-- 'L.ByteString's) to an 'Iter', or feed fewer if the 'Iter' returns +-- or an EOF is encountered. The formulation @inumMax n '.|' iter@ +-- can be used to prevent @iter@ from consuming unbounded amounts of +-- input. +inumMax :: (ChunkData t, LL.ListLike t e, Monad m) => Int -> Inum t t m a +{-# SPECIALIZE inumMax :: (Monad m) => + Int -> Inum L.ByteString L.ByteString m a #-} +{-# SPECIALIZE inumMax :: (Monad m) => + Int -> Inum S.ByteString S.ByteString m a #-} +inumMax n0 i | n0 <= 0 = runner i mempty + | otherwise = do + (t, more) <- next n0 + r <- runner i $ chunk t + case r of + IterF i1 | more -> inumMax (n0 - LL.length t) i1 + _ | isIterActive r -> return r + _ -> case getResid r of + Chunk t1 _ -> ungetI t1 >> return (setResid r mempty) + where runner = runIterMC (passCtl pullupResid) + next n = Iter $ \(Chunk t eof) -> + case LL.splitAt n t of + (t1, t2) -> Done (t1, not eof && LL.null t2) (Chunk t2 eof) + +-- | This inner enumerator is like 'inumNop' in that it passes +-- unmodified 'Chunk's straight through to an iteratee. However, it +-- also logs the 'Chunk's to a file (which can optionally be truncated +-- or appended to, based on the second argument). +inumLog :: (MonadIO m, ChunkData t, LL.ListLikeIO t e) => + FilePath -- ^ Path to log to + -> Bool -- ^ True to truncate file + -> Inum t t m a +inumLog path trunc = inumBracket openLog (liftIO . hClose) inumhLog + where openLog = liftIO $ do + h <- openBinaryFile path (if trunc then WriteMode else AppendMode) + hSetBuffering h NoBuffering + return h + +-- | Like 'inumLog', but takes a writeable file handle rather than a +-- file name. Does not close the handle when done. +inumhLog :: (MonadIO m, ChunkData t, LL.ListLikeIO t e) => + Handle -> Inum t t m a +inumhLog h = mkInumP pullupResid $ do + buf <- data0I + unless (null buf) $ liftIO $ LL.hPutStr h buf + return buf + +-- | Log a copy of everything to standard error. (@inumStderr = +-- 'inumhLog' 'stderr'@) +inumStderr :: (MonadIO m, ChunkData t, LL.ListLikeIO t e) => + Inum t t m a +inumStderr = inumhLog stderr + +-- | An 'Inum' that converts input in the lazy 'L.ByteString' format +-- to strict 'S.ByteString's. +inumLtoS :: (Monad m) => Inum L.ByteString S.ByteString m a +{-# INLINABLE inumLtoS #-} +inumLtoS = mkInumP rh loop + where rh (a, b) = (L.chunk b a, S.empty) + loop = iterF $ \c@(Chunk lbs eof) -> + case lbs of + L.Chunk bs rest -> Done bs (Chunk rest eof) + _ -> Done S.empty c + +-- | The dual of 'inumLtoS'--converts input from strict +-- 'S.ByteString's to lazy 'L.ByteString's. +inumStoL :: (Monad m) => Inum S.ByteString L.ByteString m a +inumStoL = mkInumP rh loop + where rh (a, b) = (S.concat (L.toChunks b ++ [a]), L.empty) + loop = iterF $ \(Chunk bs eof) -> + Done (L.chunk bs L.Empty) (Chunk S.empty eof) + +-- +-- Iter-Onum pairs +-- + +-- | Add a finalizer to run when an 'Iter' has received an EOF and an +-- 'Inum' has finished. This works regardless of the order in which +-- the two events happen. +pairFinalizer :: (ChunkData t, ChunkData t1, ChunkData t2 + , MonadIO m, MonadIO m1) => + Iter t m a + -> Inum t1 t2 m1 b + -> IO () + -- ^ Cleanup action + -> IO (Iter t m a, Inum t1 t2 m1 b) + -- ^ Cleanup action will run when these two are both done +pairFinalizer iter inum cleanup = do + mc <- newMVar False + let end = modifyMVar mc $ \cleanit -> + when cleanit cleanup >> return (True, ()) + return (iter `finallyI` liftIO end + , (inumNull `cat` inum) `inumFinally` liftIO end) + +-- | \"Iterizes\" a file 'Handle' by turning into an 'Onum' (for +-- 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. +iterHandle :: (LL.ListLikeIO t e, ChunkData t, MonadIO m) => + Handle -> IO (Iter t m (), Onum t m a) +iterHandle h = do + hSetBinaryMode h True `onException` hClose h + pairFinalizer (handleI h) (enumNonBinHandle h) (hClose h) + +-- | \"Iterizes\" a stream 'Socket' by turning into an 'Onum' (for +-- reading) and an 'Iter' (for writing). Uses 'pairFinalizer' to +-- 'sClose' the 'Socket' when both the 'Iter' and 'Onum' are finished. +iterStream :: (SendRecvString t, ChunkData t, MonadIO m) => + Socket -> IO (Iter t m (), Onum t m a) +iterStream s = pairFinalizer (sockStreamI s) (enumStream s) (sClose s) diff --git a/Data/IterIO/Parse.hs b/Data/IterIO/Parse.hs new file mode 100644 --- /dev/null +++ b/Data/IterIO/Parse.hs @@ -0,0 +1,561 @@ + +-- | 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". + +module Data.IterIO.Parse (-- * Iteratee combinators + (<|>), (\/), orEmpty, (), expectedI + , someI, foldrI, foldr1I, foldrMinMaxI + , foldlI, foldl1I, foldMI, foldM1I + , skipI, optionalI, ensureI + , eord + , skipWhileI, skipWhile1I + , whileI, while1I, whileMaxI, whileMinMaxI + , concatI, concat1I, concatMinMaxI + , readI, eofI + -- * Applicative combinators + , (<$>), (<$), ($>), (>$>), Applicative(..), (<**>) + , (<++>), (<:>), nil + -- * Parsing Iteratees + -- $Parseclike + , many, skipMany, sepBy, endBy, sepEndBy + , many1, skipMany1, sepBy1, endBy1, sepEndBy1 + , satisfy, char, match, string, stringCase + ) where + +import Prelude hiding (null) +import Control.Applicative (Applicative(..), (<**>), liftA2) +import Control.Monad +import Data.Char +import Data.Functor ((<$>), (<$)) +import qualified Data.ListLike as LL +import Data.Monoid + +import Data.IterIO.Iter +import Data.IterIO.Inum +import Data.IterIO.ListLike + +-- | An infix synonym for 'multiParse' that allows LL(*) parsing of +-- alternatives by executing both Iteratees on input chunks as they +-- arrive. This is similar to the @\<|>@ method of the +-- @'Alternative'@ class in "Control.Applicative", but the +-- @'Alternative'@ operator has left fixity, while for efficiency this +-- one has: +-- +-- > infixr 3 <|> +(<|>) :: (ChunkData t, Monad m) => + Iter t m a -> Iter t m a -> Iter t m a +{-# INLINE (<|>) #-} +(<|>) = multiParse +infixr 3 <|> + +-- | An infix synonym for 'ifNoParse' that allows LL(*) parsing of +-- alternatives by keeping a copy of input data consumed by the first +-- Iteratee so as to backtrack and execute the second Iteratee if the +-- first one fails. Returns a function that takes a continuation for +-- the first 'Iter', should it succeed. The code: +-- +-- > iter1 \/ iter2 $ \iter1Result -> doSomethingWith iter1Result +-- +-- Executes @iter1@ (saving a copy of the input for backtracking). If +-- @iter1@ fails with an exception of class 'IterNoParse', then the +-- input is re-wound and fed to @iter2@. On the other hand, if +-- @iter1@ succeeds and returns @iter1Result@, then the saved input is +-- discarded (as @iter2@ will not need to be run) and the result of +-- @iter1@ is fed to function @doSomethingWith@. +-- +-- For example, to build up a list of results of executing @iter@, one +-- could implement a type-restricted version of 'many' as follows: +-- +-- @ +-- myMany :: (ChunkData t, Monad m) => Iter t m a -> Iter t m [a] +-- myMany iter = iter \\/ return [] '$' \\r -> 'fmap' ((:) r) (myMany iter) +-- @ +-- +-- In other words, @myMany@ tries running @iter@. If @iter@ fails, +-- then @myMany@ returns the empty list. If @iter@ succeeds, its +-- result @r@ is added to the head of the list returned by calling +-- @myMany@ recursively. This idiom of partially applying a binary +-- funciton to a result and then applying the resulting function to an +-- 'Iter' via 'fmap' is so common that there is an infix operator for +-- it, @'>$>'@. Thus, the above code can be written: +-- +-- @ +-- myMany iter = iter \\/ return [] '$' (:) '>$>' myMany iter +-- @ +-- +-- Of course, using 'fmap' is not the most efficient way to implement +-- @myMany@. If you are going to use this pattern for something +-- performance critical, you should use an accumulator rather than +-- build up long chains of 'fmap's. A faster implementation would be: +-- +-- @ +-- myMany iter = loop id +-- where loop ac = iter \\/ return (acc []) '$' \a -> loop (acc . (a :)) +-- @ +-- +-- @\\/@ has fixity: +-- +-- > infix 2 \/ +-- +(\/) :: (ChunkData t, Monad m) => + Iter t m a -> Iter t m b -> (a -> Iter t m b) -> Iter t m b +{-# INLINE (\/) #-} +(\/) = ifNoParse +infix 2 \/ + +-- | @(f >$> a) t@ is equivalent to @f t '<$>' a@ (where '<$>' is and +-- infix alias for 'fmap'). Particularly useful with infix +-- combinators such as '\/' and ``orEmpty`` when chaining parse +-- actions. See examples at '\/' and 'orEmpty'. Note 'fmap' is not +-- always the most efficient solution (see an example in the +-- description of '\/'). +-- +-- Has fixity: +-- +-- > infixl 3 >$> +-- +(>$>) :: (Functor f) => (t -> a -> b) -> f a -> t -> f b +{-# INLINE (>$>) #-} +(>$>) f a = \t -> f t <$> a +infixr 3 >$> + +-- | @fa $> b = b <$ fa@ -- replaces the output value of a functor +-- with some pure value. Has the same fixity as '<$>' and '<$', +-- namely: +-- +-- > infixl 4 $> +($>) :: (Functor f) => f a -> b -> f b +{-# INLINE ($>) #-} +a $> b = b <$ a +infixl 4 $> + +-- | Defined as @orEmpty = ('\/' return 'mempty')@, and useful when +-- parse failures should just return an empty 'Monoid'. For example, +-- a type-restricted 'many' can be implemented as: +-- +-- @ +-- myMany :: (ChunkData t, Monad m) => Iter t m a -> Iter t m [a] +-- myMany iter = iter ``orEmpty`` (:) '>$>' myMany iter +-- @ +-- +-- Has fixity: +-- +-- > infixr 3 `orEmpty` +-- +orEmpty :: (ChunkData t, Monad m, Monoid b) => + Iter t m a -> (a -> Iter t m b) -> Iter t m b +{-# INLINE orEmpty #-} +orEmpty = (\/ nil) +infixr 3 `orEmpty` + +-- | @iter \ token@ replaces any kind of parse failure in @iter@ +-- with an exception equivalent to calling @'expectedI' prefix token@ +-- where @prefix@ is a prefix of the input that was fed to @iter@ and +-- caused it to fail. +-- +-- Has fixity: +-- +-- > infix 0 +-- +() :: (ChunkData t, Monad m) => Iter t m a -> String -> Iter t m a +{-# INLINE () #-} +() iter expected = + Iter $ \c -> case runIter iter c of + r@(Done _ _) -> r + r@(Fail e _ _) -> case e of + IterException _ -> r + _ -> Fail (IterExpected [(show c, expected)]) + Nothing Nothing + r -> slowPath (show c) expected r + where + {-# NOINLINE slowPath #-} + slowPath saw exp1 = onDoneR $ \r0 -> + case r0 of + r@(Fail e _ _) -> case e of + IterException _ -> r + _ -> Fail (IterExpected [(saw, exp1)]) + Nothing Nothing + r -> r +infix 0 + +-- | Throw an 'Iter' exception that describes expected input not +-- found. +expectedI :: (ChunkData t) => + String -- ^ Input actually received + -> String -- ^ Description of input that was wanted + -> 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. +foldrI :: (ChunkData t, Monad m) => + (a -> b -> b) -> b -> Iter t m a -> Iter t m b +foldrI = innerFoldrI id + +innerFoldrI :: (ChunkData t, Monad m) => + (b -> b) -> (a -> b -> b) -> b -> Iter t m a -> Iter t m b +innerFoldrI acc0 f z iter = loop acc0 + where loop acc = iter \/ return (acc z) $ \a -> loop (acc . f a) + +-- | A variant of 'foldrI' that requires the 'Iter' to succeed at +-- least once. +foldr1I :: (ChunkData t, Monad m) => + (a -> b -> b) -> b -> Iter t m a -> Iter t m b +foldr1I f z iter = iter >>= \a -> innerFoldrI (f a) f z iter + +-- | A variant of 'foldrI' that requires the 'Iter' to succeed at +-- least a minimum number of items and stops parsing after executing +-- the 'Iter' some maximum number of times. +foldrMinMaxI :: (ChunkData t, Monad m) => + Int -- ^ Minimum number to parse + -> Int -- ^ Maximum number to parse + -> (a -> b -> b) -- ^ Folding function + -> b -- ^ Rightmost value + -> Iter t m a -- ^ Iteratee generating items to fold + -> Iter t m b +foldrMinMaxI nmin0 nmax0 f z iter + | nmin0 > nmax0 = throwParseI "foldrMinMaxI: min > max" + | nmax0 < 0 = throwParseI "foldrMinMaxI: negative max" + | otherwise = loop id nmin0 nmax0 + where + loop acc nmin nmax + | nmax == 0 = return $ acc z + | nmin > 0 = iter >>= \a -> loop (acc . f a) (nmin - 1) (nmax - 1) + | otherwise = iter \/ return (acc z) $ \a -> + loop (acc . f a) 0 (nmax - 1) + +-- | Strict left fold over an 'Iter' (until it throws an 'IterNoParse' +-- exception). @foldlI f z iter@ is sort of equivalent to: +-- +-- > ... (f <$> (f <$> (f z <$> iter) <*> iter) <*> iter) ... +foldlI :: (ChunkData t, Monad m) => + (b -> a -> b) -> b -> Iter t m a -> Iter t m b +foldlI f z0 iter = foldNext z0 + where foldNext z = z `seq` iter \/ return z $ \a -> foldNext (f z a) + +-- | A version of 'foldlI' that fails if the 'Iter' argument does not +-- succeed at least once. +foldl1I :: (ChunkData t, Monad m) => + (b -> a -> b) -> b -> Iter t m a -> Iter t m b +foldl1I f z iter = iter >>= \a -> foldlI f (f z a) iter + +-- | @foldMI@ is a left fold in which the folding function can execute +-- monadic actions. Essentially @foldMI@ is to 'foldlI' as 'foldM' is +-- to @`foldl'`@ in the standard libraries. +foldMI :: (ChunkData t, Monad m) => + (b -> a -> Iter t m b) -> b -> Iter t m a -> Iter t m b +foldMI f z0 iter = foldNext z0 + where foldNext z = iter \/ return z $ f z >=> foldNext + +-- | A variant of 'foldMI' that requires the 'Iter' to succeed at +-- least once. +foldM1I :: (ChunkData t, Monad m) => + (b -> a -> Iter t m b) -> b -> Iter t m a -> Iter t m b +foldM1I f z0 iter = iter >>= f z0 >>= \z -> foldMI f z iter + + +-- | Discard the result of executing an Iteratee once. Throws an +-- error if the Iteratee fails. (Like @skip x = x >> return ()@.) +skipI :: Applicative f => f a -> f () +skipI = (() <$) + +-- | Execute an iteratee. Discard the result if it succeeds. Rewind +-- the input and suppress the error if it fails. +optionalI :: (ChunkData t, Monad m) => Iter t m a -> Iter t m () +optionalI iter = ifParse iter (const $ return ()) (return ()) + +-- | Ensures the next input element satisfies a predicate or throws a +-- parse error. Does not consume any input. +ensureI :: (ChunkData t, LL.ListLike t e, Monad m) => + (e -> Bool) -> Iter t m () +ensureI test = + Iter $ \c@(Chunk t eof) -> + if LL.null t + then (if eof then eofFail else IterF (ensureI test)) + else (if test (LL.head t) then Done () c else testFail) + where testFail = Fail (IterParseErr "ensureI test failed") Nothing Nothing + eofFail = Fail (mkIterEOF "ensureI EOF") Nothing Nothing + +-- | A variant of the standard library 'ord' function, but that +-- translates a 'Char' into any 'Enum' type, not just 'Int'. +-- Particularly useful for 'Iter's that must work with both 'String's +-- (which consist of 'Char's) and ASCII @'ByteString'@s (which consist +-- of @'Word8'@s). For example, to skip one or more space or TAB +-- characters, you can use: +-- +-- @ +-- skipSpace :: ('LL.ListLike' t e, ChunkData t, 'Eq' e, 'Enum' e, Monad m) => +-- 'Iter' t m () +-- skipSpace = 'skipWhile1I' (\\c -> c == eord ' ' || c == eord '\t') +-- @ +eord :: (Enum e) => Char -> e +{-# INLINE eord #-} +eord = toEnum . ord + +-- | Skip all input elements encountered until an element is found +-- that does not match the specified predicate. +skipWhileI :: (ChunkData t, LL.ListLike t e, Monad m) => + (e -> Bool) -> Iter t m () +skipWhileI test = loop + where loop = Iter $ \(Chunk t eof) -> + case LL.dropWhile test t of + t1 | LL.null t1 && not eof -> IterF loop + t1 -> Done () $ Chunk t1 eof + +-- | Like 'skipWhileI', but fails if at least one element does not +-- satisfy the predicate. +skipWhile1I :: (ChunkData t, LL.ListLike t e, Monad m) => + (e -> Bool) -> Iter t m () +skipWhile1I test = ensureI test >> skipWhileI test "skipWhile1I" + +-- | Return all input elements up to the first one that does not match +-- the specified predicate. +whileI :: (ChunkData t, LL.ListLike t e, Monad m) + => (e -> Bool) -> Iter t m t +whileI test = more id + where + more acc = Iter $ \(Chunk t eof) -> + case LL.span test t of + (t1, t2) | not (LL.null t2) || eof -> + Done (acc t1) $ Chunk t2 eof + (t1, _) -> IterF $ more (acc . LL.append t1) + +-- | Like 'whileI', but fails if at least one element does not satisfy +-- the predicate. +while1I :: (ChunkData t, LL.ListLike t e, Monad m) => + (e -> Bool) -> Iter t m t +while1I test = ensureI test >> whileI test + +-- | A variant of 'whileI' with a maximum number matches. +whileMaxI :: (ChunkData t, LL.ListLike t e, Monad m) => + Int -- ^ Maximum number to match + -> (e -> Bool) -- ^ Predicate test + -> Iter t m t +whileMaxI nmax test = inumMax nmax .| whileI test + +-- | A variant of 'whileI' with a minimum and maximum number matches. +whileMinMaxI :: (ChunkData t, LL.ListLike t e, Monad m) => + Int -- ^ Minumum number + -> Int -- ^ Maximum number + -> (e -> Bool) -- ^ Predicate test + -> Iter t m t +whileMinMaxI nmin nmax test = do + result <- whileMaxI nmax test + if LL.length result >= nmin + then return result + else expectedI "too few" "whileMinMaxI minimum" + +-- | Repeatedly execute an 'Iter' returning a 'Monoid' and 'mappend' +-- all the results in a right fold. +concatI :: (ChunkData t, Monoid s, Monad m) => + Iter t m s -> Iter t m s +concatI iter = foldrI mappend mempty iter + +-- | Like 'concatI', but fails if the 'Iter' doesn't return at least +-- once. +concat1I :: (ChunkData t, Monoid s, Monad m) => + Iter t m s -> Iter t m s +concat1I iter = foldr1I mappend mempty iter + +-- | A version of 'concatI' that takes a minimum and maximum number of +-- items to parse. +concatMinMaxI :: (ChunkData t, Monoid s, Monad m) => + Int -- ^ Minimum number to parse + -> Int -- ^ Maximum number to parse + -> Iter t m s -- ^ 'Iter' whose results to concatenate + -> Iter t m s +concatMinMaxI nmin nmax iter = foldrMinMaxI nmin nmax mappend mempty iter + + +-- | This 'Iter' parses a 'LL.StringLike' argument. It does not +-- consume any Iteratee input. The only reason it is an Iteratee is +-- so that it can throw an Iteratee parse error should it fail to +-- parse the argument string (or should the argument yield an +-- ambiguous parse). +readI :: (ChunkData t, Monad m, LL.StringLike s, Read a) => + s -> Iter t m a +readI s' = let s = LL.toString s' + in case [a | (a,"") <- reads s] of + [a] -> return a + [] -> throwParseI $ "readI can't parse: " ++ s + _ -> throwParseI $ "readI ambiguous: " ++ s + +-- | Ensures the input is at the end-of-file marker, or else throws an +-- exception. +eofI :: (ChunkData t, Monad m, Show t) => Iter t m () +eofI = do + Chunk t eof <- iterF $ \c -> Done c c + if eof && null t + then return () + else expectedI (chunkShow t) "EOF" + +-- | 'mappend' the result of two 'Applicative' types returning +-- 'Monoid' types (@\<++> = 'liftA2' 'mappend'@). Has the same fixity +-- as '++', namely: +-- +-- > infixr 5 <++> +(<++>) :: (Applicative f, Monoid t) => f t -> f t -> f t +(<++>) = liftA2 mappend +infixr 5 <++> + +-- | 'LL.cons' an 'Applicative' type onto an an 'Applicative' +-- 'LL.ListLike' type (@\<:> = 'liftA2' 'LL.cons'@). Has the same +-- fixity as @:@, namely: +-- +-- > infixr 5 <:> +(<:>) :: (LL.ListLike t e, Applicative f) => f e -> f t -> f t +{-# INLINE (<:>) #-} +(<:>) = liftA2 LL.cons +infixr 5 <:> + +-- | @nil = 'pure' 'mempty'@--An empty 'Monoid' injected into an +-- 'Applicative' type. +nil :: (Applicative f, Monoid t) => f t +{-# INLINE nil #-} +nil = pure mempty + +-- $Parseclike +-- +-- These functions are intended to be similar to those supplied by +-- "Text.Parsec". + +-- | Run an 'Iter' zero or more times (until it fails) and return a +-- list-like container of the results. +many :: (ChunkData t, LL.ListLike f a, Monad m) => Iter t m a -> Iter t m f +{-# INLINE many #-} +many = foldrI LL.cons LL.empty + +-- | Repeatedly run an 'Iter' until it fails and discard all the +-- results. +skipMany :: (ChunkData t, Monad m) => Iter t m a -> Iter t m () +skipMany = foldlI (\_ _ -> ()) () + +-- | Parses a sequence of the form +-- /Item1 Separator Item2 Separator ... Separator ItemN/ +-- and returns the list @[@/Item1/@,@ /Item2/@,@ ...@,@ /ItemN/@]@ +-- or a 'LL.ListLike' equivalent. +sepBy :: (ChunkData t, LL.ListLike f a, Monad m) => + Iter t m a -- ^ Item to parse + -> Iter t m b -- ^ Separator between items + -> Iter t m f -- ^ Returns 'LL.ListLike' list of items +sepBy item sep = item `orEmpty` \a -> + innerFoldrI (LL.cons a) LL.cons LL.empty (sep *> item) + +-- | Like 'sepBy', but expects a separator after the final item. In +-- other words, parses a sequence of the form +-- /Item1 Separator Item2 Separator ... Separator ItemN Separator/ +-- and returns the list @[@/Item1/@,@ /Item2/@,@ ...@,@ /ItemN/@]@ or +-- a 'LL.ListLike' equivalent. +endBy :: (ChunkData t, LL.ListLike f a, Monad m) => + Iter t m a -- ^ Item to parse + -> Iter t m b -- ^ Separator that must follow each item + -> Iter t m f -- ^ Returns 'LL.ListLike' list of items +endBy item sep = foldrI LL.cons LL.empty (item <* sep) + +-- | Accepts items that would be parsed by either 'sepBy' or 'endBy'. +-- Essentially a version of 'endBy' in which the final separator is +-- optional. +sepEndBy :: (ChunkData t, LL.ListLike f a, Monad m) => + Iter t m a -> Iter t m b -> Iter t m f +sepEndBy item sep = sepBy item sep <* optionalI sep + + +-- | Run an 'Iter' one or more times (until it fails) and return a +-- list-like container of the results. +many1 :: (ChunkData t, LL.ListLike f a, Monad m) => Iter t m a -> Iter t m f +many1 = foldr1I LL.cons LL.empty + +-- | A variant of 'skipMany' that throws a parse error if the 'Iter' +-- does not succeed at least once. +skipMany1 :: (ChunkData t, Monad m) => Iter t m a -> Iter t m () +skipMany1 = foldl1I (\_ _ -> ()) () + +-- | A variant of 'sepBy' that throws a parse error if it cannot +-- return at least one item. +sepBy1 :: (ChunkData t, LL.ListLike f a, Monad m) => + Iter t m a -> Iter t m b -> Iter t m f +sepBy1 item sep = item >>= \a -> + innerFoldrI (LL.cons a) LL.cons LL.empty (sep *> item) + +-- | A variant of 'endBy' that throws a parse error if it cannot +-- return at least one item. +endBy1 :: (ChunkData t, LL.ListLike f a, Monad m) => + Iter t m a -> Iter t m b -> Iter t m f +endBy1 item sep = foldr1I LL.cons LL.empty (item <* sep) + +-- | A variant of 'sepEndBy' that throws a parse error if it cannot +-- return at least one item. +sepEndBy1 :: (ChunkData t, LL.ListLike f a, Monad m) => + Iter t m a -> Iter t m b -> Iter t m f +sepEndBy1 item sep = sepBy1 item sep <* optionalI sep + + +-- | Read the next input element if it satisfies some predicate. +-- Otherwise throw an error. +satisfy :: (ChunkData t, LL.ListLike t e, Enum e, Monad m) => + (e -> Bool) -> Iter t m e +satisfy test = + Iter $ \c@(Chunk t eof) -> + if LL.null t + then (if eof then eofFail else IterF (satisfy test)) + else case LL.head t of + h | test h -> + Done h (Chunk (LL.tail t) eof) + | otherwise -> + Fail (IterExpected [(show $ chr $ fromEnum h + , "satisfy predicate")]) + Nothing (Just c) + where eofFail = Fail (mkIterEOF "satisfy: EOF") Nothing Nothing + +-- | Read input that exactly matches a character. +char :: (ChunkData t, LL.ListLike t e, Eq e, Enum e, Monad m) => + Char -> Iter t m e +{-# INLINE char #-} +char target = satisfy (eord target ==) show target + +-- | Read input that exactly matches some target. +match :: (ChunkData t, LL.ListLike t e, Eq e, Monad m) => + t -> Iter t m t +match ft = doMatch ft + where doMatch target | LL.null target = return ft + | otherwise = do + m <- data0MaxI $ LL.length target + if not (LL.null m) && LL.isPrefixOf m target + then doMatch $ LL.drop (LL.length m) target + else expectedI (chunkShow m) $ chunkShow target + +-- | Read input that exactly matches a string. +string :: (ChunkData t, LL.ListLike t e, LL.StringLike t, Eq e, Monad m) => + String -> Iter t m t +{-# INLINE string #-} +string = match . LL.fromString + +-- | Read input that matches a string up to case. +stringCase :: (ChunkData t, LL.ListLike t e, Enum e, Eq e, Monad m) => + String -> Iter t m t +stringCase ft = doMatch LL.empty $ ft + where + prefix a b | LL.null a = True + | otherwise = + if toLower (chr $ fromEnum $ LL.head a) /= toLower (head b) + then False else LL.tail a `prefix` LL.tail b + doMatch acc target | LL.null target = return acc + | otherwise = do + m <- data0MaxI $ LL.length target + if not (LL.null m) && m `prefix` target + then doMatch (LL.append acc m) $ LL.drop (LL.length m) target + else expectedI (chunkShow m) $ chunkShow target diff --git a/Data/IterIO/SSL.hs b/Data/IterIO/SSL.hs new file mode 100644 --- /dev/null +++ b/Data/IterIO/SSL.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Data.IterIO.SSL where + +import Control.Exception (throwIO, ErrorCall(..), finally, onException) +import Control.Monad +import Control.Monad.Trans +import Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Lazy.Internal as L (defaultChunkSize) +import Data.Typeable +import qualified Network.Socket as Net +import qualified OpenSSL.Session as SSL +import System.Cmd +import System.Exit + +import Data.IterIO.Iter +import Data.IterIO.Inum +import Data.IterIO.ListLike + +-- | A wrapper around the type 'SSL.SSL' to make it an instance of the +-- 'Typeable' class. +newtype SslConnection = SslConnection { unSslConnection :: SSL.SSL } + deriving (Typeable) + +-- | Control request to fetch the 'SSL' object associated with an +-- enumerator. +data SslC = SslC deriving (Typeable) +instance CtlCmd SslC SslConnection + +-- | Simple OpenSSL 'Onum'. +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) + codec = do buf <- liftIO (SSL.read ssl L.defaultChunkSize) + if S.null buf + then return L.empty + else return $ L.fromChunks [buf] + +-- | Simple OpenSSL 'Iter'. Does a uni-directional SSL shutdown when +-- it receives a 'Chunk' with the EOF bit 'True'. +sslI :: (MonadIO m) => SSL.SSL -> Iter L.ByteString m () +sslI ssl = loop + where loop = do + Chunk t eof <- chunkI + unless (L.null t) $ liftIO $ SSL.lazyWrite ssl t + if eof then liftIO $ SSL.shutdown ssl SSL.Unidirectional else loop + +-- | Turn a socket into an 'Iter' and 'Onum' that use OpenSSL to write +-- to and read from the socket, respectively. Does an SSL +-- bi-directional shutdown and closes the socket when both a) the enum +-- completes and b) the iter has received an EOF chunk. +-- +-- If the SSL handshake fails, then @iterSSL@ closes the socket before +-- throwing an exception. +-- +-- This funciton must only be invoked from within a call to +-- @withOpenSSL@. +iterSSL :: (MonadIO m) => + SSL.SSLContext + -- ^ OpenSSL context + -> Net.Socket + -- ^ The socket + -> Bool + -- ^ 'True' for server handshake, 'False' for client + -> IO (Iter L.ByteString m (), Onum L.ByteString m a) +iterSSL ctx sock server = do + ssl <- SSL.connection ctx sock `onException` Net.sClose sock + (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 + +-- | Simplest possible SSL context, loads cert and unencrypted private +-- key from a single file. +simpleContext :: FilePath -> IO SSL.SSLContext +simpleContext keyfile = do + ctx <- SSL.context + SSL.contextSetDefaultCiphers ctx + SSL.contextSetCertificateFile ctx keyfile + SSL.contextSetPrivateKeyFile ctx keyfile + -- SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer False True + SSL.contextSetVerificationMode ctx SSL.VerifyNone + return ctx + +-- | Quick and dirty funciton to generate a self signed certificate +-- for testing and stick it in a file. E.g.: +-- +-- > genSelfSigned "testkey.pem" "localhost" +genSelfSigned :: FilePath -- ^ Filename in which to output key + -> String -- ^ Common Name (usually domain name) + -> IO () +genSelfSigned file cn = do + r <- rawSystem "openssl" + [ "req", "-x509", "-nodes", "-days", "365", "-subj", "/CN=" ++ cn + , "-newkey", "rsa:1024", "-keyout", file, "-out", file + ] + when (r /= ExitSuccess) $ throwIO $ ErrorCall "openssl failed" diff --git a/Data/IterIO/Search.hs b/Data/IterIO/Search.hs new file mode 100644 --- /dev/null +++ b/Data/IterIO/Search.hs @@ -0,0 +1,114 @@ + +module Data.IterIO.Search (inumStopString + , mapI, mapLI + ) where + +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.ByteString.Lazy.Search as Search +import qualified Data.ListLike as LL +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Monoid + +import Data.IterIO.Iter +import Data.IterIO.Inum + +-- | Feeds input to an Iteratee until some boundary string is found. +-- The boundary string is neither consumed nor passed through to the +-- target 'Iter'. (Thus, if the input is at end-of-file after +-- inumStopString returns, it means the boundary string was never +-- encountered.) +inumStopString :: (Monad m) => + S8.ByteString + -> Inum L8.ByteString L8.ByteString m a +inumStopString spat = mkInumM $ nextChunk L8.empty + where + lpat = L8.fromChunks [spat] + plen = toEnum $ S8.length spat + search = Search.breakOn spat + nextChunk old = do + (Chunk t eof) <- chunkI + case search $ L8.append old t of + (a, b) | not (L8.null b) -> ungetI b >> ifeed a + (a, _) | eof -> ifeed a + (a, _) -> checkEnd a + checkEnd t = let tlen = L8.length t + hlen = max 0 (tlen - plen - 1) + ttail = L8.drop hlen t + fpm = firstPossibleMatch 0 ttail + rlen = hlen + fpm + in if rlen == tlen + then ifeed t >> nextChunk L8.empty + else case L8.splitAt rlen t of + (r, o) -> ifeed r >> nextChunk o + firstPossibleMatch n t = + if t `L8.isPrefixOf` lpat + then n + else firstPossibleMatch (n + 1) (L8.tail t) + +longestCommonPrefix :: (LL.ListLike t e, Eq e) => t -> t -> t +longestCommonPrefix a0 = cmp 0 a0 + where + cmp n a b | LL.null a || LL.null b = LL.take n a0 + cmp n a b | LL.head a == LL.head b = cmp (n + 1) (LL.tail a) (LL.tail b) + cmp n _ _ = LL.take n a0 + +findLongestPrefix :: (LL.ListLike t e, Ord t, Eq e) => + Map t a -> t -> Maybe (t, a) +findLongestPrefix mp t = maybe ckprefix (\v1 -> Just (t, v1)) ma + where + (ltmap, ma, _) = Map.splitLookup t mp + (k, v) = Map.findMax ltmap + p = longestCommonPrefix k t + ckprefix | Map.null mp || LL.null t = Nothing + | k `LL.isPrefixOf` t = Just (k, v) + | otherwise = findLongestPrefix ltmap p + +-- | Reads input until it can uniquely determine the longest key in a +-- 'Map.Map' that is a prefix of the input. Consumes the input that +-- matches the key, and returns the corresponding value in the +-- 'Map.Map', along with the residual input that follows the key. +mapI :: (ChunkData t, LL.ListLike t e, Ord t, Eq e, Monad m) => + Map t a -> Iter t m a +mapI mp | Map.null mp = fail $ "mapI: null map" + | otherwise = do + c@(Chunk t eof) <- chunkI + if not (eof) && more t + then iterF (runIter (mapI mp) . mappend c) + else case findLongestPrefix mp t of + Nothing -> Iter $ \c' -> + Fail (IterExpected $ + (show c + , show (Map.size mp) ++ " keys including the following:") + : map (\k -> ("", chunkShow k)) (take 5 $ Map.keys mp)) + Nothing (Just $ mappend c c') + Just (k, v) -> ungetI (LL.drop (LL.length k) t) >> return v + where + gtmap t = snd $ Map.split t mp + more t | Map.null $ gtmap t = False + | otherwise = t `LL.isPrefixOf` (fst $ Map.findMin $ gtmap t) + +-- | @mapLI@ is a variant of 'mapI' that takes a list of +-- @(key, value)@ pairs instead of a 'Map.Map'. +-- @mapLI = 'mapI' . 'Map.fromList'@. +mapLI :: (ChunkData t, LL.ListLike t e, Ord t, Eq e, Monad m) => + [(t, a)] -> Iter t m a +mapLI = mapI . Map.fromList + + + + +{- +main :: IO () +main = enumStdin |$ do + inumStopString end .| stdoutI + match end + liftIO $ putStrLn "\n\n*** We have reached THE END #1 ***\n\n" + inumStopString end .| stdoutI + match end + liftIO $ putStrLn "\n\n*** We have reached THE END #2 ***\n\n" + stdoutI + where + end = L8.pack "TheEnd" +-} diff --git a/Data/IterIO/Trans.hs b/Data/IterIO/Trans.hs new file mode 100644 --- /dev/null +++ b/Data/IterIO/Trans.hs @@ -0,0 +1,394 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} + +-- These extensions are only for MTL stuff where it is required +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | This module contains various helper functions and instances for +-- using 'Iter's of different 'Monad's together in the same pipeline. +-- For example, as-is the following code is illegal: +-- +-- @ +--iter1 :: 'Iter' String IO Bool +--iter1 = ... +-- +--iter2 :: 'Iter' String ('StateT' MyState IO) () +--iter2 = do ... +-- s <- iter1 -- ILLEGAL: iter1 is in wrong monad +-- ... +-- @ +-- +-- You can't invoke @iter1@ from within @iter2@ because the 'Iter' +-- type is wrapped around a different 'Monad' in each case. However, +-- the function 'liftI' exactly solves this problem: +-- +-- @ +-- s <- liftI iter1 +-- @ +-- +-- Conversely, you may be in a 'Monad' like @'Iter' String IO@ and +-- need to invoke a computation that requires some other monad +-- functionality, such as a reader. There are a number of +-- iteratee-specific runner functions that help you run other +-- 'MonadTrans' transformers inside the 'Iter' monad. These typically +-- use the names of the runner functions in the mtl library, but with +-- an @I@ appended--for instance 'runReaderTI', 'runStateTI', +-- 'runWriterTI'. Here's a fuller example of adapting the inner +-- 'Iter' 'Monad'. The example also illustrates that @'Iter' t m@ is +-- member any mtl classes (such as 'MonadReader' and 'MonadState') +-- that @m@ is. +-- +-- @ +--iter1 :: Iter String ('ReaderT' MyState IO) Bool +--iter1 = do +-- s <- 'ask' +-- liftIO $ ('putStrLn' ('show' s) >> return True) +-- ``catch`` \('SomeException' _) -> return False +-- +--iter2 :: Iter String ('StateT' MyState IO) () +--iter2 = do +-- s <- 'get' +-- ok <- 'liftI' $ 'runReaderTI' iter1 s +-- if ok then return () else fail \"iter1 failed\" +-- @ +module Data.IterIO.Trans (-- * Adapters for Iters of mtl transformers + liftI, liftIterIO + , runContTI, runErrorTI, runListTI, runReaderTI + , runRWSI, runRWSLI, runStateTI, runStateTLI + , runWriterTI, runWriterTLI + -- * Functions for building new monad adapters + , adaptIter, adaptIterM + -- * Iter-specific state monad transformer + , IterStateT(..), runIterStateT + , iget, igets, iput, imodify + ) where + +import Control.Monad.Cont +import Control.Monad.Error +import Control.Monad.List +import Control.Monad.Reader +import Control.Monad.RWS.Strict +import Control.Monad.State.Strict +import Control.Monad.Writer.Strict +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 + +-- +-- IterStateT monad +-- + +-- | @IterStateT@ is a variant of the 'StateT' monad transformer +-- specifically designed for use inside 'Iter's. The 'IterStateT' +-- Monad itself is the same as 'StateT'. However, the 'runIterStateT' +-- function works differently from 'runStateT'--it returns an 'IterR' +-- and the result state separately. The advantage of this approach is +-- that you can still recover the state at the point of the excaption +-- even after an 'IterFail' or 'InumFail' condition. +newtype IterStateT s m a = IterStateT (s -> m (a, s)) + +instance (Monad m) => Monad (IterStateT s m) where + return a = IterStateT $ \s -> return (a, s) + (IterStateT mf) >>= k = IterStateT $ \s -> do (a, s') <- mf s + let (IterStateT kf) = k a + kf $! s' + fail = IterStateT . const . fail + +instance MonadTrans (IterStateT s) where + lift m = IterStateT $ \s -> m >>= \a -> return (a, s) + +instance (MonadIO m) => MonadIO (IterStateT s m) where + liftIO = lift . liftIO + +-- | Runs an @'IterStateT' s m@ computation on some state @s@. +-- Returns the result ('IterR') of the 'Iter' and the state of @s@ as +-- a pair. Pulls residual input up to the enclosing 'Iter' monad (as +-- with @'pullupResid'@ in "Data.IterIO.Inum"). +runIterStateT :: (ChunkData t, Monad m) => + Iter t (IterStateT s m) a -> s -> Iter t m (IterR t m a, s) +runIterStateT i0 s0 = Iter $ adapt s0 . runIter i0 + where adapt s (IterM (IterStateT f)) = + IterM $ liftM (uncurry $ flip adapt) (f s) + adapt s r = + stepR' r (adapt s) $ Done (setResid r mempty, s) (getResid r) + +-- | Returns the state in an @'Iter' t ('IterStateT' s m)@ monad. +-- Analogous to @'get'@ for a @'StateT' s m@ monad. +iget :: (Monad m) => Iter t (IterStateT s m) s +iget = lift $ IterStateT $ \s -> return (s, s) + +-- | Returns a particular field of the 'IterStateT' state, analogous +-- to @'gets'@ for @'StateT'@. +igets :: (Monad m) => (s -> a) -> Iter t (IterStateT s m) a +igets f = liftM f iget + +-- | Sets the 'IterStateT' state. Analogous to @'put'@ for +-- @'StateT'@. +iput :: (Monad m) => s -> Iter t (IterStateT s m) () +iput s = lift $ IterStateT $ \_ -> return ((), s) + +-- | Modifies the 'IterStateT' state. Analogous to @'modify'@ for +-- @'StateT'@. +imodify :: (Monad m) => (s -> s) -> Iter t (IterStateT s m) () +imodify f = lift $ IterStateT $ \s -> return ((), f s) + +-- +-- Adapter utility functions +-- + +-- | Adapt an 'Iter' from one monad to another. This function is the +-- lowest-level monad adapter function, upon which all of the other +-- adapters are built. @adaptIter@ requires two functions as +-- arguments. One adapts the result to a new type (if required). The +-- second adapts monadic computations from one monad to the other. +-- For example, 'liftI' could be implemented as: +-- +-- @ +-- liftI :: ('MonadTrans' t, Monad m, Monad (t m), 'ChunkData' s) => +-- 'Iter' s m a -> 'Iter' s (t m) a +-- liftI = adaptIter 'id' (\\m -> 'lift' ('lift' m) >>= liftI) +-- @ +-- +-- Here @'lift' ('lift' m)@ executes a computation @m@ of type @m +-- ('Iter' s m a)@ from within the @'Iter' s (t m)@ monad. The +-- result, of type @'Iter' s m a@, can then be fed back into +-- @liftI@ recursively. +-- +-- Note that in general a computation adapters must invoke the outer +-- adapter function recursively. @adaptIter@ is designed this way +-- because the result adapter function may need to change. An example +-- is 'runStateTI', which could be implemented as follows: +-- +-- > runStateTI :: (ChunkData t, Monad m) => +-- > Iter t (StateT s m) a -> s -> Iter t m (a, s) +-- > runStateTI iter s = adaptIter adaptResult adaptComputation iter +-- > where adaptResult a = (a, s) +-- > adaptComputation m = do (r', s') <- lift (runStateT m s) +-- > runStateTI r' s' +-- +-- Here, after executing 'runStateT', the state may be modified. +-- Thus, @adaptComputation@ invokes @runStateTI@ recursively with the +-- modified state, @s'@, to ensure that subsequent 'IterM' +-- computations will be run on the latest state, and that eventually +-- @adaptResult@ will pair the result @a@ with the newest state. +adaptIter :: (ChunkData t, Monad m1) => + (a -> b) -- ^ How to adapt result values + -> (m1 (Iter t m1 a) -> Iter t m2 b) -- ^ How to adapt computations + -> Iter t m1 a -- ^ Input computation + -> Iter t m2 b -- ^ Output computation +adaptIter f mf i = Iter $ check . runIter i + where check (IterM m) = runIter (mf $ liftM (Iter . runIterR) m) mempty + check r = stepR' r check $ fmapR f r + +-- | Simplified adapter function to translate 'Iter' computations from +-- one monad to another. This only works on monads @m@ for which +-- running @m a@ returns a result of type @a@. For more complex +-- scenarios (such as 'ListT' or 'StateT'), you need to use the more +-- general 'adaptIter'. +-- +-- As an example, the 'liftIterIO' function is implemented as follows: +-- +-- @ +-- liftIterIO :: (ChunkData t, 'MonadIO' m) => Iter t IO a -> Iter t m a +-- liftIterIO = adaptIterM 'liftIO' +-- @ +adaptIterM :: (ChunkData t, Monad m1, Monad m2) => + (m1 (Iter t m1 a) -> m2 (Iter t m1 a)) -- ^ Conversion function + -> Iter t m1 a -- ^ 'Iter' of input monad + -> Iter t m2 a -- ^ Returns 'Iter' of output monad +adaptIterM f = adapt + where adapt = adaptIter id $ lift . f >=> adapt + +-- | Run an @'Iter' s m@ computation from witin the @'Iter' s (t m)@ +-- monad, where @t@ is a 'MonadTrans'. +liftI :: (MonadTrans t, Monad m, Monad (t m), ChunkData s) => + Iter s m a -> Iter s (t m) a +liftI = adaptIterM lift + +-- | Run an @'Iter' t IO@ computation from within an @'Iter' t m@ +-- monad where @m@ is in class 'MonadIO'. +liftIterIO :: (ChunkData t, MonadIO m) => + Iter t IO a -> Iter t m a +liftIterIO = adaptIterM liftIO + +-- +-- mtl runner functions +-- + +-- | The type signature says it all. Just a slightly optimized +-- version of @joinlift = join . lift@. +joinlift :: (Monad m) => m (Iter t m a) -> Iter t m a +joinlift m = Iter $ \c -> IterM $ m >>= \i -> return $ runIter i c + +-- | Turn a computation of type @'Iter' t ('ContT' ('Iter' t m a) m) +-- a@ into one of type @'Iter' t m a@. Note the continuation has to +-- return type @'Iter' t m a@ and not @a@ so that runContTI can call +-- itself recursively. +runContTI :: (ChunkData t, Monad m) => + Iter t (ContT (Iter t m a) m) a -> Iter t m a +runContTI = adaptIter id adapt + where adapt m = joinlift $ runContT m $ return . runContTI +-- adapt :: ContT (Iter t m a) m (Iter t (ContT (Iter t m a) m) a) +-- -> Iter t m a + +-- | Run a computation of type @'Iter' t ('ErrorT' e m)@ from within +-- the @'Iter' t m@ monad. This function is here for completeness, +-- but please consider using 'throwI' instead, since the 'Iter' monad +-- already has built-in exception handling and it's best to have a +-- single, uniform approach to error reporting. +runErrorTI :: (Monad m, ChunkData t, Error e) => + Iter t (ErrorT e m) a -> Iter t m (Either e a) +runErrorTI = adaptIter Right $ lift . runErrorT >=> next + where next (Left e) = return $ Left e + next (Right iter) = runErrorTI iter + +-- | Run an @'Iter' t ('ListT' m)@ computation from within the @'Iter' +-- t m@ monad. +runListTI :: (Monad m, ChunkData t) => + Iter t (ListT m) a -> Iter t m [a] +runListTI = adaptIter (: []) $ + lift . runListT >=> liftM concat . runListTI . sequence + +-- | Run an @'Iter' t ('ReaderT' r m)@ computation from within the +-- @'Iter' t m@ monad. +runReaderTI :: (ChunkData t, Monad m) => + Iter t (ReaderT r m) a -> r -> Iter t m a +runReaderTI m r = adaptIterM (flip runReaderT r) m + +-- | Run an @'Iter' t ('RWST' r w s m)@ computation from within the +-- @'Iter' t m@ monad. +runRWSI :: (ChunkData t, Monoid w, Monad m) => + Iter t (RWST r w s m) a -- ^ Computation to transform + -> r -- ^ Reader State + -> s -- ^ Mutable State + -> Iter t m (a, s, w) -- ^ Returns result, mutable state, writer +runRWSI iter0 r s0 = doRWS mempty s0 iter0 + where doRWS w s = adaptIter (\a -> (a, s, w)) $ \m -> do + (iter, s', w') <- lift $ runRWST m r s + doRWS (mappend w w') s' iter + +-- | Run an @'Iter' t ('Lazy.RWST' r w s m)@ computation from within +-- the @'Iter' t m@ monad. Just like 'runRWSI', execpt this function +-- is for /Lazy/ 'Lazy.RWST' rather than strict 'RWST'. +runRWSLI :: (ChunkData t, Monoid w, Monad m) => + Iter t (Lazy.RWST r w s m) a + -- ^ Computation to transform + -> r -- ^ Reader State + -> s -- ^ Mutable State + -> Iter t m (a, s, w) -- ^ Returns result, mutable state, writer +runRWSLI iter0 r s0 = doRWS mempty s0 iter0 + where doRWS w s = adaptIter (\a -> (a, s, w)) $ \m -> do + (iter, s', w') <- lift $ Lazy.runRWST m r s + doRWS (mappend w w') s' iter + +-- | Run an @'Iter' t ('StateT' m)@ computation from within the +-- @'Iter' t m@ monad. +runStateTI :: (ChunkData t, Monad m) => + Iter t (StateT s m) a -> s -> Iter t m (a, s) +runStateTI iter0 s0 = adaptIter (\a -> (a, s0)) adapt iter0 + where adapt m = lift (runStateT m s0) >>= uncurry runStateTI + +-- | Run an @'Iter' t ('Lazy.StateT' m)@ computation from within the +-- @'Iter' t m@ monad. Just like 'runStateTI', except this function +-- works on /Lazy/ 'Lazy.StateT' rather than strict 'StateT'. +runStateTLI :: (ChunkData t, Monad m) => + Iter t (Lazy.StateT s m) a -> s -> Iter t m (a, s) +runStateTLI iter0 s0 = adaptIter (\a -> (a, s0)) adapt iter0 + where adapt m = lift (Lazy.runStateT m s0) >>= uncurry runStateTLI + +-- | Run an @'Iter' t ('WriterT' w m)@ computation from within the +-- @'Iter' t m@ monad. +runWriterTI :: (ChunkData t, Monoid w, Monad m) => + Iter t (WriterT w m) a -> Iter t m (a, w) +runWriterTI = doW mempty + where doW w = adaptIter (\a -> (a, w)) $ + lift . runWriterT >=> \(iter, w') -> doW (mappend w w') iter + +-- | Run an @'Iter' t ('Lazy.WriterT' w m)@ computation from within +-- the @'Iter' t m@ monad. This is the same as 'runWriterT' but for +-- the /Lazy/ 'Lazy.WriterT', rather than the strict one. +runWriterTLI :: (ChunkData t, Monoid w, Monad m) => + Iter t (Lazy.WriterT w m) a -> Iter t m (a, w) +runWriterTLI = doW mempty + where doW w = adaptIter (\a -> (a, w)) $ + lift . Lazy.runWriterT >=> \(iter, w') -> + doW (mappend w w') iter + +-- +-- Below this line, we use FlexibleInstances and UndecidableInstances, +-- but only because this is required by mtl. +-- + +instance (ChunkData t, MonadCont m) => MonadCont (Iter t m) where + callCC f = joinlift $ (callCC $ \cc -> return $ f (icont cc)) + where icont cc a = Iter $ \c -> IterM $ cc (Iter $ \_ -> Done a c) + +instance (Error e, MonadError e m, ChunkData t) => + MonadError e (Iter t m) where + throwError = lift . throwError + catchError m0 h = adaptIter id (joinlift . runm) m0 + where runm m = do + r <- catchError (liftM Right m) (return . Left . h) + case r of + Right iter -> return $ catchError iter h + Left iter -> return iter + +instance (MonadReader r m, ChunkData t) => MonadReader r (Iter t m) where + ask = lift ask + local f = adaptIterM $ local f + +instance (MonadState s m, ChunkData t) => MonadState s (Iter t m) where + get = lift get + put = lift . put + +instance (Monoid w, MonadWriter w m, ChunkData t) => + MonadWriter w (Iter t m) where + tell = lift . tell + listen = adapt mempty + where adapt w = adaptIter (\a -> (a, w)) $ + lift . listen >=> \(iter, w') -> + adapt (mappend w w') iter + pass m = do + ((a, f), w) <- adapt mempty m + tell (f w) + return a + where + adapt w = adaptIter (\af -> (af, w)) $ + lift . censor (const mempty) . listen >=> \(i, w') -> + adapt (mappend w w') i + +-- +-- and instances for IterStateT (which are identical to StateT) +-- + +unIterStateT :: IterStateT s m a -> (s -> m (a, s)) +unIterStateT (IterStateT f) = f + +instance (MonadCont m) => MonadCont (IterStateT s m) where + callCC f = IterStateT $ \s -> callCC $ \c -> + unIterStateT (f (\a -> IterStateT $ \s' -> c (a, s'))) s + +instance (MonadError e m) => MonadError e (IterStateT s m) where + throwError = lift . throwError + catchError m h = IterStateT $ \s -> + unIterStateT m s `catchError` \e -> + unIterStateT (h e) s + +instance (MonadReader r m) => MonadReader r (IterStateT s m) where + ask = lift ask + local f m = IterStateT $ \s -> local f (unIterStateT m s) + +instance (MonadWriter w m) => MonadWriter w (IterStateT s m) where + tell = lift . tell + listen m = IterStateT $ \s -> do + ((a, s'), w) <- listen (unIterStateT m s) + return ((a, w), s') + pass m = IterStateT $ \s -> pass $ do + ((a, f), s') <- unIterStateT m s + return ((a, s'), f) diff --git a/Data/IterIO/Zlib.hs b/Data/IterIO/Zlib.hs new file mode 100644 --- /dev/null +++ b/Data/IterIO/Zlib.hs @@ -0,0 +1,261 @@ + +module Data.IterIO.Zlib (-- * Codec and Inum functions + ZState, deflateInit2, inflateInit2 + , inumZState, inumZlib, inumGzip, inumGunzip + -- * Constants from zlib.h + , max_wbits, max_mem_level, def_mem_level, zlib_version + , z_DEFAULT_COMPRESSION + , ZStrategy, z_FILTERED, z_HUFFMAN_ONLY, z_RLE + , z_FIXED, z_DEFAULT_STRATEGY + , ZMethod, z_DEFLATED + ) where + +import Prelude hiding (null) +import Control.Exception (throwIO, ErrorCall(..)) +import Control.Monad.State.Strict +-- import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as L +import Foreign +import Foreign.C + +import Data.IterIO.Iter +import Data.IterIO.Inum +import Data.IterIO.ZlibInt + +-- | State used by 'inumZState', the most generic zlib 'Inum'. +-- Create the state using 'deflateInit2' or 'inflateInit2'. +data ZState = ZState { zStream :: (ForeignPtr ZStream) + , zOp :: (ZFlush -> IO CInt) + , zFinish :: !ZFlush + , zInChunk :: !(ForeignPtr Word8) + , zOutChunk :: !(ForeignPtr Word8) + , zOut :: L.ByteString -> L.ByteString + } + +defaultZState :: ZState +defaultZState = ZState { zStream = error "must allocate zStream" + , zOp = error "must define zOp" + , zFinish = z_FINISH + , zInChunk = S.nullForeignPtr + , zOutChunk = S.nullForeignPtr + , zOut = id + } + +newZStream :: (Ptr ZStream -> IO CInt) -> IO (ForeignPtr ZStream) +newZStream initfn = do + zs <- mallocForeignPtrBytes z_stream_size + withForeignPtr zs $ \ptr -> + do _ <- S.memset (castPtr ptr) 0 z_stream_size + err <- initfn ptr + when (err /= z_OK) $ throwIO $ ErrorCall "newZStream: init failed" + return zs + +-- | Create a 'ZState' for compression. See the description of +-- @deflateInit2@ in the zlib.h C header file for a more detailed +-- description of the arguments. Note in particular that the value of +-- @windowBits@ determines the encapsulation format of the compressed +-- data: +-- +-- * 8..15 = zlib format +-- +-- * 24..31 = gzip format +-- +-- * -8..-15 = means raw zlib format with no header +deflateInit2 :: CInt + -- ^ Compression level (use 'z_DEFAULT_COMPRESSION' for default) + -> ZMethod + -- ^ Method (use 'z_DEFLATED') + -> CInt + -- ^ @windowBits@ (e.g., 'max_wbits') + -> CInt + -- ^ @memLevel@ (e.g., 'def_mem_level') + -> ZStrategy + -- ^ strategy (e.g., 'z_DEFAULT_STRATEGY') + -> IO ZState +deflateInit2 level method windowBits memLevel strategy = do + z <- newZStream $ \ptr -> (c_deflateInit2 ptr level method windowBits + memLevel strategy zlib_version z_stream_size) + addForeignPtrFinalizer c_deflateEnd z + return defaultZState { zStream = z + , zOp = \flush -> withForeignPtr z $ \zp -> + c_deflate zp flush + } + +-- | Create a 'Zstate' for uncompression. See the description of +-- @inflateInit2@ in the zlib.h C header file for a more detailed +-- description of the arguments. Note in particular that the value of +-- @windowBits@ determines the encapsulation format of the compressed +-- data: +-- +-- * 8..15 = zlib format +-- +-- * 24..31 = gzip format +-- +-- * 40..47 = automatically determine zlib/gzip format +-- +-- * -8..-15 = means raw zlib format with no header +inflateInit2 :: CInt + -- ^ windowBits + -> IO ZState +inflateInit2 windowBits = do + z <- newZStream $ \ptr -> (c_inflateInit2 ptr windowBits + zlib_version z_stream_size) + addForeignPtrFinalizer c_inflateEnd z + return defaultZState { zStream = z + , zOp = \flush -> withForeignPtr z $ \zp -> + c_inflate zp flush + , zFinish = z_NO_FLUSH + -- Library documentation makes it sound like + -- you don't need Z_FINISH for inflating, and + -- it could cause problems if the output buffer + -- is not large enough. + } + +type ZM = StateT ZState IO + +withZFP :: (ZState -> ForeignPtr a) -> (Ptr a -> ZM b) -> ZM b +withZFP field k = StateT $ \zs -> + withForeignPtr (field zs) $ \v -> (runStateT $ k v) zs + +zPeek :: (Storable a) => (Ptr ZStream -> Ptr a) -> ZM a +zPeek f = withZFP zStream $ liftIO . peek . f + +zPoke :: (Storable a) => (Ptr ZStream -> Ptr a) -> a -> ZM () +zPoke f a = withZFP zStream $ liftIO . flip poke a . f + +zPokeFP :: (Ptr ZStream -> Ptr (Ptr Word8)) -> ForeignPtr Word8 -> Int -> ZM () +zPokeFP f fp offset = withZFP zStream $ \z -> + liftIO $ withForeignPtr fp $ \p -> + poke (f z) $ p `plusPtr` offset + +zMinusPtr :: (Ptr ZStream -> Ptr (Ptr Word8)) + -> (ZState -> ForeignPtr Word8) + -> ZM Int +zMinusPtr curf basef = withZFP basef $ \base -> + if base == nullPtr + then return 0 + else do + cur <- zPeek curf + return $ cur `minusPtr` base + +zPushIn :: L.ByteString -> ZM L.ByteString +zPushIn s = do + avail <- zPeek avail_in + if avail > 0 then return s else pushit s + where + pushit (L.Chunk h t) = do + let (fp, offset, len) = S.toForeignPtr h + modify $ \zs -> zs { zInChunk = fp } + zPokeFP next_in fp offset + zPoke avail_in $ fromIntegral len + return t + pushit L.Empty = return L.Empty + +zPopIn :: L.ByteString -> ZM L.ByteString +zPopIn s = do + len <- zPeek avail_in + if len <= 0 + then return s + else do + fptr <- gets zInChunk + offset <- zMinusPtr next_in zInChunk + zPoke avail_in 0 + return $ L.chunk (S.fromForeignPtr fptr offset $ fromIntegral len) s + +zOutLen :: ZM Int +zOutLen = zMinusPtr next_out zOutChunk + +zPopOut :: ZM () +zPopOut = do + len <- zOutLen + when (len > 0) $ do + ochunk <- liftM (\c -> S.fromForeignPtr c 0 len) $ gets zOutChunk + out <- liftM (. L.chunk ochunk) $ gets zOut + modify $ \zs -> zs { zOutChunk = S.nullForeignPtr + , zOut = out } + zPoke avail_out 0 + +zMkSpace :: ZM () +zMkSpace = do + avail <- zPeek avail_out + when (avail <= 0) $ do + zPopOut + nchunk <- liftIO $ S.mallocByteString L.defaultChunkSize + zPokeFP next_out nchunk 0 + zPoke avail_out $ fromIntegral L.defaultChunkSize + modify $ \zs -> zs { zOutChunk = nchunk } + +zExec :: ZFlush -> ZM CInt +zExec flush = do + zMkSpace + op <- gets zOp + r <- withZFP zInChunk $ \_ -> liftIO $ op flush + avail <- zPeek avail_out + case () of + _ | r == z_OK && avail == 0 -> zExec flush + _ | r == z_NEED_DICT -> liftIO $ throwIO $ ErrorCall "zlib NEED_DICT" + _ | r == z_STREAM_END -> do zPopOut + return r + _ | r < 0 -> do cm <- zPeek msg + m <- if cm == nullPtr + then return $ "zlib failed (" + ++ show r ++ ")" + else liftIO $ peekCString cm + liftIO $ throwIO $ ErrorCall m + _ | otherwise -> return r + + +-- | The most general zlib 'Inum', which can take any 'ZState' created +-- by 'deflateInit2' or 'inflateInit2'. +inumZState :: (MonadIO m) => + ZState + -> Inum L.ByteString L.ByteString m a +inumZState = mkInumM . loop + where + loop zs0 = do + (Chunk dat eof) <- chunkI + ((r, rest), zs) <- liftIO (runStateT (runz eof dat) zs0) + ungetI rest + done <- ifeed $ zOut zs L.empty + unless (done || eof || r == z_STREAM_END) $ loop zs { zOut = id } + + runz False L.Empty = return (z_OK, L.Empty) + runz eof s0 = do + s <- zPushIn s0 + flush <- if eof && L.null s then gets zFinish else return z_NO_FLUSH + r <- zExec flush + if r == z_STREAM_END || L.null s + then do s' <- zPopIn s; return (r, s') + else runz eof s + +-- | An 'Inum' that compresses in zlib format. To uncompress, use +-- 'inumGunzip'. +inumZlib :: (MonadIO m) => Inum L.ByteString L.ByteString m a +inumZlib iter = do + zs <- liftIO (deflateInit2 z_DEFAULT_COMPRESSION z_DEFLATED max_wbits + def_mem_level z_DEFAULT_STRATEGY) + inumZState zs iter + +-- | An 'Inum' that compresses in gzip format. +inumGzip :: (MonadIO m) => Inum L.ByteString L.ByteString m a +inumGzip iter = do + zs <- liftIO (deflateInit2 z_DEFAULT_COMPRESSION z_DEFLATED (16 + max_wbits) + def_mem_level z_DEFAULT_STRATEGY) + inumZState zs iter + +-- | An 'Inum' that uncompresses a data in either the zlib or gzip +-- format. Note that this only uncompresses one gzip stream. Thus, +-- if you feed in the concatenation of multiple gzipped files, +-- @inumGunzip@ will stop after the first one. If this is not what +-- you want, then use @'inumRepeat' inumGunzip@ to decode repeated +-- gzip streams. +inumGunzip :: (MonadIO m) => Inum L.ByteString L.ByteString m a +inumGunzip iter = do + zs <- liftIO $ inflateInit2 (32 + max_wbits) + inumZState zs iter + +-- Local Variables: +-- haskell-program-name: "ghci -lz" +-- End: diff --git a/Data/IterIO/ZlibInt.hsc b/Data/IterIO/ZlibInt.hsc new file mode 100644 --- /dev/null +++ b/Data/IterIO/ZlibInt.hsc @@ -0,0 +1,124 @@ +{-# OPTIONS_GHC -fno-warn-deprecated-flags #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | This module exposes the raw FFI interface to zlib C functions. +-- It is intended for internal use only, and should not be imported by +-- code outside the IterIO library. +module Data.IterIO.ZlibInt where + +import Data.Word +import Foreign +import Foreign.C + +#include "zlib.h" + +foreign import ccall unsafe "zlib.h deflateInit_" + c_deflateInit :: Ptr ZStream -> CInt -> CString -> CInt -> IO CInt +foreign import ccall unsafe "zlib.h deflateInit2_" + c_deflateInit2 :: Ptr ZStream -> CInt -> ZMethod -> CInt -> CInt + -> ZStrategy -> CString -> CInt -> IO CInt +foreign import ccall unsafe "zlib.h deflate" + c_deflate :: Ptr ZStream -> ZFlush -> IO CInt +foreign import ccall unsafe "zlib.h &deflateEnd" + c_deflateEnd :: FunPtr (Ptr ZStream -> IO ()) + +foreign import ccall unsafe "zlib.h inflateInit_" + c_inflateInit :: Ptr ZStream -> CString -> CInt -> IO CInt +foreign import ccall unsafe "zlib.h inflateInit2_" + c_inflateInit2 :: Ptr ZStream -> CInt -> CString -> CInt -> IO CInt +foreign import ccall unsafe "zlib.h inflate" + c_inflate :: Ptr ZStream -> ZFlush -> IO CInt +foreign import ccall unsafe "zlib.h &inflateEnd" + c_inflateEnd :: FunPtr (Ptr ZStream -> IO ()) + +-- | Use this value for zlib format. Add 16 for gzip format. Negate +-- for raw zlib format. When uncompressing, add 32 to determine +-- zlib/gzip format automatically. +max_wbits :: CInt +max_wbits = #const MAX_WBITS + +max_mem_level :: CInt +max_mem_level = #const MAX_MEM_LEVEL + +def_mem_level :: CInt +def_mem_level = #const MAX_MEM_LEVEL > 8 ? 8 : MAX_MEM_LEVEL + +zlib_version :: CString +zlib_version = unsafePerformIO $ newCAString #const_str ZLIB_VERSION + +z_stream_size :: (Num a) => a +z_stream_size = #size z_stream + +#def struct zssz { z_stream z; char c; }; +z_stream_alignment :: Int +z_stream_alignment = #const sizeof (struct zssz) - sizeof (z_stream) + +data ZStream = ZStream + +#{let zoffdef type, field = + #field " :: Ptr ZStream -> Ptr (" #type ")\n" + #field " zptr = zptr `plusPtr` %ld" + , (long) offsetof (z_stream, field)} +#zoffdef Ptr Word8, next_in +#zoffdef CUInt, avail_in +#zoffdef CULong, total_in +#zoffdef Ptr Word8, next_out +#zoffdef CUInt, avail_out +#zoffdef CULong, total_out +#zoffdef CString, msg +#zoffdef FunPtr (Ptr a -> CUInt -> CUInt -> Ptr b), zalloc +#zoffdef FunPtr (Ptr a -> Ptr b -> ()), zfree +#zoffdef Ptr a, opaque +#zoffdef ZDataType, data_type +#zoffdef CULong, adler + +newtype ZFlush = ZFlush CInt +#{enum ZFlush, ZFlush + , z_NO_FLUSH = Z_NO_FLUSH + , z_SYNC_FLUSH = Z_SYNC_FLUSH + , z_FULL_FLUSH = Z_FULL_FLUSH + , z_FINISH = Z_FINISH + , z_BLOCK = Z_BLOCK + } + +#{enum CInt, + , z_OK = Z_OK + , z_STREAM_END = Z_STREAM_END + , z_NEED_DICT = Z_NEED_DICT + , z_ERRNO = Z_ERRNO + , z_STREAM_ERROR = Z_STREAM_ERROR + , z_DATA_ERROR = Z_DATA_ERROR + , z_MEM_ERROR = Z_MEM_ERROR + , z_BUF_ERROR = Z_BUF_ERROR + , z_VERSION_ERROR = Z_VERSION_ERROR + } + +#{enum CInt, + , z_DEFAULT_COMPRESSION = Z_DEFAULT_COMPRESSION + } + +newtype ZStrategy = ZStrategy CInt +#{enum ZStrategy, ZStrategy + , z_FILTERED = Z_FILTERED + , z_HUFFMAN_ONLY = Z_HUFFMAN_ONLY + , z_RLE = Z_RLE + , z_FIXED = Z_FIXED + , z_DEFAULT_STRATEGY = Z_DEFAULT_STRATEGY + } + +newtype ZDataType = ZDataType CInt +#{enum ZDataType, ZDataType + , z_BINARY = Z_BINARY + , z_TEXT = Z_TEXT + , z_UNKNOWN = Z_UNKNOWN + } + +newtype ZMethod = ZMethod CInt +#{enum ZMethod, ZMethod + , z_DEFLATED = Z_DEFLATED + } + + +-- Local Variables: +-- haskell-program-name: "ghci -lz" +-- End: diff --git a/Examples/fgrep.hs b/Examples/fgrep.hs new file mode 100644 --- /dev/null +++ b/Examples/fgrep.hs @@ -0,0 +1,59 @@ + +module Main where + +import qualified Data.ByteString.Lazy.Char8 as L8 +import qualified Data.ByteString.Lazy as L + +import Control.Monad +import Control.Monad.Trans +import System.Environment +import System.Exit +import System.IO +-- import System.IO.Error + +import Data.IterIO + +filterLines :: (Monad m) => + String + -> Inum L.ByteString [L.ByteString] m a +filterLines s = mkInum loop + where + loop = do line <- lineI + if match line then return [line] else loop + ls = L8.pack s + match l | L.null l = False + | otherwise = L.isPrefixOf ls l || match (L.tail l) + +printLines :: (MonadIO m) => Iter [L.ByteString] m () +printLines = do + line <- safeHeadI + case line of + Just l -> do liftIO $ L.putStrLn l + printLines + Nothing -> return () + +enumFileCatchError :: (MonadIO m) => FilePath -> Onum L.ByteString m a +enumFileCatchError file = enumFile file `inumCatch` enumCatchIO + where + enumCatchIO :: (ChunkData t, MonadIO m) => + IOError + -> IterR () m (IterR t m a) + -> Iter () m (IterR t m a) + enumCatchIO _ = verboseResumeI + -- or to avoid the need for a type signature, you could say: + -- enumCatchIO e = flip const (e :: IOError) verboseResumeI + +main :: IO () +main = do + prog <- getProgName + av <- getArgs + unless (length av >= 1) $ do + hPutStrLn stderr $ "usage: " ++ prog ++ " string [file ...]" + exitFailure + hSetBuffering stdout NoBuffering + let pat = head av + enum = if length av == 1 + then enumHandle stdin + else foldr1 cat $ map enumFileCatchError $ tail av + enum |. filterLines pat |$ printLines + exitSuccess diff --git a/Examples/httptest.hs b/Examples/httptest.hs new file mode 100644 --- /dev/null +++ b/Examples/httptest.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Prelude hiding (catch, head, id, div) +import Control.Concurrent +import Control.Exception +import Control.Monad +import Control.Monad.Trans +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +-- import qualified Data.ByteString.Lazy.Char8 as L8 +import Data.Monoid +import qualified Network.Socket as Net +import qualified OpenSSL as SSL +import qualified OpenSSL.Session as SSL +import System.IO +import System.Posix.Files + +import Data.IterIO +-- import Data.IterIO.Parse +import Data.IterIO.Http +import Data.IterIO.HttpRoute +import Data.IterIO.SSL +import System.Directory (getAppUserDataDirectory) +import System.IO.Unsafe (unsafePerformIO) + +type L = L.ByteString + +data HttpServer = HttpServer { + hsListenSock :: !Net.Socket + , hsSslCtx :: !(Maybe SSL.SSLContext) + , hsLog :: !(Maybe Handle) + } + +myListen :: Net.PortNumber -> IO Net.Socket +myListen pn = do + sock <- Net.socket Net.AF_INET Net.Stream Net.defaultProtocol + Net.setSocketOption sock Net.ReuseAddr 1 + Net.bindSocket sock (Net.SockAddrInet pn Net.iNADDR_ANY) + Net.listen sock Net.maxListenQueue + return sock + +mkServer :: Net.PortNumber -> Maybe SSL.SSLContext -> IO HttpServer +mkServer port mctx = do + sock <- myListen port + h <- openBinaryFile "http.log" WriteMode + hSetBuffering h NoBuffering + return $ HttpServer sock mctx (Just h) + +mimeMap :: String -> S8.ByteString +mimeMap = unsafePerformIO $ do + path <- findMimeTypes ["mime.types" + , "/etc/mime.types" + , "/var/www/conf/mime.types"] + enumFile path |$ mimeTypesI "application/octet-stream" + where + findMimeTypes (h:t) = do exist <- fileExist h + if exist then return h else findMimeTypes t + findMimeTypes [] = return "mime.types" -- cause error + +routeFS :: (MonadIO m) => FilePath -> HttpRoute m +routeFS = routeFileSys mimeMap (dirRedir "index.html") + +cabal_dir :: String +cabal_dir = (unsafePerformIO $ getAppUserDataDirectory "cabal") ++ "/share/doc" + +route :: (MonadIO m) => HttpRoute m +route = mconcat + [ routeTop $ routeConst $ resp301 "/cabal" + , routeMap' [ ("cabal", routeConst $ resp301 cabal_dir) + , ("static", routeFS "static") -- directory ./static + , ("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" $ + routeFS "static/favicon.ico") + ] + , routePath cabal_dir $ routeFS cabal_dir + , routePath "/usr/share/doc/ghc/html" $ + routeFS "/usr/share/doc/ghc/html" + ] + +accept_loop :: HttpServer -> IO () +accept_loop srv = loop + where + loop = do + (s, addr) <- Net.accept $ hsListenSock srv + hPutStrLn stderr (show addr) + _ <- forkIO $ server s + loop + server s = do + (iter, enum) <- maybe (iterStream s) (\ctx -> iterSSL ctx s True) + (hsSslCtx srv) + let loger = maybe inumNop inumhLog $ hsLog srv + enum |. loger |$ inumHttpServer (ioHttpServer handler) .| loger .| iter + handler = runHttpRoute route + +main :: IO () +main = Net.withSocketsDo $ SSL.withOpenSSL $ do + mctx <- if secure + then do + exists <- fileExist privkey + unless exists $ genSelfSigned privkey "localhost" + ctx <- simpleContext privkey + return $ Just ctx + else return Nothing + srv <- mkServer (if secure then 4433 else 8000) mctx + sem <- newQSem 0 + _ <- forkIO $ accept_loop srv `finally` signalQSem sem + waitQSem sem + where + privkey = "testkey.pem" + secure = True diff --git a/Examples/zpipe.hs b/Examples/zpipe.hs new file mode 100644 --- /dev/null +++ b/Examples/zpipe.hs @@ -0,0 +1,24 @@ + +module Main where + +import System.Environment +import System.IO + +import Data.IterIO +import Data.IterIO.Zlib + +main :: IO () +main = do + av <- getArgs + hSetBuffering stdout NoBuffering + case av of + -- The decision to put inumG[un]zip to the left or to the right + -- of |$ is arbitrary, so we do one of each. + [] -> enumStdin |$ inumGzip .| stdoutI + ["-d"] -> enumStdin |. inumRepeat inumGunzip |$ stdoutI + _ -> do prog <- getProgName + hPutStrLn stderr $ "usage: " ++ prog ++ " [-d]" + +-- Local Variables: +-- haskell-program-name: "ghci -lz" +-- End: diff --git a/GNUmakefile b/GNUmakefile new file mode 100644 --- /dev/null +++ b/GNUmakefile @@ -0,0 +1,68 @@ + +PKG = $(basename $(wildcard *.cabal)) +TARGETS := $(basename $(shell find Examples -name '[a-z]*.hs' -print)) +TESTS := $(basename $(shell find tests -name '[a-z]*.hs' -print)) +HSCS := $(patsubst %.hsc,%.hs,$(shell find . -name '*.hsc' -print)) +HSCCLEAN = $(patsubst %.hs,%_hsc.[ch],$(HSCS)) + +all: $(TARGETS) $(HSCS) + +.PHONY: all always clean build dist doc browse install hsc + +GHC = ghc $(WALL) +#GHC = ghc $(WALL) -prof -auto-all -caf-all -rtsopts=all -with-rtsopts=-xc +WALL = -Wall -Werror +LIBS = -lz + +always: + @: + +Examples/%: always $(HSCS) + $(GHC) --make -i$(dir $@) $@.hs $(LIBS) + +tests/%: always $(HSCS) + $(GHC) --make $@.hs + +%.hs: %.hsc + hsc2hs $< + +hsc: $(HSCS) + +Setup: Setup.hs + $(GHC) --make Setup.hs + +dist/setup-config: Setup $(PKG).cabal + ./Setup configure --user + +build: dist/setup-config + ./Setup build + +doc: dist/setup-config + ./Setup haddock --hyperlink-source + +dist: dist/setup-config + ./Setup sdist + +INDEXDOC = cd $(HOME)/.cabal/share/doc \ + && find . -name '*.haddock' -print \ + | sed -e 's/\.\/\(.*\)\/[^\/]*\.haddock/--read-interface=\1,&/' \ + | xargs -t haddock --gen-contents --gen-index --odir=. + +install: build doc + ./Setup install + $(INDEXDOC) + +uninstall: dist/setup-config + ./Setup unregister --user + rm -rf $(HOME)/.cabal/lib/$(PKG)-[0-9]* + rm -rf $(HOME)/.cabal/share/doc/$(PKG)-[0-9]* + $(INDEXDOC) + +browse: doc + xdg-open dist/doc/html/$(PKG)/index.html + +clean: + rm -rf dist + rm -f Setup $(TARGETS) $(TESTS) $(HSCS) $(HSCCLEAN) + find . \( -name '*~' -o -name '*.hi' -o -name '*.o' \) -print0 \ + | xargs -0 rm -f -- diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (C) 2009 David Mazieres + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions, and the following disclaimer. + + 2. 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. + + 3. The name of the author may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,11 @@ + +To build this package, install the Haskell platform +(http://hackage.haskell.org/platform/), then run the following +commands to install required packages: + + cabal update + cabal install ListLike HSOpenSSL stringsearch attoparsec + cabal install aeson blaze-html + cabal install binary regex-posix xhtml utf8-string + +Then run "make" or "gmake" to build the example programs. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/iterIO.cabal b/iterIO.cabal new file mode 100644 --- /dev/null +++ b/iterIO.cabal @@ -0,0 +1,99 @@ +Name: iterIO +Homepage: http://www.scs.stanford.edu/~dm/iterIO +Version: 0.1 +Cabal-version: >= 1.6 +build-type: Simple +License: BSD3 +License-file: LICENSE +Author: David Mazieres +Stability: experimental +Maintainer: http://www.scs.stanford.edu/~dm/addr/ +Category: System, Data, Enumerator +Synopsis: Iteratee-based IO with pipe operators +Extra-source-files: + GNUmakefile, README, + Examples/fgrep.hs, Examples/zpipe.hs, Examples/httptest.hs + +Description: + + Iteratee-based IO is an alternative to lazy IO that offers + better error handling, referential transparency, and + convenient composition of protocol layers or parsers. This + package provides iteratees based around /pipe/ operators for + hooking together application components and directing data + flow. New users should see the tutorial in the "Data.IterIO" + module documentation. Highlights of the library include: + + . + + * Heavy emphasis on ease of use, ease of learning, and + uniformity of mechanism. + + . + + * Copious documentation. + + . + + * Consistent EOF and error handling to avoid resource leaks + and other issues in corner cases. + + . + + * A set of iteratee parsing combinators providing LL(*) + parsing while generally not consuming large amounts of + memory for backtracking. + + . + + * Seamless integration with attoparsec for LL(1) parsing. + + . + + See "Data.IterIO" for a discussion of the differences between + iterIO and the two previous iteratee implementations (iteratee + and enumerator). + +Source-repository head + Type: git + Location: http://www.scs.stanford.edu/~dm/repos/iterIO.git + +Library + Build-depends: array >= 0.3.0.1 && < 2, + base >= 4.3 && < 6, + bytestring >= 0.9 && < 2, + containers >= 0.3 && < 2, + filepath >= 1.2 && < 2, + HsOpenSSL >= 0.8 && < 2, + ListLike >= 1.0 && < 4, + mtl >= 1.1.0.2 && < 3, + network >= 2.3 && < 3, + old-locale >= 1.0.0.2 && < 2, + attoparsec >= 0.8.5 && < 2, + process >= 1.0.1.3 && < 2, + stringsearch >= 0.3 && < 2, + time >= 1.1.4 && < 2, + unix >= 2.4 && < 3 + + ghc-options: -Wall + Exposed-modules: + Data.IterIO, + Data.IterIO.Atto, + Data.IterIO.Iter, + Data.IterIO.Extra, + Data.IterIO.Http, + Data.IterIO.HttpRoute, + Data.IterIO.Inum, + Data.IterIO.ListLike, + Data.IterIO.Parse, + Data.IterIO.SSL, + Data.IterIO.Search, + Data.IterIO.Trans, + Data.IterIO.Zlib + Other-modules: + Data.IterIO.ZlibInt + Extensions: + ForeignFunctionInterface, DeriveDataTypeable, + ExistentialQuantification, MultiParamTypeClasses, + FunctionalDependencies, FlexibleInstances + Extra-libraries: z