├── .github └── workflows │ └── tests.yml ├── .gitignore ├── .project-settings.yml ├── EXAMPLES.md ├── PROCESS.md ├── README.md ├── cereal-conduit ├── ChangeLog.md ├── Data │ └── Conduit │ │ ├── Cereal.hs │ │ └── Cereal │ │ └── Internal.hs ├── LICENSE ├── README.md ├── Setup.lhs ├── Test │ └── Main.hs └── cereal-conduit.cabal ├── conduit-extra ├── ChangeLog.md ├── Data │ └── Conduit │ │ ├── Attoparsec.hs │ │ ├── Binary.hs │ │ ├── ByteString │ │ └── Builder.hs │ │ ├── Filesystem.hs │ │ ├── Foldl.hs │ │ ├── Lazy.hs │ │ ├── Network.hs │ │ ├── Network │ │ ├── UDP.hs │ │ └── Unix.hs │ │ ├── Process.hs │ │ ├── Process │ │ └── Typed.hs │ │ ├── Text.hs │ │ └── Zlib.hs ├── LICENSE ├── README.md ├── Setup.lhs ├── attic │ ├── echo-server.hs │ ├── fibclient.hs │ └── udpflow.hs ├── bench │ └── blaze.hs ├── conduit-extra.cabal └── test │ ├── Data │ └── Conduit │ │ ├── AttoparsecSpec.hs │ │ ├── BinarySpec.hs │ │ ├── ByteString │ │ └── BuilderSpec.hs │ │ ├── ExtraSpec.hs │ │ ├── FilesystemSpec.hs │ │ ├── LazySpec.hs │ │ ├── NetworkSpec.hs │ │ ├── Process │ │ └── TypedSpec.hs │ │ ├── ProcessSpec.hs │ │ ├── TextSpec.hs │ │ └── ZlibSpec.hs │ ├── Spec.hs │ ├── filesystem │ ├── bar.txt │ ├── baz.txt │ ├── bin │ │ └── bin.txt │ └── foo.txt │ └── random ├── conduit ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.lhs ├── benchmarks │ ├── OldText.hs │ ├── bench-lift.hs │ ├── benchmark.hs │ ├── bind-bench.hs │ ├── fusion.hs │ ├── main.hs │ ├── maximum.hs │ ├── optimize-201408.hs │ ├── scanl-bench.hs │ ├── unfused.hs │ ├── utf8-bench.hs │ └── utf8-memory-usage.hs ├── conduit.cabal ├── fusion-macros.h ├── src │ ├── Conduit.hs │ ├── Data │ │ ├── Conduit.hs │ │ ├── Conduit │ │ │ ├── Combinators.hs │ │ │ ├── Combinators │ │ │ │ ├── Stream.hs │ │ │ │ └── Unqualified.hs │ │ │ ├── Internal.hs │ │ │ ├── Internal │ │ │ │ ├── Conduit.hs │ │ │ │ ├── Fusion.hs │ │ │ │ ├── List │ │ │ │ │ └── Stream.hs │ │ │ │ └── Pipe.hs │ │ │ ├── Lift.hs │ │ │ └── List.hs │ │ └── Streaming │ │ │ ├── FileRead.hs │ │ │ └── Filesystem.hs │ └── System │ │ └── Win32File.hsc └── test │ ├── Data │ └── Conduit │ │ ├── Extra │ │ └── ZipConduitSpec.hs │ │ └── StreamSpec.hs │ ├── Spec.hs │ ├── StreamSpec.hs │ ├── doctests.hs │ ├── main.hs │ └── subdir │ └── dummyfile.txt ├── network-conduit-tls ├── ChangeLog.md ├── Data │ └── Conduit │ │ └── Network │ │ ├── TLS.hs │ │ └── TLS │ │ └── Internal.hs ├── LICENSE ├── README.md ├── Setup.hs ├── network-conduit-tls.cabal └── test │ └── main.hs ├── resourcet ├── ChangeLog.md ├── Control │ └── Monad │ │ └── Trans │ │ ├── Resource.hs │ │ └── Resource │ │ └── Internal.hs ├── Data │ ├── Acquire.hs │ └── Acquire │ │ └── Internal.hs ├── LICENSE ├── README.md ├── Setup.lhs ├── UnliftIO │ └── Resource.hs ├── resourcet.cabal └── test │ └── main.hs ├── stack-9.10.yaml ├── stack-9.4.yaml ├── stack-9.6.yaml ├── stack-9.8.yaml ├── stack.yaml └── stack.yaml.lock /.github/workflows/tests.yml: -------------------------------------------------------------------------------- 1 | name: Tests 2 | 3 | on: 4 | pull_request: 5 | branches: 6 | - master 7 | push: 8 | branches: 9 | - master 10 | 11 | defaults: 12 | run: 13 | shell: bash 14 | 15 | jobs: 16 | build: 17 | name: CI 18 | runs-on: ${{ matrix.os }} 19 | strategy: 20 | fail-fast: false 21 | matrix: 22 | os: [ubuntu-latest] 23 | ghc: ['9.10', '9.8', '9.6', '9.4'] 24 | include: 25 | - os: macos-latest 26 | ghc: '9.10' 27 | - os: windows-latest 28 | ghc: '9.10' 29 | 30 | steps: 31 | - name: Clone project 32 | uses: actions/checkout@v4 33 | 34 | - name: Setup Haskell 35 | uses: haskell-actions/setup@v2 36 | with: 37 | ghc-version: ${{ matrix.ghc }} 38 | stack-version: latest 39 | enable-stack: true 40 | cabal-update: false 41 | 42 | - name: Build dependencies 43 | run: stack test --stack-yaml=stack-${{ matrix.ghc }}.yaml --dependencies-only 44 | 45 | - name: Build 46 | run: stack test --stack-yaml=stack-${{ matrix.ghc }}.yaml --no-run-tests 47 | 48 | - name: Test 49 | run: stack test --stack-yaml=stack-${{ matrix.ghc }}.yaml 50 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | dist/ 3 | dist-newstyle/ 4 | conduit/tmp 5 | conduit/tmp2 6 | conduit-extra/tmp 7 | conduit-extra/tmp2 8 | *.hi 9 | *.o 10 | tarballs/ 11 | .hsenv/ 12 | .stack-work/ 13 | *~ 14 | *# 15 | -------------------------------------------------------------------------------- /.project-settings.yml: -------------------------------------------------------------------------------- 1 | module-template: ! 'module MODULE_NAME where 2 | 3 | ' 4 | extensions: {} 5 | environment: ghc-7.4.2-unstable 6 | cabal-file: project.cabal 7 | version: 1 8 | extra-packages: '' 9 | ghc-args: [] 10 | excluded-modules: 11 | - conduit/benchmarks/OldText.hs 12 | - network-conduit-tls/Data/Conduit/Network/TLS.hs 13 | - network-conduit-tls/Data/Conduit/Network/TLS/Internal.hs 14 | -------------------------------------------------------------------------------- /EXAMPLES.md: -------------------------------------------------------------------------------- 1 | # Conduit examples 2 | 3 | This file is meant to collect self-contained examples of doing stuff with 4 | conduit. It is intended to be very open to contribution, so if you've got 5 | something to add, please send a PR! 6 | 7 | * [Ensure that a conduit produces output every X microseconds](https://gist.github.com/snoyberg/7e5dd52109b03c8bf1aa8fe1a7e522b9) 8 | -------------------------------------------------------------------------------- /cereal-conduit/ChangeLog.md: -------------------------------------------------------------------------------- 1 | ## 0.8.0 2 | 3 | * Upgrade to conduit 1.3.0 4 | 5 | ## 0.7.3 6 | 7 | * Provide `conduitGet2` 8 | 9 | ## 0.7.2.5 10 | 11 | * Support cereal 0.5 12 | 13 | ## 0.7 14 | 15 | * Upgrade to conduit 1.0.0 16 | -------------------------------------------------------------------------------- /cereal-conduit/Data/Conduit/Cereal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE NoMonomorphismRestriction #-} 4 | {-# LANGUAGE Rank2Types #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | 7 | -- | Turn a 'Get' into a 'Sink' and a 'Put' into a 'Source' 8 | -- These functions are built upno the Data.Conduit.Cereal.Internal functions with default 9 | -- implementations of 'ErrorHandler' and 'TerminationHandler' 10 | -- 11 | -- The default 'ErrorHandler' and 'TerminationHandler' both throw a 'GetException'. 12 | 13 | module Data.Conduit.Cereal ( GetException 14 | , sinkGet 15 | , conduitGet 16 | , conduitGet2 17 | , sourcePut 18 | , conduitPut 19 | ) where 20 | 21 | import Control.Exception.Base 22 | import Control.Monad.Trans.Resource (MonadThrow, throwM) 23 | import qualified Data.ByteString as BS 24 | import qualified Data.ByteString.Lazy as LBS 25 | import Data.Conduit (ConduitT, leftover, await, yield) 26 | import qualified Data.Conduit.List as CL 27 | import Data.Serialize hiding (get, put) 28 | import Data.Typeable 29 | 30 | import Data.Conduit.Cereal.Internal 31 | 32 | data GetException = GetException String 33 | deriving (Show, Typeable) 34 | 35 | instance Exception GetException 36 | 37 | -- | Run a 'Get' repeatedly on the input stream, producing an output stream of whatever the 'Get' outputs. 38 | conduitGet :: MonadThrow m => Get o -> ConduitT BS.ByteString o m () 39 | conduitGet = mkConduitGet errorHandler 40 | where errorHandler msg = throwM $ GetException msg 41 | {-# DEPRECATED conduitGet "Please switch to conduitGet2, see comment on that function" #-} 42 | 43 | -- | Convert a 'Get' into a 'Sink'. The 'Get' will be streamed bytes until it returns 'Done' or 'Fail'. 44 | -- 45 | -- If 'Get' succeed it will return the data read and unconsumed part of the input stream. 46 | -- If the 'Get' fails due to deserialization error or early termination of the input stream it raise an error. 47 | sinkGet :: MonadThrow m => Get r -> ConduitT BS.ByteString o m r 48 | sinkGet = mkSinkGet errorHandler terminationHandler 49 | where errorHandler msg = throwM $ GetException msg 50 | terminationHandler f = case f BS.empty of 51 | Fail msg _ -> throwM $ GetException msg 52 | Done r lo -> leftover lo >> return r 53 | Partial _ -> throwM $ GetException "Failed reading: Internal error: unexpected Partial." 54 | 55 | -- | Convert a 'Put' into a 'Source'. Runs in constant memory. 56 | sourcePut :: Monad m => Put -> ConduitT i BS.ByteString m () 57 | sourcePut put = CL.sourceList $ LBS.toChunks $ runPutLazy put 58 | 59 | -- | Run a 'Putter' repeatedly on the input stream, producing a concatenated 'ByteString' stream. 60 | conduitPut :: Monad m => Putter a -> ConduitT a BS.ByteString m () 61 | conduitPut p = CL.map $ runPut . p 62 | 63 | -- | Reapply @Get o@ to a stream of bytes as long as more data is available, 64 | -- and yielding each new value downstream. This has a few differences from 65 | -- @conduitGet@: 66 | -- 67 | -- * If there is a parse failure, the bytes consumed so far by this will not be 68 | -- returned as leftovers. The reason for this is that the only way to guarantee 69 | -- the leftovers will be returned correctly is to hold onto all consumed 70 | -- @ByteString@s, which leads to non-constant memory usage. 71 | -- 72 | -- * This function will properly terminate a @Get@ function at end of stream, 73 | -- see https://github.com/snoyberg/conduit/issues/246. 74 | -- 75 | -- * @conduitGet@ will pass empty @ByteString@s from the stream directly to 76 | -- cereal, which will trigger cereal to think that the stream has been closed. 77 | -- This breaks the normal abstraction in conduit of ignoring how data is 78 | -- chunked. In @conduitGet2@, all empty @ByteString@s are filtered out and not 79 | -- passed to cereal. 80 | -- 81 | -- * After @conduitGet2@ successfully returns, we are guaranteed that there is 82 | -- no data left to be consumed in the stream. 83 | -- 84 | -- @since 0.7.3 85 | conduitGet2 :: MonadThrow m => Get o -> ConduitT BS.ByteString o m () 86 | conduitGet2 get = 87 | awaitNE >>= start 88 | where 89 | -- Get the next chunk of data, only returning an empty ByteString at the 90 | -- end of the stream. 91 | awaitNE = 92 | loop 93 | where 94 | loop = await >>= maybe (return BS.empty) check 95 | check bs 96 | | BS.null bs = loop 97 | | otherwise = return bs 98 | 99 | start bs 100 | | BS.null bs = return () 101 | | otherwise = result (runGetPartial get bs) 102 | 103 | result (Fail msg _) = throwM (GetException msg) 104 | -- This will feed an empty ByteString into f at end of stream, which is how 105 | -- we indicate to cereal that there is no data left. If we wanted to be 106 | -- more pedantic, we could ensure that cereal only ever consumes a single 107 | -- ByteString to avoid a loop, but that is the contract that cereal is 108 | -- giving us anyway. 109 | result (Partial f) = awaitNE >>= result . f 110 | result (Done x rest) = do 111 | yield x 112 | if BS.null rest 113 | then awaitNE >>= start 114 | else start rest 115 | -------------------------------------------------------------------------------- /cereal-conduit/Data/Conduit/Cereal/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | 4 | module Data.Conduit.Cereal.Internal 5 | ( ConduitErrorHandler 6 | , SinkErrorHandler 7 | , SinkTerminationHandler 8 | 9 | , mkConduitGet 10 | , mkSinkGet 11 | ) where 12 | 13 | import Control.Monad (forever, when) 14 | import qualified Data.ByteString as BS 15 | import Data.Conduit (ConduitT, await, leftover, yield) 16 | import Data.Serialize hiding (get, put) 17 | 18 | -- | What should we do if the Get fails? 19 | type ConduitErrorHandler m o = String -> ConduitT BS.ByteString o m () 20 | type SinkErrorHandler m r = forall o. String -> ConduitT BS.ByteString o m r 21 | 22 | -- | What should we do if the stream is done before the Get is done? 23 | type SinkTerminationHandler m r = forall o. (BS.ByteString -> Result r) -> ConduitT BS.ByteString o m r 24 | 25 | -- | Construct a conduitGet with the specified 'ErrorHandler' 26 | mkConduitGet :: Monad m 27 | => ConduitErrorHandler m o 28 | -> Get o 29 | -> ConduitT BS.ByteString o m () 30 | mkConduitGet errorHandler get = consume True (runGetPartial get) [] BS.empty 31 | where pull f b s 32 | | BS.null s = await >>= maybe (when (not $ null b) (leftover $ BS.concat $ reverse b)) (pull f b) 33 | | otherwise = consume False f b s 34 | consume initial f b s = case f s of 35 | Fail msg _ -> do 36 | when (not $ null b) (leftover $ BS.concat $ reverse consumed) 37 | errorHandler msg 38 | Partial p -> pull p consumed BS.empty 39 | Done a s' -> case initial of 40 | -- this only works because the Get will either _always_ consume no input, or _never_ consume no input. 41 | True -> forever $ yield a 42 | False -> yield a >> pull (runGetPartial get) [] s' 43 | -- False -> yield a >> leftover s' >> mkConduitGet errorHandler get 44 | where consumed = s : b 45 | 46 | -- | Construct a sinkGet with the specified 'ErrorHandler' and 'TerminationHandler' 47 | mkSinkGet :: Monad m 48 | => SinkErrorHandler m r 49 | -> SinkTerminationHandler m r 50 | -> Get r 51 | -> ConduitT BS.ByteString o m r 52 | mkSinkGet errorHandler terminationHandler get = consume (runGetPartial get) [] BS.empty 53 | where pull f b s 54 | | BS.null s = await >>= \ x -> case x of 55 | Nothing -> when (not $ null b) (leftover $ BS.concat $ reverse b) >> terminationHandler f 56 | Just a -> pull f b a 57 | | otherwise = consume f b s 58 | consume f b s = case f s of 59 | Fail msg _ -> do 60 | when (not $ null b) (leftover $ BS.concat $ reverse consumed) 61 | errorHandler msg 62 | Partial p -> pull p consumed BS.empty 63 | Done r s' -> when (not $ BS.null s') (leftover s') >> return r 64 | where consumed = s : b 65 | -------------------------------------------------------------------------------- /cereal-conduit/LICENSE: -------------------------------------------------------------------------------- 1 | The following license covers this documentation, and the source code, except 2 | where otherwise indicated. 3 | 4 | Copyright 2012, Myles C. Maxfield. All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR 17 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 18 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO 19 | EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, 20 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 21 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, 22 | OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 23 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 24 | OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF 25 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | -------------------------------------------------------------------------------- /cereal-conduit/README.md: -------------------------------------------------------------------------------- 1 | ## cereal-conduit 2 | 3 | Turn Data.Serialize Gets and Puts into Sources, Sinks, and Conduits. 4 | -------------------------------------------------------------------------------- /cereal-conduit/Setup.lhs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env runhaskell 2 | 3 | > import Distribution.Simple 4 | > main = defaultMain 5 | -------------------------------------------------------------------------------- /cereal-conduit/cereal-conduit.cabal: -------------------------------------------------------------------------------- 1 | name: cereal-conduit 2 | version: 0.8.0 3 | license: BSD3 4 | license-file: LICENSE 5 | author: Myles C. Maxfield 6 | maintainer: Michael Snoyman 7 | synopsis: Turn Data.Serialize Gets and Puts into Sources, Sinks, and Conduits 8 | description: 9 | Turn Data.Serialize Gets and Puts into Sources, Sinks, and Conduits. 10 | category: Conduit 11 | stability: Experimental 12 | cabal-version: >= 1.8 13 | build-type: Simple 14 | homepage: https://github.com/snoyberg/conduit 15 | bug-reports: https://github.com/snoyberg/conduit/issues 16 | extra-source-files: README.md ChangeLog.md 17 | 18 | library 19 | build-depends: base >= 4.12 && < 5 20 | , conduit >= 1.3.0 && < 1.4 21 | , resourcet >= 0.4 && < 1.4 22 | , cereal >= 0.4.0.0 && < 0.6 23 | , bytestring 24 | , transformers >= 0.2.0.0 25 | exposed-modules: Data.Conduit.Cereal 26 | , Data.Conduit.Cereal.Internal 27 | ghc-options: -Wall 28 | 29 | Test-Suite test-cereal-conduit 30 | type: exitcode-stdio-1.0 31 | main-is: Main.hs 32 | hs-source-dirs: Test 33 | build-depends: base 34 | , conduit 35 | , cereal 36 | , cereal-conduit 37 | , bytestring 38 | --, test-framework-hunit 39 | , HUnit 40 | , mtl 41 | , transformers 42 | 43 | source-repository head 44 | type: git 45 | location: git://github.com/snoyberg/conduit.git 46 | -------------------------------------------------------------------------------- /conduit-extra/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # ChangeLog for conduit-extra 2 | 3 | ## 1.3.7 4 | 5 | * Allow Data.Conduit.Network.Unix on Windows [#518](https://github.com/snoyberg/conduit/pull/518) 6 | 7 | ## 1.3.6 8 | 9 | * Add support for `transformers-0.6` 10 | 11 | ## 1.3.5 12 | 13 | * Add `createSinkClose` 14 | 15 | ## 1.3.4 16 | 17 | * Use `MonadUnliftIO`-generalized versions of `withProcess`-style functions now provided by `typed-process` 18 | 19 | ## 1.3.3 20 | 21 | * Disable buffering in process modules [#402](https://github.com/snoyberg/conduit/issues/402) 22 | 23 | ## 1.3.2 24 | 25 | * Expose `BuilderInput` and `FlushInput`. 26 | 27 | ## 1.3.1.1 28 | 29 | * Attempt to fix a test suite failure [#385](https://github.com/snoyberg/conduit/issues/385) 30 | 31 | ## 1.3.1 32 | 33 | * Switched `gzip` to use zlib's default compression level. 34 | 35 | ## 1.3.0 36 | 37 | * Switch over to unliftio 38 | * Upgrade to conduit 1.3.0 39 | 40 | ## 1.2.3.2 41 | 42 | * Fix withSinkFileBuilder [#344](https://github.com/snoyberg/conduit/pull/344) 43 | 44 | ## 1.2.3.1 45 | 46 | * Fix typo in implementation of `withProcess_` 47 | 48 | ## 1.2.3 49 | 50 | * Added `withLoggedProcess_` 51 | 52 | ## 1.2.2.1 53 | 54 | * Add missing `hClose` to `withSinkFileCautious` 55 | 56 | ## 1.2.2 57 | 58 | * `sinkHandleBuilder`, `sinkHandleFlush`, `BuilderInput`, and `FlushInput` 59 | [#336](https://github.com/snoyberg/conduit/pull/336) 60 | * `withSinkFileCautious` 61 | 62 | ## 1.2.1 63 | 64 | * `Data.Conduit.Process.Typed` 65 | * `withSourceFile`, `withSinkFile`, and `withSinkFileBuilder` 66 | 67 | ## 1.2.0 68 | 69 | * Added the `posOffset` field to the 70 | `Data.Conduit.Attoparsec.Position` data type 71 | [#331](https://github.com/snoyberg/conduit/issues/331). 72 | 73 | ## 1.1.17 74 | 75 | * Speed up `sinkHandle` by not flushing after every output operation. 76 | [#322](https://github.com/snoyberg/conduit/issues/322) 77 | 78 | ## 1.1.16 79 | 80 | * Add `Data.Conduit.Foldl` adapter module for the `foldl` 81 | package. [#312](https://github.com/snoyberg/conduit/pull/312) 82 | 83 | ## 1.1.15 84 | 85 | * `sinkTempFile` and `sinkSystemTempFile` 86 | 87 | ## 1.1.14 88 | 89 | * `sinkFileCautious` 90 | 91 | ## 1.1.13.3 92 | 93 | * `withCheckedProcessCleanup` properly closes opened `Handle`s 94 | [#280](https://github.com/snoyberg/conduit/issues/280) 95 | 96 | ## 1.1.13.2 97 | 98 | * Fix alignment issues on non-X86 archs 99 | 100 | ## 1.1.13.1 101 | 102 | * Fix an incorrect comment 103 | 104 | ## 1.1.13 105 | 106 | * Add `sinkStorable` and `sinkStorableEx` 107 | 108 | ## 1.1.12.1 109 | 110 | * Fix build for GHC `<= 7.8` [#260](https://github.com/snoyberg/conduit/issues/260) 111 | * Fix accidentally breaking change in `sourceProcessWithConsumer` type signature 112 | 113 | ## 1.1.12 114 | 115 | * Add sourceProcessWithStreams [#258](https://github.com/snoyberg/conduit/pull/258) 116 | 117 | ## 1.1.11 118 | 119 | * `withCheckedProcessCleanup` 120 | 121 | ## 1.1.10.1 122 | 123 | * Fix a leftovers bug in helperDecompress #254 124 | 125 | ## 1.1.10 126 | 127 | * `multiple` combinator for `Data.Conduit.Zlib` [#254](https://github.com/snoyberg/conduit/issues/254) 128 | 129 | ## 1.1.9.3 130 | 131 | * Some typo fixes in docs 132 | 133 | ## 1.1.9 134 | 135 | * detectUtf [#217](https://github.com/snoyberg/conduit/pull/217) 136 | 137 | ## 1.1.8 138 | 139 | * Adding buffer size to sourceHandleRange [#213](https://github.com/snoyberg/conduit/pull/213) 140 | 141 | ## 1.1.7.3 142 | 143 | * Make Binary.lines O(n) instead of O(n^2) [#209](https://github.com/snoyberg/conduit/pull/209) 144 | 145 | ## 1.1.7.2 146 | 147 | * Fix for: Decompressing a specific amount of zlib data "eats" following data [#20](https://github.com/fpco/streaming-commons/issues/20) 148 | 149 | ## 1.1.7 150 | 151 | Add `Data.Conduit.ByteString.Builder` 152 | 153 | ## 1.1.6 154 | 155 | Generalized return type in `runGeneralTCPServer`. 156 | 157 | ## 1.1.5 158 | 159 | Added `sinkParserEither` ([pull request #189](https://github.com/snoyberg/conduit/pull/189)) 160 | -------------------------------------------------------------------------------- /conduit-extra/Data/Conduit/Attoparsec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | 6 | -- | 7 | -- Copyright: 2011 Michael Snoyman, 2010 John Millikin 8 | -- License: MIT 9 | -- 10 | -- Consume attoparsec parsers via conduit. 11 | -- 12 | -- This code was taken from attoparsec-enumerator and adapted for conduits. 13 | module Data.Conduit.Attoparsec 14 | ( -- * Sink 15 | sinkParser 16 | , sinkParserEither 17 | -- * Conduit 18 | , conduitParser 19 | , conduitParserEither 20 | 21 | -- * Types 22 | , ParseError (..) 23 | , Position (..) 24 | , PositionRange (..) 25 | -- * Classes 26 | , AttoparsecInput 27 | ) where 28 | 29 | import Control.Exception (Exception) 30 | import Control.Monad (unless) 31 | import qualified Data.ByteString as B 32 | import qualified Data.Text as T 33 | import qualified Data.Text.Internal as TI 34 | import Data.Typeable (Typeable) 35 | import Prelude hiding (lines) 36 | 37 | import qualified Data.Attoparsec.ByteString 38 | import qualified Data.Attoparsec.Text 39 | import qualified Data.Attoparsec.Types as A 40 | import Data.Conduit 41 | import Control.Monad.Trans.Resource (MonadThrow, throwM) 42 | 43 | -- | The context and message from a 'A.Fail' value. 44 | data ParseError = ParseError 45 | { errorContexts :: [String] 46 | , errorMessage :: String 47 | , errorPosition :: Position 48 | } | DivergentParser 49 | deriving (Show, Typeable) 50 | 51 | instance Exception ParseError 52 | 53 | data Position = Position 54 | { posLine :: {-# UNPACK #-} !Int 55 | , posCol :: {-# UNPACK #-} !Int 56 | , posOffset :: {-# UNPACK #-} !Int 57 | -- ^ @since 1.2.0 58 | } 59 | deriving (Eq, Ord) 60 | 61 | instance Show Position where 62 | show (Position l c off) = show l ++ ':' : show c ++ " (" ++ show off ++ ")" 63 | 64 | data PositionRange = PositionRange 65 | { posRangeStart :: {-# UNPACK #-} !Position 66 | , posRangeEnd :: {-# UNPACK #-} !Position 67 | } 68 | deriving (Eq, Ord) 69 | 70 | instance Show PositionRange where 71 | show (PositionRange s e) = show s ++ '-' : show e 72 | 73 | -- | A class of types which may be consumed by an Attoparsec parser. 74 | class AttoparsecInput a where 75 | parseA :: A.Parser a b -> a -> A.IResult a b 76 | feedA :: A.IResult a b -> a -> A.IResult a b 77 | empty :: a 78 | isNull :: a -> Bool 79 | getLinesCols :: a -> Position 80 | 81 | -- | Return the beginning of the first input with the length of 82 | -- the second input removed. Assumes the second string is shorter 83 | -- than the first. 84 | stripFromEnd :: a -> a -> a 85 | 86 | instance AttoparsecInput B.ByteString where 87 | parseA = Data.Attoparsec.ByteString.parse 88 | feedA = Data.Attoparsec.ByteString.feed 89 | empty = B.empty 90 | isNull = B.null 91 | getLinesCols = B.foldl' f (Position 0 0 0) 92 | where 93 | f (Position l c o) ch 94 | | ch == 10 = Position (l + 1) 0 (o + 1) 95 | | otherwise = Position l (c + 1) (o + 1) 96 | stripFromEnd b1 b2 = B.take (B.length b1 - B.length b2) b1 97 | 98 | instance AttoparsecInput T.Text where 99 | parseA = Data.Attoparsec.Text.parse 100 | feedA = Data.Attoparsec.Text.feed 101 | empty = T.empty 102 | isNull = T.null 103 | getLinesCols = T.foldl' f (Position 0 0 0) 104 | where 105 | f (Position l c o) ch 106 | | ch == '\n' = Position (l + 1) 0 (o + 1) 107 | | otherwise = Position l (c + 1) (o + 1) 108 | stripFromEnd (TI.Text arr1 off1 len1) (TI.Text _ _ len2) = 109 | TI.text arr1 off1 (len1 - len2) 110 | 111 | -- | Convert an Attoparsec 'A.Parser' into a 'Sink'. The parser will 112 | -- be streamed bytes until it returns 'A.Done' or 'A.Fail'. 113 | -- 114 | -- If parsing fails, a 'ParseError' will be thrown with 'throwM'. 115 | -- 116 | -- Since 0.5.0 117 | sinkParser :: (AttoparsecInput a, MonadThrow m) => A.Parser a b -> ConduitT a o m b 118 | sinkParser = fmap snd . sinkParserPosErr (Position 1 1 0) 119 | 120 | -- | Same as 'sinkParser', but we return an 'Either' type instead 121 | -- of raising an exception. 122 | -- 123 | -- Since 1.1.5 124 | sinkParserEither :: (AttoparsecInput a, Monad m) => A.Parser a b -> ConduitT a o m (Either ParseError b) 125 | sinkParserEither = (fmap.fmap) snd . sinkParserPos (Position 1 1 0) 126 | 127 | 128 | -- | Consume a stream of parsed tokens, returning both the token and 129 | -- the position it appears at. This function will raise a 'ParseError' 130 | -- on bad input. 131 | -- 132 | -- Since 0.5.0 133 | conduitParser :: (AttoparsecInput a, MonadThrow m) => A.Parser a b -> ConduitT a (PositionRange, b) m () 134 | conduitParser parser = 135 | conduit $ Position 1 1 0 136 | where 137 | conduit !pos = await >>= maybe (return ()) go 138 | where 139 | go x = do 140 | leftover x 141 | (!pos', !res) <- sinkParserPosErr pos parser 142 | yield (PositionRange pos pos', res) 143 | conduit pos' 144 | {-# SPECIALIZE conduitParser 145 | :: MonadThrow m 146 | => A.Parser T.Text b 147 | -> ConduitT T.Text (PositionRange, b) m () #-} 148 | {-# SPECIALIZE conduitParser 149 | :: MonadThrow m 150 | => A.Parser B.ByteString b 151 | -> ConduitT B.ByteString (PositionRange, b) m () #-} 152 | 153 | 154 | 155 | -- | Same as 'conduitParser', but we return an 'Either' type instead 156 | -- of raising an exception. 157 | conduitParserEither 158 | :: (Monad m, AttoparsecInput a) 159 | => A.Parser a b 160 | -> ConduitT a (Either ParseError (PositionRange, b)) m () 161 | conduitParserEither parser = 162 | conduit $ Position 1 1 0 163 | where 164 | conduit !pos = await >>= maybe (return ()) go 165 | where 166 | go x = do 167 | leftover x 168 | eres <- sinkParserPos pos parser 169 | case eres of 170 | Left e -> yield $ Left e 171 | Right (!pos', !res) -> do 172 | yield $! Right (PositionRange pos pos', res) 173 | conduit pos' 174 | {-# SPECIALIZE conduitParserEither 175 | :: Monad m 176 | => A.Parser T.Text b 177 | -> ConduitT T.Text (Either ParseError (PositionRange, b)) m () #-} 178 | {-# SPECIALIZE conduitParserEither 179 | :: Monad m 180 | => A.Parser B.ByteString b 181 | -> ConduitT B.ByteString (Either ParseError (PositionRange, b)) m () #-} 182 | 183 | 184 | 185 | 186 | sinkParserPosErr 187 | :: (AttoparsecInput a, MonadThrow m) 188 | => Position 189 | -> A.Parser a b 190 | -> ConduitT a o m (Position, b) 191 | sinkParserPosErr pos0 p = sinkParserPos pos0 p >>= f 192 | where 193 | f (Left e) = throwM e 194 | f (Right a) = return a 195 | {-# INLINE sinkParserPosErr #-} 196 | 197 | 198 | sinkParserPos 199 | :: (AttoparsecInput a, Monad m) 200 | => Position 201 | -> A.Parser a b 202 | -> ConduitT a o m (Either ParseError (Position, b)) 203 | sinkParserPos pos0 p = sink empty pos0 (parseA p) 204 | where 205 | sink prev pos parser = await >>= maybe close push 206 | where 207 | push c 208 | | isNull c = sink prev pos parser 209 | | otherwise = go False c $ parser c 210 | 211 | close = go True prev (feedA (parser empty) empty) 212 | 213 | go end c (A.Done lo x) = do 214 | let pos' 215 | | end = pos 216 | | otherwise = addLinesCols prev pos 217 | y = stripFromEnd c lo 218 | pos'' = addLinesCols y pos' 219 | unless (isNull lo) $ leftover lo 220 | pos'' `seq` return $! Right (pos'', x) 221 | go end c (A.Fail rest contexts msg) = 222 | let x = stripFromEnd c rest 223 | pos' 224 | | end = pos 225 | | otherwise = addLinesCols prev pos 226 | pos'' = addLinesCols x pos' 227 | in pos'' `seq` return $! Left (ParseError contexts msg pos'') 228 | go end c (A.Partial parser') 229 | | end = return $! Left DivergentParser 230 | | otherwise = 231 | pos' `seq` sink c pos' parser' 232 | where 233 | pos' = addLinesCols prev pos 234 | 235 | addLinesCols :: AttoparsecInput a => a -> Position -> Position 236 | addLinesCols x (Position lines cols off) = 237 | lines' `seq` cols' `seq` off' `seq` Position lines' cols' off' 238 | where 239 | Position dlines dcols doff = getLinesCols x 240 | lines' = lines + dlines 241 | cols' = (if dlines > 0 then 1 else cols) + dcols 242 | off' = off + doff 243 | {-# INLINE sinkParserPos #-} 244 | -------------------------------------------------------------------------------- /conduit-extra/Data/Conduit/ByteString/Builder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | -- | Convert a stream of blaze-builder @Builder@s into a stream of @ByteString@s. 5 | -- 6 | -- Works with both blaze-builder < 0.4's @Builder@s and 7 | -- 'Data.ByteString.Builder.Builder'. 8 | -- 9 | -- Adapted from blaze-builder-enumerator, written by myself and Simon Meier. 10 | -- 11 | -- Note that the functions here can work in any monad built on top of @IO@ or 12 | -- @ST@. 13 | -- 14 | -- Since 1.1.7.0 15 | -- 16 | module Data.Conduit.ByteString.Builder 17 | ( 18 | 19 | -- * Conduits from builders to bytestrings 20 | CC.builderToByteString 21 | , CC.unsafeBuilderToByteString 22 | , CC.builderToByteStringWith 23 | 24 | -- ** Flush 25 | , CC.builderToByteStringFlush 26 | , CC.builderToByteStringWithFlush 27 | 28 | -- * Buffer allocation strategies 29 | , CC.BufferAllocStrategy 30 | , CC.allNewBuffersStrategy 31 | , CC.reuseBufferStrategy 32 | ) where 33 | 34 | import qualified Data.Conduit.Combinators as CC 35 | -------------------------------------------------------------------------------- /conduit-extra/Data/Conduit/Filesystem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | -- | /NOTE/ It is recommended to start using "Data.Conduit.Combinators" instead 3 | -- of this module. 4 | module Data.Conduit.Filesystem 5 | ( CC.sourceDirectory 6 | , CC.sourceDirectoryDeep 7 | ) where 8 | 9 | import qualified Data.Conduit.Combinators as CC 10 | -------------------------------------------------------------------------------- /conduit-extra/Data/Conduit/Foldl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | -- | Adapter module to work with the package. 3 | -- 4 | -- @since 1.1.16 5 | module Data.Conduit.Foldl where 6 | 7 | import Data.Conduit 8 | import Control.Monad.Trans.Class (lift) 9 | import qualified Data.Conduit.List as CL 10 | 11 | -- | Convert a left fold into a 'Consumer'. This function is intended 12 | -- to be used with @purely@ from the 13 | -- package. 14 | -- 15 | -- @since 1.1.16 16 | sinkFold :: Monad m => (x -> a -> x) -> x -> (x -> b) -> ConduitT a o m b 17 | sinkFold combine seed extract = fmap extract (CL.fold combine seed) 18 | 19 | -- | Convert a monadic left fold into a 'Consumer'. This function is 20 | -- intended to be used with @impurely@ from the 21 | -- package. 22 | -- 23 | -- @since 1.1.16 24 | sinkFoldM :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> ConduitT a o m b 25 | sinkFoldM combine seed extract = 26 | lift . extract =<< CL.foldM combine =<< lift seed 27 | -------------------------------------------------------------------------------- /conduit-extra/Data/Conduit/Lazy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE Trustworthy #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | {-# OPTIONS_GHC -fno-warn-deprecations #-} -- Suppress warnings around Control.Monad.Trans.Error 7 | -- | Use lazy I\/O for consuming the contents of a source. Warning: All normal 8 | -- warnings of lazy I\/O apply. In particular, if you are using this with a 9 | -- @ResourceT@ transformer, you must force the list to be evaluated before 10 | -- exiting the @ResourceT@. 11 | module Data.Conduit.Lazy 12 | ( lazyConsume 13 | , MonadActive (..) 14 | ) where 15 | 16 | import Data.Conduit 17 | import Data.Conduit.Internal (Pipe (..), ConduitT (..)) 18 | import System.IO.Unsafe (unsafeInterleaveIO) 19 | 20 | import Control.Monad.Trans.Class (lift) 21 | import Control.Monad.IO.Unlift (MonadIO, liftIO, MonadUnliftIO, withUnliftIO, unliftIO) 22 | 23 | import Control.Monad.Trans.Identity ( IdentityT) 24 | #if !MIN_VERSION_transformers(0,6,0) 25 | import Control.Monad.Trans.Error ( ErrorT, Error) 26 | import Control.Monad.Trans.List ( ListT ) 27 | #endif 28 | import Control.Monad.Trans.Maybe ( MaybeT ) 29 | import Control.Monad.Trans.Reader ( ReaderT ) 30 | import Control.Monad.Trans.State ( StateT ) 31 | import Control.Monad.Trans.Writer ( WriterT ) 32 | import Control.Monad.Trans.RWS ( RWST ) 33 | 34 | import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST ) 35 | import qualified Control.Monad.Trans.State.Strict as Strict ( StateT ) 36 | import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) 37 | 38 | #if (__GLASGOW_HASKELL__ < 710) 39 | import Data.Monoid (Monoid) 40 | #endif 41 | import Control.Monad.ST (ST) 42 | import qualified Control.Monad.ST.Lazy as Lazy 43 | import Data.Functor.Identity (Identity) 44 | import Control.Monad.Trans.Resource.Internal (ResourceT (ResourceT), ReleaseMap (ReleaseMapClosed)) 45 | import qualified Data.IORef as I 46 | 47 | -- | Use lazy I\/O to consume all elements from a @Source@. 48 | -- 49 | -- This function relies on 'monadActive' to determine if the underlying monadic 50 | -- state has been closed. 51 | -- 52 | -- Since 0.3.0 53 | lazyConsume 54 | :: forall m a. 55 | (MonadUnliftIO m, MonadActive m) 56 | => Source m a 57 | -> m [a] 58 | lazyConsume (ConduitT f0) = 59 | withUnliftIO $ \u -> 60 | let go :: Pipe () () a () m () -> IO [a] 61 | go (Done _) = return [] 62 | go (HaveOutput src x) = do 63 | xs <- unsafeInterleaveIO $ go src 64 | return $ x : xs 65 | go (PipeM msrc) = unsafeInterleaveIO $ do 66 | a <- unliftIO u monadActive 67 | if a 68 | then unliftIO u msrc >>= go 69 | else return [] 70 | go (NeedInput _ c) = go (c ()) 71 | go (Leftover p _) = go p 72 | in go (f0 Done) 73 | 74 | -- | Determine if some monad is still active. This is intended to prevent usage 75 | -- of a monadic state after it has been closed. This is necessary for such 76 | -- cases as lazy I\/O, where an unevaluated thunk may still refer to a 77 | -- closed @ResourceT@. 78 | -- 79 | -- Since 0.3.0 80 | class Monad m => MonadActive m where 81 | monadActive :: m Bool 82 | 83 | instance (MonadIO m, MonadActive m) => MonadActive (ResourceT m) where 84 | monadActive = ResourceT $ \rmMap -> do 85 | rm <- liftIO $ I.readIORef rmMap 86 | case rm of 87 | ReleaseMapClosed -> return False 88 | _ -> monadActive -- recurse 89 | 90 | instance MonadActive Identity where 91 | monadActive = return True 92 | 93 | instance MonadActive IO where 94 | monadActive = return True 95 | 96 | instance MonadActive (ST s) where 97 | monadActive = return True 98 | 99 | instance MonadActive (Lazy.ST s) where 100 | monadActive = return True 101 | 102 | #define GO(T) instance MonadActive m => MonadActive (T m) where monadActive = lift monadActive 103 | #define GOX(X, T) instance (X, MonadActive m) => MonadActive (T m) where monadActive = lift monadActive 104 | GO(IdentityT) 105 | #if !MIN_VERSION_transformers(0,6,0) 106 | GOX(Error e, ErrorT e) 107 | GO(ListT) 108 | #endif 109 | GO(MaybeT) 110 | GO(ReaderT r) 111 | GO(StateT s) 112 | GOX(Monoid w, WriterT w) 113 | GOX(Monoid w, RWST r w s) 114 | GOX(Monoid w, Strict.RWST r w s) 115 | GO(Strict.StateT s) 116 | GOX(Monoid w, Strict.WriterT w) 117 | #undef GO 118 | #undef GOX 119 | 120 | instance MonadActive m => MonadActive (Pipe l i o u m) where 121 | monadActive = lift monadActive 122 | instance MonadActive m => MonadActive (ConduitT i o m) where 123 | monadActive = lift monadActive 124 | -------------------------------------------------------------------------------- /conduit-extra/Data/Conduit/Network.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE CPP #-} 5 | module Data.Conduit.Network 6 | ( -- * Basic utilities 7 | sourceSocket 8 | , sinkSocket 9 | -- * Simple TCP server/client interface. 10 | , SN.AppData 11 | , appSource 12 | , appSink 13 | , SN.appSockAddr 14 | , SN.appLocalAddr 15 | -- ** Server 16 | , SN.ServerSettings 17 | , serverSettings 18 | , SN.runTCPServer 19 | , SN.runTCPServerWithHandle 20 | , forkTCPServer 21 | , runGeneralTCPServer 22 | -- ** Client 23 | , SN.ClientSettings 24 | , clientSettings 25 | , SN.runTCPClient 26 | , runGeneralTCPClient 27 | -- ** Getters 28 | , SN.getPort 29 | , SN.getHost 30 | , SN.getAfterBind 31 | , SN.getNeedLocalAddr 32 | -- ** Setters 33 | , SN.setPort 34 | , SN.setHost 35 | , SN.setAfterBind 36 | , SN.setNeedLocalAddr 37 | -- * Types 38 | , SN.HostPreference 39 | ) where 40 | 41 | import Prelude 42 | import Data.Conduit 43 | import Network.Socket (Socket) 44 | import Network.Socket.ByteString (sendAll) 45 | import Data.ByteString (ByteString) 46 | import qualified GHC.Conc as Conc (yield) 47 | import qualified Data.ByteString as S 48 | import Control.Monad.IO.Class (MonadIO (liftIO)) 49 | import Control.Monad (unless) 50 | import Control.Monad.Trans.Class (lift) 51 | import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar, MVar, ThreadId) 52 | import qualified Data.Streaming.Network as SN 53 | import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) 54 | 55 | -- | Stream data from the socket. 56 | -- 57 | -- This function does /not/ automatically close the socket. 58 | -- 59 | -- Since 0.0.0 60 | sourceSocket :: MonadIO m => Socket -> ConduitT i ByteString m () 61 | sourceSocket socket = 62 | loop 63 | where 64 | loop = do 65 | bs <- lift $ liftIO $ SN.safeRecv socket 4096 66 | if S.null bs 67 | then return () 68 | else yield bs >> loop 69 | 70 | -- | Stream data to the socket. 71 | -- 72 | -- This function does /not/ automatically close the socket. 73 | -- 74 | -- Since 0.0.0 75 | sinkSocket :: MonadIO m => Socket -> ConduitT ByteString o m () 76 | sinkSocket socket = 77 | loop 78 | where 79 | loop = await >>= maybe (return ()) (\bs -> lift (liftIO $ sendAll socket bs) >> loop) 80 | 81 | serverSettings :: Int -> SN.HostPreference -> SN.ServerSettings 82 | serverSettings = SN.serverSettingsTCP 83 | 84 | clientSettings :: Int -> ByteString -> SN.ClientSettings 85 | clientSettings = SN.clientSettingsTCP 86 | 87 | appSource :: (SN.HasReadWrite ad, MonadIO m) => ad -> ConduitT i ByteString m () 88 | appSource ad = 89 | loop 90 | where 91 | read' = SN.appRead ad 92 | loop = do 93 | bs <- liftIO read' 94 | unless (S.null bs) $ do 95 | yield bs 96 | loop 97 | 98 | appSink :: (SN.HasReadWrite ad, MonadIO m) => ad -> ConduitT ByteString o m () 99 | appSink ad = awaitForever $ \d -> liftIO $ SN.appWrite ad d >> Conc.yield 100 | 101 | addBoundSignal::MVar ()-> SN.ServerSettings -> SN.ServerSettings 102 | addBoundSignal isBound set = SN.setAfterBind ( \socket -> originalAfterBind socket >> signalBound socket) set 103 | where originalAfterBind :: Socket -> IO () 104 | originalAfterBind = SN.getAfterBind set 105 | signalBound :: Socket -> IO () 106 | signalBound _socket = putMVar isBound () 107 | 108 | -- | Fork a TCP Server 109 | -- 110 | -- Will fork the runGeneralTCPServer function but will only return from 111 | -- this call when the server is bound to the port and accepting incoming 112 | -- connections. Will return the thread id of the server 113 | -- 114 | -- Since 1.1.4 115 | forkTCPServer 116 | :: MonadUnliftIO m 117 | => SN.ServerSettings 118 | -> (SN.AppData -> m ()) 119 | -> m ThreadId 120 | forkTCPServer set f = 121 | withRunInIO $ \run -> do 122 | isBound <- newEmptyMVar 123 | let setWithWaitForBind = addBoundSignal isBound set 124 | threadId <- forkIO . run $ runGeneralTCPServer setWithWaitForBind f 125 | takeMVar isBound 126 | return threadId 127 | 128 | 129 | 130 | -- | Run a general TCP server 131 | -- 132 | -- Same as 'SN.runTCPServer', except monad can be any instance of 133 | -- 'MonadUnliftIO'. 134 | -- 135 | -- Note that any changes to the monadic state performed by individual 136 | -- client handlers will be discarded. If you have mutable state you want 137 | -- to share among multiple handlers, you need to use some kind of mutable 138 | -- variables. 139 | -- 140 | -- Since 1.1.3 141 | runGeneralTCPServer 142 | :: MonadUnliftIO m 143 | => SN.ServerSettings 144 | -> (SN.AppData -> m ()) 145 | -> m a 146 | runGeneralTCPServer set f = withRunInIO $ \run -> 147 | SN.runTCPServer set $ run . f 148 | 149 | -- | Run a general TCP client 150 | -- 151 | -- Same as 'SN.runTCPClient', except monad can be any instance of 'MonadUnliftIO'. 152 | -- 153 | -- Since 1.1.3 154 | runGeneralTCPClient 155 | :: MonadUnliftIO m 156 | => SN.ClientSettings 157 | -> (SN.AppData -> m a) 158 | -> m a 159 | runGeneralTCPClient set f = withRunInIO $ \run -> 160 | SN.runTCPClient set $ run . f 161 | -------------------------------------------------------------------------------- /conduit-extra/Data/Conduit/Network/UDP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | module Data.Conduit.Network.UDP 3 | ( -- * UDP message representation 4 | SN.Message (..) 5 | -- * Basic utilities 6 | , sourceSocket 7 | , sinkSocket 8 | , sinkAllSocket 9 | , sinkToSocket 10 | , sinkAllToSocket 11 | -- * Helper Utilities 12 | , SN.HostPreference 13 | ) where 14 | 15 | import Data.Conduit 16 | import Network.Socket (Socket) 17 | import Network.Socket.ByteString (recvFrom, send, sendAll, sendTo, sendAllTo) 18 | import Data.ByteString (ByteString) 19 | import Control.Monad.IO.Class (MonadIO (liftIO)) 20 | import Control.Monad (void) 21 | import Control.Monad.Trans.Class (lift) 22 | import qualified Data.Streaming.Network as SN 23 | 24 | -- | Stream messages from the socket. 25 | -- 26 | -- The given @len@ defines the maximum packet size. Every produced item 27 | -- contains the message payload and the origin address. 28 | -- 29 | -- This function does /not/ automatically close the socket. 30 | sourceSocket :: MonadIO m => Socket -> Int -> ConduitT i SN.Message m () 31 | sourceSocket socket len = loop 32 | where 33 | loop = do 34 | (bs, addr) <- lift $ liftIO $ recvFrom socket len 35 | yield (SN.Message bs addr) >> loop 36 | 37 | -- | Stream messages to the connected socket. 38 | -- 39 | -- The payload is sent using @send@, so some of it might be lost. 40 | -- 41 | -- This function does /not/ automatically close the socket. 42 | sinkSocket :: MonadIO m => Socket -> ConduitT ByteString o m () 43 | sinkSocket = sinkSocketHelper (\sock bs -> void $ send sock bs) 44 | 45 | -- | Stream messages to the connected socket. 46 | -- 47 | -- The payload is sent using @sendAll@, so it might end up in multiple packets. 48 | -- 49 | -- This function does /not/ automatically close the socket. 50 | sinkAllSocket :: MonadIO m => Socket -> ConduitT ByteString o m () 51 | sinkAllSocket = sinkSocketHelper sendAll 52 | 53 | -- | Stream messages to the socket. 54 | -- 55 | -- Every handled item contains the message payload and the destination 56 | -- address. The payload is sent using @sendTo@, so some of it might be 57 | -- lost. 58 | -- 59 | -- This function does /not/ automatically close the socket. 60 | sinkToSocket :: MonadIO m => Socket -> ConduitT SN.Message o m () 61 | sinkToSocket = sinkSocketHelper (\sock (SN.Message bs addr) -> void $ sendTo sock bs addr) 62 | 63 | -- | Stream messages to the socket. 64 | -- 65 | -- Every handled item contains the message payload and the destination 66 | -- address. The payload is sent using @sendAllTo@, so it might end up in 67 | -- multiple packets. 68 | -- 69 | -- This function does /not/ automatically close the socket. 70 | sinkAllToSocket :: MonadIO m => Socket -> ConduitT SN.Message o m () 71 | sinkAllToSocket = sinkSocketHelper (\sock (SN.Message bs addr) -> sendAllTo sock bs addr) 72 | 73 | -- Internal 74 | sinkSocketHelper :: MonadIO m => (Socket -> a -> IO ()) 75 | -> Socket 76 | -> ConduitT a o m () 77 | sinkSocketHelper act socket = loop 78 | where 79 | loop = await >>= maybe 80 | (return ()) 81 | (\a -> lift (liftIO $ act socket a) >> loop) 82 | {-# INLINE sinkSocketHelper #-} 83 | -------------------------------------------------------------------------------- /conduit-extra/Data/Conduit/Network/Unix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | module Data.Conduit.Network.Unix 6 | ( -- * Basic utilities 7 | sourceSocket 8 | , sinkSocket 9 | -- * Simple server/client interface 10 | , SN.AppDataUnix 11 | , appSource 12 | , appSink 13 | -- ** Server 14 | , SN.ServerSettingsUnix 15 | , serverSettings 16 | , SN.runUnixServer 17 | -- ** Client 18 | , SN.ClientSettingsUnix 19 | , clientSettings 20 | , SN.runUnixClient 21 | -- ** Getters 22 | , SN.getPath 23 | , SN.getAfterBind 24 | -- ** Setters 25 | , SN.setPath 26 | , SN.setAfterBind 27 | ) where 28 | 29 | import Data.Conduit.Network (appSource, appSink, sourceSocket, sinkSocket) 30 | import qualified Data.Streaming.Network as SN 31 | 32 | clientSettings :: FilePath -> SN.ClientSettingsUnix 33 | clientSettings = SN.clientSettingsUnix 34 | 35 | serverSettings :: FilePath -> SN.ServerSettingsUnix 36 | serverSettings = SN.serverSettingsUnix 37 | -------------------------------------------------------------------------------- /conduit-extra/Data/Conduit/Process.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE CPP #-} 5 | {-# OPTIONS_GHC -fno-warn-orphans #-} 6 | -- | A full tutorial for this module is available at: 7 | -- . 8 | -- 9 | -- Some utilities in this module require the threaded runtime because they use 10 | -- 'System.Process.waitForProcess' internally. 11 | -- 12 | -- Note that this is a very thin layer around the @Data.Streaming.Process@ module. In particular, it: 13 | -- 14 | -- * Provides orphan instances for conduit 15 | -- 16 | -- * Provides some useful helper functions 17 | module Data.Conduit.Process 18 | ( -- * Functions 19 | sourceCmdWithConsumer 20 | , sourceProcessWithConsumer 21 | , sourceCmdWithStreams 22 | , sourceProcessWithStreams 23 | , withCheckedProcessCleanup 24 | -- * InputSource types 25 | , FlushInput(..) 26 | , BuilderInput(..) 27 | -- * Reexport 28 | , module Data.Streaming.Process 29 | ) where 30 | 31 | import Data.Streaming.Process 32 | import Data.Streaming.Process.Internal 33 | import System.Exit (ExitCode (..)) 34 | import Control.Monad.IO.Unlift (MonadIO, liftIO, MonadUnliftIO, withRunInIO, withUnliftIO, unliftIO) 35 | import System.IO (hClose, BufferMode (NoBuffering), hSetBuffering) 36 | import Data.Conduit 37 | import Data.Functor (($>)) 38 | import Data.Conduit.Binary (sourceHandle, sinkHandle, sinkHandleBuilder, sinkHandleFlush) 39 | import Data.ByteString (ByteString) 40 | import Data.ByteString.Builder (Builder) 41 | import Control.Concurrent.Async (runConcurrently, Concurrently(..)) 42 | import Control.Exception (onException, throwIO, finally, bracket) 43 | #if (__GLASGOW_HASKELL__ < 710) 44 | import Control.Applicative ((<$>), (<*>)) 45 | #endif 46 | 47 | instance (r ~ (), MonadIO m, i ~ ByteString) => InputSource (ConduitM i o m r) where 48 | isStdStream = (\(Just h) -> hSetBuffering h NoBuffering $> sinkHandle h, Just CreatePipe) 49 | instance (r ~ (), r' ~ (), MonadIO m, MonadIO n, i ~ ByteString) => InputSource (ConduitM i o m r, n r') where 50 | isStdStream = (\(Just h) -> hSetBuffering h NoBuffering $> (sinkHandle h, liftIO $ hClose h), Just CreatePipe) 51 | 52 | -- | Wrapper for input source which accepts 'Data.ByteString.Builder.Builder's. 53 | -- You can pass 'Data.ByteString.Builder.Extra.flush' to flush the input. Note 54 | -- that the pipe will /not/ automatically close when the processing completes. 55 | -- 56 | -- @since 1.3.2 57 | newtype BuilderInput o m r = BuilderInput (ConduitM Builder o m r) 58 | 59 | -- | Wrapper for input source which accepts @Flush@es. Note that the pipe 60 | -- will /not/ automatically close then processing completes. 61 | -- 62 | -- @since 1.3.2 63 | newtype FlushInput o m r = FlushInput (ConduitM (Flush ByteString) o m r) 64 | 65 | instance (MonadIO m, r ~ ()) => InputSource (BuilderInput o m r) where 66 | isStdStream = (\(Just h) -> return $ BuilderInput $ sinkHandleBuilder h, Just CreatePipe) 67 | instance (MonadIO m, MonadIO n, r ~ (), r' ~ ()) => InputSource (BuilderInput o m r, n r') where 68 | isStdStream = (\(Just h) -> return (BuilderInput $ sinkHandleBuilder h, liftIO $ hClose h), Just CreatePipe) 69 | instance (MonadIO m, r ~ ()) => InputSource (FlushInput o m r) where 70 | isStdStream = (\(Just h) -> return $ FlushInput $ sinkHandleFlush h, Just CreatePipe) 71 | instance (MonadIO m, MonadIO n, r ~ (), r' ~ ()) => InputSource (FlushInput o m r, n r') where 72 | isStdStream = (\(Just h) -> return (FlushInput $ sinkHandleFlush h, liftIO $ hClose h), Just CreatePipe) 73 | 74 | instance (r ~ (), MonadIO m, o ~ ByteString) => OutputSink (ConduitM i o m r) where 75 | osStdStream = (\(Just h) -> hSetBuffering h NoBuffering $> sourceHandle h, Just CreatePipe) 76 | instance (r ~ (), r' ~ (), MonadIO m, MonadIO n, o ~ ByteString) => OutputSink (ConduitM i o m r, n r') where 77 | osStdStream = (\(Just h) -> hSetBuffering h NoBuffering $> (sourceHandle h, liftIO $ hClose h), Just CreatePipe) 78 | 79 | -- | Given a @CreateProcess@, run the process, with its output being used as a 80 | -- @Source@ to feed the provided @Consumer@. Once the process has completed, 81 | -- return a tuple of the @ExitCode@ from the process and the output collected 82 | -- from the @Consumer@. 83 | -- 84 | -- Note that, if an exception is raised by the consumer, the process is /not/ 85 | -- terminated. This behavior is different from 'sourceProcessWithStreams' due 86 | -- to historical reasons. 87 | -- 88 | -- Requires the threaded runtime. 89 | -- 90 | -- Since 1.1.2 91 | sourceProcessWithConsumer :: MonadIO m 92 | => CreateProcess 93 | -> ConduitT ByteString Void m a -- ^ stdout 94 | -> m (ExitCode, a) 95 | sourceProcessWithConsumer cp consumer = do 96 | (ClosedStream, (source, close), ClosedStream, cph) <- streamingProcess cp 97 | res <- runConduit $ source .| consumer 98 | close 99 | ec <- waitForStreamingProcess cph 100 | return (ec, res) 101 | 102 | -- | Like @sourceProcessWithConsumer@ but providing the command to be run as 103 | -- a @String@. 104 | -- 105 | -- Requires the threaded runtime. 106 | -- 107 | -- Since 1.1.2 108 | sourceCmdWithConsumer :: MonadIO m 109 | => String -- ^command 110 | -> ConduitT ByteString Void m a -- ^stdout 111 | -> m (ExitCode, a) 112 | sourceCmdWithConsumer cmd = sourceProcessWithConsumer (shell cmd) 113 | 114 | 115 | -- | Given a @CreateProcess@, run the process 116 | -- and feed the provided @Producer@ 117 | -- to the stdin @Sink@ of the process. 118 | -- Use the process outputs (stdout, stderr) as @Source@s 119 | -- and feed it to the provided @Consumer@s. 120 | -- Once the process has completed, 121 | -- return a tuple of the @ExitCode@ from the process 122 | -- and the results collected from the @Consumer@s. 123 | -- 124 | -- If an exception is raised by any of the streams, 125 | -- the process is terminated. 126 | -- 127 | -- IO is required because the streams are run concurrently 128 | -- using the package 129 | -- 130 | -- Requires the threaded runtime. 131 | -- 132 | -- @since 1.1.12 133 | sourceProcessWithStreams 134 | :: MonadUnliftIO m 135 | => CreateProcess 136 | -> ConduitT () ByteString m () -- ^stdin 137 | -> ConduitT ByteString Void m a -- ^stdout 138 | -> ConduitT ByteString Void m b -- ^stderr 139 | -> m (ExitCode, a, b) 140 | sourceProcessWithStreams cp producerStdin consumerStdout consumerStderr = 141 | withUnliftIO $ \u -> do 142 | ( (sinkStdin, closeStdin) 143 | , (sourceStdout, closeStdout) 144 | , (sourceStderr, closeStderr) 145 | , sph) <- streamingProcess cp 146 | (_, resStdout, resStderr) <- 147 | runConcurrently ( 148 | (,,) 149 | <$> Concurrently ((unliftIO u $ runConduit $ producerStdin .| sinkStdin) `finally` closeStdin) 150 | <*> Concurrently (unliftIO u $ runConduit $ sourceStdout .| consumerStdout) 151 | <*> Concurrently (unliftIO u $ runConduit $ sourceStderr .| consumerStderr)) 152 | `finally` (closeStdout >> closeStderr) 153 | `onException` terminateStreamingProcess sph 154 | ec <- waitForStreamingProcess sph 155 | return (ec, resStdout, resStderr) 156 | 157 | -- | Like @sourceProcessWithStreams@ but providing the command to be run as 158 | -- a @String@. 159 | -- 160 | -- Requires the threaded runtime. 161 | -- 162 | -- @since 1.1.12 163 | sourceCmdWithStreams 164 | :: MonadUnliftIO m 165 | => String -- ^command 166 | -> ConduitT () ByteString m () -- ^stdin 167 | -> ConduitT ByteString Void m a -- ^stdout 168 | -> ConduitT ByteString Void m b -- ^stderr 169 | -> m (ExitCode, a, b) 170 | sourceCmdWithStreams cmd = sourceProcessWithStreams (shell cmd) 171 | 172 | -- | Same as 'withCheckedProcess', but kills the child process in the case of 173 | -- an exception being thrown by the provided callback function. 174 | -- 175 | -- Requires the threaded runtime. 176 | -- 177 | -- @since 1.1.11 178 | withCheckedProcessCleanup 179 | :: ( InputSource stdin 180 | , OutputSink stderr 181 | , OutputSink stdout 182 | , MonadUnliftIO m 183 | ) 184 | => CreateProcess 185 | -> (stdin -> stdout -> stderr -> m b) 186 | -> m b 187 | withCheckedProcessCleanup cp f = withRunInIO $ \run -> bracket 188 | (streamingProcess cp) 189 | (\(_, _, _, sph) -> closeStreamingProcessHandle sph) 190 | $ \(x, y, z, sph) -> do 191 | res <- run (f x y z) `onException` terminateStreamingProcess sph 192 | ec <- waitForStreamingProcess sph 193 | if ec == ExitSuccess 194 | then return res 195 | else throwIO $ ProcessExitedUnsuccessfully cp ec 196 | 197 | 198 | terminateStreamingProcess :: MonadIO m => StreamingProcessHandle -> m () 199 | terminateStreamingProcess = liftIO . terminateProcess . streamingProcessHandleRaw 200 | -------------------------------------------------------------------------------- /conduit-extra/Data/Conduit/Process/Typed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | -- | The "System.Process.Typed" module from @typed-process@, but with 4 | -- added conduit helpers. 5 | module Data.Conduit.Process.Typed 6 | ( -- * Conduit specific stuff 7 | createSink 8 | , createSinkClose 9 | , createSource 10 | -- * Running a process with logging 11 | , withLoggedProcess_ 12 | -- * Reexports 13 | , module System.Process.Typed 14 | ) where 15 | 16 | import System.Process.Typed 17 | import qualified System.Process.Typed as P 18 | import Data.Conduit (ConduitM, (.|), runConduit) 19 | import qualified Data.Conduit.Binary as CB 20 | import Control.Monad.IO.Unlift 21 | import qualified Data.ByteString as S 22 | import qualified Data.Conduit.List as CL 23 | import qualified Data.ByteString.Lazy as BL 24 | import Data.IORef (IORef, newIORef, readIORef, modifyIORef) 25 | import Control.Exception (throwIO, catch) 26 | import Control.Concurrent.Async (concurrently) 27 | import System.IO (hSetBuffering, BufferMode (NoBuffering), hClose) 28 | 29 | -- | Provide input to a process by writing to a conduit. The sink provided here 30 | -- will leave the pipe to the child open after the stream ends. This allows the 31 | -- sink to be used multiple times, but may result in surprising behavior. You 32 | -- may prefer 'createSinkClose', see 33 | -- . 34 | -- 35 | -- @since 1.2.1 36 | createSink :: MonadIO m => StreamSpec 'STInput (ConduitM S.ByteString o m ()) 37 | createSink = 38 | (\h -> liftIO (hSetBuffering h NoBuffering) >> CB.sinkHandle h) 39 | `fmap` createPipe 40 | 41 | -- | Like 'createSink', but closes the pipe to the child process as soon as it 42 | -- runs out of data. 43 | -- 44 | -- @since 1.3.5 45 | createSinkClose :: MonadIO m => StreamSpec 'STInput (ConduitM S.ByteString o m ()) 46 | createSinkClose = 47 | (\h -> liftIO (hSetBuffering h NoBuffering) >> CB.sinkHandle h >> liftIO (hClose h)) 48 | `fmap` createPipe 49 | 50 | -- | Read output from a process by read from a conduit. 51 | -- 52 | -- @since 1.2.1 53 | createSource :: MonadIO m => StreamSpec 'STOutput (ConduitM i S.ByteString m ()) 54 | createSource = 55 | (\h -> liftIO (hSetBuffering h NoBuffering) >> CB.sourceHandle h) 56 | `fmap` createPipe 57 | 58 | -- | Internal function: like 'createSource', but stick all chunks into 59 | -- the 'IORef'. 60 | createSourceLogged 61 | :: MonadIO m 62 | => IORef ([S.ByteString] -> [S.ByteString]) 63 | -> StreamSpec 'STOutput (ConduitM i S.ByteString m ()) 64 | createSourceLogged ref = 65 | -- We do not add a cleanup action to close the handle, since in 66 | -- withLoggedProcess_ we attempt to read from the handle twice 67 | (\h -> 68 | ( CB.sourceHandle h 69 | .| CL.iterM (\bs -> liftIO $ modifyIORef ref (. (bs:)))) 70 | ) 71 | `fmap` createPipe 72 | 73 | -- | Run a process, throwing an exception on a failure exit code. This 74 | -- will store all output from stdout and stderr in memory for better 75 | -- error messages. Note that this will require unbounded memory usage, 76 | -- so caveat emptor. 77 | -- 78 | -- This will ignore any previous settings for the stdout and stderr 79 | -- streams, and instead force them to use 'createSource'. 80 | -- 81 | -- @since 1.2.3 82 | withLoggedProcess_ 83 | :: MonadUnliftIO m 84 | => ProcessConfig stdin stdoutIgnored stderrIgnored 85 | -> (Process stdin (ConduitM () S.ByteString m ()) (ConduitM () S.ByteString m ()) -> m a) 86 | -> m a 87 | withLoggedProcess_ pc inner = withUnliftIO $ \u -> do 88 | stdoutBuffer <- newIORef id 89 | stderrBuffer <- newIORef id 90 | let pc' = setStdout (createSourceLogged stdoutBuffer) 91 | $ setStderr (createSourceLogged stderrBuffer) pc 92 | -- withProcessWait vs Term doesn't actually matter here, since we 93 | -- call checkExitCode inside regardless. But still, Wait is the 94 | -- safer function to use in general. 95 | P.withProcessWait pc' $ \p -> do 96 | a <- unliftIO u $ inner p 97 | let drain src = unliftIO u (runConduit (src .| CL.sinkNull)) 98 | ((), ()) <- drain (getStdout p) `concurrently` 99 | drain (getStderr p) 100 | checkExitCode p `catch` \ece -> do 101 | stdout <- readIORef stdoutBuffer 102 | stderr <- readIORef stderrBuffer 103 | throwIO ece 104 | { eceStdout = BL.fromChunks $ stdout [] 105 | , eceStderr = BL.fromChunks $ stderr [] 106 | } 107 | return a 108 | -------------------------------------------------------------------------------- /conduit-extra/Data/Conduit/Zlib.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | -- | Streaming compression and decompression using conduits. 4 | -- 5 | -- Parts of this code were taken from zlib-enum and adapted for conduits. 6 | module Data.Conduit.Zlib ( 7 | -- * Conduits 8 | compress, decompress, gzip, ungzip, 9 | -- * Flushing 10 | compressFlush, decompressFlush, 11 | -- * Decompression combinators 12 | multiple, 13 | -- * Re-exported from zlib-bindings 14 | WindowBits (..), defaultWindowBits 15 | ) where 16 | 17 | import Data.Streaming.Zlib 18 | import Data.Conduit 19 | import Data.ByteString (ByteString) 20 | import qualified Data.ByteString as S 21 | import Control.Monad (unless, liftM) 22 | import Control.Monad.Trans.Class (lift, MonadTrans) 23 | import Control.Monad.Primitive (PrimMonad, unsafePrimToPrim) 24 | import Control.Monad.Trans.Resource (MonadThrow, throwM) 25 | import Data.Function (fix) 26 | 27 | -- | Gzip compression with default parameters. 28 | gzip :: (MonadThrow m, PrimMonad m) => ConduitT ByteString ByteString m () 29 | gzip = compress (-1) (WindowBits 31) 30 | 31 | -- | Gzip decompression with default parameters. 32 | ungzip :: (PrimMonad m, MonadThrow m) => ConduitT ByteString ByteString m () 33 | ungzip = decompress (WindowBits 31) 34 | 35 | unsafeLiftIO :: (PrimMonad m, MonadThrow m) => IO a -> m a 36 | unsafeLiftIO = unsafePrimToPrim 37 | 38 | -- | 39 | -- Decompress (inflate) a stream of 'ByteString's. For example: 40 | -- 41 | -- > sourceFile "test.z" $= decompress defaultWindowBits $$ sinkFile "test" 42 | 43 | decompress 44 | :: (PrimMonad m, MonadThrow m) 45 | => WindowBits -- ^ Zlib parameter (see the zlib-bindings package as well as the zlib C library) 46 | -> ConduitT ByteString ByteString m () 47 | decompress = 48 | helperDecompress (liftM (fmap Chunk) await) yield' leftover 49 | where 50 | yield' Flush = return () 51 | yield' (Chunk bs) = yield bs 52 | 53 | -- | Same as 'decompress', but allows you to explicitly flush the stream. 54 | decompressFlush 55 | :: (PrimMonad m, MonadThrow m) 56 | => WindowBits -- ^ Zlib parameter (see the zlib-bindings package as well as the zlib C library) 57 | -> ConduitT (Flush ByteString) (Flush ByteString) m () 58 | decompressFlush = helperDecompress await yield (leftover . Chunk) 59 | 60 | helperDecompress :: (Monad (t m), PrimMonad m, MonadThrow m, MonadTrans t) 61 | => t m (Maybe (Flush ByteString)) 62 | -> (Flush ByteString -> t m ()) 63 | -> (ByteString -> t m ()) 64 | -> WindowBits 65 | -> t m () 66 | helperDecompress await' yield' leftover' config = do 67 | -- Initialize the stateful inflater, which will be used below 68 | -- This inflater is never exposed outside of this function 69 | inf <- lift $ unsafeLiftIO $ initInflate config 70 | 71 | -- Some helper functions used by the main feeder loop below 72 | 73 | let -- Flush any remaining inflated bytes downstream 74 | flush = do 75 | chunk <- lift $ unsafeLiftIO $ flushInflate inf 76 | unless (S.null chunk) $ yield' $ Chunk chunk 77 | 78 | -- Get any input which is unused by the inflater 79 | getUnused = lift $ unsafeLiftIO $ getUnusedInflate inf 80 | 81 | -- If there is any unused data, return it as leftovers to the stream 82 | unused = do 83 | rem' <- getUnused 84 | unless (S.null rem') $ leftover' rem' 85 | 86 | -- Main loop: feed data from upstream into the inflater 87 | fix $ \feeder -> do 88 | mnext <- await' 89 | case mnext of 90 | -- No more data is available from upstream 91 | Nothing -> do 92 | -- Flush any remaining uncompressed data 93 | flush 94 | -- Return the rest of the unconsumed data as leftovers 95 | unused 96 | -- Another chunk of compressed data arrived 97 | Just (Chunk x) -> do 98 | -- Feed the compressed data into the inflater, returning a 99 | -- "popper" which will return chunks of decompressed data 100 | popper <- lift $ unsafeLiftIO $ feedInflate inf x 101 | 102 | -- Loop over the popper grabbing decompressed chunks and 103 | -- yielding them downstream 104 | fix $ \pop -> do 105 | mbs <- lift $ unsafeLiftIO popper 106 | case mbs of 107 | -- No more data from this popper 108 | PRDone -> do 109 | rem' <- getUnused 110 | if S.null rem' 111 | -- No data was unused by the inflater, so let's 112 | -- fill it up again and get more data out of it 113 | then feeder 114 | -- In this case, there is some unconsumed data, 115 | -- meaning the compressed stream is complete. 116 | -- At this point, we need to stop feeding, 117 | -- return the unconsumed data as leftovers, and 118 | -- flush any remaining content (which should be 119 | -- nothing) 120 | else do 121 | flush 122 | leftover' rem' 123 | -- Another chunk available, yield it downstream and 124 | -- loop again 125 | PRNext bs -> do 126 | yield' (Chunk bs) 127 | pop 128 | -- An error occurred inside zlib, throw it 129 | PRError e -> lift $ throwM e 130 | -- We've been asked to flush the stream 131 | Just Flush -> do 132 | -- Get any uncompressed data waiting for us 133 | flush 134 | -- Put a Flush in the stream 135 | yield' Flush 136 | -- Feed in more data 137 | feeder 138 | 139 | -- | 140 | -- Compress (deflate) a stream of 'ByteString's. The 'WindowBits' also control 141 | -- the format (zlib vs. gzip). 142 | 143 | compress 144 | :: (PrimMonad m, MonadThrow m) 145 | => Int -- ^ Compression level 146 | -> WindowBits -- ^ Zlib parameter (see the zlib-bindings package as well as the zlib C library) 147 | -> ConduitT ByteString ByteString m () 148 | compress = 149 | helperCompress (liftM (fmap Chunk) await) yield' 150 | where 151 | yield' Flush = return () 152 | yield' (Chunk bs) = yield bs 153 | 154 | -- | Same as 'compress', but allows you to explicitly flush the stream. 155 | compressFlush 156 | :: (PrimMonad m, MonadThrow m) 157 | => Int -- ^ Compression level 158 | -> WindowBits -- ^ Zlib parameter (see the zlib-bindings package as well as the zlib C library) 159 | -> ConduitT (Flush ByteString) (Flush ByteString) m () 160 | compressFlush = helperCompress await yield 161 | 162 | helperCompress :: (Monad (t m), PrimMonad m, MonadThrow m, MonadTrans t) 163 | => t m (Maybe (Flush ByteString)) 164 | -> (Flush ByteString -> t m ()) 165 | -> Int 166 | -> WindowBits 167 | -> t m () 168 | helperCompress await' yield' level config = 169 | await' >>= maybe (return ()) start 170 | where 171 | start input = do 172 | def <- lift $ unsafeLiftIO $ initDeflate level config 173 | push def input 174 | 175 | continue def = await' >>= maybe (close def) (push def) 176 | 177 | goPopper popper = do 178 | mbs <- lift $ unsafeLiftIO popper 179 | case mbs of 180 | PRDone -> return () 181 | PRNext bs -> yield' (Chunk bs) >> goPopper popper 182 | PRError e -> lift $ throwM e 183 | 184 | push def (Chunk x) = do 185 | popper <- lift $ unsafeLiftIO $ feedDeflate def x 186 | goPopper popper 187 | continue def 188 | 189 | push def Flush = do 190 | mchunk <- lift $ unsafeLiftIO $ flushDeflate def 191 | case mchunk of 192 | PRDone -> return () 193 | PRNext x -> yield' $ Chunk x 194 | PRError e -> lift $ throwM e 195 | yield' Flush 196 | continue def 197 | 198 | close def = do 199 | mchunk <- lift $ unsafeLiftIO $ finishDeflate def 200 | case mchunk of 201 | PRDone -> return () 202 | PRNext chunk -> yield' (Chunk chunk) >> close def 203 | PRError e -> lift $ throwM e 204 | 205 | -- | The standard 'decompress' and 'ungzip' functions will only decompress a 206 | -- single compressed entity from the stream. This combinator will exhaust the 207 | -- stream completely of all individual compressed entities. This is useful for 208 | -- cases where you have a concatenated archive, e.g. @cat file1.gz file2.gz > 209 | -- combined.gz@. 210 | -- 211 | -- Usage: 212 | -- 213 | -- > sourceFile "combined.gz" $$ multiple ungzip =$ consume 214 | -- 215 | -- This combinator will not fail on an empty stream. If you want to ensure that 216 | -- at least one compressed entity in the stream exists, consider a usage such 217 | -- as: 218 | -- 219 | -- > sourceFile "combined.gz" $$ (ungzip >> multiple ungzip) =$ consume 220 | -- 221 | -- @since 1.1.10 222 | multiple :: Monad m 223 | => ConduitT ByteString a m () 224 | -> ConduitT ByteString a m () 225 | multiple inner = 226 | loop 227 | where 228 | loop = do 229 | mbs <- await 230 | case mbs of 231 | Nothing -> return () 232 | Just bs 233 | | S.null bs -> loop 234 | | otherwise -> do 235 | leftover bs 236 | inner 237 | loop 238 | -------------------------------------------------------------------------------- /conduit-extra/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /conduit-extra/README.md: -------------------------------------------------------------------------------- 1 | ## conduit-extra 2 | 3 | For more information about conduit in general, and how this package in 4 | particular fits into the ecosystem, see [the conduit 5 | homepage](https://github.com/snoyberg/conduit#readme). 6 | -------------------------------------------------------------------------------- /conduit-extra/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /conduit-extra/attic/echo-server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import Data.Conduit 3 | import Data.Conduit.Network 4 | 5 | main :: IO () 6 | main = runTCPServer (serverSettings 3001 "127.0.0.1") echo 7 | 8 | echo :: Application IO 9 | echo app = (appSource app) $$ (appSink app) 10 | -------------------------------------------------------------------------------- /conduit-extra/attic/fibclient.hs: -------------------------------------------------------------------------------- 1 | import Data.Conduit 2 | import Data.Conduit.Network 3 | import Data.Conduit.Binary (sinkHandle) 4 | import System.IO (stdout) 5 | import Data.ByteString.Char8 (ByteString, pack) 6 | import Control.Concurrent (threadDelay, forkIO) 7 | import Control.Monad.IO.Class (MonadIO, liftIO) 8 | 9 | fibs :: MonadIO m => Source m Int 10 | fibs = 11 | go (1, 1) 12 | where 13 | go (x, y) = do 14 | liftIO $ threadDelay 1000000 15 | yield x >> go (y, z) 16 | where 17 | z = x + y 18 | 19 | fibsBS :: MonadIO m => Source m ByteString 20 | fibsBS = mapOutput (\i -> pack $ show i ++ "\n") fibs 21 | 22 | main :: IO () 23 | main = do 24 | runTCPClient (clientSettings 5000 (pack "localhost")) $ \app -> do 25 | forkIO $ fibsBS $$ (appSink app) 26 | (appSource app) $$ sinkHandle stdout 27 | -------------------------------------------------------------------------------- /conduit-extra/attic/udpflow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- Build using threaded RTS 4 | 5 | import Data.Conduit 6 | import Data.Conduit.Network.UDP 7 | import qualified Data.Conduit.List as CL 8 | 9 | import Control.Concurrent (forkIO, killThread, threadDelay) 10 | import Control.Monad.IO.Class (liftIO) 11 | import Data.ByteString.Char8 () 12 | import Network.Socket (addrAddress, connect, sClose) 13 | 14 | localhost :: String 15 | localhost = "127.0.0.1" 16 | port :: Int 17 | port = 4000 18 | 19 | receiver :: IO () 20 | receiver = runResourceT $ src $$ CL.mapM_ (\_ -> return ()) 21 | where 22 | src = bracketP 23 | (bindPort port (Host localhost)) 24 | sClose 25 | (\sock -> sourceSocket sock 4096) 26 | 27 | sender :: IO () 28 | sender = runResourceT $ CL.sourceList (repeat "abc") $$ sink 29 | where 30 | sink = bracketP 31 | (getSocket localhost port) 32 | (sClose . fst) 33 | (\(sock, addr) -> do 34 | liftIO $ connect sock (addrAddress addr) 35 | sinkSocket sock) 36 | 37 | main :: IO () 38 | main = do 39 | rt <- forkIO receiver 40 | st <- forkIO sender 41 | 42 | threadDelay $ 1000 * 1000 * 5 43 | 44 | killThread st 45 | killThread rt 46 | -------------------------------------------------------------------------------- /conduit-extra/bench/blaze.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import Data.Conduit 3 | import qualified Data.Conduit.List as CL 4 | import Data.Conduit.ByteString.Builder 5 | import Gauge.Main 6 | import Data.Monoid 7 | import Data.ByteString.Builder 8 | 9 | count :: Int 10 | count = 100000 11 | 12 | single :: Builder 13 | single = shortByteString "Hello World!\n" 14 | 15 | oneBuilderLeft :: Builder 16 | oneBuilderLeft = 17 | loop count mempty 18 | where 19 | loop 0 b = b 20 | loop i b = loop (i - 1) (b <> single) 21 | 22 | oneBuilderRight :: Builder 23 | oneBuilderRight = 24 | loop count mempty 25 | where 26 | loop 0 b = b 27 | loop i b = loop (i - 1) (b <> single) 28 | 29 | builderSource :: Monad m => ConduitT i Builder m () 30 | builderSource = CL.replicate count single 31 | 32 | oneBSBuilderLeft :: Builder 33 | oneBSBuilderLeft = 34 | loop count mempty 35 | where 36 | loop 0 b = b 37 | loop i b = loop (i - 1) (b <> single) 38 | 39 | oneBSBuilderRight :: Builder 40 | oneBSBuilderRight = 41 | loop count mempty 42 | where 43 | loop 0 b = b 44 | loop i b = loop (i - 1) (b <> single) 45 | 46 | builderBSSource :: Monad m => ConduitT i Builder m () 47 | builderBSSource = CL.replicate count single 48 | 49 | main :: IO () 50 | main = defaultMain 51 | [ bench "conduit, strict, safe" $ whnfIO $ runConduit $ 52 | builderSource .| builderToByteString .| CL.sinkNull 53 | , bench "conduit, strict, unsafe" $ whnfIO $ runConduit $ 54 | builderSource .| unsafeBuilderToByteString .| CL.sinkNull 55 | 56 | , bench "one builder, left" $ nf toLazyByteString oneBuilderLeft 57 | , bench "one builder, right" $ nf toLazyByteString oneBuilderRight 58 | , bench "conduit, lazy" $ flip nf builderSource $ \src -> 59 | toLazyByteString $ runConduitPure $ src .| CL.fold (<>) mempty 60 | 61 | , bench "one bs builder, left" $ nf toLazyByteString oneBSBuilderLeft 62 | , bench "one bs builder, right" $ nf toLazyByteString oneBSBuilderRight 63 | , bench "conduit BS, lazy" $ flip nf builderBSSource $ \src -> 64 | toLazyByteString $ runConduitPure $ src .| CL.fold (<>) mempty 65 | ] 66 | -------------------------------------------------------------------------------- /conduit-extra/conduit-extra.cabal: -------------------------------------------------------------------------------- 1 | Cabal-version: >=1.10 2 | Name: conduit-extra 3 | Version: 1.3.7 4 | Synopsis: Batteries included conduit: adapters for common libraries. 5 | Description: 6 | The conduit package itself maintains relative small dependencies. The purpose of this package is to collect commonly used utility functions wrapping other library dependencies, without depending on heavier-weight dependencies. The basic idea is that this package should only depend on haskell-platform packages and conduit. 7 | License: MIT 8 | License-file: LICENSE 9 | Author: Michael Snoyman 10 | Maintainer: michael@snoyman.com 11 | Category: Data, Conduit 12 | Build-type: Simple 13 | Homepage: http://github.com/snoyberg/conduit 14 | extra-source-files: 15 | test/random 16 | test/filesystem/*.txt 17 | test/filesystem/bin/*.txt 18 | ChangeLog.md 19 | README.md 20 | 21 | Library 22 | default-language: Haskell2010 23 | Exposed-modules: Data.Conduit.Attoparsec 24 | Data.Conduit.Binary 25 | Data.Conduit.ByteString.Builder 26 | Data.Conduit.Filesystem 27 | Data.Conduit.Foldl 28 | Data.Conduit.Lazy 29 | Data.Conduit.Network 30 | Data.Conduit.Network.UDP 31 | Data.Conduit.Network.Unix 32 | Data.Conduit.Process 33 | Data.Conduit.Process.Typed 34 | Data.Conduit.Text 35 | Data.Conduit.Zlib 36 | 37 | if arch(x86_64) || arch(i386) 38 | -- These architectures are able to perform unaligned memory accesses 39 | cpp-options: -DALLOW_UNALIGNED_ACCESS 40 | 41 | Build-depends: base >= 4.12 && < 5 42 | , conduit >= 1.3 && < 1.4 43 | 44 | , bytestring >= 0.10.2 45 | , text 46 | , transformers 47 | 48 | , async 49 | , attoparsec >= 0.10 50 | , directory 51 | , filepath 52 | , network >= 2.3 53 | , primitive >= 0.5 54 | , process 55 | , resourcet >= 1.1 56 | , stm 57 | , streaming-commons >= 0.2.3.0 58 | , unliftio-core 59 | , typed-process >= 0.2.6 60 | 61 | ghc-options: -Wall 62 | 63 | test-suite test 64 | hs-source-dirs: test 65 | default-language: Haskell2010 66 | main-is: Spec.hs 67 | type: exitcode-stdio-1.0 68 | ghc-options: -threaded 69 | cpp-options: -DTEST 70 | build-depends: conduit 71 | , conduit-extra 72 | , base 73 | , hspec >= 1.3 74 | 75 | , async 76 | , attoparsec 77 | , bytestring 78 | , exceptions 79 | , process 80 | , resourcet 81 | , QuickCheck 82 | , stm 83 | , streaming-commons 84 | , text 85 | , transformers 86 | , transformers-base 87 | , directory 88 | , filepath 89 | build-tool-depends: hspec-discover:hspec-discover 90 | ghc-options: -Wall 91 | if os(windows) 92 | cpp-options: -DWINDOWS 93 | other-modules: Data.Conduit.AttoparsecSpec 94 | Data.Conduit.BinarySpec 95 | Data.Conduit.ByteString.BuilderSpec 96 | Data.Conduit.ExtraSpec 97 | Data.Conduit.FilesystemSpec 98 | Data.Conduit.LazySpec 99 | Data.Conduit.NetworkSpec 100 | Data.Conduit.ProcessSpec 101 | Data.Conduit.Process.TypedSpec 102 | Data.Conduit.TextSpec 103 | Data.Conduit.ZlibSpec 104 | 105 | benchmark blaze 106 | default-language: Haskell2010 107 | type: exitcode-stdio-1.0 108 | hs-source-dirs: bench 109 | build-depends: base 110 | , conduit 111 | , conduit-extra 112 | , gauge 113 | , bytestring 114 | , transformers 115 | main-is: blaze.hs 116 | ghc-options: -Wall -O2 -rtsopts 117 | 118 | source-repository head 119 | type: git 120 | location: git://github.com/snoyberg/conduit.git 121 | -------------------------------------------------------------------------------- /conduit-extra/test/Data/Conduit/AttoparsecSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TupleSections #-} 5 | {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} 6 | module Data.Conduit.AttoparsecSpec (spec) where 7 | import Control.Exception (fromException) 8 | import Test.Hspec 9 | 10 | import Control.Applicative ((<*), (<|>)) 11 | import Control.Monad 12 | import qualified Data.Attoparsec.ByteString.Char8 13 | import qualified Data.Attoparsec.Text 14 | import Data.Conduit 15 | import Data.Conduit.Attoparsec 16 | import qualified Data.Conduit.List as CL 17 | 18 | spec :: Spec 19 | spec = describe "Data.Conduit.AttoparsecSpec" $ do 20 | describe "error position" $ do 21 | it "works for text" $ do 22 | let input = ["aaa\na", "aaa\n\n", "aaa", "aab\n\naaaa"] 23 | badLine = 4 24 | badCol = 6 25 | badOff = 15 26 | parser = Data.Attoparsec.Text.endOfInput <|> (Data.Attoparsec.Text.notChar 'b' >> parser) 27 | sink = sinkParser parser 28 | sink' = sinkParserEither parser 29 | ea = runConduit $ CL.sourceList input .| sink 30 | case ea of 31 | Left e -> 32 | case fromException e of 33 | Just pe -> do 34 | errorPosition pe `shouldBe` Position badLine badCol badOff 35 | ea' <- runConduit $ CL.sourceList input .| sink' 36 | case ea' of 37 | Left pe -> 38 | errorPosition pe `shouldBe` Position badLine badCol badOff 39 | it "works for bytestring" $ do 40 | let input = ["aaa\na", "aaa\n\n", "aaa", "aab\n\naaaa"] 41 | badLine = 4 42 | badCol = 6 43 | badOff = 15 44 | parser = Data.Attoparsec.ByteString.Char8.endOfInput <|> (Data.Attoparsec.ByteString.Char8.notChar 'b' >> parser) 45 | sink = sinkParser parser 46 | sink' = sinkParserEither parser 47 | ea = runConduit $ CL.sourceList input .| sink 48 | case ea of 49 | Left e -> 50 | case fromException e of 51 | Just pe -> do 52 | errorPosition pe `shouldBe` Position badLine badCol badOff 53 | ea' <- runConduit $ CL.sourceList input .| sink' 54 | case ea' of 55 | Left pe -> 56 | errorPosition pe `shouldBe` Position badLine badCol badOff 57 | it "works in last chunk" $ do 58 | let input = ["aaa\na", "aaa\n\n", "aaa", "aab\n\naaaa"] 59 | badLine = 6 60 | badCol = 5 61 | badOff = 22 62 | parser = Data.Attoparsec.Text.char 'c' <|> (Data.Attoparsec.Text.anyChar >> parser) 63 | sink = sinkParser parser 64 | sink' = sinkParserEither parser 65 | ea = runConduit $ CL.sourceList input .| sink 66 | case ea of 67 | Left e -> 68 | case fromException e of 69 | Just pe -> do 70 | errorPosition pe `shouldBe` Position badLine badCol badOff 71 | ea' <- runConduit $ CL.sourceList input .| sink' 72 | case ea' of 73 | Left pe -> 74 | errorPosition pe `shouldBe` Position badLine badCol badOff 75 | it "works in last chunk" $ do 76 | let input = ["aaa\na", "aaa\n\n", "aaa", "aa\n\naaaab"] 77 | badLine = 6 78 | badCol = 6 79 | badOff = 22 80 | parser = Data.Attoparsec.Text.string "bc" <|> (Data.Attoparsec.Text.anyChar >> parser) 81 | sink = sinkParser parser 82 | sink' = sinkParserEither parser 83 | ea = runConduit $ CL.sourceList input .| sink 84 | case ea of 85 | Left e -> 86 | case fromException e of 87 | Just pe -> do 88 | errorPosition pe `shouldBe` Position badLine badCol badOff 89 | ea' <- runConduit $ CL.sourceList input .| sink' 90 | case ea' of 91 | Left pe -> 92 | errorPosition pe `shouldBe` Position badLine badCol badOff 93 | it "works after new line in text" $ do 94 | let input = ["aaa\n", "aaa\n\n", "aaa", "aa\nb\naaaa"] 95 | badLine = 5 96 | badCol = 1 97 | badOff = 15 98 | parser = Data.Attoparsec.Text.endOfInput <|> (Data.Attoparsec.Text.notChar 'b' >> parser) 99 | sink = sinkParser parser 100 | sink' = sinkParserEither parser 101 | ea = runConduit $ CL.sourceList input .| sink 102 | case ea of 103 | Left e -> 104 | case fromException e of 105 | Just pe -> do 106 | errorPosition pe `shouldBe` Position badLine badCol badOff 107 | ea' <- runConduit $ CL.sourceList input .| sink' 108 | case ea' of 109 | Left pe -> 110 | errorPosition pe `shouldBe` Position badLine badCol badOff 111 | it "works after new line in bytestring" $ do 112 | let input = ["aaa\n", "aaa\n\n", "aaa", "aa\nb\naaaa"] 113 | badLine = 5 114 | badCol = 1 115 | badOff = 15 116 | parser = Data.Attoparsec.ByteString.Char8.endOfInput <|> (Data.Attoparsec.ByteString.Char8.notChar 'b' >> parser) 117 | sink = sinkParser parser 118 | sink' = sinkParserEither parser 119 | ea = runConduit $ CL.sourceList input .| sink 120 | case ea of 121 | Left e -> 122 | case fromException e of 123 | Just pe -> do 124 | errorPosition pe `shouldBe` Position badLine badCol badOff 125 | ea' <- runConduit $ CL.sourceList input .| sink' 126 | case ea' of 127 | Left pe -> 128 | errorPosition pe `shouldBe` Position badLine badCol badOff 129 | it "works for first line" $ do 130 | let input = ["aab\na", "aaa\n\n", "aaa", "aab\n\naaaa"] 131 | badLine = 1 132 | badCol = 3 133 | badOff = 2 134 | parser = Data.Attoparsec.Text.endOfInput <|> (Data.Attoparsec.Text.notChar 'b' >> parser) 135 | sink = sinkParser parser 136 | sink' = sinkParserEither parser 137 | ea = runConduit $ CL.sourceList input .| sink 138 | case ea of 139 | Left e -> 140 | case fromException e of 141 | Just pe -> do 142 | errorPosition pe `shouldBe` Position badLine badCol badOff 143 | ea' <- runConduit $ CL.sourceList input .| sink' 144 | case ea' of 145 | Left pe -> 146 | errorPosition pe `shouldBe` Position badLine badCol badOff 147 | 148 | describe "conduitParser" $ do 149 | it "parses a repeated stream" $ do 150 | let input = ["aaa\n", "aaa\naaa\n", "aaa\n"] 151 | parser = Data.Attoparsec.Text.string "aaa" <* Data.Attoparsec.Text.endOfLine 152 | sink = conduitParserEither parser .| CL.consume 153 | (Right !ea) = runConduit $ CL.sourceList input .| sink 154 | let chk a = case a of 155 | Left{} -> False 156 | Right (_, xs) -> xs == "aaa" 157 | chkp l = PositionRange (Position l 1 ((l - 1) * 4)) (Position (l+1) 1 (l * 4)) 158 | forM_ ea $ \ a -> a `shouldSatisfy` chk :: Expectation 159 | forM_ (zip ea [1..]) $ \ (Right (pos, _), l) -> pos `shouldBe` chkp l 160 | length ea `shouldBe` 4 161 | 162 | it "positions on first line" $ do 163 | results <- runConduit $ yield "hihihi\nhihi" 164 | .| conduitParser (Data.Attoparsec.Text.string "\n" <|> Data.Attoparsec.Text.string "hi") 165 | .| CL.consume 166 | let f (a, b, c, d, e, f', g) = (PositionRange (Position a b c) (Position d e f'), g) 167 | results `shouldBe` map f 168 | [ (1, 1, 0, 1, 3, 2, "hi") 169 | , (1, 3, 2, 1, 5, 4, "hi") 170 | , (1, 5, 4, 1, 7, 6, "hi") 171 | 172 | , (1, 7, 6, 2, 1, 7, "\n") 173 | 174 | , (2, 1, 7, 2, 3, 9, "hi") 175 | , (2, 3, 9, 2, 5, 11, "hi") 176 | ] 177 | -------------------------------------------------------------------------------- /conduit-extra/test/Data/Conduit/ByteString/BuilderSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Data.Conduit.ByteString.BuilderSpec (spec) where 3 | 4 | import Test.Hspec 5 | import Test.Hspec.QuickCheck (prop) 6 | 7 | import Data.Conduit ((.|), runConduit, Flush (..)) 8 | import qualified Data.Conduit.List as CL 9 | import Data.Conduit.ByteString.Builder (builderToByteString, builderToByteStringFlush) 10 | import Control.Monad.ST (runST) 11 | import qualified Data.ByteString as S 12 | import Data.ByteString.Builder (byteString, toLazyByteString) 13 | import Data.ByteString.Builder.Internal (lazyByteStringInsert, flush) 14 | import qualified Data.ByteString.Lazy as L 15 | 16 | spec :: Spec 17 | spec = 18 | describe "Data.Conduit.ByteString.Builder" $ do 19 | prop "idempotent to toLazyByteString" $ \bss' -> runST $ do 20 | let bss = map S.pack bss' 21 | let builders = map byteString bss 22 | let lbs = toLazyByteString $ mconcat builders 23 | let src = mconcat $ map (CL.sourceList . return) builders 24 | outBss <- runConduit $ src .| builderToByteString .| CL.consume 25 | return $ lbs == L.fromChunks outBss 26 | 27 | it "works for large input" $ do 28 | let builders = replicate 10000 (byteString "hello world!") 29 | let lbs = toLazyByteString $ mconcat builders 30 | let src = mconcat $ map (CL.sourceList . return) builders 31 | outBss <- runConduit $ src .| builderToByteString .| CL.consume 32 | lbs `shouldBe` L.fromChunks outBss 33 | 34 | it "works for lazy bytestring insertion" $ do 35 | let builders = replicate 10000 (lazyByteStringInsert "hello world!") 36 | let lbs = toLazyByteString $ mconcat builders 37 | let src = mconcat $ map (CL.sourceList . return) builders 38 | outBss <- runConduit $ src .| builderToByteString .| CL.consume 39 | lbs `shouldBe` L.fromChunks outBss 40 | 41 | it "flush shouldn't bring in empty strings." $ do 42 | let dat = ["hello", "world"] 43 | src = CL.sourceList dat .| CL.map ((`mappend` flush) . byteString) 44 | out <- runConduit $ src .| builderToByteString .| CL.consume 45 | dat `shouldBe` out 46 | 47 | prop "flushing" $ \bss' -> runST $ do 48 | let bss = concatMap (\bs -> [Chunk $ S.pack bs, Flush]) $ filter (not . null) bss' 49 | let chunks = map (fmap byteString) bss 50 | let src = CL.sourceList chunks 51 | outBss <- runConduit $ src .| builderToByteStringFlush .| CL.consume 52 | if bss == outBss then return () else error (show (bss, outBss)) 53 | return $ bss == outBss 54 | it "large flush input" $ do 55 | let lbs = L.pack $ concat $ replicate 100000 [0..255] 56 | let chunks = map (Chunk . byteString) (L.toChunks lbs) 57 | let src = CL.sourceList chunks 58 | bss <- runConduit $ src .| builderToByteStringFlush .| CL.consume 59 | let unFlush (Chunk x) = [x] 60 | unFlush Flush = [] 61 | L.fromChunks (concatMap unFlush bss) `shouldBe` lbs 62 | -------------------------------------------------------------------------------- /conduit-extra/test/Data/Conduit/ExtraSpec.hs: -------------------------------------------------------------------------------- 1 | module Data.Conduit.ExtraSpec where 2 | 3 | import Data.Conduit 4 | import Test.Hspec 5 | import Test.Hspec.QuickCheck 6 | import Data.Conduit.List (isolate, peek, consume) 7 | import qualified Data.Conduit.List as CL 8 | import qualified Data.Text as T 9 | import qualified Data.Text.Encoding as T 10 | import qualified Data.ByteString as S 11 | import qualified Data.Conduit.Text as CT 12 | 13 | spec :: Spec 14 | spec = describe "Data.Conduit.Extra" $ do 15 | it "basic test" $ do 16 | let sink2 :: ConduitT a o IO (Maybe a, Maybe a) 17 | sink2 = do 18 | ma1 <- fuseLeftovers id (isolate 10) peek 19 | ma2 <- peek 20 | return (ma1, ma2) 21 | 22 | source = yield 1 >> yield 2 23 | res <- runConduit $ source .| sink2 24 | res `shouldBe` (Just 1, Just (1 :: Int)) 25 | 26 | it "get leftovers" $ do 27 | let sink2 :: ConduitT a o IO ([a], [a], [a]) 28 | sink2 = do 29 | (x, y) <- fuseReturnLeftovers (isolate 2) peek3 30 | z <- CL.consume 31 | return (x, y, z) 32 | 33 | peek3 = do 34 | x <- CL.take 3 35 | mapM_ leftover $ reverse x 36 | return x 37 | 38 | source = mapM_ yield [1..5 :: Int] 39 | res <- runConduit $ source .| sink2 40 | res `shouldBe` ([1..2], [1..2], [3..5]) 41 | 42 | it "multiple values" $ do 43 | let sink2 :: ConduitT a o IO ([a], Maybe a) 44 | sink2 = do 45 | ma1 <- fuseLeftovers id (isolate 10) peek3 46 | ma2 <- peek 47 | return (ma1, ma2) 48 | 49 | peek3 = do 50 | x <- CL.take 3 51 | mapM_ leftover $ reverse x 52 | return x 53 | 54 | source = mapM_ yield [1..5] 55 | res <- runConduit $ source .| sink2 56 | res `shouldBe` ([1..3], Just (1 :: Int)) 57 | 58 | prop "more complex" $ \ss cnt -> do 59 | let ts = map T.pack ss 60 | src = mapM_ (yield . T.encodeUtf8) ts 61 | conduit = CL.map T.decodeUtf8 62 | sink = CT.take cnt .| consume 63 | undo = return . T.encodeUtf8 . T.concat 64 | res <- runConduit $ src .| do 65 | x <- fuseLeftovers undo conduit sink 66 | y <- consume 67 | return (T.concat x, T.decodeUtf8 $ S.concat y) 68 | res `shouldBe` T.splitAt cnt (T.concat ts) 69 | 70 | main :: IO () 71 | main = hspec spec 72 | -------------------------------------------------------------------------------- /conduit-extra/test/Data/Conduit/FilesystemSpec.hs: -------------------------------------------------------------------------------- 1 | module Data.Conduit.FilesystemSpec (spec) where 2 | 3 | import Test.Hspec 4 | import Data.Conduit 5 | import qualified Data.Conduit.List as CL 6 | import Data.Conduit.Filesystem 7 | import Data.List (sort, isSuffixOf) 8 | import System.FilePath (()) 9 | 10 | spec :: Spec 11 | spec = describe "Data.Conduit.Filesystem" $ do 12 | it "sourceDirectory" $ do 13 | res <- runConduitRes 14 | $ sourceDirectory ("test" "filesystem") 15 | .| CL.filter (not . (".swp" `isSuffixOf`)) 16 | .| CL.consume 17 | sort res `shouldBe` 18 | [ "test" "filesystem" "bar.txt" 19 | , "test" "filesystem" "baz.txt" 20 | , "test" "filesystem" "bin" 21 | , "test" "filesystem" "foo.txt" 22 | ] 23 | it "sourceDirectoryDeep" $ do 24 | res1 <- runConduitRes 25 | $ sourceDirectoryDeep False ("test" "filesystem") 26 | .| CL.filter (not . (".swp" `isSuffixOf`)) 27 | .| CL.consume 28 | res2 <- runConduitRes 29 | $ sourceDirectoryDeep True ("test" "filesystem") 30 | .| CL.filter (not . (".swp" `isSuffixOf`)) 31 | .| CL.consume 32 | sort res1 `shouldBe` 33 | [ "test" "filesystem" "bar.txt" 34 | , "test" "filesystem" "baz.txt" 35 | , "test" "filesystem" "bin" "bin.txt" 36 | , "test" "filesystem" "foo.txt" 37 | ] 38 | sort res1 `shouldBe` sort res2 39 | -------------------------------------------------------------------------------- /conduit-extra/test/Data/Conduit/LazySpec.hs: -------------------------------------------------------------------------------- 1 | module Data.Conduit.LazySpec (spec) where 2 | 3 | import qualified Data.Conduit.Lazy as CLazy 4 | import Test.Hspec 5 | import Control.Monad.IO.Class 6 | import qualified Data.Conduit as C 7 | import qualified Data.Conduit.Binary as CB 8 | import Control.Monad.Trans.Resource 9 | import qualified Data.IORef as I 10 | import Control.Monad (forever) 11 | 12 | spec :: Spec 13 | spec = describe "Data.Conduit.Lazy" $ do 14 | 15 | describe "lazy" $ do 16 | it' "works inside a ResourceT" $ runResourceT $ do 17 | counter <- liftIO $ I.newIORef 0 18 | let incr i = do 19 | istate <- liftIO $ I.newIORef $ Just (i :: Int) 20 | let loop = do 21 | res <- liftIO $ I.atomicModifyIORef istate ((,) Nothing) 22 | case res of 23 | Nothing -> return () 24 | Just x -> do 25 | count <- liftIO $ I.atomicModifyIORef counter 26 | (\j -> (j + 1, j + 1)) 27 | liftIO $ count `shouldBe` i 28 | C.yield x 29 | loop 30 | loop 31 | nums <- CLazy.lazyConsume $ mconcat $ map incr [1..10] 32 | liftIO $ nums `shouldBe` [1..10] 33 | 34 | it' "returns nothing outside ResourceT" $ do 35 | bss <- runResourceT $ CLazy.lazyConsume $ CB.sourceFile "test/main.hs" 36 | bss `shouldBe` [] 37 | 38 | it' "works with pure sources" $ do 39 | nums <- CLazy.lazyConsume $ forever $ C.yield 1 40 | take 100 nums `shouldBe` replicate 100 (1 :: Int) 41 | 42 | it' :: String -> IO () -> Spec 43 | it' = it 44 | -------------------------------------------------------------------------------- /conduit-extra/test/Data/Conduit/NetworkSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Data.Conduit.NetworkSpec (spec) where 3 | 4 | import Data.Conduit 5 | import Data.Conduit.Network 6 | import Control.Concurrent (forkIO, threadDelay, putMVar, newEmptyMVar, takeMVar, killThread) 7 | import Control.Monad (replicateM_) 8 | import Test.Hspec 9 | 10 | spec :: Spec 11 | spec = describe "Data.Conduit.Network" $ do 12 | describe "run general server" $ do 13 | it "running tcp server" $ do 14 | _ <- forkIO $ runTCPServer (serverSettings 4009 "*4") echo 15 | threadDelay 1000000 16 | replicateM_ 100 17 | $ runTCPClient (clientSettings 4009 "127.0.0.1") doNothing 18 | describe "fork server" $ do 19 | it "can connect to server" $ do 20 | let set = serverSettings 4010 "*4" 21 | threadId <- forkTCPServer set echo 22 | replicateM_ 100 23 | $ runTCPClient (clientSettings 4010 "127.0.0.1") doNothing 24 | killThread threadId 25 | 26 | it "fork server also executes custom afterBind" $ do 27 | assertMVar <- newEmptyMVar 28 | let set = serverSettings 4010 "*4" 29 | setWithAfterBind = setAfterBind (\_ -> putMVar assertMVar ()) set 30 | threadId <- forkTCPServer setWithAfterBind echo 31 | takeMVar assertMVar 32 | killThread threadId 33 | 34 | it "fork server really waits for server to be finalized before returning" $ do 35 | let set = serverSettings 4010 "*4" 36 | setWithAfterBind = setAfterBind (\_ -> threadDelay 1000000) set 37 | threadId <- forkTCPServer setWithAfterBind echo 38 | replicateM_ 100 39 | $ runTCPClient (clientSettings 4010 "127.0.0.1") doNothing 40 | killThread threadId 41 | 42 | 43 | 44 | echo :: AppData -> IO () 45 | echo ad = runConduit $ appSource ad .| appSink ad 46 | 47 | doNothing :: AppData -> IO () 48 | doNothing _ = return () 49 | -------------------------------------------------------------------------------- /conduit-extra/test/Data/Conduit/Process/TypedSpec.hs: -------------------------------------------------------------------------------- 1 | module Data.Conduit.Process.TypedSpec (spec) where 2 | 3 | import Test.Hspec 4 | import Data.Conduit 5 | import Data.Conduit.Process.Typed 6 | import qualified Data.Conduit.List as CL 7 | import qualified Data.ByteString as B 8 | 9 | spec :: Spec 10 | spec = do 11 | it "cat works" $ do 12 | let fp = "ChangeLog.md" 13 | pc = setStdout createSource $ proc "cat" [fp] 14 | bs <- B.readFile fp 15 | bss <- withProcess_ pc $ \p -> 16 | runConduit (getStdout p .| CL.consume) <* waitExitCode p 17 | B.concat bss `shouldBe` bs 18 | it "cat works with withLoggedProcess_" $ do 19 | let fp = "ChangeLog.md" 20 | pc = proc "cat" [fp] 21 | bs <- B.readFile fp 22 | bss <- withLoggedProcess_ pc $ \p -> 23 | runConduit (getStdout p .| CL.consume) <* waitExitCode p 24 | B.concat bss `shouldBe` bs 25 | it "failing process throws" $ do 26 | (withLoggedProcess_ (proc "cat" ["does not exist"]) $ \p -> do 27 | runConduit $ getStdout p .| CL.mapM_ (error "shouldn't have data")) 28 | `shouldThrow` anyException 29 | it "failing process throws" $ do 30 | (withProcess_ (proc "cat" ["does not exist"]) $ const $ return ()) 31 | `shouldThrow` anyException 32 | -------------------------------------------------------------------------------- /conduit-extra/test/Data/Conduit/ProcessSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Data.Conduit.ProcessSpec (spec, main) where 4 | 5 | import Test.Hspec 6 | import Test.Hspec.QuickCheck (prop) 7 | import Data.Conduit 8 | import qualified Data.Conduit.List as CL 9 | import Data.Conduit.Process 10 | import Control.Concurrent.Async (concurrently) 11 | import qualified Data.ByteString.Lazy as L 12 | import qualified Data.ByteString as S 13 | import qualified Data.ByteString.Char8 as S8 14 | import System.Exit 15 | import Control.Concurrent (threadDelay) 16 | 17 | main :: IO () 18 | main = hspec spec 19 | 20 | spec :: Spec 21 | spec = describe "Data.Conduit.Process" $ do 22 | #ifndef WINDOWS 23 | prop "cat" $ \wss -> do 24 | let lbs = L.fromChunks $ map S.pack wss 25 | ((sink, closeStdin), source, Inherited, cph) <- streamingProcess (shell "cat") 26 | ((), bss) <- concurrently 27 | (do 28 | runConduit $ mapM_ yield (L.toChunks lbs) .| sink 29 | closeStdin) 30 | (runConduit $ source .| CL.consume) 31 | L.fromChunks bss `shouldBe` lbs 32 | ec <- waitForStreamingProcess cph 33 | ec `shouldBe` ExitSuccess 34 | 35 | it "closed stream" $ do 36 | (ClosedStream, source, Inherited, cph) <- streamingProcess (shell "cat") 37 | bss <- runConduit $ source .| CL.consume 38 | bss `shouldBe` [] 39 | 40 | ec <- waitForStreamingProcess cph 41 | ec `shouldBe` ExitSuccess 42 | 43 | it "handles sub-process exit code" $ do 44 | (sourceCmdWithConsumer "exit 0" CL.sinkNull) 45 | `shouldReturn` (ExitSuccess, ()) 46 | (sourceCmdWithConsumer "exit 11" CL.sinkNull) 47 | `shouldReturn` (ExitFailure 11, ()) 48 | (sourceCmdWithConsumer "exit 12" CL.sinkNull) 49 | `shouldReturn` (ExitFailure 12, ()) 50 | (sourceCmdWithStreams "exit 0" CL.sourceNull CL.sinkNull CL.sinkNull) 51 | `shouldReturn` (ExitSuccess, (), ()) 52 | (sourceCmdWithStreams "exit 11" CL.sourceNull CL.sinkNull CL.sinkNull) 53 | `shouldReturn` (ExitFailure 11, (), ()) 54 | (sourceCmdWithStreams "exit 12" CL.sourceNull CL.sinkNull CL.sinkNull) 55 | `shouldReturn` (ExitFailure 12, (), ()) 56 | 57 | it "consumes stdout" $ do 58 | let mystr = "this is a test string" :: String 59 | sourceCmdWithStreams ("bash -c \"echo -n " ++ mystr ++ "\"") 60 | CL.sourceNull 61 | CL.consume -- stdout 62 | CL.consume -- stderr 63 | `shouldReturn` (ExitSuccess, [S8.pack mystr], []) 64 | 65 | it "consumes stderr" $ do 66 | let mystr = "this is a test string" :: String 67 | sourceCmdWithStreams ("bash -c \">&2 echo -n " ++ mystr ++ "\"") 68 | CL.sourceNull 69 | CL.consume -- stdout 70 | CL.consume -- stderr 71 | `shouldReturn` (ExitSuccess, [], [S8.pack mystr]) 72 | 73 | it "feeds stdin" $ do 74 | let mystr = "this is a test string" :: S.ByteString 75 | sourceCmdWithStreams "cat" 76 | (yield mystr) 77 | CL.consume -- stdout 78 | CL.consume -- stderr 79 | `shouldReturn` (ExitSuccess, [mystr], []) 80 | #endif 81 | it "blocking vs non-blocking" $ do 82 | (ClosedStream, ClosedStream, ClosedStream, cph) <- streamingProcess (shell "sleep 1") 83 | 84 | mec1 <- getStreamingProcessExitCode cph 85 | mec1 `shouldBe` Nothing 86 | 87 | threadDelay 1500000 88 | 89 | -- For slow systems where sleep may take longer than 1.5 seconds, do 90 | -- this in a loop. 91 | let loop 0 = error "Took too long for sleep to exit, your system is acting funny" 92 | loop i = do 93 | mec2 <- getStreamingProcessExitCode cph 94 | case mec2 of 95 | Nothing -> do 96 | threadDelay 500000 97 | loop (pred i) 98 | Just _ -> mec2 `shouldBe` Just ExitSuccess 99 | loop (5 :: Int) 100 | 101 | ec <- waitForStreamingProcess cph 102 | ec `shouldBe` ExitSuccess 103 | -------------------------------------------------------------------------------- /conduit-extra/test/Data/Conduit/ZlibSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | module Data.Conduit.ZlibSpec (spec) where 6 | 7 | import Test.Hspec 8 | import Test.Hspec.QuickCheck (prop) 9 | 10 | import Data.Conduit ((.|), runConduit) 11 | import qualified Data.Conduit as C 12 | import qualified Data.Conduit.List as CL 13 | import qualified Data.Conduit.Zlib as CZ 14 | import qualified Data.ByteString as S 15 | import qualified Data.ByteString.Lazy as L 16 | import Data.ByteString.Char8 () 17 | import Data.ByteString.Lazy.Char8 () 18 | import Control.Monad (replicateM_) 19 | 20 | spec :: Spec 21 | spec = describe "Data.Conduit.Zlib" $ do 22 | prop "idempotent" $ \bss' -> do 23 | let bss = map S.pack bss' 24 | lbs = L.fromChunks bss 25 | src = mconcat $ map (CL.sourceList . return) bss 26 | outBss <- runConduit $ src .| CZ.gzip .| CZ.ungzip .| CL.consume 27 | L.fromChunks outBss `shouldBe` lbs 28 | prop "flush" $ \bss' -> do 29 | let bss = map S.pack $ filter (not . null) bss' 30 | bssC = concatMap (\bs -> [C.Chunk bs, C.Flush]) bss 31 | src = mconcat $ map (CL.sourceList . return) bssC 32 | outBssC <- runConduit 33 | $ src 34 | .| CZ.compressFlush 5 (CZ.WindowBits 31) 35 | .| CZ.decompressFlush (CZ.WindowBits 31) 36 | .| CL.consume 37 | outBssC `shouldBe` bssC 38 | it "compressFlush large data" $ do 39 | let content = L.pack $ map (fromIntegral . fromEnum) $ concat $ ["BEGIN"] ++ map show [1..100000 :: Int] ++ ["END"] 40 | src = CL.sourceList $ map C.Chunk $ L.toChunks content 41 | bssC <- runConduit $ src .| CZ.compressFlush 5 (CZ.WindowBits 31) .| CL.consume 42 | let unChunk (C.Chunk x) = [x] 43 | unChunk C.Flush = [] 44 | bss <- runConduit $ CL.sourceList bssC .| CL.concatMap unChunk .| CZ.ungzip .| CL.consume 45 | L.fromChunks bss `shouldBe` content 46 | 47 | it "uncompressed after compressed" $ do 48 | let c = "This data is stored compressed." 49 | u = "This data isn't." 50 | let src1 = do 51 | C.yield c .| CZ.gzip 52 | C.yield u 53 | encoded <- runConduit $ src1 .| CL.consume 54 | let src2 = mapM_ C.yield encoded 55 | (c', u') <- runConduit $ src2 .| do 56 | c' <- CZ.ungzip .| CL.consume 57 | u' <- CL.consume 58 | return (S.concat c', S.concat u') 59 | c' `shouldBe` c 60 | u' `shouldBe` u 61 | 62 | it "multiple compressed values" $ do 63 | let s1 = "hello" 64 | s2 = "world" 65 | src = do 66 | C.yield s1 .| CZ.gzip 67 | C.yield s2 .| CZ.gzip 68 | actual <- runConduit $ src .| CZ.multiple CZ.ungzip .| CL.consume 69 | S.concat actual `shouldBe` S.concat [s1, s2] 70 | 71 | it "single compressed, multiple uncompressed chunks" $ do 72 | let s1 = "hello" 73 | s2 = "there" 74 | s3 = "world" 75 | s1Z <- fmap S.concat $ runConduit $ C.yield s1 .| CZ.gzip .| CL.consume 76 | let src = do 77 | C.yield $ S.append s1Z s2 78 | C.yield s3 79 | actual <- runConduit $ src .| do 80 | x <- fmap S.concat $ CZ.ungzip .| CL.consume 81 | y <- CL.consume 82 | return (x, y) 83 | actual `shouldBe` (s1, [s2, s3]) 84 | 85 | it "multiple, over 32k" $ do 86 | let str = "One line" 87 | cnt = 30000 88 | src = replicateM_ cnt $ C.yield str .| CZ.gzip 89 | actual <- fmap S.concat $ runConduit $ src .| CZ.multiple CZ.ungzip .| CL.consume 90 | let expected = S.concat (replicate cnt str) 91 | S.length actual `shouldBe` S.length expected 92 | actual `shouldBe` expected 93 | -------------------------------------------------------------------------------- /conduit-extra/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /conduit-extra/test/filesystem/bar.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/snoyberg/conduit/0cd209d4a8ed63aa007e65ad13c3ab15ea57badd/conduit-extra/test/filesystem/bar.txt -------------------------------------------------------------------------------- /conduit-extra/test/filesystem/baz.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/snoyberg/conduit/0cd209d4a8ed63aa007e65ad13c3ab15ea57badd/conduit-extra/test/filesystem/baz.txt -------------------------------------------------------------------------------- /conduit-extra/test/filesystem/bin/bin.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/snoyberg/conduit/0cd209d4a8ed63aa007e65ad13c3ab15ea57badd/conduit-extra/test/filesystem/bin/bin.txt -------------------------------------------------------------------------------- /conduit-extra/test/filesystem/foo.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/snoyberg/conduit/0cd209d4a8ed63aa007e65ad13c3ab15ea57badd/conduit-extra/test/filesystem/foo.txt -------------------------------------------------------------------------------- /conduit-extra/test/random: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/snoyberg/conduit/0cd209d4a8ed63aa007e65ad13c3ab15ea57badd/conduit-extra/test/random -------------------------------------------------------------------------------- /conduit/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # ChangeLog for conduit 2 | 3 | ## 1.3.6.1 4 | 5 | * Forward compatibility with `-Wnoncanonical-monad-instances` becoming an error 6 | 7 | ## 1.3.6 8 | 9 | * Avoid dropping upstream items in `mergeSource` [#513](https://github.com/snoyberg/conduit/pull/513) 10 | 11 | ## 1.3.5 12 | 13 | * Add `groupOn` 14 | 15 | ## 1.3.4.3 16 | 17 | * Fix space leak in `*>` [#496](https://github.com/snoyberg/conduit/issues/496) [#497](https://github.com/snoyberg/conduit/pull/497) 18 | 19 | ## 1.3.4.2 20 | 21 | * Fix GHC 9.2 build [#473](https://github.com/snoyberg/conduit/pull/473) 22 | 23 | ## 1.3.4.1 24 | 25 | * Library and tests compile and run with GHC 9.0.1 [#455](https://github.com/snoyberg/conduit/pull/455) 26 | 27 | ## 1.3.4 28 | 29 | * Add `foldWhile` [#453](https://github.com/snoyberg/conduit/issues/453) [#456](https://github.com/snoyberg/conduit/pull/456). 30 | 31 | ## 1.3.3 32 | 33 | * Add `uncons`, `unconsM`, `unconsEither`, `unconsEitherM`. 34 | 35 | ## 1.3.2.1 36 | 37 | * Fix isChunksForExactlyE [#445](https://github.com/snoyberg/conduit/issues/445) [#446](https://github.com/snoyberg/conduit/pull/446) 38 | 39 | ## 1.3.2 40 | 41 | * Add `mapInputM` [#435](https://github.com/snoyberg/conduit/pull/435) 42 | 43 | ## 1.3.1.2 44 | 45 | * More eagerly emit groups in `chunksOf` [#427](https://github.com/snoyberg/conduit/pull/427) 46 | 47 | ## 1.3.1.1 48 | 49 | * Use lower-case imports (better for cross-compilation) [#408](https://github.com/snoyberg/conduit/pull/408) 50 | 51 | ## 1.3.1 52 | 53 | * Add `MonadFail` instance for `ConduitT`. 54 | 55 | ## 1.3.0.3 56 | 57 | * Improve fusion framework rewrite rules 58 | 59 | ## 1.3.0.2 60 | 61 | * Replace `ReadMode` with `WriteMode` in `withSinkFile` 62 | 63 | ## 1.3.0.1 64 | 65 | * Test suite compatibility with GHC 8.4.1 [#358](https://github.com/snoyberg/conduit/issues/358) 66 | 67 | ## 1.3.0 68 | 69 | * Drop monad-control and exceptions in favor of unliftio 70 | * Drop mmorph dependency 71 | * Deprecate old type synonyms and operators 72 | * Drop finalizers from the library entirely 73 | * Much simpler 74 | * Less guarantees about prompt finalization 75 | * No more `yieldOr`, `addCleanup` 76 | * Replace the `Resumable` types with `SealedConduitT` 77 | * Add the `Conduit` and `Data.Conduit.Combinators` modules, stolen from 78 | `conduit-combinators` 79 | 80 | ## 1.2.13 81 | 82 | * Add `Semigroup` instances [#345](https://github.com/snoyberg/conduit/pull/345) 83 | 84 | ## 1.2.12.1 85 | 86 | * Fix `pass` in `ConduitM` `MonadWriter` instance 87 | 88 | ## 1.2.12 89 | 90 | * Add `exceptC`, `runExceptC` and `catchExceptC` to `Data.Conduit.Lift` 91 | 92 | ## 1.2.11 93 | 94 | * Add `unfoldEither` and `unfoldEitherM` to `Data.Conduit.List` 95 | 96 | ## 1.2.10 97 | 98 | * Add `PrimMonad` instances for `ConduitM` and `Pipe` 99 | [#306](https://github.com/snoyberg/conduit/pull/306) 100 | 101 | ## 1.2.9.1 102 | 103 | * Ensure downstream and inner sink receive same inputs in 104 | `passthroughSink` 105 | [#304](https://github.com/snoyberg/conduit/issues/304) 106 | 107 | ## 1.2.9 108 | 109 | * `chunksOf` [#296](https://github.com/snoyberg/conduit/pull/296) 110 | 111 | ## 1.2.8 112 | 113 | * Implement 114 | [the reskinning idea](http://www.snoyman.com/blog/2016/09/proposed-conduit-reskin): 115 | * `.|` 116 | * `runConduitPure` 117 | * `runConduitRes` 118 | 119 | ## 1.2.7 120 | 121 | * Expose yieldM for ConduitM [#270](https://github.com/snoyberg/conduit/pull/270) 122 | 123 | ## 1.2.6.6 124 | 125 | * Fix test suite compilation on older GHCs 126 | 127 | ## 1.2.6.5 128 | 129 | * In zipConduitApp, left bias not respected mixing monadic and non-monadic conduits [#263](https://github.com/snoyberg/conduit/pull/263) 130 | 131 | ## 1.2.6.4 132 | 133 | * Fix benchmark by adding a type signature 134 | 135 | ## 1.2.6.3 136 | 137 | * Doc updates 138 | 139 | ## 1.2.6.2 140 | 141 | * resourcet cannot be built with GHC 8 [#242](https://github.com/snoyberg/conduit/issues/242) 142 | * Remove upper bound on transformers [#253](https://github.com/snoyberg/conduit/issues/253) 143 | 144 | ## 1.2.6 145 | 146 | * `sourceToList` 147 | * Canonicalise Monad instances [#237](https://github.com/snoyberg/conduit/pull/237) 148 | 149 | ## 1.2.5 150 | 151 | * mapAccum and mapAccumM should be strict in their state [#218](https://github.com/snoyberg/conduit/issues/218) 152 | 153 | ## 1.2.4.1 154 | 155 | * Some documentation improvements 156 | 157 | ## 1.2.4 158 | 159 | * [fuseBothMaybe](https://github.com/snoyberg/conduit/issues/199) 160 | 161 | __1.2.3__ Expose `connect` and `fuse` as synonyms for `$$` and `=$=`, respectively. 162 | 163 | __1.2.2__ Lots more stream fusion. 164 | 165 | __1.2__ Two performance optimizations added. (1) A stream fusion framework. This is a non-breaking change. (2) Codensity transform applied to the `ConduitM` datatype. This only affects users importing the `.Internal` module. Both changes are thoroughly described in the following to blog posts: [Speeding up conduit](https://www.fpcomplete.com/blog/2014/08/iap-speeding-up-conduit), and [conduit stream fusion](https://www.fpcomplete.com/blog/2014/08/conduit-stream-fusion). 166 | 167 | __1.1__ Refactoring into conduit and conduit-extra packages. Core functionality is now in conduit, whereas most common helper modules (including Text, Binary, Zlib, etc) are in conduit-extra. To upgrade to this version, there should only be import list and conduit file changes necessary. 168 | 169 | __1.0__ Simplified the user-facing interface back to the Source, Sink, and Conduit types, with Producer and Consumer for generic code. Error messages have been simplified, and optional leftovers and upstream terminators have been removed from the external API. Some long-deprecated functions were finally removed. 170 | 171 | __0.5__ The internals of the package are now separated to the .Internal module, leaving only the higher-level interface in the advertised API. Internally, switched to a `Leftover` constructor and slightly tweaked the finalization semantics. 172 | 173 | __0.4__ Inspired by the design of the pipes package: we now have a single unified type underlying `Source`, `Sink`, and `Conduit`. This type is named `Pipe`. There are type synonyms provided for the other three types. Additionally, `BufferedSource` is no longer provided. Instead, the connect-and-resume operator, `$$+`, can be used for the same purpose. 174 | 175 | __0.3__ ResourceT has been greatly simplified, specialized for IO, and moved into a separate package. Instead of hard-coding ResourceT into the conduit datatypes, they can now live around any monad. The Conduit datatype has been enhanced to better allow generation of streaming output. The SourceResult, SinkResult, and ConduitResult datatypes have been removed entirely. 176 | 177 | __0.2__ Instead of storing state in mutable variables, we now use CPS. A `Source` returns the next `Source`, and likewise for `Sink`s and `Conduit`s. Not only does this take better advantage of GHC\'s optimizations (about a 20% speedup), but it allows some operations to have a reduction in algorithmic complexity from exponential to linear. This also allowed us to remove the `Prepared` set of types. Also, the `State` functions (e.g., `sinkState`) use better constructors for return types, avoiding the need for a dummy state on completion. 178 | 179 | __0.1__ `BufferedSource` is now an abstract type, and has a much more efficient internal representation. The result was a 41% speedup on microbenchmarks (note: do not expect speedups anywhere near that in real usage). In general, we are moving towards `BufferedSource` being a specific tool used internally as needed, but using `Source` for all external APIs. 180 | 181 | __0.0__ Initial release. 182 | -------------------------------------------------------------------------------- /conduit/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /conduit/README.md: -------------------------------------------------------------------------------- 1 | ## conduit 2 | 3 | `conduit` is a solution to the streaming data problem, allowing for production, 4 | transformation, and consumption of streams of data in constant memory. It is an 5 | alternative to lazy I\/O which guarantees deterministic resource handling. 6 | 7 | For more information about conduit in general, and how this package in 8 | particular fits into the ecosystem, see [the conduit 9 | homepage](https://github.com/snoyberg/conduit#readme). 10 | -------------------------------------------------------------------------------- /conduit/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /conduit/benchmarks/bench-lift.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Trans.State.Strict 2 | import Criterion.Main 3 | import Data.Conduit 4 | import Data.Conduit.Internal (ConduitM (..), Pipe (..)) 5 | import qualified Data.Conduit.Lift as CLift 6 | import qualified Data.Conduit.List as CL 7 | import Data.Functor.Identity 8 | 9 | main :: IO () 10 | main = defaultMain 11 | [ bgroup "Strict StateT" $ 12 | let sink :: Sink Int (State Int) () 13 | sink = CL.mapM_ $ modify . (+) 14 | src = mapM_ yield [1..1000 :: Int] 15 | in [ bench "generic" $ whnf (\i -> runIdentity $ src $$ CLift.execStateC i sink) 0 16 | , bench "specialized" $ whnf (\i -> runIdentity $ src $$ execStateC i sink) 0 17 | ] 18 | ] 19 | 20 | runStateC 21 | :: Monad m => 22 | s -> ConduitM b o (StateT s m) r -> ConduitM b o m (r, s) 23 | runStateC s0 (ConduitM c0) = 24 | ConduitM (go s0 c0) 25 | where 26 | go s (Done r) = Done (r, s) 27 | go s (PipeM (StateT f)) = PipeM $ do 28 | (c, s') <- f s 29 | return $ go s' c 30 | go s (Leftover c i) = Leftover (go s c) i 31 | go s (HaveOutput c f o) = HaveOutput (go s c) (evalStateT f s) o 32 | go s (NeedInput x y) = NeedInput (go s . x) (go s . y) 33 | 34 | execStateC 35 | :: Monad m => 36 | b -> ConduitM b1 o (StateT b m) () -> ConduitM b1 o m b 37 | execStateC s p = fmap snd $ runStateC s p 38 | -------------------------------------------------------------------------------- /conduit/benchmarks/benchmark.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | import Control.Monad 6 | import Control.Monad.Identity 7 | import Criterion.Main 8 | import Data.Conduit 9 | import qualified Data.Conduit.Combinators as C 10 | import Data.Conduit.List (consume) 11 | import Data.Maybe 12 | import Data.MonoTraversable 13 | import Data.Monoid 14 | import qualified Data.NonNull as NonNull 15 | import Data.Sequence as S 16 | import qualified Data.Sequences as Seq 17 | import Data.Sequences.Lazy 18 | import qualified Data.Text as T 19 | import Prelude 20 | 21 | maximumC :: (Monad m, Ord a) => ConduitT a o m (Maybe a) 22 | maximumC = 23 | await >>= maybe (return Nothing) loop 24 | where 25 | loop prev = await >>= maybe (return $ Just prev) (loop . max prev) 26 | {-# INLINE maximumC #-} 27 | 28 | allC :: Monad m 29 | => (a -> Bool) 30 | -> ConduitT a o m Bool 31 | allC f = fmap isNothing $ C.find (Prelude.not . f) 32 | {-# INLINE allC #-} 33 | 34 | allOld :: Monad m 35 | => (a -> Bool) 36 | -> ConduitT a o m Bool 37 | allOld f = 38 | loop 39 | where 40 | loop = await >>= maybe (return True) go 41 | go x = if f x then loop else return False 42 | {-# INLINE allOld #-} 43 | 44 | foldl1E f = foldC (foldMaybeNull f) Nothing 45 | {-# INLINE foldl1E #-} 46 | 47 | -- Helper for foldl1E 48 | foldMaybeNull :: (MonoFoldable mono, e ~ Element mono) 49 | => (e -> e -> e) 50 | -> Maybe e 51 | -> mono 52 | -> Maybe e 53 | foldMaybeNull f macc mono = 54 | case (macc, NonNull.fromNullable mono) of 55 | (Just acc, Just nn) -> Just $ ofoldl' f acc nn 56 | (Nothing, Just nn) -> Just $ NonNull.ofoldl1' f nn 57 | _ -> macc 58 | {-# INLINE foldMaybeNull #-} 59 | 60 | foldC :: Monad m 61 | => (b -> a -> b) 62 | -> b 63 | -> ConduitT a o m b 64 | foldC f = 65 | loop 66 | where 67 | loop !accum = await >>= maybe (return accum) (loop . f accum) 68 | {-# INLINE foldC #-} 69 | 70 | maximumEOld :: (Monad m, Seq.OrdSequence seq) => ConduitT seq o m (Maybe (Element seq)) 71 | maximumEOld = 72 | start 73 | where 74 | start = await >>= maybe (return Nothing) start' 75 | start' x = 76 | case NonNull.fromNullable x of 77 | Nothing -> start 78 | Just y -> loop $ NonNull.maximum y 79 | loop prev = await >>= maybe (return $ Just prev) (loop . ofoldl' max prev) 80 | {-# INLINE maximumEOld #-} 81 | 82 | linesUnboundedOld :: (Monad m, Seq.IsSequence seq, Element seq ~ Char) 83 | => Conduit seq m seq 84 | linesUnboundedOld = 85 | start 86 | where 87 | start = await >>= maybe (return ()) loop 88 | 89 | loop t = 90 | if onull y 91 | then do 92 | mt <- await 93 | case mt of 94 | Nothing -> unless (onull t) $ yield t 95 | Just t' -> loop (t `mappend` t') 96 | else yield x >> loop (Seq.drop 1 y) 97 | where 98 | (x, y) = Seq.break (== '\n') t 99 | {-# INLINE linesUnboundedOld #-} 100 | 101 | splitOnUnboundedEC 102 | :: (Monad m, Seq.IsSequence seq) 103 | => (Element seq -> Bool) -> Conduit seq m seq 104 | splitOnUnboundedEC f = 105 | start 106 | where 107 | start = await >>= maybe (return ()) loop 108 | 109 | loop t = 110 | if onull y 111 | then do 112 | mt <- await 113 | case mt of 114 | Nothing -> unless (onull t) $ yield t 115 | Just t' -> loop (t `mappend` t') 116 | else yield x >> loop (Seq.drop 1 y) 117 | where 118 | (x, y) = Seq.break f t 119 | {-# INLINE splitOnUnboundedEC #-} 120 | 121 | #define RUN_SINK_N(n, consumer) \ 122 | flip whnf (n :: Int) $ \upper -> \ 123 | runIdentity $ \ 124 | C.enumFromTo 1 upper \ 125 | $$ C.map (+2) \ 126 | $= C.map (+1) \ 127 | $= consumer 128 | 129 | #define RUN_SINK(consumer) RUN_SINK_N(100000, consumer) 130 | 131 | main = defaultMain 132 | -- Benchmarks for 'all' 133 | [ bench "fused all" $ 134 | RUN_SINK(C.all (<90000)) 135 | , bench "unfused all" $ 136 | RUN_SINK(allC (<90000)) 137 | , bench "unfused all (old version)" $ 138 | RUN_SINK(allOld (<90000)) 139 | -- Benchmarks for 'maximumE' 140 | , bench "fused maximumE" $ 141 | RUN_SINK(C.map (\n -> S.replicate (n `mod` 20) n) =$= C.maximumE) 142 | , bench "unfused maximumE" $ 143 | RUN_SINK(C.map (\n -> S.replicate (n `mod` 20) n) =$= foldl1E max) 144 | , bench "unfused maximumE (old version)" $ 145 | RUN_SINK(C.map (\n -> S.replicate (n `mod` 20) n) =$= maximumEOld) 146 | -- Benchmarks for 'linesUnbounded' 147 | , bench "fused linesUnbounded" $ 148 | RUN_SINK_N(1000, C.map (\n -> T.replicate (n `mod` 20) (T.singleton (toEnum n))) =$= C.linesUnbounded =$= C.map T.length =$= C.sum) 149 | , bench "unfused linesUnbounded" $ 150 | RUN_SINK_N(1000, C.map (\n -> T.replicate (n `mod` 20) (T.singleton (toEnum n))) =$= splitOnUnboundedEC (== '\n') =$= C.map T.length =$= C.sum) 151 | , bench "unfused linesUnbounded (old version)" $ 152 | RUN_SINK_N(1000, C.map (\n -> T.replicate (n `mod` 20) (T.singleton (toEnum n))) =$= linesUnboundedOld =$= C.map T.length =$= C.sum) 153 | ] 154 | -------------------------------------------------------------------------------- /conduit/benchmarks/bind-bench.hs: -------------------------------------------------------------------------------- 1 | import Criterion.Main 2 | import qualified Data.Conduit as C 3 | import qualified Data.Conduit.List as CL 4 | import Control.Monad (foldM) 5 | import Data.List (foldl') 6 | 7 | input :: [Int] 8 | input = [1..100 :: Int] 9 | 10 | main :: IO () 11 | main = defaultMain 12 | [ bench "bind" $ nfIO $ C.runResourceT $ CL.sourceList input C.$$ bindSink 0 13 | , bench "no bind" $ nfIO $ C.runResourceT $ CL.sourceList input C.$$ CL.fold (+) 0 14 | , bench "no conduits" $ nfIO $ foldM plusM 0 input 15 | , bench "pure" $ nf (foldl' (+) 0) input 16 | ] 17 | 18 | plusM a b = return (a + b) 19 | 20 | bindSink accum = do 21 | mx <- CL.head 22 | case mx of 23 | Nothing -> return accum 24 | Just x -> let y = x + accum in y `seq` bindSink y 25 | 26 | {- 27 | Original results, conduit 0.1.2: 28 | 29 | benchmarking bind 30 | mean: 4.353290 ms, lb 4.339886 ms, ub 4.367442 ms, ci 0.950 31 | std dev: 70.51453 us, lb 59.84734 us, ub 86.26725 us, ci 0.950 32 | found 4 outliers among 100 samples (4.0%) 33 | 3 (3.0%) high mild 34 | variance introduced by outliers: 9.404% 35 | variance is slightly inflated by outliers 36 | 37 | benchmarking no bind 38 | mean: 456.1767 us, lb 454.7851 us, ub 457.9179 us, ci 0.950 39 | std dev: 7.919169 us, lb 6.413626 us, ub 9.522540 us, ci 0.950 40 | found 13 outliers among 100 samples (13.0%) 41 | 2 (2.0%) low mild 42 | 11 (11.0%) high severe 43 | variance introduced by outliers: 10.373% 44 | variance is moderately inflated by outliers 45 | 46 | benchmarking no conduits 47 | mean: 12.09150 us, lb 12.05770 us, ub 12.12638 us, ci 0.950 48 | std dev: 176.9865 ns, lb 151.5837 ns, ub 211.4992 ns, ci 0.950 49 | found 2 outliers among 100 samples (2.0%) 50 | 2 (2.0%) high mild 51 | variance introduced by outliers: 7.533% 52 | variance is slightly inflated by outliers 53 | 54 | benchmarking pure 55 | mean: 1.371857 us, lb 1.360364 us, ub 1.383382 us, ci 0.950 56 | std dev: 58.94660 ns, lb 52.55791 ns, ub 66.36883 ns, ci 0.950 57 | variance introduced by outliers: 40.507% 58 | variance is moderately inflated by outliers 59 | 60 | -} 61 | -------------------------------------------------------------------------------- /conduit/benchmarks/fusion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | module Main where 4 | 5 | import Criterion.Main 6 | import Data.Conduit 7 | import qualified Data.Conduit.List as CL 8 | import Data.Functor.Identity (runIdentity) 9 | import Data.Monoid 10 | 11 | foldMapC :: (Monad m, Monoid b) 12 | => (a -> b) 13 | -> ConduitT a o m b 14 | foldMapC f = let combiner accum = mappend accum . f in CL.fold combiner mempty 15 | {-# INLINE foldMapC #-} 16 | 17 | groupByC :: Monad m => (a -> a -> Bool) -> ConduitT a [a] m () 18 | groupByC f = 19 | start 20 | where 21 | start = await >>= maybe (return ()) (loop id) 22 | 23 | loop rest x = 24 | await >>= maybe (yield (x : rest [])) go 25 | where 26 | go y 27 | | f x y = loop (rest . (y:)) x 28 | | otherwise = yield (x : rest []) >> loop id y 29 | {-# INLINE groupByC #-} 30 | 31 | main :: IO () 32 | main = defaultMain 33 | [ -- groupByS is the most complicated streaming function - let's 34 | -- check if the fusion buys us anything. This is also 35 | -- benchmarked as it shows that functions that use the 36 | -- STREAMING macro do indeed fuse. 37 | bgroup "groupBy" 38 | [ bench "fused" $ flip whnf upper0 $ \upper -> 39 | runIdentity 40 | $ CL.enumFromTo 1 upper 41 | $$ CL.map (`div` 10) 42 | =$ CL.groupBy (==) 43 | =$ CL.map length 44 | =$ CL.fold (+) 0 45 | , bench "unfused" $ flip whnf upper0 $ \upper -> 46 | runIdentity 47 | $ CL.enumFromTo 1 upper 48 | $$ CL.map (`div` 10) 49 | =$ groupByC (==) 50 | =$ CL.map length 51 | =$ CL.fold (+) 0 52 | -- Does fusion also benefit groupByS when it's run in the IO 53 | -- monad? 54 | , bench "fused, running on IO" $ whnfIO $ 55 | CL.enumFromTo 1 upper0 56 | $$ CL.map (`div` 10) 57 | =$ CL.groupBy (==) 58 | =$ CL.map length 59 | =$ CL.fold (+) 0 60 | , bench "unfused, running on IO" $ whnfIO $ 61 | CL.enumFromTo 1 upper0 62 | $$ CL.map (`div` 10) 63 | =$ groupByC (==) 64 | =$ CL.map length 65 | =$ CL.fold (+) 0 66 | ] 67 | -- foldMap uses the INLINE_RULE macro to implement fusion. Here, 68 | -- we benchmark to check that this provides performance 69 | -- improvements. 70 | , bgroup "foldMap" 71 | [ bench "fused" $ flip whnf upper0 $ \upper -> 72 | runIdentity 73 | $ CL.enumFromTo 1 upper 74 | $$ CL.map (`div` 2) 75 | =$ CL.foldMap Sum 76 | , bench "unfused" $ flip whnf upper0 $ \upper -> 77 | runIdentity 78 | $ CL.enumFromTo 1 upper 79 | $$ CL.map (`div` 2) 80 | =$ foldMapC Sum 81 | , bench "fused, running on IO" $ whnfIO $ 82 | CL.enumFromTo 1 upper0 83 | $$ CL.map (`div` 2) 84 | =$ CL.foldMap Sum 85 | , bench "unfused, running on IO" $ whnfIO $ 86 | CL.enumFromTo 1 upper0 87 | $$ CL.map (`div` 2) 88 | =$ foldMapC Sum 89 | ] 90 | ] 91 | where 92 | upper0 = 100000 :: Int 93 | -------------------------------------------------------------------------------- /conduit/benchmarks/main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | import Criterion.Main 3 | import qualified Data.Conduit as C 4 | import qualified Data.Conduit.Internal as CI 5 | import qualified Data.Conduit.List as CL 6 | import qualified Data.Conduit.Binary as CB 7 | import Data.Functor.Identity (Identity, runIdentity) 8 | import Control.Monad.ST (runST) 9 | import Control.Monad (foldM) 10 | import Data.List (foldl') 11 | import "pipes" Control.Pipe 12 | import Data.Void 13 | import Control.Applicative 14 | import Data.Maybe 15 | import qualified "pipes-core" Control.Pipe as PC 16 | import qualified "pipes-core" Control.Pipe.Combinators as PCC 17 | import qualified "conduitfour" Data.Conduit as C4 18 | import qualified "conduitfour" Data.Conduit.List as CL4 19 | import qualified "conduitfour" Data.Conduit.Binary as CB4 20 | import qualified Data.ByteString as S 21 | import Control.Monad.Trans.Resource 22 | import Control.Monad.Trans.Class (lift) 23 | import qualified System.IO as SIO 24 | import qualified "pipes-core" Control.Pipe.Exception as PCE 25 | 26 | main :: IO () 27 | main = defaultMain 28 | [ bgroup "bigsum" 29 | [ bench "conduit5" $ whnf (\i -> (runIdentity $ CL.sourceList [1..1000 :: Int] C.$$ CL.fold (+) i)) 0 30 | , bench "conduit5->+>" $ whnf (\i -> (runIdentity $ C.runPipe $ CL.sourceList [1..1000 :: Int] C.>+> CL.fold (+) i)) 0 31 | , bench "conduit5-resume" $ flip whnf 0 $ \i -> runIdentity $ do 32 | (rsrc, res) <- CL.sourceList [1..1000 :: Int] C.$$+ CL.fold (+) i 33 | rsrc C.$$+- return () 34 | , bench "conduit4" $ whnf (\i -> (runIdentity $ CL4.sourceList [1..1000 :: Int] C4.$$ CL4.fold (+) i)) 0 35 | , bench "pipes" $ whnf pipeTestSum 0 36 | , bench "pipes-core" $ whnf pipeCoreTest 0 37 | , bench "pipes-core-seq" $ whnf pipeCoreTestSeq 0 38 | , bench "pure" $ whnf (\i -> foldl' (+) i [1..1000 :: Int]) 0 39 | ] 40 | , bgroup "bytecount" 41 | [ bench "conduit5" (whnfIO $ C.runResourceT $ CB.sourceFile "foo" C.$$ CL.fold (\x bs -> x + S.length bs) 0) 42 | , bench "conduit5->+>" (whnfIO $ C.runResourceT $ C.runPipe $ CB.sourceFile "foo" C.>+> CL.fold (\x bs -> x + S.length bs) 0) 43 | , bench "conduit5-resume" $ whnfIO $ C.runResourceT $ do 44 | (rsrc, res) <- CB.sourceFile "foo" C.$$+ CL.fold (\x bs -> x + S.length bs) 0 45 | rsrc C.$$+- return () 46 | return res 47 | , bench "conduit4" (whnfIO $ C4.runResourceT $ CB4.sourceFile "foo" C4.$$ CL4.fold (\x bs -> x + S.length bs) 0) 48 | , bench "pipes" (whnfIO pipeTestCount) 49 | , bench "pipes-resource" (whnfIO pipeTestResource) 50 | , bench "pipes-core" (whnfIO pipesCoreTest) 51 | , bench "pipes-core-resource" (whnfIO pipesCoreTestResource) 52 | ] 53 | ] 54 | 55 | pipeFold :: Monad m => (b -> a -> b) -> b -> Frame a o m b 56 | pipeFold f = 57 | Frame . go 58 | where 59 | go accum = do 60 | mx <- await 61 | case mx of 62 | Nothing -> return $ return accum 63 | Just x -> 64 | let accum' = f accum x 65 | in accum' `seq` go accum 66 | 67 | pipeSourceList :: Monad m => [a] -> Frame i a m () 68 | pipeSourceList list = Frame $ do 69 | mapM_ yieldF list 70 | close $ return () 71 | 72 | pipeTestSum :: Int -> Int 73 | pipeTestSum start = fromMaybe (-1) $ runIdentity $ runFrame $ (Just <$> pipeFold (+) start) <-< (Nothing <$ pipeSourceList [1..1000 :: Int]) 74 | 75 | pipesCoreFold :: Monad m => (b -> a -> b) -> b -> PC.Pipe a x m b 76 | pipesCoreFold f = go 77 | where 78 | go x = PCC.tryAwait >>= maybe (return x) (let y = f x in y `seq` go . y) 79 | 80 | pipeCoreTest :: Int -> Int 81 | pipeCoreTest start = fromMaybe (-1) $ runIdentity $ PC.runPurePipe_ $ PCC.fromList [1..1000 :: Int] PCC.$$ PCC.fold (+) start 82 | 83 | pipeCoreTestSeq :: Int -> Int 84 | pipeCoreTestSeq start = fromMaybe (-1) $ runIdentity $ PC.runPurePipe_ $ PCC.fromList [1..1000 :: Int] PCC.$$ pipesCoreFold (+) start 85 | 86 | sourceFilePipes :: FilePath -> Frame i S.ByteString IO Int 87 | sourceFilePipes file = Frame $ close $ do 88 | h <- lift $ SIO.openBinaryFile file SIO.ReadMode 89 | finallyP (SIO.hClose h) (pull h) 90 | where 91 | pull h = do 92 | bs <- lift $ S.hGetSome h 4096 93 | if S.null bs 94 | then return 0 95 | else do 96 | yieldF bs 97 | pull h 98 | 99 | sourceFilePipesResource :: FilePath -> Frame i S.ByteString (ResourceT IO) Int 100 | sourceFilePipesResource file = Frame $ close $ do 101 | (key, h) <- lift $ allocate (SIO.openBinaryFile file SIO.ReadMode) SIO.hClose 102 | finallyP (release key) (pull h) 103 | where 104 | pull h = do 105 | bs <- lift $ lift $ S.hGetSome h 4096 106 | if S.null bs 107 | then return (-2) 108 | else do 109 | yieldF bs 110 | pull h 111 | 112 | pipeTestCount = runFrame $ pipeFold (\x bs -> x + S.length bs) 0 <-< (sourceFilePipes "foo") 113 | pipeTestResource = runResourceT $ runFrame $ pipeFold (\x bs -> x + S.length bs) 0 <-< (sourceFilePipesResource "foo") 114 | 115 | sourceFilePipesCore :: FilePath -> PC.Pipe i S.ByteString IO Int 116 | sourceFilePipesCore file = 117 | PCE.bracket 118 | (SIO.openBinaryFile file SIO.ReadMode) 119 | SIO.hClose 120 | pull 121 | where 122 | pull h = do 123 | bs <- lift $ S.hGetSome h 4096 124 | if S.null bs 125 | then return 0 126 | else do 127 | PC.yield bs 128 | pull h 129 | 130 | sourceFilePipesCoreResource :: FilePath -> PC.Pipe i S.ByteString (ResourceT IO) Int 131 | sourceFilePipesCoreResource file = 132 | PCE.bracket 133 | (allocate (SIO.openBinaryFile file SIO.ReadMode) SIO.hClose) 134 | (release . fst) 135 | (pull . snd) 136 | where 137 | pull h = do 138 | bs <- lift $ lift $ S.hGetSome h 4096 139 | if S.null bs 140 | then return 0 141 | else do 142 | PC.yield bs 143 | pull h 144 | 145 | pipesCoreTest = PC.runPipe $ sourceFilePipesCore "foo" PCC.$$ PCC.fold (\x bs -> x + S.length bs) 0 146 | pipesCoreTestResource = runResourceT $ PC.runPurePipe_ $ sourceFilePipesCoreResource "foo" PCC.$$ PCC.fold (\x bs -> x + S.length bs) 0 147 | -------------------------------------------------------------------------------- /conduit/benchmarks/maximum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | import Control.Monad 3 | import Control.Monad.Identity 4 | import Criterion.Main 5 | import Data.Conduit 6 | import qualified Data.Conduit.Combinators as C 7 | import Data.Conduit.List (consume) 8 | import Data.Maybe 9 | import Prelude 10 | 11 | {- I get output like this, which justifies the new definition: 12 | 13 | benchmarking old maximum 14 | time 6.000 ns (5.994 ns .. 6.008 ns) 15 | 1.000 R² (1.000 R² .. 1.000 R²) 16 | mean 5.997 ns (5.992 ns .. 6.004 ns) 17 | std dev 19.62 ps (15.78 ps .. 25.19 ps) 18 | 19 | benchmarking fold maximum 20 | time 4.514 ns (4.510 ns .. 4.518 ns) 21 | 1.000 R² (1.000 R² .. 1.000 R²) 22 | mean 4.510 ns (4.505 ns .. 4.516 ns) 23 | std dev 18.15 ps (13.74 ps .. 25.97 ps) 24 | 25 | -} 26 | 27 | -- Old definition 28 | maximum1 :: (Monad m, Ord a) => ConduitT a o m (Maybe a) 29 | maximum1 = 30 | await >>= maybe (return Nothing) loop 31 | where 32 | loop prev = await >>= maybe (return $ Just prev) (loop . max prev) 33 | {-# INLINE [0] maximum1 #-} 34 | 35 | maximum2 :: (Monad m, Ord a) => ConduitT a o m (Maybe a) 36 | maximum2 = C.foldl1 max 37 | {-# INLINE [0] maximum2 #-} 38 | 39 | main = defaultMain 40 | [ bench "old maximum" $ runSink maximum1 41 | , bench "fold maximum" $ runSink maximum2 42 | ] 43 | 44 | runSink :: Sink Int Identity b -> Benchmarkable 45 | runSink f = error "runSink inlining didn't happen" 46 | {-# NOINLINE runSink #-} 47 | {-# RULES "define runSink" forall f. 48 | runSink f = 49 | flip whnf () $ \() -> 50 | runIdentity $ 51 | C.enumFromTo 1 (100000 :: Int) 52 | $$ C.map (+1) 53 | $= C.map (+2) 54 | $= f 55 | #-} 56 | -------------------------------------------------------------------------------- /conduit/benchmarks/scanl-bench.hs: -------------------------------------------------------------------------------- 1 | import Criterion.Main 2 | import Data.Conduit 3 | import qualified Data.Conduit.List as CL 4 | import qualified Data.Foldable as F 5 | import Control.Monad (replicateM_) 6 | import Data.Functor.Identity 7 | 8 | test name f = 9 | bench name $ flip nf 200 $ \i -> runIdentity (replicateM_ i (yield ()) $= f (\_ _ -> ((), Nothing)) () $= CL.catMaybes $$ CL.sinkNull) 10 | 11 | cScanl :: Monad m => (a -> s -> (s, b)) -> s -> ConduitT a b m () 12 | cScanl step = loop where 13 | loop state = 14 | do ma <- await 15 | case ma of 16 | Nothing -> return () 17 | Just a -> let ~(newState, b) = step a state in yield b >> loop newState 18 | 19 | scanlOrig :: Monad m => (a -> s -> (s,b)) -> s -> ConduitT a b m () 20 | scanlOrig f = 21 | loop 22 | where 23 | loop s = await >>= F.mapM_ go 24 | where 25 | go a = case f a s of 26 | (s',b) -> yield b >> loop s' 27 | 28 | scanlOrigTweaked :: Monad m => (a -> s -> (s,b)) -> s -> ConduitT a b m () 29 | scanlOrigTweaked f = 30 | loop 31 | where 32 | loop s = await >>= maybe (return ()) go 33 | where 34 | go a = case f a s of 35 | (s',b) -> yield b >> loop s' 36 | 37 | main = defaultMain 38 | [ test "Data.Conduit.List.scanl" CL.scanl 39 | , test "Miguel's" cScanl 40 | , test "orig" scanlOrig 41 | , test "orig tweaked" scanlOrigTweaked 42 | ] 43 | -------------------------------------------------------------------------------- /conduit/benchmarks/unfused.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, BangPatterns #-} 2 | -- Compare low-level, fused, unfused, and partially fused 3 | import Data.Conduit 4 | import qualified Data.Conduit.List as CL 5 | import Gauge.Main 6 | 7 | -- | unfused 8 | enumFromToC :: (Eq a, Monad m, Enum a) => a -> a -> ConduitT i a m () 9 | enumFromToC x0 y = 10 | loop x0 11 | where 12 | loop x 13 | | x == y = yield x 14 | | otherwise = yield x >> loop (succ x) 15 | {-# INLINE enumFromToC #-} 16 | 17 | -- | unfused 18 | mapC :: Monad m => (a -> b) -> ConduitT a b m () 19 | mapC f = awaitForever $ yield . f 20 | {-# INLINE mapC #-} 21 | 22 | -- | unfused 23 | foldC :: Monad m => (b -> a -> b) -> b -> ConduitT a o m b 24 | foldC f = 25 | loop 26 | where 27 | loop !b = await >>= maybe (return b) (loop . f b) 28 | {-# INLINE foldC #-} 29 | 30 | main :: IO () 31 | main = defaultMain 32 | [ bench "low level" $ flip whnf upper0 $ \upper -> 33 | let loop x t 34 | | x > upper = t 35 | | otherwise = loop (x + 1) (t + ((x * 2) + 1)) 36 | in loop 1 0 37 | , bench "completely fused" $ flip whnf upper0 $ \upper -> 38 | runConduitPure 39 | $ CL.enumFromTo 1 upper 40 | .| CL.map (* 2) 41 | .| CL.map (+ 1) 42 | .| CL.fold (+) 0 43 | , bench "runConduit, completely fused" $ flip whnf upper0 $ \upper -> 44 | runConduitPure 45 | $ CL.enumFromTo 1 upper 46 | .| CL.map (* 2) 47 | .| CL.map (+ 1) 48 | .| CL.fold (+) 0 49 | , bench "completely unfused" $ flip whnf upper0 $ \upper -> 50 | runConduitPure 51 | $ enumFromToC 1 upper 52 | .| mapC (* 2) 53 | .| mapC (+ 1) 54 | .| foldC (+) 0 55 | , bench "beginning fusion" $ flip whnf upper0 $ \upper -> 56 | runConduitPure 57 | $ (CL.enumFromTo 1 upper .| CL.map (* 2)) 58 | .| mapC (+ 1) 59 | .| foldC (+) 0 60 | , bench "middle fusion" $ flip whnf upper0 $ \upper -> 61 | runConduitPure 62 | $ enumFromToC 1 upper 63 | .| (CL.map (* 2) .| CL.map (+ 1)) 64 | .| foldC (+) 0 65 | , bench "ending fusion" $ flip whnf upper0 $ \upper -> 66 | runConduitPure 67 | $ enumFromToC 1 upper 68 | .| mapC (* 2) 69 | .| (CL.map (+ 1) .| CL.fold (+) 0) 70 | , bench "performance of CL.enumFromTo without fusion" $ flip whnf upper0 $ \upper -> 71 | runConduitPure 72 | $ CL.enumFromTo 1 upper 73 | .| mapC (* 2) 74 | .| (CL.map (+ 1) .| CL.fold (+) 0) 75 | ] 76 | where 77 | upper0 = 100000 :: Int 78 | -------------------------------------------------------------------------------- /conduit/benchmarks/utf8-bench.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | import Data.Conduit 3 | import qualified Data.Conduit.Text as CT 4 | import qualified OldText as OT 5 | import Criterion.Main 6 | import qualified Data.Text as T 7 | import qualified Data.Text.Lazy as TL 8 | import qualified Data.Text.Lazy.Encoding as TLE 9 | import qualified Data.ByteString as S 10 | import qualified Data.ByteString.Lazy as L 11 | import qualified Data.Conduit.List as CL 12 | import Data.Text.StreamDecoding 13 | import Data.Text.Encoding (decodeUtf8) 14 | 15 | lengthT :: Monad m => ConduitT T.Text o m Int 16 | lengthT = CL.fold (\x y -> x + T.length y) 0 17 | 18 | main :: IO () 19 | main = do 20 | bs <- S.readFile "utf8-bench.hs" 21 | let bss = replicate 1000 bs 22 | src = mapM_ yield bss 23 | lbs = L.fromChunks bss 24 | defaultMain 25 | [ bench "old conduit" $ whnf (\src' -> runException_ $ src' $$ OT.decode OT.utf8 =$ lengthT) src 26 | , bench "lazy text" $ whnf (TL.length . TLE.decodeUtf8) lbs 27 | , bench "new conduit" $ whnf (\src' -> runException_ $ src' $$ CT.decode CT.utf8 =$ lengthT) src 28 | , bench "stream" $ whnf calcLen bss 29 | -- , bench "stream fake" $ whnf (calcLen2 bss) 0 30 | ] 31 | 32 | calcLen [] = 0 33 | calcLen (bs0:bss0) = 34 | loop (streamUtf8 bs0) bss0 0 35 | where 36 | loop (DecodeResultSuccess t next) bss total = 37 | let total' = total + T.length t 38 | in case bss of 39 | [] -> total' 40 | bs:bss' -> total' `seq` loop (next bs) bss' total' 41 | {- 42 | 43 | calcLen [] = id 44 | calcLen (bs0:bss0) = 45 | loop (streamUtf8 bs0) bss0 46 | where 47 | loop t bss total = 48 | let total' = total + T.length t 49 | in case bss of 50 | [] -> total' 51 | bs:bss' -> total' `seq` loop (streamUtf8 bs) bss' total' 52 | 53 | calcLen2 [] = id 54 | calcLen2 (bs0:bss0) = 55 | loop (decodeUtf8 bs0) bss0 56 | where 57 | loop t bss total = 58 | let total' = total + T.length t 59 | in case bss of 60 | [] -> total' 61 | bs:bss' -> total' `seq` loop (decodeUtf8 bs) bss' total' 62 | -} 63 | -------------------------------------------------------------------------------- /conduit/benchmarks/utf8-memory-usage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import Control.Monad (replicateM_) 3 | import Data.ByteString (ByteString) 4 | import Data.Conduit 5 | import qualified Data.Conduit.List as CL 6 | import Data.Conduit.Text (decode, utf8) 7 | 8 | src :: Source IO ByteString 9 | src = replicateM_ 1000000 $ yield "Hello World!\n" 10 | 11 | main :: IO () 12 | main = src $$ decode utf8 =$ CL.sinkNull 13 | -------------------------------------------------------------------------------- /conduit/conduit.cabal: -------------------------------------------------------------------------------- 1 | Name: conduit 2 | Version: 1.3.6.1 3 | Synopsis: Streaming data processing library. 4 | description: 5 | `conduit` is a solution to the streaming data problem, allowing for production, 6 | transformation, and consumption of streams of data in constant memory. It is an 7 | alternative to lazy I\/O which guarantees deterministic resource handling. 8 | . 9 | For more information about conduit in general, and how this package in 10 | particular fits into the ecosystem, see [the conduit 11 | homepage](https://github.com/snoyberg/conduit#readme). 12 | . 13 | Hackage documentation generation is not reliable. For up to date documentation, please see: . 14 | License: MIT 15 | License-file: LICENSE 16 | Author: Michael Snoyman 17 | Maintainer: michael@snoyman.com 18 | Category: Data, Conduit 19 | Build-type: Simple 20 | Cabal-version: >=1.10 21 | Homepage: http://github.com/snoyberg/conduit 22 | extra-source-files: test/main.hs 23 | , test/doctests.hs 24 | , test/subdir/dummyfile.txt 25 | , README.md 26 | , ChangeLog.md 27 | , fusion-macros.h 28 | 29 | Library 30 | default-language: Haskell2010 31 | hs-source-dirs: src 32 | Exposed-modules: Data.Conduit 33 | Data.Conduit.Combinators 34 | Data.Conduit.List 35 | Data.Conduit.Internal 36 | Data.Conduit.Lift 37 | Data.Conduit.Internal.Fusion 38 | Data.Conduit.Internal.List.Stream 39 | Data.Conduit.Combinators.Stream 40 | Conduit 41 | other-modules: Data.Conduit.Internal.Pipe 42 | Data.Conduit.Internal.Conduit 43 | Data.Conduit.Combinators.Unqualified 44 | Data.Streaming.FileRead 45 | Data.Streaming.Filesystem 46 | Build-depends: base >= 4.12 && < 5 47 | , resourcet >= 1.2 && < 1.4 48 | , transformers >= 0.4 49 | , mtl 50 | , primitive 51 | , unliftio-core 52 | , exceptions 53 | , mono-traversable >= 1.0.7 54 | , vector 55 | , bytestring 56 | , text 57 | , filepath 58 | , directory 59 | 60 | if os(windows) 61 | build-depends: Win32 62 | other-modules: System.Win32File 63 | cpp-options: -DWINDOWS 64 | else 65 | build-depends: unix 66 | 67 | ghc-options: -Wall 68 | include-dirs: . 69 | 70 | test-suite conduit-test 71 | default-language: Haskell2010 72 | hs-source-dirs: test 73 | main-is: main.hs 74 | other-modules: Data.Conduit.Extra.ZipConduitSpec 75 | , Data.Conduit.StreamSpec 76 | , Spec 77 | , StreamSpec 78 | type: exitcode-stdio-1.0 79 | cpp-options: -DTEST 80 | build-depends: conduit 81 | , base 82 | , hspec >= 1.3 83 | , QuickCheck >= 2.7 84 | , transformers 85 | , mtl 86 | , resourcet 87 | , containers 88 | , exceptions >= 0.6 89 | , safe 90 | , split >= 0.2.0.0 91 | , mono-traversable 92 | , text 93 | , vector 94 | , directory 95 | , bytestring 96 | , silently 97 | , filepath 98 | , unliftio >= 0.2.4.0 99 | ghc-options: -Wall 100 | 101 | if os(windows) 102 | cpp-options: -DWINDOWS 103 | 104 | --test-suite doctests 105 | -- hs-source-dirs: test 106 | -- main-is: doctests.hs 107 | -- type: exitcode-stdio-1.0 108 | -- ghc-options: -threaded 109 | -- build-depends: base, directory, doctest >= 0.8 110 | 111 | -- benchmark utf8-memory-usage 112 | -- type: exitcode-stdio-1.0 113 | -- hs-source-dirs: benchmarks 114 | -- build-depends: base 115 | -- , text-stream-decode 116 | -- , bytestring 117 | -- , text 118 | -- , conduit 119 | -- main-is: utf8-memory-usage.hs 120 | -- ghc-options: -Wall -O2 -with-rtsopts=-s 121 | 122 | benchmark optimize-201408 123 | default-language: Haskell2010 124 | type: exitcode-stdio-1.0 125 | hs-source-dirs: benchmarks 126 | build-depends: base 127 | , conduit 128 | , vector 129 | , deepseq 130 | , containers 131 | , transformers 132 | , hspec 133 | , mwc-random 134 | , gauge 135 | main-is: optimize-201408.hs 136 | ghc-options: -Wall -O2 -rtsopts 137 | 138 | benchmark unfused 139 | default-language: Haskell2010 140 | type: exitcode-stdio-1.0 141 | hs-source-dirs: benchmarks 142 | build-depends: base 143 | , conduit 144 | , gauge 145 | , transformers 146 | main-is: unfused.hs 147 | ghc-options: -Wall -O2 -rtsopts 148 | 149 | source-repository head 150 | type: git 151 | location: git://github.com/snoyberg/conduit.git 152 | -------------------------------------------------------------------------------- /conduit/fusion-macros.h: -------------------------------------------------------------------------------- 1 | #define INLINE_RULE0(new,old) ;\ 2 | new = old ;\ 3 | {-# INLINE [0] new #-} ;\ 4 | {-# RULES "inline new" new = old #-} 5 | 6 | #define INLINE_RULE(new,vars,body) ;\ 7 | new vars = body ;\ 8 | {-# INLINE [0] new #-} ;\ 9 | {-# RULES "inline new" forall vars. new vars = body #-} 10 | 11 | #define STREAMING0(name, nameC, nameS) ;\ 12 | name = nameC ;\ 13 | {-# INLINE [0] name #-} ;\ 14 | {-# RULES "unstream name" \ 15 | name = unstream (streamConduit nameC nameS) \ 16 | #-} 17 | 18 | #define STREAMING(name, nameC, nameS, vars) ;\ 19 | name = nameC ;\ 20 | {-# INLINE [0] name #-} ;\ 21 | {-# RULES "unstream name" forall vars. \ 22 | name vars = unstream (streamConduit (nameC vars) (nameS vars)) \ 23 | #-} 24 | -------------------------------------------------------------------------------- /conduit/src/Conduit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | -- | Your intended one-stop-shop for conduit functionality. 4 | -- This re-exports functions from many commonly used modules. 5 | -- When there is a conflict with standard functions, functions 6 | -- in this module are disambiguated by adding a trailing C 7 | -- (or for chunked functions, replacing a trailing E with CE). 8 | -- This means that the Conduit module can be imported unqualified 9 | -- without causing naming conflicts. 10 | -- 11 | -- For more information on the naming scheme and intended usages of the 12 | -- combinators, please see the "Data.Conduit.Combinators" documentation. 13 | module Conduit 14 | ( -- * Core conduit library 15 | module Data.Conduit 16 | , module Data.Conduit.Lift 17 | -- * Commonly used combinators 18 | , module Data.Conduit.Combinators.Unqualified 19 | -- * Monadic lifting 20 | , MonadIO (..) 21 | , MonadTrans (..) 22 | , MonadThrow (..) 23 | , MonadUnliftIO (..) 24 | , PrimMonad (..) 25 | -- * ResourceT 26 | , MonadResource 27 | , ResourceT 28 | , runResourceT 29 | -- * Acquire 30 | , module Data.Acquire 31 | -- * Pure pipelines 32 | , Identity (..) 33 | ) where 34 | 35 | import Data.Conduit 36 | import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO (..)) 37 | import Control.Monad.Trans.Class (MonadTrans (..)) 38 | import Control.Monad.Primitive (PrimMonad (..), PrimState) 39 | import Data.Conduit.Lift 40 | import Data.Conduit.Combinators.Unqualified 41 | import Data.Functor.Identity (Identity (..)) 42 | import Control.Monad.Trans.Resource (MonadResource, MonadThrow (..), runResourceT, ResourceT) 43 | import Data.Acquire hiding (with) 44 | -------------------------------------------------------------------------------- /conduit/src/Data/Conduit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | -- | If this is your first time with conduit, you should probably start with 5 | -- the tutorial: 6 | -- . 7 | module Data.Conduit 8 | ( -- * Core interface 9 | -- ** Types 10 | ConduitT 11 | -- *** Deprecated 12 | , Source 13 | , Conduit 14 | , Sink 15 | , ConduitM 16 | -- ** Connect/fuse operators 17 | , (.|) 18 | , connect 19 | , fuse 20 | -- *** Deprecated 21 | , ($$) 22 | , ($=) 23 | , (=$) 24 | , (=$=) 25 | 26 | -- *** Fuse with upstream results 27 | , fuseBoth 28 | , fuseBothMaybe 29 | , fuseUpstream 30 | 31 | -- ** Primitives 32 | , await 33 | , yield 34 | , yieldM 35 | , leftover 36 | , runConduit 37 | , runConduitPure 38 | , runConduitRes 39 | 40 | -- ** Finalization 41 | , bracketP 42 | 43 | -- ** Exception handling 44 | , catchC 45 | , handleC 46 | , tryC 47 | 48 | -- * Generalized conduit types 49 | , Producer 50 | , Consumer 51 | , toProducer 52 | , toConsumer 53 | 54 | -- * Utility functions 55 | , awaitForever 56 | , transPipe 57 | , mapOutput 58 | , mapOutputMaybe 59 | , mapInput 60 | , mapInputM 61 | , mergeSource 62 | , passthroughSink 63 | , sourceToList 64 | 65 | -- * Connect-and-resume 66 | , SealedConduitT 67 | , sealConduitT 68 | , unsealConduitT 69 | , ($$+) 70 | , ($$++) 71 | , ($$+-) 72 | , ($=+) 73 | 74 | -- ** For @Conduit@s 75 | , (=$$+) 76 | , (=$$++) 77 | , (=$$+-) 78 | 79 | -- * Fusion with leftovers 80 | , fuseLeftovers 81 | , fuseReturnLeftovers 82 | 83 | -- * Flushing 84 | , Flush (..) 85 | 86 | -- * Newtype wrappers 87 | -- ** ZipSource 88 | , ZipSource (..) 89 | , sequenceSources 90 | 91 | -- ** ZipSink 92 | , ZipSink (..) 93 | , sequenceSinks 94 | 95 | -- ** ZipConduit 96 | , ZipConduit (..) 97 | , sequenceConduits 98 | 99 | -- * Convenience reexports 100 | , Void -- FIXME consider instead relaxing type of runConduit 101 | ) where 102 | 103 | import Data.Conduit.Internal.Conduit 104 | import Data.Void (Void) 105 | import Data.Functor.Identity (Identity, runIdentity) 106 | import Control.Monad.Trans.Resource (ResourceT, runResourceT) 107 | import Control.Monad.IO.Unlift (MonadUnliftIO) 108 | -------------------------------------------------------------------------------- /conduit/src/Data/Conduit/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | {-# OPTIONS_HADDOCK not-home #-} 3 | module Data.Conduit.Internal 4 | ( -- * Pipe 5 | module Data.Conduit.Internal.Pipe 6 | -- * Conduit 7 | , module Data.Conduit.Internal.Conduit 8 | -- * Fusion (highly experimental!!!) 9 | , module Data.Conduit.Internal.Fusion 10 | ) where 11 | 12 | import Data.Conduit.Internal.Conduit hiding (await, 13 | awaitForever, bracketP, 14 | leftover, mapInput, mapInputM, 15 | mapOutput, mapOutputMaybe, 16 | transPipe, 17 | yield, yieldM, 18 | unconsM, unconsEitherM) 19 | import Data.Conduit.Internal.Pipe 20 | import Data.Conduit.Internal.Fusion 21 | -------------------------------------------------------------------------------- /conduit/src/Data/Conduit/Internal/Fusion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE Trustworthy #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | module Data.Conduit.Internal.Fusion 8 | ( -- ** Types 9 | Step (..) 10 | , Stream (..) 11 | , ConduitWithStream 12 | , StreamConduitT 13 | , StreamConduit 14 | , StreamSource 15 | , StreamProducer 16 | , StreamSink 17 | , StreamConsumer 18 | -- ** Functions 19 | , streamConduit 20 | , streamSource 21 | , streamSourcePure 22 | , unstream 23 | ) where 24 | 25 | import Data.Conduit.Internal.Conduit 26 | import Data.Conduit.Internal.Pipe (Pipe (..)) 27 | import Data.Functor.Identity (Identity (runIdentity)) 28 | import Data.Void (Void, absurd) 29 | import Control.Monad.Trans.Resource (runResourceT) 30 | 31 | -- | This is the same as stream fusion\'s Step. Constructors are renamed to 32 | -- avoid confusion with conduit names. 33 | data Step s o r 34 | = Emit s o 35 | | Skip s 36 | | Stop r 37 | deriving Functor 38 | 39 | data Stream m o r = forall s. Stream 40 | (s -> m (Step s o r)) 41 | (m s) 42 | 43 | data ConduitWithStream i o m r = ConduitWithStream 44 | (ConduitT i o m r) 45 | (StreamConduitT i o m r) 46 | 47 | type StreamConduitT i o m r = Stream m i () -> Stream m o r 48 | 49 | type StreamConduit i m o = StreamConduitT i o m () 50 | 51 | type StreamSource m o = StreamConduitT () o m () 52 | 53 | type StreamProducer m o = forall i. StreamConduitT i o m () 54 | 55 | type StreamSink i m r = StreamConduitT i Void m r 56 | 57 | type StreamConsumer i m r = forall o. StreamConduitT i o m r 58 | 59 | unstream :: ConduitWithStream i o m r -> ConduitT i o m r 60 | unstream (ConduitWithStream c _) = c 61 | {-# INLINE [0] unstream #-} 62 | 63 | fuseStream :: Monad m 64 | => ConduitWithStream a b m () 65 | -> ConduitWithStream b c m r 66 | -> ConduitWithStream a c m r 67 | fuseStream (ConduitWithStream a x) (ConduitWithStream b y) = 68 | ConduitWithStream (a .| b) (y . x) 69 | {-# INLINE fuseStream #-} 70 | 71 | {-# RULES "conduit: fuseStream (.|)" forall left right. 72 | unstream left .| unstream right = unstream (fuseStream left right) 73 | #-} 74 | {-# RULES "conduit: fuseStream (fuse)" forall left right. 75 | fuse (unstream left) (unstream right) = unstream (fuseStream left right) 76 | #-} 77 | {-# RULES "conduit: fuseStream (=$=)" forall left right. 78 | unstream left =$= unstream right = unstream (fuseStream left right) 79 | #-} 80 | 81 | runStream :: Monad m 82 | => ConduitWithStream () Void m r 83 | -> m r 84 | runStream (ConduitWithStream _ f) = 85 | run $ f $ Stream emptyStep (return ()) 86 | where 87 | emptyStep _ = return $ Stop () 88 | run (Stream step ms0) = 89 | ms0 >>= loop 90 | where 91 | loop s = do 92 | res <- step s 93 | case res of 94 | Stop r -> return r 95 | Skip s' -> loop s' 96 | Emit _ o -> absurd o 97 | {-# INLINE runStream #-} 98 | 99 | {-# RULES "conduit: runStream" forall stream. 100 | runConduit (unstream stream) = runStream stream 101 | #-} 102 | {-# RULES "conduit: runStream (pure)" forall stream. 103 | runConduitPure (unstream stream) = runIdentity (runStream stream) 104 | #-} 105 | {-# RULES "conduit: runStream (ResourceT)" forall stream. 106 | runConduitRes (unstream stream) = runResourceT (runStream stream) 107 | #-} 108 | 109 | connectStream :: Monad m 110 | => ConduitWithStream () i m () 111 | -> ConduitWithStream i Void m r 112 | -> m r 113 | connectStream (ConduitWithStream _ stream) (ConduitWithStream _ f) = 114 | run $ f $ stream $ Stream emptyStep (return ()) 115 | where 116 | emptyStep _ = return $ Stop () 117 | run (Stream step ms0) = 118 | ms0 >>= loop 119 | where 120 | loop s = do 121 | res <- step s 122 | case res of 123 | Stop r -> return r 124 | Skip s' -> loop s' 125 | Emit _ o -> absurd o 126 | {-# INLINE connectStream #-} 127 | 128 | {-# RULES "conduit: connectStream ($$)" forall left right. 129 | unstream left $$ unstream right = connectStream left right 130 | #-} 131 | 132 | connectStream1 :: Monad m 133 | => ConduitWithStream () i m () 134 | -> ConduitT i Void m r 135 | -> m r 136 | connectStream1 (ConduitWithStream _ fstream) (ConduitT sink0) = 137 | case fstream $ Stream (const $ return $ Stop ()) (return ()) of 138 | Stream step ms0 -> 139 | let loop _ (Done r) _ = return r 140 | loop ls (PipeM mp) s = mp >>= flip (loop ls) s 141 | loop ls (Leftover p l) s = loop (l:ls) p s 142 | loop _ (HaveOutput _ o) _ = absurd o 143 | loop (l:ls) (NeedInput p _) s = loop ls (p l) s 144 | loop [] (NeedInput p c) s = do 145 | res <- step s 146 | case res of 147 | Stop () -> loop [] (c ()) s 148 | Skip s' -> loop [] (NeedInput p c) s' 149 | Emit s' i -> loop [] (p i) s' 150 | in ms0 >>= loop [] (sink0 Done) 151 | {-# INLINE connectStream1 #-} 152 | 153 | {-# RULES "conduit: connectStream1 ($$)" forall left right. 154 | unstream left $$ right = connectStream1 left right 155 | #-} 156 | 157 | {-# RULES "conduit: connectStream1 (runConduit/.|)" forall left right. 158 | runConduit (unstream left .| right) = connectStream1 left right 159 | #-} 160 | {-# RULES "conduit: connectStream1 (runConduit/=$=)" forall left right. 161 | runConduit (unstream left =$= right) = connectStream1 left right 162 | #-} 163 | {-# RULES "conduit: connectStream1 (runConduit/fuse)" forall left right. 164 | runConduit (fuse (unstream left) right) = connectStream1 left right 165 | #-} 166 | 167 | {-# RULES "conduit: connectStream1 (runConduitPure/.|)" forall left right. 168 | runConduitPure (unstream left .| right) = runIdentity (connectStream1 left right) 169 | #-} 170 | {-# RULES "conduit: connectStream1 (runConduitPure/=$=)" forall left right. 171 | runConduitPure (unstream left =$= right) = runIdentity (connectStream1 left right) 172 | #-} 173 | {-# RULES "conduit: connectStream1 (runConduitPure/fuse)" forall left right. 174 | runConduitPure (fuse (unstream left) right) = runIdentity (connectStream1 left right) 175 | #-} 176 | 177 | {-# RULES "conduit: connectStream1 (runConduitRes/.|)" forall left right. 178 | runConduitRes (unstream left .| right) = runResourceT (connectStream1 left right) 179 | #-} 180 | {-# RULES "conduit: connectStream1 (runConduitRes/=$=)" forall left right. 181 | runConduitRes (unstream left =$= right) = runResourceT (connectStream1 left right) 182 | #-} 183 | {-# RULES "conduit: connectStream1 (runConduitRes/fuse)" forall left right. 184 | runConduitRes (fuse (unstream left) right) = runResourceT (connectStream1 left right) 185 | #-} 186 | 187 | connectStream2 :: forall i m r. Monad m 188 | => ConduitT () i m () 189 | -> ConduitWithStream i Void m r 190 | -> m r 191 | connectStream2 (ConduitT src0) (ConduitWithStream _ fstream) = 192 | run $ fstream $ Stream step' $ return (src0 Done) 193 | where 194 | step' :: Pipe () () i () m () -> m (Step (Pipe () () i () m ()) i ()) 195 | step' (Done ()) = return $ Stop () 196 | step' (HaveOutput pipe o) = return $ Emit pipe o 197 | step' (NeedInput _ c) = return $ Skip $ c () 198 | step' (PipeM mp) = Skip <$> mp 199 | step' (Leftover p ()) = return $ Skip p 200 | {-# INLINE step' #-} 201 | 202 | run (Stream step ms0) = 203 | ms0 >>= loop 204 | where 205 | loop s = do 206 | res <- step s 207 | case res of 208 | Stop r -> return r 209 | Emit _ o -> absurd o 210 | Skip s' -> loop s' 211 | {-# INLINE connectStream2 #-} 212 | 213 | {-# RULES "conduit: connectStream2 ($$)" forall left right. 214 | left $$ unstream right = connectStream2 left right 215 | #-} 216 | 217 | {-# RULES "conduit: connectStream2 (runConduit/.|)" forall left right. 218 | runConduit (left .| unstream right) = connectStream2 left right 219 | #-} 220 | {-# RULES "conduit: connectStream2 (runConduit/fuse)" forall left right. 221 | runConduit (fuse left (unstream right)) = connectStream2 left right 222 | #-} 223 | {-# RULES "conduit: connectStream2 (runConduit/=$=)" forall left right. 224 | runConduit (left =$= unstream right) = connectStream2 left right 225 | #-} 226 | 227 | {-# RULES "conduit: connectStream2 (runConduitPure/.|)" forall left right. 228 | runConduitPure (left .| unstream right) = runIdentity (connectStream2 left right) 229 | #-} 230 | {-# RULES "conduit: connectStream2 (runConduitPure/fuse)" forall left right. 231 | runConduitPure (fuse left (unstream right)) = runIdentity (connectStream2 left right) 232 | #-} 233 | {-# RULES "conduit: connectStream2 (runConduitPure/=$=)" forall left right. 234 | runConduitPure (left =$= unstream right) = runIdentity (connectStream2 left right) 235 | #-} 236 | 237 | {-# RULES "conduit: connectStream2 (runConduitRes/.|)" forall left right. 238 | runConduitRes (left .| unstream right) = runResourceT (connectStream2 left right) 239 | #-} 240 | {-# RULES "conduit: connectStream2 (runConduitRes/fuse)" forall left right. 241 | runConduitRes (fuse left (unstream right)) = runResourceT (connectStream2 left right) 242 | #-} 243 | {-# RULES "conduit: connectStream2 (runConduitRes/=$=)" forall left right. 244 | runConduitRes (left =$= unstream right) = runResourceT (connectStream2 left right) 245 | #-} 246 | 247 | streamConduit :: ConduitT i o m r 248 | -> (Stream m i () -> Stream m o r) 249 | -> ConduitWithStream i o m r 250 | streamConduit = ConduitWithStream 251 | {-# INLINE CONLIKE streamConduit #-} 252 | 253 | streamSource 254 | :: Monad m 255 | => Stream m o () 256 | -> ConduitWithStream i o m () 257 | streamSource str@(Stream step ms0) = 258 | ConduitWithStream con (const str) 259 | where 260 | con = ConduitT $ \rest -> PipeM $ do 261 | s0 <- ms0 262 | let loop s = do 263 | res <- step s 264 | case res of 265 | Stop () -> return $ rest () 266 | Emit s' o -> return $ HaveOutput (PipeM $ loop s') o 267 | Skip s' -> loop s' 268 | loop s0 269 | {-# INLINE streamSource #-} 270 | 271 | streamSourcePure 272 | :: Monad m 273 | => Stream Identity o () 274 | -> ConduitWithStream i o m () 275 | streamSourcePure (Stream step ms0) = 276 | ConduitWithStream con (const $ Stream (return . runIdentity . step) (return s0)) 277 | where 278 | s0 = runIdentity ms0 279 | con = ConduitT $ \rest -> 280 | let loop s = 281 | case runIdentity $ step s of 282 | Stop () -> rest () 283 | Emit s' o -> HaveOutput (loop s') o 284 | Skip s' -> loop s' 285 | in loop s0 286 | {-# INLINE streamSourcePure #-} 287 | -------------------------------------------------------------------------------- /conduit/src/Data/Streaming/FileRead.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | The standard @openFile@ call on Windows causing problematic file locking 3 | -- in some cases. This module provides a cross-platform file reading API 4 | -- without the file locking problems on Windows. 5 | -- 6 | -- This module /always/ opens files in binary mode. 7 | -- 8 | -- @readChunk@ will return an empty @ByteString@ on EOF. 9 | module Data.Streaming.FileRead 10 | ( ReadHandle 11 | , openFile 12 | , closeFile 13 | , readChunk 14 | ) where 15 | 16 | #if WINDOWS 17 | 18 | import System.Win32File 19 | 20 | #else 21 | 22 | import qualified System.IO as IO 23 | import qualified Data.ByteString as S 24 | import Data.ByteString.Lazy.Internal (defaultChunkSize) 25 | 26 | newtype ReadHandle = ReadHandle IO.Handle 27 | 28 | openFile :: FilePath -> IO ReadHandle 29 | openFile fp = ReadHandle `fmap` IO.openBinaryFile fp IO.ReadMode 30 | 31 | closeFile :: ReadHandle -> IO () 32 | closeFile (ReadHandle h) = IO.hClose h 33 | 34 | readChunk :: ReadHandle -> IO S.ByteString 35 | readChunk (ReadHandle h) = S.hGetSome h defaultChunkSize 36 | 37 | #endif 38 | -------------------------------------------------------------------------------- /conduit/src/Data/Streaming/Filesystem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | -- | Streaming functions for interacting with the filesystem. 5 | module Data.Streaming.Filesystem 6 | ( DirStream 7 | , openDirStream 8 | , readDirStream 9 | , closeDirStream 10 | , FileType (..) 11 | , getFileType 12 | ) where 13 | 14 | import Data.Typeable (Typeable) 15 | 16 | #if WINDOWS 17 | 18 | import qualified System.Win32 as Win32 19 | import System.FilePath (()) 20 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) 21 | import System.Directory (doesFileExist, doesDirectoryExist) 22 | 23 | data DirStream = DirStream !Win32.HANDLE !Win32.FindData !(IORef Bool) 24 | deriving Typeable 25 | 26 | openDirStream :: FilePath -> IO DirStream 27 | openDirStream fp = do 28 | (h, fdat) <- Win32.findFirstFile $ fp "*" 29 | imore <- newIORef True -- always at least two records, "." and ".." 30 | return $! DirStream h fdat imore 31 | 32 | closeDirStream :: DirStream -> IO () 33 | closeDirStream (DirStream h _ _) = Win32.findClose h 34 | 35 | readDirStream :: DirStream -> IO (Maybe FilePath) 36 | readDirStream ds@(DirStream h fdat imore) = do 37 | more <- readIORef imore 38 | if more 39 | then do 40 | filename <- Win32.getFindDataFileName fdat 41 | Win32.findNextFile h fdat >>= writeIORef imore 42 | if filename == "." || filename == ".." 43 | then readDirStream ds 44 | else return $ Just filename 45 | else return Nothing 46 | 47 | isSymlink :: FilePath -> IO Bool 48 | isSymlink _ = return False 49 | 50 | getFileType :: FilePath -> IO FileType 51 | getFileType fp = do 52 | isFile <- doesFileExist fp 53 | if isFile 54 | then return FTFile 55 | else do 56 | isDir <- doesDirectoryExist fp 57 | return $ if isDir then FTDirectory else FTOther 58 | 59 | #else 60 | 61 | import System.Posix.Directory (DirStream, openDirStream, closeDirStream) 62 | import qualified System.Posix.Directory as Posix 63 | import qualified System.Posix.Files as PosixF 64 | import Control.Exception (try, IOException) 65 | 66 | readDirStream :: DirStream -> IO (Maybe FilePath) 67 | readDirStream ds = do 68 | fp <- Posix.readDirStream ds 69 | case fp of 70 | "" -> return Nothing 71 | "." -> readDirStream ds 72 | ".." -> readDirStream ds 73 | _ -> return $ Just fp 74 | 75 | getFileType :: FilePath -> IO FileType 76 | getFileType fp = do 77 | s <- PosixF.getSymbolicLinkStatus fp 78 | case () of 79 | () 80 | | PosixF.isRegularFile s -> return FTFile 81 | | PosixF.isDirectory s -> return FTDirectory 82 | | PosixF.isSymbolicLink s -> do 83 | es' <- try $ PosixF.getFileStatus fp 84 | case es' of 85 | Left (_ :: IOException) -> return FTOther 86 | Right s' 87 | | PosixF.isRegularFile s' -> return FTFileSym 88 | | PosixF.isDirectory s' -> return FTDirectorySym 89 | | otherwise -> return FTOther 90 | | otherwise -> return FTOther 91 | 92 | #endif 93 | 94 | data FileType 95 | = FTFile 96 | | FTFileSym -- ^ symlink to file 97 | | FTDirectory 98 | | FTDirectorySym -- ^ symlink to a directory 99 | | FTOther 100 | deriving (Show, Read, Eq, Ord, Typeable) 101 | -------------------------------------------------------------------------------- /conduit/src/System/Win32File.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | module System.Win32File 4 | ( openFile 5 | , readChunk 6 | , closeFile 7 | , ReadHandle 8 | ) where 9 | 10 | import Foreign.C.String (CString) 11 | import Foreign.Ptr (castPtr) 12 | import Foreign.Marshal.Alloc (mallocBytes, free) 13 | import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) 14 | #if __GLASGOW_HASKELL__ >= 704 15 | import Foreign.C.Types (CInt (..)) 16 | #else 17 | import Foreign.C.Types (CInt) 18 | #endif 19 | import Foreign.C.Error (throwErrnoIfMinus1Retry) 20 | import Foreign.Ptr (Ptr) 21 | import Data.Bits (Bits, (.|.)) 22 | import qualified Data.ByteString as S 23 | import qualified Data.ByteString.Unsafe as BU 24 | import qualified Data.ByteString.Internal as BI 25 | import Data.Text (pack) 26 | import Data.Text.Encoding (encodeUtf16LE) 27 | import Data.Word (Word8) 28 | import Prelude hiding (read) 29 | import GHC.ForeignPtr (mallocPlainForeignPtrBytes) 30 | import Data.ByteString.Lazy.Internal (defaultChunkSize) 31 | 32 | 33 | #include 34 | #include 35 | #include 36 | #include 37 | 38 | newtype OFlag = OFlag CInt 39 | deriving (Num, Bits, Show, Eq) 40 | 41 | #{enum OFlag, OFlag 42 | , oBinary = _O_BINARY 43 | , oRdonly = _O_RDONLY 44 | , oWronly = _O_WRONLY 45 | , oCreat = _O_CREAT 46 | } 47 | 48 | newtype SHFlag = SHFlag CInt 49 | deriving (Num, Bits, Show, Eq) 50 | 51 | #{enum SHFlag, SHFlag 52 | , shDenyno = _SH_DENYNO 53 | } 54 | 55 | newtype PMode = PMode CInt 56 | deriving (Num, Bits, Show, Eq) 57 | 58 | #{enum PMode, PMode 59 | , pIread = _S_IREAD 60 | , pIwrite = _S_IWRITE 61 | } 62 | 63 | foreign import ccall "_wsopen" 64 | c_wsopen :: CString -> OFlag -> SHFlag -> PMode -> IO CInt 65 | 66 | foreign import ccall "_read" 67 | c_read :: ReadHandle -> Ptr Word8 -> CInt -> IO CInt 68 | 69 | foreign import ccall "_write" 70 | c_write :: ReadHandle -> Ptr Word8 -> CInt -> IO CInt 71 | 72 | foreign import ccall "_close" 73 | closeFile :: ReadHandle -> IO () 74 | 75 | newtype ReadHandle = ReadHandle CInt 76 | 77 | openFile :: FilePath -> IO ReadHandle 78 | openFile fp = do 79 | -- need to append a null char 80 | -- note that useAsCString is not sufficient, as we need to have two 81 | -- null octets to account for UTF16 encoding 82 | let bs = encodeUtf16LE $ pack $ fp ++ "\0" 83 | h <- BU.unsafeUseAsCString bs $ \str -> 84 | throwErrnoIfMinus1Retry "Data.Streaming.FileRead.openFile" $ 85 | c_wsopen 86 | str 87 | (oBinary .|. oRdonly) 88 | shDenyno 89 | pIread 90 | return $ ReadHandle h 91 | 92 | readChunk :: ReadHandle -> IO S.ByteString 93 | readChunk fd = do 94 | fp <- mallocPlainForeignPtrBytes defaultChunkSize 95 | withForeignPtr fp $ \p -> do 96 | len <- throwErrnoIfMinus1Retry "System.Win32File.read" $ c_read fd p 97 | (fromIntegral defaultChunkSize) 98 | if len == 0 99 | then return $! S.empty 100 | else return $! BI.PS fp 0 (fromIntegral len) 101 | -------------------------------------------------------------------------------- /conduit/test/Data/Conduit/Extra/ZipConduitSpec.hs: -------------------------------------------------------------------------------- 1 | module Data.Conduit.Extra.ZipConduitSpec (spec) where 2 | import Test.Hspec 3 | import Data.Conduit 4 | import qualified Data.Conduit.List as CL 5 | import Control.Applicative ((<*), pure) 6 | 7 | spec :: Spec 8 | spec = describe "Data.Conduit.Extra.ZipConduit" $ do 9 | it "ZipConduit" $ do 10 | let src = mapM_ yield [1..3 :: Int] 11 | conduit1 = CL.map (+1) 12 | conduit2 = CL.concatMap (replicate 2) 13 | conduit = getZipConduit $ ZipConduit conduit1 <* ZipConduit conduit2 14 | sink = CL.consume 15 | res <- runConduit $ src .| conduit .| sink 16 | res `shouldBe` [2, 1, 1, 3, 2, 2, 4, 3, 3] 17 | it "sequenceConduits" $ do 18 | let src = mapM_ yield [1..3 :: Int] 19 | conduit1 = CL.map (+1) 20 | conduit2 = CL.concatMap (replicate 2) 21 | conduit = do 22 | x <- sequenceConduits [conduit1, conduit2] 23 | yield $ length x + 10 24 | sink = CL.consume 25 | res <- runConduit $ src .| conduit .| sink 26 | res `shouldBe` [2, 1, 1, 3, 2, 2, 4, 3, 3, 12] 27 | it "ZipConduitMonad" $ do 28 | let src = mapM_ yield [1..3 :: Int] 29 | conduit1 = CL.mapM (pure . (+1)) 30 | conduit2 = CL.map id 31 | conduit = getZipConduit $ ZipConduit conduit1 <* ZipConduit conduit2 32 | sink = CL.consume 33 | res <- runConduit $ src .| conduit .| sink 34 | res `shouldBe` [2, 1, 3, 2, 4, 3] 35 | -------------------------------------------------------------------------------- /conduit/test/doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.DocTest 4 | 5 | main :: IO () 6 | main = doctest ["Data/Conduit.hs"] 7 | -------------------------------------------------------------------------------- /conduit/test/subdir/dummyfile.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/snoyberg/conduit/0cd209d4a8ed63aa007e65ad13c3ab15ea57badd/conduit/test/subdir/dummyfile.txt -------------------------------------------------------------------------------- /network-conduit-tls/ChangeLog.md: -------------------------------------------------------------------------------- 1 | ## 1.4.0.1 2 | 3 | * Fix test suite for crypton-connection 0.4 [#512](https://github.com/snoyberg/conduit/issues/512) 4 | 5 | ## 1.4.0 6 | 7 | * Migrate to crypton 8 | 9 | ## 1.3.2 10 | 11 | * Use the recommended SSL versions from TLS 12 | 13 | ## 1.3.1 14 | 15 | * Use the default ciphersuite from TLS 16 | 17 | ## 1.3.0 18 | 19 | * Upgrade to conduit 1.3.0 20 | 21 | ## 1.2.2 22 | 23 | * Make runTLS{Client,Server}StartTLS general [#264](https://github.com/snoyberg/conduit/pull/264) 24 | 25 | ## 1.2.1 26 | 27 | * Expose ApplicationStartTLS [#262](https://github.com/snoyberg/conduit/pull/262) 28 | 29 | ## 1.2.0.1 30 | 31 | * tls 1.3 support 32 | 33 | ## 1.2.0 34 | 35 | * Drop system-filepath 36 | 37 | ## 1.1.2 38 | 39 | * Added 'runGeneralTCPServerTLS' function [#208](https://github.com/snoyberg/conduit/pull/208) 40 | 41 | ## 1.1.1.1 42 | 43 | * Fill in `appRawSocket` for streaming-commons 0.1.12 and later 44 | 45 | ## 1.1.1 46 | 47 | * Support chain certificates in network-conduit-tls [#203](https://github.com/snoyberg/conduit/pull/203) 48 | -------------------------------------------------------------------------------- /network-conduit-tls/Data/Conduit/Network/TLS/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | module Data.Conduit.Network.TLS.Internal 3 | ( TLSConfig (..) 4 | , TlsCertData (..) 5 | ) where 6 | 7 | import Prelude hiding (FilePath) 8 | import Data.Streaming.Network (HostPreference) 9 | import qualified Data.ByteString as S 10 | 11 | -- structure providing access to certificate and key data through call backs 12 | data TlsCertData = TlsCertData { getTLSCert :: IO S.ByteString 13 | , getTLSChainCerts :: IO [S.ByteString] 14 | , getTLSKey :: IO S.ByteString } 15 | 16 | 17 | data TLSConfig = TLSConfig 18 | { tlsHost :: HostPreference 19 | , tlsPort :: Int 20 | , tlsCertData :: TlsCertData 21 | , tlsNeedLocalAddr :: Bool 22 | } 23 | -------------------------------------------------------------------------------- /network-conduit-tls/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /network-conduit-tls/README.md: -------------------------------------------------------------------------------- 1 | ## network-conduit-tls 2 | 3 | Create TLS-aware network code with conduits. Uses the tls package for a pure-Haskell implementation. 4 | -------------------------------------------------------------------------------- /network-conduit-tls/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /network-conduit-tls/network-conduit-tls.cabal: -------------------------------------------------------------------------------- 1 | name: network-conduit-tls 2 | version: 1.4.0.1 3 | synopsis: Create TLS-aware network code with conduits 4 | description: Uses the tls package for a pure-Haskell implementation. 5 | homepage: https://github.com/snoyberg/conduit 6 | license: MIT 7 | license-file: LICENSE 8 | author: Michael Snoyman 9 | maintainer: michael@snoyman.com 10 | category: Network 11 | build-type: Simple 12 | cabal-version: >=1.10 13 | extra-source-files: README.md ChangeLog.md 14 | 15 | library 16 | default-language: Haskell2010 17 | exposed-modules: Data.Conduit.Network.TLS 18 | Data.Conduit.Network.TLS.Internal 19 | build-depends: base >= 4.12 && < 5 20 | , bytestring >= 0.9 21 | , tls >= 1.3 22 | , conduit-extra >= 1.3 23 | , conduit >= 1.3 24 | , network 25 | , transformers 26 | , crypton-connection 27 | , streaming-commons >= 0.1.12 28 | , unliftio-core 29 | , data-default-class 30 | 31 | test-suite test 32 | default-language: Haskell2010 33 | hs-source-dirs: test 34 | main-is: main.hs 35 | type: exitcode-stdio-1.0 36 | cpp-options: -DTEST 37 | build-depends: conduit 38 | , conduit-extra 39 | , crypton-connection 40 | , base 41 | , mtl 42 | , network-conduit-tls 43 | , bytestring 44 | , HUnit 45 | , data-default-class 46 | ghc-options: -Wall -threaded 47 | -------------------------------------------------------------------------------- /network-conduit-tls/test/main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE CPP #-} 3 | import Test.HUnit 4 | import Data.Conduit 5 | import Data.Conduit.Network (appSource, appSink) 6 | import Data.Conduit.Network.TLS 7 | import Control.Concurrent (forkIO, threadDelay, killThread) 8 | import qualified Network.Connection as NC 9 | import qualified Data.ByteString as BS 10 | 11 | #if MIN_VERSION_crypton_connection(0,4,0) 12 | import qualified Data.Default.Class 13 | #endif 14 | 15 | testKeyRaw :: BS.ByteString 16 | testKeyRaw = "-----BEGIN RSA PRIVATE KEY-----\nMIIEpAIBAAKCAQEAwAU371YZKOVON+S/TpNERcSbe5vWk0kdodR/cC7iwQ40ukO6\nIH7H40THVAWQwlD6kasRdsxcsk+KcOpoBgivw9izJ7ggBp7reFe8mJRp2qMGyK+n89ZRHNlVWl1qSAC/o0A1ldvyfZ2X4nNYHVAFqwhPSsFTxQgxORJbL7qdKy1tirqg\nWpHQMgK6dQJjOEEhrMKmOC2q6l9vbTYuAghDsdtbbEc8FWWVeExiIj8RopPY9+if\nj3BoXxp4WhfiDWmnnBWp71oJIfB1uziLV6PJdA1nKfVbPUeAM0wCFFUCbrjaxdg3\n4RenckCZIJwDo+ff/OSpKynrwznunZW847m2lwIDAQABAoIBAEqjPKS5MLpmt0qe\njYX7VDRSQaWAY52IdA4tTQPMFbO40+H65WQwI35Bg8EzEJuXYm4wsm8c7IMay9Ms\nKhb+VWOo3ap4tWodZ6W1ZMdiGOs1JzPmoz/ydEDkcXrYiLFIKTVJhgqkHdOZ6CnL\nb9qk+i8K4ddK4kbZ8lgevHcG8ISRTV2B8dRc3iohGJ0F6VlL62GnjbExjegsUs4N\n4Ozy8xI4oxlKdZcgutBkfPqdJOWixWPnMXf0PtJVFMzKzVujZlupoonqUUGn51c6\nTVVXAh1pcF0XrmKNscuODFMwBtVfIrfNf/iL1KvIIlKFbUSb/Yu9/9KBvLmfKdxf\nyrtvNBECgYEA5rRdd8IaskROgQxRTJagZn39Sl6oBVFLQ+fy0LGXV3bDbgl7myx8\nOtkKiTMHGT8g6JWv5NMWUgGSZBkMnZSQ/QCtbCxpuDjajxY2GVKU+1EbJjPccuWH\nTnopBuss6WiDbI/Jl9JjPBmhs8EsuAgAOo9yPzgs6SLiMfUwWKkPRdUCgYEA1RMH\nhhKUULqE+/xF214aUqcIk38BCw9g9Uo0pGp4cIfA8iuRachZGsbRpDQyaGRWL+4A\n9hOLPdV2ey6TvNcP/7H6dXrvj4TXLqrxPC2ne2zawqeCkqigxq8Rk55pBF5c52Xz\nX5Rie98TC++gf+fyUTIUS4OqMLg4q1Erk23g5LsCgYEApZg3MtvXj7ep5cUyodfI\nYGj0oyoYTmDQtnhJ+PRQHk637kbOO06OCSt6/YnsAXono+q1q3i8n7ZTHphATuex\nvnh7ApdKdxoP/v7BbCGzoETSSPSWur34BiN3SWkK/qqvEwCOgfRYmG4JfF4fPCU6\nDM6kAa7PxbPtSlClGC6ZMNUCgYEAwp+tIaPa4ZpdWiXmUSe1d4Wm6cL6WvXjJGpx\nhzTRakg1z35IRo2ABltQpmIfIQd1SjZlnl/fsc1HeeDjhXwT2wTgt2phY4B9ZN0z\nmDpDXxPhBigntnpc0N6ceXAakKj4x0xybv2Er4zlQuPQgMSGq+/IZemQDQxYhvOP\nkAyvfX0CgYBEVKvhcXQ9ETmEsk0FxPvpS9CtWXaNWItVzC/z3+mrU2B5JPcBQF72\nBsuoupeq52S+SGH7el5Xp2AoLXjZYsQ9S0t76p6G3lE/cHmnc/QNt4kT6oe5mpv1\nYXIo3/044Cbw2FEkEaj0iucagYCoqhlZTFN8aR6dXFTmvU+k6VP7pg==\n-----END RSA PRIVATE KEY-----" 17 | 18 | 19 | -- self signed certificate corresponding to private key above. 20 | -- this certificate will expire circa january 2015 ... 21 | testCertificateRaw :: BS.ByteString 22 | testCertificateRaw = "-----BEGIN CERTIFICATE-----\nMIIDBjCCAe4CCQDBE77UEng3SDANBgkqhkiG9w0BAQsFADBFMQswCQYDVQQGEwJG\nUjETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0\ncyBQdHkgTHRkMB4XDTE0MDEwNjIxNTA1OVoXDTE1MDEwNjIxNTA1OVowRTELMAkG\nA1UEBhMCRlIxEzARBgNVBAgMClNvbWUtU3RhdGUxITAfBgNVBAoMGEludGVybmV0\nIFdpZGdpdHMgUHR5IEx0ZDCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEB\nAMAFN+9WGSjlTjfkv06TREXEm3ub1pNJHaHUf3Au4sEONLpDuiB+x+NEx1QFkMJQ\n+pGrEXbMXLJPinDqaAYIr8PYsye4IAae63hXvJiUadqjBsivp/PWURzZVVpdakgA\nv6NANZXb8n2dl+JzWB1QBasIT0rBU8UIMTkSWy+6nSstbYq6oFqR0DICunUCYzhB\nIazCpjgtqupfb202LgIIQ7HbW2xHPBVllXhMYiI/EaKT2Pfon49waF8aeFoX4g1p\np5wVqe9aCSHwdbs4i1ejyXQNZyn1Wz1HgDNMAhRVAm642sXYN+EXp3JAmSCcA6Pn\n3/zkqSsp68M57p2VvOO5tpcCAwEAATANBgkqhkiG9w0BAQsFAAOCAQEAq1Vy0VBj\nKxuXrpzU8O8bMNrH571Mtjb7tNAhpv77HeyfssW151Rltn71DDPIOqwhoA9zN47I\ns/t/aq1+BmXSdEEb9chbOkZ+KOsJlG/Y0Io4jSK4j4JHlnSBhjItTaoEkkvQtr45\nbyrLYSeixGY5JZd8hIOUcGuru+PPx+SKtuZrnxHF+oXyT9O4BLIe9BYWHvE0Qpop\nvc060w8CIDW4gfYcxxMsA45IrULv5mq2J8bLAtcI9hQY3Z8dPNejsChYTHK6JDEL\n7/G6POAMxenO5cg+Y6Y3OKp5+LrzJNIwfnAnLLFl+/Gb2kC+GcfwZDojuiCJ9iIG\njPwFEAl/7WuMlg==\n-----END CERTIFICATE-----" 23 | 24 | 25 | serverConfig :: TLSConfig 26 | serverConfig = tlsConfigBS "*4" 4242 testCertificateRaw testKeyRaw 27 | 28 | clientConfig :: TLSClientConfig 29 | clientConfig = tlsClientConfig 4242 "127.0.0.1" 30 | 31 | clientConfigNoCA :: TLSClientConfig 32 | clientConfigNoCA = clientConfig 33 | { tlsClientTLSSettings = NC.TLSSettingsSimple True False False 34 | #if MIN_VERSION_crypton_connection(0,4,0) 35 | Data.Default.Class.def 36 | #endif 37 | } 38 | 39 | testSimpleServerClient :: IO () 40 | testSimpleServerClient = do 41 | -- a simple server that says hello over tls 42 | serverThreadId <- forkIO $ runTCPServerTLS serverConfig $ \ad -> 43 | runConduit $ yield "hello world" .| appSink ad 44 | 45 | -- wait for server to be ready 46 | threadDelay 1000000 47 | 48 | -- default settings checks CA, the test cert is self-signed. should 49 | runTLSClient clientConfigNoCA $ \ad -> do 50 | d <- runConduit $ appSource ad .| (await >>= return) 51 | assertEqual "client receives hello world" (Just "hello world") d 52 | 53 | -- kill the server 54 | killThread serverThreadId 55 | 56 | 57 | testSimpleServerClientStartTLS :: IO () 58 | testSimpleServerClientStartTLS = do 59 | serverThreadId <- forkIO $ runTCPServerStartTLS serverConfig serve 60 | threadDelay 100000 61 | 62 | runTLSClientStartTLS clientConfigNoCA client 63 | 64 | killThread serverThreadId 65 | 66 | where 67 | serve (ad, startTls) = do 68 | runConduit $ yield "proceed" .| appSink ad 69 | startTls $ \app -> runConduit $ (yield "crypted") .| appSink app 70 | 71 | 72 | client (ad, startTls) = do 73 | -- reads one message from server 74 | msg <- runConduit $ appSource ad .| (await >>= return) 75 | assertEqual "server sends proceed" (Just "proceed") msg 76 | startTls $ \app -> do 77 | msgTls <- runConduit $ appSource app .| (await >>= return) 78 | assertEqual "server sends crypted" (Just "crypted") msgTls 79 | 80 | 81 | main :: IO (Counts) 82 | main = runTestTT $ TestList [ TestLabel "TLS Server" $ TestCase testSimpleServerClient 83 | , TestLabel "StartTLS" $ TestCase testSimpleServerClientStartTLS ] 84 | 85 | 86 | 87 | 88 | 89 | 90 | -------------------------------------------------------------------------------- /resourcet/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # ChangeLog for resourcet 2 | 3 | ## 1.3.0 4 | 5 | * Include the exception in ReleaseTypes indicating exceptional exit. 6 | 7 | Only backwards-incompatible in code relying on instances of ReleaseType 8 | other than Show, or constructing ReleaseException directly. 9 | 10 | ## 1.2.6 11 | 12 | * Add `allocateU` [#490](https://github.com/snoyberg/conduit/pull/490) 13 | 14 | ## 1.2.5 15 | 16 | * Support `transformers-0.6` / `mtl-2.3` 17 | 18 | ## 1.2.4.3 19 | 20 | * Fix a space leak when using `forever` with `ResourceT`. [#470](https://github.com/snoyberg/conduit/pull/470) 21 | 22 | ## 1.2.4.2 23 | 24 | * Mask exceptions in `Acquire` allocation action 25 | 26 | ## 1.2.4.1 27 | 28 | * Document risk of using `forkIO` within a `ResourceT` [#441](https://github.com/snoyberg/conduit/pull/441) 29 | 30 | ## 1.2.4 31 | 32 | * Add `allocate_` [#437](https://github.com/snoyberg/conduit/pull/437) 33 | 34 | ## 1.2.3 35 | 36 | * Support `unliftio-core` 0.2.0.0 37 | 38 | ## 1.2.2 39 | 40 | * Add `MonadFail` instance for `ResourceT`. 41 | 42 | ## 1.2.1 43 | 44 | * Support `exceptions-0.10`. 45 | 46 | ## 1.2.0 47 | 48 | * Drop `monad-control` and `mmorph` dependencies 49 | * Change behavior of `runResourceT` to match `runResourceTChecked` 50 | 51 | ## 1.1.11 52 | 53 | * `runResourceTChecked`, which checks if any of the cleanup actions 54 | threw exceptions and, if so, rethrows them. __NOTE__ This is 55 | probably a much better choice of function than `runResourceT`, and 56 | in the next major version release, will become the new behavior of 57 | `runResourceT`. 58 | 59 | ## 1.1.10 60 | 61 | * Added `MonadUnliftIO` instances and `UnliftIO.Resource` 62 | 63 | ## 1.1.9 64 | 65 | * Add generalized version of resourceForkIO 66 | 67 | ## 1.1.8.1 68 | 69 | * Allocation actions should be masked 70 | 71 | ## 1.1.8 72 | 73 | * Add `instance MonadFix ResourceT` 74 | [#281](https://github.com/snoyberg/conduit/pull/281) 75 | 76 | ## 1.1.7.5 77 | 78 | * Inline the tutorial from SoH 79 | 80 | ## 1.1.7.4 81 | 82 | * Make test suite slightly more robust 83 | 84 | ## 1.1.7.3 85 | 86 | * Doc tweak 87 | 88 | ## 1.1.7.2 89 | 90 | * Remove upper bound on transformers [#249](https://github.com/snoyberg/conduit/issues/249) 91 | 92 | ## 1.1.7.1 93 | 94 | * transformers-compat 0.5 95 | 96 | ## 1.1.7 97 | 98 | * Canonicalise Monad instances [#237](https://github.com/snoyberg/conduit/pull/237) 99 | 100 | ## 1.1.6 101 | 102 | * Safe/Trustworthy for resourcet [#220](https://github.com/snoyberg/conduit/pull/220) 103 | 104 | ## 1.1.5 105 | 106 | * Add pass-through instances for Alternative and MonadPlus [#214](https://github.com/snoyberg/conduit/pull/214) 107 | 108 | ## 1.1.4.1 109 | 110 | * Allow older `exceptions` version again 111 | 112 | ## 1.1.4 113 | 114 | * Add `MonadResource ExceptT` instance [#198](https://github.com/snoyberg/conduit/pull/198) 115 | 116 | ## 1.1.3.2 117 | 118 | monad-control-1.0 support [#191](https://github.com/snoyberg/conduit/pull/191) 119 | 120 | ## 1.1.3 121 | 122 | Provide the `withEx` function to interact nicely with the exceptions package. 123 | -------------------------------------------------------------------------------- /resourcet/Data/Acquire.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | This was previously known as the Resource monad. However, that term is 3 | -- confusing next to the ResourceT transformer, so it has been renamed. 4 | 5 | module Data.Acquire 6 | ( Acquire 7 | -- * Example usage of 'Acquire' for allocating a resource and freeing it up. 8 | -- 9 | -- | The code makes use of 'mkAcquire' to create an 'Acquire' and uses 'allocateAcquire' to allocate the resource and register an action to free up the resource. 10 | -- 11 | -- === __Reproducible Stack code snippet__ 12 | -- 13 | -- > #!/usr/bin/env stack 14 | -- > {- stack 15 | -- > --resolver lts-10.0 16 | -- > --install-ghc 17 | -- > runghc 18 | -- > --package resourcet 19 | -- > -} 20 | -- > 21 | -- > {-#LANGUAGE ScopedTypeVariables#-} 22 | -- > 23 | -- > import Data.Acquire 24 | -- > import Control.Monad.Trans.Resource 25 | -- > import Control.Monad.IO.Class 26 | -- > 27 | -- > main :: IO () 28 | -- > main = runResourceT $ do 29 | -- > let (ack :: Acquire Int) = mkAcquire (do 30 | -- > putStrLn "Enter some number" 31 | -- > readLn) (\i -> putStrLn $ "Freeing scarce resource: " ++ show i) 32 | -- > (releaseKey, resource) <- allocateAcquire ack 33 | -- > doSomethingDangerous resource 34 | -- > liftIO $ putStrLn $ "Going to release resource immediately: " ++ show resource 35 | -- > release releaseKey 36 | -- > somethingElse 37 | -- > 38 | -- > doSomethingDangerous :: Int -> ResourceT IO () 39 | -- > doSomethingDangerous i = 40 | -- > liftIO $ putStrLn $ "5 divided by " ++ show i ++ " is " ++ show (5 `div` i) 41 | -- > 42 | -- > somethingElse :: ResourceT IO () 43 | -- > somethingElse = liftIO $ putStrLn 44 | -- > "This could take a long time, don't delay releasing the resource!" 45 | -- 46 | -- Execution output: 47 | -- 48 | -- > ~ $ stack code.hs 49 | -- > Enter some number 50 | -- > 3 51 | -- > 5 divided by 3 is 1 52 | -- > Going to release resource immediately: 3 53 | -- > Freeing scarce resource: 3 54 | -- > This could take a long time, don't delay releasing the resource! 55 | -- > 56 | -- > ~ $ stack code.hs 57 | -- > Enter some number 58 | -- > 0 59 | -- > 5 divided by 0 is Freeing scarce resource: 0 60 | -- > code.hs: divide by zero 61 | -- 62 | , with 63 | , withAcquire 64 | , mkAcquire 65 | , mkAcquireType 66 | , allocateAcquire 67 | , ReleaseType (..) 68 | ) where 69 | 70 | import Control.Monad.Trans.Resource.Internal 71 | import Data.Acquire.Internal 72 | import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO) 73 | import qualified Control.Exception as E 74 | 75 | -- | Allocate a resource and register an action with the @MonadResource@ to 76 | -- free the resource. 77 | -- 78 | -- @since 1.1.0 79 | allocateAcquire :: MonadResource m => Acquire a -> m (ReleaseKey, a) 80 | allocateAcquire = liftResourceT . allocateAcquireRIO 81 | 82 | allocateAcquireRIO :: Acquire a -> ResourceT IO (ReleaseKey, a) 83 | allocateAcquireRIO (Acquire f) = ResourceT $ \istate -> liftIO $ E.mask $ \restore -> do 84 | Allocated a free <- f restore 85 | key <- registerType istate free 86 | return (key, a) 87 | 88 | -- | Longer name for 'with', in case @with@ is not obvious enough in context. 89 | -- 90 | -- @since 1.2.0 91 | withAcquire :: MonadUnliftIO m => Acquire a -> (a -> m b) -> m b 92 | withAcquire = with 93 | {-# INLINE withAcquire #-} 94 | -------------------------------------------------------------------------------- /resourcet/Data/Acquire/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE DeriveDataTypeable #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE PatternSynonyms #-} 8 | module Data.Acquire.Internal 9 | ( Acquire (..) 10 | , Allocated (..) 11 | , with 12 | , mkAcquire 13 | , ReleaseType (.., ReleaseException) 14 | , mkAcquireType 15 | ) where 16 | 17 | import Control.Applicative (Applicative (..)) 18 | import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO, withRunInIO) 19 | import qualified Control.Exception as E 20 | import Data.Typeable (Typeable) 21 | import Control.Monad (liftM, ap) 22 | import qualified Control.Monad.Catch as C () 23 | 24 | -- | The way in which a release is called. 25 | -- 26 | -- @since 1.1.2 27 | data ReleaseType = ReleaseEarly 28 | | ReleaseNormal 29 | | ReleaseExceptionWith E.SomeException 30 | deriving (Show, Typeable) 31 | 32 | {-# COMPLETE ReleaseEarly, ReleaseNormal, ReleaseException #-} 33 | {-# DEPRECATED ReleaseException "Use `ReleaseExceptionWith`, which has the exception in the constructor. This pattern synonym hides the exception and can obscure problems." #-} 34 | pattern ReleaseException :: ReleaseType 35 | pattern ReleaseException <- ReleaseExceptionWith _ 36 | 37 | data Allocated a = Allocated !a !(ReleaseType -> IO ()) 38 | 39 | -- | A method for acquiring a scarce resource, providing the means of freeing 40 | -- it when no longer needed. This data type provides 41 | -- @Functor@\/@Applicative@\/@Monad@ instances for composing different resources 42 | -- together. You can allocate these resources using either the @bracket@ 43 | -- pattern (via @with@) or using @ResourceT@ (via @allocateAcquire@). 44 | -- 45 | -- This concept was originally introduced by Gabriel Gonzalez and described at: 46 | -- . The 47 | -- implementation in this package is slightly different, due to taking a 48 | -- different approach to async exception safety. 49 | -- 50 | -- @since 1.1.0 51 | newtype Acquire a = Acquire ((forall b. IO b -> IO b) -> IO (Allocated a)) 52 | deriving Typeable 53 | 54 | instance Functor Acquire where 55 | fmap = liftM 56 | instance Applicative Acquire where 57 | pure a = Acquire (\_ -> return (Allocated a (const $ return ()))) 58 | (<*>) = ap 59 | 60 | instance Monad Acquire where 61 | return = pure 62 | Acquire f >>= g' = Acquire $ \restore -> do 63 | Allocated x free1 <- f restore 64 | let Acquire g = g' x 65 | Allocated y free2 <- g restore `E.catch` (\e -> free1 (ReleaseExceptionWith e) >> E.throwIO e) 66 | return $! Allocated y (\rt -> free2 rt `E.finally` free1 rt) 67 | 68 | instance MonadIO Acquire where 69 | liftIO f = Acquire $ \restore -> do 70 | x <- restore f 71 | return $! Allocated x (const $ return ()) 72 | 73 | -- | Create an @Acquire@ value using the given allocate and free functions. 74 | -- 75 | -- To acquire and free the resource in an arbitrary monad with `MonadUnliftIO`, 76 | -- do the following: 77 | -- 78 | -- > acquire <- withRunInIO $ \runInIO -> 79 | -- > return $ mkAcquire (runInIO create) (runInIO . free) 80 | -- 81 | -- Note that this is only safe if the Acquire is run and freed within the same 82 | -- monadic scope it was created in. 83 | -- 84 | -- @since 1.1.0 85 | mkAcquire :: IO a -- ^ acquire the resource 86 | -> (a -> IO ()) -- ^ free the resource 87 | -> Acquire a 88 | mkAcquire create free = mkAcquireType create (\a _ -> free a) 89 | 90 | -- | Same as 'mkAcquire', but the cleanup function will be informed of /how/ 91 | -- cleanup was initiated. This allows you to distinguish, for example, between 92 | -- normal and exceptional exits. 93 | -- 94 | -- To acquire and free the resource in an arbitrary monad with `MonadUnliftIO`, 95 | -- do the following: 96 | -- 97 | -- > acquire <- withRunInIO $ \runInIO -> 98 | -- > return $ mkAcquireType (runInIO create) (\a -> runInIO . free a) 99 | -- 100 | -- Note that this is only safe if the Acquire is run and freed within the same 101 | -- monadic scope it was created in. 102 | -- 103 | -- @since 1.1.2 104 | mkAcquireType 105 | :: IO a -- ^ acquire the resource 106 | -> (a -> ReleaseType -> IO ()) -- ^ free the resource 107 | -> Acquire a 108 | mkAcquireType create free = Acquire $ \_ -> do 109 | x <- create 110 | return $! Allocated x (free x) 111 | 112 | -- | Allocate the given resource and provide it to the provided function. The 113 | -- resource will be freed as soon as the inner block is exited, whether 114 | -- normally or via an exception. This function is similar in function to 115 | -- @bracket@. 116 | -- 117 | -- @since 1.1.0 118 | with :: MonadUnliftIO m 119 | => Acquire a 120 | -> (a -> m b) 121 | -> m b 122 | with (Acquire f) g = withRunInIO $ \run -> E.mask $ \restore -> do 123 | Allocated x free <- f restore 124 | res <- restore (run (g x)) `E.catch` (\e -> free (ReleaseExceptionWith e) >> E.throwIO e) 125 | free ReleaseNormal 126 | return res 127 | -------------------------------------------------------------------------------- /resourcet/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2011, Michael Snoyman 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Michael Snoyman nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /resourcet/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > module Main where 4 | > import Distribution.Simple 5 | 6 | > main :: IO () 7 | > main = defaultMain 8 | -------------------------------------------------------------------------------- /resourcet/UnliftIO/Resource.hs: -------------------------------------------------------------------------------- 1 | -- | Unlifted "Control.Monad.Trans.Resource". 2 | -- 3 | -- @since 1.1.10 4 | module UnliftIO.Resource 5 | ( -- * UnliftIO variants 6 | runResourceT 7 | , liftResourceT 8 | , allocateU 9 | -- * Reexports 10 | , module Control.Monad.Trans.Resource 11 | ) where 12 | 13 | import qualified Control.Monad.Trans.Resource as Res 14 | import Control.Monad.Trans.Resource.Internal (ResourceT (..)) 15 | import Control.Monad.IO.Unlift 16 | import Control.Monad.Trans.Resource (ResourceT, ReleaseKey, allocate, register, release, unprotect, MonadResource) 17 | 18 | -- | Unlifted version of 'Res.runResourceT'. 19 | -- 20 | -- @since 1.1.10 21 | runResourceT :: MonadUnliftIO m => ResourceT m a -> m a 22 | runResourceT m = withRunInIO $ \run -> Res.runResourceT $ Res.transResourceT run m 23 | 24 | -- | Lifted version of 'Res.liftResourceT'. 25 | -- 26 | -- @since 1.1.10 27 | liftResourceT :: MonadIO m => ResourceT IO a -> ResourceT m a 28 | liftResourceT (ResourceT f) = ResourceT $ liftIO . f 29 | 30 | -- | Unlifted 'allocate'. 31 | -- 32 | -- @since 1.2.6 33 | allocateU 34 | :: (MonadUnliftIO m, MonadResource m) 35 | => m a 36 | -> (a -> m ()) 37 | -> m (ReleaseKey, a) 38 | allocateU alloc free = withRunInIO $ \run -> 39 | run $ allocate (run alloc) (run . free) 40 | -------------------------------------------------------------------------------- /resourcet/resourcet.cabal: -------------------------------------------------------------------------------- 1 | Name: resourcet 2 | Version: 1.3.0 3 | Synopsis: Deterministic allocation and freeing of scarce resources. 4 | description: Hackage documentation generation is not reliable. For up to date documentation, please see: . 5 | License: BSD3 6 | License-file: LICENSE 7 | Author: Michael Snoyman 8 | Maintainer: michael@snoyman.com 9 | Category: Data, Conduit 10 | Build-type: Simple 11 | Cabal-version: >=1.10 12 | Homepage: http://github.com/snoyberg/conduit 13 | extra-source-files: ChangeLog.md, README.md 14 | 15 | Library 16 | default-language: Haskell2010 17 | Exposed-modules: Control.Monad.Trans.Resource 18 | Control.Monad.Trans.Resource.Internal 19 | Data.Acquire 20 | Data.Acquire.Internal 21 | UnliftIO.Resource 22 | Build-depends: base >= 4.12 && < 5 23 | , containers 24 | , transformers >= 0.4 25 | , mtl >= 2.0 && < 2.4 26 | , exceptions (== 0.8.* || == 0.10.*) 27 | , unliftio-core >= 0.1.1.0 28 | , primitive 29 | ghc-options: -Wall 30 | 31 | test-suite test 32 | default-language: Haskell2010 33 | hs-source-dirs: test 34 | main-is: main.hs 35 | type: exitcode-stdio-1.0 36 | cpp-options: -DTEST 37 | build-depends: resourcet 38 | , base 39 | , exceptions 40 | , hspec >= 1.3 41 | , transformers 42 | ghc-options: -Wall 43 | 44 | source-repository head 45 | type: git 46 | location: git://github.com/snoyberg/conduit.git 47 | -------------------------------------------------------------------------------- /resourcet/test/main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | import Control.Concurrent 5 | import Control.Exception (Exception, MaskingState (MaskedInterruptible), 6 | getMaskingState, throwIO, try, fromException) 7 | import Control.Exception (SomeException, handle) 8 | import Control.Monad (unless, void) 9 | import qualified Control.Monad.Catch 10 | import Control.Monad.IO.Class (liftIO) 11 | import Control.Monad.Trans.Resource 12 | import Data.IORef 13 | import Data.Typeable (Typeable) 14 | import Test.Hspec 15 | import Data.Acquire 16 | 17 | main :: IO () 18 | main = hspec $ do 19 | describe "general" $ do 20 | it "survives releasing bottom" $ do 21 | x <- newIORef (0 :: Int) 22 | handle (\(_ :: SomeException) -> return ()) $ runResourceT $ do 23 | _ <- register $ writeIORef x 1 24 | release undefined 25 | x' <- readIORef x 26 | x' `shouldBe` 1 27 | describe "early release" $ do 28 | it "works from a different context" $ do 29 | x <- newIORef (0 :: Int) 30 | runResourceT $ do 31 | key <- register $ writeIORef x 1 32 | runResourceT $ release key 33 | y <- liftIO $ readIORef x 34 | liftIO $ y `shouldBe` 1 35 | describe "resourceForkIO" $ do 36 | it "waits for all threads" $ do 37 | x <- newEmptyMVar 38 | y <- newIORef (0 :: Int) 39 | z <- newEmptyMVar 40 | w <- newEmptyMVar 41 | 42 | _ <- runResourceT $ do 43 | _ <- register $ do 44 | writeIORef y 1 45 | putMVar w () 46 | resourceForkIO $ do 47 | () <- liftIO $ takeMVar x 48 | y' <- liftIO $ readIORef y 49 | _ <- register $ putMVar z y' 50 | return () 51 | 52 | y1 <- readIORef y 53 | y1 `shouldBe` 0 54 | 55 | putMVar x () 56 | 57 | z' <- takeMVar z 58 | z' `shouldBe` 0 59 | 60 | takeMVar w 61 | y2 <- readIORef y 62 | Just y2 `shouldBe` Just 1 63 | describe "unprotecting" $ do 64 | it "unprotect keeps resource from being cleared" $ do 65 | x <- newIORef (0 :: Int) 66 | _ <- runResourceT $ do 67 | key <- register $ writeIORef x 1 68 | unprotect key 69 | y <- readIORef x 70 | y `shouldBe` 0 71 | it "cleanup actions are masked #144" $ do 72 | let checkMasked name = do 73 | ms <- getMaskingState 74 | unless (ms == MaskedInterruptible) $ 75 | error $ show (name, ms) 76 | _ <- runResourceT $ do 77 | register (checkMasked "release") >>= release 78 | register (checkMasked "normal") 79 | Left Dummy <- try $ runResourceT $ do 80 | _ <- register (checkMasked "exception") 81 | liftIO $ throwIO Dummy 82 | return () 83 | describe "mkAcquireType" $ do 84 | describe "ResourceT" $ do 85 | it "early" $ do 86 | ref <- newIORef Nothing 87 | let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just 88 | runResourceT $ do 89 | (releaseKey, ()) <- allocateAcquire acq 90 | release releaseKey 91 | readIORef ref >>= (`shouldSatisfy` just releaseEarly) 92 | it "normal" $ do 93 | ref <- newIORef Nothing 94 | let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just 95 | runResourceT $ do 96 | (_releaseKey, ()) <- allocateAcquire acq 97 | return () 98 | readIORef ref >>= (`shouldSatisfy` just releaseNormal) 99 | it "exception" $ do 100 | ref <- newIORef Nothing 101 | let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just 102 | Left Dummy <- try $ runResourceT $ do 103 | (_releaseKey, ()) <- allocateAcquire acq 104 | liftIO $ throwIO Dummy 105 | readIORef ref >>= (`shouldSatisfy` just (releaseException dummy)) 106 | describe "with" $ do 107 | it "normal" $ do 108 | ref <- newIORef Nothing 109 | let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just 110 | with acq $ const $ return () 111 | readIORef ref >>= (`shouldSatisfy` just releaseNormal) 112 | it "exception" $ do 113 | ref <- newIORef Nothing 114 | let acq = mkAcquireType (return ()) $ \() -> writeIORef ref . Just 115 | Left Dummy <- try $ with acq $ const $ throwIO Dummy 116 | readIORef ref >>= (`shouldSatisfy` just (releaseException dummy)) 117 | describe "runResourceTChecked" $ do 118 | it "catches exceptions" $ do 119 | eres <- try $ runResourceTChecked $ void $ register $ throwIO Dummy 120 | case eres of 121 | Right () -> error "Expected an exception" 122 | Left (ResourceCleanupException Nothing ex []) -> 123 | case fromException ex of 124 | Just Dummy -> return () 125 | Nothing -> error "It wasn't Dummy" 126 | Left (ResourceCleanupException (Just _) _ []) -> error "Got a ResourceT exception" 127 | Left (ResourceCleanupException _ _ (_:_)) -> error "Got more than one" 128 | it "no exception is fine" $ (runResourceTChecked $ void $ register $ return () :: IO ()) 129 | it "catches multiple exceptions" $ do 130 | eres <- try $ runResourceTChecked $ do 131 | void $ register $ throwIO Dummy 132 | void $ register $ throwIO Dummy2 133 | case eres of 134 | Right () -> error "Expected an exception" 135 | Left (ResourceCleanupException Nothing ex1 [ex2]) -> 136 | case (fromException ex1, fromException ex2) of 137 | (Just Dummy, Just Dummy2) -> return () 138 | _ -> error $ "It wasn't Dummy, Dummy2: " ++ show (ex1, ex2) 139 | Left (ResourceCleanupException (Just _) _ [_]) -> error "Got a ResourceT exception" 140 | Left (ResourceCleanupException _ _ []) -> error "Only got 1" 141 | Left (ResourceCleanupException _ _ (_:_:_)) -> error "Got more than 2" 142 | describe "MonadMask" $ 143 | it "works" (runResourceT $ Control.Monad.Catch.bracket (return ()) (const (return ())) (const (return ())) :: IO ()) 144 | 145 | data Dummy = Dummy 146 | deriving (Show, Typeable) 147 | instance Exception Dummy 148 | 149 | data Dummy2 = Dummy2 150 | deriving (Show, Typeable) 151 | instance Exception Dummy2 152 | 153 | -- Helpers needed due to lack of 'Eq' on 'ReleaseType' 154 | 155 | releaseEarly :: ReleaseType -> Bool 156 | releaseEarly ReleaseEarly = True 157 | releaseEarly _ = False 158 | 159 | releaseNormal :: ReleaseType -> Bool 160 | releaseNormal ReleaseNormal = True 161 | releaseNormal _ = False 162 | 163 | releaseException :: (Exception e) => Selector e -> ReleaseType -> Bool 164 | releaseException sel (ReleaseExceptionWith se) = case fromException se of 165 | Just e -> sel e 166 | Nothing -> False 167 | releaseException _ _ = False 168 | 169 | just :: (a -> Bool) -> Maybe a -> Bool 170 | just sel (Just x) = sel x 171 | just _ Nothing = False 172 | 173 | dummy :: Selector Dummy 174 | dummy Dummy = True 175 | -------------------------------------------------------------------------------- /stack-9.10.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2025-03-14 2 | packages: 3 | - cereal-conduit 4 | - conduit 5 | - conduit-extra 6 | - network-conduit-tls 7 | - resourcet 8 | nix: 9 | packages: [zlib] 10 | -------------------------------------------------------------------------------- /stack-9.4.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.25 2 | packages: 3 | - cereal-conduit 4 | - conduit 5 | - conduit-extra 6 | - network-conduit-tls 7 | - resourcet 8 | nix: 9 | packages: [zlib] 10 | extra-deps: 11 | - crypton-connection-0.3.1 12 | - crypton-x509-1.7.6 13 | - crypton-x509-store-1.6.9 14 | - crypton-x509-system-1.6.7 15 | - crypton-x509-validation-1.6.12 16 | - streaming-commons-0.2.3.0 17 | - tls-1.7.0 18 | drop-packages: 19 | - cryptonite 20 | - x509 21 | - connection 22 | -------------------------------------------------------------------------------- /stack-9.6.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-22.43 2 | packages: 3 | - cereal-conduit 4 | - conduit 5 | - conduit-extra 6 | - network-conduit-tls 7 | - resourcet 8 | nix: 9 | packages: [zlib] 10 | extra-deps: 11 | - streaming-commons-0.2.3.0 12 | drop-packages: 13 | - cryptonite 14 | - x509 15 | - connection 16 | -------------------------------------------------------------------------------- /stack-9.8.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-23.14 2 | packages: 3 | - cereal-conduit 4 | - conduit 5 | - conduit-extra 6 | - network-conduit-tls 7 | - resourcet 8 | nix: 9 | packages: [zlib] 10 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.25 2 | packages: 3 | - cereal-conduit 4 | - conduit 5 | - conduit-extra 6 | - network-conduit-tls 7 | - resourcet 8 | nix: 9 | packages: [zlib] 10 | extra-deps: 11 | # - crypton-0.31 12 | - crypton-connection-0.3.1 13 | - crypton-x509-1.7.6 14 | - crypton-x509-store-1.6.9 15 | - crypton-x509-system-1.6.7 16 | - crypton-x509-validation-1.6.12 17 | - streaming-commons-0.2.3.0 18 | - tls-1.7.0 19 | drop-packages: 20 | - cryptonite 21 | - x509 22 | - connection 23 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/topics/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: crypton-connection-0.3.1@sha256:4d0958537197956b536ea91718b1749949757022532f50b8f683290056a19021,1581 9 | pantry-tree: 10 | sha256: e35ac3a35611afab9fafac633d0c4e6328b9cce4c8262378671d6c5a739e7e70 11 | size: 394 12 | original: 13 | hackage: crypton-connection-0.3.1 14 | - completed: 15 | hackage: crypton-x509-1.7.6@sha256:c567657a705b6d6521f9dd2de999bf530d618ec00f3b939df76a41fb0fe94281,2339 16 | pantry-tree: 17 | sha256: 729e7db8dfc0a8b43e08bbd8d1387c9065e39beda6ac39e0fb9f10140810a3eb 18 | size: 1080 19 | original: 20 | hackage: crypton-x509-1.7.6 21 | - completed: 22 | hackage: crypton-x509-store-1.6.9@sha256:422b9b9f87a7382c66385d047615b16fc86a68c08ea22b1e0117c143a2d44050,1750 23 | pantry-tree: 24 | sha256: 87654d130a7f987ee139c821a1be45736d18df9fa4cb1142c4e054d3802338f3 25 | size: 406 26 | original: 27 | hackage: crypton-x509-store-1.6.9 28 | - completed: 29 | hackage: crypton-x509-system-1.6.7@sha256:023ed573d82983bc473a37a89e0434a085b413be9f68d07e085361056afd4637,1532 30 | pantry-tree: 31 | sha256: c0ca49e6a9537f3fdb7b47c5cfe93f7d744a369bf9d089f3c668b9c2d97402b7 32 | size: 399 33 | original: 34 | hackage: crypton-x509-system-1.6.7 35 | - completed: 36 | hackage: crypton-x509-validation-1.6.12@sha256:85989721b64be4b90de9f66ef641c26f57575cffed1a50d707065fb60176f386,2227 37 | pantry-tree: 38 | sha256: d4a0135f11218614fcd912cffaf54de8f749caca8696380e2589cbcfd64cc681 39 | size: 639 40 | original: 41 | hackage: crypton-x509-validation-1.6.12 42 | - completed: 43 | hackage: streaming-commons-0.2.3.0@sha256:68d5f3daa6caa7cc7d659094a03d543021df5ec4737b67e63ffa4541ac0aae10,4841 44 | pantry-tree: 45 | sha256: 66a00daed951de5a26118dac7e34c72ee32f33ddcd3a50981d80b4dd244992b4 46 | size: 2374 47 | original: 48 | hackage: streaming-commons-0.2.3.0 49 | - completed: 50 | hackage: tls-1.7.0@sha256:fa82e9ca8fd887b66fba8433b3ba1db4e5e047fe7c815707f06209679d04177b,5566 51 | pantry-tree: 52 | sha256: 7521091021ecbbbf9b46c2fdb08f9e449eddcebf3a3922f76d23baca5db83b4f 53 | size: 4897 54 | original: 55 | hackage: tls-1.7.0 56 | snapshots: 57 | - completed: 58 | sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd 59 | size: 640086 60 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml 61 | original: lts-21.25 62 | --------------------------------------------------------------------------------