diff --git a/Codec/Image/Tiff.hs b/Codec/Image/Tiff.hs new file mode 100644 --- /dev/null +++ b/Codec/Image/Tiff.hs @@ -0,0 +1,623 @@ +{-# LANGUAGE Rank2Types #-} + +-- +-- | A general-purpose TIFF library +-- +-- +-- +-- 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: +-- +-- 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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2008 Oleg Kiselyov +Copyright (c) 2008-2009 Oleg Kiselyov All rights reserved. diff --git a/System/IterateeM.hs b/System/IterateeM.hs new file mode 100644 --- /dev/null +++ b/System/IterateeM.hs @@ -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: +-- +-- > CRLF CRLF +-- +-- where is the hexadecimal number; is a +-- sequence of 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: +-- +-- +-- 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" diff --git a/System/LowLevelIO.hs b/System/LowLevelIO.hs new file mode 100644 --- /dev/null +++ b/System/LowLevelIO.hs @@ -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) + + diff --git a/System/RandomIO.hs b/System/RandomIO.hs new file mode 100644 --- /dev/null +++ b/System/RandomIO.hs @@ -0,0 +1,349 @@ +-- Haskell98! + +-- | Random and Binary IO with IterateeM +-- +-- +-- +-- +-- 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 +-} diff --git a/System/SysOpen.hs b/System/SysOpen.hs new file mode 100644 --- /dev/null +++ b/System/SysOpen.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- +-- +-- 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) +-- +-- +-- 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" + diff --git a/cbits/sys_open.c b/cbits/sys_open.c new file mode 100644 --- /dev/null +++ b/cbits/sys_open.c @@ -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 +#include +#include +#include +#include +#include +#include +#include +#include +#include +#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 +/*typedef struct in_addr in_addr_t; Fixed in FreeBSD 4.6+ */ +#endif +#include +#include +#include +#include + /* 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; +} diff --git a/include/sys_open.h b/include/sys_open.h new file mode 100644 --- /dev/null +++ b/include/sys_open.h @@ -0,0 +1,2 @@ + +int sys_open(const char *filename, const int mode, const int mask); diff --git a/liboleg.cabal b/liboleg.cabal --- a/liboleg.cabal +++ b/liboleg.cabal @@ -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