streaming-png (empty) → 0.1.0.0
raw patch · 13 files changed
+1621/−0 lines, 13 filesdep +JuicyPixelsdep +basedep +bytestringsetup-changed
Dependencies added: JuicyPixels, base, bytestring, cereal, criterion, exceptions, mmorph, mtl, resourcet, streaming, streaming-bytestring, streaming-commons, streaming-png, transformers, vector
Files
- LICENSE +165/−0
- Setup.hs +2/−0
- demo/Main.hs +62/−0
- src/Codec/Picture/Png/Streaming.hs +140/−0
- src/Codec/Picture/Png/Streaming/Core.hs +227/−0
- src/Codec/Picture/Png/Streaming/Header.hs +90/−0
- src/Codec/Picture/Png/Streaming/Info.hs +137/−0
- src/Codec/Picture/Png/Streaming/Juicy.hs +74/−0
- src/Codec/Picture/Png/Streaming/MainData.hs +336/−0
- src/Codec/Picture/Png/Streaming/Util.hs +141/−0
- src/Streaming/CRC.hs +56/−0
- src/Streaming/Zlib.hs +119/−0
- streaming-png.cabal +72/−0
+ LICENSE view
@@ -0,0 +1,165 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.+++ This version of the GNU Lesser General Public License incorporates+the terms and conditions of version 3 of the GNU General Public+License, supplemented by the additional permissions listed below.++ 0. Additional Definitions.++ As used herein, "this License" refers to version 3 of the GNU Lesser+General Public License, and the "GNU GPL" refers to version 3 of the GNU+General Public License.++ "The Library" refers to a covered work governed by this License,+other than an Application or a Combined Work as defined below.++ An "Application" is any work that makes use of an interface provided+by the Library, but which is not otherwise based on the Library.+Defining a subclass of a class defined by the Library is deemed a mode+of using an interface provided by the Library.++ A "Combined Work" is a work produced by combining or linking an+Application with the Library. The particular version of the Library+with which the Combined Work was made is also called the "Linked+Version".++ The "Minimal Corresponding Source" for a Combined Work means the+Corresponding Source for the Combined Work, excluding any source code+for portions of the Combined Work that, considered in isolation, are+based on the Application, and not on the Linked Version.++ The "Corresponding Application Code" for a Combined Work means the+object code and/or source code for the Application, including any data+and utility programs needed for reproducing the Combined Work from the+Application, but excluding the System Libraries of the Combined Work.++ 1. Exception to Section 3 of the GNU GPL.++ You may convey a covered work under sections 3 and 4 of this License+without being bound by section 3 of the GNU GPL.++ 2. Conveying Modified Versions.++ If you modify a copy of the Library, and, in your modifications, a+facility refers to a function or data to be supplied by an Application+that uses the facility (other than as an argument passed when the+facility is invoked), then you may convey a copy of the modified+version:++ a) under this License, provided that you make a good faith effort to+ ensure that, in the event an Application does not supply the+ function or data, the facility still operates, and performs+ whatever part of its purpose remains meaningful, or++ b) under the GNU GPL, with none of the additional permissions of+ this License applicable to that copy.++ 3. Object Code Incorporating Material from Library Header Files.++ The object code form of an Application may incorporate material from+a header file that is part of the Library. You may convey such object+code under terms of your choice, provided that, if the incorporated+material is not limited to numerical parameters, data structure+layouts and accessors, or small macros, inline functions and templates+(ten or fewer lines in length), you do both of the following:++ a) Give prominent notice with each copy of the object code that the+ Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the object code with a copy of the GNU GPL and this license+ document.++ 4. Combined Works.++ You may convey a Combined Work under terms of your choice that,+taken together, effectively do not restrict modification of the+portions of the Library contained in the Combined Work and reverse+engineering for debugging such modifications, if you also do each of+the following:++ a) Give prominent notice with each copy of the Combined Work that+ the Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the Combined Work with a copy of the GNU GPL and this license+ document.++ c) For a Combined Work that displays copyright notices during+ execution, include the copyright notice for the Library among+ these notices, as well as a reference directing the user to the+ copies of the GNU GPL and this license document.++ d) Do one of the following:++ 0) Convey the Minimal Corresponding Source under the terms of this+ License, and the Corresponding Application Code in a form+ suitable for, and under terms that permit, the user to+ recombine or relink the Application with a modified version of+ the Linked Version to produce a modified Combined Work, in the+ manner specified by section 6 of the GNU GPL for conveying+ Corresponding Source.++ 1) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (a) uses at run time+ a copy of the Library already present on the user's computer+ system, and (b) will operate properly with a modified version+ of the Library that is interface-compatible with the Linked+ Version.++ e) Provide Installation Information, but only if you would otherwise+ be required to provide such information under section 6 of the+ GNU GPL, and only to the extent that such information is+ necessary to install and execute a modified version of the+ Combined Work produced by recombining or relinking the+ Application with a modified version of the Linked Version. (If+ you use option 4d0, the Installation Information must accompany+ the Minimal Corresponding Source and Corresponding Application+ Code. If you use option 4d1, you must provide the Installation+ Information in the manner specified by section 6 of the GNU GPL+ for conveying Corresponding Source.)++ 5. Combined Libraries.++ You may place library facilities that are a work based on the+Library side by side in a single library together with other library+facilities that are not Applications and are not covered by this+License, and convey such a combined library under terms of your+choice, if you do both of the following:++ a) Accompany the combined library with a copy of the same work based+ on the Library, uncombined with any other library facilities,+ conveyed under the terms of this License.++ b) Give prominent notice with the combined library that part of it+ is a work based on the Library, and explaining where to find the+ accompanying uncombined form of the same work.++ 6. Revised Versions of the GNU Lesser General Public License.++ The Free Software Foundation may publish revised and/or new versions+of the GNU Lesser General Public License from time to time. Such new+versions will be similar in spirit to the present version, but may+differ in detail to address new problems or concerns.++ Each version is given a distinguishing version number. If the+Library as you received it specifies that a certain numbered version+of the GNU Lesser General Public License "or any later version"+applies to it, you have the option of following the terms and+conditions either of that published version or of any later version+published by the Free Software Foundation. If the Library as you+received it does not specify a version number of the GNU Lesser+General Public License, you may choose any version of the GNU Lesser+General Public License ever published by the Free Software Foundation.++ If the Library as you received it specifies that a proxy can decide+whether future versions of the GNU Lesser General Public License shall+apply, that proxy's public statement of acceptance of any version is+permanent authorization for you to choose that version for the+Library.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ demo/Main.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleContexts #-}+module Main where++import Codec.Picture (DynamicImage)+import qualified Codec.Picture.Png as Juicy+import Codec.Picture.Png.Streaming+import Codec.Picture.Png.Streaming.Juicy++import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Resource (MonadResource, runResourceT)++import qualified Data.ByteString as B++import Criterion.Main++import qualified Data.ByteString.Streaming as Q+import Streaming.Prelude (Of (..))++readPNG :: (MonadResource m) => FilePath -> m DynamicImage+readPNG readPath =+ do decoded <- decodePNGFile readPath+ res :> _ <- imageFromStream decoded+ return res++decodeBS :: B.ByteString -> IO DynamicImage+decodeBS bs =+ do decoded <- decodePNG $ Q.fromStrict bs+ res :> _ <- imageFromStream decoded+ return res++copyPNG :: (MonadResource m) => FilePath -> FilePath -> m ()+copyPNG readPath writePath =+ do image <- readPNG readPath+ liftIO . void $ Juicy.writeDynamicPng writePath image++fstOf :: Of a b -> a+fstOf (x :> _) = x++benchImage :: (String, B.ByteString) -> [Benchmark]+benchImage (path, image) =+ -- [ bench ("read " ++ path ++ " with JuicyPixels") . nf Juicy.decodePng $ image+ [ bench ("read " ++ path ++ " with streaming") . nfIO $ decodeBS image+ ]++benchmarkMain :: IO ()+benchmarkMain =+ do hugeFile <- B.readFile "huge.png"+ largeFile <- B.readFile "large.png"+ mediumFile <- B.readFile "medium.png"+ smallFile <- B.readFile "small.png"++ defaultMain $ benchImage =<< [("huge.png", hugeFile)]+ -- [ ("small.png", smallFile)+ -- , ("medium.png", mediumFile)+ -- , ("large.png", largeFile)+ -- , ("huge.png", hugeFile)+ -- ]++main :: IO ()+-- main = runResourceT $ copyPNG "huge.png" "result.png"+main = benchmarkMain
+ src/Codec/Picture/Png/Streaming.hs view
@@ -0,0 +1,140 @@+{-|+Module : Codec.Picture.Png.Streaming+Copyright : (c) Bradley Hardy 2016+License: LGPL3+Maintainer: bradleyhardy@live.com+Stability: experimental+Portability: non-portable++A perfectly streaming PNG decoding library.+-}++{-# LANGUAGE RecordWildCards #-}+module Codec.Picture.Png.Streaming+ (+ -- * Decoding+ decodePNG+ , decodePNGComplete+ , decodePNGFile+ , decodeHeader++ -- * Types+ , PNGDecodeError(..)+ , DecodedPNG+ , HeaderData(..)++ -- * Misc+ , ChunkType+ , BitDepth+ , ColourType+ , CompressionMethod+ , FilterMethod+ , FilterType+ , InterlaceMethod++ , isColourTypeSupported+ , isCompressionMethodSupported+ , isFilterMethodSupported+ , isInterlaceMethodSupported+ )+ where++import Codec.Picture.Png.Streaming.Core+import Codec.Picture.Png.Streaming.Header+import Codec.Picture.Png.Streaming.Info+import Codec.Picture.Png.Streaming.MainData+import Codec.Picture.Png.Streaming.Util++import Control.Monad (unless)+import Control.Monad.Catch (MonadThrow (..))+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans (MonadTrans (..))+import Control.Monad.Trans.Resource (MonadResource)++import Data.ByteString.Streaming (ByteString)+import qualified Data.ByteString.Streaming as Q+import Streaming.Prelude (Of (..))++-- | A decoded PNG: header information followed by decoded pixel data whose+-- format depends on the image's colour type and bit depth.+type DecodedPNG m r = Of HeaderData (ByteString m r)++{-|+Decode a PNG from the given raw streaming 'ByteString'. The result is header+information followed by a stream of bytes that can be interpreted directly as+pixels whose format depends on the image's colour type and bit depth.++Any remaining data after the end of the PNG image is returned untouched.+-}+decodePNG :: (MonadThrow m, MonadIO m) => ByteString m r -> m (DecodedPNG m (ByteString m r))+decodePNG input =+ do (hd :> rest) <- takeHeaderData (decodePNGChunks input)+ unless (isImageTypeSupported hd) (throwM UnsupportedImageType)+ return (hd :> decodeImageData hd rest)++{-|+Decode just the PNG header data from the given raw streaming 'ByteString',+inspecting the minimum number of bytes from the input necessary to do so. The+remaining bytes are returned also.+-}+decodeHeader :: (MonadThrow m) => ByteString m r -> m (Of HeaderData (ByteString m r))+decodeHeader input =+ do PNGChunk{..} <-+ either (const $ throwM UnexpectedEOF) return+ =<< decodeChunk input++ unless (chunkType == ctIHDR) (throwM (UnexpectedChunk chunkType))+ tryDecodeHeader chunkData++{-|+Decode a PNG from the given raw streaming 'ByteString'. The result is header+information followed by a stream of bytes that can be interpreted directly as+pixels whose format depends on the image's colour type and bit depth.++If there is any more data after the end of the PNG image, an 'ExpectedEOF'+exception is thrown.+-}+decodePNGComplete :: (MonadThrow m, MonadIO m) => ByteString m r -> m (DecodedPNG m r)+decodePNGComplete input =+ do (hd :> rest) <- decodePNG input+ let rest' = lift . expectNull ExpectedEOF =<< rest+ return (hd :> rest')++{-|+Decode a PNG from the given file. The result is header information followed by a+stream of bytes that can be interpreted directly as pixels whose format depends+on the image's colour type and bit depth.++If there is any more data after the end of the PNG image, an 'ExpectedEOF'+exception is thrown.+-}+decodePNGFile :: (MonadResource m) => FilePath -> m (DecodedPNG m ())+decodePNGFile = decodePNGComplete . Q.readFile++-- | Is the PNG image type described by the given header supported?+isImageTypeSupported :: HeaderData -> Bool+isImageTypeSupported HeaderData{..} =+ isColourTypeSupported hdColourType &&+ isCompressionMethodSupported hdCompressionMethod &&+ isFilterMethodSupported hdFilterMethod &&+ isInterlaceMethodSupported hdInterlaceMethod++-- | Is the given PNG image colour type supported? Currently we only support+-- non-indexed colour types.+isColourTypeSupported :: ColourType -> Bool+isColourTypeSupported = (`elem` [0, 2, 4, 6])++-- | Is the given PNG compression method supported? Currently we only support+-- method 0.+isCompressionMethodSupported :: CompressionMethod -> Bool+isCompressionMethodSupported = (== 0)++-- | Is the given PNG filter method supported? Currently we only support method+-- 0.+isFilterMethodSupported :: FilterMethod -> Bool+isFilterMethodSupported = (== 0)++-- | Is the given PNG interlace method supported? Currently only the null+-- interlace method (no interlacing) is supported.+isInterlaceMethodSupported :: InterlaceMethod -> Bool+isInterlaceMethodSupported = (== 0)
+ src/Codec/Picture/Png/Streaming/Core.hs view
@@ -0,0 +1,227 @@+{-|+Module : Codec.Picture.Png.Streaming.Core+Copyright : (c) Bradley Hardy 2016+License: LGPL3+Maintainer: bradleyhardy@live.com+Stability: experimental+Portability: non-portable++-}++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+module Codec.Picture.Png.Streaming.Core+ ( ChunkType+ , ChunkLength+ , PNGDecodeError(..)+ , PNGEncodeError(..)+ , PNGChunk(..)+ , decodePNGChunks+ , encodePNGChunks+ , decodeChunk+ )+ where++import Streaming.CRC+import Codec.Picture.Png.Streaming.Info+import Codec.Picture.Png.Streaming.Util++import Control.Monad (join, when)+import Control.Monad.Catch (Exception, MonadThrow (..))+import Control.Monad.Trans (lift)+import qualified Data.ByteString as B+import Data.Int (Int64)+import qualified Data.Serialize as C+import Data.Word (Word32)++import Data.ByteString.Streaming (ByteString)+import qualified Data.ByteString.Streaming as Q+import Streaming (Stream)+import qualified Streaming as S+import Streaming.Prelude (Of (..))++--------------------------------------------------------------------------------+-- Types++-- | A raw chunk of PNG data, containing the length, type and a streaming+-- 'ByteString' of data.+data PNGChunk m r =+ PNGChunk+ { chunkLength :: ChunkLength+ , chunkType :: ChunkType+ , chunkData :: ByteString m r+ }+ deriving (Functor)++-- | The type of errors that might arise when decoding a PNG.+data PNGDecodeError+ = IncorrectSignature+ | CRCMismatch+ | UnexpectedEOF+ | BadChunkSize ChunkType+ | UnexpectedChunk ChunkType+ | UnsupportedImageType+ | UnsupportedColourType+ | UnsupportedFilterType FilterType+ | ExpectedEOF+ | UnknownError String+ deriving (Show)++instance Exception PNGDecodeError where++-- | The type of errors that might arise when encoding a PNG.+data PNGEncodeError+ = IncorrectLength+ deriving (Show)++instance Exception PNGEncodeError where++--------------------------------------------------------------------------------+-- Raw decode and encode functions++-- | Fully decode a PNG to its raw streaming representation, returning the PNG+-- data chunks until "IEND" is reached. The return value is the (potentially+-- empty) rest of the 'ByteString' after the PNG.++{-|++Decode a stream of individual PNG chunks from a raw streaming 'ByteString'+input. The return value of the resulting stream is any remaining data after+encountering the final "IEND" chunk.++-}+decodePNGChunks :: (MonadThrow m) => ByteString m r -> Stream (PNGChunk m) m (ByteString m r)+decodePNGChunks = S.unfold decodeChunk . checkSig++-- | Encode a stream of individual PNG chunks into a raw streaming 'ByteString'.+encodePNGChunks :: (MonadThrow m) => Stream (PNGChunk m) m r -> ByteString m r+encodePNGChunks png =+ do Q.fromStrict pngSignature+ res <- S.iterTM (join . encodeChunk) png+ encodeChunk chunkIEND+ return res++--------------------------------------------------------------------------------+-- Decoding and encoding individual chunks++-- | Decode a chunk of a PNG file, returning the raw binary data in the chunk+-- followed by the rest of the input; or the remaining data in the 'ByteString'+-- if we have reached the "IEND" chunk.+decodeChunk+ :: (MonadThrow m)+ => ByteString m r+ -> m (Either (ByteString m r) (PNGChunk m (ByteString m r)))+decodeChunk input =+ do -- The first 4 bytes tell us the length of the chunk+ lenBS :> input' <- Q.toStrict $ Q.splitAt 4 input++ -- Read the length (which is in big endian) using 'cereal',+ -- throwing an error if it can't be read.+ chunkLength <- readWord32 lenBS++ -- Split at the end of the chunk, and calculate the CRC of the data, while+ -- copying the chunk data so that we can hand it to 'reader'.+ let input'' = calcCRC32 $ Q.copy $ Q.splitAt (fromIntegral chunkLength + 4) input'++ -- The next 4 bytes tell us the chunk type.+ chunkType :> input''' <- Q.toStrict $ Q.splitAt 4 input''++ -- The length of the chunk type can't be more than 4 because we split at 4,+ -- but if it's less then we have encountered an error.+ when (B.length chunkType < 4) (throwM UnexpectedEOF)++ -- Use the provided 'reader' function to read the input, while+ -- simultaneously calculating the CRC of the data.+ let readData = Q.splitAt (fromIntegral chunkLength) input'''++ -- Discard the rest of the first ByteString in the result, as it's always+ -- empty, then make sure we fail with an error if the CRC is wrong.+ chunkData = checkCRC <$> Q.drained readData++ if chunkType /= ctIEND+ then return $ Right PNGChunk{..}+ else Left <$> Q.effects chunkData++-- | Encode a chunk of a PNG file with a specified length and chunk type. The+-- input 'PNGChunk' must not lie about its length. If it does, an+-- 'IncorrectLength' error will be thrown. It is important to know the length+-- at the head of the chunk to maintain streaming.+encodeChunk+ :: (MonadThrow m)+ => PNGChunk m r -- ^ The data segment to write.+ -> ByteString m r -- ^ The resulting data encoded as a PNG chunk.+encodeChunk PNGChunk{..} =+ do let lenBS = C.runPut . C.putWord32be $ chunkLength++ -- write the+ Q.fromStrict lenBS++ let -- restrict the length of the input to the given data length as above+ restrictedLen = checkLength (fromIntegral chunkLength) chunkData++ -- tack the chunk type bytes to the front+ -- it is important to do this BEFORE calculating the CRC, because the+ -- CRC applies to the chunk type too (but not to the length)+ withChunkType = Q.fromStrict chunkType >> restrictedLen++ -- calculate the CRC and write that to the end+ appendCRC32 withChunkType++--------------------------------------------------------------------------------+-- Extra helper functions++-- | Check the length of a ByteString against an expected length. Running the+-- resulting 'ByteString' to the end will throw an error if it is not exactly the+-- right length.+checkLength+ :: MonadThrow m+ => Int64+ -> ByteString m r+ -> ByteString m r+checkLength expectedLength input =+ do (len :> rest) <- Q.length $ Q.copy $ Q.splitAt expectedLength input+ when (fromIntegral len /= expectedLength) $+ lift $ throwM IncorrectLength++ lift $ expectNull IncorrectLength rest++-- | Read 32 bits from a 'B.ByteString' into a 'Word32'. Throws an+-- 'UnexpectedEOF' exception if the bits can't be read.+readWord32 :: MonadThrow m => B.ByteString -> m Word32+readWord32 bs =+ case C.runGet C.getWord32be bs of+ Left _ -> throwM UnexpectedEOF+ Right x -> return (fromIntegral x)++-- | Given an expected CRC and a 'ByteString' whose first 4 bytes should match+-- that CRC, check if there is a match. If not, throw a 'CRCMismatch' error. If+-- it matches, return the remainder of the 'ByteString'.+checkCRC :: MonadThrow m => Of Word32 (ByteString m r) -> ByteString m r+checkCRC (dataCRC :> bytes) = Q.mwrap $+ do (crcBS :> bytes') <- Q.toStrict $ Q.splitAt 4 bytes+ crc <- readWord32 crcBS+ if crc == dataCRC+ then return bytes'+ else throwM CRCMismatch++-- | Check the fixed PNG signature, return the rest of the input after the+-- signature.+checkSig :: MonadThrow m => ByteString m r -> ByteString m r+checkSig input = Q.mwrap $ do+ (header :> remainder) <- Q.toStrict $ Q.splitAt 8 input+ if header == pngSignature+ then return remainder+ else throwM IncorrectSignature++chunkIEND :: (Monad m) => PNGChunk m ()+chunkIEND =+ let chunkLength = 0+ chunkType = ctIEND+ chunkData = mempty+ in PNGChunk{..}
+ src/Codec/Picture/Png/Streaming/Header.hs view
@@ -0,0 +1,90 @@+{-|+Module : Codec.Picture.Png.Streaming.Header+Copyright : (c) Bradley Hardy 2016+License: LGPL3+Maintainer: bradleyhardy@live.com+Stability: experimental+Portability: non-portable++-}++{-# LANGUAGE RecordWildCards #-}+module Codec.Picture.Png.Streaming.Header+ ( HeaderData(..)+ , takeHeaderData+ , tryDecodeHeader+ )+ where++import Codec.Picture.Png.Streaming.Core+import Codec.Picture.Png.Streaming.Info+import Codec.Picture.Png.Streaming.Util++import Control.Monad (unless)+import Control.Monad.Catch (MonadThrow (..))++import qualified Data.ByteString as B+import qualified Data.Serialize as C+import Data.Word (Word32)++import Data.ByteString.Streaming (ByteString)+import qualified Data.ByteString.Streaming as Q+import Streaming (Stream)+import qualified Streaming as S+import Streaming.Prelude (Of (..))++-- | Represents the header data of a PNG file in raw binary format.+data HeaderData =+ HeaderData+ { hdWidth :: Word32+ , hdHeight :: Word32+ , hdBitDepth :: BitDepth+ , hdColourType :: ColourType+ , hdCompressionMethod :: CompressionMethod+ , hdFilterMethod :: FilterMethod+ , hdInterlaceMethod :: InterlaceMethod+ }+ deriving (Show)++-- | Take the header data from the front of a stream and return the remainder.+-- Throws an 'UnexpectedChunk' exception if the first chunk isn't of type+-- "IHDR", or 'UnexpectedEOF' if the stream is empty.+takeHeaderData :: (MonadThrow m) => Stream (PNGChunk m) m r -> m (Of HeaderData (Stream (PNGChunk m) m r))+takeHeaderData input =+ do maybeChunk <- S.inspect input+ case maybeChunk of+ Left _ -> throwM UnexpectedEOF+ Right PNGChunk{..} ->+ do unless (chunkType == ctIHDR) (throwM (UnexpectedChunk chunkType))+ tryDecodeHeader chunkData++deserializeHeaderData :: B.ByteString -> Either String HeaderData+deserializeHeaderData = C.runGet $+ do hdWidth <- C.getWord32be+ hdHeight <- C.getWord32be+ hdBitDepth <- C.getWord8+ hdColourType <- C.getWord8+ hdCompressionMethod <- C.getWord8+ hdFilterMethod <- C.getWord8+ hdInterlaceMethod <- C.getWord8+ return HeaderData{..}++-- serializeHeaderData :: HeaderData -> B.ByteString+-- serializeHeaderData HeaderData{..} = C.runPut $+-- do C.putWord32be hdWidth+-- C.putWord32be hdHeight+-- C.putWord8 hdBitDepth+-- C.putWord8 hdColourType+-- C.putWord8 hdCompressionMethod+-- C.putWord8 hdFilterMethod+-- C.putWord8 hdInterlaceMethod++-- | Try to decode a PNG header from a ByteString, failing if it is of the wrong+-- length.+tryDecodeHeader+ :: MonadThrow m => ByteString m r -> m (Of HeaderData r)+tryDecodeHeader input =+ do (bytes :> rest) <- Q.toStrict $ Q.splitAt (fromIntegral ihdrLength) input+ res <- expectNull (BadChunkSize ctIHDR) rest+ parsed <- either (throwM . UnknownError) return (deserializeHeaderData bytes)+ return (parsed :> res)
+ src/Codec/Picture/Png/Streaming/Info.hs view
@@ -0,0 +1,137 @@+{-|+Module : Codec.Picture.Png.Streaming.Info+Copyright : (c) Bradley Hardy 2016+License: LGPL3+Maintainer: bradleyhardy@live.com+Stability: experimental+Portability: non-portable++-}++{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+module Codec.Picture.Png.Streaming.Info where++import qualified Data.ByteString as B+import Data.Int (Int16)+import Data.Word (Word16, Word32, Word8)++-- | A chunk type, represented as a 'B.ByteString' of length 4.+type ChunkType = B.ByteString++-- | A chunk length.+type ChunkLength = Word32++-- | A colour type.+type ColourType = Word8++-- | A bit depth.+type BitDepth = Word8++-- | A PNG compression method (distinct from the type in 'Streaming.Zlib' of the+-- same name).+type CompressionMethod = Word8++-- | A PNG filtering method.+type FilterMethod = Word8++-- | A PNG interlacing method.+type InterlaceMethod = Word8++-- | A PNG filter type, for filter method 0.+type FilterType = Word8++-- | The 4-byte identifier for a PNG header chunk.+ctIHDR :: ChunkType+ctIHDR = "IHDR"++-- | The 4-byte identifier for a PNG data chunk.+ctIDAT :: ChunkType+ctIDAT = "IDAT"++-- | The 4-byte identifier for a PNG ending chunk.+ctIEND :: ChunkType+ctIEND = "IEND"++-- | The 8-byte signature for a PNG file.+pngSignature :: B.ByteString+pngSignature = "\137PNG\r\n\26\n"++-- | The length of the header chunk.+ihdrLength :: ChunkLength+ihdrLength = 13++-- | From a bit depth and colour type, return the number of bits in each pixel,+-- checking also that the bit depth provided is allowed for the given colour+-- type.+getBitsPerPixel :: BitDepth -> ColourType -> Maybe Word8+getBitsPerPixel bitDepth colourType+ -- greyscale+ | colourType == 0 && bitDepth `elem` [1, 2, 4, 8, 16] = Just bitDepth+ -- indexed colour+ | colourType == 3 && bitDepth `elem` [1, 2, 4, 8] = Just bitDepth+ -- truecolour+ | colourType == 2 && bitDepth == 8 || bitDepth == 16 = Just (bitDepth * 3)+ -- greyscale with alpha+ | colourType == 4 && bitDepth == 8 || bitDepth == 16 = Just (bitDepth * 2)+ -- truecolour with alpha+ | colourType == 6 && bitDepth == 8 || bitDepth == 16 = Just (bitDepth * 4)+ -- unknown+ | otherwise = Nothing++-- | The Paeth predictor function due to Alan W. Paeth.+paethPredictor :: Word8 -> Word8 -> Word8 -> Word8+paethPredictor a b c =+ -- It is important to convert the bytes to signed integers before doing the+ -- calculations, because the Paeth predictor relies on signed arithmetic.+ let ia = fromIntegral a :: Int16+ ib = fromIntegral b+ ic = fromIntegral c++ p = ia + ib - ic+ pa = abs (p - ia)+ pb = abs (p - ib)+ pc = abs (p - ic)+ in if | pa <= pb && pa <= pc -> a+ | pb <= pc -> b+ | otherwise -> c++-- | Average filter a byte.+filterAverage :: Word8 -> Word8 -> Word8 -> Word8+filterAverage a b x = x - fromIntegral ((fromIntegral a + fromIntegral b) `div` (2 :: Word16))+{-# INLINE filterAverage #-}++-- | Paeth filter a byte.+filterPaeth :: Word8 -> Word8 -> Word8 -> Word8 -> Word8+filterPaeth a b c x = x - paethPredictor a b c+{-# INLINE filterPaeth #-}++-- | Reconstruct an average filtered byte.+reconAverage :: Word8 -> Word8 -> Word8 -> Word8+reconAverage a b x = x + fromIntegral ((fromIntegral a + fromIntegral b) `div` (2 :: Word16))+{-# INLINE reconAverage #-}++-- | Reconstruct a Paeth filtered byte.+reconPaeth :: Word8 -> Word8 -> Word8 -> Word8 -> Word8+reconPaeth a b c x = x + paethPredictor a b c+{-# INLINE reconPaeth #-}++-- {- |+-- Given a filter type, return the reconstruction function for a single byte, if+-- the filter type is valid. If @f@ is a function returned by 'getReconFunction',+-- the correct argument order is @f a b c x@, where those variable names match the+-- ones used in the <http://www.w3.org/TR/PNG/#9Filter-types PNG specification,+-- section 9.2>.+-- -}+-- getReconFunction :: FilterType -> Maybe (Word8 -> Word8 -> Word8 -> Word8 -> Word8)+-- getReconFunction filterType =+-- let ftInt = fromIntegral filterType+-- funs = [ reconNone+-- , reconSub+-- , reconUp+-- , reconAverage+-- , reconPaeth ]++-- in if ftInt < length funs+-- then Just (funs !! ftInt)+-- else Nothing
+ src/Codec/Picture/Png/Streaming/Juicy.hs view
@@ -0,0 +1,74 @@+{-|+Module : Codec.Picture.Png.Streaming.Juicy+Copyright : (c) Bradley Hardy 2016+License: LGPL3+Maintainer: bradleyhardy@live.com+Stability: experimental+Portability: non-portable++Provides a way to produce @JuicyPixels@ images from PNG data decoded with+@streaming-png@.++For example, to load a @JuicyPixels@ image from a PNG file:++> decodePNGFile "my-png.png" >>= imageFromStream :: (MonadIO m, MonadThrow m) => m (Of DynamicImage ())++-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}+module Codec.Picture.Png.Streaming.Juicy+ ( imageFromStream )+ where++import Codec.Picture+import Codec.Picture.Png.Streaming+import Codec.Picture.Png.Streaming.Util++import Control.Monad.Catch (MonadThrow (..))++import qualified Data.ByteString.Internal as BI+import Data.Vector.Storable (Vector)+import qualified Data.Vector.Storable as Vec+import Data.Word (Word16, Word8)+import Foreign (castForeignPtr, sizeOf)++import Data.ByteString.Streaming (ByteString)+import qualified Data.ByteString.Streaming as Q+import Streaming.Prelude (Of (..))++type BytePacker m b r = ByteString m r -> m (Of (Vector b) r)+type MkImage m p r = (Int, Int) -> ByteString m r -> m (Of (Image p) r)++bp8 :: (Monad m) => BytePacker m Word8 r+bp8 input =+ do bs :> res <- Q.toStrict input+ return (bytestringToVector bs :> res)++bp16 :: (Monad m) => BytePacker m Word16 r+bp16 input =+ do BI.PS fptr offset idx :> res <- Q.toStrict input+ let ws = sizeOf (0 :: Word16)+ return (Vec.unsafeFromForeignPtr (castForeignPtr fptr) (offset `div` ws) (idx `div` ws) :> res)++mkImage :: (Monad m) => BytePacker m (PixelBaseComponent p) r -> MkImage m p r+mkImage bytePacker (imageWidth, imageHeight) input =+ do imageData :> res <- bytePacker input+ return (Image{..} :> res)++lmap :: (a -> b) -> Of a r -> Of b r+lmap f (x :> r) = f x :> r++-- | Pulls a PNG image stream into memory as a JuicyPixels 'DynamicImage'.+-- Currently supports every legal non-indexed colour type.+imageFromStream :: (MonadThrow m) => DecodedPNG m r -> m (Of DynamicImage r)+imageFromStream (HeaderData{..} :> bytes) =+ let wh = (fromIntegral hdWidth, fromIntegral hdHeight)+ in if | hdColourType == 0 && hdBitDepth == 8 -> lmap ImageY8 <$> mkImage bp8 wh bytes+ | hdColourType == 0 && hdBitDepth == 16 -> lmap ImageY16 <$> mkImage bp16 wh bytes+ | hdColourType == 2 && hdBitDepth == 8 -> lmap ImageRGB8 <$> mkImage bp8 wh bytes+ | hdColourType == 2 && hdBitDepth == 16 -> lmap ImageRGB16 <$> mkImage bp16 wh bytes+ | hdColourType == 4 && hdBitDepth == 8 -> lmap ImageYA8 <$> mkImage bp8 wh bytes+ | hdColourType == 4 && hdBitDepth == 16 -> lmap ImageYA16 <$> mkImage bp16 wh bytes+ | hdColourType == 6 && hdBitDepth == 8 -> lmap ImageRGBA8 <$> mkImage bp8 wh bytes+ | hdColourType == 6 && hdBitDepth == 16 -> lmap ImageRGBA16 <$> mkImage bp16 wh bytes+ | otherwise -> throwM UnsupportedImageType
+ src/Codec/Picture/Png/Streaming/MainData.hs view
@@ -0,0 +1,336 @@+{-|+Module : Codec.Picture.Png.Streaming.MainData+Copyright : (c) Bradley Hardy 2016+License: LGPL3+Maintainer: bradleyhardy@live.com+Stability: experimental+Portability: non-portable++-}+{-# LANGUAGE RecordWildCards #-}+module Codec.Picture.Png.Streaming.MainData+ ( decodeImageData )+ where++import Codec.Picture.Png.Streaming.Core+import Codec.Picture.Png.Streaming.Header+import Codec.Picture.Png.Streaming.Info+import Codec.Picture.Png.Streaming.Util+import Streaming.Zlib++import Control.Monad.Catch (MonadThrow (..))+import Control.Monad.IO.Class (MonadIO (..))++import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B+import Data.Functor.Identity (Identity (..))+import Data.Functor.Sum (Sum (..))+import Data.Int (Int64)+import qualified Data.Vector.Storable as Vec+import qualified Data.Vector.Storable.Mutable as Vec+import Data.Word (Word64)+import Data.Foldable (minimumBy)+import Data.Ord (comparing)++import Data.ByteString.Streaming (ByteString)+import qualified Data.ByteString.Streaming as Q+import Streaming (Of (..), Stream)+import qualified Streaming as S++--------------------------------------------------------------------------------+-- Main function++{-|+Given a stream of PNG chunks, decode the image data from it. The resulting bytes+can be directly interpreted as pixels, whose format depends on the image's+colour type.+-}+decodeImageData+ :: (MonadThrow m, MonadIO m)+ => HeaderData+ -> Stream (PNGChunk m) m r+ -> ByteString m r+decodeImageData hd@HeaderData{..} =+ let prevByteDistance =+ case getBitsPerPixel hdBitDepth hdColourType of+ Just bpp -> (fromIntegral bpp + 4) `div` 8+ Nothing -> 1+ in Q.fromChunks+ . reconstructScanlines prevByteDistance+ . splitImageDataByScanlines hd+ . getDecompressedImageData++--------------------------------------------------------------------------------+-- Internals++{- |++Given a chunk type and a mapping function from a streaming ByteString to some+other functor, returns a filtering function suitable for passing to+'filterMapped' which accepts only the specified chunk type and applies the given+function to the bytes of the chunks of that type.++-}+mapChunkOfType+ :: (Monad m, Functor f)+ => ChunkType+ -> (ByteString m r -> m (f r))+ -> PNGChunk m r+ -> m (Sum Identity f r)+mapChunkOfType desiredType f PNGChunk{..}+ | chunkType == desiredType = InR <$> f chunkData+ | otherwise = InL . Identity <$> Q.effects chunkData++-- | From a raw stream of PNG chunks, filter out the IDAT chunks and decompress+-- them.+getDecompressedImageData+ :: (MonadIO m, MonadThrow m)+ => Stream (PNGChunk m) m r+ -> ByteString m r+getDecompressedImageData+ = decompressStream+ . Q.concat+ . filterMapped (mapChunkOfType ctIDAT return)++-- | Returns the number of bytes per scanline in a PNG with the given header, so+-- long as the colour type and bit depth fields are compatible with each other.+getScanlineLengthBytes :: HeaderData -> Maybe Int64+getScanlineLengthBytes HeaderData{..}+ = (1 +) -- Each scanline is preceded by a filter type byte+ . ceiling+ . (/ (8.0 :: Float))+ . fromIntegral+ . (* (fromIntegral hdWidth :: Word64))+ . fromIntegral+ <$> getBitsPerPixel hdBitDepth hdColourType++-- | Split a stream of raw, decompressed, PNG image data into scanlines.+splitImageDataByScanlines+ :: (MonadThrow m)+ => HeaderData+ -> ByteString m r+ -> Stream (ByteString m) m r+splitImageDataByScanlines hd@HeaderData{..} input = S.effect $+ do scanlineLength <-+ maybe (throwM UnsupportedColourType) return (getScanlineLengthBytes hd)++ return (chunksOfBS scanlineLength input)++type UnfilteredScanline = B.ByteString+type FilteredScanline = B.ByteString++-- | Given a stream of filtered scanlines, reconstruct each of them.+reconstructScanlines+ :: (MonadThrow m)+ => Int+ -> Stream (ByteString m) m r+ -> Stream (Of UnfilteredScanline) m r+reconstructScanlines prevByteDistance+ = mapWithMemory (reconstructScanline prevByteDistance)+ . S.mapped Q.toStrict++{- |++Given a filtered scanline (whose first byte encodes the filter method), along+with the previous unfiltered scanline (which is 'Nothing' if we're at the first+scanline), reconstruct the pixel data. Fails at runtime, possible even with a+segfault, if either input scanline is the wrong size.++This is a giant ugly mess, but it's fast. Can it be refactored into something+nicer while retaining its speed?++Also, it still takes up roughly 50% of the running time of decoding a PNG. Maybe+it can be made even faster?+-}+reconstructScanline+ :: (MonadThrow m)+ => Int+ -> Maybe UnfilteredScanline+ -> FilteredScanline+ -> m UnfilteredScanline+reconstructScanline prevByteDistance mprev filteredLine+ | Just (filterType, this) <- B.uncons filteredLine =+ let lenThis = B.length this++ -- This function is equivalent to @forM_ [0 .. lenThis - 1]@, but+ -- slightly faster in my benchmarks+ loop :: Monad m => (Int -> m ()) -> m ()+ loop action = go 0+ where+ go n | n < lenThis = do action n; go (n + 1)+ | otherwise = return ()+ {-# INLINE loop #-}++ noFilter = this++ subFilter = vectorToBytestring $ Vec.create $+ do v <- Vec.new lenThis+ loop $ \i ->+ do a <- if i >= prevByteDistance+ then Vec.read v (i - prevByteDistance)+ else return 0+ Vec.write v i (B.unsafeIndex this i + a)+ return v++ upFilter =+ case mprev of+ Just prev ->+ vectorToBytestring $ Vec.generate lenThis $ \i ->+ B.unsafeIndex prev i + B.unsafeIndex this i+ Nothing -> this++ averageFilter = vectorToBytestring $ Vec.create $+ case mprev of+ Just prev ->+ do v <- Vec.new lenThis+ loop $ \i ->+ do a <- if i >= prevByteDistance+ then Vec.read v (i - prevByteDistance)+ else return 0+ Vec.write v i (reconAverage a (B.unsafeIndex prev i) (B.unsafeIndex this i))+ return v+ Nothing ->+ do v <- Vec.new lenThis+ loop $ \i ->+ do a <- if i >= prevByteDistance+ then Vec.read v (i - prevByteDistance)+ else return 0+ Vec.write v i (reconAverage a 0 (B.unsafeIndex this i))+ return v++ paethFilter = vectorToBytestring $ Vec.create $+ case mprev of+ Just prev ->+ do v <- Vec.new lenThis+ loop $ \i ->+ do (a, c) <- if i >= prevByteDistance+ then do a <- Vec.read v (i - prevByteDistance)+ return (a, B.unsafeIndex prev (i - prevByteDistance))+ else return (0, 0)+ Vec.write v i (reconPaeth a (B.unsafeIndex prev i) c (B.unsafeIndex this i))+ return v+ Nothing ->+ do v <- Vec.new lenThis+ loop $ \i ->+ do a <- if i >= prevByteDistance+ then Vec.read v (i - prevByteDistance)+ else return 0+ Vec.write v i (reconPaeth a 0 0 (B.unsafeIndex this i))+ return v++ res | filterType == 0 = noFilter+ | filterType == 1 = subFilter+ | filterType == 2 = upFilter+ | filterType == 3 = averageFilter+ | filterType == 4 = paethFilter+ | otherwise = mempty++ in if B.length res == lenThis+ then return res+ else throwM (UnsupportedFilterType filterType)++ | otherwise = error "reconstructScanline: empty input"++filterScanlineFixed+ :: Int+ -> Maybe FilteredScanline+ -> UnfilteredScanline+ -> FilterType+ -> FilteredScanline+filterScanlineFixed prevByteDistance mprev this filterType =+ let lenThis = B.length this++ -- This function is equivalent to @forM_ [0 .. lenThis - 1]@, but+ -- slightly faster in my benchmarks+ loop :: Monad m => (Int -> m ()) -> m ()+ loop action = go 0+ where+ go n | n < lenThis = do action n; go (n + 1)+ | otherwise = return ()+ {-# INLINE loop #-}++ noFilter = this++ subFilter = vectorToBytestring $ Vec.create $+ do v <- Vec.new lenThis+ loop $ \i ->+ do a <- if i >= prevByteDistance+ then Vec.read v (i - prevByteDistance)+ else return 0+ Vec.write v i (B.unsafeIndex this i - a)+ return v++ upFilter =+ case mprev of+ Just prev ->+ vectorToBytestring $ Vec.generate lenThis $ \i ->+ B.unsafeIndex this i - B.unsafeIndex prev i+ Nothing -> this++ averageFilter = vectorToBytestring $ Vec.create $+ case mprev of+ Just prev ->+ do v <- Vec.new lenThis+ loop $ \i ->+ do a <- if i >= prevByteDistance+ then Vec.read v (i - prevByteDistance)+ else return 0+ Vec.write v i (filterAverage a (B.unsafeIndex prev i) (B.unsafeIndex this i))+ return v+ Nothing ->+ do v <- Vec.new lenThis+ loop $ \i ->+ do a <- if i >= prevByteDistance+ then Vec.read v (i - prevByteDistance)+ else return 0+ Vec.write v i (filterAverage a 0 (B.unsafeIndex this i))+ return v++ paethFilter = vectorToBytestring $ Vec.create $+ case mprev of+ Just prev ->+ do v <- Vec.new lenThis+ loop $ \i ->+ do (a, c) <- if i >= prevByteDistance+ then do a <- Vec.read v (i - prevByteDistance)+ return (a, B.unsafeIndex prev (i - prevByteDistance))+ else return (0, 0)+ Vec.write v i (filterPaeth a (B.unsafeIndex prev i) c (B.unsafeIndex this i))+ return v+ Nothing ->+ do v <- Vec.new lenThis+ loop $ \i ->+ do a <- if i >= prevByteDistance+ then Vec.read v (i - prevByteDistance)+ else return 0+ Vec.write v i (filterPaeth a 0 0 (B.unsafeIndex this i))+ return v++ res | filterType == 0 = noFilter+ | filterType == 1 = subFilter+ | filterType == 2 = upFilter+ | filterType == 3 = averageFilter+ | filterType == 4 = paethFilter+ | otherwise = error "filterScanlineFixed: bad filter type"++ in res++-- | Calculate the absolute value of the signed sum of the input bytes.+absSumBytes :: B.ByteString -> Int64+absSumBytes = abs . B.foldl' addSigned 0+ where addSigned a b = a + fromIntegral b - 128++data FilterHeuristic+ = FixedFilter FilterType+ | MinAbsSum++filterScanline+ :: FilterHeuristic+ -> Int+ -> Maybe FilteredScanline+ -> UnfilteredScanline+ -> FilteredScanline+filterScanline (FixedFilter filterType) pbd mprev this = filterScanlineFixed pbd mprev this filterType+filterScanline MinAbsSum pbd mprev this =+ let differentMethods = map (filterScanlineFixed pbd mprev this) [0..4]+ in minimumBy (comparing absSumBytes) differentMethods
+ src/Codec/Picture/Png/Streaming/Util.hs view
@@ -0,0 +1,141 @@+{-|+Module : Codec.Picture.Png.Streaming.Util+Copyright : (c) Bradley Hardy 2016+License: LGPL3+Maintainer: bradleyhardy@live.com+Stability: experimental+Portability: non-portable++This is a set of assorted utility functions for @streaming@ and+@streaming-bytestring@ which are used in various places in this library, but may+also be of use to others so they are exposed here.++-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Codec.Picture.Png.Streaming.Util where++import Control.Monad.Catch (Exception, MonadThrow (..))+import Control.Monad.Morph (generalize)+import Control.Monad.Trans (MonadTrans (..))+import qualified Data.ByteString.Internal as BI+import Data.Functor.Identity (Identity (..))+import Data.Functor.Sum (Sum (..))+import Data.Int (Int64)+import Data.Vector.Storable (Vector)+import qualified Data.Vector.Storable as Vec+import Data.Word (Word8)++import Data.ByteString.Streaming (ByteString)+import qualified Data.ByteString.Streaming as Q+import Streaming (Stream)+import qualified Streaming as S+import Streaming.Prelude (Of (..))+import qualified Streaming.Prelude as S++-- | If the input 'ByteString' is empty, return its result. Otherwise throw the+-- provided error value.+expectNull :: (MonadThrow m, Exception e) => e -> ByteString m r -> m r+expectNull err input =+ do headChunk <- Q.nextChunk input+ case headChunk of+ Left res -> return res+ Right _ -> throwM err++-- | Split a streaming ByteString up into a stream of chunks of the given size.+chunksOfBS :: (Monad m) => Int64 -> ByteString m r -> Stream (ByteString m) m r+chunksOfBS n input =+ do isEmpty <- lift (Q.null_ input)+ if isEmpty+ then lift (Q.effects input)+ else do rest <- S.yields (Q.splitAt n input)+ chunksOfBS n rest++-- | Remember the previous value at each point in a stream of values.+rememberPrevious :: (Monad m) => Stream (Of a) m r -> Stream (Of (Maybe a, a)) m r+rememberPrevious = go Nothing+ where+ go prevItem input =+ let continue (thisItem, rest) =+ do S.yields ((prevItem, thisItem) :> ())+ go (Just thisItem) rest+ in lift (S.next input) >>= either return continue++-- | Map a function across a stream, but also include in its arguments the+-- result of applying it to the previous item in the stream (which is 'Nothing'+-- if the current item is the first in the stream).+mapWithMemory :: forall m a b r. (Monad m) => (Maybe b -> a -> m b) -> Stream (Of a) m r -> Stream (Of b) m r+mapWithMemory f input = S.unfoldr step (Nothing, input)+ where+ step :: (Maybe b, Stream (Of a) m r) -> m (Either r (b, (Maybe b, Stream (Of a) m r)))+ step (prevResult, stream) =+ let handleItem (thisItem, remainder) =+ do thisResult <- f prevResult thisItem+ return (Right (thisResult, (Just thisResult, remainder)))+ in S.next stream >>= either (return . Left) handleItem++{-|++For each functor wrapper @f@ in the stream, either strip it off or convert it to+some new functor @g@. Return the stream of @g@'s. This can be seen to be+analogous to a list function of type @'Monad' m => (a -> m ('Maybe' b)) -> [a]+-> m [b]@ if we consider what it looks like when @f@ and @g@ are @'Of' a@ and+@'Of' b@ respectively:++> filterMapped+> :: (forall x. Of a x -> m (Sum Identity (Of b) x))+> -> Stream (Of a) m r -> Stream (Of b) m r++Here, @'Sum' 'Identity' ('Of' b) x@ is isomorphic to @'Of' ('Maybe' b) x@.++-}++filterMapped+ :: (Monad m, Functor f, Functor g)+ => (forall x. f x -> m (Sum Identity g x))+ -> Stream f m r+ -> Stream g m r+filterMapped f = S.run . S.maps generalize . S.separate . S.mapped f++{-|++For each functor wrapper in the stream, optionally strip it off. Those stripped+off will be removed from the resulting stream.++-}++filtered+ :: (Monad m, Functor f)+ => (forall x. f x -> m (Maybe x))+ -> Stream f m r+ -> Stream f m r+filtered f =+ let f' x = maybe (InR x) (InL . Identity) <$> f x+ in filterMapped f'+++-- | Build a 'ByteString' monadically from a seed.+buildByteString+ :: Monad m+ => (a -> m (Either r (ByteString m (), a)))+ -> a+ -> ByteString m r+buildByteString build seed =+ do mx <- lift $ build seed+ case mx of+ Left r -> return r+ Right (bs, seed') ->+ do bs+ buildByteString build seed'++-- | Directly convert a 'BI.ByteString' into a storable 'Vector', in constant+-- time.+bytestringToVector :: BI.ByteString -> Vector Word8+bytestringToVector (BI.PS fptr offset idx) = Vec.unsafeFromForeignPtr fptr offset idx++-- | Directly convert a storable 'Vector' of 'Word8's into a 'BI.ByteString', in+-- constant time.+vectorToBytestring :: Vector Word8 -> BI.ByteString+vectorToBytestring v+ | (fptr, offset, idx) <- Vec.unsafeToForeignPtr v =+ BI.PS fptr offset idx
+ src/Streaming/CRC.hs view
@@ -0,0 +1,56 @@+{-|+Module : Streaming.CRC+Copyright : (c) Bradley Hardy 2016+License: LGPL3+Maintainer: bradleyhardy@live.com+Stability: experimental+Portability: non-portable++-}+module Streaming.CRC (calcCRC32, appendCRC32) where++import Data.Bits+import Data.Vector.Unboxed (Vector)+import qualified Data.Vector.Unboxed as U+import Data.Word (Word32, Word8)+import qualified Data.Serialize as C++import qualified Data.ByteString as B+import Data.ByteString.Streaming (ByteString)+import qualified Data.ByteString.Streaming as Q+import Streaming.Prelude (Of (..))++crc32Table :: Vector Word32+crc32Table = U.generate 256 (calc . fromIntegral)+ where+ calc :: Word8 -> Word32+ calc = go 8 . fromIntegral+ where+ go :: Int -> Word32 -> Word32+ go 0 c = c+ go k c =+ if c .&. 1 > 0+ then go (k - 1) (0xedb88320 `xor` shiftR c 1)+ else go (k - 1) (shift c (-1))++updateCRC32 :: Word32 -> B.ByteString -> Word32+updateCRC32 crc bytes+ | Just (h, tl) <- B.uncons bytes =+ let index = fromIntegral ((crc `xor` fromIntegral h) .&. 0xff)+ in updateCRC32 ((crc32Table U.! index) `xor` shiftR crc 8) tl+ | otherwise = crc++-- | Calculate the CRC of a streaming 'ByteString', consuming the input and+-- returning the CRC paired with the 'ByteString''s return value.+calcCRC32 :: Monad m => ByteString m r -> m (Of Word32 r)+calcCRC32 input =+ do (res :> x) <- Q.foldlChunks updateCRC32 0xffffffff input+ return (res `xor` 0xffffffff :> x)++-- | If the input stream is finite, calculate its CRC and append it to the end+-- (maintaining streaming). The is the identity function for infinite inputs.+appendCRC32 :: Monad m => ByteString m r -> ByteString m r+appendCRC32 input =+ do (crc :> res) <- calcCRC32 $ Q.copy input+ Q.fromStrict (C.runPut . C.putWord32be $ crc)+ return res
+ src/Streaming/Zlib.hs view
@@ -0,0 +1,119 @@+{-|+Module : Streaming.Zlib+Copyright : (c) Bradley Hardy 2016+License: LGPL3+Maintainer: bradleyhardy@live.com+Stability: experimental+Portability: non-portable++-}+{-# LANGUAGE OverloadedStrings #-}+module Streaming.Zlib+ (+ -- * Decompressing and compressing streams+ decompressStream+ , decompressStream'+ , compressStream+ , compressStream'++ -- * Re-exported from 'Data.Streaming.Zlib'+ , CompressionLevel+ , WindowBits+ , defaultWindowBits+ , defaultCompressionLevel)+ where++import Codec.Picture.Png.Streaming.Util++import Data.Streaming.Zlib (Popper, PopperRes (PRDone, PRNext, PRError),+ WindowBits,+ defaultWindowBits)+import qualified Data.Streaming.Zlib as Z++import Control.Monad.Catch (MonadThrow (..))+import Control.Monad.IO.Class (MonadIO (..))++import Data.ByteString.Streaming (ByteString)+import qualified Data.ByteString.Streaming as Q++exhaustPopper+ :: (MonadIO m, MonadThrow m)+ => Popper+ -> ByteString m ()+exhaustPopper popper = go+ where+ go = do pres <- liftIO popper+ case pres of+ PRDone -> return ()+ PRNext bs -> do Q.chunk bs; go+ PRError e -> throwM e++-- | Use Zlib to decompress a 'ByteString' with the specified 'WindowBits'.+decompressStream'+ :: (MonadIO m, MonadThrow m)+ => WindowBits+ -> ByteString m r+ -> ByteString m r+decompressStream' windowBits input =+ do inflate <- liftIO $ Z.initInflate windowBits++ let build bs =+ do mchnk <- Q.nextChunk bs+ case mchnk of+ Left r -> return (Left r)+ Right (chnk, bs') ->+ do popper <- liftIO $ Z.feedInflate inflate chnk+ return (Right (exhaustPopper popper, bs'))++ res <- buildByteString build input++ remaining <- liftIO $ Z.finishInflate inflate+ Q.chunk remaining++ return res++-- | Use Zlib to decompress a 'ByteString' with the default parameters.+decompressStream+ :: (MonadIO m, MonadThrow m)+ => ByteString m r+ -> ByteString m r+decompressStream = decompressStream' defaultWindowBits++-- | An integer between 0 and 9.+type CompressionLevel = Int++-- | The default compression level is 6.+defaultCompressionLevel :: CompressionLevel+defaultCompressionLevel = 6++-- | Use Zlib to compress a 'ByteString' with the specified 'CompressionLevel'+-- and 'WindowBits'.+compressStream'+ :: (MonadIO m, MonadThrow m)+ => CompressionLevel+ -> WindowBits+ -> ByteString m r+ -> ByteString m r+compressStream' compressLevel windowBits input =+ do deflate <- liftIO $ Z.initDeflate compressLevel windowBits++ let build bs =+ do mchnk <- Q.nextChunk bs+ case mchnk of+ Left r -> return (Left r)+ Right (chnk, bs') ->+ do popper <- liftIO $ Z.feedDeflate deflate chnk+ return (Right (exhaustPopper popper, bs'))++ res <- buildByteString build input++ exhaustPopper $ Z.finishDeflate deflate++ return res++-- | Use Zlib to compress a 'ByteString' with the default parameters.+compressStream+ :: (MonadIO m, MonadThrow m)+ => ByteString m r+ -> ByteString m r+compressStream = compressStream' defaultCompressionLevel defaultWindowBits
+ streaming-png.cabal view
@@ -0,0 +1,72 @@+name: streaming-png+version: 0.1.0.0+synopsis: Perfectly streaming PNG image decoding+description: Please see README.md+homepage: http://github.com/bch29/streaming-png#readme+license: BSD3+license-file: LICENSE+author: Bradley Hardy+maintainer: bradleyhardy@live.com+copyright: (C) Bradley Hardy 2015+category: Codec, Graphics, Image, Streaming+build-type: Simple+cabal-version: >=1.10++flag build-demo+ description: Build the executable demo.+ default: False++executable streaming-png-demo+ hs-source-dirs: demo+ main-is: Main.hs+ default-language: Haskell2010+ if flag(build-demo)+ build-depends: JuicyPixels+ , base >= 4.7 && < 5+ , criterion >= 1.1.0.0+ , resourcet+ , streaming+ , streaming-bytestring+ , streaming-png+ , transformers+ , bytestring+ else+ buildable: False++library+ hs-source-dirs: src++ exposed-modules: Codec.Picture.Png.Streaming+ , Codec.Picture.Png.Streaming.Util+ , Codec.Picture.Png.Streaming.Juicy+ , Streaming.CRC+ , Streaming.Zlib++ other-modules: Codec.Picture.Png.Streaming.Core+ , Codec.Picture.Png.Streaming.Header+ , Codec.Picture.Png.Streaming.MainData+ , Codec.Picture.Png.Streaming.Info++ default-language: Haskell2010++ build-depends: JuicyPixels >= 3.2+ , base >= 4.7 && < 5+ , bytestring >= 0.10+ , cereal >= 0.5+ , exceptions >= 0.8.2+ , mmorph >= 1.0+ , mtl >= 2.2+ , resourcet >= 1.1+ , streaming >= 0.1.4+ , streaming-bytestring >= 0.1.4+ , streaming-commons >= 0.1.14+ , transformers >= 0.4.2+ , vector >= 0.11++ ghc-options:+ -- -Wall+ -O2++source-repository head+ type: git+ location: http://github.com/bch29/streaming-png