diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `png-chunk-yaftee` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright 2025 Yoshikuni Jujo + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# png-chunk-yaftee + +PNG's chunk codec on Yaftee diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/png-chunk-yaftee.cabal b/png-chunk-yaftee.cabal new file mode 100644 --- /dev/null +++ b/png-chunk-yaftee.cabal @@ -0,0 +1,80 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.38.1. +-- +-- see: https://github.com/sol/hpack + +name: png-chunk-yaftee +version: 0.1.0.0 +synopsis: PNG's chunk codec on Yaftee +description: Please see the README on GitHub at +category: Codec,Graphics,Image +homepage: https://github.com/YoshikuniJujo/png-chunk-yaftee#readme +bug-reports: https://github.com/YoshikuniJujo/png-chunk-yaftee/issues +author: Yoshikuni Jujo +maintainer: yoshikuni.jujo@gmail.com +copyright: (c) 2025 Yoshikuni Jujo +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md +extra-doc-files: + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/YoshikuniJujo/png-chunk-yaftee + +library + exposed-modules: + Control.Monad.Yaftee.Pipe.Png.Chunk + other-modules: + Paths_png_chunk_yaftee + autogen-modules: + Paths_png_chunk_yaftee + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.7 && <5 + , bitarray-bs ==0.1.* + , bytestring-ft ==0.1.* + , higher-order-open-union ==0.1.* + , mono-traversable ==1.0.* + , tools-yj ==0.1.* + , typelevel-tools-yj ==0.1.* + , yaftee ==0.1.* + , yaftee-basic-monads ==0.1.* + , yaftee-conduit ==0.1.* + , yaftee-conduit-bytestring ==0.1.* + , yaftee-conduit-bytestring-ft ==0.1.* + , yaftee-conduit-mono-traversable ==0.1.* + default-language: Haskell2010 + +test-suite png-chunk-yaftee-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_png_chunk_yaftee + autogen-modules: + Paths_png_chunk_yaftee + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , bitarray-bs ==0.1.* + , bytestring-ft ==0.1.* + , higher-order-open-union ==0.1.* + , mono-traversable ==1.0.* + , png-chunk-yaftee + , tools-yj ==0.1.* + , typelevel-tools-yj ==0.1.* + , yaftee ==0.1.* + , yaftee-basic-monads ==0.1.* + , yaftee-conduit ==0.1.* + , yaftee-conduit-bytestring ==0.1.* + , yaftee-conduit-bytestring-ft ==0.1.* + , yaftee-conduit-mono-traversable ==0.1.* + default-language: Haskell2010 diff --git a/src/Control/Monad/Yaftee/Pipe/Png/Chunk.hs b/src/Control/Monad/Yaftee/Pipe/Png/Chunk.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Yaftee/Pipe/Png/Chunk.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments, LambdaCase, OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE RequiredTypeArguments #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Control.Monad.Yaftee.Pipe.Png.Chunk ( + + -- * DATA TYPE + + C(..), + + -- * DECODE + + decode, hDecode, decodeRun_, DecodeStates, + + -- * ENCODE + + encode, hEncode, encodeRun_, EncodeStates + + ) where + +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Yaftee.Eff qualified as Eff +import Control.Monad.Yaftee.Pipe qualified as Pipe +import Control.Monad.Yaftee.Pipe.Tools qualified as PipeT +import Control.Monad.Yaftee.Pipe.ByteString qualified as PipeBS +import Control.Monad.Yaftee.Pipe.ByteString.FingerTree.OnDemand + qualified as OnDemand +import Control.Monad.Yaftee.Pipe.MonoTraversable.Crc32 + qualified as PipeCrc32 +import Control.Monad.Yaftee.State qualified as State +import Control.Monad.Yaftee.Except qualified as Except +import Control.Monad.Yaftee.Fail qualified as Fail +import Control.Monad.Yaftee.IO qualified as IO +import Control.HigherOpenUnion qualified as U +import Data.Foldable +import Data.MonoTraversable +import Data.Word +import Data.Word.Word8 qualified as Word8 +import Data.Word.Crc32 qualified as Crc32 +import Data.ByteString.FingerTree qualified as BSF +import Data.ByteString.FingerTree.Bits qualified as BSF +import System.IO + +import Data.HigherFunctor qualified as F +import Data.TypeLevel.List + +import Numeric + + +decode :: forall nm -> ( + U.Member Pipe.P es, OnDemand.Members nm es, + U.Member (State.Named nm Crc32.C) es, U.Member (Except.E String) es ) => + Int -> Eff.E es BSF.ByteString C () +decode nm n = void $ OnDemand.onDemand nm Pipe.=$= PipeCrc32.crc32 nm Pipe.=$= do + State.putN nm $ OnDemand.RequestBytes 8 + fh <- Pipe.await + when (fh /= fileHeader) . Except.throw @String + $ "Not PNG file: " ++ show fh + chunks nm n + +hDecode :: forall nm -> ( + U.Member Pipe.P es, OnDemand.Members nm es, + U.Member (State.Named nm Crc32.C) es, U.Member (Except.E String) es, + U.Base IO.I es ) => + Handle -> Int -> Int -> Eff.E es BSF.ByteString C () +hDecode nm h n n' = void $ + PipeBS.hGet n h Pipe.=$= + PipeT.convert BSF.fromStrict Pipe.=$= + decode nm n' + +chunks :: forall nm -> ( + U.Member Pipe.P es, OnDemand.Members nm es, + U.Member (State.Named nm Crc32.C) es, U.Member (Except.E String) es ) => + Int -> Eff.E es BSF.ByteString C () +chunks nm d = fix \go -> do + b <- chunk1 nm d + if b then go else Pipe.yield EndOfTheWorld + +chunk1 :: forall nm -> ( + U.Member Pipe.P es, OnDemand.Members nm es, + U.Member (State.Named nm Crc32.C) es, U.Member (Except.E String) es ) => + Int -> Eff.E es BSF.ByteString C Bool +chunk1 nm d = do + State.putN nm $ OnDemand.RequestBytes 4 + n <- Word8.toBitsBE @_ @Int <$> Pipe.await + PipeCrc32.reset nm + State.putN nm $ OnDemand.RequestBytes 4 + cn <- Pipe.await +-- trace ("chunk1: yield Begin: " ++ show cn) (Pipe.yield $ Begin n cn) + Pipe.yield $ Begin n cn + for_ (split d n) \n' -> do + State.putN nm $ OnDemand.RequestBytes n' + Pipe.yield . Body =<< Pipe.await + PipeCrc32.complement nm + c1 <- State.getN @Crc32.C nm + State.putN nm $ OnDemand.RequestBytes 4 + c0 <- Crc32.fromWord . Word8.toBitsBE @_ @Word32 <$> Pipe.await + when (c1 /= c0) $ Except.throw @String + $ "corrupted -- crc32 mismatch: " ++ + showHex (Crc32.toWord c0) "" ++ " " ++ showHex (Crc32.toWord c1) "" +-- trace ("chunk1: yield End: " ++ show cn) $ Pipe.yield End + Pipe.yield End + pure $ cn /= "IEND" + where + split n = fix \go -> \case + 0 -> [] + m | n < m -> n : go (m - n) | otherwise -> [m] + +decodeRun_ :: + F.Loose (U.U es) => + Eff.E (DecodeStates nm `Append` es) i o r -> Eff.E es i o () +decodeRun_ = void . (`State.runN` Crc32.initial) + +type DecodeStates nm = '[State.Named nm Crc32.C] + +data C = Begin Int BSF.ByteString + | Body BSF.ByteString | End + | EndOfTheWorld + deriving Show + +fileHeader :: BSF.ByteString +fileHeader = "\137PNG\r\n\SUB\n" + +type instance Element C = Word8 + +instance MonoFoldable C where + ofoldMap f = \case + Begin _ bs -> ofoldMap f bs + Body bs -> ofoldMap f bs; _ -> mempty + ofoldr o v = \case + Begin _ bs -> ofoldr o v bs + Body bs -> ofoldr o v bs; _ -> v + ofoldl' o v = \case + Begin _ bs -> ofoldl' o v bs + Body bs -> ofoldl' o v bs; _ -> v + ofoldr1Ex o = \case + Begin _ bs -> ofoldr1Ex o bs + Body bs -> ofoldr1Ex o bs; _ -> error "instance MonoFoldable C: bad" + ofoldl1Ex' o = \case + Begin _ bs -> ofoldl1Ex' o bs + Body bs -> ofoldl1Ex' o bs; _ -> error "instance MonoFoldable C: bad" + +encode :: forall nm -> ( + U.Member Pipe.P es, U.Member (State.Named nm Crc32.C) es, + U.Member (Except.E String) es, U.Member Fail.F es ) => + Eff.E es C BSF.ByteString () +encode nm = void $ + PipeCrc32.crc32 nm + Pipe.=$= do + Pipe.yield fileHeader + fix \go -> (`when` go) =<< encodeChunk1 nm + +hEncode :: forall nm -> ( + U.Member Pipe.P es, U.Member (State.Named nm Crc32.C) es, + U.Member (Except.E String) es, U.Member Fail.F es, U.Base IO.I es ) => + Handle -> Eff.E es C o () +hEncode nm ho = void $ encode nm + Pipe.=$= PipeT.convert BSF.toStrict + Pipe.=$= PipeBS.hPutStr ho + +encodeChunk1 :: forall nm -> ( + U.Member Pipe.P es, U.Member (State.Named nm Crc32.C) es, + U.Member (Except.E String) es, U.Member Fail.F es ) => + Eff.E es C BSF.ByteString Bool +encodeChunk1 nm = do + PipeCrc32.reset nm + Begin n cn <- Pipe.await + Pipe.yield . BSF.fromBitsBE' @Word32 $ fromIntegral n + Pipe.yield cn + fix \go -> Pipe.await >>= \case + Body bd -> Pipe.yield bd >> go + End -> pure () + _ -> Except.throw @String "encodeChunk1: bad" + PipeCrc32.complement nm + c <- State.getN @Crc32.C nm + Pipe.yield . BSF.fromBitsBE' $ Crc32.toWord c + pure $ cn /= "IEND" + +encodeRun_ :: forall nm es i o r . + F.Loose (U.U es) => + Eff.E (EncodeStates nm `Append` es) i o r -> + Eff.E es i o () +encodeRun_ = void . OnDemand.run @nm . PipeCrc32.run @nm + +type EncodeStates nm = State.Named nm Crc32.C ': OnDemand.States nm diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"