├── .clang-format ├── .drone.yml ├── .github └── workflows │ └── ci.yml ├── .gitignore ├── .gitmodules ├── AUTHORS ├── CODE_OF_CONDUCT.md ├── ChangeLog.md ├── LICENSE ├── README.md ├── Z-IO.cabal ├── Z ├── IO.hs └── IO │ ├── BIO.hs │ ├── BIO │ ├── Base.hs │ ├── Concurrent.hs │ └── Zlib.hsc │ ├── Buffered.hs │ ├── Environment.hs │ ├── Exception.hs │ ├── FileSystem.hs │ ├── FileSystem │ ├── Base.hs │ ├── FilePath.hsc │ ├── Threaded.hs │ └── Watch.hs │ ├── Logger.hs │ ├── LowResTimer.hs │ ├── Network.hs │ ├── Network │ ├── DNS.hsc │ ├── IPC.hs │ ├── SocketAddr.hsc │ ├── TCP.hs │ └── UDP.hs │ ├── Process.hsc │ ├── Resource.hs │ ├── StdStream.hs │ ├── StdStream │ └── Ansi.hs │ ├── Time.hs │ └── UV │ ├── Errno.hsc │ ├── FFI.hsc │ ├── FFI_Env.hsc │ ├── Manager.hs │ ├── UVStream.hs │ └── Win.hs ├── bench ├── GetTime.hs └── Http.hs ├── cbits ├── hs_cwalk.c ├── hs_uv_base.c ├── hs_uv_dns.c ├── hs_uv_file.c ├── hs_uv_fs_event.c ├── hs_uv_process.c ├── hs_uv_stream.c ├── hs_uv_udp.c └── hs_zlib.c ├── include ├── fs_shared.hs ├── hs_cwalk.h └── hs_uv.h └── test ├── Spec.hs └── Z └── IO ├── BIO ├── BaseSpec.hs ├── ConcurrentSpec.hs └── ZlibSpec.hs ├── FileSystem └── ThreadedSpec.hs ├── FileSystemSpec.hs ├── LowResTimerSpec.hs ├── Network ├── IPCSpec.hs ├── TCPSpec.hs └── UDPSpec.hs ├── ProcessSpec.hs └── ResourceSpec.hs /.clang-format: -------------------------------------------------------------------------------- 1 | --- 2 | Language: Cpp 3 | # BasedOnStyle: LLVM 4 | AccessModifierOffset: -2 5 | AlignAfterOpenBracket: Align 6 | AlignConsecutiveMacros: false 7 | AlignConsecutiveAssignments: false 8 | AlignConsecutiveBitFields: false 9 | AlignConsecutiveDeclarations: false 10 | AlignEscapedNewlines: Right 11 | AlignOperands: Align 12 | AlignTrailingComments: true 13 | AllowAllArgumentsOnNextLine: true 14 | AllowAllConstructorInitializersOnNextLine: true 15 | AllowAllParametersOfDeclarationOnNextLine: true 16 | AllowShortEnumsOnASingleLine: true 17 | AllowShortBlocksOnASingleLine: Never 18 | AllowShortCaseLabelsOnASingleLine: false 19 | AllowShortFunctionsOnASingleLine: All 20 | AllowShortLambdasOnASingleLine: All 21 | AllowShortIfStatementsOnASingleLine: Never 22 | AllowShortLoopsOnASingleLine: false 23 | AlwaysBreakAfterDefinitionReturnType: None 24 | AlwaysBreakAfterReturnType: None 25 | AlwaysBreakBeforeMultilineStrings: false 26 | AlwaysBreakTemplateDeclarations: MultiLine 27 | BinPackArguments: true 28 | BinPackParameters: true 29 | BraceWrapping: 30 | AfterCaseLabel: false 31 | AfterClass: false 32 | AfterControlStatement: Never 33 | AfterEnum: false 34 | AfterFunction: false 35 | AfterNamespace: false 36 | AfterObjCDeclaration: false 37 | AfterStruct: false 38 | AfterUnion: false 39 | AfterExternBlock: false 40 | BeforeCatch: false 41 | BeforeElse: false 42 | BeforeLambdaBody: false 43 | BeforeWhile: false 44 | IndentBraces: false 45 | SplitEmptyFunction: true 46 | SplitEmptyRecord: true 47 | SplitEmptyNamespace: true 48 | BreakBeforeBinaryOperators: None 49 | BreakBeforeBraces: Attach 50 | BreakBeforeInheritanceComma: false 51 | BreakInheritanceList: BeforeColon 52 | BreakBeforeTernaryOperators: true 53 | BreakConstructorInitializersBeforeComma: false 54 | BreakConstructorInitializers: BeforeColon 55 | BreakAfterJavaFieldAnnotations: false 56 | BreakStringLiterals: true 57 | ColumnLimit: 80 58 | CommentPragmas: '^ IWYU pragma:' 59 | CompactNamespaces: false 60 | ConstructorInitializerAllOnOneLineOrOnePerLine: false 61 | ConstructorInitializerIndentWidth: 4 62 | ContinuationIndentWidth: 4 63 | Cpp11BracedListStyle: true 64 | DeriveLineEnding: true 65 | DerivePointerAlignment: false 66 | DisableFormat: false 67 | ExperimentalAutoDetectBinPacking: false 68 | FixNamespaceComments: true 69 | ForEachMacros: 70 | - foreach 71 | - Q_FOREACH 72 | - BOOST_FOREACH 73 | IncludeBlocks: Preserve 74 | IncludeCategories: 75 | - Regex: '^"(llvm|llvm-c|clang|clang-c)/' 76 | Priority: 2 77 | SortPriority: 0 78 | - Regex: '^(<|"(gtest|gmock|isl|json)/)' 79 | Priority: 3 80 | SortPriority: 0 81 | - Regex: '.*' 82 | Priority: 1 83 | SortPriority: 0 84 | IncludeIsMainRegex: '(Test)?$' 85 | IncludeIsMainSourceRegex: '' 86 | IndentCaseLabels: false 87 | IndentCaseBlocks: false 88 | IndentGotoLabels: true 89 | IndentPPDirectives: None 90 | IndentExternBlock: AfterExternBlock 91 | IndentWidth: 2 92 | IndentWrappedFunctionNames: false 93 | InsertTrailingCommas: None 94 | JavaScriptQuotes: Leave 95 | JavaScriptWrapImports: true 96 | KeepEmptyLinesAtTheStartOfBlocks: true 97 | MacroBlockBegin: '' 98 | MacroBlockEnd: '' 99 | MaxEmptyLinesToKeep: 1 100 | NamespaceIndentation: None 101 | ObjCBinPackProtocolList: Auto 102 | ObjCBlockIndentWidth: 2 103 | ObjCBreakBeforeNestedBlockParam: true 104 | ObjCSpaceAfterProperty: false 105 | ObjCSpaceBeforeProtocolList: true 106 | PenaltyBreakAssignment: 2 107 | PenaltyBreakBeforeFirstCallParameter: 19 108 | PenaltyBreakComment: 300 109 | PenaltyBreakFirstLessLess: 120 110 | PenaltyBreakString: 1000 111 | PenaltyBreakTemplateDeclaration: 10 112 | PenaltyExcessCharacter: 1000000 113 | PenaltyReturnTypeOnItsOwnLine: 60 114 | PointerAlignment: Right 115 | ReflowComments: true 116 | SortIncludes: true 117 | SortUsingDeclarations: true 118 | SpaceAfterCStyleCast: false 119 | SpaceAfterLogicalNot: false 120 | SpaceAfterTemplateKeyword: true 121 | SpaceBeforeAssignmentOperators: true 122 | SpaceBeforeCpp11BracedList: false 123 | SpaceBeforeCtorInitializerColon: true 124 | SpaceBeforeInheritanceColon: true 125 | SpaceBeforeParens: ControlStatements 126 | SpaceBeforeRangeBasedForLoopColon: true 127 | SpaceInEmptyBlock: false 128 | SpaceInEmptyParentheses: false 129 | SpacesBeforeTrailingComments: 1 130 | SpacesInAngles: false 131 | SpacesInConditionalStatement: false 132 | SpacesInContainerLiterals: true 133 | SpacesInCStyleCastParentheses: false 134 | SpacesInParentheses: false 135 | SpacesInSquareBrackets: false 136 | SpaceBeforeSquareBrackets: false 137 | Standard: Latest 138 | StatementMacros: 139 | - Q_UNUSED 140 | - QT_REQUIRE_VERSION 141 | TabWidth: 8 142 | UseCRLF: false 143 | UseTab: Never 144 | WhitespaceSensitiveMacros: 145 | - STRINGIZE 146 | - PP_STRINGIZE 147 | - BOOST_PP_STRINGIZE 148 | ... 149 | 150 | -------------------------------------------------------------------------------- /.drone.yml: -------------------------------------------------------------------------------- 1 | kind: pipeline 2 | name: arm64 3 | platform: { os: linux, arch: arm64 } 4 | steps: 5 | - name: submodules 6 | image: alpine/git 7 | commands: 8 | - git submodule update --init --recursive 9 | 10 | - name: Test 11 | image: buildpack-deps:focal 12 | commands: 13 | - export LC_ALL=C.UTF-8 14 | - apt-get update -y 15 | - apt-get install -y ghc cabal-install 16 | - cabal update 17 | - cabal new-test 18 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | on: [push, pull_request] 2 | name: ci 3 | 4 | jobs: 5 | build: 6 | name: GHC ${{ matrix.ghc-version }} on ${{ matrix.os }} 7 | runs-on: ${{ matrix.os }} 8 | strategy: 9 | fail-fast: false 10 | matrix: 11 | os: [ubuntu-latest, windows-latest, macOS-latest] 12 | ghc-version: ["9.2", "9.4"] 13 | cabal: ["3.8"] 14 | avx_flag: ["", '--constraint="Z-Data +use-avx2"'] 15 | env: 16 | CONFIG: "--enable-tests --enable-benchmarks" 17 | 18 | steps: 19 | - name: CPU info 20 | run: | 21 | if [ "$RUNNER_OS" == "Linux" ]; then 22 | sudo apt-get install cpuid 23 | cpuid 24 | elif [ "$RUNNER_OS" == "macOS" ]; then 25 | brew install cpuid 26 | cpuid 27 | fi 28 | shell: bash 29 | 30 | - uses: actions/checkout@v4 31 | with: 32 | submodules: "recursive" 33 | 34 | - name: Set up GHC ${{ matrix.ghc-version }} 35 | uses: haskell-actions/setup@v2 36 | id: setup 37 | with: 38 | ghc-version: ${{ matrix.ghc-version }} 39 | cabal-version: ${{ matrix.cabal }} 40 | cabal-update: true 41 | 42 | - name: Configure the build 43 | run: | 44 | cabal configure ${{ matrix.avx_flag }} $CONFIG 45 | cabal build all --dry-run 46 | 47 | - name: Restore cached dependencies 48 | uses: actions/cache/restore@v3 49 | id: cache 50 | env: 51 | key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }} 52 | with: 53 | path: ${{ steps.setup.outputs.cabal-store }} 54 | key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }} 55 | restore-keys: ${{ env.key }}- 56 | 57 | - name: Install dependencies 58 | # If we had an exact cache hit, the dependencies will be up to date. 59 | if: steps.cache.outputs.cache-hit != 'true' 60 | run: cabal build all --only-dependencies 61 | 62 | # Cache dependencies already here, so that we do not have to rebuild them should the subsequent steps fail. 63 | - name: Save cached dependencies 64 | uses: actions/cache/save@v3 65 | # If we had an exact cache hit, trying to save the cache would error because of key clash. 66 | if: steps.cache.outputs.cache-hit != 'true' 67 | with: 68 | path: ${{ steps.setup.outputs.cabal-store }} 69 | key: ${{ steps.cache.outputs.cache-primary-key }} 70 | 71 | - name: Build 72 | run: cabal build $CONFIG 73 | 74 | - name: Run tests 75 | # https://github.com/haskell/cabal/issues/7883 76 | run: | 77 | if [ "$RUNNER_OS" == "Windows" ]; then 78 | # windows need permission to open pipes 79 | cabal test --enable-tests --test-show-details=direct --test-options='--skip=IPC --skip=Process' 80 | else 81 | cabal test --enable-tests --test-show-details=direct 82 | fi 83 | shell: bash 84 | 85 | - run: | 86 | cabal haddock 87 | cabal check 88 | cabal sdist 89 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | test-* 4 | cabal-dev 5 | *.o 6 | *.hi 7 | *.hie 8 | *.chi 9 | *.chs.h 10 | *.dyn_o 11 | *.dyn_hi 12 | .hpc 13 | .hsenv 14 | .cabal-sandbox/ 15 | cabal.sandbox.config 16 | *.prof 17 | *.aux 18 | *.hp 19 | *.eventlog 20 | .stack-work/ 21 | cabal.project 22 | cabal.project.local 23 | cabal.project.local~ 24 | .HTF/ 25 | .ghc.environment.* 26 | example/** 27 | !examples/wordcount.hs 28 | !examples/examples.cabal 29 | /_local/ 30 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "third_party/libuv"] 2 | path = third_party/libuv 3 | url = https://github.com/ZHaskell/libuv.git 4 | [submodule "third_party/zlib"] 5 | path = third_party/zlib 6 | url = https://github.com/ZHaskell/zlib.git 7 | [submodule "third_party/cwalk"] 8 | path = third_party/cwalk 9 | url = https://github.com/likle/cwalk.git 10 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | # Authors ordered by first contribution. 2 | Dong Han 3 | Tao He 4 | Song Xue 5 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Code of Conduct 2 | 3 | The Z.Haskell project adheres to the [Haskell Foundation Guidelines For Respectful Communication](https://haskell.foundation/guidelines-for-respectful-communication/). This describes the minimum behavior expected from all contributors. 4 | 5 | ## Enforcement 6 | 7 | Instances of violations of the Code of Conduct can be reported by contacting the project team at [winterland1989@gmail.com](mailto:winterland1989@gmail.com). 8 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for Z-IO 2 | 3 | ## 1.0.1.0 -- 2020-07-24 4 | 5 | Maintenance release: 6 | 7 | * Update libuv to v1.42.0, rewrite `UV_Stream`'s `Output` instance to perform a `uv_try_write` first since now `uv_try_write` is sensible. 8 | 9 | ## 1.0.0.0 -- 2020-07-08 10 | 11 | * Clean function names in `Z.IO.BIO` module, now no `BIO` or `Node` suffix anymore. 12 | * `Z.IO.BIO` is not re-exported from `Z.IO` anymore, user are recommended to import it with qualified name, e.g. `import qualified Z.IO.BIO as BIO`. 13 | * Add `foldl'` and `foldIO'` to `Z.IO.BIO` to use with `Fold` and `FoldM` from `foldl` package. 14 | * Add `INLINABLE` pragmas to many functions. 15 | * Add `printStdLnP` to `Z.IO.StdStream`, a `Parser` debug tool. 16 | 17 | ## 0.8.1.0 -- 2020-06-12 18 | 19 | * Remove `-march=native` flag to improve binary portability. 20 | 21 | ## 0.8.1.0 -- 2020-04-25 22 | 23 | * Add `getInterface` to `Z.IO.Network`. 24 | * `mkstemp` now return opend file, the type changed to `mkstemp :: CBytes -> CBytes -> Bool -> Resource (CBytes, File)`, which has an option for keep file or not. 25 | * `initTempFile` and `initTempDir` now do not need a prefix argument, the prefix is hardcoded as `Z-IO-`. 26 | 27 | ## 0.8.0.0 -- 2020-04-25 28 | 29 | This is an experimental version to test new 'BIO' module. 30 | 31 | * Rewrite `Z.IO.BIO` module, now `BIO` is push based. 32 | * Remove `>|>`, `>~>`, `>!>`, now `BIO` nodes can be composed via funtion composition `(.)`! 33 | * Remove `zipSource/zipBIO`, add `stepBIO/stepBIO_/runBIO_`. 34 | * Add `zipBIO` to `Z.IO.BIO.Concurrent`, which run two BIO nodes concurrently. 35 | * Add `ungroupingNode`, change `newGroupingNode` to use `Vector`. 36 | * Rename `EOF` exception to `UnexpectedEOF` to avoid the clash with `EOF` pattern. 37 | 38 | ## 0.7.1.0 -- 2020-03-16 39 | 40 | * Use `CPtr` from Z-Data instead of `ForeignPtr`. 41 | 42 | ## 0.7.0.0 -- 2020-03-09 43 | 44 | * Change resource `Pool` to keyed by default, add `SimplePool`. 45 | * Add `Semigroup` instance to `Logger`. 46 | * Add `clearInputBuffer/clearOutputBuffer` to `Z.IO.Buffered`. 47 | * Add `catchSync/ingoreSync` to `Z.IO.Exception`. 48 | * Add `putStdLn/printStdLn` back. 49 | 50 | ## 0.6.4.0 -- 2020-02-20 51 | 52 | * Add `initProcess'` to kill process while finish using the process resource by default. 53 | 54 | ## 0.6.3.0 -- 2020-02-20 55 | 56 | * Split `Z.IO.UV.FFI` to `Z.IO.UV.FFI` and `Z.IO.UV.FFI_Env`, to make the module buildable when memory is constrained. 57 | * Make functions works on TTY in `Z.IO.StdStream` correctly ignore redirected streams. 58 | * Move `pathSeparator` to `pathSeparators`, now `pathSeparator` return the default path separator. 59 | 60 | ## 0.6.2.0 -- 2020-02-18 61 | 62 | * Hide `Logger` constructor from `Z.IO.Logger`, remove implementation details such as `defaultTSCache`, `pushLogIORef`, `flushLogIORef`, add `loggerFormatter` to `LoggerConfig`. 63 | * Add `newStdLogger/newFileLogger` to make new logger easily. 64 | * Rework `Z.IO.FileSystem.Watch`'s API, change `watchDirs` to accept a recursive param and a callback. 65 | * Hide `Z.IO.UV.Win` module, which should not be directly used by user. 66 | * Fix a bug when stdio is redirected to pipes: https://github.com/ZHaskell/z-io/pull/16 67 | 68 | ## 0.6.1.0 -- 2020-02-09 69 | 70 | * Fix a bug in `newMagicSplitter/newLineSplitter` code. 71 | * Remove `sourceFromInput` and related functions to reduce API surface, use `newBufferedInput` with `sourceFromBuffered` instead. 72 | * Refactor server loop to allow more code sharing between `Z.IO.Network.TCP` and `Z.IO.Network.IPC`. 73 | 74 | ## 0.6.0.0 -- 2020-02-04 75 | 76 | * FileSystem: replace `DEFAULT_MODE` with `DEFAULT_FILE_MODE` & `DEFAULT_DIR_MODE`. 77 | * Ignore exception while `mkdirp` on an exist directory. 78 | * Make `rmrf` more like `rm -rf`, which can be used on files. 79 | * Add `doesPathExist/doesFileExist/doesDirExist` to file system module. 80 | * Add `Z.IO.FileSystem` re-export `Z.IO.FileSystem.Watch` and `Z.IO.FileSystem.FilePath`. 81 | * Add `mkstemp`, `initTempFile/initTempDir` to file system module. 82 | 83 | ## 0.5.0.0 -- 2020-01-28 84 | 85 | * Add `unwrap/unwrap'` to `Z.IO.Exception`. 86 | * Add `readParseChunks` to `Z.IO.Buffered`, Change `readParser`'s type to match `readParseChunks`. 87 | * Add `sourceParseChunksBufferedInput`, `sourceParseChunksInput` to `Z.IO.BIO`. 88 | * Add `newJSONLogger/defaultJSONFmt` to `Z.IO.Logger`, provide simple JSON structured logging. 89 | 90 | ## 0.3.0.0 -- 2020-12-29 91 | 92 | * Add `getSystemTime'` to `Z.IO.Time`. 93 | * Add `shutdownUVStream` to `Z.IO.UV.UVStream`. 94 | * Change `sourceFrom/sinkToFile` to `initSourceFrom/initSinkToFile`. 95 | * Bump `Z-Data` version. 96 | 97 | ## 0.2.0.0 -- 2020-12-16 98 | 99 | * Add `sourceParsedBufferInput` and JSON sources to `Z.IO.BIO`. 100 | * Fix `readLine` and `newLineSplitter`. 101 | * Improve low resolution timer precision. 102 | * Fix a bug in `Z.IO.FileSystem.FilePath.relative`, see [#17](https://github.com/likle/cwalk/issues/17). 103 | 104 | ## 0.1.9.0 -- 2020-11-23 105 | 106 | * Clean up API in `Z.IO.Buffered`, remove `readToMagic'`, `readLine'`, `readExactly'`. 107 | * `readExactly` now throw exception when not reading enough bytes before EOF. 108 | * Add `Show/ShowT` instance to `UVStream`, `StdStream`, `UDP`, `UVManager`. 109 | * Add JSON instance to various types: `SocketAddr` and all configure types. 110 | * Rename `InetAddr` to `IPv4`, `Inet6Addr` to `IPv6`, change `SocketAddr` 's constructor name, and payload order. 111 | * Add `seek` to `Z.IO.FileSystem`. 112 | 113 | ## 0.1.8.1 -- 2020-11-21 114 | 115 | * Export `ZStream` type from `Z.IO.BIO.Zlib` 116 | 117 | ## 0.1.8.0 -- 2020-11-20 118 | 119 | * Remove type index from `BufferedInput`, `BufferedOutput`. 120 | * Add `Z.IO.BIO` module to facilitate streaming process, and `Z.IO.BIO.Concurrent` to facilitate producer-consumer model. 121 | * Remove streamming related functions from `Z.IO.Buffered`, use `Z.IO.BIO` instead. 122 | * Move `Z.IO.Compression.Zlib` to `Z.IO.BIO.Zlib`, change API to `BIO` style. 123 | * Add `Z.IO.FileSystem.Watch` module, provides cross-platform filesystem watching. 124 | 125 | ## 0.1.7.0 -- 2020-10-24 126 | 127 | * Add `iso8016DateFormat`, change logger's default time format to include time zone. 128 | * Rename `warn` to `warning`, change `Level` to `Int` type alias in `Z.IO.Logger`, add `critical`. 129 | * Export `TimeVal` from `Z.IO.Environment`. 130 | * Add `getCPUInfo`, `getLoadAvg`, `getXXXMem` to `Z.IO.Environment`. 131 | 132 | ## 0.1.6.1 -- 2020-10-17 133 | 134 | * Export `ResUsage` from `Z.IO.Environment`. 135 | * Export `Level` from `Z.IO.Logger`. 136 | * Add linefeed with default logger formattor. 137 | 138 | ## 0.1.6.0 -- 2020-10-17 139 | 140 | * Fix a bug affects udp exception raising(simliar to the one fixed in 0.1.5.2). 141 | * Add `Z.IO.StdStream.Ansi` module, add a default colored logger. 142 | * Add `Z.IO.Time` module, for fast time parsing and formatting. 143 | * Add `Z.IO.FileSystem.FilePath` module for file path manipulations. 144 | * Add `getCWD`, `chDir`, `getHomeDir`, `getTempDir`, `getPassWD` to `Z.IO.Environment`. 145 | * Add `chown`, `fchown`, `lchown` to `Z.IO.FileSystem` and `Z.IO.FileSystem.Threaded`. 146 | * Rename `UVFD` to `FD` accross module. 147 | 148 | ## 0.1.5.2 -- 2020-10-13 149 | 150 | * Fix windows dist(add `fs-fd-hash-inl.h` to other-source-files). 151 | 152 | ## 0.1.5.1 -- 2020-10-13 153 | 154 | * Export `ProcessFlag` from `Z.IO.Process`. 155 | * Add quick read & write functions to fileSystem modules. 156 | * Fix a bug: when exception raise from server loop an uninitialized uv_check_t is closed. 157 | * Update libuv's version to 1.40.1. 158 | * Change `IOEInfo` type to use `Text` instead of `CBytes`. 159 | 160 | ## 0.1.5.0 -- 2020-10-10 161 | 162 | * Add `Z.IO.Process` module. 163 | * Move many flag type to type alias from newtype, adjust patterns haddock. 164 | * Sync IPC's server API to TCP's. 165 | 166 | ## 0.1.4.0 -- 2020-10-02 167 | 168 | * Add `Z.IO.Environment` module. 169 | * Add various instances to data types in `Z.IO.UV.FFI`. 170 | * Fix a UDP batch receiving bug. 171 | * Remove `UV` prefix in config data types(`Z.IO.FileSystem`, `Z.IO.UDP`). 172 | * Change `TCP`, `IPC` server config, move server worker to start params instead of config. 173 | * `Logger` type rework, colorful logger are possible. 174 | 175 | ## 0.1.3.0 -- 2020-09-28 176 | * Rename `newBufferedInput/Output` to `newBufferedInput'/Output'`, add default chunk `newBufferedInput/Output`. 177 | * Remove `ghc-pirm` depends. 178 | * Make library works with GHC 8.6 and 8.8 again. 179 | 180 | ## 0.1.2.0 -- 2020-09-28 181 | 182 | * Add file offset interface back, see `FilePtr` and `FilePtrT`. 183 | * Remove `checkFileTClosed` from `Z.IO.FileSystem.Threaded`. 184 | * Take c source file list from libuv Makefile, remove lib requirements on linux and osx. 185 | * Fix `uv_check_t` initiate order in accept loop, which cause a segfault. 186 | 187 | ## 0.1.1.2 -- 2020-09-25 188 | 189 | * Fix macOS build problem caused by missing zconf.h. 190 | * Add more tests(TCP, IPC). 191 | 192 | ## 0.1.1.0 -- 2020-09-19 193 | 194 | * Add stream utilities to `Z.IO.Buffered`. 195 | * Add `Z.Compression.Zlib`. 196 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) Z.Haskell Contributors, 2017-2020 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 winter 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 | 32 | -------------------------------------------------------------------------------- 33 | libuv is licensed for use as follows: 34 | 35 | ==== 36 | Copyright (c) 2015-present libuv project contributors. 37 | 38 | Permission is hereby granted, free of charge, to any person obtaining a copy 39 | of this software and associated documentation files (the "Software"), to 40 | deal in the Software without restriction, including without limitation the 41 | rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 42 | sell copies of the Software, and to permit persons to whom the Software is 43 | furnished to do so, subject to the following conditions: 44 | 45 | The above copyright notice and this permission notice shall be included in 46 | all copies or substantial portions of the Software. 47 | 48 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 49 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 50 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 51 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 52 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 53 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 54 | IN THE SOFTWARE. 55 | ==== 56 | 57 | This license applies to parts of libuv originating from the 58 | https://github.com/joyent/libuv repository: 59 | 60 | ==== 61 | 62 | Copyright Joyent, Inc. and other Node contributors. All rights reserved. 63 | Permission is hereby granted, free of charge, to any person obtaining a copy 64 | of this software and associated documentation files (the "Software"), to 65 | deal in the Software without restriction, including without limitation the 66 | rights to use, copy, modify, merge, publish, distribute, sublicense, and/or 67 | sell copies of the Software, and to permit persons to whom the Software is 68 | furnished to do so, subject to the following conditions: 69 | 70 | The above copyright notice and this permission notice shall be included in 71 | all copies or substantial portions of the Software. 72 | 73 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 74 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 75 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 76 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 77 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 78 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS 79 | IN THE SOFTWARE. 80 | 81 | ==== 82 | 83 | This license applies to all parts of libuv that are not externally 84 | maintained libraries. 85 | 86 | The externally maintained libraries used by libuv are: 87 | 88 | - tree.h (from FreeBSD), copyright Niels Provos. Two clause BSD license. 89 | 90 | - inet_pton and inet_ntop implementations, contained in src/inet.c, are 91 | copyright the Internet Systems Consortium, Inc., and licensed under the ISC 92 | license. 93 | 94 | - stdint-msvc2008.h (from msinttypes), copyright Alexander Chemeris. Three 95 | clause BSD license. 96 | 97 | - pthread-fixes.c, copyright Google Inc. and Sony Mobile Communications AB. 98 | Three clause BSD license. 99 | 100 | - android-ifaddrs.h, android-ifaddrs.c, copyright Berkeley Software Design 101 | Inc, Kenneth MacKay and Emergya (Cloud4all, FP7/2007-2013, grant agreement 102 | n° 289016). Three clause BSD license. 103 | 104 | -------------------------------------------------------------------------------- 105 | 106 | MIT License 107 | 108 | Copyright (c) 2020 Leonard Iklé 109 | 110 | Permission is hereby granted, free of charge, to any person obtaining a copy 111 | of this software and associated documentation files (the "Software"), to deal 112 | in the Software without restriction, including without limitation the rights 113 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 114 | copies of the Software, and to permit persons to whom the Software is 115 | furnished to do so, subject to the following conditions: 116 | 117 | The above copyright notice and this permission notice shall be included in all 118 | copies or substantial portions of the Software. 119 | 120 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 121 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 122 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 123 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 124 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 125 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 126 | SOFTWARE. 127 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Z-IO 2 | 3 | [![Hackage](https://img.shields.io/hackage/v/Z-IO.svg?style=flat)](https://hackage.haskell.org/package/Z-IO) 4 | [![Linux Build Status](https://github.com/ZHaskell/z-io/workflows/ubuntu-ci/badge.svg)](https://github.com/ZHaskell/z-io/actions) 5 | [![MacOS Build Status](https://github.com/ZHaskell/z-io/workflows/osx-ci/badge.svg)](https://github.com/ZHaskell/z-io/actions) 6 | [![Windows Build Status](https://github.com/ZHaskell/z-io/workflows/win-ci/badge.svg)](https://github.com/ZHaskell/z-io/actions) 7 | [![Docker Build Status](https://github.com/ZHaskell/z-io/workflows/docker-ci/badge.svg)](https://github.com/ZHaskell/z-io/actions) 8 | [![Gitter chat](https://badges.gitter.im/gitterHQ/gitter.svg)](https://gitter.im/Z-Haskell/community) 9 | 10 | 11 | 12 | 13 | This package is part of [Z.Haskell](https://z.haskell.world) project, provides basic IO operations: 14 | 15 | * IO resource management, resource pool 16 | * File system operations 17 | * Network: DNS, TCP, UDP and IPC 18 | * Buffered input and output 19 | * Process management 20 | * Environment settings 21 | * High performance logger 22 | * High performance low resolution timer 23 | 24 | ## Requirements 25 | 26 | * A working haskell compiler system, GHC(>=8.6), cabal-install(>=2.4), hsc2hs. 27 | * Tests need [hspec-discover](https://hackage.haskell.org/package/hspec-discover). 28 | 29 | ## Example usage 30 | 31 | ```haskell 32 | > :set -XOverloadedStrings 33 | > import Z.IO.Network 34 | > import Z.IO.Resource 35 | > import Z.IO.Buffered 36 | > 37 | > -- call getAddrInfo to perform DNS 38 | > head <$> getAddrInfo Nothing "www.bing.com" "http" 39 | AddrInfo {addrFlags = [AI_ADDRCONFIG,AI_V4MAPPED], addrFamily = SocketFamily 2, addrSocketType = SocketType 1, addrProtocol = ProtocolNumber 6, addrAddress = 204.79.197.200:80, addrCanonName = ""} 40 | > 41 | > import qualified Z.Data.Text as T 42 | > -- send a simple HTTP request 43 | > :{ 44 | let addr = ipv4 "13.107.21.200" 80 45 | in withResource (initTCPClient defaultTCPClientConfig{ tcpRemoteAddr = addr}) $ \ tcp -> do 46 | (i, o) <- newBufferedIO tcp 47 | writeBuffer' o "GET http://www.bing.com HTTP/1.1\r\nHost: www.bing.com\r\n\r\n" 48 | readBuffer i >>= pure . T.validate 49 | :} 50 | "HTTP/1.1 200 OK\r\nDate: Sat, 19 Sep 2020 06:11:08 GMT\r\nContent-Length: 0\r\n\r\n" 51 | > 52 | > -- Start a TCP echo server, use @nc -v localhost 8080@ to test 53 | > :{ 54 | startTCPServer defaultTCPServerConfig{ 55 | tcpListenAddr = SocketAddrIPv4 ipv4Loopback 8080} $ \ tcp -> do 56 | i <- newBufferedInput tcp 57 | o <- newBufferedOutput tcp 58 | forever $ readBuffer i >>= writeBuffer o >> flushBuffer o 59 | } 60 | :} 61 | ``` 62 | 63 | ## Dev guide 64 | 65 | ```bash 66 | # get code 67 | git clone --recursive git@github.com:ZHaskell/z-io.git 68 | cd z-io 69 | # build 70 | cabal build 71 | # test 72 | cabal run Z-IO-Test 73 | # install 74 | cabal install 75 | # generate document 76 | cabal haddock 77 | ``` 78 | -------------------------------------------------------------------------------- /Z/IO.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Z.IO 3 | Description : IO Umbrella module 4 | Copyright : (c) Dong Han, 2020 5 | License : BSD 6 | Maintainer : winterland1989@gmail.com 7 | Stability : experimental 8 | Portability : non-portable 9 | 10 | This re-exports several common modules to be used together with file, network, and other specific modules, 11 | such as resource management, buffered IO and std streams. 12 | 13 | -} 14 | 15 | module Z.IO 16 | ( module Z.IO.Buffered 17 | , module Z.IO.Environment 18 | , module Z.IO.Exception 19 | , module Z.IO.Logger 20 | , module Z.IO.Resource 21 | , module Z.IO.StdStream 22 | , forkBa 23 | ) where 24 | 25 | import Z.IO.Buffered 26 | import Z.IO.Environment 27 | import Z.IO.Exception 28 | import Z.IO.Logger 29 | import Z.IO.Resource 30 | import Z.IO.StdStream 31 | import Z.IO.UV.Manager (forkBa) 32 | 33 | -------------------------------------------------------------------------------- /Z/IO/BIO.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Z.IO.BIO.Base 3 | Description : Composable IO Loops 4 | Copyright : (c) Dong Han, 2017-2020 5 | License : BSD 6 | Maintainer : winterland1989@gmail.com 7 | Stability : experimental 8 | Portability : non-portable 9 | 10 | This module provides 'BIO' (block IO) type to facilitate writing streaming programs. A 'BIO' node usually: 11 | 12 | * Process input in unit of block(or item). 13 | * Running in constant spaces, which means the memory usage won't accumulate. 14 | * Keep some state in IO, which is sealed in 'BIO' closure. 15 | 16 | Some examples of such nodes are: 17 | 18 | * Compressor \/ decompressor, e.g. zlib, etc. 19 | * Codec, e.g. utf8 codec, base64 codec. 20 | * Ciphers. 21 | * Packet parsers. 22 | 23 | We use @BIO inp out@ type to represent all the objects above, @BIO Void out@ to represent an 'IO' source, 24 | and @BIO inp Void@ to represent an 'IO' sink, which can all be connected with '.' to build a larger 'BIO' node. 25 | 26 | @ 27 | import Z.Data.CBytes (CBytes) 28 | import Z.IO 29 | import Z.IO.BIO 30 | import Z.IO.BIO.Zlib 31 | 32 | base64AndCompressFile :: HasCallStack => CBytes -> CBytes -> IO () 33 | base64AndCompressFile origin target = do 34 | base64Enc <- newBase64Encoder 35 | (_, zlibCompressor) <- newCompress defaultCompressConfig{compressWindowBits = 31} 36 | 37 | withResource (initSourceFromFile origin) $ \ src -> 38 | withResource (initSinkToFile target) $ \ sink -> 39 | run_ $ src . base64Enc . zlibCompressor . sink 40 | 41 | > base64AndCompressFile "test" "test.gz" 42 | -- run 'zcat "test.gz" | base64 -d' will give you original file 43 | @ 44 | 45 | This module is intended to be imported qualified: 46 | @ 47 | import Z.IO.BIO (BIO, Source, Sink) 48 | import qualified Z.IO.BIO as BIO 49 | @ 50 | 51 | -} 52 | module Z.IO.BIO ( 53 | -- * The BIO type 54 | BIO, pattern EOF, Source, Sink 55 | -- ** Basic combinators 56 | , appendSource, concatSource, concatSource' 57 | , joinSink, fuseSink 58 | -- * Run BIO chain 59 | , discard 60 | , step, step_ 61 | , run, run_ 62 | , runBlock, runBlock_, unsafeRunBlock 63 | , runBlocks, runBlocks_, unsafeRunBlocks 64 | -- * Make new BIO 65 | , fromPure, fromIO 66 | , filter, filterIO 67 | -- * Use with fold 68 | , fold', foldIO' 69 | -- ** Source 70 | , initSourceFromFile 71 | , initSourceFromFile' 72 | , sourceFromIO 73 | , sourceFromList 74 | , sourceFromBuffered 75 | , sourceTextFromBuffered 76 | , sourceJSONFromBuffered 77 | , sourceParserFromBuffered 78 | , sourceParseChunkFromBuffered 79 | -- ** Sink 80 | , sinkToIO 81 | , sinkToList 82 | , initSinkToFile 83 | , sinkToBuffered 84 | , sinkBuilderToBuffered 85 | -- ** Bytes specific 86 | , newReChunk 87 | , newUTF8Decoder 88 | , newParser, newMagicSplitter, newLineSplitter 89 | , newBase64Encoder, newBase64Decoder 90 | , hexEncode 91 | , newHexDecoder 92 | -- ** Generic BIO 93 | , counter 94 | , seqNum 95 | , newGrouping 96 | , ungrouping 97 | , consumed 98 | -- * Concurrent helpers 99 | , zip, newTQueuePair, newTBQueuePair, newBroadcastTChanPair 100 | -- * Zlib BIO 101 | , newCompress, compressReset 102 | , CompressConfig(..) 103 | , defaultCompressConfig 104 | , newDecompress, decompressReset 105 | , DecompressConfig(..) 106 | , defaultDecompressConfig 107 | , MemLevel 108 | , defaultMemLevel 109 | , ZStream 110 | ) where 111 | 112 | import Z.IO.BIO.Base 113 | import Z.IO.BIO.Concurrent 114 | import Z.IO.BIO.Zlib 115 | import Prelude hiding (filter, zip) 116 | -------------------------------------------------------------------------------- /Z/IO/BIO/Concurrent.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-missing-fields #-} 2 | {-# OPTIONS_GHC -Wno-incomplete-patterns #-} 3 | 4 | {-| 5 | Module : Z.IO.BIO.Concurrent 6 | Description : Base64 codec 7 | Copyright : (c) Dong Han, 2017-2020 8 | License : BSD 9 | Maintainer : winterland1989@gmail.com 10 | Stability : experimental 11 | Portability : non-portable 12 | 13 | This module provides some concurrent 'BIO' node, to ease the implementation of producer-consumer model. 14 | All sources and sinks return by this module are safe to be used in multiple threads. 15 | 16 | * Use 'newTQueuePair' for common cases. 17 | * Use 'newTBQueuePair' if you have a fast producer and you don't want input get piled up in memory. 18 | * Use 'newBroadcastTChanPair' if you want messages get broadcasted, i.e. every message written by 19 | producers will be received by every consumers. 20 | 21 | It's important to correctly set the numebr of producers, internally it keeps a counter on how many producers 22 | reached their ends, and send EOF to all consumers when last producer ends. So it's a good idea to catch 23 | exceptions and pull the sink(which indicate EOF) on producer side. 24 | 25 | @ 26 | (sink, src) <- newTQueuePair 2 -- it's important to correctly set the numebr of producers 27 | 28 | -------------------------------------------------------------------------------- 29 | -- producers 30 | 31 | forkIO $ do 32 | ... 33 | push x sink -- producer using push 34 | ... 35 | pull sink -- when EOF is reached, manually pull, you may consider put it in a bracket. 36 | 37 | forkIO $ do 38 | ... 39 | (runBIO $ ... . sink) -- producer using BIO 40 | `onException` (pull sink) 41 | 42 | -------------------------------------------------------------------------------- 43 | -- consumers 44 | 45 | forkIO $ do 46 | ... 47 | r <- pull src -- consumer using pull 48 | case r of Just r' -> ... 49 | _ -> ... -- EOF indicate all producers reached EOF 50 | 51 | forkIO $ do 52 | ... 53 | runBIO $ src . ... -- consumer using BIO 54 | @ 55 | 56 | -} 57 | 58 | module Z.IO.BIO.Concurrent where 59 | 60 | import Control.Monad 61 | import Control.Concurrent 62 | import Control.Concurrent.STM 63 | import qualified Data.Sequence as Seq 64 | import Data.Sequence (Seq((:<|),(:|>))) 65 | import GHC.Natural 66 | import Z.IO.BIO.Base 67 | import Z.Data.PrimRef 68 | import Z.IO.Exception 69 | 70 | -- | Zip two BIO node by running them concurrently. 71 | -- 72 | -- This implementation use 'MVar' to synchronize two BIO's output, which has some implications: 73 | -- 74 | -- * Two node should output same numebr of results. 75 | -- * If the number differs, one node maybe 76 | -- 77 | zip :: BIO a b -> BIO a c -> BIO a (b,c) 78 | {-# INLINABLE zip #-} 79 | zip b1 b2 = \ k mx -> do 80 | bEOF <- newTVarIO False 81 | cEOF <- newTVarIO False 82 | bBuf <- newTVarIO Seq.empty 83 | cBuf <- newTVarIO Seq.empty 84 | _ <- forkIO (b1 (f bBuf bEOF) mx) 85 | _ <- forkIO (b2 (f cBuf cEOF) mx) 86 | loop k bBuf cBuf bEOF cEOF 87 | where 88 | f xBuf xEOF = \ mx -> 89 | case mx of 90 | Just x -> atomically $ modifyTVar' xBuf (:|> x) 91 | _ -> atomically $ writeTVar xEOF True 92 | 93 | loop k bBuf cBuf bEOF cEOF = join . atomically $ do 94 | bs <- readTVar bBuf 95 | cs <- readTVar cBuf 96 | beof <- readTVar bEOF 97 | ceof <- readTVar cEOF 98 | case bs of 99 | b :<| bs' -> case cs of 100 | c :<| cs' -> do 101 | writeTVar bBuf bs' 102 | writeTVar cBuf cs' 103 | return (k (Just (b, c)) >> loop k bBuf cBuf bEOF cEOF) 104 | _ -> if ceof then return (k EOF) else retry 105 | _ -> if beof then return (k EOF) else retry 106 | 107 | -- | Make an unbounded queue and a pair of sink and souce connected to it. 108 | newTQueuePair :: Int -- ^ number of producers 109 | -> IO (Sink a, Source a) 110 | {-# INLINABLE newTQueuePair #-} 111 | newTQueuePair n = do 112 | q <- newTQueueIO 113 | ec <- newCounter 0 114 | return 115 | ( \ k mx -> case mx of 116 | Just _ -> atomically (writeTQueue q mx) 117 | _ -> do 118 | i <- atomicAddCounter' ec 1 119 | when (i == n) $ do 120 | atomically (writeTQueue q EOF) 121 | k EOF 122 | 123 | , \ k _ -> 124 | let loop = uninterruptibleMask $ \ restore -> do 125 | x <- restore $ atomically (readTQueue q) 126 | case x of Just _ -> k x >> loop 127 | _ -> do atomically (unGetTQueue q EOF) 128 | k EOF 129 | in loop) 130 | 131 | -- | Make an bounded queue and a pair of sink and souce connected to it. 132 | newTBQueuePair :: Int -- ^ number of producers 133 | -> Natural -- ^ queue buffer bound 134 | -> IO (Sink a, Source a) 135 | {-# INLINABLE newTBQueuePair #-} 136 | newTBQueuePair n bound = do 137 | q <- newTBQueueIO bound 138 | ec <- newCounter 0 139 | return 140 | ( \ k mx -> case mx of 141 | Just _ -> atomically (writeTBQueue q mx) 142 | _ -> do 143 | i <- atomicAddCounter' ec 1 144 | when (i == n) $ do 145 | atomically (writeTBQueue q EOF) 146 | k EOF 147 | 148 | , \ k _ -> 149 | let loop = uninterruptibleMask $ \ restore -> do 150 | x <- restore $ atomically (readTBQueue q) 151 | case x of Just _ -> k x >> loop 152 | _ -> do atomically (unGetTBQueue q EOF) 153 | k EOF 154 | in loop) 155 | 156 | -- | Make a broadcast chan and a sink connected to it, and a function return sources to receive broadcast message. 157 | newBroadcastTChanPair :: Int -- ^ number of producers 158 | -> IO (Sink a, IO (Source a)) -- ^ (Sink, IO Source) 159 | {-# INLINABLE newBroadcastTChanPair #-} 160 | newBroadcastTChanPair n = do 161 | b <- newBroadcastTChanIO 162 | ec <- newCounter 0 163 | let dupSrc = do 164 | c <- atomically (dupTChan b) 165 | return $ \ k _ -> 166 | let loop = do 167 | x <- atomically (readTChan c) 168 | case x of Just _ -> k x >> loop 169 | _ -> k EOF 170 | in loop 171 | 172 | return 173 | (\ k mx -> case mx of 174 | Just _ -> atomically (writeTChan b mx) 175 | _ -> do i <- atomicAddCounter' ec 1 176 | when (i == n) (atomically (writeTChan b EOF)) 177 | k EOF 178 | , dupSrc) 179 | -------------------------------------------------------------------------------- /Z/IO/Environment.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Z.IO.Environment 3 | Description : Miscellaneous functions(environment variables, metrics, etc.) 4 | Copyright : (c) Dong Han, 2020 5 | License : BSD 6 | Maintainer : winterland1989@gmail.com 7 | Stability : experimental 8 | Portability : non-portable 9 | 10 | This module provide methods for retrieving various environment infomation. There's no encoding guarantee about these information, if you want textual representation, UTF8 assumption is recommended. i.e. use 'Z.Data.Text.validate'. 11 | 12 | -} 13 | module Z.IO.Environment 14 | ( -- * arguments 15 | getArgs 16 | -- * environment variables 17 | , getAllEnv 18 | , getEnv, getEnv' 19 | , setEnv, unsetEnv 20 | -- * other environment infos 21 | , getCWD, chDir, getHomeDir, getTempDir 22 | , getRandom, getRandomT 23 | , getResUsage, ResUsage(..), TimeVal(..) 24 | , getResidentSetMemory 25 | , getUpTime 26 | , getHighResolutionTime 27 | , PID(..) 28 | , getPID, getPPID 29 | , getHostname 30 | , getOSName, OSName(..) 31 | , getPassWD, PassWD(..), UID, GID 32 | , getCPUInfo, CPUInfo(..) 33 | , getLoadAvg 34 | , getFreeMem, getTotalMem, getConstrainedMem 35 | ) where 36 | 37 | import Control.Monad 38 | import Data.Word 39 | import qualified Z.Data.Vector.Base as V 40 | import Z.Data.CBytes 41 | import Z.Foreign 42 | import Z.IO.Exception 43 | import Z.IO.UV.Manager 44 | import Foreign.Storable 45 | import Z.IO.UV.FFI 46 | import Z.IO.UV.FFI_Env 47 | 48 | -- | Computation 'getArgs' returns a list of the program's command 49 | -- line arguments (including the program path). 50 | -- 51 | -- This is different from base's 'System.Environment.getArgs' since result 52 | -- includes the program path(more like C's *argv). 53 | getArgs :: IO [CBytes] 54 | {-# INLINABLE getArgs #-} 55 | getArgs = do 56 | (argc :: CInt, (p_argv :: Ptr CString, _)) <- allocPrimUnsafe $ \ p_argc -> do 57 | allocPrimUnsafe $ \ p_p_argv -> do 58 | getProgArgv p_argc p_p_argv 59 | forM [0..fromIntegral (argc-1)] $ \ i -> do 60 | fromCString =<< peekElemOff p_argv i 61 | 62 | -- | Retrieves the environment variable. 63 | -- 64 | -- Warning: This function is not thread safe. 65 | getAllEnv :: HasCallStack => IO [(CBytes, CBytes)] 66 | {-# INLINABLE getAllEnv #-} 67 | getAllEnv = bracket 68 | (do (p_env :: Ptr CString, (envc :: CInt, _)) <- allocPrimUnsafe $ \ p_p_env -> do 69 | allocPrimUnsafe $ \ p_envc -> 70 | throwUVIfMinus_ (uv_os_environ p_p_env p_envc) 71 | return (p_env, envc)) 72 | (\ (p_env, envc) -> uv_os_free_environ p_env envc) 73 | (\ (p_env, envc) -> do 74 | forM [0..fromIntegral (envc-1)] $ \ i -> do 75 | k <- fromCString =<< peekElemOff p_env (i*2) 76 | v <- fromCString =<< peekElemOff p_env (i*2+1) 77 | return (k, v)) 78 | 79 | -- | Retrieves the environment variable specified by name. 80 | -- 81 | -- Warning: This function is not thread safe. 82 | getEnv :: HasCallStack => CBytes -> IO (Maybe CBytes) 83 | {-# INLINABLE getEnv #-} 84 | getEnv k = go 512 85 | where 86 | go siz = do 87 | (siz', (v, r))<- withPrimUnsafe siz $ \ p_siz -> 88 | withCBytesUnsafe k $ \ p_k -> 89 | allocCBytesUnsafe siz $ \ p_v -> 90 | uv_os_getenv p_k p_v p_siz 91 | case r of 92 | UV_ENOBUFS -> go siz' 93 | UV_ENOENT -> return Nothing 94 | _ -> do 95 | throwUVIfMinus_ (return r) 96 | return (Just v) 97 | 98 | -- | Retrieves the environment variable specified by name, throw 'NoSuchThing' if not exists. 99 | -- 100 | -- Warning: This function is not thread safe. 101 | getEnv' :: HasCallStack => CBytes -> IO CBytes 102 | {-# INLINABLE getEnv' #-} 103 | getEnv' k = getEnv k >>= \ mv -> case mv of 104 | Just v -> return v 105 | _ -> throwUVError UV_ENOENT (IOEInfo "ENOENT" "no such environment variable" callStack) 106 | 107 | -- | Creates or updates the environment variable specified by name with value. 108 | -- 109 | -- Warning: This function is not thread safe. 110 | setEnv :: HasCallStack => CBytes -> CBytes -> IO () 111 | {-# INLINABLE setEnv #-} 112 | setEnv k v = withCBytesUnsafe k $ \ p_k -> 113 | withCBytesUnsafe v $ \ p_v -> 114 | throwUVIfMinus_ (uv_os_setenv p_k p_v) 115 | 116 | -- | Deletes the environment variable specified by name if such environment variable exists. 117 | -- 118 | -- Warning: This function is not thread safe. 119 | unsetEnv :: HasCallStack => CBytes -> IO () 120 | {-# INLINABLE unsetEnv #-} 121 | unsetEnv k = void . withCBytesUnsafe k $ \ p -> throwUVIfMinus_ (uv_os_unsetenv p) 122 | 123 | -- | Gets the resident set size (RSS) for the current process. 124 | getResidentSetMemory :: HasCallStack => IO CSize 125 | {-# INLINABLE getResidentSetMemory #-} 126 | getResidentSetMemory = do 127 | (size, r) <- allocPrimUnsafe uv_resident_set_memory 128 | throwUVIfMinus_ (return r) 129 | return size 130 | 131 | -- | Gets the current system uptime. 132 | getUpTime :: HasCallStack => IO Double 133 | {-# INLINABLE getUpTime #-} 134 | getUpTime = do 135 | (size, r) <- allocPrimUnsafe uv_uptime 136 | throwUVIfMinus_ (return r) 137 | return size 138 | 139 | -- | Returns the current high-resolution real time. 140 | -- 141 | -- This is expressed in nanoseconds. It is relative to an arbitrary time in the past. 142 | -- It is not related to the time of day and therefore not subject to clock drift. 143 | -- The primary use is for measuring performance between intervals. 144 | getHighResolutionTime :: IO Word64 145 | {-# INLINABLE getHighResolutionTime #-} 146 | getHighResolutionTime = uv_hrtime 147 | 148 | -- | Gets the resource usage measures for the current process. 149 | -- 150 | -- On Windows not all fields are set, the unsupported fields are filled with zeroes. 151 | -- See 'ResUsage' for more details. 152 | getResUsage :: HasCallStack => IO ResUsage 153 | {-# INLINABLE getResUsage #-} 154 | getResUsage = do 155 | (MutableByteArray mba#) <- newByteArray sizeOfResUsage 156 | throwUVIfMinus_ (uv_getrusage mba#) 157 | peekResUsage mba# 158 | 159 | -- | Returns the current process ID. 160 | getPID :: IO PID 161 | {-# INLINABLE getPID #-} 162 | getPID = uv_os_getpid 163 | 164 | -- | Returns the parent process ID. 165 | getPPID :: IO PID 166 | {-# INLINABLE getPPID #-} 167 | getPPID = uv_os_getppid 168 | 169 | -- | Returns the hostname as a null-terminated string. 170 | -- 171 | getHostname :: HasCallStack => IO CBytes 172 | {-# INLINABLE getHostname #-} 173 | getHostname = do 174 | (n, _) <- allocCBytesUnsafe (fromIntegral UV_MAXHOSTNAMESIZE) $ \ p_n -> 175 | withPrimUnsafe UV_MAXHOSTNAMESIZE $ \ p_siz -> 176 | throwUVIfMinus_ (uv_os_gethostname p_n p_siz) 177 | return n 178 | 179 | -- | Fill buf with exactly buflen cryptographically strong random bytes acquired from the system CSPRNG. 180 | -- 181 | -- The function may block indefinitely when not enough entropy is available, don't use it to get 182 | -- long random sequences. 183 | getRandom :: Int -> IO V.Bytes 184 | {-# INLINABLE getRandom #-} 185 | getRandom siz = do 186 | (v, _) <- allocPrimVectorUnsafe siz $ \ mba# -> 187 | throwUVIfMinus_ (hs_uv_random mba# (fromIntegral siz) 0) 188 | return v 189 | 190 | -- | Fill buf with exactly buflen cryptographically strong random bytes acquired from the system CSPRNG. 191 | -- 192 | -- The function run 'getRandom' in libuv's threadpool, suitable for get long random byte sequences. 193 | getRandomT :: Int -> IO V.Bytes 194 | {-# INLINABLE getRandomT #-} 195 | getRandomT siz = do 196 | (v, _) <- allocPrimVectorSafe siz $ \ p -> do 197 | uvm <- getUVManager 198 | withUVRequest_ uvm (hs_uv_random_threaded p (fromIntegral siz) 0) 199 | return v 200 | 201 | -- | Gets the current working directory. 202 | -- 203 | getCWD :: HasCallStack => IO CBytes 204 | {-# INLINABLE getCWD #-} 205 | getCWD = go 512 206 | where 207 | go siz = do 208 | (siz', (v, r))<- withPrimUnsafe siz $ \ p_siz -> 209 | allocCBytesUnsafe siz $ \ p_v -> 210 | uv_cwd p_v p_siz 211 | case r of 212 | UV_ENOBUFS -> go siz' 213 | _ -> do 214 | throwUVIfMinus_ (return r) 215 | return v 216 | 217 | -- | Changes the current working directory. 218 | -- 219 | chDir :: HasCallStack => CBytes -> IO () 220 | {-# INLINABLE chDir #-} 221 | chDir p = throwUVIfMinus_ (withCBytesUnsafe p $ \ pp -> uv_chdir pp) 222 | 223 | -- | Gets the current user’s home directory. 224 | -- 225 | -- On Windows, first checks the USERPROFILE environment variable using GetEnvironmentVariableW(). 226 | -- If USERPROFILE is not set, GetUserProfileDirectoryW() is called. 227 | -- On all other operating systems, first checks the HOME environment variable using getenv(3). 228 | -- If HOME is not set, getpwuid_r(3) is called. 229 | -- 230 | -- Warning 'getHomeDir' is not thread safe. 231 | getHomeDir :: HasCallStack => IO CBytes 232 | {-# INLINABLE getHomeDir #-} 233 | getHomeDir = go 512 234 | where 235 | go siz = do 236 | (siz', (v, r))<- withPrimUnsafe siz $ \ p_siz -> 237 | allocCBytesUnsafe siz $ \ p_v -> 238 | uv_os_homedir p_v p_siz 239 | case r of 240 | UV_ENOBUFS -> go siz' 241 | _ -> do 242 | throwUVIfMinus_ (return r) 243 | return v 244 | 245 | -- | Gets the temp directory. 246 | -- 247 | -- On Windows, uses GetTempPathW(). On all other operating systems, 248 | -- uses the first environment variable found in the ordered list TMPDIR, TMP, TEMP, and TEMPDIR. 249 | -- If none of these are found, the path @\/tmp@ is used, or, on Android, @\/data\/local\/tmp@ is used. 250 | -- 251 | -- Warning 'getHomeDir' is not thread safe. 252 | getTempDir :: HasCallStack => IO CBytes 253 | {-# INLINABLE getTempDir #-} 254 | getTempDir = go 512 255 | where 256 | go siz = do 257 | (siz', (v, r))<- withPrimUnsafe siz $ \ p_siz -> 258 | allocCBytesUnsafe siz $ \ p_v -> 259 | uv_os_tmpdir p_v p_siz 260 | case r of 261 | UV_ENOBUFS -> go siz' 262 | _ -> do 263 | throwUVIfMinus_ (return r) 264 | return v 265 | 266 | -- | Gets the amount of free memory available in the system, as reported by the kernel (in bytes). 267 | getFreeMem :: IO Word64 268 | {-# INLINABLE getFreeMem #-} 269 | getFreeMem = uv_get_free_memory 270 | 271 | -- | Gets the total amount of physical memory in the system (in bytes). 272 | getTotalMem :: IO Word64 273 | {-# INLINABLE getTotalMem #-} 274 | getTotalMem = uv_get_total_memory 275 | 276 | -- | Gets the amount of memory available to the process (in bytes) based on limits imposed by the OS. 277 | -- 278 | -- If there is no such constraint, or the constraint is unknown, 0 is returned. 279 | -- Note that it is not unusual for this value to be less than or greater than 'getTotalMem'. 280 | -- Note This function currently only returns a non-zero value on Linux, based on cgroups if it is present. 281 | getConstrainedMem :: IO Word64 282 | {-# INLINABLE getConstrainedMem #-} 283 | getConstrainedMem = uv_get_constrained_memory 284 | 285 | -------------------------------------------------------------------------------- 286 | 287 | -- from base 288 | foreign import ccall unsafe getProgArgv :: MBA# CInt -> MBA# (Ptr CString) -> IO () 289 | -------------------------------------------------------------------------------- /Z/IO/FileSystem.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Z.IO.Network 3 | Description : FileSystem Umbrella module 4 | Copyright : (c) Song Xue, Dong Han, 2020 5 | License : BSD 6 | Maintainer : winterland1989@gmail.com 7 | Stability : experimental 8 | Portability : non-portable 9 | 10 | Umbrella module to export everything you need to start using file. 11 | 12 | -} 13 | 14 | module Z.IO.FileSystem 15 | ( -- * Basic Operations 16 | module Z.IO.FileSystem.Base 17 | 18 | -- * FilePath 19 | , module Z.IO.FileSystem.FilePath 20 | 21 | -- * FileWatch 22 | , module Z.IO.FileSystem.Watch 23 | ) where 24 | 25 | import Z.IO.FileSystem.Base 26 | import Z.IO.FileSystem.FilePath 27 | import Z.IO.FileSystem.Watch 28 | -------------------------------------------------------------------------------- /Z/IO/FileSystem/Watch.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Z.IO.FileSystem.Watch 3 | Description : cross-platform recursive fs watcher 4 | Copyright : (c) Dong Han, 2017-2020 5 | License : BSD 6 | Maintainer : winterland1989@gmail.com 7 | Stability : experimental 8 | Portability : non-portable 9 | 10 | This module provides fs watcher based on libuv's fs_event, we also maintain watch list if target OS doesn't 11 | support recursive watch(Linux's inotify). 12 | 13 | @ 14 | -- start watching threads, cleanup watching threads automatically when finished. 15 | withResource (initWatchDirs ["fold_to_be_watch"] True) $ \ srcf -> do 16 | -- dup a file event source 17 | src <- srcf 18 | -- print event to stdout 19 | BIO.run_ $ src . sinkToIO printStd 20 | @ 21 | -} 22 | 23 | module Z.IO.FileSystem.Watch 24 | ( FileEvent(..) 25 | , watchDirs 26 | , initWatchDirs 27 | ) where 28 | 29 | import Control.Concurrent 30 | import Control.Monad 31 | import Data.Bits 32 | import qualified Data.HashMap.Strict as HM 33 | import Data.IORef 34 | #if defined(linux_HOST_OS) 35 | import qualified Data.List as List 36 | #endif 37 | import Data.Primitive.PrimArray 38 | import Data.Word 39 | import GHC.Generics 40 | import Z.Data.Array.Unaligned 41 | import Z.Data.CBytes (CBytes) 42 | import qualified Z.Data.CBytes as CBytes 43 | import Z.Data.JSON (JSON) 44 | import Z.Data.Text.Print (Print) 45 | import Z.Data.Vector (defaultChunkSize) 46 | import Z.Foreign 47 | import Z.IO.BIO as BIO 48 | import Z.IO.Exception 49 | import Z.IO.FileSystem.Base 50 | import qualified Z.IO.FileSystem.FilePath as P 51 | import Z.IO.LowResTimer 52 | import Z.IO.Resource 53 | import Z.IO.UV.FFI 54 | import Z.IO.UV.Manager 55 | 56 | -- | File event with path info. 57 | data FileEvent = FileAdd CBytes | FileRemove CBytes | FileModify CBytes 58 | deriving (Show, Read, Ord, Eq, Generic) 59 | deriving anyclass (Print, JSON) 60 | 61 | -- | Watching a list of given directories. 62 | watchDirs :: [CBytes] -- ^ Directories to be watched 63 | -> Bool -- ^ recursively watch? 64 | -> (FileEvent -> IO ()) -- ^ Callback function to handle 'FileEvent' 65 | -> IO () 66 | {-# INLINABLE watchDirs #-} 67 | watchDirs dirs rec callback = do 68 | withResource (initWatchDirs dirs rec) $ \ srcf -> do 69 | src <- srcf 70 | run_ $ src . sinkToIO callback 71 | 72 | -- | Start watching a list of given directories, stream version. 73 | initWatchDirs :: [CBytes] -- ^ watching list 74 | -> Bool -- ^ recursively watch? 75 | -> Resource (IO (Source FileEvent)) 76 | {-# INLINABLE initWatchDirs #-} 77 | initWatchDirs dirs False = do 78 | liftIO . forM_ dirs $ \ dir -> do 79 | b <- isDir dir 80 | unless b (throwUVIfMinus_ (return UV_ENOTDIR)) 81 | watch_ 0 dirs 82 | initWatchDirs dirs _ = do 83 | #if defined(linux_HOST_OS) 84 | -- inotify doesn't support recursive watch, so we manually maintain watch list 85 | subDirs <- liftIO . forM dirs $ \ dir -> 86 | scandirRecursively dir (\ _ t -> return (t == DirEntDir)) 87 | watch_ UV_FS_EVENT_RECURSIVE (List.concat (dirs:subDirs)) 88 | #else 89 | watch_ UV_FS_EVENT_RECURSIVE dirs 90 | #endif 91 | 92 | -- Internal function to start watching 93 | watch_ :: CUInt -> [CBytes] -> Resource (IO (Source FileEvent)) 94 | {-# INLINABLE watch_ #-} 95 | watch_ flag dirs = fst <$> initResource (do 96 | -- HashMap to store all watchers 97 | mRef <- newMVar HM.empty 98 | -- there's only one place to pull the sink, that is cleanUpWatcher 99 | (sink, srcf) <- newBroadcastTChanPair 1 100 | -- lock UVManager first 101 | (forM_ dirs $ \ dir -> do 102 | dir' <- P.normalize dir 103 | tid <- forkIO $ watchThread mRef dir' sink 104 | modifyMVar_ mRef $ \ m -> 105 | return $! HM.insert dir' tid m) `onException` cleanUpWatcher mRef sink 106 | return (srcf, (sink, mRef))) 107 | (\ (_, (sink, mRef)) -> cleanUpWatcher mRef sink) 108 | where 109 | eventBufSiz = defaultChunkSize 110 | 111 | cleanUpWatcher mRef sink = do 112 | m <- takeMVar mRef 113 | forM_ m killThread 114 | void (sink discard EOF) 115 | 116 | watchThread mRef dir sink = do 117 | -- IORef store temp events to de-duplicated 118 | eRef <- newIORef Nothing 119 | uvm <- getUVManager 120 | (bracket 121 | (do withUVManager uvm $ \ loop -> do 122 | hdl <- hs_uv_handle_alloc loop 123 | slot <- getUVSlot uvm (peekUVHandleData hdl) 124 | -- init uv struct 125 | throwUVIfMinus_ (uv_fs_event_init loop hdl) 126 | 127 | buf <- newPinnedPrimArray eventBufSiz :: IO (MutablePrimArray RealWorld Word8) 128 | 129 | check <- throwOOMIfNull $ hs_uv_check_alloc 130 | throwUVIfMinus_ (hs_uv_check_init check hdl) 131 | 132 | withMutablePrimArrayContents buf $ \ p -> do 133 | pokeBufferTable uvm slot (castPtr p) eventBufSiz 134 | -- init uv_check_t must come after poking buffer 135 | throwUVIfMinus_ $ hs_uv_fs_event_check_start check 136 | 137 | return (hdl, slot, buf, check)) 138 | 139 | (\ (hdl,_,_,check) -> hs_uv_handle_close hdl >> hs_uv_check_close check) 140 | 141 | (\ (hdl, slot, buf, _) -> do 142 | m <- getBlockMVar uvm slot 143 | withUVManager' uvm $ do 144 | _ <- tryTakeMVar m 145 | pokeBufferSizeTable uvm slot eventBufSiz 146 | CBytes.withCBytesUnsafe dir $ \ p -> 147 | throwUVIfMinus_ (hs_uv_fs_event_start hdl p flag) 148 | 149 | forever $ do 150 | 151 | _ <- takeMVar m `onException` (do 152 | _ <- withUVManager' uvm $ uv_fs_event_stop hdl 153 | void (tryTakeMVar m)) 154 | 155 | (PrimArray buf#) <- withUVManager' uvm $ do 156 | _ <- tryTakeMVar m 157 | r <- peekBufferSizeTable uvm slot 158 | pokeBufferSizeTable uvm slot eventBufSiz 159 | 160 | let eventSiz = eventBufSiz - r 161 | buf' <- newPrimArray eventSiz 162 | copyMutablePrimArray buf' 0 buf r eventSiz 163 | unsafeFreezePrimArray buf' 164 | 165 | forkIO $ processEvent dir mRef eRef sink =<< loopReadFileEvent buf# 0 []) 166 | ) `catch` 167 | -- when a directory is removed, either watcher is killed 168 | -- or hs_uv_fs_event_start return ENOENT 169 | (\ (_ :: NoSuchThing) -> return ()) 170 | 171 | loopReadFileEvent buf# i acc 172 | | i >= siz = return acc 173 | | otherwise = 174 | let !event = indexBA buf# i 175 | !path = CBytes.indexBACBytes buf# (i + 1) 176 | in loopReadFileEvent buf# (i + CBytes.length path + 2) ((event,path):acc) 177 | where siz = sizeofPrimArray (PrimArray buf# :: PrimArray Word8) 178 | 179 | processEvent pdir mRef eRef sink = mapM_ $ \ (e, path) -> 180 | -- don't report event about directory itself, it will reported by its parent 181 | unless (CBytes.null path) $ do 182 | f <- pdir `P.join` path 183 | if (e .&. UV_RENAME) /= 0 184 | then catch 185 | (do _s <- lstat f 186 | #if defined(linux_HOST_OS) 187 | when ((stMode _s .&. S_IFMT == S_IFDIR) && (flag .&. UV_FS_EVENT_RECURSIVE /= 0)) $ do 188 | modifyMVar_ mRef $ \ m -> do 189 | case HM.lookup f m of 190 | Just _ -> return m 191 | _ -> do 192 | ds <- scandirRecursively f (\ _ t -> return (t == DirEntDir)) 193 | foldM (\ m' d -> do 194 | tid <- forkIO $ watchThread mRef d sink 195 | return $! HM.insert d tid m') m (f:ds) 196 | #endif 197 | pushDedup eRef sink (FileAdd f)) 198 | (\ (_ :: NoSuchThing) -> do 199 | modifyMVar_ mRef $ \ m -> do 200 | forM_ (HM.lookup f m) killThread 201 | return (HM.delete f m) 202 | pushDedup eRef sink (FileRemove f)) 203 | else pushDedup eRef sink (FileModify f) 204 | 205 | pushDedup eRef sink event = do 206 | registerLowResTimer_ 1 $ do 207 | me' <- atomicModifyIORef' eRef $ \ me -> 208 | case me of 209 | Just e -> (Nothing, Just e) 210 | _ -> (Nothing, Nothing) 211 | forM_ me' (BIO.step_ sink) 212 | 213 | me' <- atomicModifyIORef' eRef $ \ me -> 214 | case me of 215 | Just e -> if (e == event) 216 | then (me, Nothing) 217 | else (Just event, Just e) 218 | _ -> (Just event, Nothing) 219 | forM_ me' (BIO.step_ sink) 220 | -------------------------------------------------------------------------------- /Z/IO/Network.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Z.IO.Network 3 | Description : Network Umbrella module, DNS, TCP, UDP, IPC 4 | Copyright : (c) Dong Han, 2020 5 | License : BSD 6 | Maintainer : winterland1989@gmail.com 7 | Stability : experimental 8 | Portability : non-portable 9 | 10 | Umbrella module to export everything you need to start using network. 11 | 12 | -} 13 | 14 | module Z.IO.Network ( 15 | module Z.IO.Network.SocketAddr 16 | , module Z.IO.Network.DNS 17 | , module Z.IO.Network.IPC 18 | , module Z.IO.Network.TCP 19 | , module Z.IO.Network.UDP 20 | ) where 21 | 22 | import Z.IO.Network.SocketAddr 23 | import Z.IO.Network.DNS 24 | import Z.IO.Network.IPC 25 | import Z.IO.Network.TCP 26 | import Z.IO.Network.UDP 27 | -------------------------------------------------------------------------------- /Z/IO/Network/IPC.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Z.IO.IPC 3 | Description : Named pipe\/Unix domain servers and clients 4 | Copyright : (c) Dong Han, 2018 5 | License : BSD 6 | Maintainer : winterland1989@gmail.com 7 | Stability : experimental 8 | Portability : non-portable 9 | 10 | This module provides an API for creating IPC servers and clients. IPC Support is implemented with named pipes on Windows, and UNIX domain sockets on other operating systems. 11 | 12 | On UNIX, the local domain is also known as the UNIX domain. The path is a filesystem path name. It gets truncated to sizeof(sockaddr_un.sun_path) - 1, which varies on different operating system between 91 and 107 bytes. The typical values are 107 on Linux and 103 on macOS. The path is subject to the same naming conventions and permissions checks as would be done on file creation. It will be visible in the filesystem, and will persist until unlinked. 13 | 14 | On Windows, the local domain is implemented using a named pipe. The path must refer to an entry in \\?\pipe\ or \\.\pipe\. Any characters are permitted, but the latter may do some processing of pipe names, such as resolving .. sequences. Despite appearances, the pipe name space is flat. Pipes will not persist, they are removed when the last reference to them is closed. 15 | 16 | -} 17 | 18 | module Z.IO.Network.IPC ( 19 | -- * IPC Client 20 | IPCClientConfig(..) 21 | , UVStream 22 | , defaultIPCClientConfig 23 | , initIPCClient 24 | -- * IPC Server 25 | , IPCServerConfig(..) 26 | , defaultIPCServerConfig 27 | , startIPCServer 28 | -- * For test 29 | , helloWorld 30 | , echo 31 | -- * Internal helper 32 | , initIPCStream 33 | ) where 34 | 35 | import Control.Monad 36 | import Control.Monad.IO.Class 37 | import GHC.Generics 38 | import Z.Data.CBytes 39 | import Z.Data.Text.Print (Print) 40 | import Z.Data.JSON (JSON) 41 | import Z.IO.Exception 42 | import Z.IO.Resource 43 | import Z.IO.Network.TCP (startServerLoop) 44 | import Z.IO.UV.FFI 45 | import Z.IO.UV.Manager 46 | import Z.IO.UV.UVStream 47 | 48 | -------------------------------------------------------------------------------- 49 | 50 | -- | A IPC client configuration 51 | -- 52 | data IPCClientConfig = IPCClientConfig 53 | { ipcClientName :: Maybe CBytes -- ^ bind to a local file path (Unix) or name (Windows), 54 | -- won't bind if set to 'Nothing'. 55 | , ipcTargetName :: CBytes -- ^ target path (Unix) or a name (Windows). 56 | } deriving (Eq, Ord, Show, Read, Generic) 57 | deriving anyclass (Print, JSON) 58 | 59 | -- | Default config, connect to ".\/ipc". 60 | -- 61 | defaultIPCClientConfig :: IPCClientConfig 62 | {-# INLINABLE defaultIPCClientConfig #-} 63 | defaultIPCClientConfig = IPCClientConfig Nothing "./ipc" 64 | 65 | -- | init a IPC client 'Resource', which open a new connect when used. 66 | -- 67 | initIPCClient :: IPCClientConfig -> Resource UVStream 68 | {-# INLINABLE initIPCClient #-} 69 | initIPCClient (IPCClientConfig cname tname) = do 70 | uvm <- liftIO getUVManager 71 | client <- initIPCStream uvm 72 | let hdl = uvsHandle client 73 | liftIO $ do 74 | forM_ cname $ \ cname' -> 75 | withCBytesUnsafe cname' $ \ cname_p -> 76 | -- bind is safe without withUVManager 77 | throwUVIfMinus_ (uv_pipe_bind hdl cname_p) 78 | withCBytesUnsafe tname $ \ tname_p -> do 79 | void . withUVRequest uvm $ \ _ -> hs_uv_pipe_connect hdl tname_p 80 | return client 81 | 82 | -------------------------------------------------------------------------------- 83 | 84 | -- | A IPC server configuration 85 | -- 86 | data IPCServerConfig = IPCServerConfig 87 | { ipcListenName :: CBytes -- ^ listening path (Unix) or a name (Windows). 88 | , ipcListenBacklog :: Int -- ^ listening pipe's backlog size, should be large enough(>128) 89 | } deriving (Eq, Ord, Show, Read, Generic) 90 | deriving anyclass (Print, JSON) 91 | 92 | -- | A default hello world server on @.\/ipc@ 93 | -- 94 | -- Test it with @main = startIPCServer defaultIPCServerConfig@ 95 | -- 96 | defaultIPCServerConfig :: IPCServerConfig 97 | {-# INLINABLE defaultIPCServerConfig #-} 98 | defaultIPCServerConfig = IPCServerConfig 99 | "./ipc" 100 | 256 101 | 102 | -- | Start a server 103 | -- 104 | -- Fork new worker thread upon a new connection. 105 | -- 106 | startIPCServer :: HasCallStack 107 | => IPCServerConfig 108 | -> (UVStream -> IO ()) -- ^ worker which get an accepted IPC stream, 109 | -- run in a seperated haskell thread, 110 | -- will be closed upon exception or worker finishes. 111 | -> IO () 112 | {-# INLINABLE startIPCServer #-} 113 | startIPCServer IPCServerConfig{..} = startServerLoop 114 | (max ipcListenBacklog 128) 115 | initIPCStream 116 | (\ serverHandle -> 117 | withCBytesUnsafe ipcListenName $ \ name_p -> do 118 | throwUVIfMinus_ (uv_pipe_bind serverHandle name_p)) 119 | ( \ fd worker -> void . forkBa $ do 120 | uvm <- getUVManager 121 | withResource (initUVStream (\ loop hdl -> do 122 | throwUVIfMinus_ (uv_pipe_init loop hdl 0) 123 | throwUVIfMinus_ (uv_pipe_open hdl fd)) uvm) $ \ uvs -> do 124 | worker uvs) 125 | 126 | -------------------------------------------------------------------------------- 127 | 128 | initIPCStream :: HasCallStack => UVManager -> Resource UVStream 129 | {-# INLINABLE initIPCStream #-} 130 | initIPCStream = initUVStream (\ loop hdl -> 131 | throwUVIfMinus_ (uv_pipe_init loop hdl 0)) 132 | -------------------------------------------------------------------------------- /Z/IO/Network/TCP.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Z.IO.Network.TCP 3 | Description : TCP servers and clients 4 | Copyright : (c) Dong Han, 2018 5 | License : BSD 6 | Maintainer : winterland1989@gmail.com 7 | Stability : experimental 8 | Portability : non-portable 9 | 10 | This module provides an API for creating TCP servers and clients. 11 | 12 | -} 13 | 14 | module Z.IO.Network.TCP ( 15 | -- * TCP Client 16 | TCPClientConfig(..) 17 | , UVStream 18 | , defaultTCPClientConfig 19 | , initTCPClient 20 | , getTCPSockName 21 | -- * TCP Server 22 | , TCPServerConfig(..) 23 | , defaultTCPServerConfig 24 | , startTCPServer 25 | , getTCPPeerName 26 | -- * For test 27 | , helloWorld 28 | , echo 29 | -- * Internal helper 30 | , startServerLoop 31 | , setTCPNoDelay 32 | , setTCPKeepAlive 33 | , initTCPStream 34 | ) where 35 | 36 | import Control.Concurrent 37 | import Control.Monad 38 | import Control.Monad.IO.Class 39 | import Data.Primitive.PrimArray 40 | import Foreign.Ptr 41 | import GHC.Generics 42 | import Z.Data.Text.Print (Print) 43 | import Z.Data.JSON (JSON) 44 | import Z.IO.Exception 45 | import Z.IO.Network.SocketAddr 46 | import Z.IO.Resource 47 | import Z.IO.UV.FFI 48 | import Z.IO.UV.Manager 49 | import Z.IO.UV.UVStream 50 | import Z.Foreign 51 | 52 | -------------------------------------------------------------------------------- 53 | 54 | -- | A TCP client configuration 55 | -- 56 | data TCPClientConfig = TCPClientConfig 57 | { tcpClientAddr :: Maybe SocketAddr -- ^ assign a local address, or let OS pick one 58 | , tcpRemoteAddr :: SocketAddr -- ^ remote target address 59 | , tcpClientNoDelay :: Bool -- ^ if we want to use @TCP_NODELAY@ 60 | , tcpClientKeepAlive :: CUInt -- ^ set keepalive delay for client socket, see 'setTCPKeepAlive' 61 | } deriving (Eq, Ord, Show, Generic) 62 | deriving anyclass (Print, JSON) 63 | 64 | -- | Default config, connect to @localhost:8888@. 65 | -- 66 | defaultTCPClientConfig :: TCPClientConfig 67 | {-# INLINABLE defaultTCPClientConfig #-} 68 | defaultTCPClientConfig = TCPClientConfig Nothing (SocketAddrIPv4 ipv4Loopback 8888) True 30 69 | 70 | -- | init a TCP client 'Resource', which open a new connect when used. 71 | -- 72 | initTCPClient :: HasCallStack => TCPClientConfig -> Resource UVStream 73 | {-# INLINABLE initTCPClient #-} 74 | initTCPClient TCPClientConfig{..} = do 75 | uvm <- liftIO getUVManager 76 | client <- initTCPStream uvm 77 | let hdl = uvsHandle client 78 | liftIO $ do 79 | forM_ tcpClientAddr $ \ tcpClientAddr' -> 80 | withSocketAddrUnsafe tcpClientAddr' $ \ localPtr -> 81 | -- bind is safe without withUVManager 82 | throwUVIfMinus_ (uv_tcp_bind hdl localPtr 0) 83 | -- nodelay is safe without withUVManager 84 | when tcpClientNoDelay . throwUVIfMinus_ $ uv_tcp_nodelay hdl 1 85 | when (tcpClientKeepAlive > 0) . throwUVIfMinus_ $ 86 | uv_tcp_keepalive hdl 1 tcpClientKeepAlive 87 | withSocketAddrUnsafe tcpRemoteAddr $ \ targetPtr -> do 88 | void . withUVRequest uvm $ \ _ -> hs_uv_tcp_connect hdl targetPtr 89 | return client 90 | 91 | -------------------------------------------------------------------------------- 92 | 93 | -- | A TCP server configuration 94 | -- 95 | data TCPServerConfig = TCPServerConfig 96 | { tcpListenAddr :: SocketAddr -- ^ listening address 97 | , tcpListenBacklog :: Int -- ^ listening socket's backlog size, should be large enough(>128) 98 | , tcpServerWorkerNoDelay :: Bool -- ^ if we want to use @TCP_NODELAY@ 99 | , tcpServerWorkerKeepAlive :: CUInt -- ^ set keepalive delay for worker socket, see 'setTCPKeepAlive' 100 | } deriving (Eq, Ord, Show, Generic) 101 | deriving anyclass (Print, JSON) 102 | 103 | -- | A default hello world server on 0.0.0.0:8888 104 | -- 105 | -- Test it with @main = startTCPServer defaultTCPServerConfig helloWorldWorker@ or 106 | -- @main = startTCPServer defaultTCPServerConfig echoWorker@, now try @nc -v 127.0.0.1 8888@ 107 | -- 108 | defaultTCPServerConfig :: TCPServerConfig 109 | {-# INLINABLE defaultTCPServerConfig #-} 110 | defaultTCPServerConfig = TCPServerConfig 111 | (SocketAddrIPv4 ipv4Any 8888) 112 | 256 113 | True 114 | 30 115 | 116 | -- | Start a TCP server 117 | -- 118 | -- Fork new worker threads upon a new connection. 119 | -- 120 | startTCPServer :: HasCallStack 121 | => TCPServerConfig 122 | -> (UVStream -> IO ()) -- ^ worker which will get an accepted TCP stream and 123 | -- run in a seperated haskell thread, 124 | -- will be closed upon exception or worker finishes. 125 | -> IO () 126 | {-# INLINABLE startTCPServer #-} 127 | startTCPServer TCPServerConfig{..} = startServerLoop 128 | (max tcpListenBacklog 128) 129 | initTCPStream 130 | -- bind is safe without withUVManager 131 | (\ serverHandle -> withSocketAddrUnsafe tcpListenAddr $ \ addrPtr -> do 132 | throwUVIfMinus_ (uv_tcp_bind serverHandle addrPtr 0)) 133 | (\ fd worker -> void . forkBa $ do 134 | -- It's important to use the worker thread's mananger instead of server's one! 135 | uvm <- getUVManager 136 | withResource (initUVStream (\ loop hdl -> do 137 | throwUVIfMinus_ (uv_tcp_init loop hdl) 138 | throwUVIfMinus_ (uv_tcp_open hdl fd)) uvm) $ \ uvs -> do 139 | -- safe without withUVManager 140 | when tcpServerWorkerNoDelay . throwUVIfMinus_ $ 141 | uv_tcp_nodelay (uvsHandle uvs) 1 142 | when (tcpServerWorkerKeepAlive > 0) . throwUVIfMinus_ $ 143 | uv_tcp_keepalive (uvsHandle uvs) 1 tcpServerWorkerKeepAlive 144 | worker uvs) 145 | 146 | -- | Start a server loop with different kind of @uv_stream@s, such as tcp or pipe. 147 | -- 148 | startServerLoop :: HasCallStack 149 | => Int -- ^ backLog 150 | -> (UVManager -> Resource UVStream) -- ^ uv_stream_t initializer 151 | -> (Ptr UVHandle -> IO ()) -- ^ bind function 152 | -> (FD -> (UVStream -> IO ()) -> IO ()) -- ^ thread spawner 153 | -> (UVStream -> IO ()) -- ^ worker 154 | -> IO () 155 | {-# INLINABLE startServerLoop #-} 156 | startServerLoop backLog initStream bind spawn worker = do 157 | serverUVManager <- getUVManager 158 | withResource (initStream serverUVManager) $ \ (UVStream serverHandle serverSlot _ _) -> do 159 | bind serverHandle 160 | bracket 161 | (do check <- throwOOMIfNull $ hs_uv_check_alloc 162 | throwUVIfMinus_ (hs_uv_check_init check serverHandle) 163 | return check) 164 | hs_uv_check_close $ 165 | \ check -> do 166 | -- The buffer passing of accept is a litte complicated here, to get maximum performance, 167 | -- we do batch accepting. i.e. recv multiple client inside libuv's event loop: 168 | -- 169 | -- We poke uvmanager's buffer table like a normal Ptr Word8, with byte size (backLog*sizeof(FD)) 170 | -- inside libuv event loop, we cast the buffer back to int32_t* pointer. 171 | -- each accept callback push a new socket fd to the buffer, and increase a counter(buffer_size_table). 172 | -- backLog should be large enough(>128), so under windows we can't possibly filled it up within one 173 | -- uv_run, under unix we hacked uv internal to provide a stop and resume function, when backLog is 174 | -- reached, we will stop receiving. 175 | -- 176 | -- Once back to haskell side, we read all accepted sockets and fork worker threads. 177 | -- if backLog is reached, we resume receiving from haskell side. 178 | -- 179 | -- Step 1. 180 | -- we allocate a buffer to hold accepted FDs, pass it just like a normal reading buffer. 181 | -- then we can start listening. 182 | acceptBuf <- newPinnedPrimArray backLog 183 | -- https://stackoverflow.com/questions/1953639/is-it-safe-to-cast-socket-to-int-under-win64 184 | -- FD is 32bit CInt, it's large enough to hold uv_os_sock_t 185 | let acceptBufPtr = castPtr (mutablePrimArrayContents acceptBuf :: Ptr FD) 186 | 187 | withUVManager' serverUVManager $ do 188 | -- We use buffersize as accepted fd count(count backwards) 189 | pokeBufferTable serverUVManager serverSlot acceptBufPtr (backLog-1) 190 | throwUVIfMinus_ (hs_uv_listen serverHandle (fromIntegral backLog)) 191 | -- Step 2. 192 | -- we start a uv_check_t for given uv_stream_t, with predefined checking callback 193 | -- see hs_accept_check_cb in hs_uv_stream.c 194 | throwUVIfMinus_ $ hs_uv_accept_check_start check 195 | 196 | m <- getBlockMVar serverUVManager serverSlot 197 | forever $ do 198 | -- wait until accept some FDs 199 | _ <- takeMVar m 200 | -- Step 3. 201 | -- After uv loop finishes, if we got some FDs, copy the FD buffer, fetch accepted FDs and fork worker threads. 202 | 203 | -- we shouldn't receive asycn exceptions here otherwise accepted FDs are not closed 204 | mask_$ do 205 | -- we lock uv manager here in case of next uv_run overwrite current accept buffer 206 | acceptBufCopy <- withUVManager' serverUVManager $ do 207 | _ <- tryTakeMVar m 208 | acceptCountDown <- peekBufferSizeTable serverUVManager serverSlot 209 | pokeBufferSizeTable serverUVManager serverSlot (backLog-1) 210 | 211 | -- if acceptCountDown count to -1, we should resume on haskell side 212 | when (acceptCountDown == -1) (hs_uv_listen_resume serverHandle) 213 | 214 | -- copy accepted FDs 215 | let acceptCount = backLog - 1 - acceptCountDown 216 | acceptBuf' <- newPrimArray acceptCount 217 | copyMutablePrimArray acceptBuf' 0 acceptBuf (acceptCountDown+1) acceptCount 218 | unsafeFreezePrimArray acceptBuf' 219 | 220 | -- looping to fork worker threads 221 | forM_ [0..sizeofPrimArray acceptBufCopy-1] $ \ i -> do 222 | let fd = indexPrimArray acceptBufCopy i 223 | if fd < 0 224 | -- minus fd indicate a server error and we should close server 225 | then throwUVIfMinus_ (return fd) 226 | else spawn fd worker 227 | 228 | -------------------------------------------------------------------------------- 229 | 230 | initTCPStream :: UVManager -> Resource UVStream 231 | {-# INLINABLE initTCPStream #-} 232 | initTCPStream = initUVStream (\ loop hdl -> throwUVIfMinus_ (uv_tcp_init loop hdl)) 233 | 234 | -- | Enable or disable @TCP_NODELAY@, which enable or disable Nagle’s algorithm. 235 | setTCPNoDelay :: HasCallStack => UVStream -> Bool -> IO () 236 | {-# INLINABLE setTCPNoDelay #-} 237 | setTCPNoDelay uvs nodelay = 238 | throwUVIfMinus_ (uv_tcp_nodelay (uvsHandle uvs) (if nodelay then 1 else 0)) 239 | 240 | -- | Enable \/ disable TCP keep-alive. delay is the initial delay in seconds, ignored when enable is zero. 241 | -- 242 | -- After delay has been reached, 10 successive probes, each spaced 1 second from the previous one, 243 | -- will still happen. If the connection is still lost at the end of this procedure, 244 | -- then the connection is closed, pending io thread will throw 'TimeExpired' exception. 245 | setTCPKeepAlive :: HasCallStack => UVStream -> CUInt -> IO () 246 | {-# INLINABLE setTCPKeepAlive #-} 247 | setTCPKeepAlive uvs delay 248 | | delay > 0 = throwUVIfMinus_ (uv_tcp_keepalive (uvsHandle uvs) 1 delay) 249 | | otherwise = throwUVIfMinus_ (uv_tcp_keepalive (uvsHandle uvs) 0 0) 250 | 251 | -- | Get the current address to which the handle is bound. 252 | getTCPSockName :: HasCallStack => UVStream -> IO SocketAddr 253 | {-# INLINABLE getTCPSockName #-} 254 | getTCPSockName uvs = do 255 | withSocketAddrStorageUnsafe $ \ paddr -> 256 | void $ withPrimUnsafe (fromIntegral sizeOfSocketAddrStorage :: CInt) $ \ plen -> 257 | throwUVIfMinus_ (uv_tcp_getsockname (uvsHandle uvs) paddr plen) 258 | 259 | -- | Get the address of the peer connected to the handle. 260 | getTCPPeerName :: HasCallStack => UVStream -> IO SocketAddr 261 | {-# INLINABLE getTCPPeerName #-} 262 | getTCPPeerName uvs = do 263 | withSocketAddrStorageUnsafe $ \ paddr -> 264 | void $ withPrimUnsafe (fromIntegral sizeOfSocketAddrStorage :: CInt) $ \ plen -> 265 | throwUVIfMinus_ (uv_tcp_getpeername (uvsHandle uvs) paddr plen) 266 | -------------------------------------------------------------------------------- /Z/IO/Process.hsc: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Z.IO.Process 3 | Description : Process utilities 4 | Copyright : (c) Dong Han, 2018-2020 5 | License : BSD 6 | Maintainer : winterland1989@gmail.com 7 | Stability : experimental 8 | Portability : non-portable 9 | 10 | This module provides process utilities. 11 | 12 | @ 13 | import Control.Concurrent.MVar 14 | import Z.IO.Process 15 | 16 | > readProcessText defaultProcessOptions{processFile = "cat"} "hello world" 17 | ("hello world","",ExitSuccess) 18 | @ 19 | 20 | -} 21 | 22 | module Z.IO.Process 23 | ( initProcess 24 | , initProcess' 25 | , readProcess 26 | , readProcessText 27 | , ProcessOptions(..) 28 | , defaultProcessOptions 29 | , ProcessStdStream(..) 30 | , ProcessState(..) 31 | , ExitCode(..) 32 | , waitProcessExit 33 | , getProcessPID 34 | , killPID 35 | , getPriority, setPriority 36 | -- * internal 37 | , spawn 38 | -- * Constant 39 | -- ** ProcessFlag 40 | , ProcessFlag 41 | , pattern PROCESS_SETUID 42 | , pattern PROCESS_SETGID 43 | , pattern PROCESS_WINDOWS_VERBATIM_ARGUMENTS 44 | , pattern PROCESS_DETACHED 45 | , pattern PROCESS_WINDOWS_HIDE_CONSOLE 46 | , pattern PROCESS_WINDOWS_HIDE_GUI 47 | -- ** Signal 48 | , Signal 49 | , pattern SIGTERM 50 | , pattern SIGINT 51 | , pattern SIGKILL 52 | , pattern SIGHUP 53 | -- ** Priority 54 | , Priority 55 | , pattern PRIORITY_LOW 56 | , pattern PRIORITY_BELOW_NORMAL 57 | , pattern PRIORITY_NORMAL 58 | , pattern PRIORITY_ABOVE_NORMAL 59 | , pattern PRIORITY_HIGH 60 | , pattern PRIORITY_HIGHEST 61 | ) where 62 | 63 | import Control.Concurrent 64 | import Control.Concurrent.STM 65 | import Control.Monad 66 | import Data.Primitive.ByteArray 67 | import GHC.Generics 68 | import GHC.Conc.Signal (Signal) 69 | import System.Exit 70 | import Z.Data.CBytes 71 | import Z.Data.CBytes as CBytes 72 | import Z.Data.JSON (JSON) 73 | import qualified Z.Data.Vector as V 74 | import qualified Z.Data.Text as T 75 | import qualified Data.List as List 76 | import Z.Data.Array.Unaligned 77 | import Z.Foreign 78 | import Z.IO.Buffered 79 | import Z.IO.Exception 80 | import Z.IO.Network.IPC 81 | import Z.IO.Resource 82 | import Z.IO.UV.FFI 83 | import Z.IO.UV.FFI_Env 84 | import Z.IO.UV.Manager 85 | import Z.IO.UV.UVStream 86 | 87 | #include "uv.h" 88 | 89 | -- | Default process options, start @".\/main"@ with no arguments, redirect all std streams to @\/dev\/null@. 90 | defaultProcessOptions :: ProcessOptions 91 | {-# INLINABLE defaultProcessOptions #-} 92 | defaultProcessOptions = ProcessOptions 93 | { processFile = "./main" 94 | , processArgs = [] 95 | , processEnv = Nothing 96 | , processCWD = "." 97 | , processFlags = 0 98 | , processUID = UID 0 99 | , processGID = GID 0 100 | , processStdStreams = (ProcessIgnore, ProcessIgnore, ProcessIgnore) 101 | } 102 | 103 | -- | Process state 104 | data ProcessState = ProcessRunning PID | ProcessExited ExitCode 105 | deriving (Show, Eq, Ord, Generic) 106 | deriving anyclass (T.Print, JSON) 107 | 108 | -- | Wait until process exit and return the 'ExitCode'. 109 | waitProcessExit :: TVar ProcessState -> IO ExitCode 110 | {-# INLINABLE waitProcessExit #-} 111 | waitProcessExit svar = atomically $ do 112 | s <- readTVar svar 113 | case s of ProcessExited e -> return e 114 | _ -> retry 115 | 116 | -- | Get process 'PID' if process is running. 117 | getProcessPID :: TVar ProcessState -> IO (Maybe PID) 118 | {-# INLINABLE getProcessPID #-} 119 | getProcessPID svar = atomically $ do 120 | s <- readTVar svar 121 | case s of ProcessRunning pid -> return (Just pid) 122 | _ -> return Nothing 123 | 124 | -- | Send signals to process. 125 | killPID :: HasCallStack => PID -> Signal -> IO () 126 | {-# INLINABLE killPID #-} 127 | killPID (PID pid) sig = throwUVIfMinus_ (uv_kill pid sig) 128 | 129 | pattern SIGTERM :: Signal 130 | pattern SIGINT :: Signal 131 | pattern SIGKILL :: Signal 132 | pattern SIGHUP :: Signal 133 | pattern SIGTERM = #const SIGTERM 134 | pattern SIGINT = #const SIGINT 135 | pattern SIGKILL = 9 -- on windows this is absent 136 | pattern SIGHUP = #const SIGHUP 137 | 138 | -- | Resourced spawn processes. 139 | -- 140 | -- Return a resource spawn processes, when initiated return the 141 | -- @(stdin, stdout, stderr, pstate)@ tuple, std streams are created when pass 142 | -- 'ProcessCreate' option, otherwise will be 'Nothing', @pstate@ will be updated 143 | -- to 'ProcessExited' automatically when the process exits. 144 | -- 145 | -- When you finish using the process resource, a cleanup action will be called 146 | -- to wait process exit and close any std stream created during spawn. If you 147 | -- also need to kill the process, see 'initProcess'' instead. 148 | -- 149 | -- @ 150 | -- initProcess defaultProcessOptions{ 151 | -- processFile="your program" 152 | -- , processStdStreams = (ProcessCreate, ProcessCreate, ProcessCreate) 153 | -- } $ (stdin, stdout, stderr, pstate) -> do 154 | -- ... -- read or write from child process's std stream, will clean up automatically 155 | -- waitProcessExit pstate -- wait for process exit on current thread. 156 | -- @ 157 | initProcess :: ProcessOptions -> Resource (Maybe UVStream, Maybe UVStream, Maybe UVStream, TVar ProcessState) 158 | {-# INLINABLE initProcess #-} 159 | initProcess opt = initResource (spawn opt) $ 160 | \ (s0,s1,s2, pstate) -> do 161 | _ <- waitProcessExit pstate 162 | forM_ s0 closeUVStream 163 | forM_ s1 closeUVStream 164 | forM_ s2 closeUVStream 165 | 166 | -- | Resourced spawn processes. 167 | -- 168 | -- The same as 'initProcess', but the clean action will try to send 'SIGTERM' 169 | -- to the process first. 170 | initProcess' :: ProcessOptions -> Resource (Maybe UVStream, Maybe UVStream, Maybe UVStream, TVar ProcessState) 171 | {-# INLINABLE initProcess' #-} 172 | initProcess' opt = initResource (spawn opt) $ 173 | \ (s0, s1, s2, pstate) -> do 174 | m_pid <- getProcessPID pstate 175 | forM_ m_pid (`killPID` SIGTERM) 176 | _ <- waitProcessExit pstate 177 | forM_ s0 closeUVStream 178 | forM_ s1 closeUVStream 179 | forM_ s2 closeUVStream 180 | 181 | -- | Spawn a processe with given input. 182 | -- 183 | -- Child process's stdout and stderr output are collected, return with exit code. 184 | readProcess :: HasCallStack 185 | => ProcessOptions -- ^ processStdStreams options are ignored 186 | -> V.Bytes -- ^ stdin 187 | -> IO (V.Bytes, V.Bytes, ExitCode) -- ^ stdout, stderr, exit code 188 | {-# INLINABLE readProcess #-} 189 | readProcess opts inp = do 190 | withResource (initProcess opts{processStdStreams=(ProcessCreate, ProcessCreate, ProcessCreate)}) 191 | $ \ (Just s0, Just s1, Just s2, pstate) -> do 192 | r1 <- newEmptyMVar 193 | r2 <- newEmptyMVar 194 | _ <- forkIO $ do 195 | withPrimVectorSafe inp (writeOutput s0) 196 | closeUVStream s0 197 | _ <- forkIO $ do 198 | b1 <- newBufferedInput s1 199 | readAll' b1 >>= putMVar r1 200 | _ <- forkIO $ do 201 | b2 <- newBufferedInput s2 202 | readAll' b2 >>= putMVar r2 203 | (,,) <$> takeMVar r1 <*> takeMVar r2 <*> waitProcessExit pstate 204 | 205 | -- | Spawn a processe with given UTF8 textual input. 206 | -- 207 | -- Child process's stdout and stderr output are collected as UTF8 bytes, return with exit code. 208 | readProcessText :: HasCallStack 209 | => ProcessOptions -- ^ processStdStreams options are ignored 210 | -> T.Text -- ^ stdin 211 | -> IO (T.Text, T.Text, ExitCode) -- ^ stdout, stderr, exit code 212 | {-# INLINABLE readProcessText #-} 213 | readProcessText opts inp = do 214 | (out, err, e) <- readProcess opts (T.getUTF8Bytes inp) 215 | return (T.validate out, T.validate err, e) 216 | 217 | -- | Spawn a new process. 218 | -- 219 | -- Please manually close child process's std stream(if any) after process exits. 220 | spawn :: HasCallStack => ProcessOptions -> IO (Maybe UVStream, Maybe UVStream, Maybe UVStream, TVar ProcessState) 221 | {-# INLINABLE spawn #-} 222 | spawn ProcessOptions{..} = do 223 | 224 | (MutableByteArray popts##) <- newByteArray (#size uv_process_options_t) 225 | (MutableByteArray pstdio##) <- newByteArray ((#size uv_stdio_container_t)*3) 226 | 227 | pokeMBA popts## (#offset uv_process_options_t, flags) processFlags 228 | pokeMBA popts## (#offset uv_process_options_t, uid) processUID 229 | pokeMBA popts## (#offset uv_process_options_t, gid) processGID 230 | 231 | uvm <- getUVManager 232 | 233 | let (s0, s1, s2) = processStdStreams 234 | 235 | pokeMBA pstdio## (#offset uv_stdio_container_t, flags) (processStdStreamFlag s0) 236 | uvs0' <- case s0 of 237 | ProcessInherit fd -> do 238 | pokeMBA pstdio## (#offset uv_stdio_container_t, data) fd 239 | return Nothing 240 | ProcessCreate -> do 241 | (uvs0, _) <- acquire (initIPCStream uvm) 242 | pokeMBA pstdio## (#offset uv_stdio_container_t, data) (uvsHandle uvs0) 243 | return (Just uvs0) 244 | _ -> return Nothing 245 | 246 | pokeMBA pstdio## ((#offset uv_stdio_container_t, flags)+(#size uv_stdio_container_t)) 247 | (processStdStreamFlag s1) 248 | uvs1' <- case s1 of 249 | ProcessInherit fd -> do 250 | pokeMBA pstdio## ((#offset uv_stdio_container_t, data)+(#size uv_stdio_container_t)) fd 251 | return Nothing 252 | ProcessCreate -> do 253 | (uvs1, _) <- acquire (initIPCStream uvm) 254 | pokeMBA pstdio## ((#offset uv_stdio_container_t, data)+(#size uv_stdio_container_t)) 255 | (uvsHandle uvs1) 256 | return (Just uvs1) 257 | _ -> return Nothing 258 | 259 | pokeMBA pstdio## ((#offset uv_stdio_container_t, flags)+(#size uv_stdio_container_t)*2) 260 | (processStdStreamFlag s2) 261 | uvs2' <- case s2 of 262 | ProcessInherit fd -> do 263 | pokeMBA pstdio## ((#offset uv_stdio_container_t, data)+(#size uv_stdio_container_t)*2) fd 264 | return Nothing 265 | ProcessCreate -> do 266 | (uvs2, _) <- acquire (initIPCStream uvm) 267 | pokeMBA pstdio## ((#offset uv_stdio_container_t, data.stream)+(#size uv_stdio_container_t)*2) 268 | (uvsHandle uvs2) 269 | return (Just uvs2) 270 | _ -> return Nothing 271 | 272 | let mkEnv (k, v) = CBytes.concat [k, "=", v] 273 | allEnv = case processEnv of 274 | Just e -> List.map mkEnv e 275 | _ -> [] 276 | envLen = case processEnv of 277 | Just e -> List.length e 278 | _ -> -1 -- use -1 to inherit from parent 279 | 280 | (slot, pid) <- withCBytesUnsafe processFile $ \ pfile -> 281 | withCBytesUnsafe processCWD $ \ pcwd -> 282 | withCBytesListUnsafe processArgs $ \ pargs argsLen -> 283 | withCBytesListUnsafe allEnv $ \ penv _ -> 284 | withUVManager uvm $ \ loop -> do 285 | slot <- throwUVIfMinus (hs_uv_spawn loop popts## pfile 286 | pargs argsLen penv envLen pcwd pstdio##) 287 | pid <- peekBufferSizeTable uvm slot 288 | return (slot, pid) 289 | 290 | exitLock <- getBlockMVar uvm slot 291 | ps <- newTVarIO (ProcessRunning (PID (fromIntegral pid))) 292 | 293 | _ <- forkFinally (takeMVar exitLock) $ \ r -> do 294 | case r of 295 | Left _ -> atomically (writeTVar ps (ProcessExited (ExitFailure (-1)))) 296 | Right e -> 297 | let e' = if e == 0 then ExitSuccess else ExitFailure e 298 | in atomically (writeTVar ps (ProcessExited e')) 299 | 300 | 301 | return (uvs0', uvs1', uvs2', ps) 302 | 303 | -- | Retrieves the scheduling priority of the process specified by pid. 304 | -- 305 | -- The returned value of priority is between -20 (high priority) and 19 (low priority). 306 | -- On Windows, the returned priority will equal one of the PRIORITY constants. 307 | getPriority :: HasCallStack => PID -> IO Priority 308 | {-# INLINABLE getPriority #-} 309 | getPriority pid = do 310 | (p, _) <- allocPrimUnsafe $ \ p_p -> throwUVIfMinus_ (uv_os_getpriority pid p_p) 311 | return p 312 | 313 | -- | Sets the scheduling priority of the process specified by pid. 314 | -- 315 | -- The priority value range is between -20 (high priority) and 19 (low priority). 316 | -- The constants 'PRIORITY_LOW', 'PRIORITY_BELOW_NORMAL', 'PRIORITY_NORMAL', 317 | -- 'PRIORITY_ABOVE_NORMAL', 'PRIORITY_HIGH', and 'PRIORITY_HIGHEST' are also provided for convenience. 318 | -- 319 | setPriority :: HasCallStack => PID -> Priority -> IO () 320 | {-# INLINABLE setPriority #-} 321 | setPriority pid p = throwUVIfMinus_ (uv_os_setpriority pid p) 322 | -------------------------------------------------------------------------------- /Z/IO/StdStream.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Z.IO.StdStream 3 | Description : Standard Streams and TTY devices 4 | Copyright : (c) Dong Han, 2018-2020 5 | License : BSD 6 | Maintainer : winterland1989@gmail.com 7 | Stability : experimental 8 | Portability : non-portable 9 | 10 | This module provides stdin\/stderr\/stdout reading and writings. Usually you don't have to use 'stderr' or 'stderrBuf' directly, 'Z.IO.Logger' provides more logging utilities through @stderr@. While 'stdinBuf' and 'stdoutBuf' is useful when you write interactive programs, 'Z.IO.Buffered' module provide many reading and writing operations. Example: 11 | 12 | @ 13 | import Control.Concurrent.MVar 14 | import Z.IO.LowResTimer 15 | import Z.IO.Buffered 16 | import Z.IO.StdStream 17 | import qualified Z.Data.Vector as V 18 | import qualified Z.Data.Builder as B 19 | main = do 20 | -- read by '\n' 21 | b1 <- readStd 22 | -- read whatever user input in 3s, otherwise get Nothing 23 | b2 <- timeoutLowRes 30 $ withMVar stdinBuf readBuffer 24 | ... 25 | putStd "hello world!" 26 | 27 | -- Raw mode 28 | setStdinTTYMode TTY_MODE_RAW 29 | forever $ do 30 | withMVar stdinBuf $ \ i -> withMVar stdoutBuf $ \ o -> do 31 | bs <- readBuffer i 32 | let Just key = V.headMaybe bs 33 | writeBuilder o (B.hex key) 34 | flushBuffer o 35 | @ 36 | 37 | -} 38 | module Z.IO.StdStream 39 | ( -- * Standard input & output streams 40 | StdStream 41 | , getStdStreamFD 42 | , isStdStreamTTY 43 | , setStdinTTYMode 44 | , withRawStdin 45 | , getStdoutWinSize 46 | , stdin, stdout, stderr 47 | , stdinBuf, stdoutBuf, stderrBuf 48 | -- * utils 49 | , readStd, printStd, putStd, printStdLn, printStdLnP, putStdLn 50 | -- * re-export 51 | , withMVar 52 | -- * Constant 53 | -- ** TTYMode 54 | , TTYMode 55 | , pattern TTY_MODE_NORMAL 56 | , pattern TTY_MODE_RAW 57 | ) where 58 | 59 | import Control.Monad 60 | import Control.Monad.Primitive 61 | import Control.Concurrent.MVar 62 | import Foreign.Ptr 63 | import System.IO.Unsafe 64 | import qualified Z.Data.Builder as B 65 | import qualified Z.Data.Parser.Base as P 66 | import qualified Z.Data.Text.Print as T 67 | import qualified Z.Data.Vector as V 68 | import Z.IO.UV.FFI 69 | import Z.IO.UV.Manager 70 | import Z.IO.UV.Errno 71 | import Z.IO.Exception 72 | import Z.IO.Buffered 73 | import Z.Foreign 74 | 75 | -- | Standard input and output streams 76 | -- 77 | -- We support both regular file and TTY based streams, when initialized 78 | -- 'uv_guess_handle' is called to decide which type of devices are connected 79 | -- to standard streams. 80 | -- 81 | -- Note 'StdStream' is not thread safe, you shouldn't use them without lock. 82 | -- For the same reason you shouldn't use stderr directly, use `Z.IO.Logger` module instead. 83 | 84 | data StdStream 85 | = StdStream Bool {-# UNPACK #-}!(Ptr UVHandle) {-# UNPACK #-}!UVSlot UVManager 86 | -- ^ similar to UVStream, first field is is_tty 87 | | StdFile {-# UNPACK #-}!FD 88 | -- ^ similar to UVFile 89 | 90 | instance Show StdStream where show = T.toString 91 | 92 | instance T.Print StdStream where 93 | {-# INLINE toUTF8BuilderP #-} 94 | toUTF8BuilderP p (StdStream istty ptr slot uvm) = T.parenWhen (p > 10) $ do 95 | if istty 96 | then "StdStream(TTY) " 97 | else "StdStream " 98 | T.toUTF8Builder ptr 99 | T.char7 ' ' 100 | T.toUTF8Builder slot 101 | T.char7 ' ' 102 | T.toUTF8BuilderP 11 uvm 103 | toUTF8BuilderP p (StdFile fd) = T.parenWhen (p > 10) $ do 104 | "StdFile " 105 | T.toUTF8Builder fd 106 | 107 | 108 | -- | Is this standard stream connected to a TTY device? 109 | isStdStreamTTY :: StdStream -> Bool 110 | isStdStreamTTY (StdStream istty _ _ _) = istty 111 | isStdStreamTTY _ = False 112 | 113 | -- | Get the standard stream's OS file descriptor. 114 | getStdStreamFD :: StdStream -> IO FD 115 | getStdStreamFD (StdStream _ hdl _ _) = throwUVIfMinus (hs_uv_fileno hdl) 116 | getStdStreamFD (StdFile fd) = return fd 117 | 118 | instance Input StdStream where 119 | {-# INLINE readInput #-} 120 | readInput (StdStream _ hdl slot uvm) buf len = mask_ $ do 121 | pokeBufferTable uvm slot buf len 122 | m <- getBlockMVar uvm slot 123 | _ <- tryTakeMVar m 124 | throwUVIfMinus_ $ withUVManager' uvm (hs_uv_read_start hdl) 125 | -- since we are inside mask, this is the only place 126 | -- async exceptions could possibly kick in, and we should stop reading 127 | r <- takeMVar m `onException` (do 128 | -- normally we call 'uv_read_stop' in C read callback 129 | -- but when exception raise, here's the place to stop 130 | -- stop a handle twice will be a libuv error, so we don't check result 131 | _ <- withUVManager' uvm (uv_read_stop hdl) 132 | void (tryTakeMVar m)) 133 | if | r > 0 -> return r 134 | | r == fromIntegral UV_EOF -> return 0 135 | | r < 0 -> throwUVIfMinus (return r) 136 | -- r == 0 should be impossible, since we guard this situation in c side 137 | | otherwise -> throwUVError UV_UNKNOWN IOEInfo{ 138 | ioeName = "StdStream read error" 139 | , ioeDescription = "StdStream read should never return 0 before EOF" 140 | , ioeCallStack = callStack 141 | } 142 | readInput (StdFile fd) buf len = 143 | throwUVIfMinus $ hs_uv_fs_read fd buf len (-1) 144 | 145 | instance Output StdStream where 146 | {-# INLINE writeOutput #-} 147 | writeOutput (StdStream _ hdl _ uvm) buf len = mask_ $ do 148 | m <- withUVManager' uvm $ do 149 | reqSlot <- getUVSlot uvm (hs_uv_write hdl buf len) 150 | m <- getBlockMVar uvm reqSlot 151 | _ <- tryTakeMVar m 152 | return m 153 | -- we can't cancel uv_write_t with current libuv, 154 | -- otherwise disaster will happen if buffer got collected. 155 | -- so we have to turn to uninterruptibleMask_'s help. 156 | -- i.e. writing UVStream is an uninterruptible operation. 157 | -- OS will guarantee writing TTY and socket will not 158 | -- hang forever anyway. 159 | throwUVIfMinus_ (uninterruptibleMask_ $ takeMVar m) 160 | writeOutput (StdFile fd) buf len = go buf len 161 | where 162 | go !b !bufSiz = do 163 | written <- throwUVIfMinus 164 | (hs_uv_fs_write fd b bufSiz (-1)) 165 | when (written < bufSiz) 166 | (go (b `plusPtr` written) (bufSiz-written)) 167 | 168 | -- | The global stdin stream. 169 | stdin :: StdStream 170 | {-# NOINLINE stdin #-} 171 | stdin = unsafePerformIO (makeStdStream 0) 172 | 173 | -- | The global stdout stream. 174 | -- 175 | -- If you want a buffered device, consider use the 'stdoutBuf' first. 176 | -- If you want to write logs, don't use 'stdout' directly, use 'Z.IO.Logger' instead. 177 | stdout :: StdStream 178 | {-# NOINLINE stdout #-} 179 | stdout = unsafePerformIO (makeStdStream 1) 180 | 181 | -- | The global stderr stream. 182 | -- 183 | -- If you want a buffered device, consider use the 'stderrBuf' first. 184 | -- | If you want to write logs, don't use 'stderr' directly, use 'Z.IO.Logger' instead. 185 | stderr :: StdStream 186 | {-# NOINLINE stderr #-} 187 | stderr = unsafePerformIO (makeStdStream 2) 188 | 189 | -- | A global buffered stdin stream protected by 'MVar'. 190 | -- 191 | -- If you want a buffered device, consider use the 'stdinBuf' first. 192 | stdinBuf :: MVar BufferedInput 193 | {-# NOINLINE stdinBuf #-} 194 | stdinBuf = unsafePerformIO (newBufferedInput stdin >>= newMVar) 195 | 196 | -- | A global buffered stdout stream protected by 'MVar'. 197 | -- 198 | -- If you want to write logs, don't use 'stdoutBuf' directly, use 'Z.IO.Logger' instead. 199 | stdoutBuf :: MVar BufferedOutput 200 | {-# NOINLINE stdoutBuf #-} 201 | stdoutBuf = unsafePerformIO (newBufferedOutput stdout >>= newMVar) 202 | 203 | -- | A global buffered stderr stream protected by 'MVar'. 204 | -- 205 | -- If you want to write logs, don't use 'stderrBuf' directly, use 'Z.IO.Logger' instead. 206 | stderrBuf :: MVar BufferedOutput 207 | {-# NOINLINE stderrBuf #-} 208 | stderrBuf = unsafePerformIO (newBufferedOutput stderr >>= newMVar) 209 | 210 | makeStdStream :: HasCallStack => FD -> IO StdStream 211 | makeStdStream fd = do 212 | typ <- uv_guess_handle fd 213 | if typ == UV_FILE 214 | then return (StdFile fd) 215 | else mask_ $ do 216 | uvm <- getUVManager 217 | withUVManager uvm $ \ loop -> do 218 | hdl <- hs_uv_handle_alloc loop 219 | slot <- getUVSlot uvm (peekUVHandleData hdl) 220 | _ <- tryTakeMVar =<< getBlockMVar uvm slot -- clear the parking spot 221 | case typ of 222 | UV_TTY -> do 223 | throwUVIfMinus_ (uv_tty_init loop hdl (fromIntegral fd)) 224 | return (StdStream True hdl slot uvm) 225 | UV_TCP -> do 226 | throwUVIfMinus_ (uv_tcp_init loop hdl) 227 | throwUVIfMinus_ (uv_tcp_open hdl fd) 228 | return (StdStream False hdl slot uvm) 229 | UV_UDP -> 230 | throwUVError UV_EXDEV IOEInfo{ 231 | ioeName = "EXDEV" 232 | , ioeDescription = "redirect to UDP is not supported" 233 | , ioeCallStack = callStack 234 | } 235 | -- normally this would be UV_NAMED_PIPE, 236 | -- but we also give UV_UNKNOWN_HANDLE a try. 237 | _ -> do 238 | throwUVIfMinus_ (uv_pipe_init loop hdl 0) 239 | throwUVIfMinus_ (uv_pipe_open hdl fd) 240 | return (StdStream False hdl slot uvm) 241 | 242 | -- | Change terminal's mode if stdin is connected to a terminal, 243 | -- do nothing if stdout is not connected to TTY. 244 | -- 245 | setStdinTTYMode :: TTYMode -> IO () 246 | setStdinTTYMode mode = case stdin of 247 | StdStream True hdl _ uvm -> 248 | withUVManager' uvm . throwUVIfMinus_ $ uv_tty_set_mode hdl mode 249 | _ -> return () 250 | 251 | -- | Set stdin to raw mode before run IO, set back to normal after. 252 | withRawStdin :: IO a -> IO a 253 | withRawStdin = bracket_ (setStdinTTYMode TTY_MODE_RAW) (setStdinTTYMode TTY_MODE_NORMAL) 254 | 255 | -- | Get terminal's output window size in (width, height) format, 256 | -- return (-1, -1) if stdout is not connected to TTY. 257 | getStdoutWinSize :: HasCallStack => IO (Int, Int) 258 | getStdoutWinSize = case stdout of 259 | StdStream True hdl _ uvm -> 260 | withUVManager' uvm $ do 261 | (w, (h, ())) <- allocPrimUnsafe @CInt $ \ w -> 262 | allocPrimUnsafe @CInt $ \ h -> throwUVIfMinus_ $ uv_tty_get_winsize hdl w h 263 | return (fromIntegral w, fromIntegral h) 264 | _ -> return (-1, -1) 265 | 266 | -------------------------------------------------------------------------------- 267 | 268 | -- | Print a 'Print' and flush to stdout, without linefeed. 269 | printStd :: (HasCallStack, T.Print a) => a -> IO () 270 | printStd s = putStd (T.toUTF8Builder s) 271 | 272 | -- | Print a 'Builder' and flush to stdout, without linefeed. 273 | putStd :: HasCallStack => B.Builder a -> IO () 274 | putStd b = withMVar stdoutBuf $ \ o -> do 275 | writeBuilder o b 276 | flushBuffer o 277 | 278 | -- | Print a 'Print' and flush to stdout, with a linefeed. 279 | printStdLn :: (HasCallStack, T.Print a) => a -> IO () 280 | printStdLn s = putStdLn (T.toUTF8Builder s) 281 | 282 | -- | Similar to 'printStdLn', 'P.Parser' debug tool. 283 | printStdLnP :: (HasCallStack, T.Print a) => a -> P.Parser () 284 | printStdLnP s = unsafeIOToPrim $ putStdLn (T.toUTF8Builder s) 285 | 286 | -- | Print a 'Builder' and flush to stdout, with a linefeed. 287 | putStdLn :: HasCallStack => B.Builder a -> IO () 288 | putStdLn b = withMVar stdoutBuf $ \ o -> do 289 | writeBuilder o (b >> B.char8 '\n') 290 | flushBuffer o 291 | 292 | -- | Read a line from stdin(in normal mode). 293 | -- 294 | -- This function will throw 'ECLOSED' when meet EOF, which may cause trouble if stdin is connected 295 | -- to a file, use 'readLine' instead. 296 | readStd :: HasCallStack => IO V.Bytes 297 | readStd = withMVar stdinBuf $ \ s -> do 298 | line <- readLine s 299 | case line of Just line' -> return line' 300 | Nothing -> throwIO (ResourceVanished 301 | (IOEInfo "ECLOSED" "stdin is closed" callStack)) 302 | -------------------------------------------------------------------------------- /Z/IO/StdStream/Ansi.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Z.IO.StdStream.Ansi 3 | Description : Ansi control code sequences 4 | Copyright : (c) Winterland, 2017-2020 5 | License : BSD 6 | Maintainer : winterland1989@gmail.com 7 | Stability : experimental 8 | Portability : non-portable 9 | Provides utilities to build . 10 | @ 11 | > putStd . bold . italicize . color Red $ "hello" 12 | hello -- bold, italicize and red 13 | @ 14 | -} 15 | 16 | module Z.IO.StdStream.Ansi 17 | ( -- * Style modifier 18 | bold, italicize, underline, 19 | color, color', palette, palette', rgb, rgb', 20 | -- * Control codes 21 | cursorUp, cursorDown, cursorForward, cursorBackward, 22 | cursorDownLine, cursorUpLine , 23 | setCursorColumn, setCursorPosition, saveCursor, restoreCursor, getCursorPosition, 24 | clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen, 25 | clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine, 26 | scrollPageUp, scrollPageDown, 27 | hideCursor, showCursor, 28 | setTitle, 29 | -- * Style codes 30 | reset, 31 | boldIntensity, faintIntensity, resetIntensity, 32 | italicized, noItalicized, 33 | singleUnderline, doubleUnderline, noUnderline, 34 | slowBlink, rapidBlink, blinkOff, 35 | conceal, reveal, 36 | invert, invertOff, 37 | setForeground, setBrightForeground, setBackground, setBrightBackground, 38 | setPaletteForeground, setPaletteBackground, 39 | setRGBForeground, setRGBBackground, 40 | setDefaultForeground, setDefaultBackground, 41 | AnsiColor(..), PaletteColor, RGBColor, 42 | -- * Internal helper 43 | csi, sgr, colorToCode 44 | ) where 45 | 46 | import Control.Monad 47 | import qualified Z.Data.Builder as B 48 | import qualified Z.Data.Parser as P 49 | import qualified Z.Data.Text as T 50 | import Z.Data.ASCII 51 | import Data.Word 52 | import GHC.Generics 53 | import Z.IO.StdStream 54 | import Z.IO.Buffered 55 | 56 | csi :: [Int] -- ^ List of parameters for the control sequence 57 | -> B.Builder () -- ^ Character(s) that identify the control function 58 | -> B.Builder () 59 | {-# INLINABLE csi #-} 60 | csi args code = do 61 | B.char8 '\ESC' 62 | B.char8 '[' 63 | B.intercalateList (B.char8 ';') B.int args 64 | code 65 | 66 | cursorUp, cursorDown, cursorForward, cursorBackward 67 | :: Int -- ^ Number of lines or characters to move 68 | -> B.Builder () 69 | cursorDownLine, cursorUpLine :: Int -- ^ Number of lines to move 70 | -> B.Builder () 71 | {-# INLINABLE cursorUp #-} 72 | cursorUp n = when (n > 0) $ csi [n] (B.char8 'A') 73 | {-# INLINABLE cursorDown #-} 74 | cursorDown n = when (n > 0) $ csi [n] (B.char8 'B') 75 | {-# INLINABLE cursorForward #-} 76 | cursorForward n = when (n > 0) $ csi [n] (B.char8 'C') 77 | {-# INLINABLE cursorBackward #-} 78 | cursorBackward n = when (n > 0) $ csi [n] (B.char8 'D') 79 | {-# INLINABLE cursorDownLine #-} 80 | cursorDownLine n = when (n > 0) $ csi [n] (B.char8 'E') 81 | {-# INLINABLE cursorUpLine #-} 82 | cursorUpLine n = when (n > 0) $ csi [n] (B.char8 'F') 83 | 84 | getCursorPosition :: BufferedInput -> IO (Int, Int) 85 | {-# INLINABLE getCursorPosition #-} 86 | getCursorPosition i = do 87 | clearInputBuffer i 88 | putStd (csi [] "6n") 89 | readParser (do 90 | P.word8 ESC 91 | P.word8 BRACKET_LEFT 92 | !n <- P.int 93 | P.word8 SEMICOLON 94 | !m <- P.int 95 | P.word8 LETTER_R 96 | return (m, n)) i 97 | 98 | -- | Code to move the cursor to the specified column. The column numbering is 99 | -- 1-based (that is, the left-most column is numbered 1). 100 | setCursorColumn :: Int -- ^ 1-based column to move to 101 | -> B.Builder () 102 | {-# INLINABLE setCursorColumn #-} 103 | setCursorColumn n = csi [n] (B.char8 'G') 104 | 105 | -- | Code to move the cursor to the specified position (row and column). The 106 | -- position is 1-based (that is, the top-left corner is at row 1 column 1). 107 | setCursorPosition :: Int -- ^ 1-based row to move to 108 | -> Int -- ^ 1-based column to move to 109 | -> B.Builder () 110 | {-# INLINABLE setCursorPosition #-} 111 | setCursorPosition n m = csi [n, m] (B.char8 'G') 112 | 113 | saveCursor, restoreCursor :: B.Builder () 114 | {-# INLINABLE saveCursor #-} 115 | saveCursor = B.char8 '\ESC' >> B.char8 '7' 116 | {-# INLINABLE restoreCursor #-} 117 | restoreCursor = B.char8 '\ESC' >> B.char8 '8' 118 | 119 | clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen :: B.Builder () 120 | clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine :: B.Builder () 121 | 122 | {-# INLINABLE clearFromCursorToScreenEnd #-} 123 | clearFromCursorToScreenEnd = csi [0] (B.char8 'J') 124 | {-# INLINABLE clearFromCursorToScreenBeginning #-} 125 | clearFromCursorToScreenBeginning = csi [1] (B.char8 'J') 126 | {-# INLINABLE clearScreen #-} 127 | clearScreen = csi [2] (B.char8 'J') 128 | {-# INLINABLE clearFromCursorToLineEnd #-} 129 | clearFromCursorToLineEnd = csi [0] (B.char8 'K') 130 | {-# INLINABLE clearFromCursorToLineBeginning #-} 131 | clearFromCursorToLineBeginning = csi [1] (B.char8 'K') 132 | {-# INLINABLE clearLine #-} 133 | clearLine = csi [2] (B.char8 'K') 134 | 135 | scrollPageUp, scrollPageDown :: Int -- ^ Number of lines to scroll by 136 | -> B.Builder() 137 | {-# INLINABLE scrollPageUp #-} 138 | scrollPageUp n = when (n > 0) $ csi [n] (B.char8 'S') 139 | {-# INLINABLE scrollPageDown #-} 140 | scrollPageDown n = when (n > 0) $ csi [n] (B.char8 'T') 141 | 142 | hideCursor, showCursor :: B.Builder () 143 | {-# INLINABLE hideCursor #-} 144 | hideCursor = csi [] "?25l" 145 | {-# INLINABLE showCursor #-} 146 | showCursor = csi [] "?25h" 147 | 148 | -- | XTerm control sequence to set the Icon Name and Window Title. 149 | setTitle :: T.Text -- ^ New Icon Name and Window Title 150 | -> B.Builder () 151 | {-# INLINABLE setTitle #-} 152 | setTitle title = do 153 | "\ESC]0;" 154 | B.text (T.filter (/= '\007') title) 155 | B.char8 '\007' 156 | 157 | sgr :: [Word8] -- ^ List of sgr code for the control sequence 158 | -> B.Builder () 159 | {-# INLINABLE sgr #-} 160 | sgr args = do 161 | B.char8 '\ESC' 162 | B.char8 '[' 163 | B.intercalateList (B.char8 ';') B.int args 164 | B.char8 'm' 165 | 166 | reset :: B.Builder () 167 | {-# INLINABLE reset #-} 168 | reset = sgr [0] 169 | 170 | boldIntensity, faintIntensity, resetIntensity :: B.Builder () 171 | {-# INLINABLE boldIntensity #-} 172 | boldIntensity = sgr [1] 173 | {-# INLINABLE faintIntensity #-} 174 | faintIntensity = sgr [2] 175 | {-# INLINABLE resetIntensity #-} 176 | resetIntensity = sgr [22] 177 | 178 | bold :: B.Builder () -> B.Builder () 179 | {-# INLINABLE bold #-} 180 | bold t = boldIntensity >> t >> resetIntensity 181 | 182 | italicized, noItalicized :: B.Builder () 183 | {-# INLINABLE italicized #-} 184 | italicized = sgr [3] 185 | {-# INLINABLE noItalicized #-} 186 | noItalicized = sgr [23] 187 | 188 | -- | Italicize some text 189 | italicize :: B.Builder () -> B.Builder () 190 | {-# INLINABLE italicize #-} 191 | italicize t = italicized >> t >> noItalicized 192 | 193 | singleUnderline, doubleUnderline, noUnderline :: B.Builder () 194 | {-# INLINABLE singleUnderline #-} 195 | singleUnderline = sgr [4] 196 | {-# INLINABLE doubleUnderline #-} 197 | doubleUnderline = sgr [21] 198 | {-# INLINABLE noUnderline #-} 199 | noUnderline = sgr [24] 200 | 201 | -- | Add single underline to some text 202 | underline :: B.Builder () -> B.Builder () 203 | {-# INLINABLE underline #-} 204 | underline t = singleUnderline >> t >> singleUnderline 205 | 206 | slowBlink, rapidBlink, blinkOff :: B.Builder () 207 | -- | less than 150 per minute 208 | {-# INLINABLE slowBlink #-} 209 | slowBlink = sgr [5] 210 | -- | MS-DOS ANSI.SYS, 150+ per minute; not widely supported 211 | {-# INLINABLE rapidBlink #-} 212 | rapidBlink = sgr [6] 213 | {-# INLINABLE blinkOff #-} 214 | blinkOff = sgr [25] 215 | 216 | conceal, reveal :: B.Builder () 217 | -- | Aka Hide, not widely supported. 218 | {-# INLINABLE conceal #-} 219 | conceal = sgr [8] 220 | {-# INLINABLE reveal #-} 221 | reveal = sgr [28] 222 | 223 | invert, invertOff :: B.Builder () 224 | -- | Swap foreground and background colors, inconsistent emulation 225 | {-# INLINABLE invert #-} 226 | invert = sgr [7] 227 | {-# INLINABLE invertOff #-} 228 | invertOff = sgr [27] 229 | 230 | -- | Colorized some text 231 | color :: AnsiColor -> B.Builder () -> B.Builder () 232 | {-# INLINABLE color #-} 233 | color c t = do 234 | setForeground c 235 | t 236 | setDefaultForeground 237 | 238 | -- | Colorized some text with background color 239 | color' :: AnsiColor -> AnsiColor -> B.Builder () -> B.Builder () 240 | {-# INLINABLE color' #-} 241 | color' c1 c2 t = do 242 | setForeground c1 243 | setBackground c2 244 | t 245 | setDefaultForeground 246 | setDefaultBackground 247 | 248 | -- | Colorized some text 249 | palette :: PaletteColor -> B.Builder () -> B.Builder () 250 | {-# INLINABLE palette #-} 251 | palette c t = do 252 | setPaletteForeground c 253 | t 254 | setDefaultForeground 255 | 256 | -- | Colorized some text with background color 257 | palette' :: PaletteColor -> PaletteColor -> B.Builder () -> B.Builder () 258 | {-# INLINABLE palette' #-} 259 | palette' c1 c2 t = do 260 | setPaletteForeground c1 261 | setPaletteBackground c2 262 | t 263 | setDefaultForeground 264 | setDefaultBackground 265 | 266 | -- | Colorized some text 267 | rgb :: RGBColor -> B.Builder () -> B.Builder () 268 | {-# INLINABLE rgb #-} 269 | rgb c t = do 270 | setRGBForeground c 271 | t 272 | setDefaultForeground 273 | 274 | -- | Colorized some text with background color 275 | rgb' :: RGBColor -> RGBColor -> B.Builder () -> B.Builder () 276 | {-# INLINABLE rgb' #-} 277 | rgb' c1 c2 t = do 278 | setRGBForeground c1 279 | setRGBBackground c2 280 | t 281 | setDefaultForeground 282 | setDefaultBackground 283 | 284 | setForeground, setBrightForeground, setBackground, setBrightBackground :: AnsiColor -> B.Builder () 285 | {-# INLINABLE setForeground #-} 286 | setForeground c = sgr [30 + colorToCode c] 287 | {-# INLINABLE setBrightForeground #-} 288 | setBrightForeground c = sgr [90 + colorToCode c] 289 | {-# INLINABLE setBackground #-} 290 | setBackground c = sgr [40 + colorToCode c] 291 | {-# INLINABLE setBrightBackground #-} 292 | setBrightBackground c = sgr [100 + colorToCode c] 293 | 294 | setPaletteForeground, setPaletteBackground :: PaletteColor -> B.Builder () 295 | {-# INLINABLE setPaletteForeground #-} 296 | setPaletteForeground index = sgr [38, 5, index] 297 | {-# INLINABLE setPaletteBackground #-} 298 | setPaletteBackground index = sgr [48, 5, index] 299 | 300 | setRGBForeground, setRGBBackground :: RGBColor -> B.Builder () 301 | {-# INLINABLE setRGBForeground #-} 302 | setRGBForeground (r,g,b) = sgr [38, 2, r, g, b] 303 | {-# INLINABLE setRGBBackground #-} 304 | setRGBBackground (r,g,b) = sgr [48, 2, r, g, b] 305 | 306 | setDefaultForeground, setDefaultBackground :: B.Builder () 307 | {-# INLINABLE setDefaultForeground #-} 308 | setDefaultForeground = sgr [39] 309 | {-# INLINABLE setDefaultBackground #-} 310 | setDefaultBackground = sgr [49] 311 | 312 | -- | ANSI's eight standard colors 313 | data AnsiColor = Black 314 | | Red 315 | | Green 316 | | Yellow 317 | | Blue 318 | | Magenta 319 | | Cyan 320 | | White 321 | deriving (Eq, Ord, Bounded, Enum, Show, Read, Generic) 322 | deriving anyclass T.Print 323 | 324 | colorToCode :: AnsiColor -> Word8 325 | {-# INLINABLE colorToCode #-} 326 | colorToCode c = case c of 327 | Black -> 0 328 | Red -> 1 329 | Green -> 2 330 | Yellow -> 3 331 | Blue -> 4 332 | Magenta -> 5 333 | Cyan -> 6 334 | White -> 7 335 | 336 | -- | 8-bit palette color, see https://en.wikipedia.org/wiki/ANSI_escape_code#8-bit 337 | type PaletteColor = Word8 338 | 339 | -- | 24-bit RGB color 340 | type RGBColor = (Word8, Word8, Word8) 341 | -------------------------------------------------------------------------------- /Z/IO/Time.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Z.IO.Time 3 | Description : Fast time functions 4 | Copyright : (c) Dong Han, 2020 5 | (c) Kazu Yamamoto 2019 6 | License : BSD 7 | Maintainer : winterland1989@gmail.com 8 | Stability : experimental 9 | Portability : non-portable 10 | 11 | This module provides functions directly work on 'SystemTime' type, a compact time type from @time@ library. 12 | For advanced time editing, use @time@ library. 13 | 14 | -} 15 | module Z.IO.Time 16 | ( -- * SystemTime 17 | SystemTime(..), getSystemTime' 18 | -- * Parsing 19 | , parseSystemTime, parseSystemTimeGMT 20 | -- * Formatting 21 | , formatSystemTime, formatSystemTimeGMT 22 | -- * Format 23 | , TimeFormat, simpleDateFormat, iso8061DateFormat, webDateFormat, mailDateFormat 24 | ) where 25 | 26 | import Data.Time.Clock.System 27 | import Data.Word 28 | import Data.Int 29 | import Foreign.C.Types 30 | import Z.Foreign 31 | import Z.Data.CBytes 32 | import Z.IO.UV.FFI_Env 33 | import Z.IO.Exception 34 | import System.IO.Unsafe (unsafePerformIO) 35 | 36 | 37 | -- | A alternative version of 'getSystemTime'' based on libuv's @uv_gettimeofday@, which also doesn't use pinned allocation. 38 | getSystemTime' :: HasCallStack => IO SystemTime 39 | {-# INLINABLE getSystemTime' #-} 40 | getSystemTime' = do 41 | (TimeVal64 s us) <- getTimeOfDay 42 | return (MkSystemTime s (fromIntegral us * 1000)) 43 | 44 | -- | time format. 45 | type TimeFormat = CBytes 46 | 47 | -- | Simple format @2020-10-16 03:15:29@. 48 | -- 49 | -- The value is \"%Y-%m-%d %H:%M:%S\". 50 | -- This should be used with 'formatSystemTime' and 'parseSystemTime'. 51 | simpleDateFormat :: TimeFormat 52 | {-# INLINABLE simpleDateFormat #-} 53 | simpleDateFormat = "%Y-%m-%d %H:%M:%S" 54 | 55 | -- | Simple format @2020-10-16T03:15:29@. 56 | -- 57 | -- The value is \"%Y-%m-%dT%H:%M:%S%z\". 58 | -- This should be used with 'formatSystemTime' and 'parseSystemTime'. 59 | iso8061DateFormat :: TimeFormat 60 | {-# INLINABLE iso8061DateFormat #-} 61 | iso8061DateFormat = "%Y-%m-%dT%H:%M:%S%z" 62 | 63 | -- | Format for web (RFC 2616). 64 | -- 65 | -- The value is \"%a, %d %b %Y %H:%M:%S GMT\". 66 | -- This should be used with 'formatSystemTimeGMT' and 'parseSystemTimeGMT'. 67 | webDateFormat :: TimeFormat 68 | {-# INLINABLE webDateFormat #-} 69 | webDateFormat = "%a, %d %b %Y %H:%M:%S GMT" 70 | 71 | -- | Format for e-mail (RFC 5322). 72 | -- 73 | -- The value is \"%a, %d %b %Y %H:%M:%S %z\". 74 | -- This should be used with 'formatSystemTime' and 'parseSystemTime'. 75 | mailDateFormat :: TimeFormat 76 | {-# INLINABLE mailDateFormat #-} 77 | mailDateFormat = "%a, %d %b %Y %H:%M:%S %z" 78 | 79 | ---------------------------------------------------------------- 80 | -- | Formatting 'SystemTime' to 'CBytes' in local time. 81 | -- 82 | -- This is a wrapper for strftime_l(), 'systemNanoseconds' is ignored. 83 | -- The result depends on the TZ environment variable. 84 | -- 85 | formatSystemTime :: TimeFormat -> SystemTime -> IO CBytes 86 | formatSystemTime fmt t = formatSystemTimeHelper c_format_unix_time fmt t 87 | {-# INLINABLE formatSystemTime #-} 88 | 89 | -- | Formatting 'SystemTime' to 'CBytes' in GMT. 90 | -- 91 | -- This is a wrapper for strftime_l(), 'systemNanoseconds' is ignored. 92 | -- 93 | -- >>> formatSystemTimeGMT webDateFormat $ MkSystemTime 0 0 94 | -- "Thu, 01 Jan 1970 00:00:00 GMT" 95 | -- >>> let ut = MkSystemTime 100 200 96 | -- >>> let str = formatSystemTimeGMT "%s" ut 97 | -- >>> let ut' = parseSystemTimeGMT "%s" str 98 | -- >>> ((==) `on` systemSeconds) ut ut' 99 | -- True 100 | -- >>> ((==) `on` systemNanoseconds) ut ut' 101 | -- False 102 | -- 103 | formatSystemTimeGMT :: TimeFormat -> SystemTime -> CBytes 104 | formatSystemTimeGMT fmt t = 105 | unsafePerformIO $ formatSystemTimeHelper c_format_unix_time_gmt fmt t 106 | {-# INLINABLE formatSystemTimeGMT #-} 107 | 108 | ---------------------------------------------------------------- 109 | -- | Parsing 'CBytes' to 'SystemTime' interpreting as localtime. 110 | -- 111 | -- This is a wrapper for strptime_l(). 112 | -- Many implementations of strptime_l() do not support %Z and 113 | -- some implementations of strptime_l() do not support %z, either. 114 | -- 'systemNanoSeconds' is always set to 0. 115 | -- 116 | -- The result depends on the TZ environment variable. 117 | -- 118 | -- @ 119 | -- > setEnv "TZ" "Africa\/Algiers" 120 | -- parseSystemTime simpleDateFormat "1970-01-01 00:00:00" 121 | -- MkSystemTime {systemSeconds = 0, systemNanoseconds = 0} 122 | -- > setEnv "TZ" "Asia\/Shanghai" 123 | -- parseSystemTime simpleDateFormat "1970-01-01 00:00:00" 124 | -- MkSystemTime {systemSeconds = -28800, systemNanoseconds = 0} 125 | -- @ 126 | -- 127 | parseSystemTime :: TimeFormat -> CBytes -> IO SystemTime 128 | {-# INLINABLE parseSystemTime #-} 129 | parseSystemTime fmt str = 130 | withCBytesUnsafe fmt $ \cfmt -> 131 | withCBytesUnsafe str $ \cstr -> do 132 | sec <- c_parse_unix_time cfmt cstr 133 | return $ MkSystemTime sec 0 134 | 135 | -- | Parsing 'CBytes' to 'SystemTime' interpreting as GMT. 136 | -- This is a wrapper for strptime_l(). 137 | -- 'systemNanoSeconds' is always set to 0. 138 | -- 139 | -- >>> parseSystemTimeGMT webDateFormat "Thu, 01 Jan 1970 00:00:00 GMT" 140 | -- MkSystemTime {systemSeconds = 0, systemNanoseconds = 0} 141 | 142 | parseSystemTimeGMT :: TimeFormat -> CBytes -> SystemTime 143 | {-# INLINABLE parseSystemTimeGMT #-} 144 | parseSystemTimeGMT fmt str = unsafePerformIO $ 145 | withCBytesUnsafe fmt $ \cfmt -> 146 | withCBytesUnsafe str $ \cstr -> do 147 | sec <- c_parse_unix_time_gmt cfmt cstr 148 | return $ MkSystemTime sec 0 149 | 150 | -------------------------------------------------------------------------------- 151 | 152 | foreign import ccall unsafe "c_parse_unix_time" 153 | c_parse_unix_time :: BA# Word8 -> BA# Word8 -> IO Int64 154 | 155 | foreign import ccall unsafe "c_parse_unix_time_gmt" 156 | c_parse_unix_time_gmt :: BA# Word8 -> BA# Word8 -> IO Int64 157 | 158 | foreign import ccall unsafe "c_format_unix_time" 159 | c_format_unix_time :: BA# Word8 -> Int64 -> MBA# Word8 -> CInt -> IO CSize 160 | 161 | foreign import ccall unsafe "c_format_unix_time_gmt" 162 | c_format_unix_time_gmt :: BA# Word8 -> Int64 -> MBA# Word8 -> CInt -> IO CSize 163 | 164 | -- | Helper handling memory allocation for formatSystemTime and formatSystemTimeGMT. 165 | formatSystemTimeHelper 166 | :: (BA# Word8 -> Int64 -> MBA# Word8 -> CInt -> IO CSize) 167 | -> TimeFormat 168 | -> SystemTime 169 | -> IO CBytes 170 | {-# INLINABLE formatSystemTimeHelper #-} 171 | formatSystemTimeHelper formatFun fmt t = go 80 172 | where 173 | MkSystemTime sec _ = t 174 | go !siz = do 175 | (bs, r)<- allocCBytesUnsafe siz $ \ pbuf -> 176 | withCBytesUnsafe fmt $ \ pfmt -> 177 | formatFun pfmt sec pbuf (fromIntegral siz) 178 | if r <= 0 then go (siz*2) else return bs 179 | -------------------------------------------------------------------------------- /Z/IO/UV/Errno.hsc: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Z.IO.UVErrno 3 | Description : Errno provided by libuv 4 | Copyright : (c) Winterland, 2017-2018 5 | License : BSD 6 | Maintainer : winterland1989@gmail.com 7 | Stability : experimental 8 | Portability : non-portable 9 | 10 | INTERNAL MODULE, provides all libuv errno. 11 | 12 | -} 13 | 14 | module Z.IO.UV.Errno where 15 | 16 | import Foreign.C.Types 17 | import Foreign.C.String 18 | import Z.Data.Text (Text) 19 | import Z.Data.CBytes as CB 20 | 21 | #include "hs_uv.h" 22 | 23 | -- | Returns the error message for the given error code. Leaks a few bytes of memory when you call it with an unknown error code. 24 | uvStdError :: CInt -> IO Text 25 | {-# INLINABLE uvStdError #-} 26 | uvStdError errno = toText <$> (fromCString =<< uv_strerror errno) 27 | 28 | foreign import ccall unsafe uv_strerror :: CInt -> IO CString 29 | 30 | -- | Returns the error name for the given error code. Leaks a few bytes of memory when you call it with an unknown error code. 31 | uvErrName :: CInt -> IO Text 32 | {-# INLINABLE uvErrName #-} 33 | uvErrName errno = toText <$> (fromCString =<< uv_err_name errno) 34 | 35 | foreign import ccall unsafe uv_err_name :: CInt -> IO CString 36 | 37 | -- | argument list too long 38 | pattern UV_E2BIG :: CInt 39 | pattern UV_E2BIG = #{const UV_E2BIG } 40 | -- | permission denied 41 | pattern UV_EACCES :: CInt 42 | pattern UV_EACCES = #{const UV_EACCES } 43 | -- | address already in use 44 | pattern UV_EADDRINUSE :: CInt 45 | pattern UV_EADDRINUSE = #{const UV_EADDRINUSE } 46 | -- | address not available 47 | pattern UV_EADDRNOTAVAIL :: CInt 48 | pattern UV_EADDRNOTAVAIL = #{const UV_EADDRNOTAVAIL } 49 | -- | address family not supported 50 | pattern UV_EAFNOSUPPORT :: CInt 51 | pattern UV_EAFNOSUPPORT = #{const UV_EAFNOSUPPORT } 52 | -- | resource temporarily unavailable 53 | pattern UV_EAGAIN :: CInt 54 | pattern UV_EAGAIN = #{const UV_EAGAIN } 55 | -- | address family not supported 56 | pattern UV_EAI_ADDRFAMILY :: CInt 57 | pattern UV_EAI_ADDRFAMILY = #{const UV_EAI_ADDRFAMILY } 58 | -- | temporary failure 59 | pattern UV_EAI_AGAIN :: CInt 60 | pattern UV_EAI_AGAIN = #{const UV_EAI_AGAIN } 61 | -- | bad ai_flags value 62 | pattern UV_EAI_BADFLAGS :: CInt 63 | pattern UV_EAI_BADFLAGS = #{const UV_EAI_BADFLAGS } 64 | -- | invalid value for hints 65 | pattern UV_EAI_BADHINTS :: CInt 66 | pattern UV_EAI_BADHINTS = #{const UV_EAI_BADHINTS } 67 | -- | request canceled 68 | pattern UV_EAI_CANCELED :: CInt 69 | pattern UV_EAI_CANCELED = #{const UV_EAI_CANCELED } 70 | -- | permanent failure 71 | pattern UV_EAI_FAIL :: CInt 72 | pattern UV_EAI_FAIL = #{const UV_EAI_FAIL } 73 | -- | ai_family not supported 74 | pattern UV_EAI_FAMILY :: CInt 75 | pattern UV_EAI_FAMILY = #{const UV_EAI_FAMILY } 76 | -- | out of memory 77 | pattern UV_EAI_MEMORY :: CInt 78 | pattern UV_EAI_MEMORY = #{const UV_EAI_MEMORY } 79 | -- | no address 80 | pattern UV_EAI_NODATA :: CInt 81 | pattern UV_EAI_NODATA = #{const UV_EAI_NODATA } 82 | -- | unknown node or service 83 | pattern UV_EAI_NONAME :: CInt 84 | pattern UV_EAI_NONAME = #{const UV_EAI_NONAME } 85 | -- | argument buffer overflow 86 | pattern UV_EAI_OVERFLOW :: CInt 87 | pattern UV_EAI_OVERFLOW = #{const UV_EAI_OVERFLOW } 88 | -- | resolved protocol is unknown 89 | pattern UV_EAI_PROTOCOL :: CInt 90 | pattern UV_EAI_PROTOCOL = #{const UV_EAI_PROTOCOL } 91 | -- | service not available for socket type 92 | pattern UV_EAI_SERVICE :: CInt 93 | pattern UV_EAI_SERVICE = #{const UV_EAI_SERVICE } 94 | -- | socket type not supported 95 | pattern UV_EAI_SOCKTYPE :: CInt 96 | pattern UV_EAI_SOCKTYPE = #{const UV_EAI_SOCKTYPE } 97 | -- | connection already in progress 98 | pattern UV_EALREADY :: CInt 99 | pattern UV_EALREADY = #{const UV_EALREADY } 100 | -- | bad file descriptor 101 | pattern UV_EBADF :: CInt 102 | pattern UV_EBADF = #{const UV_EBADF } 103 | -- | resource busy or locked 104 | pattern UV_EBUSY :: CInt 105 | pattern UV_EBUSY = #{const UV_EBUSY } 106 | -- | operation canceled 107 | pattern UV_ECANCELED :: CInt 108 | pattern UV_ECANCELED = #{const UV_ECANCELED } 109 | -- | invalid Unicode character 110 | pattern UV_ECHARSET :: CInt 111 | pattern UV_ECHARSET = #{const UV_ECHARSET } 112 | -- | software caused connection abort 113 | pattern UV_ECONNABORTED :: CInt 114 | pattern UV_ECONNABORTED = #{const UV_ECONNABORTED } 115 | -- | connection refused 116 | pattern UV_ECONNREFUSED :: CInt 117 | pattern UV_ECONNREFUSED = #{const UV_ECONNREFUSED } 118 | -- | connection reset by peer 119 | pattern UV_ECONNRESET :: CInt 120 | pattern UV_ECONNRESET = #{const UV_ECONNRESET } 121 | -- | destination address required 122 | pattern UV_EDESTADDRREQ :: CInt 123 | pattern UV_EDESTADDRREQ = #{const UV_EDESTADDRREQ } 124 | -- | file already exists 125 | pattern UV_EEXIST :: CInt 126 | pattern UV_EEXIST = #{const UV_EEXIST } 127 | -- | bad address in system call argument 128 | pattern UV_EFAULT :: CInt 129 | pattern UV_EFAULT = #{const UV_EFAULT } 130 | -- | file too large 131 | pattern UV_EFBIG :: CInt 132 | pattern UV_EFBIG = #{const UV_EFBIG } 133 | -- | host is unreachable 134 | pattern UV_EHOSTUNREACH :: CInt 135 | pattern UV_EHOSTUNREACH = #{const UV_EHOSTUNREACH } 136 | -- | interrupted system call 137 | pattern UV_EINTR :: CInt 138 | pattern UV_EINTR = #{const UV_EINTR } 139 | -- | invalid argument 140 | pattern UV_EINVAL :: CInt 141 | pattern UV_EINVAL = #{const UV_EINVAL } 142 | -- | i/o error 143 | pattern UV_EIO :: CInt 144 | pattern UV_EIO = #{const UV_EIO } 145 | -- | socket is already connected 146 | pattern UV_EISCONN :: CInt 147 | pattern UV_EISCONN = #{const UV_EISCONN } 148 | -- | illegal operation on a directory 149 | pattern UV_EISDIR :: CInt 150 | pattern UV_EISDIR = #{const UV_EISDIR } 151 | -- | too many symbolic links encountered 152 | pattern UV_ELOOP :: CInt 153 | pattern UV_ELOOP = #{const UV_ELOOP } 154 | -- | too many open files 155 | pattern UV_EMFILE :: CInt 156 | pattern UV_EMFILE = #{const UV_EMFILE } 157 | -- | message too long 158 | pattern UV_EMSGSIZE :: CInt 159 | pattern UV_EMSGSIZE = #{const UV_EMSGSIZE } 160 | -- | name too long 161 | pattern UV_ENAMETOOLONG :: CInt 162 | pattern UV_ENAMETOOLONG = #{const UV_ENAMETOOLONG } 163 | -- | network is down 164 | pattern UV_ENETDOWN :: CInt 165 | pattern UV_ENETDOWN = #{const UV_ENETDOWN } 166 | -- | network is unreachable 167 | pattern UV_ENETUNREACH :: CInt 168 | pattern UV_ENETUNREACH = #{const UV_ENETUNREACH } 169 | -- | file table overflow 170 | pattern UV_ENFILE :: CInt 171 | pattern UV_ENFILE = #{const UV_ENFILE } 172 | -- | no buffer space available 173 | pattern UV_ENOBUFS :: CInt 174 | pattern UV_ENOBUFS = #{const UV_ENOBUFS } 175 | -- | no such device 176 | pattern UV_ENODEV :: CInt 177 | pattern UV_ENODEV = #{const UV_ENODEV } 178 | -- | no such file or directory 179 | pattern UV_ENOENT :: CInt 180 | pattern UV_ENOENT = #{const UV_ENOENT } 181 | -- | not enough memory 182 | pattern UV_ENOMEM :: CInt 183 | pattern UV_ENOMEM = #{const UV_ENOMEM } 184 | -- | machine is not on the network 185 | pattern UV_ENONET :: CInt 186 | pattern UV_ENONET = #{const UV_ENONET } 187 | -- | protocol not available 188 | pattern UV_ENOPROTOOPT :: CInt 189 | pattern UV_ENOPROTOOPT = #{const UV_ENOPROTOOPT } 190 | -- | no space left on device 191 | pattern UV_ENOSPC :: CInt 192 | pattern UV_ENOSPC = #{const UV_ENOSPC } 193 | -- | function not implemented 194 | pattern UV_ENOSYS :: CInt 195 | pattern UV_ENOSYS = #{const UV_ENOSYS } 196 | -- | socket is not connected 197 | pattern UV_ENOTCONN :: CInt 198 | pattern UV_ENOTCONN = #{const UV_ENOTCONN } 199 | -- | not a directory 200 | pattern UV_ENOTDIR :: CInt 201 | pattern UV_ENOTDIR = #{const UV_ENOTDIR } 202 | -- | directory not empty 203 | pattern UV_ENOTEMPTY :: CInt 204 | pattern UV_ENOTEMPTY = #{const UV_ENOTEMPTY } 205 | -- | socket operation on non-socket 206 | pattern UV_ENOTSOCK :: CInt 207 | pattern UV_ENOTSOCK = #{const UV_ENOTSOCK } 208 | -- | operation not supported on socket 209 | pattern UV_ENOTSUP :: CInt 210 | pattern UV_ENOTSUP = #{const UV_ENOTSUP } 211 | -- | operation not permitted 212 | pattern UV_EPERM :: CInt 213 | pattern UV_EPERM = #{const UV_EPERM } 214 | -- | broken pipe 215 | pattern UV_EPIPE :: CInt 216 | pattern UV_EPIPE = #{const UV_EPIPE } 217 | -- | protocol error 218 | pattern UV_EPROTO :: CInt 219 | pattern UV_EPROTO = #{const UV_EPROTO } 220 | -- | protocol not supported 221 | pattern UV_EPROTONOSUPPORT :: CInt 222 | pattern UV_EPROTONOSUPPORT = #{const UV_EPROTONOSUPPORT} 223 | -- | protocol wrong type for socket 224 | pattern UV_EPROTOTYPE :: CInt 225 | pattern UV_EPROTOTYPE = #{const UV_EPROTOTYPE } 226 | -- | result too large 227 | pattern UV_ERANGE :: CInt 228 | pattern UV_ERANGE = #{const UV_ERANGE } 229 | -- | read-only file system 230 | pattern UV_EROFS :: CInt 231 | pattern UV_EROFS = #{const UV_EROFS } 232 | -- | cannot send after transport endpoint shutdown 233 | pattern UV_ESHUTDOWN :: CInt 234 | pattern UV_ESHUTDOWN = #{const UV_ESHUTDOWN } 235 | -- | invalid seek 236 | pattern UV_ESPIPE :: CInt 237 | pattern UV_ESPIPE = #{const UV_ESPIPE } 238 | -- | no such process 239 | pattern UV_ESRCH :: CInt 240 | pattern UV_ESRCH = #{const UV_ESRCH } 241 | -- | connection timed out 242 | pattern UV_ETIMEDOUT :: CInt 243 | pattern UV_ETIMEDOUT = #{const UV_ETIMEDOUT } 244 | -- | text file is busy 245 | pattern UV_ETXTBSY :: CInt 246 | pattern UV_ETXTBSY = #{const UV_ETXTBSY } 247 | -- | cross-device link not permitted 248 | pattern UV_EXDEV :: CInt 249 | pattern UV_EXDEV = #{const UV_EXDEV } 250 | -- | unknown error 251 | pattern UV_UNKNOWN :: CInt 252 | pattern UV_UNKNOWN = #{const UV_UNKNOWN } 253 | -- | end of file 254 | pattern UV_EOF :: CInt 255 | pattern UV_EOF = #{const UV_EOF } 256 | -- | no such device or address 257 | pattern UV_ENXIO :: CInt 258 | pattern UV_ENXIO = #{const UV_ENXIO } 259 | -- | too many links 260 | pattern UV_EMLINK :: CInt 261 | pattern UV_EMLINK = #{const UV_EMLINK } 262 | -------------------------------------------------------------------------------- /Z/IO/UV/UVStream.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Z.IO.UV.UVStream 3 | Description : IO manager based on libuv 4 | Copyright : (c) Dong Han, 2017-2018 5 | License : BSD 6 | Maintainer : winterland1989@gmail.com 7 | Stability : experimental 8 | Portability : non-portable 9 | 10 | This module provides 'UVStream' handle type. 11 | 12 | -} 13 | 14 | module Z.IO.UV.UVStream 15 | ( -- * uv_stream abstraction 16 | initUVStream 17 | , UVStream(..) 18 | , getUVStreamFD 19 | , closeUVStream 20 | , shutdownUVStream 21 | , helloWorld, echo 22 | ) where 23 | 24 | import Control.Concurrent 25 | import Control.Monad 26 | import qualified Z.Data.Text.Print as T 27 | import Z.IO.UV.Errno 28 | import Z.IO.UV.FFI 29 | import Z.IO.UV.Manager 30 | import Z.IO.Buffered 31 | import Z.IO.Exception 32 | import Z.IO.Resource 33 | import Data.IORef 34 | import GHC.Ptr 35 | 36 | -------------------------------------------------------------------------------- 37 | -- UVStream 38 | 39 | -- | A haskell data type wrap an @uv_stream_t@ inside 40 | -- 41 | -- 'UVStream' DO NOT provide thread safety! Use 'UVStream' concurrently in multiple 42 | -- threads will lead to undefined behavior. 43 | data UVStream = UVStream 44 | { uvsHandle :: {-# UNPACK #-} !(Ptr UVHandle) 45 | , uvsSlot :: {-# UNPACK #-} !UVSlot 46 | , uvsManager :: UVManager 47 | , uvsClosed :: {-# UNPACK #-} !(IORef Bool) -- We have no thread-safe guarantee, 48 | -- so no need to use atomic read&write 49 | } 50 | 51 | instance Show UVStream where show = T.toString 52 | 53 | instance T.Print UVStream where 54 | {-# INLINABLE toUTF8BuilderP #-} 55 | toUTF8BuilderP _ (UVStream hdl slot uvm _) = do 56 | "UVStream{uvsHandle=" >> T.toUTF8Builder hdl 57 | ",uvsSlot=" >> T.toUTF8Builder slot 58 | ",uvsManager=" >> T.toUTF8Builder uvm 59 | T.char7 '}' 60 | 61 | -- | Safely lock an uv manager and perform uv_handle initialization. 62 | -- 63 | -- Initialization an UV stream usually take two step: 64 | -- 65 | -- * allocate an uv_stream struct with proper size 66 | -- * lock a particular uv_loop from a uv manager, and perform custom initialization, such as @uv_tcp_init@. 67 | -- 68 | -- And this is what 'initUVStream' do, all you need to do is to provide the manager you want to hook the handle 69 | -- onto(usually the one on the same capability, i.e. the one obtained by 'getUVManager'), 70 | -- and provide a custom initialization function (which should throw an exception if failed). 71 | -- 72 | initUVStream :: HasCallStack 73 | => (Ptr UVLoop -> Ptr UVHandle -> IO ()) 74 | -> UVManager 75 | -> Resource UVStream 76 | {-# INLINABLE initUVStream #-} 77 | initUVStream f uvm = initResource 78 | (withUVManager uvm $ \ loop -> do 79 | hdl <- hs_uv_handle_alloc loop 80 | slot <- getUVSlot uvm (peekUVHandleData hdl) 81 | _ <- tryTakeMVar =<< getBlockMVar uvm slot -- clear the parking spot 82 | -- this function should be run inside mask, no need to protect 83 | f loop hdl -- `onException` hs_uv_handle_free hdl 84 | closed <- newIORef False 85 | return (UVStream hdl slot uvm closed)) 86 | closeUVStream 87 | 88 | -- | Manually close a uv stream. 89 | closeUVStream :: UVStream -> IO () 90 | {-# INLINABLE closeUVStream #-} 91 | closeUVStream (UVStream hdl _ uvm closed) = withUVManager' uvm $ do 92 | c <- readIORef closed 93 | -- hs_uv_handle_close won't return error 94 | unless c $ writeIORef closed True >> hs_uv_handle_close hdl 95 | 96 | -- | Shutdown the outgoing (write) side of a duplex stream. It waits for pending write requests to complete. 97 | -- 98 | -- Futher writing will throw 'ResourceVanished'(EPIPE). 99 | shutdownUVStream :: HasCallStack => UVStream -> IO () 100 | {-# INLINABLE shutdownUVStream #-} 101 | shutdownUVStream (UVStream hdl _ uvm closed) = do 102 | c <- readIORef closed 103 | when c throwECLOSED 104 | m <- withUVManager' uvm $ do 105 | reqSlot <- getUVSlot uvm (hs_uv_shutdown hdl) 106 | m <- getBlockMVar uvm reqSlot 107 | _ <- tryTakeMVar m 108 | return m 109 | throwUVIfMinus_ (uninterruptibleMask_ $ takeMVar m) 110 | 111 | -- | Get stream fd 112 | getUVStreamFD :: HasCallStack => UVStream -> IO FD 113 | {-# INLINABLE getUVStreamFD #-} 114 | getUVStreamFD (UVStream hdl _ _ closed) = do 115 | c <- readIORef closed 116 | when c throwECLOSED 117 | throwUVIfMinus (hs_uv_fileno hdl) 118 | 119 | instance Input UVStream where 120 | -- readInput :: HasCallStack => UVStream -> Ptr Word8 -> Int -> IO Int 121 | {-# INLINABLE readInput #-} 122 | readInput (UVStream hdl slot uvm closed) buf len = mask_ $ do 123 | c <- readIORef closed 124 | when c throwECLOSED 125 | -- set up buffer 126 | pokeBufferTable uvm slot buf len 127 | m <- getBlockMVar uvm slot 128 | -- clean up 129 | _ <- tryTakeMVar m 130 | 131 | throwUVIfMinus_ $ withUVManager' uvm (hs_uv_read_start hdl) 132 | -- since we are inside mask, this is the only place 133 | -- async exceptions could possibly kick in, and we should stop reading 134 | r <- takeMVar m `onException` (do 135 | -- normally we call 'uv_read_stop' in C read callback 136 | -- but when exception raise, here's the place to stop 137 | -- stop a handle twice will be a libuv error, so we don't check result 138 | _ <- withUVManager' uvm (uv_read_stop hdl) 139 | void (tryTakeMVar m)) 140 | 141 | if | r > 0 -> return r 142 | | r == fromIntegral UV_EOF -> return 0 143 | | r < 0 -> throwUVIfMinus (return r) 144 | -- r == 0 should be impossible, since we guard this situation in c side 145 | | otherwise -> throwUVError UV_UNKNOWN IOEInfo{ 146 | ioeName = "UVStream read error" 147 | , ioeDescription = "UVStream read should never return 0 before EOF" 148 | , ioeCallStack = callStack 149 | } 150 | 151 | instance Output UVStream where 152 | -- writeOutput :: HasCallStack => UVStream -> Ptr Word8 -> Int -> IO () 153 | {-# INLINABLE writeOutput #-} 154 | writeOutput (UVStream hdl _ uvm closed) buf len = mask_ $ do 155 | c <- readIORef closed 156 | when c throwECLOSED 157 | -- attempt blocking write first 158 | r <- hs_uv_try_write hdl buf len 159 | if | r == len -> return () 160 | | r < 0 && r /= fromIntegral UV_EAGAIN -> throwUV r 161 | | otherwise -> do 162 | m <- withUVManager' uvm $ do 163 | reqSlot <- if r > 0 164 | then getUVSlot uvm (hs_uv_write hdl (buf `plusPtr` r) (len - r)) 165 | else getUVSlot uvm (hs_uv_write hdl buf len) 166 | m <- getBlockMVar uvm reqSlot 167 | _ <- tryTakeMVar m 168 | return m 169 | -- we can't cancel uv_write_t with current libuv, 170 | -- otherwise disaster will happen if buffer got collected. 171 | -- so we have to turn to uninterruptibleMask_'s help. 172 | -- i.e. writing UVStream is an uninterruptible operation. 173 | -- OS will guarantee writing TTY and socket will not 174 | -- hang forever anyway. 175 | throwUVIfMinus_ (uninterruptibleMask_ $ takeMVar m) 176 | 177 | -------------------------------------------------------------------------------- 178 | 179 | -- | Write "hello world" to a 'UVStream'. 180 | helloWorld :: UVStream -> IO () 181 | {-# INLINABLE helloWorld #-} 182 | helloWorld uvs = writeOutput uvs (Ptr "hello world"#) 11 183 | 184 | -- | Echo whatever received bytes. 185 | echo :: UVStream -> IO () 186 | {-# INLINABLE echo #-} 187 | echo uvs = do 188 | i <- newBufferedInput uvs 189 | o <- newBufferedOutput uvs 190 | forever $ readBuffer i >>= writeBuffer o >> flushBuffer o 191 | -------------------------------------------------------------------------------- /Z/IO/UV/Win.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Z.IO.UV.Win 3 | Description : Special code on windows 4 | Copyright : (c) Winterland, 2017-2018 5 | License : BSD 6 | Maintainer : winterland1989@gmail.com 7 | Stability : experimental 8 | Portability : non-portable 9 | -} 10 | module Z.IO.UV.Win where 11 | 12 | #if defined(mingw32_HOST_OS) 13 | import System.IO.Unsafe 14 | import Control.Exception 15 | #endif 16 | 17 | -- | 'withUVInitDo' is necessary for some socket code because on windows WSAStartup has to be called 18 | -- before use sockets. 19 | -- 20 | -- This functions will run 'uv__once_init' once if not run before, 21 | -- 22 | withUVInitDo :: IO a -> IO a 23 | {-# INLINABLE withUVInitDo #-} 24 | 25 | #if defined(mingw32_HOST_OS) 26 | 27 | withUVInitDo act = evaluate withUVInit >> act 28 | 29 | {-# NOINLINE withUVInit #-} 30 | withUVInit :: () 31 | -- Use a CAF to make forcing it do initialisation once, but subsequent forces will be cheap 32 | withUVInit = unsafePerformIO $ uv__once_init 33 | 34 | foreign import ccall unsafe "uv__once_init" uv__once_init :: IO () 35 | #else 36 | 37 | withUVInitDo x = x 38 | #endif 39 | -------------------------------------------------------------------------------- /bench/GetTime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | {-| gettimeofday bench 5 | 6 | This benchmark confirms an unneglectable overhead in common FFI bindings: the 7 | overhead of doing pinned allocation. 8 | 9 | Theoretically things will get worse under high concurrent load since pinned 10 | allocation sometime requires lock GHC's sm. 11 | -} 12 | import Criterion.Main (Benchmark, bench, bgroup, defaultMain, 13 | nfIO) 14 | 15 | import qualified Data.Time.Clock.System as T 16 | import qualified Z.IO.Time as Z 17 | 18 | main :: IO () 19 | main = do 20 | defaultMain 21 | [ bgroup "Z-IO" 22 | [ bench "gettimeofday-z" $ nfIO Z.getSystemTime' 23 | , bench "gettimeofday-time" $ nfIO T.getSystemTime 24 | ] 25 | ] 26 | -------------------------------------------------------------------------------- /bench/Http.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | {-| HTTP benchmark test 5 | 6 | This program read HTTP request(without parsing), and send some respond. You can 7 | use HTTP benchmark tools such as ab or wrk to test IO throughput, remember to 8 | add a proper heap size to improve performance (-Hx parammeter): 9 | 10 | ulimit -n 10000 11 | http-bench +RTS -H512M 12 | wrk -c5000 http://localhost:8888 13 | 14 | -} 15 | 16 | module Main where 17 | 18 | import Control.Monad 19 | import Foreign.ForeignPtr 20 | import qualified Z.Data.Vector as V 21 | import qualified Z.Foreign as FFI 22 | import Z.IO 23 | import Z.IO.Network 24 | 25 | main :: IO () 26 | main = startTCPServer defaultTCPServerConfig $ \ uvs -> do 27 | recvbuf <- mallocForeignPtrBytes 2048 28 | sendcontent' <- FFI.pinPrimVector sendcontent 29 | catch (echo uvs recvbuf sendcontent') (\ (e::SomeException) -> return ()) 30 | where 31 | echo uvs recvbuf sendcontent' = loop 32 | where 33 | loop = do 34 | r <- withForeignPtr recvbuf $ \ p -> do 35 | readInput uvs p 2048 36 | when (r /= 0) $ do 37 | FFI.withPrimVectorSafe sendcontent' $ writeOutput uvs 38 | loop 39 | 40 | sendcontent :: V.Bytes 41 | sendcontent = 42 | "HTTP/1.1 200 OK\r\n\ 43 | \Content-Type: text/html; charset=UTF-8\r\n\ 44 | \Content-Length: 500\r\n\ 45 | \Connection: Keep-Alive\r\n\ 46 | \\r\n" `V.append` (V.pack $ replicate 500 48) 47 | -------------------------------------------------------------------------------- /cbits/hs_cwalk.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2020 Dong Han 3 | * 4 | * 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 8 | * are met: 9 | * 1. Redistributions of source code must retain the above copyright 10 | * notice, this list of conditions and the following disclaimer. 11 | * 2. Redistributions in binary form must reproduce the above copyright 12 | * notice, this list of conditions and the following disclaimer in the 13 | * documentation and/or other materials provided with the distribution. 14 | * 3. Neither the names of the authors or the names of any contributors 15 | * may be used to endorse or promote products derived from this software 16 | * without specific prior written permission. 17 | * 18 | * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 19 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 22 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 24 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 25 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 26 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 27 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 28 | * SUCH DAMAGE. 29 | */ 30 | 31 | #include 32 | #include 33 | 34 | HsInt hs_cwk_path_get_basename(const char *path, HsInt *base_off){ 35 | size_t length; 36 | const char *basename = NULL; 37 | cwk_path_get_basename(path, &basename, &length); 38 | if (basename == NULL) { 39 | *base_off = 0; 40 | return 0; 41 | } else { 42 | *base_off = (HsInt)(basename - path); 43 | return (HsInt)length; 44 | } 45 | } 46 | 47 | HsInt hs_cwk_path_get_dirname(const char *path){ 48 | size_t length; 49 | cwk_path_get_dirname(path, &length); 50 | return (HsInt)length; 51 | } 52 | 53 | HsInt hs_cwk_path_get_root(const char *path){ 54 | size_t length; 55 | cwk_path_get_root(path, &length); 56 | return (HsInt)length; 57 | } 58 | 59 | #if __GLASGOW_HASKELL__ < 810 60 | HsInt hs_cwk_path_join_multiple(const StgMutArrPtrs *paths_arr, HsInt path_n, char *buffer, size_t buffer_size){ 61 | StgArrBytes **paths = (StgArrBytes**)paths_arr->payload; 62 | #else 63 | HsInt hs_cwk_path_join_multiple(const StgArrBytes **paths, HsInt path_n, char *buffer, size_t buffer_size){ 64 | #endif 65 | HsInt r; 66 | const char **path_list = (const char**)malloc(sizeof(char*)*(path_n+1)); 67 | if (path_list == NULL) { 68 | *buffer = 0; 69 | return 0; 70 | } 71 | path_list[path_n--] = NULL; 72 | while(path_n >= 0){ 73 | path_list[path_n] = (char*)paths[path_n]->payload; 74 | path_n--; 75 | } 76 | r = (HsInt)cwk_path_join_multiple(path_list, buffer, buffer_size); 77 | free(path_list); 78 | return r; 79 | } 80 | 81 | HsInt hs_cwk_path_get_extension(const char *path, size_t *length){ 82 | const char *extension; 83 | if (cwk_path_get_extension(path, &extension, length)){ 84 | return (extension - path); 85 | } else { 86 | return -1; 87 | } 88 | } 89 | -------------------------------------------------------------------------------- /cbits/hs_uv_dns.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2020-2020 Dong Han 3 | * 4 | * 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 8 | * are met: 9 | * 1. Redistributions of source code must retain the above copyright 10 | * notice, this list of conditions and the following disclaimer. 11 | * 2. Redistributions in binary form must reproduce the above copyright 12 | * notice, this list of conditions and the following disclaimer in the 13 | * documentation and/or other materials provided with the distribution. 14 | * 3. Neither the names of the authors or the names of any contributors 15 | * may be used to endorse or promote products derived from this software 16 | * without specific prior written permission. 17 | * 18 | * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 19 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 22 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 24 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 25 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 26 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 27 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 28 | * SUCH DAMAGE. 29 | */ 30 | 31 | #include 32 | 33 | HsInt hs_getaddrinfo(const char *node, const char *service, 34 | const struct addrinfo *hints, 35 | struct addrinfo **res){ 36 | int err; 37 | err = getaddrinfo(node, service, hints, res); 38 | 39 | return (HsInt)uv__getaddrinfo_translate_error(err); 40 | } 41 | 42 | HsInt hs_getnameinfo(const struct sockaddr *addr, socklen_t addrlen, 43 | char *host, socklen_t hostlen, 44 | char *serv, socklen_t servlen, int flags){ 45 | int err; 46 | err = getnameinfo(addr, addrlen, host, hostlen, serv, servlen, flags); 47 | return (HsInt)uv__getaddrinfo_translate_error(err); 48 | } 49 | -------------------------------------------------------------------------------- /cbits/hs_uv_fs_event.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2020 Dong Han 3 | * 4 | * 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 8 | * are met: 9 | * 1. Redistributions of source code must retain the above copyright 10 | * notice, this list of conditions and the following disclaimer. 11 | * 2. Redistributions in binary form must reproduce the above copyright 12 | * notice, this list of conditions and the following disclaimer in the 13 | * documentation and/or other materials provided with the distribution. 14 | * 3. Neither the names of the authors or the names of any contributors 15 | * may be used to endorse or promote products derived from this software 16 | * without specific prior written permission. 17 | * 18 | * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 19 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 22 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 24 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 25 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 26 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 27 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 28 | * SUCH DAMAGE. 29 | */ 30 | 31 | #include 32 | #include 33 | 34 | void hs_fs_event_cb(uv_fs_event_t* handle, const char* filename, int events, int status){ 35 | if (status < 0) return; 36 | HsInt slot = (HsInt)handle->data; 37 | hs_loop_data* loop_data = handle->loop->data; 38 | 39 | // OSX fsevent backend filename could be NULL 40 | if (filename == NULL){ 41 | if (loop_data->buffer_size_table[slot] >= 2){ 42 | loop_data->buffer_size_table[slot] -= 2; 43 | char* buf = loop_data->buffer_table[slot] + loop_data->buffer_size_table[slot]; 44 | *buf = (uint8_t)events; 45 | // empty filename will be filtered on Haskell side 46 | *(buf+1) = 0; 47 | } 48 | } else { 49 | size_t l = strlen(filename) + 2; // including the \NUL and event byte 50 | // we simply ignore more events if buffer can't hold it 51 | // libuv use a buffer size 4096, so on haskell side anything > 4096 should work 52 | if (loop_data->buffer_size_table[slot] >= l){ 53 | loop_data->buffer_size_table[slot] -= l; 54 | char* buf = loop_data->buffer_table[slot] + loop_data->buffer_size_table[slot]; 55 | *buf = (uint8_t)events; 56 | memcpy(buf+1, filename, l-1); 57 | } 58 | } 59 | } 60 | 61 | int hs_uv_fs_event_start(uv_fs_event_t* handle, const char* path, unsigned int flags){ 62 | return uv_fs_event_start(handle, hs_fs_event_cb, path, flags); 63 | } 64 | 65 | // Check if the fs event buffer is filled with messages, if so, unlock the fs event thread 66 | // 67 | void hs_fs_event_check_cb(uv_check_t* check){ 68 | uv_fs_event_t* f =(uv_fs_event_t*)check->data; 69 | HsInt slot = (HsInt)f->data; 70 | hs_loop_data* loop_data = f->loop->data; 71 | size_t buffer_index = loop_data->buffer_size_table[slot]; 72 | // This relys on GHC ByteArray# memory layout, ByteArray# length is recorded before content. 73 | HsInt* buffer_ptr = (HsInt*)loop_data->buffer_table[slot]; 74 | HsInt buffer_total_len = *(buffer_ptr-1); 75 | if (buffer_index < buffer_total_len ) { 76 | loop_data->event_queue[loop_data->event_counter] = slot; // push the slot to event queue 77 | loop_data->event_counter += 1; 78 | } 79 | } 80 | 81 | int hs_uv_fs_event_check_start(uv_check_t* check){ 82 | return uv_check_start(check, hs_fs_event_check_cb); 83 | } 84 | -------------------------------------------------------------------------------- /cbits/hs_uv_process.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2017-2019 Dong Han 3 | * 4 | * 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 8 | * are met: 9 | * 1. Redistributions of source code must retain the above copyright 10 | * notice, this list of conditions and the following disclaimer. 11 | * 2. Redistributions in binary form must reproduce the above copyright 12 | * notice, this list of conditions and the following disclaimer in the 13 | * documentation and/or other materials provided with the distribution. 14 | * 3. Neither the names of the authors or the names of any contributors 15 | * may be used to endorse or promote products derived from this software 16 | * without specific prior written permission. 17 | * 18 | * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 19 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 22 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 24 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 25 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 26 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 27 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 28 | * SUCH DAMAGE. 29 | */ 30 | 31 | #include 32 | #include 33 | 34 | //////////////////////////////////////////////////////////////////////////////// 35 | // 36 | // process 37 | 38 | 39 | void hs_uv_exit_cb(uv_process_t* handle, int64_t exit_status, int term_signal){ 40 | HsInt slot = (HsInt)handle->data; 41 | uv_loop_t* loop = handle->loop; 42 | hs_loop_data* loop_data = loop->data; 43 | loop_data->buffer_size_table[slot] = (HsInt)exit_status; 44 | loop_data->event_queue[loop_data->event_counter] = slot; // push the slot to event queue 45 | loop_data->event_counter += 1; 46 | free_slot(loop_data, slot); // free the uv_process_t 47 | } 48 | 49 | HsInt hs_uv_spawn(uv_loop_t* loop 50 | , uv_process_options_t* options 51 | , const char* file 52 | #if __GLASGOW_HASKELL__ < 810 53 | , const StgMutArrPtrs* all_args_arr 54 | , const HsInt args_len 55 | , const StgMutArrPtrs* all_env_arr 56 | , const HsInt env_len 57 | #else 58 | , const StgArrBytes** all_args 59 | , const HsInt args_len 60 | , const StgArrBytes** all_env 61 | , const HsInt env_len 62 | #endif 63 | , const char* cwd 64 | , uv_stdio_container_t* container){ 65 | #if __GLASGOW_HASKELL__ < 810 66 | StgArrBytes **all_args = (StgArrBytes**)all_args_arr->payload; 67 | StgArrBytes **all_env = (StgArrBytes**)all_env_arr->payload; 68 | #endif 69 | int r; 70 | HsInt i; 71 | char **args = NULL, **env = NULL; 72 | 73 | hs_loop_data* loop_data = loop->data; 74 | HsInt slot = alloc_slot(loop_data); 75 | if (slot < 0) return UV_ENOMEM; 76 | uv_process_t* handle = 77 | (uv_process_t*)fetch_uv_struct(loop_data, slot); 78 | handle->data = (void*)slot; 79 | 80 | options->exit_cb = hs_uv_exit_cb; 81 | options->file = file; 82 | 83 | i = 0; 84 | args = (char**)malloc(sizeof(char*)*(args_len + 2)); 85 | if (args == NULL) return UV_ENOMEM; 86 | args[i++] = (char*)file; 87 | while(i <= args_len) { 88 | args[i] = (char*)all_args[i-1]->payload; 89 | i++; 90 | } 91 | args[i] = NULL; 92 | options->args = args; 93 | 94 | i = 0; 95 | // env_len == -1 for inherit from parent 96 | if (env_len >= 0){ 97 | env = (char**)malloc(sizeof(char*)*(env_len+1)); 98 | if (env == NULL) return UV_ENOMEM; 99 | while(i < env_len) { 100 | env[i] = (char*)all_env[i]->payload; 101 | i++; 102 | } 103 | env[i] = NULL; 104 | } 105 | options->env = env; 106 | 107 | options->stdio_count = 3; 108 | options->stdio = container; 109 | options->cwd = cwd; 110 | 111 | r = uv_spawn(loop, handle, options); 112 | 113 | free(args); 114 | if (env != NULL) free(env); 115 | 116 | if (r < 0) { 117 | free_slot(loop_data, slot); // free the uv_process_t, the callback won't fired 118 | return (HsInt)r; 119 | } else { 120 | loop_data->buffer_size_table[slot] = (HsInt)handle->pid; 121 | return slot; 122 | } 123 | } 124 | -------------------------------------------------------------------------------- /cbits/hs_uv_udp.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2017-2019 Dong Han 3 | * 4 | * 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 8 | * are met: 9 | * 1. Redistributions of source code must retain the above copyright 10 | * notice, this list of conditions and the following disclaimer. 11 | * 2. Redistributions in binary form must reproduce the above copyright 12 | * notice, this list of conditions and the following disclaimer in the 13 | * documentation and/or other materials provided with the distribution. 14 | * 3. Neither the names of the authors or the names of any contributors 15 | * may be used to endorse or promote products derived from this software 16 | * without specific prior written permission. 17 | * 18 | * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 19 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 22 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 24 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 25 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 26 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 27 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 28 | * SUCH DAMAGE. 29 | */ 30 | 31 | #include 32 | 33 | //////////////////////////////////////////////////////////////////////////////// 34 | // 35 | // udp 36 | 37 | // We do batch read per uv_run, the buffer index keep decreasing until hit zero 38 | void hs_udp_alloc_cb(uv_handle_t* handle, size_t suggested_size, uv_buf_t* buf){ 39 | HsInt slot = (HsInt)handle->data; 40 | hs_loop_data* loop_data = handle->loop->data; 41 | // fetch buffer_table from buffer_table table 42 | // the first 12 + 128 bytes is reserved for sockaddr and flag 43 | char** buffer_array = (char**)loop_data->buffer_table[slot]; 44 | ssize_t buffer_index = loop_data->buffer_size_table[slot]; 45 | if (buffer_index < 0) { 46 | //will be called in hs_udp_check_cb 47 | //uv_udp_recv_stop((uv_udp_t*)handle); 48 | buf->base = NULL; 49 | buf->len = 0; 50 | } else { 51 | buf->base = (char*)buffer_array[buffer_index] + 140; 52 | buf->len = *((int32_t*)buffer_array[buffer_index]); 53 | } 54 | } 55 | 56 | void hs_udp_recv_cb (uv_udp_t* udp, ssize_t nread, const uv_buf_t* _buf 57 | , const struct sockaddr* addr, unsigned flags){ 58 | if (nread ==0 && addr == NULL) return; 59 | HsInt slot = (HsInt)udp->data; 60 | hs_loop_data* loop_data = udp->loop->data; 61 | 62 | // no bufs are available 63 | if (_buf->base == NULL) return; 64 | // EAGAIN, EWOULDBLOCK 65 | if (addr == NULL && nread == 0) return; 66 | 67 | // move buffer_index 68 | (loop_data->buffer_size_table[slot])--; 69 | 70 | char* buf = (char*)(_buf->base)-140; 71 | struct sockaddr* addr_buf = (struct sockaddr*)(buf+12); 72 | // result 73 | *(int32_t*)buf = (int32_t)nread; 74 | // flag 75 | *(int32_t*)(buf+4) = (int32_t)flags; 76 | 77 | if (addr == NULL) { 78 | // set sockaddr flag 79 | *(int32_t*)(buf+8) = 0; 80 | } else { 81 | // set sockaddr flag 82 | *(int32_t*)(buf+8) = 1; 83 | // copy sockaddr 84 | if (addr->sa_family == AF_INET){ 85 | memcpy(addr_buf, addr, sizeof(struct sockaddr_in)); 86 | } else if (addr->sa_family == AF_INET6){ 87 | memcpy(addr_buf, addr, sizeof(struct sockaddr_in6)); 88 | } else { 89 | memcpy(addr_buf, addr, sizeof(struct sockaddr)); 90 | } 91 | } 92 | } 93 | 94 | int hs_uv_udp_recv_start(uv_udp_t* handle){ 95 | return uv_udp_recv_start(handle, hs_udp_alloc_cb, hs_udp_recv_cb); 96 | } 97 | 98 | // Check if the socket's udp buffer is filled with messages, if so, unlock the udp thread 99 | // 100 | void hs_udp_check_cb(uv_check_t* check){ 101 | uv_udp_t* server=(uv_udp_t*)check->data; 102 | HsInt slot = (HsInt)server->data; 103 | hs_loop_data* loop_data = server->loop->data; 104 | ssize_t buffer_index = loop_data->buffer_size_table[slot]; 105 | // This relys on GHC ByteArray# memory layout, ByteArray# length is recorded before content. 106 | HsInt* buffer_ptr = (HsInt*)loop_data->buffer_table[slot]; 107 | HsInt buffer_total_len = *(buffer_ptr-1)/(sizeof(void*)); 108 | if (buffer_index < buffer_total_len -1 ) { 109 | // we stopped if we got some messages, will resume from haskell 110 | uv_udp_recv_stop(server); 111 | loop_data->event_queue[loop_data->event_counter] = slot; // push the slot to event queue 112 | loop_data->event_counter += 1; 113 | } 114 | } 115 | 116 | int hs_uv_udp_check_start(uv_check_t* check){ 117 | return uv_check_start(check, hs_udp_check_cb); 118 | } 119 | 120 | void hs_uv_udp_send_cb(uv_udp_send_t* req, int status){ 121 | HsInt slot = (HsInt)req->data; 122 | uv_loop_t* loop = req->handle->loop; 123 | hs_loop_data* loop_data = loop->data; 124 | loop_data->buffer_size_table[slot] = (HsInt)status; // 0 in case of success, < 0 otherwise. 125 | loop_data->event_queue[loop_data->event_counter] = slot; // push the slot to event queue 126 | loop_data->event_counter += 1; 127 | free_slot(loop_data, slot); // free the uv_req_t 128 | } 129 | 130 | HsInt hs_uv_udp_send(uv_udp_t* handle, const struct sockaddr* addr, char* buf, HsInt buf_siz){ 131 | uv_loop_t* loop = handle->loop; 132 | hs_loop_data* loop_data = loop->data; 133 | HsInt slot = alloc_slot(loop_data); 134 | if (slot < 0) return UV_ENOMEM; 135 | uv_udp_send_t* req = 136 | (uv_udp_send_t*)fetch_uv_struct(loop_data, slot); 137 | req->data = (void*)slot; 138 | 139 | // on windows this struct is captured by WSASend 140 | // on unix this struct is copied by libuv's uv_udp_send 141 | // so it's safe to allocate it on stack 142 | uv_buf_t buf_t = { .base = buf, .len = (size_t)buf_siz }; 143 | 144 | int r = uv_udp_send(req, handle, &buf_t, 1, addr, hs_uv_udp_send_cb); 145 | // we never use writev: we do our own 146 | // user-space buffering in haskell. 147 | if (r < 0) { 148 | free_slot(loop_data, slot); // free the uv_req_t, the callback won't fired 149 | return (HsInt)r; 150 | } else return slot; 151 | 152 | } 153 | 154 | HsInt hs_uv_udp_send_connected(uv_udp_t* handle, char* buf, HsInt buf_siz){ 155 | return hs_uv_udp_send(handle, NULL, buf, buf_siz); 156 | } 157 | 158 | -------------------------------------------------------------------------------- /cbits/hs_zlib.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2020 Dong Han 3 | * 4 | * 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 8 | * are met: 9 | * 1. Redistributions of source code must retain the above copyright 10 | * notice, this list of conditions and the following disclaimer. 11 | * 2. Redistributions in binary form must reproduce the above copyright 12 | * notice, this list of conditions and the following disclaimer in the 13 | * documentation and/or other materials provided with the distribution. 14 | * 3. Neither the names of the authors or the names of any contributors 15 | * may be used to endorse or promote products derived from this software 16 | * without specific prior written permission. 17 | * 18 | * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 19 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 22 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 24 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 25 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 26 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 27 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 28 | * SUCH DAMAGE. 29 | */ 30 | 31 | #include 32 | #include 33 | #include 34 | 35 | z_stream* create_z_stream(){ 36 | z_stream* stream = malloc(sizeof(z_stream)); 37 | if (stream) { 38 | stream->zalloc = Z_NULL; 39 | stream->zfree = Z_NULL; 40 | stream->opaque = Z_NULL; 41 | stream->next_in = NULL; 42 | stream->avail_in = 0; 43 | stream->next_out = NULL; 44 | stream->avail_out = 0; 45 | } 46 | return stream; 47 | } 48 | 49 | int deflate_init2(z_stream *stream, int level, int methodBits, int memlevel, int strategy) 50 | { 51 | return deflateInit2(stream, level, Z_DEFLATED, methodBits, memlevel, strategy); 52 | } 53 | 54 | void free_z_stream_deflate (z_stream *stream) 55 | { 56 | deflateEnd(stream); 57 | free(stream); 58 | } 59 | 60 | int inflate_init2(z_stream *stream, int methodBits) 61 | { 62 | return inflateInit2(stream, methodBits); 63 | } 64 | 65 | void free_z_stream_inflate (z_stream *stream) 66 | { 67 | inflateEnd(stream); 68 | free(stream); 69 | } 70 | 71 | unsigned int deflate_set_dictionary (z_stream* stream, const unsigned char* dict, HsInt off, HsInt len){ 72 | return deflateSetDictionary(stream, dict+off, (unsigned int)len); 73 | } 74 | 75 | unsigned int inflate_set_dictionary (z_stream* stream, const unsigned char* dict, HsInt off, HsInt len){ 76 | return inflateSetDictionary(stream, dict+off, (unsigned int)len); 77 | } 78 | -------------------------------------------------------------------------------- /include/fs_shared.hs: -------------------------------------------------------------------------------- 1 | -- This file should be included from both base and threaded FS module 2 | 3 | -- | File bundled with offset. 4 | -- 5 | -- Reading or writing using 'Input' \/ 'Output' instance will automatically increase offset. 6 | -- 'FilePtr' and its operations are NOT thread safe, use 'MVar' 'FilePtr' in multiple threads. 7 | -- 8 | -- The notes on linux 'writeFileP' applied to 'FilePtr' too. 9 | data FilePtr = FilePtr {-# UNPACK #-} !File 10 | {-# UNPACK #-} !(PrimRef RealWorld Int64) 11 | 12 | -- | Create a file offset bundle from an 'File'. 13 | -- 14 | newFilePtr :: File -- ^ the file we're reading 15 | -> Int64 -- ^ initial offset 16 | -> IO FilePtr 17 | {-# INLINABLE newFilePtr #-} 18 | newFilePtr uvf off = FilePtr uvf <$> newPrimRef off 19 | 20 | -- | Get current offset. 21 | getFilePtrOffset :: FilePtr -> IO Int64 22 | {-# INLINABLE getFilePtrOffset #-} 23 | getFilePtrOffset (FilePtr _ offsetRef) = readPrimRef offsetRef 24 | 25 | -- | Change current offset. 26 | setFilePtrOffset :: FilePtr -> Int64 -> IO () 27 | {-# INLINABLE setFilePtrOffset #-} 28 | setFilePtrOffset (FilePtr _ offsetRef) = writePrimRef offsetRef 29 | 30 | instance Input FilePtr where 31 | {-# INLINABLE readInput #-} 32 | readInput (FilePtr file offsetRef) buf bufSiz = 33 | readPrimRef offsetRef >>= \ off -> do 34 | l <- readFileP file buf bufSiz off 35 | writePrimRef offsetRef (off + fromIntegral l) 36 | return l 37 | 38 | instance Output FilePtr where 39 | {-# INLINABLE writeOutput #-} 40 | writeOutput (FilePtr file offsetRef) buf bufSiz = 41 | readPrimRef offsetRef >>= \ off -> do 42 | writeFileP file buf bufSiz off 43 | writePrimRef offsetRef (off + fromIntegral bufSiz) 44 | 45 | -- | Quickly open a file and read its content. 46 | readFile :: HasCallStack => CBytes -> IO V.Bytes 47 | {-# INLINABLE readFile #-} 48 | readFile filename = do 49 | withResource (initFile filename O_RDONLY DEFAULT_FILE_MODE) $ \ file -> do 50 | readAll' =<< newBufferedInput file 51 | 52 | -- | Quickly open a file and read its content as UTF8 text. 53 | readTextFile :: HasCallStack => CBytes -> IO T.Text 54 | {-# INLINABLE readTextFile #-} 55 | readTextFile filename = T.validate <$> readFile filename 56 | 57 | -- | Quickly open a file and write some content. 58 | writeFile :: HasCallStack => CBytes -> V.Bytes -> IO () 59 | {-# INLINABLE writeFile #-} 60 | writeFile filename content = do 61 | withResource (initFile filename (O_WRONLY .|. O_CREAT) DEFAULT_FILE_MODE) $ \ file -> do 62 | withPrimVectorSafe content (writeOutput file) 63 | 64 | -- | Quickly open a file and write some content as UTF8 text. 65 | writeTextFile :: HasCallStack => CBytes -> T.Text -> IO () 66 | {-# INLINABLE writeTextFile #-} 67 | writeTextFile filename content = writeFile filename (T.getUTF8Bytes content) 68 | 69 | -- | Quickly open a file and read its content as a JSON value. 70 | -- Throw 'OtherError' with name @EPARSE@ if JSON value is not parsed. 71 | readJSONFile :: (HasCallStack, JSON.JSON a) => CBytes -> IO a 72 | {-# INLINABLE readJSONFile #-} 73 | readJSONFile filename = unwrap "EPARSE" . JSON.decode' =<< readFile filename 74 | 75 | -- | Quickly open a file and write a JSON Value. 76 | writeJSONFile :: (HasCallStack, JSON.JSON a) => CBytes -> a -> IO () 77 | {-# INLINABLE writeJSONFile #-} 78 | writeJSONFile filename x = writeFile filename (JSON.encode x) 79 | 80 | -------------------------------------------------------------------------------- 81 | 82 | -- | Find all files and directories within a given directory with a predicator. 83 | -- 84 | -- @ 85 | -- import Z.IO.FileSystem.FilePath (splitExtension) 86 | -- -- find all haskell source file within current dir 87 | -- scandirRecursively "." (\\ p _ -> (== ".hs") . snd \<$\> splitExtension p) 88 | -- @ 89 | scandirRecursively :: HasCallStack => CBytes -> (CBytes -> DirEntType -> IO Bool) -> IO [CBytes] 90 | {-# INLINABLE scandirRecursively #-} 91 | scandirRecursively dir p = loop [] =<< P.normalize dir 92 | where 93 | loop acc0 pdir = 94 | foldM (\ acc (d,t) -> do 95 | d' <- pdir `P.join` d 96 | r <- p d' t 97 | let acc' = if r then (d':acc) else acc 98 | if (t == DirEntDir) 99 | then loop acc' d' 100 | else return acc' 101 | ) acc0 =<< scandir pdir 102 | 103 | -------------------------------------------------------------------------------- 104 | 105 | -- | Does given path exist? 106 | -- 107 | doesPathExist :: CBytes -> IO Bool 108 | {-# INLINABLE doesPathExist #-} 109 | doesPathExist path = maybe False (const True) <$> stat' path 110 | 111 | -- | Returns 'True' if the argument file exists and is either a file or a 112 | -- symbolic link to a file, and 'False' otherwise. 113 | doesFileExist :: CBytes -> IO Bool 114 | {-# INLINABLE doesFileExist #-} 115 | doesFileExist path = maybe False isFileSt <$> stat' path 116 | 117 | -- | Returns 'True' if the argument directory exists and is either a directory or a 118 | -- symbolic link to a directory, and 'False' otherwise. 119 | doesDirExist :: CBytes -> IO Bool 120 | {-# INLINABLE doesDirExist #-} 121 | doesDirExist path = maybe False isDirSt <$> stat' path 122 | 123 | -------------------------------------------------------------------------------- 124 | 125 | -- | If given path is a symbolic link? 126 | isLink :: HasCallStack => CBytes -> IO Bool 127 | {-# INLINABLE isLink #-} 128 | isLink = fmap isLinkSt . lstat 129 | 130 | -- | If given path is a directory or a symbolic link to a directory? 131 | isDir :: HasCallStack => CBytes -> IO Bool 132 | {-# INLINABLE isDir #-} 133 | isDir = fmap isDirSt . stat 134 | 135 | -- | If given path is a file or a symbolic link to a file? 136 | isFile :: HasCallStack => CBytes -> IO Bool 137 | {-# INLINABLE isFile #-} 138 | isFile = fmap isFileSt . stat 139 | 140 | -- | Shortcut to @\\ st -> stMode st .&. S_IFMT == S_IFLNK@ 141 | -- 142 | -- Note you should use 'lstat' to get the link's stat. 143 | isLinkSt :: FStat -> Bool 144 | {-# INLINABLE isLinkSt #-} 145 | isLinkSt st = stMode st .&. S_IFMT == S_IFLNK 146 | 147 | -- | Shortcut to @\\ st -> stMode st .&. S_IFMT == S_IFDIR@ 148 | isDirSt :: FStat -> Bool 149 | {-# INLINABLE isDirSt #-} 150 | isDirSt st = stMode st .&. S_IFMT == S_IFDIR 151 | 152 | -- | Shortcut to @\\ st -> stMode st .&. S_IFMT == S_IFREG@ 153 | isFileSt :: FStat -> Bool 154 | {-# INLINABLE isFileSt #-} 155 | isFileSt st = stMode st .&. S_IFMT == S_IFREG 156 | 157 | ------------------------------------------------------------------------------- 158 | 159 | -- | Make a temporary file under system 'Env.getTempDir' and automatically clean after used. 160 | -- 161 | -- This is a shortcut to 'mkstemp', the file name use @Z-IO-@ as prefix, and will be removed after use. 162 | -- 163 | -- >>> withResource initTempFile $ printStd 164 | -- ("/var/folders/3l/cfdy03vd1gvd1x75gg_js7280000gn/T/Z-IO-bYgZDX",File 13) 165 | -- 166 | initTempFile :: HasCallStack => Resource (CBytes, File) 167 | {-# INLINABLE initTempFile #-} 168 | initTempFile = do 169 | d <- liftIO $ Env.getTempDir 170 | mkstemp d "Z-IO-" False 171 | 172 | -- | Make a temporary directory under system 'Env.getTempDir' and automatically clean after used. 173 | -- 174 | -- This is a shortcut to 'mkdtemp', the directory name use @Z-IO-@ as prefix, and will be removed(with files within it) after use. 175 | -- 176 | -- >>> withResource initTempDir $ printStd 177 | -- "/tmp/Z-IO-xfWR0L" 178 | -- 179 | initTempDir :: HasCallStack => Resource CBytes 180 | {-# INLINABLE initTempDir #-} 181 | initTempDir = initResource (Env.getTempDir >>= (`P.join` "Z-IO-") >>= mkdtemp) rmrf 182 | -------------------------------------------------------------------------------- /include/hs_cwalk.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2017-2018 Dong Han 3 | * 4 | * 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 8 | * are met: 9 | * 1. Redistributions of source code must retain the above copyright 10 | * notice, this list of conditions and the following disclaimer. 11 | * 2. Redistributions in binary form must reproduce the above copyright 12 | * notice, this list of conditions and the following disclaimer in the 13 | * documentation and/or other materials provided with the distribution. 14 | * 3. Neither the names of the authors or the names of any contributors 15 | * may be used to endorse or promote products derived from this software 16 | * without specific prior written permission. 17 | * 18 | * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 19 | * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 22 | * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 24 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 25 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 26 | * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 27 | * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 28 | * SUCH DAMAGE. 29 | */ 30 | 31 | #include // for HsInt 32 | #include // for StgArrBytes 33 | #include 34 | 35 | HsInt hs_cwk_path_get_basename(const char *path, HsInt *base_off); 36 | HsInt hs_cwk_path_get_dirname(const char *path); 37 | HsInt hs_cwk_path_get_root(const char *path); 38 | #if __GLASGOW_HASKELL__ < 810 39 | HsInt hs_cwk_path_join_multiple(const StgMutArrPtrs *paths_arr, HsInt path_n, char *buffer, size_t buffer_size); 40 | #else 41 | HsInt hs_cwk_path_join_multiple(const StgArrBytes **paths, HsInt path_n, char *buffer, size_t buffer_size); 42 | #endif 43 | HsInt hs_cwk_path_get_extension(const char *path, size_t *length); 44 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | -- file test/Spec.hs 2 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 3 | -------------------------------------------------------------------------------- /test/Z/IO/BIO/BaseSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Z.IO.BIO.BaseSpec where 4 | 5 | import Control.Concurrent 6 | import Control.Monad 7 | import qualified Codec.Compression.Zlib as TheZlib 8 | import Data.IORef 9 | import qualified Z.Data.Vector as V 10 | import Z.IO.BIO.Zlib 11 | import Z.IO.BIO.Base 12 | import Z.IO 13 | import Test.QuickCheck 14 | import Test.QuickCheck.Function 15 | import Test.QuickCheck.Property 16 | import Test.Hspec 17 | import Test.Hspec.QuickCheck 18 | import Test.HUnit 19 | import System.IO.Unsafe 20 | 21 | 22 | spec :: Spec 23 | spec = describe "BIO" . modifyMaxSize (*10) $ do 24 | 25 | describe "decode . encode === id(Base64)" $ 26 | prop "Base64" $ \ xs -> 27 | let r = unsafePerformIO $ do 28 | let src = sourceFromList xs 29 | (rRef, sink) <- sinkToList 30 | enc <- newBase64Encoder 31 | dec <- newBase64Decoder 32 | run_ $ src . enc . dec . sink 33 | takeMVar rRef 34 | in V.concat r === V.concat xs 35 | 36 | describe "decode . encode === id(Hex)" $ do 37 | prop "Hex" $ \ xs upper -> 38 | let r = unsafePerformIO $ do 39 | let src = sourceFromList xs 40 | (rRef, sink) <- sinkToList 41 | dec <- newHexDecoder 42 | run_ $ src . hexEncode upper . dec . sink 43 | takeMVar rRef 44 | in V.concat r === V.concat xs 45 | 46 | -------------------------------------------------------------------------------- /test/Z/IO/BIO/ConcurrentSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Z.IO.BIO.ConcurrentSpec where 5 | 6 | import Control.Concurrent 7 | import Control.Monad 8 | import Control.Monad.IO.Class 9 | import Data.IORef 10 | import qualified Z.IO.BIO as BIO 11 | import Test.QuickCheck 12 | import Test.QuickCheck.Function 13 | import Test.QuickCheck.Property 14 | import Test.QuickCheck.Monadic as QM 15 | import Test.Hspec 16 | import Test.Hspec.QuickCheck 17 | import Test.HUnit 18 | import System.IO.Unsafe 19 | 20 | 21 | spec :: Spec 22 | spec = describe "BIO.Concurrent" $ do 23 | 24 | prop "zip works like zip on Sources" $ \ xs ys -> monadicIO $ do 25 | (zs :: [(Int, Int)]) <- liftIO . BIO.run $ BIO.zip (BIO.sourceFromList xs) (BIO.sourceFromList ys) 26 | QM.assert (zs == zip xs ys) 27 | 28 | it "TQueueNode works as expected" $ do 29 | let content = [1..1000] 30 | 31 | (sink, src) <- BIO.newTQueuePair 2 32 | sumRef <- newIORef 0 33 | 34 | let producter = do 35 | src' <- sourceListWithDelay content 36 | BIO.run_ (src' . sink) 37 | 38 | let consumer = do 39 | (rRef, sink') <- BIO.sinkToList 40 | BIO.run_ (src . sink') 41 | r <- takeMVar rRef 42 | atomicModifyIORef' sumRef $ \ x -> (x + sum r, ()) 43 | 44 | forkIO $ consumer 45 | forkIO $ consumer 46 | forkIO $ consumer 47 | forkIO $ producter 48 | forkIO $ producter 49 | 50 | threadDelay 10000000 51 | 52 | s <- readIORef sumRef 53 | s @?= (sum content * 2) 54 | 55 | it "TBQueueNode works as expected" $ do 56 | let content = [1..1000] 57 | 58 | (sink, src) <- BIO.newTBQueuePair 2 10 59 | sumRef <- newIORef 0 60 | 61 | let producter = do 62 | src' <- sourceListWithDelay content 63 | BIO.run_ (src' . sink) 64 | 65 | let consumer = do 66 | (rRef, sink') <- BIO.sinkToList 67 | BIO.run_ (src . sink') 68 | r <- takeMVar rRef 69 | atomicModifyIORef' sumRef $ \ x -> (x + sum r, ()) 70 | 71 | forkIO $ consumer 72 | forkIO $ consumer 73 | forkIO $ consumer 74 | forkIO $ producter 75 | forkIO $ producter 76 | 77 | threadDelay 10000000 78 | 79 | s <- readIORef sumRef 80 | s @?= (sum content * 2) 81 | 82 | it "TChanNode works as expected" $ do 83 | let content = [1..1000] 84 | 85 | (sink, srcf) <- BIO.newBroadcastTChanPair 2 86 | sumRef <- newIORef 0 87 | 88 | let producter = do 89 | src' <- sourceListWithDelay content 90 | BIO.run_ (src' . sink) 91 | 92 | let consumer = do 93 | (rRef, sink') <- BIO.sinkToList 94 | src <- srcf 95 | BIO.run_ (src . sink') 96 | r <- takeMVar rRef 97 | atomicModifyIORef' sumRef $ \ x -> (x + sum r, ()) 98 | 99 | forkIO $ consumer 100 | forkIO $ consumer 101 | forkIO $ consumer 102 | forkIO $ producter 103 | forkIO $ producter 104 | 105 | threadDelay 10000000 106 | 107 | s <- readIORef sumRef 108 | s @?= (sum content * 2 * 3) 109 | 110 | 111 | sourceListWithDelay :: [Int] -> IO (BIO.Source Int) 112 | sourceListWithDelay xs = do 113 | return $ \ k _ -> do 114 | forM_ xs $ \ x -> do 115 | threadDelay x 116 | k (Just x) 117 | k Nothing 118 | -------------------------------------------------------------------------------- /test/Z/IO/BIO/ZlibSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Z.IO.BIO.ZlibSpec where 4 | 5 | import Control.Monad 6 | import qualified Codec.Compression.Zlib as TheZlib 7 | import Data.IORef 8 | import Data.ByteString as B 9 | import Data.ByteString.Lazy as BL 10 | import Z.Data.Vector as V 11 | import Z.IO.BIO.Zlib 12 | import Z.IO.BIO 13 | import Z.IO 14 | import Test.QuickCheck 15 | import Test.QuickCheck.Function 16 | import Test.QuickCheck.Property 17 | import Test.Hspec 18 | import Test.Hspec.QuickCheck 19 | import Test.HUnit 20 | 21 | 22 | spec :: Spec 23 | spec = describe "zlib" $ do 24 | 25 | describe "decompress . compress === id" . modifyMaxSize (*10) $ do 26 | prop "decompress . compress === id" $ \ xs -> do 27 | decompress defaultDecompressConfig 28 | (compress defaultCompressConfig (V.pack xs)) === V.pack xs 29 | 30 | prop "decompress . compress === id(with dict)" $ \ xs -> do 31 | let dict = "aabbccdd" 32 | decompress defaultDecompressConfig{decompressDictionary = dict} 33 | (compress defaultCompressConfig{compressDictionary = dict} (V.pack xs)) 34 | === V.pack xs 35 | 36 | prop "compress === TheZlib.compress" $ \ xs -> do 37 | V.unpack (compress defaultCompressConfig (V.pack xs)) === 38 | BL.unpack (TheZlib.compressWith TheZlib.defaultCompressParams (BL.pack xs)) 39 | 40 | prop "compress === TheZlib.compress(with dict)" $ \ xs -> do 41 | V.unpack (compress defaultCompressConfig{compressDictionary = "aabbccdd"} (V.pack xs)) === 42 | BL.unpack (TheZlib.compressWith 43 | TheZlib.defaultCompressParams{TheZlib.compressDictionary = Just "aabbccdd" } 44 | (BL.pack xs)) 45 | 46 | prop "TheZlib.decompress . TheZlib.compress == id(performace benchmark)" $ \ xss -> do 47 | let vs = Prelude.map B.pack xss 48 | vs' = TheZlib.decompress . TheZlib.compress $ BL.fromChunks vs 49 | 50 | B.concat vs @=? BL.toStrict vs' 51 | 52 | prop "compress . decompress" $ \ xss -> do 53 | (_, c) <- newCompress defaultCompressConfig 54 | (_, d) <- newDecompress defaultDecompressConfig 55 | 56 | let vs = Prelude.map V.pack xss 57 | vs' <- runBlocks (c . d) vs 58 | 59 | V.concat vs @=? V.concat vs' 60 | 61 | prop "compress . decompress (with dict)" $ \ xss -> do 62 | let dict = "aabbccdd" 63 | 64 | (_, c) <- newCompress defaultCompressConfig{compressDictionary = dict} 65 | (_, d) <- newDecompress defaultDecompressConfig{decompressDictionary = dict} 66 | 67 | let vs = Prelude.map V.pack xss 68 | vs' <- runBlocks (c . d) vs 69 | 70 | V.concat vs @=? V.concat vs' 71 | -------------------------------------------------------------------------------- /test/Z/IO/FileSystem/ThreadedSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Z.IO.FileSystem.ThreadedSpec where 4 | 5 | import Control.Concurrent.MVar (readMVar) 6 | import Control.Monad 7 | import Data.Bits 8 | import Z.Data.ASCII 9 | import Z.Data.Vector as V 10 | import Z.Data.Vector.Base as V 11 | import Data.List as List 12 | import Foreign.Marshal.Array 13 | import Foreign.Ptr 14 | import Z.IO.Buffered 15 | import Z.IO.Exception 16 | import Z.IO.FileSystem.Threaded 17 | import Z.IO.Resource 18 | import Z.IO.UV.Manager 19 | import Test.Hspec 20 | import Test.HUnit 21 | 22 | spec :: Spec 23 | spec = describe "filesystem (threadpool version) operations" $ do 24 | 25 | let content = "Hello world!" 26 | content2 = V.cycleN 1024 "quick fox jumps over the lazy dog, 世界你好!\n" 27 | size = V.length content 28 | size2 = V.length content2 29 | 30 | it "create a temp dir" $ do 31 | tempdir <- mkdtemp "stdio-filesystem-unit" 32 | dirs <- scandir "./" 33 | rmdir tempdir 34 | List.lookup tempdir dirs @?= Just DirEntDir 35 | 36 | 37 | let flags = O_RDWR .|. O_CREAT 38 | mode = DEFAULT_FILE_MODE 39 | filename = "test-file" 40 | 41 | it "Opens and writes a file" $ do 42 | withResource (initFile filename flags mode) $ \ file -> do 43 | o <- newBufferedOutput' 4096 file 44 | writeBuffer o content 45 | flushBuffer o 46 | 47 | withResource (initFile filename flags mode) $ \ file -> do 48 | i <- newBufferedInput' 4096 file 49 | written <- readExactly size i 50 | written @?= content 51 | 52 | fr <- newFilePtr file 0 53 | i <- newBufferedInput' 4096 fr 54 | written <- readExactly size i 55 | written @=? content 56 | 57 | unlink filename 58 | 59 | it "Opens and writes a file II" $ do 60 | withResource (initFile filename flags mode) $ \ file -> do 61 | o <- newBufferedOutput' 4096 file 62 | writeBuffer o content2 63 | flushBuffer o 64 | 65 | withResource (initFile filename flags mode) $ \ file -> do 66 | i <- newBufferedInput' 4096 file 67 | written <- readExactly size2 i 68 | written @=? content2 69 | 70 | withResource (initFile filename flags mode) $ \ file -> do 71 | i <- newBufferedInput' 4096 file 72 | Just firstLine <- readLine i 73 | firstLine @=? fst (V.break (== c2w '\n') content2) 74 | 75 | fr <- newFilePtr file (fromIntegral $ size2 `div` 2) 76 | i <- newBufferedInput' 4096 fr 77 | replicateM_ 512 $ do 78 | Just firstLine <- readLine i 79 | firstLine @=? fst (V.break (== c2w '\n') content2) 80 | 81 | unlink filename 82 | 83 | 84 | it "create and remove dir" $ do 85 | tempdir <- mkdtemp "stdio-filesystem-unit" 86 | let dirname = tempdir <> "/test-dir" 87 | mkdir dirname mode 88 | dirs <- scandir tempdir 89 | print dirs 90 | rmdir dirname 91 | rmdir tempdir 92 | List.lookup "test-dir" dirs @?= Just DirEntDir 93 | 94 | let linkname = "test-link" 95 | symlinkname = "test-symlink" 96 | symlinkname2 = "test-symlink2" 97 | 98 | it "link stat should be equal to target file" $ ( do 99 | 100 | withResource (initFile filename flags mode) $ \ file -> return () 101 | 102 | s0 <- stat filename 103 | 104 | link filename linkname 105 | symlink "test-link" symlinkname SYMLINK_DEFAULT 106 | 107 | absfp <- realpath filename 108 | symlink absfp symlinkname2 SYMLINK_DEFAULT -- the second way to create a proper symlink 109 | 110 | s1 <- stat linkname 111 | s2 <- stat symlinkname 112 | s2' <- stat symlinkname2 113 | 114 | s0 @=? s1 {stNlink = 1, stCtim = stCtim s0} -- update hard link number 115 | s0 @=? s2 {stNlink = 1, stCtim = stCtim s0} 116 | s0 @=? s2' {stNlink = 1, stCtim = stCtim s0} 117 | 118 | withResource (initFile filename flags mode) $ \ file -> do 119 | s4 <- fstat file 120 | s0 @?= s4 {stNlink = 1, stCtim = stCtim s0} 121 | ) `finally` ( do 122 | unlink filename 123 | unlink linkname 124 | unlink symlinkname 125 | unlink symlinkname2 126 | ) 127 | 128 | it "utime result in stat change" $ do 129 | withResource (initFile filename flags mode) $ \ file -> return () 130 | utime filename 1000.2000 3000.4000 131 | s <- stat filename 132 | print s 133 | uvtSecond (stAtim s) @?= 1000 134 | uvtNanoSecond (stAtim s) @?= 200000000 135 | uvtSecond (stMtim s) @?= 3000 136 | uvtNanoSecond (stMtim s) @?= 400000000 137 | unlink filename 138 | 139 | it "futime result in fstat change" $ do 140 | withResource (initFile filename flags mode) $ \ file -> do 141 | futime file 5000.6000 7000.8000 142 | s <- fstat file 143 | print s 144 | uvtSecond (stAtim s) @?= 5000 145 | uvtNanoSecond (stAtim s) @?= 600000000 146 | uvtSecond (stMtim s) @?= 7000 147 | uvtNanoSecond (stMtim s) @?= 800000000 148 | unlink filename 149 | 150 | -------------------------------------------------------------------------------- /test/Z/IO/FileSystemSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Z.IO.FileSystemSpec where 4 | 5 | import Control.Concurrent.MVar (readMVar) 6 | import Control.Monad 7 | import Data.Bits 8 | import Z.Data.ASCII 9 | import Z.Data.Vector as V 10 | import Z.Data.Vector.Base as V 11 | import Data.List as List 12 | import Foreign.Marshal.Array 13 | import Foreign.Ptr 14 | import Z.IO.Buffered 15 | import Z.IO.Exception 16 | import Z.IO.FileSystem 17 | import Z.IO.Resource 18 | import Z.IO.UV.Manager 19 | import Test.Hspec 20 | import Test.HUnit 21 | 22 | spec :: Spec 23 | spec = describe "filesystem operations" $ do 24 | 25 | let content = "Hello world!" 26 | content2 = V.cycleN 1024 "quick fox jumps over the lazy dog, 世界你好!\n" 27 | size = V.length content 28 | size2 = V.length content2 29 | 30 | 31 | it "create a temp dir" $ do 32 | tempdir <- mkdtemp "stdio-filesystem-unit" 33 | dirs <- scandir "./" 34 | rmdir tempdir 35 | List.lookup tempdir dirs @?= Just DirEntDir 36 | 37 | 38 | let flags = O_RDWR .|. O_CREAT 39 | mode = DEFAULT_FILE_MODE 40 | filename = "test-file" 41 | 42 | it "Opens and writes a file" $ do 43 | withResource (initFile filename flags mode) $ \ file -> do 44 | o <- newBufferedOutput' 4096 file 45 | writeBuffer o content 46 | flushBuffer o 47 | 48 | withResource (initFile filename flags mode) $ \ file -> do 49 | i <- newBufferedInput' 4096 file 50 | written <- readExactly size i 51 | written @?= content 52 | 53 | fr <- newFilePtr file 0 54 | i <- newBufferedInput' 4096 fr 55 | written <- readExactly size i 56 | written @=? content 57 | 58 | 59 | unlink filename 60 | 61 | it "Opens and writes a file II" $ do 62 | withResource (initFile filename flags mode) $ \ file -> do 63 | o <- newBufferedOutput' 4096 file 64 | writeBuffer o content2 65 | flushBuffer o 66 | 67 | withResource (initFile filename flags mode) $ \ file -> do 68 | i <- newBufferedInput' 4096 file 69 | written <- readExactly size2 i 70 | written @?= content2 71 | 72 | withResource (initFile filename flags mode) $ \ file -> do 73 | i <- newBufferedInput' 4096 file 74 | Just firstLine <- readLine i 75 | firstLine @?= fst (V.break (== c2w '\n') content2) 76 | 77 | fr <- newFilePtr file (fromIntegral $ size2 `div` 2) 78 | i <- newBufferedInput' 4096 fr 79 | replicateM_ 512 $ do 80 | Just firstLine <- readLine i 81 | firstLine @=? fst (V.break (== c2w '\n') content2) 82 | 83 | unlink filename 84 | 85 | 86 | it "create and remove dir" $ do 87 | tempdir <- mkdtemp "stdio-filesystem-unit" 88 | let dirname = tempdir <> "/test-dir" 89 | mkdir dirname mode 90 | dirs <- scandir tempdir 91 | print dirs 92 | rmdir dirname 93 | rmdir tempdir 94 | List.lookup "test-dir" dirs @?= Just DirEntDir 95 | 96 | let linkname = "test-link" 97 | symlinkname = "test-symlink" 98 | symlinkname2 = "test-symlink2" 99 | 100 | it "link stat should be equal to target file" $ ( do 101 | 102 | withResource (initFile filename flags mode) $ \ file -> return () 103 | 104 | s0 <- stat filename 105 | 106 | link filename linkname 107 | symlink "test-link" symlinkname SYMLINK_DEFAULT 108 | 109 | absfp <- realpath filename 110 | symlink absfp symlinkname2 SYMLINK_DEFAULT -- the second way to create a proper symlink 111 | 112 | s1 <- stat linkname 113 | s2 <- stat symlinkname 114 | s2' <- stat symlinkname2 115 | 116 | s0 @=? s1 {stNlink = 1, stCtim = stCtim s0} -- update hard link number, stCtim could have some small diff 117 | s0 @=? s2 {stNlink = 1, stCtim = stCtim s0} 118 | s0 @=? s2' {stNlink = 1, stCtim = stCtim s0} 119 | 120 | withResource (initFile filename flags mode) $ \ file -> do 121 | s4 <- fstat file 122 | s0 @=? s4 {stNlink = 1, stCtim = stCtim s0} 123 | ) `finally` ( do 124 | unlink filename 125 | unlink linkname 126 | unlink symlinkname 127 | unlink symlinkname2 128 | ) 129 | 130 | it "utime result in stat change" $ do 131 | withResource (initFile filename flags mode) $ \ file -> return () 132 | utime filename 1000.2000 3000.4000 133 | s <- stat filename 134 | print s 135 | uvtSecond (stAtim s) @?= 1000 136 | uvtNanoSecond (stAtim s) @?= 200000000 137 | uvtSecond (stMtim s) @?= 3000 138 | uvtNanoSecond (stMtim s) @?= 400000000 139 | unlink filename 140 | 141 | it "futime result in fstat change" $ do 142 | withResource (initFile filename flags mode) $ \ file -> do 143 | futime file 5000.6000 7000.8000 144 | s <- fstat file 145 | print s 146 | uvtSecond (stAtim s) @?= 5000 147 | uvtNanoSecond (stAtim s) @?= 600000000 148 | uvtSecond (stMtim s) @?= 7000 149 | uvtNanoSecond (stMtim s) @?= 800000000 150 | unlink filename 151 | 152 | -------------------------------------------------------------------------------- /test/Z/IO/LowResTimerSpec.hs: -------------------------------------------------------------------------------- 1 | module Z.IO.LowResTimerSpec where 2 | 3 | import Control.Concurrent 4 | import Control.Monad 5 | import Control.Monad.IO.Class 6 | import Z.Data.PrimRef 7 | import Z.IO.LowResTimer 8 | import Test.Hspec 9 | import Test.HUnit 10 | 11 | spec :: Spec 12 | spec = describe "low resolution timers" $ do 13 | it "timers registration should not be missed" $ do 14 | c <- newCounter 0 15 | replicateM_ 10000 $ do 16 | forM_ [1..10] $ \ i -> do 17 | registerLowResTimer i (atomicAddCounter_ c 1) 18 | 19 | threadDelay 1000 20 | lrtm <- getLowResTimerManager 21 | running <- isLowResTimerManagerRunning lrtm 22 | assertEqual "timer manager should start" True running 23 | 24 | threadDelay 2000000 -- make sure all timers are fired 25 | c' <- readPrimRef c 26 | assertEqual "timers registration counter" 100000 c' 27 | 28 | threadDelay 100000 -- another 0.1s 29 | 30 | lrtm <- getLowResTimerManager 31 | running <- isLowResTimerManagerRunning lrtm 32 | assertEqual "timer manager should stopped" False running 33 | 34 | it "throttle" $ do 35 | c <- newCounter 0 36 | throttledAdd <- throttle 10 (atomicAddCounter_ c 1) 37 | forkIO . replicateM_ 50 $ do 38 | throttledAdd 39 | threadDelay 100000 40 | threadDelay 10000000 -- wait 10s here 41 | c' <- readPrimRef c 42 | assertBool ("throttled add " ++ show c') (5 <= c' && c' <= 8) -- on osx CI threadDelay drift too much 43 | 44 | it "throttleTrailing" $ do 45 | c <- newCounter 0 46 | throttledAdd <- throttleTrailing_ 10 (atomicAddCounter_ c 1) 47 | forkIO . replicateM_ 50 $ do 48 | throttledAdd 49 | threadDelay 100000 50 | threadDelay 10000000 -- wait 10s here 51 | c' <- readPrimRef c 52 | assertBool ("throttled add " ++ show c') (5 <= c' && c' <= 8) -- on osx CI threadDelay drift too muc 53 | -------------------------------------------------------------------------------- /test/Z/IO/Network/IPCSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Z.IO.Network.IPCSpec where 4 | 5 | import Control.Concurrent 6 | import Control.Monad 7 | import Data.Bits 8 | import Data.List as List 9 | import Foreign.Marshal.Array 10 | import Foreign.Ptr 11 | import Test.HUnit 12 | import Test.Hspec 13 | import Z.Data.Vector as V 14 | import Z.Data.Vector.Base as V 15 | import Z.IO.Buffered 16 | import Z.IO.Exception 17 | import Z.IO.FileSystem (mkdtemp) 18 | import Z.IO.Network 19 | import Z.IO.Resource 20 | 21 | spec :: Spec 22 | spec = describe "IPC operations" $ do 23 | it "roundtrip test" $ do 24 | let testMsg = V.cycleN 256 "abc" 25 | longMsg = V.cycleN 2048 "abcdefg" 26 | tmpDir <- mkdtemp "z-io-test" 27 | let addr = tmpDir <> "socket-file" 28 | 29 | serverThread <- forkIO $ startIPCServer defaultIPCServerConfig{ ipcListenName = addr } echo 30 | 31 | threadDelay 1000000 -- 1s 32 | 33 | replicateM_ 10 . forkIO $ 34 | withResource (initIPCClient defaultIPCClientConfig{ipcTargetName = addr}) $ \ ipc -> do 35 | i <- newBufferedInput ipc 36 | o <- newBufferedOutput ipc 37 | 38 | writeBuffer o testMsg >> flushBuffer o 39 | testMsg' <- readAll' i 40 | testMsg' @=? testMsg 41 | 42 | writeBuffer o longMsg >> flushBuffer o 43 | longMsg' <- readAll' i 44 | longMsg' @=? longMsg 45 | 46 | threadDelay 5000000 -- 5s 47 | killThread serverThread 48 | -------------------------------------------------------------------------------- /test/Z/IO/Network/TCPSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Z.IO.Network.TCPSpec where 4 | 5 | import Control.Concurrent 6 | import Control.Monad 7 | import Data.Bits 8 | import Z.Data.Vector as V 9 | import Z.Data.Vector.Base as V 10 | import Data.List as List 11 | import Foreign.Marshal.Array 12 | import Foreign.Ptr 13 | import Z.IO.Exception 14 | import Z.IO.Resource 15 | import Z.IO.Buffered 16 | import Z.IO.Network 17 | import Test.Hspec 18 | import Test.HUnit 19 | 20 | spec :: Spec 21 | spec = describe "TCP operations" $ do 22 | it "roundtrip test" $ do 23 | let testMsg = V.cycleN 256 "abc" 24 | longMsg = V.cycleN 2048 "abcdefg" 25 | addr = SocketAddrIPv4 ipv4Loopback 12345 26 | 27 | serverThread <- forkIO $ startTCPServer defaultTCPServerConfig{ tcpListenAddr = addr } echo 28 | 29 | threadDelay 2000000 -- 2s 30 | 31 | replicateM_ 10 . forkIO $ 32 | withResource (initTCPClient defaultTCPClientConfig{tcpRemoteAddr = addr}) $ \ tcp -> do 33 | i <- newBufferedInput tcp 34 | o <- newBufferedOutput tcp 35 | 36 | writeBuffer o testMsg >> flushBuffer o 37 | testMsg' <- readExactly (V.length testMsg) i 38 | testMsg' @=? testMsg 39 | 40 | writeBuffer o longMsg >> flushBuffer o 41 | longMsg' <- readExactly (V.length longMsg) i 42 | longMsg' @=? longMsg 43 | 44 | threadDelay 5000000 -- 5s 45 | killThread serverThread 46 | -------------------------------------------------------------------------------- /test/Z/IO/Network/UDPSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Z.IO.Network.UDPSpec where 4 | 5 | import Control.Concurrent 6 | import Control.Monad 7 | import Data.Bits 8 | import Data.IORef 9 | import qualified Z.Data.Vector as V 10 | import qualified Z.Data.Vector.Base as V 11 | import Data.List as List 12 | import Foreign.Marshal.Array 13 | import Foreign.Ptr 14 | import Z.IO.Exception 15 | import Z.IO.Resource 16 | import Z.IO.Network 17 | import Test.Hspec 18 | import Test.HUnit 19 | 20 | spec :: Spec 21 | spec = describe "UDP operations" $ do 22 | it "roundtrip test" $ do 23 | let testMsg = V.replicate 256 48 24 | longMsg = V.replicate 2048 48 25 | addr = SocketAddrIPv4 ipv4Loopback 12345 26 | withResource (initUDP defaultUDPConfig{udpSendMsgSize = 2048}) $ \ c -> 27 | withResource (initUDP defaultUDPConfig{udpLocalAddr = Just (addr,UDP_DEFAULT)}) $ \ s -> do 28 | forkIO $ sendUDP c addr testMsg 29 | [(_, partial, rcvMsg)]<- recvUDP defaultUDPRecvConfig s 30 | partial @=? False 31 | rcvMsg @=? testMsg 32 | 33 | threadDelay 100000 34 | 35 | forkIO $ sendUDP c addr longMsg 36 | [(_, partial, rcvMsg)]<- recvUDP defaultUDPRecvConfig s 37 | partial @=? True 38 | 39 | it "UDP sending addr test" $ do 40 | let testMsg = V.replicate 256 48 41 | addr = SocketAddrIPv4 ipv4Loopback 12346 42 | addr' = SocketAddrIPv4 ipv4Loopback 12347 43 | withResource (initUDP defaultUDPConfig{udpLocalAddr = Just (addr,UDP_DEFAULT)}) $ \ c -> 44 | withResource (initUDP defaultUDPConfig{udpLocalAddr = Just (addr',UDP_DEFAULT)}) $ \ s -> do 45 | forkIO $ sendUDP c addr' testMsg 46 | [(rcvAddr, _, _)]<- recvUDP defaultUDPRecvConfig s 47 | Just addr @=? rcvAddr 48 | 49 | it "overlong message exception" $ do 50 | let testMsg = V.replicate 4096 48 51 | addr = SocketAddrIPv4 ipv4Loopback 12348 52 | withResource (initUDP defaultUDPConfig) $ \ c -> 53 | withResource (initUDP defaultUDPConfig) $ \_s -> do 54 | sendUDP c addr testMsg `shouldThrow` anyException 55 | 56 | it "batch receiving(multiple messages)" $ do 57 | let testMsg = V.replicate 256 48 58 | addr = SocketAddrIPv4 ipv4Loopback 12346 59 | msgList <- newIORef [] 60 | forkIO $ withResource (initUDP defaultUDPConfig{udpLocalAddr = Just (addr,UDP_DEFAULT)}) $ \ s -> do 61 | recvUDPLoop defaultUDPRecvConfig s $ \ msgs -> 62 | modifyIORef msgList (msgs:) 63 | withResource (initUDP defaultUDPConfig) $ \c -> replicateM_ 100 $ sendUDP c addr testMsg 64 | msgs <- readIORef msgList 65 | True @=? (List.length msgs > 50) -- udp packet may get lost 66 | forM_ msgs $ \ (_,_,msg) -> testMsg @=? msg 67 | -------------------------------------------------------------------------------- /test/Z/IO/ProcessSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Z.IO.ProcessSpec where 3 | 4 | import Control.Concurrent 5 | import Control.Monad 6 | import Control.Monad.IO.Class 7 | import Data.Bits 8 | import Z.IO.Buffered 9 | import Z.IO.Process 10 | import Z.IO.Resource 11 | import Z.IO.FileSystem 12 | import Test.Hspec 13 | import Test.HUnit 14 | 15 | spec :: Spec 16 | spec = describe "process" $ do 17 | it "arguments should be passed" $ do 18 | (out, err, ecode) <- readProcess defaultProcessOptions{ 19 | processFile = "echo" 20 | , processArgs = ["-n", "hello", "world", "good", "byte"] 21 | } "" 22 | 23 | assertEqual "echo back arguments" "hello world good byte" out 24 | assertEqual "echo exit successfully" ExitSuccess ecode 25 | 26 | it "UTF8 input should be passed" $ do 27 | (out, err, ecode) <- readProcess defaultProcessOptions{ 28 | processFile = "cat" 29 | } "你好世界再见" 30 | 31 | assertEqual "cat echo back stdin" "你好世界再见" out 32 | assertEqual "cat exit successfully" ExitSuccess ecode 33 | 34 | it "environment should be passed" $ do 35 | (out, err, ecode) <- readProcess defaultProcessOptions{ 36 | processFile = "env" 37 | , processEnv = Just [("hello", "world"), ("good", "byte")] 38 | } "" 39 | 40 | assertEqual "env echo back environment" "hello=world\ngood=byte\n" out 41 | assertEqual "env exit successfully" ExitSuccess ecode 42 | 43 | it "exit code should be passed" $ do 44 | (out, err, ecode) <- readProcess defaultProcessOptions{ 45 | processFile = "sh" 46 | , processArgs = ["-c", "exit 8"] 47 | } "" 48 | 49 | assertEqual "exit code" (ExitFailure 8) ecode 50 | 51 | it "redirect stdin, stdout to file" $ do 52 | 53 | tempdir <- mkdtemp "stdio-filesystem-unit" 54 | let ifilename = tempdir <> "/test-stdin" 55 | ofilename = tempdir <> "/test-stdout" 56 | withResource (initFile ifilename (O_RDWR .|. O_CREAT) DEFAULT_FILE_MODE) $ \ input -> do 57 | bi <- newBufferedOutput' 4096 input 58 | writeBuffer bi "hello world" >> flushBuffer bi 59 | 60 | ecode <- withResource (initFile ifilename O_RDWR DEFAULT_FILE_MODE) $ \ input -> do 61 | 62 | withResource (initFile ofilename (O_RDWR .|. O_CREAT) DEFAULT_FILE_MODE) $ \ output -> do 63 | 64 | iF <- getFileFD input 65 | oF <- getFileFD output 66 | 67 | withResource (initProcess defaultProcessOptions{ 68 | processFile = "cat" 69 | , processStdStreams = (ProcessInherit iF, ProcessInherit oF, ProcessIgnore) 70 | }) $ \ (_, _, _, pstate) -> do 71 | 72 | waitProcessExit pstate 73 | 74 | withResource (initFile ofilename (O_RDWR .|. O_CREAT) DEFAULT_FILE_MODE) $ \ output -> do 75 | bo <- newBufferedInput' 4096 output 76 | o <- readBuffer bo 77 | assertEqual "cat echo back" "hello world" o 78 | 79 | assertEqual "exit code" ecode ExitSuccess 80 | 81 | -- clean up file 82 | unlink ifilename 83 | unlink ofilename 84 | rmdir tempdir 85 | -------------------------------------------------------------------------------- /test/Z/IO/ResourceSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Z.IO.ResourceSpec where 4 | 5 | import Control.Concurrent 6 | import Control.Exception 7 | import Control.Monad 8 | import Z.Data.PrimRef 9 | import Z.IO.Resource as R 10 | import Test.Hspec 11 | import Test.HUnit 12 | 13 | data WorkerException = WorkerException deriving (Show) 14 | 15 | instance Exception WorkerException 16 | 17 | spec :: Spec 18 | spec = describe "resource tests" $ do 19 | it "resource pool" $ do 20 | resCounter <- newCounter 0 21 | workerCounter <- newCounter 0 22 | let res = initResource (atomicAddCounter_ resCounter 1) 23 | (\ _ -> atomicSubCounter_ resCounter 1) 24 | resPool = initSimplePool res 100 1 25 | 26 | R.withResource resPool $ \ pool -> do 27 | forM_ [1..200] $ \ k -> forkIO. R.withSimplePool pool $ \ i -> do 28 | atomicAddCounter_ workerCounter 1 29 | threadDelay 100000 30 | 31 | threadDelay 1000000 32 | 33 | r <- readPrimRef resCounter 34 | assertEqual "pool should keep returned resources alive" 100 r 35 | 36 | threadDelay 5000000 -- after 5s, 200 thread should release all resources 37 | 38 | w <- readPrimRef workerCounter 39 | assertEqual "worker should be able to get resource" 200 w 40 | 41 | r <- readPrimRef resCounter 42 | assertEqual "pool should reap unused resources" 0 r 43 | 44 | -- Let's test again 45 | 46 | writePrimRef workerCounter 0 47 | 48 | forM_ [1..200] $ \ k -> forkIO. R.withSimplePool pool $ \ i -> do 49 | atomicAddCounter_ workerCounter 1 50 | threadDelay 100000 51 | 52 | threadDelay 1000000 53 | 54 | r <- readPrimRef resCounter 55 | assertEqual "pool should keep returned resources alive" 100 r 56 | 57 | threadDelay 5000000 58 | 59 | w <- readPrimRef workerCounter 60 | assertEqual "worker should be able to get resource" 200 w 61 | 62 | r <- readPrimRef resCounter 63 | assertEqual "pool should reap unused resources" 0 r 64 | 65 | it "resource pool under exceptions" $ do 66 | resCounter <- newCounter 0 67 | let res = initResource (atomicAddCounter' resCounter 1) 68 | (\ _ -> atomicSubCounter_ resCounter 1) 69 | resPool = initSimplePool res 100 1 70 | R.withResource resPool $ \ pool -> do 71 | 72 | forM_ [1..200] $ \ k -> forkIO. R.withSimplePool pool $ \ i -> do 73 | threadDelay 100000 74 | when (even i) (throwIO WorkerException) 75 | 76 | threadDelay 1000000 77 | 78 | threadDelay 5000000 79 | 80 | r <- readPrimRef resCounter 81 | assertEqual "pool should reap unused resources" 0 r 82 | --------------------------------------------------------------------------------