liboleg 0.1.0.1 → 0.1.0.2
raw patch · 9 files changed
+2597/−3 lines, 9 filesdep +unix
Dependencies added: unix
Files
- Codec/Image/Tiff.hs +623/−0
- LICENSE +1/−1
- System/IterateeM.hs +713/−0
- System/LowLevelIO.hs +121/−0
- System/RandomIO.hs +349/−0
- System/SysOpen.hs +219/−0
- cbits/sys_open.c +552/−0
- include/sys_open.h +2/−0
- liboleg.cabal +17/−2
+ Codec/Image/Tiff.hs view
@@ -0,0 +1,623 @@+{-# LANGUAGE Rank2Types #-}++--+-- | A general-purpose TIFF library+--+-- <http://okmij.org/ftp/Streams.html#random-bin-IO>+--+-- The library gives the user the TIFF dictionary, which the user+-- can search for specific tags and obtain the values associated with +-- the tags, including the pixel matrix.+--+-- The overarching theme is incremental processing: initially,+-- only the TIFF dictionary is read. The value associated with a tag+-- is read only when that tag is looked up (unless the value was short+-- and was packed in the TIFF dictionary entry). The pixel matrix+-- (let alone the whole TIFF file) is not loaded in memory -- +-- the pixel matrix is not even located before it is needed.+-- The matrix is processed incrementally, by a user-supplied +-- iteratee.+--+-- The incremental processing is accomplished by iteratees and enumerators.+-- The enumerators are indeed first-class, they are stored+-- in the interned TIFF dictionary data structure. These enumerators+-- represent the values associated with tags; the values will be read+-- on demand, when the enumerator is applied to a user-given iteratee.+--+-- The library extensively uses nested streams, tacitly converting the +-- stream of raw bytes from the file into streams of integers, +-- rationals and other user-friendly items. The pixel matrix is+-- presented as a contiguous stream, regardless of its segmentation+-- into strips and physical arrangement.+-- The library exhibits random IO and binary parsing, reading+-- of multi-byte numeric data in big- or little-endian formats.+-- The library can be easily adopted for AIFF, RIFF and other+-- IFF formats.+--+-- We show a representative application of the library: reading a sample+-- TIFF file, printing selected values from the TIFF dictionary,+-- verifying the values of selected pixels and computing the histogram+-- of pixel values. The pixel verification procedure stops reading the+-- pixel matrix as soon as all specified pixel values are verified.+-- The histogram accumulation does read the entire matrix, but+-- incrementally. Neither pixel matrix processing procedure loads+-- the whole matrix in memory. In fact, we never read and retain+-- more than the IO-buffer-full of raw data.++-- This TIFF library is to be contrasted with the corresponding Scheme+-- code:+-- <http://okmij.org/ftp/Scheme/binary-io.html#tiff>+-- The main distinction is using iteratees for on-demand processing.++module Codec.Image.Tiff where++import System.IterateeM+import System.RandomIO++import Control.Monad.Trans+import Data.Char (chr)+import Data.Int+import Data.Word+import Data.Ratio+import Data.Bits+import qualified Data.IntMap as IM+++-- ========================================================================+-- | Sample TIFF user code+-- The following is sample code using the TIFF library (whose implementation+-- is in the second part of this file).+-- Our sample code prints interesting information from the TIFF+-- dictionary (such as the dimensions, the resolution and the name+-- of the image)+--+-- The sample file is a GNU logo (from http://www.gnu.org)+-- converted from JPG to TIFF. Copyleft by GNU.+sample_tiff_file = "gnu-head-sm.tif"+++-- | The main user function. tiff_reader is the library function,+-- which builds the TIFF dictionary.+-- process_tiff is the user function, to extract useful data+-- from the dictionary+test_tiff = test_driver_random (tiff_reader >>= process_tiff) sample_tiff_file++-- | Sample TIFF processing function+process_tiff (Just dict) = do+ note ["dict size: ", show $ IM.size dict]+ -- Check tag values against the known values for the sample image+ check_tag TG_IMAGEWIDTH (flip dict_read_int dict) 129+ check_tag TG_IMAGELENGTH (flip dict_read_int dict) 122+ check_tag TG_BITSPERSAMPLE (flip dict_read_int dict) 8+ check_tag TG_IMAGEDESCRIPTION (flip dict_read_string dict)+ "JPEG:gnu-head-sm.jpg 129x122"+ check_tag TG_COMPRESSION (flip dict_read_int dict) 1+ check_tag TG_SAMPLESPERPIXEL (flip dict_read_int dict) 1+ check_tag TG_STRIPBYTECOUNTS (flip dict_read_int dict) 15738 -- nrows*ncols+ check_tag TG_XRESOLUTION (flip dict_read_rat dict) (72%1)+ check_tag TG_YRESOLUTION (flip dict_read_rat dict) (72%1)++ (n,hist) <- compute_hist dict+ note ["computed histogram over ", show n, " values\n", show hist]+ iter_report_err >>= maybe (return ()) error+ note ["Verifying values of sample pixels"]+ verify_pixel_vals dict [(0,255), (17,248)]+ err <- iter_report_err+ maybe (return ()) error err+ return err+ where check_tag tag action v = do+ vc <- action tag+ case vc of+ Just v' | v' == v -> note ["Tag ",show tag, " value ", show v]+ _ -> error $ unwords ["Tag", show tag, "unexpected:", show vc]++-- process_tiff Nothing = return Nothing++-- | sample processing of the pixel matrix: computing the histogram+compute_hist :: TIFFDict -> IterateeGM Word8 RBIO (Int,IM.IntMap Int)+compute_hist dict = joinI $ pixel_matrix_enum dict ==<< compute_hist' 0 IM.empty+ where+ compute_hist' count hist = liftI $ IE_cont (step count hist)+ step count hist (Chunk []) = compute_hist' count hist+ step count hist (Chunk ch) = compute_hist' (count + length ch) + (foldr accum hist ch)+ step count hist s = liftI $ IE_done (count,hist) s+ accum e h = IM.insertWith (+) (fromIntegral e) 1 h++-- | Another sample processor of the pixel matrix: verifying values of+-- some pixels+-- This processor does not read the whole matrix; it stops as soon+-- as everything is verified or the error is detected+verify_pixel_vals dict pixels = joinI $ pixel_matrix_enum dict ==<< + verify 0 (IM.fromList pixels)+ where+ verify _ m | IM.null m = return ()+ verify n m = liftI $ IE_cont (step n m)+ step n m (Chunk []) = verify n m+ step n m (Chunk (h:t)) = + case IM.updateLookupWithKey (\k e -> Nothing) n m of+ (Just v,m) -> if v == h then step (succ n) m (Chunk t)+ else iter_err $ unwords ["Pixel #",show n,+ "expected:",show v,+ "found", show h]+ (Nothing,m)-> step (succ n) m (Chunk t)+ step n m s = liftI $ IE_done () s+++-- ========================================================================+-- | TIFF library code+--+-- We need a more general enumerator type: enumerator that maps+-- streams (not necessarily in lock-step). This is+-- a flattened (`joinI-ed') EnumeratorN elfrom elto m a+type EnumeratorGMM elfrom elto m a =+ IterateeG elto m a -> IterateeGM elfrom m a+++-- | A TIFF directory is a finite map associating a TIFF tag with+-- a record TIFFDE+type TIFFDict = IM.IntMap TIFFDE++data TIFFDE = TIFFDE{tiffde_count :: Int, -- number of items+ tiffde_enum :: TIFFDE_ENUM -- enumerator to get values+ }++data TIFFDE_ENUM = TEN_CHAR (forall a. EnumeratorGMM Word8 Char RBIO a)+ | TEN_BYTE (forall a. EnumeratorGMM Word8 Word8 RBIO a)+ | TEN_INT (forall a. EnumeratorGMM Word8 Integer RBIO a)+ | TEN_RAT (forall a. EnumeratorGMM Word8 Rational RBIO a)++-- | Standard TIFF data types+data TIFF_TYPE = TT_NONE -- 0+ | TT_byte -- 1 8-bit unsigned integer+ | TT_ascii -- 2 8-bit bytes with last byte null+ | TT_short -- 3 16-bit unsigned integer+ | TT_long -- 4 32-bit unsigned integer+ | TT_rational -- 5 64-bit fractional (numer+denominator)+ -- The following was added in TIFF 6.0+ | TT_sbyte -- 6 8-bit signed (2s-complement) integer+ | TT_undefined -- 7 An 8-bit byte, "8-bit chunk"+ | TT_sshort -- 8 16-bit signed (2s-complement) integer+ | TT_slong -- 9 32-bit signed (2s-complement) integer+ | TT_srational -- 10 "signed rational", two SLONGs (num+denominator)+ | TT_float -- 11 "IEEE 32-bit float", single precision (4-byte)+ | TT_double -- 12 "IEEE 64-bit double", double precision (8-byte)+ deriving (Eq, Enum, Ord, Bounded, Show)+++-- | Standard TIFF tags+data TIFF_TAG = TG_other Int -- other than below+ | TG_SUBFILETYPE -- subfile data descriptor+ | TG_OSUBFILETYPE -- +kind of data in subfile+ | TG_IMAGEWIDTH -- image width in pixels+ | TG_IMAGELENGTH -- image height in pixels+ | TG_BITSPERSAMPLE -- bits per channel (sample)+ | TG_COMPRESSION -- data compression technique+ | TG_PHOTOMETRIC -- photometric interpretation+ | TG_THRESHOLDING -- +thresholding used on data+ | TG_CELLWIDTH -- +dithering matrix width+ | TG_CELLLENGTH -- +dithering matrix height+ | TG_FILLORDER -- +data order within a byte+ | TG_DOCUMENTNAME -- name of doc. image is from+ | TG_IMAGEDESCRIPTION -- info about image+ | TG_MAKE -- scanner manufacturer name+ | TG_MODEL -- scanner model name/number+ | TG_STRIPOFFSETS -- offsets to data strips+ | TG_ORIENTATION -- +image orientation+ | TG_SAMPLESPERPIXEL -- samples per pixel+ | TG_ROWSPERSTRIP -- rows per strip of data+ | TG_STRIPBYTECOUNTS -- bytes counts for strips+ | TG_MINSAMPLEVALUE -- +minimum sample value+ | TG_MAXSAMPLEVALUE -- maximum sample value+ | TG_XRESOLUTION -- pixels/resolution in x+ | TG_YRESOLUTION -- pixels/resolution in y+ | TG_PLANARCONFIG -- storage organization+ | TG_PAGENAME -- page name image is from+ | TG_XPOSITION -- x page offset of image lhs+ | TG_YPOSITION -- y page offset of image lhs+ | TG_FREEOFFSETS -- +byte offset to free block+ | TG_FREEBYTECOUNTS -- +sizes of free blocks+ | TG_GRAYRESPONSEUNIT -- gray scale curve accuracy+ | TG_GRAYRESPONSECURVE -- gray scale response curve+ | TG_GROUP3OPTIONS -- 32 flag bits+ | TG_GROUP4OPTIONS -- 32 flag bits+ | TG_RESOLUTIONUNIT -- units of resolutions+ | TG_PAGENUMBER -- page numbers of multi-page+ | TG_COLORRESPONSEUNIT -- color scale curve accuracy+ | TG_COLORRESPONSECURVE -- RGB response curve+ | TG_SOFTWARE -- name & release+ | TG_DATETIME -- creation date and time+ | TG_ARTIST -- creator of image+ | TG_HOSTCOMPUTER -- machine where created+ | TG_PREDICTOR -- prediction scheme w/ LZW+ | TG_WHITEPOINT -- image white point+ | TG_PRIMARYCHROMATICITIES -- primary chromaticities+ | TG_COLORMAP -- RGB map for pallette image+ | TG_BADFAXLINES -- lines w/ wrong pixel count+ | TG_CLEANFAXDATA -- regenerated line info+ | TG_CONSECUTIVEBADFAXLINES -- max consecutive bad lines+ | TG_MATTEING -- alpha channel is present+ deriving (Eq, Show)++tag_map = [+ (TG_SUBFILETYPE,254),+ (TG_OSUBFILETYPE,255),+ (TG_IMAGEWIDTH,256),+ (TG_IMAGELENGTH,257),+ (TG_BITSPERSAMPLE,258),+ (TG_COMPRESSION,259),+ (TG_PHOTOMETRIC,262),+ (TG_THRESHOLDING,263),+ (TG_CELLWIDTH,264),+ (TG_CELLLENGTH,265),+ (TG_FILLORDER,266),+ (TG_DOCUMENTNAME,269),+ (TG_IMAGEDESCRIPTION,270),+ (TG_MAKE,271),+ (TG_MODEL,272),+ (TG_STRIPOFFSETS,273),+ (TG_ORIENTATION,274),+ (TG_SAMPLESPERPIXEL,277),+ (TG_ROWSPERSTRIP,278),+ (TG_STRIPBYTECOUNTS,279),+ (TG_MINSAMPLEVALUE,280),+ (TG_MAXSAMPLEVALUE,281),+ (TG_XRESOLUTION,282),+ (TG_YRESOLUTION,283),+ (TG_PLANARCONFIG,284),+ (TG_PAGENAME,285),+ (TG_XPOSITION,286),+ (TG_YPOSITION,287),+ (TG_FREEOFFSETS,288),+ (TG_FREEBYTECOUNTS,289),+ (TG_GRAYRESPONSEUNIT,290),+ (TG_GRAYRESPONSECURVE,291),+ (TG_GROUP3OPTIONS,292),+ (TG_GROUP4OPTIONS,293),+ (TG_RESOLUTIONUNIT,296),+ (TG_PAGENUMBER,297),+ (TG_COLORRESPONSEUNIT,300),+ (TG_COLORRESPONSECURVE,301),+ (TG_SOFTWARE,305),+ (TG_DATETIME,306),+ (TG_ARTIST,315),+ (TG_HOSTCOMPUTER,316),+ (TG_PREDICTOR,317),+ (TG_WHITEPOINT,318),+ (TG_PRIMARYCHROMATICITIES,319),+ (TG_COLORMAP,320),+ (TG_BADFAXLINES,326),+ (TG_CLEANFAXDATA,327),+ (TG_CONSECUTIVEBADFAXLINES,328),+ (TG_MATTEING,32995)+ ]++tag_map' = IM.fromList $ map (\(tag,v) -> (v,tag)) tag_map++tag_to_int :: TIFF_TAG -> Int+tag_to_int (TG_other x) = x+tag_to_int x = maybe (error $ "not found tag: " ++ show x) id $ lookup x tag_map++int_to_tag :: Int -> TIFF_TAG+int_to_tag x = maybe (TG_other x) id $ IM.lookup x tag_map'++++-- | The library function to read the TIFF dictionary+tiff_reader :: IterateeGM Word8 RBIO (Maybe TIFFDict)+tiff_reader = do+ read_magic+ check_version+ bindm endian_read4 $ \dict_offset -> do+ sseek (fromIntegral dict_offset)+ load_dict+ where+ -- Read the magic and set the endianness+ read_magic = do+ c1 <- snext+ c2 <- snext+ case (c1,c2) of+ (Just 0x4d, Just 0x4d) -> lift $ rb_msb_first_set True -- MM magic+ (Just 0x49, Just 0x49) -> lift $ rb_msb_first_set False -- II magic+ _ -> iter_err $ "Bad TIFF magic word: " ++ show [c1,c2]++ -- Check the version in the header. It is always ...+ tiff_version = 42+ check_version = do+ v <- endian_read2+ case v of+ Just v | v == tiff_version -> return ()+ _ -> iter_err $ "Bad TIFF version: " ++ show v++-- | A few conversion procedures+u32_to_float :: Word32 -> Double+u32_to_float x = -- unsigned 32-bit int -> IEEE float+ error "u32->float is not yet implemented"++u32_to_s32 :: Word32 -> Int32 -- unsigned 32-bit int -> signed 32 bit+u32_to_s32 = fromIntegral+-- u32_to_s32 0x7fffffff == 0x7fffffff+-- u32_to_s32 0xffffffff == -1++u16_to_s16 :: Word16 -> Int16 -- unsigned 16-bit int -> signed 16 bit+u16_to_s16 = fromIntegral+-- u16_to_s16 32767 == 32767+-- u16_to_s16 32768 == -32768+-- u16_to_s16 65535 == -1++u8_to_s8 :: Word8 -> Int8 -- unsigned 8-bit int -> signed 8 bit+u8_to_s8 = fromIntegral+-- u8_to_s8 127 == 127+-- u8_to_s8 128 == -128+-- u8_to_s8 255 == -1++note :: [String] -> IterateeGM el RBIO ()+note = lift . liftIO . putStrLn . concat++-- | An internal function to load the dictionary. It assumes that the stream+-- is positioned to read the dictionary+load_dict :: IterateeGM Word8 RBIO (Maybe TIFFDict)+load_dict = do+ bindm endian_read2 $ \nentries -> do+ dict <- foldr (const read_entry) (return (Just IM.empty)) [1..nentries]+ bindm endian_read4 $ \next_dict -> do+ if next_dict > 0 + then note ["The TIFF file contains several images, ",+ "only the first one will be considered"]+ else return ()+ return dict+ where+ read_entry dictM = do+ bindm dictM $ \dict ->+ bindm endian_read2 $ \tag -> + bindm endian_read2 $ \typ' -> + bindm (convert_type (fromIntegral typ')) $ \typ -> + bindm endian_read4 $ \count -> do+ -- we read the val-offset later. We need to check the size and the type+ -- of the datum, because val-offset may contain the value itself,+ -- in its lower-numbered bytes, regardless of the big/little endian+ -- order!++ note ["TIFFEntry: tag ",show . int_to_tag . fromIntegral $ tag, + " type ", show typ, " count ", show count]+ enum <- read_value typ (fromIntegral count)+ case enum of+ Just enum ->+ return . Just $ IM.insert (fromIntegral tag) + (TIFFDE (fromIntegral count) enum) dict+ _ -> return (Just dict)++ convert_type :: Monad m => Int -> IterateeGM el m (Maybe TIFF_TYPE)+ convert_type typ | typ > 0 && typ <= fromEnum (maxBound::TIFF_TYPE)+ = return . Just . toEnum $ typ+ convert_type typ = do+ iter_err $ "Bad type of entry: " ++ show typ+ return Nothing++ read_value :: TIFF_TYPE -> Int -> + IterateeGM Word8 RBIO (Maybe TIFFDE_ENUM)++ read_value typ 0 = do+ bindm endian_read4 $ \offset -> do+ iter_err $ "Zero count in the entry of type: " ++ show typ+ return Nothing++ -- Read an ascii string from the offset in the+ -- dictionary. The last byte of+ -- an ascii string is always zero, which is+ -- included in 'count' but we don't need to read it+ read_value TT_ascii count | count > 4 = do -- for sure, val-offset is offset+ bindm endian_read4 $ \offset ->+ return . Just . TEN_CHAR $ \iter_char -> do+ sseek (fromIntegral offset)+ let iter = conv_stream + (bindm snext (return. Just .(:[]). chr . fromIntegral))+ iter_char+ joinI $ joinI $ stakeR (pred count) ==<< iter++ -- Read the string of 0 to 3 characters long+ -- The zero terminator is included in count, but+ -- we don't need to read it+ read_value TT_ascii count = do -- count is within 1..4+ let len = pred count -- string length+ let loop acc 0 = return . Just . reverse $ acc+ loop acc n = bindm snext (\v -> loop ((chr . fromIntegral $ v):acc)+ (pred n))+ bindm (loop [] len) $ \str -> do+ sdrop (4-len)+ return . Just . TEN_CHAR $ immed_value str++ -- Read the array of signed or unsigned bytes+ read_value typ count | count > 4 && typ == TT_byte || typ == TT_sbyte = do + bindm endian_read4 $ \offset ->+ return . Just . TEN_INT $ \iter_int -> do+ sseek (fromIntegral offset)+ let iter = conv_stream + (bindm snext (return . Just . (:[]) . conv_byte typ))+ iter_int+ joinI $ joinI $ stakeR count ==<< iter++ -- Read the array of 1 to 4 bytes+ read_value typ count | typ == TT_byte || typ == TT_sbyte = do+ let loop acc 0 = return . Just . reverse $ acc+ loop acc n = bindm snext (\v -> loop ((conv_byte typ $ v):acc)+ (pred n))+ bindm (loop [] count) $ \str -> do+ sdrop (4-count)+ return . Just . TEN_INT $ immed_value str++ -- Read the array of Word8+ read_value TT_undefined count | count > 4 = do + bindm endian_read4 $ \offset ->+ return . Just . TEN_BYTE $ \iter -> do+ sseek (fromIntegral offset)+ joinI $ stakeR count iter++ -- Read the array of Word8 of 1..4 elements,+ -- packed in the offset field+ read_value TT_undefined count = do + let loop acc 0 = return . Just . reverse $ acc+ loop acc n = bindm snext (\v -> loop (v:acc) (pred n))+ bindm (loop [] count) $ \str -> do+ sdrop (4-count)+ return . Just . TEN_BYTE $ immed_value str++ -- Read the array of short integers++ -- of 1 element: the offset field contains the value+ read_value typ 1 | typ == TT_short || typ == TT_sshort = do + bindm endian_read2 $ \item -> do+ sdrop 2 -- skip the padding+ return . Just . TEN_INT $ immed_value [conv_short typ item]++ -- of 2 elements: the offset field contains the value+ read_value typ 2 | typ == TT_short || typ == TT_sshort = do + bindm endian_read2 $ \i1 -> + bindm endian_read2 $ \i2 -> do+ return . Just . TEN_INT $ + immed_value [conv_short typ i1, conv_short typ i2]++ -- of n elements+ read_value typ count | typ == TT_short || typ == TT_sshort = do + bindm endian_read4 $ \offset ->+ return . Just . TEN_INT $ \iter_int -> do+ sseek (fromIntegral offset)+ let iter = conv_stream + (bindm endian_read2 + (return . Just . (:[]) . conv_short typ))+ iter_int+ joinI $ joinI $ stakeR (2*count) ==<< iter+++ -- Read the array of long integers+ -- of 1 element: the offset field contains the value+ read_value typ 1 | typ == TT_long || typ == TT_slong = do + bindm endian_read4 $ \item ->+ return . Just . TEN_INT $ immed_value [conv_long typ item]++ -- of n elements+ read_value typ count | typ == TT_long || typ == TT_slong = do + bindm endian_read4 $ \offset ->+ return . Just . TEN_INT $ \iter_int -> do+ sseek (fromIntegral offset)+ let iter = conv_stream + (bindm endian_read4 + (return . Just . (:[]) . conv_long typ))+ iter_int+ joinI $ joinI $ stakeR (4*count) ==<< iter++ -- Read the array of rationals. A rational can't+ -- be packed into the offset field+ read_value typ count | typ == TT_rational || typ == TT_srational = do + bindm endian_read4 $ \offset ->+ return . Just . TEN_RAT $ \iter_rat -> do+ sseek (fromIntegral offset)+ let iter = conv_stream + (bindm endian_read4 $ \i1 ->+ bindm endian_read4 $ \i2 ->+ (return . Just . (:[]) $ conv_rat typ i1 i2))+ iter_rat+ joinI $ joinI $ stakeR (8*count) ==<< iter+++ read_value typ count = do -- stub+ bindm endian_read4 $ \offset -> do+ note ["unhandled type: ", show typ, " with count ", show count]+ return Nothing++ immed_value :: [el] -> EnumeratorGMM Word8 el RBIO a+ immed_value item iter =+ (enum_pure_1chunk item >. enum_eof) iter >>== joinI . return++ conv_byte :: TIFF_TYPE -> Word8 -> Integer+ conv_byte TT_byte = fromIntegral+ conv_byte TT_sbyte = fromIntegral . u8_to_s8++ conv_short :: TIFF_TYPE -> Word16 -> Integer+ conv_short TT_short = fromIntegral+ conv_short TT_sshort = fromIntegral . u16_to_s16++ conv_long :: TIFF_TYPE -> Word32 -> Integer+ conv_long TT_long = fromIntegral+ conv_long TT_slong = fromIntegral . u32_to_s32++ conv_rat :: TIFF_TYPE -> Word32 -> Word32 -> Rational+ conv_rat TT_rational v1 v2 = (fromIntegral v1) % (fromIntegral v2)+ conv_rat TT_srational v1 v2 = (fromIntegral (u32_to_s32 v1)) % + (fromIntegral (u32_to_s32 v2))++-- | Reading the pixel matrix+-- For simplicity, we assume no compression and 8-bit pixels+pixel_matrix_enum :: TIFFDict -> EnumeratorN Word8 Word8 RBIO a+pixel_matrix_enum dict iter = validate_dict >>= proceed+ where+ -- Make sure we can handle this particular TIFF image+ validate_dict = do+ dict_assert TG_COMPRESSION 1 `bindm` \() ->+ dict_assert TG_SAMPLESPERPIXEL 1 `bindm` \() ->+ dict_assert TG_BITSPERSAMPLE 8 `bindm` \() ->+ dict_read_int TG_IMAGEWIDTH dict `bindm` \ncols ->+ dict_read_int TG_IMAGELENGTH dict `bindm` \nrows ->+ dict_read_ints TG_STRIPOFFSETS dict `bindm` \strip_offsets -> do+ rps <- dict_read_int TG_ROWSPERSTRIP dict >>= return . maybe nrows id+ if ncols > 0 && nrows > 0 && rps > 0 + then return $ Just (ncols,nrows,rps,strip_offsets)+ else return Nothing+ + dict_assert tag v = do+ vfound <- dict_read_int tag dict+ case vfound of+ Just v' | v' == v -> return $ Just ()+ _ -> iter_err (unwords ["dict_assert: tag:", show tag,+ "expected:", show v, "found:", show vfound]) >>+ return Nothing++ proceed Nothing = enum_err "Can't handle this TIFF" iter >>== return++ proceed (Just (ncols,nrows,rows_per_strip,strip_offsets)) = do+ let strip_size = rows_per_strip * ncols+ image_size = nrows * ncols+ note ["Processing the pixel matrix, ", show image_size, " bytes"]+ let loop pos _ iter@IE_done{} = return iter+ loop pos [] iter = return iter+ loop pos (strip:strips) iter = do+ sseek (fromIntegral strip)+ let len = min strip_size (image_size - pos)+ iter <- stakeR (fromIntegral len) iter+ loop (pos+len) strips iter+ loop 0 strip_offsets iter+++-- | A few helpers for getting data from TIFF dictionary+--+dict_read_int :: TIFF_TAG -> TIFFDict -> IterateeGM Word8 RBIO (Maybe Integer)+dict_read_int tag dict = do+ els <- dict_read_ints tag dict+ case els of+ Just (e:_) -> return $ Just e+ _ -> return Nothing++dict_read_ints :: TIFF_TAG -> TIFFDict -> + IterateeGM Word8 RBIO (Maybe [Integer])+dict_read_ints tag dict = + case IM.lookup (tag_to_int tag) dict of+ Just (TIFFDE _ (TEN_INT enum)) -> do+ e <- enum ==<< stream2list+ return (Just e)+ _ -> return Nothing++dict_read_rat :: TIFF_TAG -> TIFFDict -> IterateeGM Word8 RBIO (Maybe Rational)+dict_read_rat tag dict = + case IM.lookup (tag_to_int tag) dict of+ Just (TIFFDE 1 (TEN_RAT enum)) -> do+ [e] <- enum ==<< stream2list+ return (Just e)+ _ -> return Nothing++dict_read_string :: TIFF_TAG -> TIFFDict -> IterateeGM Word8 RBIO (Maybe String)+dict_read_string tag dict = + case IM.lookup (tag_to_int tag) dict of+ Just (TIFFDE _ (TEN_CHAR enum)) -> do+ e <- enum ==<< stream2list+ return (Just e)+ _ -> return Nothing
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2008 Oleg Kiselyov+Copyright (c) 2008-2009 Oleg Kiselyov All rights reserved.
+ System/IterateeM.hs view
@@ -0,0 +1,713 @@+-- Haskell98!++-- | Monadic and General Iteratees:+-- incremental input parsers, processors and transformers+--+-- The running example, parts 1 and 2+-- Part 1 is reading the headers, the sequence of lines terminated by an+-- empty line. Each line is terminated by CR, LF, or CRLF.+-- We should return the headers in order. In the case of error,+-- we should return the headers read so far and the description of the error.+-- Part 2 is reading the headers and reading all the lines from the+-- HTTP-chunk-encoded content that follows the headers. Part 2 thus+-- verifies layering of streams, and processing of one stream+-- embedded (chunk encoded) into another stream.++module System.IterateeM where++import System.Posix+import Foreign.C+import Foreign.Ptr+import Foreign.Marshal.Alloc+import Data.List (splitAt)+import Data.Char (isHexDigit, digitToInt, isSpace)+import Control.Monad.Trans+import Control.Monad.Identity++import System.LowLevelIO++-- | A stream is a (continuing) sequence of elements bundled in Chunks.+-- The first two variants indicate termination of the stream.+-- Chunk [a] gives the currently available part of the stream.+-- The stream is not terminated yet.+-- The case (Chunk []) signifies a stream with no currently available+-- data but which is still continuing. A stream processor should,+-- informally speaking, ``suspend itself'' and wait for more data+-- to arrive.+-- Later on, we can add another variant: IE_block (Ptr CChar) CSize+-- so we could parse right from the buffer.+data StreamG a = EOF | Err String | Chunk [a] deriving Show++-- | A particular instance of StreamG: the stream of characters.+-- This stream is used by many input parsers.+type Stream = StreamG Char+++-- | Iteratee -- a generic stream processor, what is being folded over+-- a stream+-- When Iteratee is in the 'done' state, it contains the computed+-- result and the remaining part of the stream.+-- In the 'cont' state, the iteratee has not finished the computation+-- and needs more input.+-- We assume that all iteratees are `good' -- given bounded input,+-- they do the bounded amount of computation and take the bounded amount+-- of resources. The monad m describes the sort of computations done+-- by the iteratee as it processes the stream. The monad m could be+-- the identity monad (for pure computations) or the IO monad+-- (to let the iteratee store the stream processing results as they+-- are computed).+-- We also assume that given a terminated stream, an iteratee+-- moves to the done state, so the results computed so far could be returned.+--+-- We could have used existentials instead, by doing the closure conversion++--+data IterateeG el m a = IE_done a (StreamG el)+ | IE_cont (StreamG el -> IterateeGM el m a)+newtype IterateeGM el m a = IM{unIM:: m (IterateeG el m a)}++type Iteratee m a = IterateeG Char m a+type IterateeM m a = IterateeGM Char m a+++-- | Useful combinators for implementing iteratees and enumerators+--+liftI :: Monad m => IterateeG el m a -> IterateeGM el m a+liftI = IM . return++-- | Just like bind (at run-time, this is indeed exactly bind)+infixl 1 >>==+(>>==):: Monad m =>+ IterateeGM el m a ->+ (IterateeG el m a -> IterateeGM el' m b) ->+ IterateeGM el' m b+m >>== f = IM (unIM m >>= unIM . f)++-- | Just like an application -- a call-by-value-like application+infixr 1 ==<<+f ==<< m = m >>== f++-- | The following is a `variant' of join in the IterateeGM el m monad.+-- When el' is the same as el, the type of joinI is indeed that of+-- true monadic join. However, joinI is subtly different: since+-- generally el' is different from el, it makes no sense to+-- continue using the internal, IterateeG el' m a: we no longer+-- have elements of the type el' to feed to that iteratee.+-- We thus send EOF to the internal Iteratee and propagate its result.+-- This join function is useful when dealing with `derived iteratees'+-- for embedded/nested streams. In particular, joinI is useful to+-- process the result of stake, map_stream, or conv_stream below.+joinI :: Monad m => IterateeGM el m (IterateeG el' m a) -> IterateeGM el m a+joinI m = m >>= (\iter -> enum_eof iter >>== check)+ where+ check (IE_done x (Err str)) = liftI $ (IE_done x (Err str))+ check (IE_done x _) = liftI $ (IE_done x EOF)+ check (IE_cont _) = error "joinI: can't happen: EOF didn't terminate"++-- | It turns out, IterateeGM form a monad. We can use the familiar do+-- notation for composing Iteratees+--+instance Monad m => Monad (IterateeGM el m) where+ return x = liftI $ IE_done x (Chunk [])+ m >>= f = m >>== docase+ where+ docase (IE_done a (Chunk [])) = f a+ docase (IE_done a stream) = f a >>== (\r -> case r of+ IE_done x _ -> liftI $ IE_done x stream+ IE_cont k -> k stream)+ docase (IE_cont k) = liftI $ IE_cont ((>>= f) . k)++instance MonadTrans (IterateeGM el) where+ lift m = IM (m >>= unIM . return)+++-- ------------------------------------------------------------------------+-- Primitive iteratees++-- | Read a stream to the end and return all of its elements as a list+stream2list :: Monad m => IterateeGM el m [el]+stream2list = liftI $ IE_cont (step [])+ where+ step acc (Chunk []) = liftI $ IE_cont (step acc)+ step acc (Chunk ls) = liftI $ IE_cont (step $ acc ++ ls)+ step acc stream = liftI $ IE_done acc stream++-- | Check to see if the stream is in error+iter_report_err :: Monad m => IterateeGM el m (Maybe String)+iter_report_err = liftI $ IE_cont step+ where step s@(Err str) = liftI $ IE_done (Just str) s+ step s = liftI $ IE_done Nothing s++-- ------------------------------------------------------------------------+-- Parser combinators++-- | The analogue of List.break+-- It takes an element predicate and returns a pair:+-- (str, Just c) -- the element 'c' is the first element of the stream+-- satisfying the break predicate;+-- The list str is the prefix of the stream up+-- to but including 'c'+-- (str,Nothing) -- The stream is terminated with EOF or error before+-- any element satisfying the break predicate was found.+-- str is the scanned part of the stream.+-- None of the element in str satisfy the break predicate.+--+sbreak :: Monad m => (el -> Bool) -> IterateeGM el m ([el],Maybe el)+sbreak cpred = liftI $ IE_cont (liftI . step [])+ where+ step before (Chunk []) = IE_cont (liftI . step before)+ step before (Chunk str) =+ case break cpred str of+ (_,[]) -> IE_cont (liftI . step (before ++ str))+ (str,c:tail) -> done (before ++ str) (Just c) (Chunk tail)+ step before stream = done before Nothing stream+ done line char stream = IE_done (line,char) stream+++-- | A particular optimized case of the above: skip all elements of the stream+-- satisfying the given predicate -- until the first element+-- that does not satisfy the predicate, or the end of the stream.+-- This is the analogue of List.dropWhile+sdropWhile :: Monad m => (el -> Bool) -> IterateeGM el m ()+sdropWhile cpred = liftI $ IE_cont step+ where+ step (Chunk []) = sdropWhile cpred+ step (Chunk str) =+ case dropWhile cpred str of+ [] -> sdropWhile cpred+ str -> liftI $ IE_done () (Chunk str)+ step stream = liftI $ IE_done () stream++++-- | Attempt to read the next element of the stream+-- Return (Just c) if successful, return Nothing if the stream is+-- terminated (by EOF or an error)+snext :: Monad m => IterateeGM el m (Maybe el)+snext = liftI $ IE_cont step+ where+ step (Chunk []) = snext+ step (Chunk (c:t)) = liftI $ IE_done (Just c) (Chunk t)+ step stream = liftI $ IE_done Nothing stream++-- | Look ahead at the next element of the stream, without removing+-- it from the stream.+-- Return (Just c) if successful, return Nothing if the stream is+-- terminated (by EOF or an error)+speek :: Monad m => IterateeGM el m (Maybe el)+speek = liftI $ IE_cont step+ where+ step (Chunk []) = speek+ step s@(Chunk (c:_)) = liftI $ IE_done (Just c) s+ step stream = liftI $ IE_done Nothing stream+++-- | Skip the rest of the stream+skip_till_eof :: Monad m => IterateeGM el m ()+skip_till_eof = liftI $ IE_cont step+ where+ step (Chunk _) = skip_till_eof+ step _ = return ()++-- | Skip n elements of the stream, if there are that many+-- This is the analogue of List.drop+sdrop :: Monad m => Int -> IterateeGM el m ()+sdrop 0 = return ()+sdrop n = liftI $ IE_cont step+ where+ step (Chunk str) | length str <= n = sdrop (n - length str)+ step (Chunk str) = liftI $ IE_done () (Chunk s2)+ where (s1,s2) = splitAt n str+ step stream = liftI $ IE_done () stream++-- ------------------------------------------------------------------------+-- | Iteratee converters for stream embedding+-- The converters show a different way of composing two iteratees:+-- `vertical' rather than `horizontal'+--+-- The type of the converter from the stream with elements el_outer+-- to the stream with element el_inner. The result is the iteratee+-- for the outer stream that uses an `IterateeG el_inner m a'+-- to process the embedded, inner stream as it reads the outer stream.+type EnumeratorN el_outer el_inner m a = + IterateeG el_inner m a -> IterateeGM el_outer m (IterateeG el_inner m a)++-- | Read n elements from a stream and apply the given iteratee to the+-- stream of the read elements. Unless the stream is terminated early, we+-- read exactly n elements (even if the iteratee has accepted fewer).+stake :: Monad m => Int -> EnumeratorN el el m a+stake 0 iter = return iter+stake n iter@IE_done{} = sdrop n >> return iter+stake n (IE_cont k) = liftI $ IE_cont step+ where+ step (Chunk []) = liftI $ IE_cont step+ step chunk@(Chunk str) | length str <= n =+ stake (n - length str) ==<< k chunk+ step (Chunk str) = done (Chunk s1) (Chunk s2)+ where (s1,s2) = splitAt n str+ step stream = done stream stream+ done s1 s2 = k s1 >>== \r -> liftI $ IE_done r s2++-- | Map the stream: yet another iteratee transformer+-- Given the stream of elements of the type el and the function el->el',+-- build a nested stream of elements of the type el' and apply the+-- given iteratee to it.+-- Note the contravariance+--+map_stream :: Monad m => (el -> el') -> EnumeratorN el el' m a+map_stream f iter@IE_done{} = return iter+map_stream f (IE_cont k) = liftI $ IE_cont step+ where+ step (Chunk []) = liftI $ IE_cont step+ step (Chunk str) = k (Chunk (map f str)) >>== map_stream f+ step EOF = k EOF >>== \r -> liftI $ IE_done r EOF+ step (Err err) = k (Err err) >>== \r -> liftI $ IE_done r (Err err)+++-- | Convert one stream into another, not necessarily in `lockstep'+-- The transformer map_stream maps one element of the outer stream+-- to one element of the nested stream. The transformer below is more+-- general: it may take several elements of the outer stream to produce+-- one element of the inner stream, or the other way around.+-- The transformation from one stream to the other is specified as+-- IterateeGM el m (Maybe [el']). The `Maybe' type reflects the+-- possibility of the conversion error.+--+conv_stream :: Monad m =>+ IterateeGM el m (Maybe [el']) -> EnumeratorN el el' m a+conv_stream fi iter@IE_done{} = return iter+conv_stream fi (IE_cont k) = + fi >>= (conv_stream fi ==<<) . k . maybe (Err "conv: stream error") Chunk++-- ------------------------------------------------------------------------+-- | Combining the primitive iteratees to solve the running problem:+-- Reading headers and the content from an HTTP-like stream+--+type Line = String -- The line of text, terminators are not included++-- | Read the line of text from the stream+-- The line can be terminated by CR, LF or CRLF.+-- Return (Right Line) if successful. Return (Left Line) if EOF or+-- a stream error were encountered before the terminator is seen.+-- The returned line is the string read so far.+--+-- The code is the same as that of pure Iteratee, only the signature+-- has changed.+-- Compare the code below with GHCBufferIO.line_lazy+--+line :: Monad m => IterateeM m (Either Line Line)+line = sbreak (\c -> c == '\r' || c == '\n') >>= check_next+ where+ check_next (line,Just '\r') = speek >>= \c ->+ case c of+ Just '\n' -> snext >> return (Right line)+ Just _ -> return (Right line)+ Nothing -> return (Left line)+ check_next (line,Just _) = return (Right line)+ check_next (line,Nothing) = return (Left line)+++++-- | Line iteratees: processors of a stream whose elements are made of Lines+--+-- Collect all read lines and return them as a list+-- see stream2list+--+-- Print lines as they are received. This is the first `impure' iteratee+-- with non-trivial actions during chunk processing+print_lines :: IterateeGM Line IO ()+print_lines = liftI $ IE_cont step+ where+ step (Chunk []) = print_lines+ step (Chunk ls) = lift (mapM_ pr_line ls) >> print_lines+ step EOF = lift (putStrLn ">> natural end") >> liftI (IE_done () EOF)+ step stream = lift (putStrLn ">> unnatural end") >>+ liftI (IE_done () stream)+ pr_line line = putStrLn $ ">> read line: " ++ line+++-- | Convert the stream of characters to the stream of lines, and+-- apply the given iteratee to enumerate the latter.+-- The stream of lines is normally terminated by the empty line.+-- When the stream of characters is terminated, the stream of lines+-- is also terminated, abnormally.+-- This is the first proper iteratee-enumerator: it is the iteratee of the+-- character stream and the enumerator of the line stream.+-- More generally, we could have used conv_stream to implement enum_lines.+--+enum_lines :: Monad m => EnumeratorN Char Line m a+enum_lines iter@IE_done{} = return iter+enum_lines (IE_cont k) = line >>= check_line k+ where+ check_line k (Right "") = enum_lines ==<< k EOF -- empty line, normal term+ check_line k (Right l) = enum_lines ==<< k (Chunk [l])+ check_line k _ = enum_lines ==<< k (Err "EOF") -- abnormal termin+++-- | Convert the stream of characters to the stream of words, and+-- apply the given iteratee to enumerate the latter.+-- Words are delimited by white space.+-- This is the analogue of List.words+-- It is instructive to compare the code below with the code of+-- List.words, which is:+--+-- >words :: String -> [String]+-- >words s = case dropWhile isSpace s of+-- > "" -> []+-- > s' -> w : words s''+-- > where (w, s'') =+-- > break isSpace s'+--+-- One should keep in mind that enum_words is a more general, monadic+-- function.+-- More generally, we could have used conv_stream to implement enum_words.+--+enum_words :: Monad m => EnumeratorN Char String m a+enum_words iter@IE_done{} = return iter+enum_words (IE_cont k) = sdropWhile isSpace >> sbreak isSpace >>= check_word k+ where+ check_word k ("",_) = enum_words ==<< k EOF+ check_word k (str,_) = enum_words ==<< k (Chunk [str])+++-- ------------------------------------------------------------------------+-- | Enumerators+-- Each enumerator takes an iteratee and returns an iteratee+-- an Enumerator is an iteratee transformer.+-- The enumerator normally stops when the stream is terminated+-- or when the iteratee moves to the done state, whichever comes first.+-- When to stop is of course up to the enumerator...+--+-- We have two choices of composition: compose iteratees or compose+-- enumerators. The latter is useful when one iteratee+-- reads from the concatenation of two data sources.+--+type EnumeratorGM el m a = IterateeG el m a -> IterateeGM el m a+type EnumeratorM m a = EnumeratorGM Char m a++-- | The most primitive enumerator: applies the iteratee to the terminated+-- stream. The result is the iteratee usually in the done state.+enum_eof :: Monad m => EnumeratorGM el m a+enum_eof iter@(IE_done _ (Err _)) = liftI iter+enum_eof (IE_done x _) = liftI $ IE_done x EOF+enum_eof (IE_cont k) = k EOF++-- | Another primitive enumerator: report an error+enum_err :: Monad m => String -> EnumeratorGM el m a+enum_err str iter@(IE_done _ (Err _)) = liftI iter+enum_err str (IE_done x _) = liftI $ IE_done x (Err str)+enum_err str (IE_cont k) = k (Err str)++-- | The composition of two enumerators: essentially the functional composition+-- It is convenient to flip the order of the arguments of the composition+-- though: in e1 >. e2, e1 is executed first+--+(>.):: Monad m =>+ EnumeratorGM el m a -> EnumeratorGM el m a -> EnumeratorGM el m a+e1 >. e2 = (e2 ==<<) . e1++-- | The pure 1-chunk enumerator+-- It passes a given list of elements to the iteratee in one chunk+-- This enumerator does no IO and is useful for testing of base parsing+enum_pure_1chunk :: Monad m => [el] -> EnumeratorGM el m a+enum_pure_1chunk str iter@IE_done{} = liftI $ iter+enum_pure_1chunk str (IE_cont k) = k (Chunk str)++-- | The pure n-chunk enumerator+-- It passes a given lift of elements to the iteratee in n chunks+-- This enumerator does no IO and is useful for testing of base parsing+-- and handling of chunk boundaries+enum_pure_nchunk :: Monad m => [el] -> Int -> EnumeratorGM el m a+enum_pure_nchunk str n iter@IE_done{} = liftI $ iter+enum_pure_nchunk [] n iter = liftI $ iter+enum_pure_nchunk str n (IE_cont k) = enum_pure_nchunk s2 n ==<< k (Chunk s1)+ where (s1,s2) = splitAt n str+++-- | The enumerator of a POSIX Fd+-- Unlike fdRead (which allocates a new buffer on+-- each invocation), we use the same buffer all throughout+enum_fd :: Fd -> EnumeratorM IO a+enum_fd fd iter = IM $ allocaBytes (fromIntegral buffer_size) (loop iter)+ where+-- buffer_size = 4096+ buffer_size = 5 -- for tests; in real life, there should be 1024 or so+ loop iter@IE_done{} p = return iter+ loop iter@(IE_cont step) p = do+ n <- myfdRead fd p buffer_size+ putStrLn $ "Read buffer, size " ++ either (const "IO err") show n+ case n of+ Left errno -> unIM $ step (Err "IO error")+ Right 0 -> return iter+ Right n -> do+ str <- peekCAStringLen (p,fromIntegral n)+ im <- unIM $ step (Chunk str)+ loop im p++enum_file :: FilePath -> EnumeratorM IO a+enum_file filepath iter = IM $ do+ putStrLn $ "opened file " ++ filepath+ fd <- openFd filepath ReadOnly Nothing defaultFileFlags+ r <- unIM $ enum_fd fd iter+ closeFd fd+ putStrLn $ "closed file " ++ filepath+ return r++-- | HTTP chunk decoding+-- Each chunk has the following format:+--+-- > <chunk-size> CRLF <chunk-data> CRLF+--+-- where <chunk-size> is the hexadecimal number; <chunk-data> is a+-- sequence of <chunk-size> bytes.+-- The last chunk (so-called EOF chunk) has the format+-- 0 CRLF CRLF (where 0 is an ASCII zero, a character with the decimal code 48).+-- For more detail, see "Chunked Transfer Coding", Sec 3.6.1 of+-- the HTTP/1.1 standard:+-- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.6.1>+--+-- The following enum_chunk_decoded has the signature of the enumerator+-- of the nested (encapsulated and chunk-encoded) stream. It receives+-- an iteratee for the embedded stream and returns the iteratee for+-- the base, embedding stream. Thus what is an enumerator and what+-- is an iteratee may be a matter of perspective.+--+-- We have a decision to make: Suppose an iteratee has finished (either because+-- it obtained all needed data or encountered an error that makes further+-- processing meaningless). While skipping the rest of the stream/the trailer,+-- we encountered a framing error (e.g., missing CRLF after chunk data).+-- What do we do? We chose to disregard the latter problem.+-- Rationale: when the iteratee has finished, we are in the process+-- of skipping up to the EOF (draining the source).+-- Disregarding the errors seems OK then.+-- Also, the iteratee may have found an error and decided to abort further+-- processing. Flushing the remainder of the input is reasonable then.+-- One can make a different choice...+--+enum_chunk_decoded :: Monad m => Iteratee m a -> IterateeM m a+enum_chunk_decoded = docase+ where+ docase iter@IE_done{} =+ liftI iter >>= (\r -> (enum_chunk_decoded ==<< skip_till_eof) >> return r)+ docase iter@(IE_cont k) = line >>= check_size+ where+ check_size (Right "0") = line >> k EOF+ check_size (Right str) =+ maybe (k . Err $ "Bad chunk size: " ++ str) (read_chunk iter)+ $ read_hex 0 str+ check_size _ = k (Err "Error reading chunk size")++ read_chunk iter size =+ do+ r <- stake size iter+ c1 <- snext+ c2 <- snext+ case (c1,c2) of+ (Just '\r',Just '\n') -> docase r+ _ -> (enum_chunk_decoded ==<< skip_till_eof) >>+ enum_err "Bad chunk trailer" r++ read_hex acc "" = Just acc+ read_hex acc (d:rest) | isHexDigit d = read_hex (16*acc + digitToInt d) rest+ read_hex acc _ = Nothing+++-- ------------------------------------------------------------------------+-- Tests+++-- Pure tests, requiring no IO++test_str1 =+ "header1: v1\rheader2: v2\r\nheader3: v3\nheader4: v4\n" +++ "header5: v5\r\nheader6: v6\r\nheader7: v7\r\n\nrest\n"++testp1 =+ let IE_done (IE_done lines EOF) (Chunk rest)+ = runIdentity . unIM $ enum_pure_1chunk test_str1 ==<<+ (enum_lines ==<< stream2list)+ in+ lines == ["header1: v1","header2: v2","header3: v3","header4: v4",+ "header5: v5","header6: v6","header7: v7"]+ && rest == "rest\n"++testp2 =+ let IE_done (IE_done lines EOF) (Chunk rest)+ = runIdentity . unIM $ enum_pure_nchunk test_str1 5 ==<<+ (enum_lines ==<< stream2list)+ in+ lines == ["header1: v1","header2: v2","header3: v3","header4: v4",+ "header5: v5","header6: v6","header7: v7"]+ && rest == "r"+++testw1 =+ let test_str = "header1: v1\rheader2: v2\r\nheader3:\t v3"+ expected = ["header1:","v1","header2:","v2","header3:","v3"] in+ let run_test test_str =+ let IE_done (IE_done words EOF) EOF+ = runIdentity . unIM $ (enum_pure_nchunk test_str 5 >. enum_eof)+ ==<< (enum_words ==<< stream2list)+ in words+ in+ and [run_test test_str == expected,+ run_test (test_str ++ " ") == expected]+++-- Test Fd driver++test_driver line_collector filepath = do+ fd <- openFd filepath ReadOnly Nothing defaultFileFlags+ putStrLn "About to read headers"+ result <- unIM $ (enum_fd fd >. enum_eof) ==<< read_lines_and_one_more_line+ closeFd fd+ putStrLn "Finished reading headers"+ case result of+ IE_done (IE_done headers EOF,after) _ ->+ do+ putStrLn $ "The line after headers is: " ++ show after+ putStrLn "Complete headers"+ print headers+ IE_done (IE_done headers err,_) stream ->+ do+ putStrLn $ "Problem " ++ show stream+ putStrLn "Incomplete headers"+ print headers+ where+ read_lines_and_one_more_line = do+ lines <- enum_lines ==<< line_collector+ after <- line+ return (lines,after)+++test11 = test_driver stream2list "test1.txt"+test12 = test_driver stream2list "test2.txt"+test13 = test_driver stream2list "test3.txt"+test14 = test_driver stream2list "/dev/null"++test21 = test_driver print_lines "test1.txt"+test22 = test_driver print_lines "test2.txt"+test23 = test_driver print_lines "test3.txt"+test24 = test_driver print_lines "/dev/null"+++-- Run the complete test, reading the headers and the body++-- | This simple iteratee is used to process a variety of streams:+-- embedded, interleaved, etc.+line_printer = enum_lines ==<< print_lines++-- |Two sample processors+--+-- Read the headers, print the headers, read the lines of the chunk-encoded+-- body and print each line as it has been read+read_headers_print_body = do+ headers <- enum_lines ==<< stream2list+ case headers of+ IE_done headers EOF -> lift $ do+ putStrLn "Complete headers"+ print headers+ IE_done headers (Err err) -> lift $ do+ putStrLn $ "Incomplete headers due to " ++ err+ print headers++ lift $ putStrLn "\nLines of the body follow"+ enum_chunk_decoded ==<< line_printer++-- | Read the headers and print the header right after it has been read+-- Read the lines of the chunk-encoded body and print each line as+-- it has been read+print_headers_print_body = do+ lift $ putStrLn "\nLines of the headers follow"+ line_printer+ lift $ putStrLn "\nLines of the body follow"+ enum_chunk_decoded ==<< line_printer+++test_driver_full iter filepath = do+ fd <- openFd filepath ReadOnly Nothing defaultFileFlags+ putStrLn "About to read headers"+ unIM $ (enum_fd fd >. enum_eof) ==<< iter+ closeFd fd+ putStrLn "Finished reading"++test31 = test_driver_full read_headers_print_body "test_full1.txt"+test32 = test_driver_full read_headers_print_body "test_full2.txt"+test33 = test_driver_full read_headers_print_body "test_full3.txt"++test34 = test_driver_full print_headers_print_body "test_full3.txt"+++-- | Interleaved reading from two descriptors using select+--+-- If the two arguments are the names of regular files, the driver+-- does simple round-robin interleaving, reading a block from one+-- file and a block from the other file. If the arguments name+-- pipes or devices, the reading becomes truly supply-driven.+-- We use select for multiplexing.+-- The first argument is the reader-iteratee. It is exactly+-- the same iteratee that is being used in the `sequential' tests above.+-- By design, two Fds are being read independently and in parallel,+-- closely emulating two OS processes each reading from their own file.+-- The code below is a simple, round-robin OS scheduler.+test_driver_mux iter fpath1 fpath2 = do+ fd1 <- openFd fpath1 ReadOnly Nothing defaultFileFlags+ fd2 <- openFd fpath2 ReadOnly Nothing defaultFileFlags+ let fds = [fd1,fd2]+ putStrLn $ "Opened file descriptors: " ++ show fds+ mapM (\(fd,reader) -> unIM reader >>= return . ((,) fd))+ (zip fds (repeat iter)) >>=+ allocaBytes (fromIntegral buffer_size) . loop+ mapM_ closeFd fds+ putStrLn $ "Closed file descriptors. All done"+ where+ -- we use one single IO buffer for reading+ buffer_size = 5 -- for tests; in real life, there should be 1024 or so+ loop fjque buf = do+ let fds = get_fds fjque+ if null fds then return ()+ else do+ selected <- select'read'pending fds+ case selected of+ Left errno -> putStrLn "IO Err" >>+ tell_iteratee_err "IO Err" fjque >>+ return ()+ Right [] -> loop fjque buf+ Right sel -> process buf sel fjque++ -- get Fds from the jobqueue for the unfinished iteratees+ get_fds = foldr (\ (fd,iter) acc ->+ case iter of {IE_cont _ -> fd:acc; _ -> acc}) []++ -- find the first ready jobqueue element,+ -- that is, the job queue element whose Fd is in selected.+ -- Return the element and the rest of the queue+ get_ready selected jq = (e, before ++ after)+ where (before,e:after) = break (\(fd,_) -> fd `elem` selected) jq++ process buf selected fjque = do+ let ((fd,IE_cont step),fjrest) = get_ready selected fjque+ n <- myfdRead fd buf buffer_size+ putStrLn $ unwords ["Read buffer, size", either (const "IO err") show n,+ "from fd", show fd]+ case n of+ Left errno -> unIM (step (Err "IO error")) >>+ loop fjrest buf+ Right 0 -> unIM (step EOF) >>+ loop fjrest buf+ Right n -> do+ str <- peekCAStringLen (buf,fromIntegral n)+ im <- unIM $ step (Chunk str)+ loop (fjrest ++ [(fd,im)]) buf -- round-robin++ tell_iteratee_err err = mapM_ (\ (_,iter) -> unIM (enum_err err iter))+++-- Running these tests shows true interleaving, of reading from the+-- two file descriptors and of printing the results. All IO is interleaved,+-- and yet it is safe. No unsafe operations are used.+testm1 = test_driver_mux line_printer "test1.txt" "test3.txt"++testm2 = test_driver_mux print_headers_print_body+ "test_full2.txt" "test_full3.txt"
+ System/LowLevelIO.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE ForeignFunctionInterface #-}++-- | Low-level IO operations +-- These operations are either missing from the GHC run-time library,+-- or implemented suboptimally or heavy-handedly+--+module System.LowLevelIO (myfdRead, myfdSeek, Errno(..), select'read'pending)+ where++import Foreign.C+import Foreign.Ptr+import System.Posix+import System.IO (SeekMode(..))+import Data.Bits -- for select+import Foreign.Marshal.Array -- for select++-- | Alas, GHC provides no function to read from Fd to an allocated buffer.+-- The library function fdRead is not appropriate as it returns a string+-- already. I'd rather get data from a buffer.+-- Furthermore, fdRead (at least in GHC) allocates a new buffer each+-- time it is called. This is a waste. Yet another problem with fdRead+-- is in raising an exception on any IOError or even EOF. I'd rather+-- avoid exceptions altogether.+--+myfdRead :: Fd -> Ptr CChar -> ByteCount -> IO (Either Errno ByteCount)+myfdRead (Fd fd) ptr n = do+ n' <- cRead fd ptr n+ if n' == -1 then getErrno >>= return . Left + else return . Right . fromIntegral $ n'+++foreign import ccall unsafe "unistd.h read" cRead+ :: CInt -> Ptr CChar -> CSize -> IO CInt++foreign import ccall unsafe "string.h" strerror :: Errno -> IO (Ptr CChar)+++-- | The following fseek procedure throws no exceptions.+myfdSeek:: Fd -> SeekMode -> FileOffset -> IO (Either Errno FileOffset)+myfdSeek (Fd fd) mode off = do+ n' <- cLSeek fd off (mode2Int mode)+ if n' == -1 then getErrno >>= return . Left + else return . Right $ n'+ where mode2Int :: SeekMode -> CInt -- From GHC source+ mode2Int AbsoluteSeek = (0)+ mode2Int RelativeSeek = (1)+ mode2Int SeekFromEnd = (2)++foreign import ccall unsafe "unistd.h lseek" cLSeek+ :: CInt -> FileOffset -> CInt -> IO FileOffset+++-- | Darn! GHC doesn't provide the real select over several descriptors! +-- We have to implement it ourselves+--+type FDSET = CUInt+type TIMEVAL = CLong -- Two longs+foreign import ccall "unistd.h select" c_select+ :: CInt -> Ptr FDSET -> Ptr FDSET -> Ptr FDSET -> Ptr TIMEVAL -> IO CInt++-- | Convert a file descriptor to an FDSet (for use with select)+-- essentially encode a file descriptor in a big-endian notation+fd2fds :: CInt -> [FDSET]+fd2fds fd = (replicate nb 0) ++ [setBit 0 off]+ where+ (nb,off) = quotRem (fromIntegral fd) (bitSize (undefined::FDSET))++fds2mfd :: [FDSET] -> [CInt]+fds2mfd fds = [fromIntegral (j+i*bitsize) | + (afds,i) <- zip fds [0..], j <- [0..bitsize],+ testBit afds j]+ where bitsize = bitSize (undefined::FDSET)++test_fd_conv = and $ map (\e -> [e] == (fds2mfd $ fd2fds e)) lst+ where+ lst = [0,1,5,7,8,9,16,17,63,64,65]++test_fd_conv' = mfd == fds2mfd fds+ where+ mfd = [0,1,5,7,8,9,16,17,63,64,65]+ fds :: [FDSET]+ fds = foldr ormax [] (map fd2fds mfd)+ fdmax = maximum $ map fromIntegral mfd+ ormax [] x = x+ ormax x [] = x+ ormax (a:ar) (b:br) = (a .|. b) : ormax ar br+++unFd :: Fd -> CInt+unFd (Fd x) = x++-- | poll if file descriptors have something to read+-- Return the list of read-pending descriptors+select'read'pending :: [Fd] -> IO (Either Errno [Fd])+select'read'pending mfd =+ withArray ([0,1]::[TIMEVAL]) ( -- holdover...+ \timeout ->+ withArray fds (+ \readfs ->+ do+ rc <- c_select (fdmax+1) readfs nullPtr nullPtr nullPtr+ if rc == -1 then getErrno >>= return . Left + -- because the wait was indefinite, rc must be positive!+ else peekArray (length fds) readfs >>=+ return . Right . map Fd . fds2mfd))+ where+ fds :: [FDSET]+ fds = foldr ormax [] (map (fd2fds . unFd) mfd)+ fdmax = maximum $ map fromIntegral mfd+ ormax [] x = x+ ormax x [] = x+ ormax (a:ar) (b:br) = (a .|. b) : ormax ar br++foreign import ccall "fcntl.h fcntl" fcntl+ :: CInt -> CInt -> CInt -> IO CInt+++-- | use it as cleanup'fd [5..6] to clean up the sockets left hanging...+cleanup'fd = mapM_ (closeFd . Fd) ++
+ System/RandomIO.hs view
@@ -0,0 +1,349 @@+-- Haskell98!++-- | Random and Binary IO with IterateeM+--+-- <http://okmij.org/ftp/Streams.html#random-bin-IO>+--+--+-- Random and binary IO: Reading TIFF+--+-- Iteratees presuppose sequential processing. A general-purpose input method+-- must also support random IO: processing a seek-able input stream from an+-- arbitrary position, jumping back and forth through the stream. We demonstrate+-- random IO with iteratees, as well as reading non-textual files and converting+-- raw bytes into multi-byte quantities such as integers, rationals, and TIFF+-- dictionaries. Positioning of the input stream is evocative of delimited+-- continuations.+--+-- We use random and binary IO to write a general-purpose TIFF library. The+-- library emphasizes incremental processing, relying on iteratees and enumerators+-- for on-demand reading of tag values. The library extensively uses nested+-- streams, tacitly converting the stream of raw bytes from the file into streams+-- of integers, rationals and other user-friendly items. The pixel matrix is+-- presented as a contiguous stream, regardless of its segmentation into strips+-- and physical arrangement.+--+-- We show a representative application of the library: reading a sample TIFF+-- file, printing selected values from the TIFF dictionary, verifying the values+-- of selected pixels and computing the histogram of pixel values. The pixel+-- verification procedure stops reading the pixel matrix as soon as all specified+-- pixel values are verified. The histogram accumulation does read the entire+-- matrix, but incrementally. Neither pixel matrix processing procedure loads the+-- whole matrix in memory. In fact, we never read and retain more than the+-- IO-buffer-full of raw data.+--+-- Version: The current version is 1.1, December 2008.+--+module System.RandomIO where+++import System.Posix+import Foreign.C+import Foreign.Ptr+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import Control.Monad.Trans+import Data.Word+import Data.Bits+import Data.IORef+import Text.Printf++import System.IO (SeekMode(..))++import System.IterateeM+import System.LowLevelIO+++-- | The type of the IO monad supporting seek requests and endianness+-- The seek_request is not-quite a state, more like a `communication channel'+-- set by the iteratee and answered by the enumerator. Since the+-- base monad is IO, it seems simpler to implement both endianness+-- and seek requests as IORef cells. Their names are grouped in a structure+-- RBState, which is propagated as the `environment.'+newtype RBIO a = RBIO{unRBIO:: RBState -> IO a}++instance Monad RBIO where+ return = RBIO . const . return+ m >>= f = RBIO( \env -> unRBIO m env >>= (\x -> unRBIO (f x) env) )++instance MonadIO RBIO where+ liftIO = RBIO . const++-- | Generally, RBState is opaque and should not be exported.+data RBState = RBState{msb_first :: IORef Bool,+ seek_req :: IORef (Maybe FileOffset) }++-- | The programmer should use the following functions instead+--+rb_empty = do+ mref <- newIORef True+ sref <- newIORef Nothing+ return RBState{msb_first = mref, seek_req = sref}++-- | To request seeking, the iteratee sets seek_req to (Just desired_offset)+-- When the enumerator answers the request, it sets seek_req back+-- to Nothing+--+rb_seek_set :: FileOffset -> RBIO ()+rb_seek_set off = RBIO action+ where action env = writeIORef (seek_req env) (Just off)++rb_seek_answered :: RBIO Bool+rb_seek_answered = RBIO action+ where action env = readIORef (seek_req env) >>= + return . maybe True (const False)++rb_msb_first :: RBIO Bool+rb_msb_first = RBIO action+ where action env = readIORef (msb_first env)++rb_msb_first_set :: Bool -> RBIO ()+rb_msb_first_set flag = RBIO action+ where action env = writeIORef (msb_first env) flag++runRB:: RBState -> IterateeGM el RBIO a -> IO (IterateeG el RBIO a)+runRB rbs m = unRBIO (unIM m) rbs++-- ------------------------------------------------------------------------+-- Binary Random IO Iteratees++-- | A useful combinator.+-- Perhaps a better idea would have been to define+-- Iteratee to have (Maybe a) in IE_done? In that case, we could+-- make IterateeGM to be the instance of MonadPlus+bindm :: Monad m => m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b)+bindm m f = m >>= maybe (return Nothing) f+++-- | We discard all available input first.+-- We keep discarding the stream s until we determine that our request +-- has been answered:+-- rb_seek_set sets the state seek_req to (Just off). When the+-- request is answered, the state goes back to Nothing.+-- The above features remind one of delimited continuations.+sseek :: FileOffset -> IterateeGM el RBIO ()+sseek off = lift (rb_seek_set off) >> liftI (IE_cont step)+ where+ step s@(Err _) = liftI $ IE_done () s+ step s = do+ r <- lift rb_seek_answered+ if r then liftI $ IE_done () s+ else liftI $ IE_cont step+++-- | An iteratee that reports and propagates an error+-- We disregard the input first and then propagate error.+-- It is reminiscent of `abort'+iter_err :: Monad m => String -> IterateeGM el m ()+iter_err err = liftI $ IE_cont step+ where+ step _ = liftI $ IE_done () (Err err)+++-- | Read n elements from a stream and apply the given iteratee to the+-- stream of the read elements. If the given iteratee accepted fewer+-- elements, we stop.+-- This is the variation of `stake' with the early termination+-- of processing of the outer stream once the processing of the inner stream+-- finished early. This variation is particularly useful for randomIO,+-- where we do not have to care to `drain the input stream'.+stakeR :: Monad m => Int -> EnumeratorN el el m a+stakeR 0 iter = return iter+stakeR n iter@IE_done{} = return iter+stakeR n (IE_cont k) = liftI $ IE_cont step+ where+ step (Chunk []) = liftI $ IE_cont step+ step chunk@(Chunk str) | length str <= n =+ stakeR (n - length str) ==<< k chunk+ step (Chunk str) = done (Chunk s1) (Chunk s2)+ where (s1,s2) = splitAt n str+ step stream = done stream stream+ done s1 s2 = k s1 >>== \r -> liftI $ IE_done r s2+++-- | Iteratees to read unsigned integers written in Big- or Little-endian ways+--+endian_read2 :: IterateeGM Word8 RBIO (Maybe Word16)+endian_read2 =+ bindm snext $ \c1 ->+ bindm snext $ \c2 -> do+ flag <- lift rb_msb_first+ if flag then+ return $ return $ (fromIntegral c1 `shiftL` 8) .|. fromIntegral c2+ else+ return $ return $ (fromIntegral c2 `shiftL` 8) .|. fromIntegral c1++endian_read4 :: IterateeGM Word8 RBIO (Maybe Word32)+endian_read4 =+ bindm snext $ \c1 ->+ bindm snext $ \c2 ->+ bindm snext $ \c3 ->+ bindm snext $ \c4 -> do+ flag <- lift rb_msb_first+ if flag then+ return $ return $ + (((((fromIntegral c1+ `shiftL` 8) .|. fromIntegral c2)+ `shiftL` 8) .|. fromIntegral c3)+ `shiftL` 8) .|. fromIntegral c4+ else+ return $ return $ + (((((fromIntegral c4+ `shiftL` 8) .|. fromIntegral c3)+ `shiftL` 8) .|. fromIntegral c2)+ `shiftL` 8) .|. fromIntegral c1+++-- ------------------------------------------------------------------------+-- Binary Random IO enumerators++-- | The enumerator of a POSIX Fd: a variation of enum_fd that+-- supports RandomIO (seek requests)+enum_fd_random :: Fd -> EnumeratorGM Word8 RBIO a+enum_fd_random fd iter = + IM . RBIO $ (\env -> + allocaBytes (fromIntegral buffer_size) (loop env (0,0) iter))+ where+-- buffer_size = 4096+ buffer_size = 5 -- for tests; in real life, there should be 1024 or so+ -- the second argument of loop is (off,len), describing which part+ -- of the file is currently in the buffer 'p'+ loop :: RBState -> (FileOffset,Int) -> IterateeG Word8 RBIO a -> + Ptr Word8 -> IO (IterateeG Word8 RBIO a)+ loop env pos iter@IE_done{} p = return iter+ loop env pos iter p = readIORef (seek_req env) >>= loop' env pos iter p++ loop' env pos@(off,len) iter p (Just off') | + off <= off' && off' < off + fromIntegral len = -- Seek within buffer p+ do+ writeIORef (seek_req env) Nothing+ let local_off = fromIntegral $ off' - off+ str <- peekArray (len - local_off) (p `plusPtr` local_off)+ im <- runRB env $ enum_pure_1chunk str iter+ loop env pos im p+ loop' env pos iter p (Just off) = do -- Seek outside the buffer+ writeIORef (seek_req env) Nothing+ off <- myfdSeek fd AbsoluteSeek (fromIntegral off)+ putStrLn $ "Read buffer, offset " ++ either (const "IO err") show off+ case off of+ Left errno -> runRB env $ enum_err "IO error" iter+ Right off -> loop' env (off,0) iter p Nothing+ -- Thanks to John Lato for the strictness annotation+ -- Otherwise, the `off + fromIntegral len' below accumulates thunks+ loop' env (off,len) iter p Nothing | off `seq` len `seq` False = undefined+ loop' env (off,len) iter@(IE_cont step) p Nothing = do+ n <- myfdRead fd (castPtr p) buffer_size+ putStrLn $ "Read buffer, size " ++ either (const "IO err") show n+ case n of+ Left errno -> runRB env $ step (Err "IO error")+ Right 0 -> return iter+ Right n -> do+ str <- peekArray (fromIntegral n) p+ im <- runRB env $ step (Chunk str)+ loop env (off + fromIntegral len,fromIntegral n) im p+++-- ------------------------------------------------------------------------+-- Tests++test1 () = do+ Just s1 <- snext+ Just s2 <- snext+ sseek 0+ Just s3 <- snext+ sseek 100+ Just s4 <- snext+ Just s5 <- snext+ sseek 101+ Just s6 <- snext+ sseek 1+ Just s7 <- snext+ return [s1,s2,s3,s4,s5,s6,s7]++test2 () = do+ sseek 100+ sseek 0+ sseek 100+ Just s4 <- snext+ Just s5 <- snext+ sseek 101+ Just s6 <- snext+ sseek 1+ Just s7 <- snext+ sseek 0+ Just s1 <- snext+ Just s2 <- snext+ sseek 0+ Just s3 <- snext+ return [s1,s2,s3,s4,s5,s6,s7]++test3 () = do+ let show_x fmt = map (\x -> (printf fmt x)::String)+ lift $ rb_msb_first_set True+ Just ns1 <- endian_read2+ Just ns2 <- endian_read2+ Just ns3 <- endian_read2+ Just ns4 <- endian_read2+ sseek 0+ Just nl1 <- endian_read4+ Just nl2 <- endian_read4+ sseek 4+ lift $ rb_msb_first_set False+ Just ns3' <- endian_read2+ Just ns4' <- endian_read2+ sseek 0+ Just ns1' <- endian_read2+ Just ns2' <- endian_read2+ sseek 0+ Just nl1' <- endian_read4+ Just nl2' <- endian_read4+ return [show_x "%04x" [ns1,ns2,ns3,ns4],+ show_x "%08x" [nl1,nl2],+ show_x "%04x" [ns1',ns2',ns3',ns4'],+ show_x "%08x" [nl1',nl2']]+ +test4 () = do+ lift $ rb_msb_first_set True+ Just ns1 <- endian_read2+ Just ns2 <- endian_read2+ iter_err "Error"+ ns3 <- endian_read2+ return (ns1,ns2,ns3)++test_driver_random iter filepath = do+ fd <- openFd filepath ReadOnly Nothing defaultFileFlags+ rb <- rb_empty+ putStrLn "About to read file"+ result <- runRB rb $ (enum_fd_random fd >. enum_eof) ==<< iter+ closeFd fd+ putStrLn "Finished reading file"+ print_res result+ where+ print_res (IE_done a EOF) = print a >> return a+ print_res (IE_done a (Err err)) = print a >>+ putStrLn ("Stream error: " ++ err) >>+ return a++test1r = test_driver_random (test1 ()) "test_full1.txt" >>=+ return . (== [104,101,104,13,10,10,101])++test2r = test_driver_random (test2 ()) "test_full1.txt" >>=+ return . (== [104,101,104,13,10,10,101])++test3r = test_driver_random (test3 ()) "test4.txt" >>=+ return . (==+ [["0001","0203","fffe","fdfc"],+ ["00010203","fffefdfc"],+ ["0100","0302","feff","fcfd"],+ ["03020100","fcfdfeff"]])++test4r = test_driver_random (test4 ()) "test4.txt" >>=+ return . (== (1,515,Nothing))++{-+About to read file+Read buffer, size 5+Finished reading file+(1,515,Nothing)+Stream error: Error+-}
+ System/SysOpen.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- <http://okmij.org/ftp/Haskell/misc.html#sys_open>+--+-- Haskell interface to sys_open.c:+-- providing openFd and closeFd that can deal with `extended'+-- file names (which can name TCP and bi-directional pipes in addition+-- to the regular disk files)+-- <http://okmij.org/ftp/syscall-interpose.html#Application>+--+-- Also included a useful utility read_line to read a NL-terminated+-- line from an Fd. It deliberately uses no handles and so never+-- messes with Fd (in particular, it doesn't put the file descriptor in the +-- non-blocking mode)+--+-- Simple and reliable uni- and bi-directional pipes+-- +-- MySysOpen module offers a reliable, proven way of interacting with another+-- local or remote process via a unidirectional or bidirectional channel. It+-- supports pipes and Unix and TCP sockets. MySysOpen is a simple and explicit+-- alternative to the multi-threaded IO processing of the GHC run-time system. The+-- module is the Haskell binding to sys_open -- the extended, user-level file+-- opening interface.+-- +-- The second half of MySysOpen.hs contains several bi-directional channel+-- interaction tests. One checks repeated sending and receiving of data; the+-- amount of received data is intentionally large, about 510K. Two other tests+-- interact with programs that are not specifically written for interactive use,+-- such as sort. The latter cannot produce any output before it has read all of+-- the input, accepting no input terminator other than the EOF condition. One test+-- uses shutdown to set the EOF condition. The other test programs the handler for+-- a custom EOF indicator, literally in the file name of the communication pipe.+-- +module System.SysOpen (mysysOpenFd, mysysCloseFd, mysysCloseOut, read_line) where++import Data.List (elemIndex)++import Foreign+import Foreign.C+import System.Posix++-- For testing+import System.IO (putStrLn, hPutStrLn, hClose, openTempFile)+++-- | Interface with my sys_open, see sys_open.c for detailed+-- description and comments+--+foreign import ccall unsafe "sys_open.h sys_open" c_mysysOpen+ :: CString -> CInt -> CInt -> IO CInt++foreign import ccall unsafe "sys_open.h sys_close" c_mysysClose+ :: CInt -> IO CInt++foreign import ccall unsafe "sys/socket.h shutdown" c_shutdown+ :: CInt -> CInt -> IO CInt++-- from "/usr/include/fcntl.h"+--+open_mode_RDONLY :: CInt = 0x0000+open_mode_WRONLY :: CInt = 0x0001+open_mode_RDWR :: CInt = 0x0002++-- from "/usr/include/sys/socket.h"+flag_SHUT_RD = 0 -- shut down the reading side+flag_SHUT_WR = 1 -- shut down the writing side+flag_SHUT_RDWR = 2 -- shut down both sides+++mysysOpenFd:: FilePath -> OpenMode -> Maybe FileMode -> IO Fd+mysysOpenFd path open_mode fmode = + throwErrnoIfMinus1 "sys_open" + (withCString path $+ \s -> c_mysysOpen s (open_mode_cnv open_mode)+ (maybe 0666 fromIntegral fmode))+ >>= return.Fd++ where+ open_mode_cnv ReadOnly = open_mode_RDONLY+ open_mode_cnv WriteOnly = open_mode_WRONLY+ open_mode_cnv ReadWrite = open_mode_RDWR++mysysCloseFd :: Fd -> IO ()+mysysCloseFd fd = c_mysysClose (fromIntegral fd) >> return ()++-- | Close the output direction of the bi-directional pipe+mysysCloseOut :: Fd -> IO ()+mysysCloseOut fd = do+ throwErrnoIfMinus1Retry_ "shutdown" (c_shutdown (fromIntegral fd) flag_SHUT_WR)++-- | Read up to and including newline, return the line and the remaining+-- data. It should be invoked as:+--+-- > read_line "" fd.+--+-- In the case of EOF, the returned line will NOT be terminated with newline+read_line acc fd =+ case elemIndex '\n' acc of+ Nothing -> do (str,n) <- fdRead fd 4000+ if n == 0 -- EOF+ then return (acc,"")+ else read_line (acc++str) fd+ Just i -> return $ splitAt (succ i) acc -- keep \n in the first part+++-- ----------------------------------------------------------------------+-- Tests++-- To run tests, compile this code as+-- ghc -O2 -main-is System.MySysOpen.test_main MySysOpen.hs sys_open.c++-- The first two tests check communication with `third-party' programs+-- such as a SAT solver via a bi-directional pipe.+-- In the tests below, we use the system program `sort'.+-- Generally, a program must be specifically written for interactive use +-- over a bi-directional pipe: The program should avoid read-ahead, +-- produce output as soon as it obtained all necessary input data, +-- and be especially careful with buffering.+-- Most systems programs (including sort) are not written with these +-- goals in mind. These programs cannot be used with inetd,+-- or with bidirectional pipes. The program sort is quite bad in this +-- respect: it cannot produce any output before it has read all of the input. +-- It has no input terminator other than the EOF condition. Alas, to send+-- EOF, we have to close the communication channel. How can we receive+-- the reply from sort then?++-- Fortunately, there are work-arounds.+-- The first one is the shutdown(2) system call, to close only+-- the sending direction of the bi-directional pipe.+-- The second work-around is an intermediary to interpret a custom EOF +-- indicator. We program this intermediary in the `file name'+-- of the communication channel.+-- Other tricks are described in+-- http://okmij.org/ftp/Communications.html#sh-agents++test_main = do+ test_sort1+ test_sort2+ test_proxy >>= print+++-- Illustrating the first trick: shutdown to close one direction+-- of the bi-directional pipe.++test_sort1 = do+ putStrLn "Interacting with sort using shutdown" + fd <- mysysOpenFd "| sort" ReadWrite Nothing+ putStrLn "Opened the bi-directional pipe to sort"+ fdWrite fd "zzz\nfoo\nbar\n"+ putStrLn "Shutting down the sending direction"+ mysysCloseOut fd+ putStrLn "Reading the reply from sort\n"+ con@(_,rest) <- read_line "" fd+ print con+ con@(_,rest) <- read_line rest fd+ print con+ con@(_,rest) <- read_line rest fd+ print con+ putStrLn "\nDone"++-- Illustrating the second trick: programming the handler for+-- a custom EOF indicator in the file name++test_sort2 = do+ putStrLn "Interacting with sort using the custom EOF indicator" + fd <- mysysOpenFd + "| (while read i && test $i != '***EOF***'; do echo $i; done) | sort" + ReadWrite Nothing+ putStrLn "Opened the bi-directional pipe to sort"+ fdWrite fd "zzz\nfoo\nbar\n***EOF***\n"+ putStrLn "Sent the custom EOF indicator"+ putStrLn "Reading the reply from sort\n"+ con@(_,rest) <- read_line "" fd+ print con+ con@(_,rest) <- read_line rest fd+ print con+ con@(_,rest) <- read_line rest fd+ print con+ putStrLn "\nDone"++-- Check sys_open and the interaction with a `dumb proxy'.+-- We want this test to be representative of SimpleProxy.hs: we send data to+-- another process, read _large_ amount of data in response;+-- send some data again, read large amount again.+-- The proxy below is dumb: it reads an NL-terminated string and+-- writes it out N times, where N is the large number.+-- Then it writes the string "EOF\n".++dummy_proxy ="\+\import System.IO\n\+\main = do{l<-getLine; mapM_ (const (putStrLn l)) [1..10000]; putStrLn \"EOF\"; main}"++test_proxy = do+ (fp,h) <- openTempFile "/tmp" "dproxy.hs"+ hPutStrLn h dummy_proxy+ hClose h+ putStrLn "Starting the dummy proxy"+ pfd <- mysysOpenFd ("| runghc " ++ fp) ReadWrite Nothing+ let test_string = "123xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxZ\n"+ fdWrite pfd test_string+ n <- read_back 0 "" pfd test_string+ -- do it again+ putStrLn "Doing it again"+ let test_string = "55123\n"+ fdWrite pfd test_string+ n <- read_back 0 "" pfd test_string+ mysysCloseFd pfd+ putStrLn "Finished"+ return n+ where+ read_back count acc pfd test_str = do+ (str,rest) <- read_line acc pfd+ -- putStrLn $ "read: `" ++ str ++ "'"+ if str == "EOF\n" then return count+ else if str == test_str then read_back (succ count) rest pfd test_str+ else error "bad read"+
+ cbits/sys_open.c view
@@ -0,0 +1,552 @@+/*+ ************************************************************************+ *+ * The lowest but one level file opener+ *+ * This code implements an "extended" system call open(2), which+ * opens a file for reading or writing. A function sys_open() defined+ * in this code takes the same arguments as open(2) and returns the+ * same result (that is, a file handle of an opened file, or -1 in+ * case of error). See "man 2 open" for more details.+ *+ * int sys_open(const char * filename, const int mode, const int mask)+ *+ * If a filename argument given to sys_open() is a regular file/path+ * name, sys_open() is *identical* to open() (it simply exits+ * to open(), as a matter of fact). Unlike open() however, sys_open() can+ * handle extended file names like "cmd |" or "| cmd", where "cmd" is+ * anything that can be passed to /bin/sh. In that case, shell "/bin/sh"+ * is launched in a subprocess to interpret the "cmd"; the shell's stdin+ * or stdout become the file that is being "opened" by sys_open().+ *+ * An extended file name "cmd |" assumes that cmd's standard output becomes+ * a "file" (a pipe, actually) the caller of sys_open() will read from.+ * That is, "cmd |" assumes a RDONLY open mode. By the same token,+ * a "| cmd" extended file name usually means that the caller of sys_open()+ * would then write into the file; all the data being written will be+ * passed to the stdin of the given "cmd". Still, _regardless_ of how+ * the extended file name is specified, "| cmd" or "cmd |", sys_open() always+ * obeys the opening mode as given by the 'mode' argument. But when+ * a file "cmd |" is open for writing, or "| cmd" is opened for reading,+ * sys_open() writes a gripe about it on the stderr.+ * + * Version 4 of this code permits an extended file name to be opened for + * both reading _and_ writing, with an O_RDWR open mode. In this case,+ * a *bidirectional* pipe is created -- a pair of sockets. One end of that+ * pipe is returned to the caller as a "handle" to the opened file. The+ * other end is assigned to _both_ stdin and stdout of a forked process+ * (which runs a shell to execute a command).+ * + * In extended file names, leading spaces (before the '|' character)+ * and trainling spaces (after the '|' char) are allowed and ignored.+ *+ * This code is patterned after sys_open.cc in the earlier version+ * (v. 2.1) of c++advio distribution. The original inspiration for+ * _popen is due to+ * Copyright (C) 1991, 1992 Per Bothner. (bothner@cygnus.com)+ *+ * Version 3.0 adds another format of extended file names:+ * tcp://hostname:port+ * In this case, sys_open tries to establish a connection to the given+ * host at the given port. If successful, it returns the connected socket+ * (handle). In case of a format, name resolution, network, connection+ * refused etc errors the return result is -1, with errno set appropriately.+ *+ * Version 5.2 adds another format (proposed and implemented by+ * Bernhard Mogens Ege) of extended file names:+ * ltcp://hostname:port+ * In this case, sys_open opens a listening socket bound to+ * hostname:port and blocks until it accepts one connection to that+ * socket. If successful, it returns the connected socket (handle). In+ * case of a format, name resolution, network, connection refused etc+ * errors the return result is -1, with errno set appropriately.+ * Normally one would write sys_open("ltcp://0:5000",O_RDWR) to accept+ * the first connection to the port 5000 from any host. To limit the+ * host that is allowed to initiate the connection (e.g., to the+ * localhost) one would write sys_open("ltcp://127.0.0.1:5000",O_RDWR)+ * This implementation is intentionally meant to be simple: only the+ * first incoming connection is accepted. If one wishes to do+ * something more advanced, he can easily do sys_open("nc -l -p port+ * |",O_RDWR), i.e., use a more advanced network program as a filter.+ *+ * Zombie control+ * When we launch a sub-process in response to opening file names such+ * as "cmd |" and "| cmd", we store the child process id and the+ * corresponding file descriptor in a special static table. The table+ * has a fixed size. If the table is full, we return error EMFILE. On+ * each new open-pipe operation, we scan the table to check if any of+ * the sub-processes terminated. If some have, we clear the+ * corresponding entry. We are not interested in the return code of+ * the sub-process. However, retrieving it (via a call to waitpid)+ * gets rid of a zombie subprocess. This way, we keep the number of+ * zombies under control. We also define a new operation sys_close,+ * which checks the table of subprocesses. If it determines that the+ * file descriptor to close was associated with a pipe, sys_close+ * closes the descriptor and waits until the corresponding process+ * terminates. Otherwise, sys_close is equivalent to the ordinary+ * close(2).+ *+ * $Id: sys_open.c,v 5.3 2007/01/24 22:22:15 oleg Exp oleg $+ *+ ************************************************************************+ */ ++#include <unistd.h>+#include <fcntl.h>+#include <sys/file.h>+#include <errno.h>+#include <assert.h>+#include <stdio.h>+#include <string.h>+#include <stdlib.h>+#include <limits.h>+#include <sys/wait.h>+#define report_error(MSG,ARG) fprintf(stderr,MSG,(ARG))+#define _XOPEN_SOURCE_EXTENDED+#if 0 /*defined(linux) I guess they fixed it */+typedef unsigned long in_addr_t;+#elif defined(__FreeBSD__)+#include <netinet/in.h>+/*typedef struct in_addr in_addr_t; Fixed in FreeBSD 4.6+ */+#endif+#include <netinet/tcp.h>+#include <sys/socket.h>+#include <arpa/inet.h>+#include <netdb.h>+ /* Convertion between the host and the network byte orders */+#if !defined(htons) && !defined(__htons) && !defined(linux) && !defined(__FreeBSD__)+unsigned short htons(unsigned int data); /* For a short data item */+unsigned short ntohs(unsigned int data); /* For a short data item */+unsigned long htonl(unsigned long data); /* For a long data item */+#endif+#if !defined(INADDR_NONE)+#define INADDR_NONE (unsigned long)(-1)+#endif++/*+ *------------------------------------------------------------------------+ *+ * Open a connection to a specified host at a specified port, and+ * return the connected socket if successful.+ * A conn_dest parameter must be a string "hostname:port". If it is+ * not in this format, the errno is set to ENXIO.+ */+static const char TCP_EXTENDED_FNAME_PREFIX [] = "tcp://";+static const char TCP_LISTEN_EXTENDED_FNAME_PREFIX [] = "ltcp://";++static struct sockaddr_in parse_dest(const char * conn_dest)+{+ struct sockaddr_in sock_addr;+ char hostname [PATH_MAX+1];+ const char * const colonp = strchr(conn_dest,':');+ sock_addr.sin_family = 0; /* means invalid, for now */+ + if( colonp == 0 )+ return report_error("Colon is missing in the destination address '%s'\n",+ conn_dest),+ errno = ENXIO, sock_addr;++ if( (unsigned)(colonp-conn_dest) >= sizeof(hostname) -1 )+ return errno=ENAMETOOLONG, sock_addr;+ strncpy(hostname,conn_dest,colonp-conn_dest);+ hostname[colonp-conn_dest] = '\0';+ + { /* Try to parse the port number, after the colon */+ char * endp = (char *)colonp+1;+ const int port_no = strtol(colonp+1,&endp,10);+ if( endp == colonp+1 || *endp != '\0' )+ return report_error("Invalid port specification in the "+ "destination address '%s'\n",conn_dest),+ errno = ENXIO, sock_addr;+ sock_addr.sin_port = htons((short)port_no);+ }+ + /* First check to see if hostname is an IP address in+ the dot notation */+ if( (sock_addr.sin_addr.s_addr = inet_addr(hostname)) != INADDR_NONE )+ return sock_addr.sin_family = AF_INET, sock_addr;+ + { /* Otherwise, try to resolve the hostname */+ struct hostent *host_ptr = gethostbyname(hostname);+ if( host_ptr == 0 )+ return report_error("Hostname '%s' could not be resolved\n",hostname),+ errno = ENXIO, sock_addr;+ if( host_ptr->h_addrtype != AF_INET )+ return report_error("Hostname '%s' isn't an Internet site, or so the DNS says\n",hostname),+ errno = ENXIO, sock_addr;+ memcpy(&sock_addr.sin_addr,host_ptr->h_addr,+ sizeof(sock_addr.sin_addr.s_addr));+ }+ sock_addr.sin_family = AF_INET; /* This makes sock_addr valid */+ return sock_addr;+}++static int close_save_errno(const int handle)+{+ const int errno_saved = errno;+ close(handle);+ errno = errno_saved;+ return -1;+}++static int open_connect(const char * conn_dest, int mode)+{+ struct sockaddr_in sock_addr = parse_dest(conn_dest);+ int socket_handle;+ + if( sock_addr.sin_family == 0 )+ return -1; /* Failed to parse the connection target addr*/++ if( (socket_handle=socket(AF_INET,SOCK_STREAM,0)) < 0 )+ return socket_handle;++ if( connect(socket_handle, (const struct sockaddr *)&sock_addr,+ sizeof(sock_addr)) < 0 )+ return close_save_errno(socket_handle); /* Connection failed */+++ /* As the user will probably do his own buffering+ (via fdopen(), fstream, whatever) + we tell the TCP stack to refrain from buffering+ See man tcp(7P) for more details on TCP_NODELAY+ */+ {+ int opt_value = 1;+ if( setsockopt(socket_handle, IPPROTO_TCP, TCP_NODELAY,+ (char*)&opt_value, sizeof(opt_value)) < 0 )+ return close_save_errno(socket_handle);+ }+ return socket_handle;+}+++static int open_listen(const char * conn_dest, int mode)+{+ struct sockaddr_in sock_addr = parse_dest(conn_dest);+ int socket_handle,slaveSocket_handle;+ struct sockaddr_in clientName;+ socklen_t clientLength = sizeof(clientName);+ + if( sock_addr.sin_family == 0 )+ return -1; /* Failed to parse the connection target addr*/++ if( (socket_handle=socket(AF_INET,SOCK_STREAM,0)) < 0 )+ return socket_handle;++ {+ int value = 1;+ if( setsockopt(socket_handle, SOL_SOCKET, SO_REUSEADDR,+ (char*)&value, sizeof(value)) < 0 )+ return close_save_errno(socket_handle);+ }++ if( bind(socket_handle, + (struct sockaddr *)&sock_addr,sizeof(sock_addr)) < 0 )+ return close_save_errno(socket_handle);++ if( listen(socket_handle, 1) < 0 )+ return close_save_errno(socket_handle);++ (void) memset(&clientName, 0, sizeof(clientName));+ + /* this will block */+ slaveSocket_handle = accept(socket_handle,+ (struct sockaddr *) &clientName, + &clientLength);++ /* no need for the original listening socket as only one connection+ can be handled per filehandle anyway.+ */+ close(socket_handle);++ if (slaveSocket_handle < 0) /* if accept() failed. */+ return slaveSocket_handle;+ + /* As the user will probably do his own buffering+ (via fdopen(), fstream, whatever) + we tell the TCP stack to refrain from buffering+ See man tcp(7P) for more details on TCP_NODELAY+ */+ {+ int opt_value = 1;+ if( setsockopt(slaveSocket_handle, IPPROTO_TCP, TCP_NODELAY,+ (char*)&opt_value, sizeof(opt_value)) < 0 )+ return close_save_errno(slaveSocket_handle);+ }+ return slaveSocket_handle;+}+++/*+ *------------------------------------------------------------------------+ *+ * Launch a shell in a subprocess and have it interpret a string,+ * from cmd_beg up to (but not including) cmd_end. Shell's stdin or+ * stdout is directed to a pipe (depending on the 'mode' argument,+ * which can be either O_RDONLY or O_WRONLY). The other end of this+ * pipe is returned as the result of this function. In case of error,+ * the result is -1.+ * Note, fork() copies parent's address space. So it appears we may+ * modify cmd_beg and cmd_end (see below) at will without affecting+ * the parent. There is a hitch though: sys_open() might be called+ * with a constant string, like sys_open("cat < /tmp/a |"). In which+ * case the string is allocated in a BSS or even TEXT segment, which+ * is read-only. It remains read-only in the child process, so we+ * may not actually modify it.+ */++ /* The table to keep track of pipe sub-processes */+static struct popen_desc {+ pid_t pid; /* PID for the process on the other end */+ int fh; /* The corresponding file descriptor */+} popen_desc_table [5];++static const struct popen_desc * const popen_desc_table_end =+popen_desc_table + sizeof(popen_desc_table)/sizeof(popen_desc_table[0]);++/* Scan the popen_desc_table and check if any of the subprocesses+ terminated. If so, clear (zero out) the corresponding entry.+ */+static void clean_popens(void)+{+ struct popen_desc * pp = (struct popen_desc *)0;+ for(pp=popen_desc_table; pp < popen_desc_table_end; pp++)+ {+ int status;+ if( pp->pid == 0 )+ continue;+ if( waitpid(pp->pid,&status,WNOHANG) != pp->pid )+ continue; /* pp->pid still runs or waitpid error */+ memset(pp,0,sizeof(pp[0]));+ }+}++/* Try to close fh. Return 0 if successful, 1 if no such fh among+ popen_desc, -1 if there was some error.*/+static int try_close_popen(const int fh)+{+ struct popen_desc * pp = (struct popen_desc *)0;+ for(pp=popen_desc_table; pp < popen_desc_table_end; pp++)+ {+ int status;+ int rc = 0;+ if( pp->fh != fh )+ continue;+ close(fh);+ rc = waitpid(pp->pid,&status,0) < 0 ? -1 : 0;+ if( rc != 0 && errno == ECHILD )+ rc = 0; /* Ignore the case child being reaped */+ memset(pp,0,sizeof(pp[0]));+ return rc;+ }+ return 1; /* Didn't find fh among popen_desc_table */+}++static int _popen(const char * cmd_beg, const char * cmd_end, int mode)+{+ struct { int read_fd, write_fd; } pipe_fds;++ int parent_end, child_end; /* ends of the pipe */+ int child_std_end; /* File handles for stdin/out */+ pid_t kid_id;+ struct popen_desc * pp;++ clean_popens();+ for(pp=popen_desc_table; ; pp++) /* Find empty slot in popen_desc_table*/+ {+ if( pp >= popen_desc_table_end )+ return (errno=EMFILE), -1;+ if( pp->pid == 0 )+ break;+ }+ + assert( cmd_end > cmd_beg );+ if( pipe((int *)&pipe_fds) < 0 )+ return -1;++ if( mode == O_RDONLY ) /* We're reading, shell is writing */+ parent_end = pipe_fds.read_fd, child_end = pipe_fds.write_fd,+ child_std_end = 1; /* command's stdout handle */+ else /* shell is reading, we're writing */+ parent_end = pipe_fds.write_fd, child_end = pipe_fds.read_fd,+ child_std_end = 0; /* command's stdin handle */++ if( (kid_id = fork()) == 0 )+ { /* We're in kid's process */+ /* which is to execute the command */+ char * cmd_string = malloc(cmd_end - cmd_beg + 1);+ strncpy(cmd_string,cmd_beg,cmd_end - cmd_beg);+ cmd_string[cmd_end - cmd_beg] = '\0';++ close(parent_end); + if( child_end != child_std_end )+ {+ dup2(child_end, child_std_end);+ close(child_end);+ }+ execl("/bin/sh", "sh", "-c", cmd_string, (char *)0);+ _exit(127); /* Executed only if execl failed! */+ }++ close(child_end); /* We're in the parent process */+ if( kid_id < 0 )+ close(parent_end), parent_end = -1; /* if fork failed */+ else+ pp->pid = kid_id, pp->fh = parent_end;++ return parent_end;+}++/*+ *------------------------------------------------------------------------+ *+ * Launch a shell in a subprocess and have it interpret a string,+ * from cmd_beg up to (but not including) cmd_end. Both shell's stdin _and_+ * stdout are directed to a bidirectional "pipe", which is implemented+ * as a socketpair. One end of the socketpair serves as both stdin and+ * stdout for the kid process; the other end of that pair is returned+ * as the result of this function. In case of error, the result is -1.+ * This function is called when a user has attempted to open a pipe+ * and specified an opening mode of O_RDWR.+ */++static int bidirectional_popen(const char * cmd_beg, const char * cmd_end)+{+ int pair_of_sockets[2]; /* the first element is for the parent,+ the other is for the kid */+ int kid_id;+ struct popen_desc * pp;++ clean_popens();+ for(pp=popen_desc_table; ; pp++) /* Find empty slot in popen_desc_table*/+ {+ if( pp >= popen_desc_table_end )+ return (errno=EMFILE), -1;+ if( pp->pid == 0 )+ break;+ }+ + assert( cmd_end > cmd_beg );+ if( socketpair(AF_UNIX, SOCK_STREAM, 0, pair_of_sockets) < 0 )+ return -1;++ if( (kid_id = fork()) == 0 )+ { /* We're in kid's process */+ /* which is to execute the command */+ char * cmd_string = malloc(cmd_end - cmd_beg + 1);+ strncpy(cmd_string,cmd_beg,cmd_end - cmd_beg);+ cmd_string[cmd_end - cmd_beg] = '\0';++ close(pair_of_sockets[0]); /* close the parent's end */+ dup2(pair_of_sockets[1],0); /* re-direct both stdin and stdout */+ dup2(pair_of_sockets[1],1);+ close(pair_of_sockets[1]); /* it has been duplicated */+ execl("/bin/sh", "sh", "-c", cmd_string, (char *)0);+ _exit(127); /* Executed only if execl failed! */+ }++ close(pair_of_sockets[1]); /* We're in the parent process */+ if( kid_id < 0 )+ return close_save_errno(pair_of_sockets[0]); /* if fork failed */+ else+ pp->pid = kid_id, pp->fh = pair_of_sockets[0];++ return pair_of_sockets[0];+}++/*+ *------------------------------------------------------------------------+ * An extended 'open(2)'+ */+ /* if str begins with a pipe char '|' (after possibly several spaces)+ * return a pointer to the character right after that.+ * Otherwise, return NULL+ */+static const char * check_leading_barchar(const char * str)+{+ register const char * p = str;+ while( *p == ' ' )+ p++;+ return *p == '|' ? p+1 : (char *)0;+}++ /* if str ends with a pipe char '|' (followed by possibly several+ * spaces) return a pointer to it.+ * Otherwise, return NULL+ */+static const char * check_trailing_barchar(const char * str)+{+ register const char * p = str + strlen(str);+ while( *--p == ' ' && p > str )+ ;+ return *p == '|' ? p : (char *)0;+}++int sys_open(const char *filename, const int mode, const int mask)+{+ register const char *p = check_leading_barchar(filename);+ if( p != (char*)0 )+ { /* fname starts with '|' */+ /* p points to the first char after | */+ if( *p == '\0' )+ return (errno = EINVAL), -1; /* Empty command */+ + switch( mode & O_ACCMODE )+ {+ case O_RDONLY:+ report_error+ ("File name '%s' looks like the pipe to write to,"+ "\nbut the open mode is not WRITE_ONLY\n",filename);+ return _popen(p,filename+strlen(filename),O_RDONLY);+ + case O_WRONLY:+ return _popen(p,filename+strlen(filename),O_WRONLY);+ + default:+ return bidirectional_popen(p,filename+strlen(filename));+ }+ }+ /* '|' is the last char of the filename */+ else if( (p=check_trailing_barchar(filename)) != (char *)0 )+ {+ switch( mode & O_ACCMODE )+ {+ case O_RDONLY:+ return _popen(filename,p,O_RDONLY);+ + case O_WRONLY:+ report_error+ ("File name '%s' looks like the pipe to read from,"+ "\nbut the open mode is not READ_ONLY\n",filename);+ return _popen(filename,p,O_WRONLY);+ + default:+ return bidirectional_popen(filename,p);+ }+ }+ else if( strncmp(filename,TCP_EXTENDED_FNAME_PREFIX,+ strlen(TCP_EXTENDED_FNAME_PREFIX)) == 0 )+ return open_connect(filename+strlen(TCP_EXTENDED_FNAME_PREFIX),mode);+ else if( strncmp(filename,TCP_LISTEN_EXTENDED_FNAME_PREFIX,+ strlen(TCP_LISTEN_EXTENDED_FNAME_PREFIX)) == 0 )+ return open_listen(filename+strlen(TCP_LISTEN_EXTENDED_FNAME_PREFIX),mode);+ else+ return open(filename,mode,mask);++ return -1; /* Unnecessary, but gcc really likes it... */+}+++/*+ *------------------------------------------------------------------------+ * An extended 'close(2)'+ * If needed, clean after ourselves. Otherwise, just do regular close(2).+ * At present, we need to check if fh is a pipe descriptor. If it is,+ * we need to wait for the process to finish.+ */++int sys_close(const int fh)+{+ const int rc = try_close_popen(fh);+ return rc > 0 ? close(fh) : rc;+}
+ include/sys_open.h view
@@ -0,0 +1,2 @@++int sys_open(const char *filename, const int mode, const int mask);
liboleg.cabal view
@@ -1,5 +1,5 @@ name: liboleg-version: 0.1.0.1+version: 0.1.0.2 license: BSD3 license-file: LICENSE author: Oleg Kiselyov@@ -14,18 +14,33 @@ library build-depends:- base, containers, mtl+ base,+ containers,+ mtl,+ unix exposed-modules: Data.FDList Control.CaughtMonadIO + Codec.Image.Tiff+ Language.TypeLC Language.TypeFN Text.PrintScan Text.PrintScanF + System.SysOpen+ System.IterateeM+ System.LowLevelIO+ System.RandomIO+ ghc-options: -funbox-strict-fields ++ c-sources: cbits/sys_open.c+ include-dirs: include+ includes: sys_open.h+ install-includes: sys_open.h