├── .github └── workflows │ ├── bump.yaml │ ├── cabal.yaml │ └── nix.yaml ├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── benchmark ├── README.md ├── insert │ ├── MySQLHaskell.hs │ ├── MySQLHaskellInsertMany.hs │ ├── MySQLHaskellPrepared.hs │ ├── bench.sh │ ├── insert.sql │ ├── libmysql.cpp │ └── mysql-haskell-bench.cabal ├── result.numbers ├── result.png └── select │ ├── MySQLFFI.hs │ ├── MySQLHaskell.hs │ ├── MySQLHaskellOpenSSL.hs │ ├── MySQLHaskellPrepared.hs │ ├── MySQLHaskellTLS.hs │ ├── bench-nossl-noffi.sh │ ├── bench.sh │ ├── employees.sql │ ├── libmysql.cpp │ ├── libmysql_prepared.cpp │ ├── load_employees.dump │ └── mysql-haskell-bench.cabal ├── binary-parser-bench ├── Aeson.hs ├── AesonBP.hs ├── Bench.hs ├── Common.hs ├── HttpReq.hs ├── Network │ └── Wai │ │ └── Handler │ │ └── Warp │ │ ├── ReadInt.hs │ │ └── RequestHeader.hs ├── http-request.txt └── json-data │ ├── buffer-builder.json │ ├── dates-fract.json │ ├── dates.json │ ├── example.json │ ├── geometry.json │ ├── integers.json │ ├── jp10.json │ ├── jp100.json │ ├── jp50.json │ ├── numbers.json │ ├── twitter1.json │ ├── twitter10.json │ ├── twitter100.json │ ├── twitter20.json │ └── twitter50.json ├── flake.lock ├── flake.nix ├── mozillaCAStore.pem ├── mysql-haskell.cabal ├── src ├── Data │ ├── Binary │ │ ├── Parser.hs │ │ └── Parser │ │ │ ├── Numeric.hs │ │ │ └── Word8.hs │ ├── Connection.hs │ ├── Int │ │ └── Int24.hs │ ├── TLSSetting.hs │ └── Word │ │ └── Word24.hs ├── Database │ └── MySQL │ │ ├── Base.hs │ │ ├── BinLog.hs │ │ ├── BinLogProtocol │ │ ├── BinLogEvent.hs │ │ ├── BinLogMeta.hs │ │ └── BinLogValue.hs │ │ ├── Connection.hs │ │ ├── Protocol │ │ ├── Auth.hs │ │ ├── ColumnDef.hs │ │ ├── Command.hs │ │ ├── Escape.hs │ │ ├── MySQLValue.hs │ │ └── Packet.hs │ │ ├── Query.hs │ │ └── TLS.hs └── System │ └── IO │ └── Streams │ ├── TCP.hs │ └── TLS.hs ├── tcp-streams-bench ├── TCPLoopBack.hs └── tcp-streams-bench.cabal ├── test ├── Aeson.hs ├── AesonBP.hs ├── BinLog.hs ├── BinLogNew.hs ├── BinaryRow.hs ├── BinaryRowNew.hs ├── ExecuteMany.hs ├── JSON.hs ├── Main.hs ├── MysqlTests.hs ├── QC │ ├── ByteString.hs │ ├── Combinator.hs │ └── Common.hs ├── QCUtils.hs ├── TCPStreams.hs ├── TextRow.hs ├── TextRowNew.hs ├── Word24.hs ├── cert │ ├── ca-key.pem │ ├── ca.pem │ ├── server-cert.pem │ ├── server-key.pem │ └── server-req.pem └── json-data │ ├── buffer-builder.json │ ├── dates-fract.json │ ├── dates.json │ ├── example.json │ ├── geometry.json │ ├── integers.json │ ├── jp10.json │ ├── jp100.json │ ├── jp50.json │ ├── numbers.json │ ├── twitter1.json │ ├── twitter10.json │ ├── twitter100.json │ ├── twitter20.json │ └── twitter50.json └── word24-bench └── Benchmark.hs /.github/workflows/bump.yaml: -------------------------------------------------------------------------------- 1 | # https://github.com/nomeata/haskell-bounds-bump-action 2 | on: 3 | # allows manual triggering from https://github.com/../../actions/workflows/bump.yml 4 | workflow_dispatch: 5 | # runs weekly on Thursday at 8:00 6 | schedule: 7 | # ┌───────────── minute (0 - 59) 8 | # │ ┌───────────── hour (0 - 23) 9 | # │ │ ┌───────────── day of the month (1 - 31) 10 | # │ │ │ ┌───────────── month (1 - 12 or JAN-DEC) 11 | # │ │ │ │ ┌───────────── day of the week (0 - 6 or SUN-SAT) 12 | # │ │ │ │ │ 13 | # │ │ │ │ │ 14 | # │ │ │ │ │ 15 | # * * * * * 16 | - cron: '0 0 * * 3' 17 | 18 | permissions: 19 | contents: write 20 | pull-requests: write 21 | 22 | jobs: 23 | bump: 24 | runs-on: ubuntu-latest 25 | steps: 26 | - uses: nomeata/haskell-bounds-bump-action@main 27 | with: 28 | test: false 29 | -------------------------------------------------------------------------------- /.github/workflows/cabal.yaml: -------------------------------------------------------------------------------- 1 | on: [pull_request] 2 | jobs: 3 | build: 4 | 5 | runs-on: ${{ matrix.os }} 6 | 7 | strategy: 8 | fail-fast: false 9 | matrix: 10 | ghc: # should mirror current stable releases: https://www.haskell.org/ghc/download.html 11 | - '9.6' 12 | - '9.4' 13 | - '9.2' 14 | os: [ubuntu-latest, macOS-latest, windows-latest] 15 | 16 | steps: 17 | - uses: actions/checkout@v3 18 | - uses: haskell/actions/setup@v2 # https://github.com/haskell/actions/tree/main/setup#haskellactionssetup 19 | with: 20 | ghc-version: ${{ matrix.ghc }} 21 | 22 | - name: Cabal cache 23 | uses: actions/cache@v3 24 | env: 25 | cache-name: cache-cabal 26 | with: 27 | path: ~/.cabal 28 | key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} 29 | restore-keys: | 30 | ${{ runner.os }}-build-${{ env.cache-name }}- 31 | - name: Cabal update 32 | run: cabal update 33 | - name: Build using cabal 34 | run: cabal build all 35 | - name: Test 36 | run: cabal test all 37 | -------------------------------------------------------------------------------- /.github/workflows/nix.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | pull_request: 3 | jobs: 4 | tests: 5 | runs-on: ubuntu-latest 6 | steps: 7 | - uses: actions/checkout@v3 8 | - name: Local cache 9 | uses: actions/cache@v3 10 | with: 11 | path: /nix/store 12 | key: "${{ runner.os }}-nix-cache" 13 | - uses: cachix/install-nix-action@v20 14 | with: 15 | nix_path: nixpkgs=channel:nixos-unstable 16 | extra_nix_config: | 17 | access-tokens = github.com=${{ secrets.GITHUB_TOKEN }} 18 | 19 | # follow guide: https://nix.dev/tutorials/continuous-integration-github-actions 20 | # this uses the tokens which are revokable 21 | - uses: cachix/cachix-action@v12 22 | with: 23 | name: jappie 24 | # If you chose API tokens for write access OR if you have a private cache 25 | # authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 26 | signingKey: '${{ secrets.CACHIX_SIGNING_KEY }}' 27 | - run: nix build -Lv 28 | - run: nix flake check -Lv 29 | - run: nix develop -Lv -c echo OK 30 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for mysql-haskell 2 | 3 | ## 1.1.6 -- 2024.10.23 4 | + bump constraints 5 | 6 | ## 1.1.5 -- 2024.06.25 7 | + bump constraints 8 | 9 | ## 1.1.4 -- 2024.02.17 10 | + bump constraints 11 | 12 | ## 1.1.3 -- 2023.08.30 13 | + bump constraints 14 | 15 | ## 1.1.2 -- 2023.08.14 16 | 17 | + Fix package name of changelog 18 | + Drop support for RC4 chipher which is depracated 19 | + drop dependency on binary-ieee754, which was unused. 20 | + Fix text 2 support, thanks @RikvanToor 21 | 22 | ## 1.1.1 -- 2023.08.14 23 | 24 | + cleaned up some warnings 25 | + Merge back into mysql-haskell after gaining hackage access. 26 | + Deprecate mysql-pure in favor of old hackage 27 | since it's only been out for a day this sort off 28 | stream lines upgrading for most applications. 29 | Cabal will just figure it out, rather then 30 | users having to "find" mysql-pure. 31 | I'll just make a bonus announcement to 32 | let people not depend on mysql-pure. 33 | 34 | ## 1.1.0 -- 2023.08.12 35 | There was a bunch of stuff unrelated to mysql 36 | which I purged. 37 | If you need any on these go depend on the 38 | respective unmaintained package. 39 | 40 | + Delete module System.IO.Streams.UnixSocket 41 | + Dleete module Data.Binary.Parser.Char8 42 | + Delete module System.IO.Streams.Binary 43 | 44 | ## 1.0.2 -- 2023.08.12 45 | + Bump dependencies, go all into crypton 46 | + merge tcp-streams into the package 47 | 48 | ## 1.0.1 -- 2023.08.12 49 | + add json testfiles as extra source files to make tests pass in nix builds 50 | 51 | ## 1.0.0 -- 2023.08.12 52 | 53 | + Fork from mysql-haskell into mysql-pure 54 | + add flake 55 | + merge packages: 56 | + word24 57 | + binary-parsers 58 | + wirestreams 59 | 60 | This involved copying over all source files, 61 | furthermore I copied in all tests and benchmarks. 62 | The tests are now one giant test suite. 63 | I temporarly disabled the mysql tests as they need a mysql 64 | database to run which won't work nicely with CI right now. 65 | However you can run these locally by uncommenting that line. 66 | + Add CI which relies on native cabal instead of stack 67 | + Add an action to automatically bump version. 68 | + Add nightly build cron job. 69 | 70 | ## 0.8.4.3 -- 2020-11-04 71 | 72 | * Fix build with GHC 8.8. 73 | 74 | ## 0.8.4.2 -- 2019-01-22 75 | 76 | * Fix [stackage#4312](https://github.com/commercialhaskell/stackage/issues/4312): Relax `network` bounds. 77 | 78 | ## 0.8.4.1 -- 2018-10-23 79 | 80 | * Relax `tasty` version bound to build with latest stackage. [#26](https://github.com/winterland1989/mysql-haskell/pull/26) 81 | 82 | ## 0.8.4.0 -- 2018-10-23 83 | 84 | * Add `executeMany_` to execute batch SQLs, [#26](https://github.com/winterland1989/mysql-haskell/issues/26). 85 | * Optimize connection closing sequence, [#20](https://github.com/winterland1989/mysql-haskell/pull/20), [#25](https://github.com/winterland1989/mysql-haskell/pull/25). 86 | 87 | ## 0.8.3.0 -- 2017-10-09 88 | 89 | * Remove unnecessary exports from `Database.MySQL.Base`. 90 | * Reuse TCP connection when using TLS. 91 | * Clean up some compiler warnings. 92 | 93 | ## 0.8.2.0 -- 2017-10-09 94 | 95 | Courtesy of naushadh, `mysql-haskell` will be on stackage again. 96 | 97 | * Update to use `tcp-streams-1.x`. 98 | * Fix compatibility with new `tls/memory` version. 99 | 100 | ## 0.8.1.0 -- 2016-11-09 101 | 102 | * Add `Show` instance to `ConnectInfo`. 103 | * Add proper version bound for `binary`. 104 | 105 | ## 0.8.0.0 -- 2016-11-09 106 | 107 | * Add `ciCharset` field to support `utf8mb4` charset. 108 | * Add `BitMap` field to `COM_STMT_EXECUTE`, and [#8](https://github.com/winterland1989/mysql-haskell/pull/8) by [alexbiehl](https://github.com/alexbiehl). 109 | 110 | ## 0.7.1.0 -- 2016-11-21 111 | 112 | * Add `QueryParam` class and `Param` datatype for multi-valued parameter(s) by [naushadh](https://github.com/naushadh). 113 | 114 | ## 0.7.0.0 -- 2016-11-09 115 | 116 | * Split openssl support to [mysql-haskell-openssl](http://hackage.haskell.org/package/mysql-haskell-openssl). 117 | * Expose `Database.MySQL.Connection` module due to this split, it shouldn't be used by user directly. 118 | 119 | ## 0.6.0.0 -- 2016-10-25 120 | 121 | * Use binary-ieee754 for older binary compatibility. 122 | * Clean up `Database.MySQL.Protocol.MySQLValue` 's export. 123 | 124 | ## 0.5.1.0 -- 2016-10-20 125 | 126 | * Add `queryVector`, `queryVector_` and `queryStmtVector`. 127 | * Use binary-parsers to speed up binary parsers. 128 | 129 | ## 0.5.0.0 -- 2016-8-22 130 | 131 | * Export exception types. 132 | * Fix a regression cause password authentication failed, add tests. 133 | * Fix a reading order bug cause 'prepareStmt/prepareStmtDetail' failed. 134 | 135 | ## 0.4.0.0 -- 2016-8-22 136 | 137 | * Enable TLS support via `tls` package, add benchmarks. 138 | 139 | ## 0.3.0.0 -- 2016-8-22 140 | 141 | * Fix tls connection, change TLS implementation to HsOpenSSL, add benchmarks. 142 | * Fix a bug in 'putLenEncInt' which cause sending large field fail. 143 | * Various optimizations. 144 | 145 | ## 0.2.0.0 -- 2016-8-19 146 | 147 | * Fix OK packet decoder. 148 | * Fix sending large packet(>16M). 149 | * Add `executeMany`, `withTransaction` to Base module. 150 | * Add timestamp field to `RowBinLogEvent`. 151 | * Add test, add insert benchmark. 152 | 153 | ## 0.1.0.0 -- 2016-8-16 154 | 155 | * First version. Released on an unsuspecting world. 156 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Winterland 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 winterland1989 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 | -------------------------------------------------------------------------------- /benchmark/README.md: -------------------------------------------------------------------------------- 1 | mysql-haskell benchmark 2 | ----------------------- 3 | 4 | We mainly want to benchmark `mysql-haskell` against pure c `libmysql`, Haskell's FFI version `mysql` are not buildable from hackage, so here we include it, install it using `cabal install mysql-0.1.1.8.tar.gz`. 5 | -------------------------------------------------------------------------------- /benchmark/insert/MySQLHaskell.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Main where 5 | 6 | import Control.Concurrent.Async 7 | import Control.Monad 8 | import Database.MySQL.Base 9 | import System.Environment 10 | import System.IO.Streams (fold) 11 | import qualified Data.ByteString as B 12 | 13 | main :: IO () 14 | main = do 15 | args <- getArgs 16 | case args of [threadNum] -> go (read threadNum) 17 | _ -> putStrLn "No thread number provided." 18 | 19 | go :: Int -> IO () 20 | go n = void . flip mapConcurrently [1..n] $ \ _ -> do 21 | c <- connect defaultConnectInfo { ciUser = "testMySQLHaskell" 22 | , ciDatabase = "testMySQLHaskell" 23 | } 24 | 25 | execute_ c "BEGIN" 26 | replicateM_ 1000 $ 27 | execute_ c "INSERT INTO insert_test values (\ 28 | \ 0 ,\ 29 | \ b'1110000010101010' ,\ 30 | \ -128 ,\ 31 | \ 255 ,\ 32 | \ -32768 ,\ 33 | \ 65535 ,\ 34 | \ -8388608 ,\ 35 | \ 16777215 ,\ 36 | \ -2147483648 ,\ 37 | \ 4294967295 ,\ 38 | \ -9223372036854775808 ,\ 39 | \ 18446744073709551615 ,\ 40 | \ 1234567890.0123456789 ,\ 41 | \ 3.14159 ,\ 42 | \ 3.1415926535 ,\ 43 | \ '2016-08-08' ,\ 44 | \ '2016-08-08 17:25:59' ,\ 45 | \ '2016-08-08 17:25:59' ,\ 46 | \ '-199:59:59' ,\ 47 | \ 1999 ,\ 48 | \ '12345678' ,\ 49 | \ '韩冬真赞' ,\ 50 | \ '12345678' ,\ 51 | \ '12345678' ,\ 52 | \ '12345678' ,\ 53 | \ '韩冬真赞' ,\ 54 | \ '12345678' ,\ 55 | \ '韩冬真赞' ,\ 56 | \ 'foo' ,\ 57 | \ 'foo,bar')" 58 | 59 | execute_ c "COMMIT" 60 | return () 61 | 62 | 63 | 64 | 65 | 66 | -------------------------------------------------------------------------------- /benchmark/insert/MySQLHaskellInsertMany.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Main where 5 | 6 | import Control.Concurrent.Async 7 | import Control.Monad 8 | import Database.MySQL.Base 9 | import System.Environment 10 | import System.IO.Streams (fold) 11 | import qualified Data.ByteString as B 12 | 13 | main :: IO () 14 | main = do 15 | args <- getArgs 16 | case args of [threadNum] -> go (read threadNum) 17 | _ -> putStrLn "No thread number provided." 18 | 19 | go :: Int -> IO () 20 | go n = void . flip mapConcurrently [1..n] $ \ _ -> do 21 | c <- connect defaultConnectInfo { ciUser = "testMySQLHaskell" 22 | , ciDatabase = "testMySQLHaskell" 23 | } 24 | 25 | execute_ c "BEGIN" 26 | executeMany c "INSERT INTO insert_test values (\ 27 | \ 0 ,\ 28 | \ b'1110000010101010' ,\ 29 | \ -128 ,\ 30 | \ 255 ,\ 31 | \ -32768 ,\ 32 | \ 65535 ,\ 33 | \ -8388608 ,\ 34 | \ 16777215 ,\ 35 | \ -2147483648 ,\ 36 | \ 4294967295 ,\ 37 | \ -9223372036854775808 ,\ 38 | \ 18446744073709551615 ,\ 39 | \ 1234567890.0123456789 ,\ 40 | \ 3.14159 ,\ 41 | \ 3.1415926535 ,\ 42 | \ '2016-08-08' ,\ 43 | \ '2016-08-08 17:25:59' ,\ 44 | \ '2016-08-08 17:25:59' ,\ 45 | \ '-199:59:59' ,\ 46 | \ 1999 ,\ 47 | \ '12345678' ,\ 48 | \ '韩冬真赞' ,\ 49 | \ '12345678' ,\ 50 | \ '12345678' ,\ 51 | \ '12345678' ,\ 52 | \ '韩冬真赞' ,\ 53 | \ '12345678' ,\ 54 | \ '韩冬真赞' ,\ 55 | \ 'foo' ,\ 56 | \ 'foo,bar')" 57 | (replicate 1000 []) 58 | 59 | execute_ c "COMMIT" 60 | return () 61 | 62 | 63 | 64 | 65 | 66 | -------------------------------------------------------------------------------- /benchmark/insert/MySQLHaskellPrepared.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE NegativeLiterals #-} 4 | 5 | module Main where 6 | 7 | import Control.Concurrent.Async 8 | import Control.Monad 9 | import Database.MySQL.Base 10 | import System.Environment 11 | import System.IO.Streams (fold) 12 | import qualified Data.ByteString as B 13 | import Data.Time.Calendar (fromGregorian) 14 | import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..)) 15 | 16 | main :: IO () 17 | main = do 18 | args <- getArgs 19 | case args of [threadNum] -> go (read threadNum) 20 | _ -> putStrLn "No thread number provided." 21 | 22 | go :: Int -> IO () 23 | go n = void . flip mapConcurrently [1..n] $ \ _ -> do 24 | c <- connect defaultConnectInfo { ciUser = "testMySQLHaskell" 25 | , ciDatabase = "testMySQLHaskell" 26 | } 27 | 28 | stmt <- prepareStmt c "INSERT INTO insert_test values (\ 29 | \ ? ,\ 30 | \ ? ,\ 31 | \ ? ,\ 32 | \ ? ,\ 33 | \ ? ,\ 34 | \ ? ,\ 35 | \ ? ,\ 36 | \ ? ,\ 37 | \ ? ,\ 38 | \ ? ,\ 39 | \ ? ,\ 40 | \ ? ,\ 41 | \ ? ,\ 42 | \ ? ,\ 43 | \ ? ,\ 44 | \ ? ,\ 45 | \ ? ,\ 46 | \ ? ,\ 47 | \ ? ,\ 48 | \ ? ,\ 49 | \ ? ,\ 50 | \ ? ,\ 51 | \ ? ,\ 52 | \ ? ,\ 53 | \ ? ,\ 54 | \ ? ,\ 55 | \ ? ,\ 56 | \ ? ,\ 57 | \ ? ,\ 58 | \ ?)" 59 | 60 | let bitV = 43744 -- 0b1010101011100000 61 | execute_ c "BEGIN" 62 | replicateM_ 1000 $ executeStmt c stmt 63 | [ MySQLInt32 0 64 | , MySQLBit bitV 65 | , MySQLInt8 (-128) 66 | , MySQLInt8U 255 67 | , MySQLInt16 (-32768) 68 | , MySQLInt16U 65535 69 | , MySQLInt32 (-8388608) 70 | , MySQLInt32U 16777215 71 | , MySQLInt32 (-2147483648) 72 | , MySQLInt32U 4294967295 73 | , MySQLInt64 (-9223372036854775808) 74 | , MySQLInt64U 18446744073709551615 75 | , MySQLDecimal 1234567890.0123456789 76 | , MySQLFloat 3.14159 77 | , MySQLDouble 3.1415926535 78 | , MySQLDate (fromGregorian 2016 08 08) 79 | , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59)) 80 | , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59)) 81 | , MySQLTime 1 (TimeOfDay 199 59 59) 82 | , MySQLYear 1999 83 | , MySQLText "12345678" 84 | , MySQLText "韩冬真赞" 85 | , MySQLBytes "12345678" 86 | , MySQLBytes "12345678" 87 | , MySQLBytes "12345678" 88 | , MySQLText "韩冬真赞" 89 | , MySQLBytes "12345678" 90 | , MySQLText "韩冬真赞" 91 | , MySQLText "foo" 92 | , MySQLText "foo,bar" 93 | ] 94 | 95 | execute_ c "COMMIT" 96 | 97 | 98 | 99 | 100 | 101 | -------------------------------------------------------------------------------- /benchmark/insert/bench.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | mysql -utestMySQLHaskell -DtestMySQLHaskell -e "DROP TABLE IF EXISTS insert_test" 4 | mysql -utestMySQLHaskell -DtestMySQLHaskell -e "CREATE TABLE insert_test(\ 5 | __id INT,\ 6 | __bit BIT(16),\ 7 | __tinyInt TINYINT,\ 8 | __tinyIntU TINYINT UNSIGNED,\ 9 | __smallInt SMALLINT,\ 10 | __smallIntU SMALLINT UNSIGNED,\ 11 | __mediumInt MEDIUMINT,\ 12 | __mediumIntU MEDIUMINT UNSIGNED,\ 13 | __int INT,\ 14 | __intU INT UNSIGNED,\ 15 | __bigInt BIGINT,\ 16 | __bigIntU BIGINT UNSIGNED,\ 17 | __decimal DECIMAL(20,10),\ 18 | __float FLOAT,\ 19 | __double DOUBLE,\ 20 | __date DATE,\ 21 | __datetime DATETIME,\ 22 | __timestamp TIMESTAMP NULL,\ 23 | __time TIME,\ 24 | __year YEAR(4),\ 25 | __char CHAR(8),\ 26 | __varchar VARCHAR(1024),\ 27 | __binary BINARY(8),\ 28 | __varbinary VARBINARY(1024),\ 29 | __tinyblob TINYBLOB,\ 30 | __tinytext TINYTEXT,\ 31 | __blob BLOB,\ 32 | __text TEXT,\ 33 | __enum ENUM('foo', 'bar', 'qux'),\ 34 | __set SET('foo', 'bar', 'qux')\ 35 | ) CHARACTER SET utf8" 36 | 37 | g++ ./libmysql.cpp -lmysqlclient -lpthread -lz -lm -lssl -lcrypto -ldl\ 38 | -I/usr/local/opt/mysql/include -L/usr/local/opt/mysql/lib -I/usr/local/opt/openssl/include -L/usr/local/opt/openssl/lib\ 39 | -o libmysql 40 | 41 | echo "=============== start benchmark c++ client ================" 42 | time ./libmysql 1 43 | time ./libmysql 2 44 | time ./libmysql 3 45 | time ./libmysql 4 46 | time ./libmysql 10 47 | rm ./libmysql 48 | echo "=============== benchmark c++ client end ================" 49 | 50 | mysql -utestMySQLHaskell -DtestMySQLHaskell -e "select count(*) from insert_test" 51 | mysql -utestMySQLHaskell -DtestMySQLHaskell -e "DELETE FROM insert_test" 52 | 53 | cabal build 54 | echo "=============== start benchmark haskell client =============" 55 | time ./dist/build/bench/bench 1 +RTS -N4 -A128M -RTS 56 | time ./dist/build/bench/bench 2 +RTS -N4 -A128M -RTS 57 | time ./dist/build/bench/bench 3 +RTS -N4 -A128M -RTS 58 | time ./dist/build/bench/bench 4 +RTS -N4 -A128M -RTS 59 | time ./dist/build/bench/bench 10 +RTS -N4 -A128M -RTS 60 | echo "=============== benchmark haskell client end ================" 61 | 62 | mysql -utestMySQLHaskell -DtestMySQLHaskell -e "select count(*) from insert_test" 63 | mysql -utestMySQLHaskell -DtestMySQLHaskell -e "DELETE FROM insert_test" 64 | 65 | echo "=============== start benchmark haskell client (executeMany) =============" 66 | time ./dist/build/bench-insert-many/bench-insert-many 1 +RTS -N4 -A128M -RTS 67 | time ./dist/build/bench-insert-many/bench-insert-many 2 +RTS -N4 -A128M -RTS 68 | time ./dist/build/bench-insert-many/bench-insert-many 3 +RTS -N4 -A128M -RTS 69 | time ./dist/build/bench-insert-many/bench-insert-many 4 +RTS -N4 -A128M -RTS 70 | time ./dist/build/bench-insert-many/bench-insert-many 10 +RTS -N4 -A128M -RTS 71 | echo "=============== benchmark haskell client (executeMany) end ================" 72 | 73 | mysql -utestMySQLHaskell -DtestMySQLHaskell -e "select count(*) from insert_test" 74 | mysql -utestMySQLHaskell -DtestMySQLHaskell -e "DELETE FROM insert_test" 75 | echo "=============== start benchmark haskell client prepared =============" 76 | time ./dist/build/benchPrepared/benchPrepared 1 +RTS -N4 -A128M -RTS 77 | time ./dist/build/benchPrepared/benchPrepared 2 +RTS -N4 -A128M -RTS 78 | time ./dist/build/benchPrepared/benchPrepared 3 +RTS -N4 -A128M -RTS 79 | time ./dist/build/benchPrepared/benchPrepared 4 +RTS -N4 -A128M -RTS 80 | time ./dist/build/benchPrepared/benchPrepared 10 +RTS -N4 -A128M -RTS 81 | echo "=============== benchmark haskell client prepared end ================" 82 | 83 | mysql -utestMySQLHaskell -DtestMySQLHaskell -e "select count(*) from insert_test" 84 | mysql -utestMySQLHaskell -DtestMySQLHaskell -e "DELETE FROM insert_test" 85 | -------------------------------------------------------------------------------- /benchmark/insert/insert.sql: -------------------------------------------------------------------------------- 1 | -- Sample employee database 2 | -- Copyright (C) 2007,2008, MySQL AB 3 | 4 | USE testMySQLHaskell; 5 | 6 | CREATE TABLE employees ( 7 | emp_no INT NOT NULL, 8 | birth_date DATE NOT NULL, 9 | first_name VARCHAR(14) NOT NULL, 10 | last_name VARCHAR(16) NOT NULL, 11 | gender ENUM ('M','F') NOT NULL, 12 | hire_date DATE NOT NULL, 13 | PRIMARY KEY (emp_no) 14 | ); 15 | 16 | SELECT 'LOADING employees' as 'INFO'; 17 | source load_employees.dump ; 18 | -------------------------------------------------------------------------------- /benchmark/insert/libmysql.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | #define THREAD_NUM 4 9 | #define DBHOST "localhost" 10 | #define DBUSER "testMySQLHaskell" 11 | #define DBPASS "" 12 | #define DBPORT 3306 13 | #define DBNAME "testMySQLHaskell" 14 | #define DBSOCK NULL //"/var/lib/mysql/mysql.sock" 15 | #define DBPCNT 0 16 | 17 | typedef struct ThreadArgsST 18 | { 19 | int id; 20 | pthread_t *thread_id; 21 | } ThreadArgs; 22 | 23 | void *func(void *arg) 24 | { 25 | ThreadArgs *args = (ThreadArgs *)arg; 26 | MYSQL_RES *result; 27 | MYSQL_ROW row; 28 | unsigned int rowCounter = 0; 29 | MYSQL_FIELD *field; 30 | unsigned int i; 31 | unsigned int timeout = 3000; 32 | const char *pBegin = "BEGIN"; 33 | const char *pCommit = "COMMIT"; 34 | const char *pStatement = "INSERT INTO insert_test values (\ 35 | 0 ,\ 36 | b'1110000010101010' ,\ 37 | -128 ,\ 38 | 255 ,\ 39 | -32768 ,\ 40 | 65535 ,\ 41 | -8388608 ,\ 42 | 16777215 ,\ 43 | -2147483648 ,\ 44 | 4294967295 ,\ 45 | -9223372036854775808 ,\ 46 | 18446744073709551615 ,\ 47 | 1234567890.0123456789 ,\ 48 | 3.14159 ,\ 49 | 3.1415926535 ,\ 50 | '2016-08-08' ,\ 51 | '2016-08-08 17:25:59' ,\ 52 | '2016-08-08 17:25:59' ,\ 53 | '-199:59:59' ,\ 54 | 1999 ,\ 55 | '12345678' ,\ 56 | '韩冬真赞' ,\ 57 | '12345678' ,\ 58 | '12345678' ,\ 59 | '12345678' ,\ 60 | '韩冬真赞' ,\ 61 | '12345678' ,\ 62 | '韩冬真赞' ,\ 63 | 'foo' ,\ 64 | 'foo,bar')"; 65 | mysql_thread_init(); 66 | MYSQL *mysql = mysql_init(NULL); 67 | 68 | if (mysql == NULL) 69 | { 70 | printf("[%ld][%d]mysql init failed: %s\n", *args->thread_id, args->id, mysql_error(mysql)); 71 | return (void *)0; 72 | } 73 | 74 | mysql_options(mysql, MYSQL_OPT_CONNECT_TIMEOUT, &timeout); 75 | 76 | if (mysql_real_connect(mysql, DBHOST, DBUSER, DBPASS, DBNAME, DBPORT, DBSOCK, DBPCNT) == NULL) 77 | { 78 | printf("[%ld][%d]connect failed: %s\n", *args->thread_id, args->id, mysql_error(mysql)); 79 | mysql_close(mysql); 80 | mysql_thread_end(); 81 | return (void *)0; 82 | } 83 | if (0 != mysql_real_query(mysql, pBegin, strlen(pBegin))) 84 | { 85 | printf("[%ld][%d]query failed: %s\n", *args->thread_id, args->id, mysql_error(mysql)); 86 | mysql_close(mysql); 87 | mysql_thread_end(); 88 | return (void *)0; 89 | } 90 | for (i = 0; i < 1000; i++ ) 91 | { 92 | if (0 != mysql_real_query(mysql, pStatement, strlen(pStatement))) 93 | { 94 | printf("[%ld][%d]query failed: %s\n", *args->thread_id, args->id, mysql_error(mysql)); 95 | mysql_close(mysql); 96 | mysql_thread_end(); 97 | return (void *)0; 98 | } 99 | } 100 | if (0 != mysql_real_query(mysql, pCommit, strlen(pCommit))) 101 | { 102 | printf("[%ld][%d]query failed: %s\n", *args->thread_id, args->id, mysql_error(mysql)); 103 | mysql_close(mysql); 104 | mysql_thread_end(); 105 | return (void *)0; 106 | } 107 | mysql_close(mysql); 108 | mysql_thread_end(); 109 | return (void *)0; 110 | } 111 | 112 | int main(int argc, char *argv[]) 113 | { 114 | int thread_num; 115 | 116 | if (argc == 2) 117 | { 118 | thread_num = atoi(argv[1]); 119 | } 120 | else 121 | { 122 | thread_num = THREAD_NUM; 123 | } 124 | 125 | mysql_library_init(0, NULL, NULL); 126 | printf("argc: %d and thread_num: %d\n", argc, thread_num); 127 | 128 | do 129 | { 130 | pthread_t *pTh = new pthread_t[thread_num]; 131 | ThreadArgs *pArgs = new ThreadArgs[thread_num]; 132 | int i; 133 | 134 | for (i = 0; i < thread_num; i ++) 135 | { 136 | pArgs[i].id = i; 137 | pArgs[i].thread_id = &pTh[i]; 138 | 139 | if (0 != pthread_create(&pTh[i], NULL, func, &pArgs[i])) 140 | { 141 | printf("pthread_create failed\n"); 142 | continue; 143 | } 144 | } 145 | 146 | for (i = 0; i < thread_num; i ++) 147 | { 148 | pthread_join(pTh[i], NULL); 149 | } 150 | 151 | delete[] pTh; 152 | delete[] pArgs; 153 | } 154 | while (0); 155 | 156 | mysql_library_end(); 157 | return 0; 158 | } 159 | 160 | -------------------------------------------------------------------------------- /benchmark/insert/mysql-haskell-bench.cabal: -------------------------------------------------------------------------------- 1 | -- Initial mysql-haskell-bench.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: mysql-haskell-bench 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: winterland1989 11 | maintainer: winterland1989@gmail.com 12 | -- copyright: 13 | category: Development 14 | build-type: Simple 15 | extra-source-files: ChangeLog.md 16 | cabal-version: >=1.10 17 | 18 | library 19 | hs-source-dirs: ../../ 20 | exposed-modules: Database.MySQL.Base 21 | , Database.MySQL.TLS 22 | , Database.MySQL.OpenSSL 23 | , Database.MySQL.Protocol.Auth 24 | , Database.MySQL.Protocol.Command 25 | , Database.MySQL.Protocol.ColumnDef 26 | , Database.MySQL.Protocol.Packet 27 | , Database.MySQL.Protocol.MySQLValue 28 | , Database.MySQL.Protocol.Escape 29 | , Database.MySQL.BinLog 30 | , Database.MySQL.BinLogProtocol.BinLogEvent 31 | , Database.MySQL.BinLogProtocol.BinLogValue 32 | , Database.MySQL.BinLogProtocol.BinLogMeta 33 | 34 | 35 | other-modules: Database.MySQL.Connection 36 | , Database.MySQL.Query 37 | 38 | build-depends: base >= 4.7 && <5 39 | , monad-loops == 0.4.* 40 | , network >= 2.3 && < 3.0 41 | , io-streams >= 1.2 && < 2.0 42 | , tcp-streams == 0.5.* 43 | , wire-streams >= 0.0.2 && < 0.1 44 | , binary == 0.8.* 45 | , binary-ieee754 == 0.1.* 46 | , binary-parsers >= 0.2.1 47 | , bytestring >= 0.10.2.0 48 | , text >= 1.1 && < 1.3 49 | , cryptonite == 0.* 50 | , memory >= 0.8 51 | , time >= 1.5.0 52 | , scientific == 0.3.* 53 | , bytestring-lexing == 0.5.* 54 | , blaze-textual == 0.2.* 55 | , word24 == 1.* 56 | , tls >= 1.3.5 && <1.4 57 | , HsOpenSSL >=0.10.3 && <0.12 58 | , vector >= 0.8 59 | 60 | default-language: Haskell2010 61 | default-extensions: DeriveDataTypeable 62 | , DeriveGeneric 63 | , MultiWayIf 64 | , OverloadedStrings 65 | 66 | if os(mingw32) || os(windows) 67 | extra-libraries: eay32, ssl32 68 | else 69 | if os(osx) 70 | extra-libraries: crypto 71 | extra-lib-dirs: /usr/local/opt/openssl/lib 72 | include-dirs: /usr/local/opt/openssl/include 73 | else 74 | extra-libraries: crypto 75 | 76 | executable bench 77 | build-depends: base, mysql-haskell-bench, bytestring, io-streams, async 78 | default-language: Haskell2010 79 | hs-source-dirs: . 80 | main-is: MySQLHaskell.hs 81 | ghc-options: -O2 -threaded -rtsopts 82 | 83 | executable bench-insert-many 84 | build-depends: base, mysql-haskell-bench, bytestring, io-streams, async 85 | default-language: Haskell2010 86 | hs-source-dirs: . 87 | main-is: MySQLHaskellInsertMany.hs 88 | ghc-options: -O2 -threaded -rtsopts 89 | 90 | executable benchPrepared 91 | build-depends: base, mysql-haskell-bench, bytestring, io-streams, async, time 92 | default-language: Haskell2010 93 | hs-source-dirs: . 94 | main-is: MySQLHaskellPrepared.hs 95 | ghc-options: -O2 -threaded -rtsopts 96 | -------------------------------------------------------------------------------- /benchmark/result.numbers: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/winterland1989/mysql-haskell/87882321327c3a6e7bd1d2ae3a41b3564c078a3d/benchmark/result.numbers -------------------------------------------------------------------------------- /benchmark/result.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/winterland1989/mysql-haskell/87882321327c3a6e7bd1d2ae3a41b3564c078a3d/benchmark/result.png -------------------------------------------------------------------------------- /benchmark/select/MySQLFFI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Main where 5 | 6 | import Control.Concurrent.Async 7 | import Control.Monad 8 | import Database.MySQL.Simple 9 | import System.Environment 10 | import Data.Time.Calendar 11 | import Data.Text (Text) 12 | 13 | main :: IO () 14 | main = do 15 | args <- getArgs 16 | case args of [threadNum] -> go (read threadNum) 17 | _ -> putStrLn "No thread number provided." 18 | 19 | go :: Int -> IO () 20 | go n = void . flip mapConcurrently [1..n] $ \ _ -> do 21 | c <- connect defaultConnectInfo { connectUser = "testMySQLHaskell" 22 | , connectDatabase = "testMySQLHaskell" 23 | } 24 | 25 | putStr "total rows: " 26 | (rs :: [(Int, Day, Text, Text, Text, Day)]) <- query_ c "SELECT * FROM employees" 27 | print (length rs) 28 | 29 | 30 | 31 | 32 | 33 | 34 | -------------------------------------------------------------------------------- /benchmark/select/MySQLHaskell.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Main where 5 | 6 | import Control.Concurrent.Async 7 | import Control.Monad 8 | import Database.MySQL.Base 9 | import System.Environment 10 | import System.IO.Streams (fold) 11 | import qualified Data.ByteString as B 12 | 13 | main :: IO () 14 | main = do 15 | args <- getArgs 16 | case args of [threadNum] -> go (read threadNum) 17 | _ -> putStrLn "No thread number provided." 18 | 19 | go :: Int -> IO () 20 | go n = void . flip mapConcurrently [1..n] $ \ _ -> do 21 | c <- connect defaultConnectInfo { ciUser = "testMySQLHaskell" 22 | , ciDatabase = "testMySQLHaskell" 23 | } 24 | 25 | (fs, is) <- query_ c "SELECT * FROM employees" 26 | (rowCount :: Int) <- fold (\s _ -> s+1) 0 is 27 | putStr "field name: " 28 | forM_ fs $ \ f -> B.putStr (columnName f) >> B.putStr ", " 29 | putStr "\n" 30 | putStr "numbers of rows: " 31 | print rowCount 32 | 33 | 34 | 35 | 36 | 37 | 38 | -------------------------------------------------------------------------------- /benchmark/select/MySQLHaskellOpenSSL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Main where 5 | 6 | import Control.Concurrent.Async 7 | import Control.Monad 8 | import Database.MySQL.Base hiding (connect, connectDetail) 9 | import Database.MySQL.OpenSSL 10 | import System.Environment 11 | import System.IO.Streams (fold) 12 | import qualified Data.ByteString as B 13 | 14 | main :: IO () 15 | main = do 16 | args <- getArgs 17 | case args of [threadNum] -> go (read threadNum) 18 | _ -> putStrLn "No thread number provided." 19 | 20 | go :: Int -> IO () 21 | go n = do 22 | ctx <- makeClientSSLContext (CustomCAStore "/usr/local/var/mysql/ca.pem") 23 | void . flip mapConcurrently [1..n] $ \ _ -> do 24 | c <- connect defaultConnectInfo { ciUser = "testMySQLHaskell" 25 | , ciDatabase = "testMySQLHaskell" 26 | } 27 | (ctx, "MySQL") 28 | 29 | (fs, is) <- query_ c "SELECT * FROM employees" 30 | (rowCount :: Int) <- fold (\s _ -> s+1) 0 is 31 | putStr "field name: " 32 | forM_ fs $ \ f -> B.putStr (columnName f) >> B.putStr ", " 33 | putStr "\n" 34 | putStr "numbers of rows: " 35 | print rowCount 36 | 37 | 38 | 39 | 40 | 41 | 42 | -------------------------------------------------------------------------------- /benchmark/select/MySQLHaskellPrepared.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Main where 5 | 6 | import Control.Concurrent.Async 7 | import Control.Monad 8 | import Database.MySQL.Base 9 | import System.Environment 10 | import System.IO.Streams (fold) 11 | import qualified Data.ByteString as B 12 | 13 | main :: IO () 14 | main = do 15 | args <- getArgs 16 | case args of [threadNum] -> go (read threadNum) 17 | _ -> putStrLn "No thread number provided." 18 | 19 | go :: Int -> IO () 20 | go n = void . flip mapConcurrently [1..n] $ \ _ -> do 21 | c <- connect defaultConnectInfo { ciUser = "testMySQLHaskell" 22 | , ciDatabase = "testMySQLHaskell" 23 | } 24 | 25 | 26 | stmt <- prepareStmt c "SELECT * FROM employees" 27 | (fs, is) <- queryStmt c stmt [] 28 | (rowCount :: Int) <- fold (\s _ -> s+1) 0 is 29 | putStr "field name: " 30 | forM_ fs $ \ f -> B.putStr (columnName f) >> B.putStr ", " 31 | putStr "\n" 32 | putStr "numbers of rows: " 33 | print rowCount 34 | 35 | 36 | 37 | 38 | 39 | 40 | -------------------------------------------------------------------------------- /benchmark/select/MySQLHaskellTLS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Main where 5 | 6 | import Control.Concurrent.Async 7 | import Control.Monad 8 | import Database.MySQL.Base hiding (connect, connectDetail) 9 | import Database.MySQL.TLS 10 | import System.Environment 11 | import System.IO.Streams (fold) 12 | import qualified Data.ByteString as B 13 | 14 | main :: IO () 15 | main = do 16 | args <- getArgs 17 | case args of [threadNum] -> go (read threadNum) 18 | _ -> putStrLn "No thread number provided." 19 | 20 | go :: Int -> IO () 21 | go n = do 22 | cparams <- makeClientParams (CustomCAStore "/usr/local/var/mysql/ca.pem") 23 | 24 | void . flip mapConcurrently [1..n] $ \ _ -> do 25 | c <- connect defaultConnectInfo { ciUser = "testMySQLHaskell" 26 | , ciDatabase = "testMySQLHaskell" 27 | } 28 | (cparams, "MySQL") 29 | 30 | (fs, is) <- query_ c "SELECT * FROM employees" 31 | (rowCount :: Int) <- fold (\s _ -> s+1) 0 is 32 | putStr "field name: " 33 | forM_ fs $ \ f -> B.putStr (columnName f) >> B.putStr ", " 34 | putStr "\n" 35 | putStr "numbers of rows: " 36 | print rowCount 37 | 38 | 39 | 40 | 41 | 42 | 43 | -------------------------------------------------------------------------------- /benchmark/select/bench-nossl-noffi.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | mysql -utestMySQLHaskell -DtestMySQLHaskell -e "DROP TABLE IF EXISTS employees" 4 | mysql -utestMySQLHaskell < employees.sql 5 | 6 | g++ ./libmysql.cpp -lmysqlclient -lpthread -lz -lm -lssl -lcrypto -ldl\ 7 | -I/usr/local/opt/mysql/include -L/usr/local/opt/mysql/lib -I/usr/local/opt/openssl/include -L/usr/local/opt/openssl/lib\ 8 | -o libmysql 9 | 10 | echo "=============== start benchmark c++ client ================" 11 | time ./libmysql 1 12 | time ./libmysql 2 13 | time ./libmysql 3 14 | time ./libmysql 4 15 | time ./libmysql 10 16 | rm ./libmysql 17 | echo "=============== benchmark c++ client end ================" 18 | 19 | g++ ./libmysql_prepared.cpp -lmysqlclient -lpthread -lz -lm -lssl -lcrypto -ldl\ 20 | -I/usr/local/opt/mysql/include -L/usr/local/opt/mysql/lib -I/usr/local/opt/openssl/include -L/usr/local/opt/openssl/lib\ 21 | -o libmysql_prepared 22 | 23 | echo "=============== start benchmark c++ client prepared ================" 24 | time ./libmysql_prepared 1 25 | time ./libmysql_prepared 2 26 | time ./libmysql_prepared 3 27 | time ./libmysql_prepared 4 28 | time ./libmysql_prepared 10 29 | rm ./libmysql_prepared 30 | echo "=============== benchmark c++ client prepared end ================" 31 | 32 | cabal build 33 | echo "=============== start benchmark haskell client =============" 34 | time ./dist/build/bench/bench 1 +RTS -N4 -A128M -RTS 35 | time ./dist/build/bench/bench 2 +RTS -N4 -A128M -RTS 36 | time ./dist/build/bench/bench 3 +RTS -N4 -A128M -RTS 37 | time ./dist/build/bench/bench 4 +RTS -N4 -A128M -RTS 38 | time ./dist/build/bench/bench 10 +RTS -N4 -A128M -RTS 39 | echo "=============== benchmark haskell client end ================" 40 | 41 | echo "=============== start benchmark haskell client prepared =============" 42 | time ./dist/build/benchPrepared/benchPrepared 1 +RTS -N4 -A128M -RTS 43 | time ./dist/build/benchPrepared/benchPrepared 2 +RTS -N4 -A128M -RTS 44 | time ./dist/build/benchPrepared/benchPrepared 3 +RTS -N4 -A128M -RTS 45 | time ./dist/build/benchPrepared/benchPrepared 4 +RTS -N4 -A128M -RTS 46 | time ./dist/build/benchPrepared/benchPrepared 10 +RTS -N4 -A128M -RTS 47 | echo "=============== benchmark haskell client prepared end ================" 48 | 49 | -------------------------------------------------------------------------------- /benchmark/select/bench.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | mysql -utestMySQLHaskell -DtestMySQLHaskell -e "DROP TABLE IF EXISTS employees" 4 | mysql -utestMySQLHaskell < employees.sql 5 | 6 | g++ ./libmysql.cpp -lmysqlclient -lpthread -lz -lm -lssl -lcrypto -ldl\ 7 | -I/usr/local/opt/mysql/include -L/usr/local/opt/mysql/lib -I/usr/local/opt/openssl/include -L/usr/local/opt/openssl/lib\ 8 | -o libmysql 9 | 10 | echo "=============== start benchmark c++ client ================" 11 | time ./libmysql 1 12 | time ./libmysql 2 13 | time ./libmysql 3 14 | time ./libmysql 4 15 | time ./libmysql 10 16 | rm ./libmysql 17 | echo "=============== benchmark c++ client end ================" 18 | 19 | g++ ./libmysql_prepared.cpp -lmysqlclient -lpthread -lz -lm -lssl -lcrypto -ldl\ 20 | -I/usr/local/opt/mysql/include -L/usr/local/opt/mysql/lib -I/usr/local/opt/openssl/include -L/usr/local/opt/openssl/lib\ 21 | -o libmysql_prepared 22 | 23 | echo "=============== start benchmark c++ client prepared ================" 24 | time ./libmysql_prepared 1 25 | time ./libmysql_prepared 2 26 | time ./libmysql_prepared 3 27 | time ./libmysql_prepared 4 28 | time ./libmysql_prepared 10 29 | rm ./libmysql_prepared 30 | echo "=============== benchmark c++ client prepared end ================" 31 | 32 | cabal build 33 | echo "=============== start benchmark haskell client =============" 34 | time ./dist/build/bench/bench 1 +RTS -N4 -A128M -RTS 35 | time ./dist/build/bench/bench 2 +RTS -N4 -A128M -RTS 36 | time ./dist/build/bench/bench 3 +RTS -N4 -A128M -RTS 37 | time ./dist/build/bench/bench 4 +RTS -N4 -A128M -RTS 38 | time ./dist/build/bench/bench 10 +RTS -N4 -A128M -RTS 39 | echo "=============== benchmark haskell client end ================" 40 | 41 | echo "=============== start benchmark haskell client openssl =============" 42 | time ./dist/build/bench-openssl/bench-openssl 1 +RTS -N4 -A128M -RTS 43 | time ./dist/build/bench-openssl/bench-openssl 2 +RTS -N4 -A128M -RTS 44 | time ./dist/build/bench-openssl/bench-openssl 3 +RTS -N4 -A128M -RTS 45 | time ./dist/build/bench-openssl/bench-openssl 4 +RTS -N4 -A128M -RTS 46 | time ./dist/build/bench-openssl/bench-openssl 10 +RTS -N4 -A128M -RTS 47 | echo "=============== benchmark haskell client end openssl ================" 48 | 49 | echo "=============== start benchmark haskell client tls =============" 50 | time ./dist/build/bench-tls/bench-tls 1 +RTS -N4 -A128M -RTS 51 | time ./dist/build/bench-tls/bench-tls 2 +RTS -N4 -A128M -RTS 52 | time ./dist/build/bench-tls/bench-tls 3 +RTS -N4 -A128M -RTS 53 | time ./dist/build/bench-tls/bench-tls 4 +RTS -N4 -A128M -RTS 54 | time ./dist/build/bench-tls/bench-tls 10 +RTS -N4 -A128M -RTS 55 | echo "=============== benchmark haskell client end tls ================" 56 | 57 | echo "=============== start benchmark haskell client FFI =============" 58 | time ./dist/build/benchFFI/benchFFI 1 +RTS -N4 -A128M -RTS 59 | time ./dist/build/benchFFI/benchFFI 2 +RTS -N4 -A128M -RTS 60 | time ./dist/build/benchFFI/benchFFI 3 +RTS -N4 -A128M -RTS 61 | time ./dist/build/benchFFI/benchFFI 4 +RTS -N4 -A128M -RTS 62 | time ./dist/build/benchFFI/benchFFI 10 +RTS -N4 -A128M -RTS 63 | echo "=============== benchmark haskell client FFI end ================" 64 | 65 | echo "=============== start benchmark haskell client prepared =============" 66 | time ./dist/build/benchPrepared/benchPrepared 1 +RTS -N4 -A128M -RTS 67 | time ./dist/build/benchPrepared/benchPrepared 2 +RTS -N4 -A128M -RTS 68 | time ./dist/build/benchPrepared/benchPrepared 3 +RTS -N4 -A128M -RTS 69 | time ./dist/build/benchPrepared/benchPrepared 4 +RTS -N4 -A128M -RTS 70 | time ./dist/build/benchPrepared/benchPrepared 10 +RTS -N4 -A128M -RTS 71 | echo "=============== benchmark haskell client prepared end ================" 72 | 73 | -------------------------------------------------------------------------------- /benchmark/select/employees.sql: -------------------------------------------------------------------------------- 1 | -- Sample employee database 2 | -- Copyright (C) 2007,2008, MySQL AB 3 | 4 | USE testMySQLHaskell; 5 | 6 | CREATE TABLE employees ( 7 | emp_no INT NOT NULL, 8 | birth_date DATE NOT NULL, 9 | first_name VARCHAR(14) NOT NULL, 10 | last_name VARCHAR(16) NOT NULL, 11 | gender ENUM ('M','F') NOT NULL, 12 | hire_date DATE NOT NULL, 13 | PRIMARY KEY (emp_no) 14 | ); 15 | 16 | SELECT 'LOADING employees' as 'INFO'; 17 | source load_employees.dump ; 18 | -------------------------------------------------------------------------------- /benchmark/select/libmysql.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | #define THREAD_NUM 4 9 | #define DBHOST "127.0.0.1" 10 | #define DBUSER "testMySQLHaskell" 11 | #define DBPASS "" 12 | #define DBPORT 3306 13 | #define DBNAME "testMySQLHaskell" 14 | #define DBSOCK NULL //"/var/lib/mysql/mysql.sock" 15 | #define DBPCNT 0 16 | 17 | typedef struct ThreadArgsST 18 | { 19 | int id; 20 | pthread_t *thread_id; 21 | } ThreadArgs; 22 | 23 | void *func(void *arg) 24 | { 25 | ThreadArgs *args = (ThreadArgs *)arg; 26 | MYSQL_RES *result; 27 | MYSQL_ROW row; 28 | unsigned int rowCounter = 0; 29 | MYSQL_FIELD *field; 30 | unsigned int i; 31 | unsigned int timeout = 3000; 32 | const char *pStatement = "SELECT * FROM employees"; 33 | mysql_thread_init(); 34 | MYSQL *mysql = mysql_init(NULL); 35 | 36 | if (mysql == NULL) 37 | { 38 | printf("[%ld][%d]mysql init failed: %s\n", *args->thread_id, args->id, mysql_error(mysql)); 39 | return (void *)0; 40 | } 41 | 42 | mysql_options(mysql, MYSQL_OPT_CONNECT_TIMEOUT, &timeout); 43 | 44 | if (mysql_real_connect(mysql, DBHOST, DBUSER, DBPASS, DBNAME, DBPORT, DBSOCK, DBPCNT) == NULL) 45 | { 46 | printf("[%ld][%d]connect failed: %s\n", *args->thread_id, args->id, mysql_error(mysql)); 47 | mysql_close(mysql); 48 | mysql_thread_end(); 49 | return (void *)0; 50 | } 51 | 52 | if (0 != mysql_real_query(mysql, pStatement, strlen(pStatement))) 53 | { 54 | printf("[%ld][%d]query failed: %s\n", *args->thread_id, args->id, mysql_error(mysql)); 55 | mysql_close(mysql); 56 | mysql_thread_end(); 57 | return (void *)0; 58 | } 59 | 60 | result = mysql_store_result(mysql); 61 | 62 | if (result == NULL) 63 | { 64 | printf("[%ld][%d]fetch result failed: %s\n", *args->thread_id, args->id, mysql_error(mysql)); 65 | mysql_close(mysql); 66 | mysql_thread_end(); 67 | return (void *)0; 68 | } 69 | 70 | printf("field name: "); 71 | while (NULL != (field = mysql_fetch_field(result))) 72 | { 73 | printf(" %s, ", field->name); 74 | } 75 | 76 | while (NULL != (row = mysql_fetch_row(result))) 77 | { 78 | rowCounter++; 79 | unsigned long *lengths; 80 | lengths = mysql_fetch_lengths(result); 81 | 82 | } 83 | printf("loop through result, total %d rows\n", rowCounter); 84 | 85 | mysql_free_result(result); 86 | mysql_close(mysql); 87 | mysql_thread_end(); 88 | return (void *)0; 89 | } 90 | 91 | int main(int argc, char *argv[]) 92 | { 93 | int thread_num; 94 | 95 | if (argc == 2) 96 | { 97 | thread_num = atoi(argv[1]); 98 | } 99 | else 100 | { 101 | thread_num = THREAD_NUM; 102 | } 103 | 104 | mysql_library_init(0, NULL, NULL); 105 | printf("argc: %d and thread_num: %d\n", argc, thread_num); 106 | 107 | do 108 | { 109 | pthread_t *pTh = new pthread_t[thread_num]; 110 | ThreadArgs *pArgs = new ThreadArgs[thread_num]; 111 | int i; 112 | 113 | for (i = 0; i < thread_num; i ++) 114 | { 115 | pArgs[i].id = i; 116 | pArgs[i].thread_id = &pTh[i]; 117 | 118 | if (0 != pthread_create(&pTh[i], NULL, func, &pArgs[i])) 119 | { 120 | printf("pthread_create failed\n"); 121 | continue; 122 | } 123 | } 124 | 125 | for (i = 0; i < thread_num; i ++) 126 | { 127 | pthread_join(pTh[i], NULL); 128 | } 129 | 130 | delete[] pTh; 131 | delete[] pArgs; 132 | } 133 | while (0); 134 | 135 | mysql_library_end(); 136 | return 0; 137 | } 138 | 139 | -------------------------------------------------------------------------------- /benchmark/select/libmysql_prepared.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | #define THREAD_NUM 4 9 | #define DBHOST "127.0.0.1" 10 | #define DBUSER "testMySQLHaskell" 11 | #define DBPASS "" 12 | #define DBPORT 3306 13 | #define DBNAME "testMySQLHaskell" 14 | #define DBSOCK NULL //"/var/lib/mysql/mysql.sock" 15 | #define DBPCNT 0 16 | #define STRING_SIZE 50 17 | 18 | typedef struct ThreadArgsST 19 | { 20 | int id; 21 | pthread_t *thread_id; 22 | } ThreadArgs; 23 | 24 | void *func(void *arg) 25 | { 26 | ThreadArgs *args = (ThreadArgs *)arg; 27 | MYSQL_ROW row; 28 | unsigned int rowCounter = 0; 29 | MYSQL_FIELD *field; 30 | unsigned int i; 31 | unsigned int timeout = 3000; 32 | const char *pStatement = "SELECT * FROM employees"; 33 | mysql_thread_init(); 34 | MYSQL *mysql = mysql_init(NULL); 35 | MYSQL_STMT *stmt; 36 | MYSQL_BIND bind[6]; 37 | MYSQL_RES *prepare_meta_result; 38 | short small_data; 39 | int int_data; 40 | char str_data[STRING_SIZE]; 41 | char str_data2[STRING_SIZE]; 42 | my_bool is_null[6]; 43 | my_bool error[6]; 44 | MYSQL_TIME ts; 45 | unsigned long length[6]; 46 | 47 | if (mysql == NULL) 48 | { 49 | printf("[%ld][%d]mysql init failed: %s\n", *args->thread_id, args->id, mysql_error(mysql)); 50 | return (void *)0; 51 | } 52 | 53 | mysql_options(mysql, MYSQL_OPT_CONNECT_TIMEOUT, &timeout); 54 | 55 | if (mysql_real_connect(mysql, DBHOST, DBUSER, DBPASS, DBNAME, DBPORT, DBSOCK, DBPCNT) == NULL) 56 | { 57 | printf("[%ld][%d]connect failed: %s\n", *args->thread_id, args->id, mysql_error(mysql)); 58 | mysql_close(mysql); 59 | mysql_thread_end(); 60 | return (void *)0; 61 | } 62 | 63 | stmt = mysql_stmt_init(mysql); 64 | if (0 != mysql_stmt_prepare(stmt, pStatement, 23)) 65 | { 66 | printf("[%ld][%d]prepare statement failed: %s\n", *args->thread_id, args->id, mysql_error(mysql)); 67 | mysql_close(mysql); 68 | mysql_thread_end(); 69 | return (void *)0; 70 | } 71 | 72 | prepare_meta_result = mysql_stmt_result_metadata(stmt); 73 | if (!prepare_meta_result) 74 | { 75 | printf( "mysql_stmt_result_metadata(), returned no meta information\n"); 76 | printf(" %s\n", mysql_stmt_error(stmt)); 77 | exit(0); 78 | } 79 | 80 | if (0 != mysql_stmt_execute(stmt)) 81 | { 82 | printf("[%ld][%d]query failed: %s\n", *args->thread_id, args->id, mysql_error(mysql)); 83 | mysql_close(mysql); 84 | mysql_thread_end(); 85 | return (void *)0; 86 | } 87 | 88 | /* Bind the result buffers for all 4 columns before fetching them */ 89 | 90 | memset(bind, 0, sizeof(bind)); 91 | 92 | bind[0].buffer_type= MYSQL_TYPE_LONG; 93 | bind[0].buffer= (char *)&int_data; 94 | bind[0].is_null= &is_null[0]; 95 | bind[0].length= &length[0]; 96 | bind[0].error= &error[0]; 97 | 98 | /* TIMESTAMP COLUMN */ 99 | bind[1].buffer_type= MYSQL_TYPE_DATE; 100 | bind[1].buffer= (char *)&ts; 101 | bind[1].is_null= &is_null[1]; 102 | bind[1].length= &length[1]; 103 | bind[1].error= &error[1]; 104 | 105 | /* STRING COLUMN */ 106 | bind[2].buffer_type= MYSQL_TYPE_STRING; 107 | bind[2].buffer= (char *)str_data; 108 | bind[2].buffer_length= STRING_SIZE; 109 | bind[2].is_null= &is_null[2]; 110 | bind[2].length= &length[2]; 111 | bind[2].error= &error[2]; 112 | 113 | /* STRING COLUMN */ 114 | bind[3].buffer_type= MYSQL_TYPE_STRING; 115 | bind[3].buffer= (char *)str_data; 116 | bind[3].buffer_length= STRING_SIZE; 117 | bind[3].is_null= &is_null[3]; 118 | bind[3].length= &length[3]; 119 | bind[3].error= &error[3]; 120 | 121 | /* STRING COLUMN */ 122 | bind[4].buffer_type= MYSQL_TYPE_STRING; 123 | bind[4].buffer= (char *)str_data; 124 | bind[4].buffer_length= STRING_SIZE; 125 | bind[4].is_null= &is_null[4]; 126 | bind[4].length= &length[4]; 127 | bind[4].error= &error[4]; 128 | 129 | /* TIMESTAMP COLUMN */ 130 | bind[5].buffer_type= MYSQL_TYPE_DATE; 131 | bind[5].buffer= (char *)&ts; 132 | bind[5].is_null= &is_null[5]; 133 | bind[5].length= &length[5]; 134 | bind[5].error= &error[5]; 135 | 136 | /* Bind the result buffers */ 137 | if (mysql_stmt_bind_result(stmt, bind)) 138 | { 139 | printf( " mysql_stmt_bind_result() failed\n"); 140 | printf( " %s\n", mysql_stmt_error(stmt)); 141 | exit(0); 142 | } 143 | mysql_stmt_store_result(stmt); 144 | 145 | printf("field name: "); 146 | while (NULL != (field = mysql_fetch_field(prepare_meta_result))) 147 | { 148 | printf(" %s, ", field->name); 149 | } 150 | 151 | while (!mysql_stmt_fetch(stmt)) 152 | { 153 | rowCounter++; 154 | 155 | } 156 | printf("loop through result, total %d rows\n", rowCounter); 157 | 158 | mysql_free_result(prepare_meta_result); 159 | mysql_close(mysql); 160 | mysql_thread_end(); 161 | return (void *)0; 162 | } 163 | 164 | int main(int argc, char *argv[]) 165 | { 166 | int thread_num; 167 | 168 | if (argc == 2) 169 | { 170 | thread_num = atoi(argv[1]); 171 | } 172 | else 173 | { 174 | thread_num = THREAD_NUM; 175 | } 176 | 177 | mysql_library_init(0, NULL, NULL); 178 | printf("argc: %d and thread_num: %d\n", argc, thread_num); 179 | 180 | do 181 | { 182 | pthread_t *pTh = new pthread_t[thread_num]; 183 | ThreadArgs *pArgs = new ThreadArgs[thread_num]; 184 | int i; 185 | 186 | for (i = 0; i < thread_num; i ++) 187 | { 188 | pArgs[i].id = i; 189 | pArgs[i].thread_id = &pTh[i]; 190 | 191 | if (0 != pthread_create(&pTh[i], NULL, func, &pArgs[i])) 192 | { 193 | printf("pthread_create failed\n"); 194 | continue; 195 | } 196 | } 197 | 198 | for (i = 0; i < thread_num; i ++) 199 | { 200 | pthread_join(pTh[i], NULL); 201 | } 202 | 203 | delete[] pTh; 204 | delete[] pArgs; 205 | } 206 | while (0); 207 | 208 | mysql_library_end(); 209 | return 0; 210 | } 211 | 212 | -------------------------------------------------------------------------------- /benchmark/select/mysql-haskell-bench.cabal: -------------------------------------------------------------------------------- 1 | -- Initial mysql-haskell-bench.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: mysql-haskell-bench 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: winterland1989 11 | maintainer: winterland1989@gmail.com 12 | -- copyright: 13 | category: Development 14 | build-type: Simple 15 | extra-source-files: ChangeLog.md 16 | cabal-version: >=1.10 17 | 18 | library 19 | hs-source-dirs: ../../ 20 | exposed-modules: Database.MySQL.Base 21 | , Database.MySQL.TLS 22 | , Database.MySQL.OpenSSL 23 | , Database.MySQL.Protocol.Auth 24 | , Database.MySQL.Protocol.Command 25 | , Database.MySQL.Protocol.ColumnDef 26 | , Database.MySQL.Protocol.Packet 27 | , Database.MySQL.Protocol.MySQLValue 28 | , Database.MySQL.Protocol.Escape 29 | , Database.MySQL.BinLog 30 | , Database.MySQL.BinLogProtocol.BinLogEvent 31 | , Database.MySQL.BinLogProtocol.BinLogValue 32 | , Database.MySQL.BinLogProtocol.BinLogMeta 33 | 34 | other-modules: Database.MySQL.Connection 35 | , Database.MySQL.Query 36 | 37 | build-depends: base >=4.7 && <5 38 | , monad-loops == 0.4.* 39 | , network >= 2.3 && < 3.0 40 | , io-streams >= 1.2 && < 2.0 41 | , tcp-streams == 0.5.* 42 | , wire-streams >= 0.1 43 | , binary == 0.8.* 44 | , binary-ieee754 == 0.1.* 45 | , binary-parsers >= 0.2.1 46 | , bytestring >= 0.10.2.0 47 | , text >= 1.1 && < 1.3 48 | , cryptonite == 0.* 49 | , memory >= 0.8 50 | , time >= 1.5.0 51 | , scientific == 0.3.* 52 | , bytestring-lexing == 0.5.* 53 | , blaze-textual == 0.2.* 54 | , word24 == 1.* 55 | , tls >=1.3.5 && < 1.4 56 | , HsOpenSSL >=0.10.3 && <0.12 57 | , vector >= 0.8 58 | 59 | default-language: Haskell2010 60 | default-extensions: DeriveDataTypeable 61 | , DeriveGeneric 62 | , MultiWayIf 63 | , OverloadedStrings 64 | 65 | if os(mingw32) || os(windows) 66 | extra-libraries: eay32, ssl32 67 | else 68 | if os(osx) 69 | extra-libraries: crypto 70 | extra-lib-dirs: /usr/local/opt/openssl/lib 71 | include-dirs: /usr/local/opt/openssl/include 72 | else 73 | extra-libraries: crypto 74 | 75 | executable bench 76 | build-depends: base, mysql-haskell-bench, bytestring, io-streams, async 77 | default-language: Haskell2010 78 | hs-source-dirs: . 79 | main-is: MySQLHaskell.hs 80 | ghc-options: -O2 -threaded -rtsopts 81 | 82 | executable bench-tls 83 | build-depends: base, mysql-haskell-bench, bytestring, io-streams, async, tcp-streams 84 | default-language: Haskell2010 85 | hs-source-dirs: . 86 | main-is: MySQLHaskellTLS.hs 87 | ghc-options: -O2 -threaded -rtsopts 88 | 89 | executable bench-openssl 90 | build-depends: base, mysql-haskell-bench, bytestring, io-streams, async, tcp-streams 91 | default-language: Haskell2010 92 | hs-source-dirs: . 93 | main-is: MySQLHaskellOpenSSL.hs 94 | ghc-options: -O2 -threaded -rtsopts 95 | 96 | executable benchPrepared 97 | build-depends: base, mysql-haskell-bench, bytestring, io-streams, async 98 | default-language: Haskell2010 99 | hs-source-dirs: . 100 | main-is: MySQLHaskellPrepared.hs 101 | ghc-options: -O2 -threaded -rtsopts 102 | 103 | executable benchFFI 104 | build-depends: base, async, mysql, text, mysql-simple, time 105 | default-language: Haskell2010 106 | hs-source-dirs: . 107 | main-is: MySQLFFI.hs 108 | ghc-options: -O2 -threaded -rtsopts 109 | -------------------------------------------------------------------------------- /binary-parser-bench/Bench.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main (main) where 4 | 5 | import Criterion.Main 6 | import qualified Aeson 7 | import qualified AesonBP 8 | import qualified HttpReq 9 | import Data.List 10 | 11 | main :: IO () 12 | main = do 13 | http <- HttpReq.headers 14 | 15 | putStrLn "start benchmark http request parser" 16 | 17 | defaultMain http 18 | 19 | putStrLn "start benchmark JSON parser" 20 | 21 | aeson <- Aeson.aeson 22 | aesonbp <- AesonBP.aeson 23 | aesonLazy <- Aeson.aesonLazy 24 | aesonbpLazy <- AesonBP.aesonLazy 25 | 26 | (defaultMain . concat . transpose) [ aeson, aesonbp, aesonLazy, aesonbpLazy ] 27 | -------------------------------------------------------------------------------- /binary-parser-bench/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | module Common ( 5 | chunksOf 6 | , pathTo 7 | , rechunkBS 8 | , rechunkT 9 | ) where 10 | 11 | import Control.DeepSeq (NFData(rnf)) 12 | import System.Directory (doesDirectoryExist) 13 | import System.FilePath (()) 14 | import qualified Data.ByteString as B 15 | import qualified Data.ByteString.Lazy as BL 16 | import qualified Data.Text as T 17 | import qualified Data.Text.Lazy as TL 18 | 19 | #if !MIN_VERSION_bytestring(0,10,0) 20 | import Data.ByteString.Internal (ByteString(..)) 21 | 22 | instance NFData ByteString where 23 | rnf (PS _ _ _) = () 24 | #endif 25 | 26 | chunksOf :: Int -> [a] -> [[a]] 27 | chunksOf k = go 28 | where go xs = case splitAt k xs of 29 | ([],_) -> [] 30 | (y, ys) -> y : go ys 31 | 32 | rechunkBS :: Int -> B.ByteString -> BL.ByteString 33 | rechunkBS n = BL.fromChunks . map B.pack . chunksOf n . B.unpack 34 | 35 | rechunkT :: Int -> T.Text -> TL.Text 36 | rechunkT n = TL.fromChunks . map T.pack . chunksOf n . T.unpack 37 | 38 | pathTo :: String -> IO FilePath 39 | pathTo wat = do 40 | exists <- doesDirectoryExist "bench" 41 | return $ if exists 42 | then "bench" wat 43 | else wat 44 | -------------------------------------------------------------------------------- /binary-parser-bench/HttpReq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module HttpReq (headers) where 4 | 5 | import Common (pathTo, rechunkBS) 6 | import Control.Applicative 7 | import Criterion.Main (bench, bgroup, nf, nfIO) 8 | import Control.DeepSeq (NFData(..)) 9 | import Criterion.Types (Benchmark) 10 | import Network.Wai.Handler.Warp.RequestHeader (parseHeaderLines) 11 | import Data.ByteString.Internal (c2w, w2c) 12 | import qualified Data.Attoparsec.ByteString as AP 13 | import qualified Data.Attoparsec.ByteString.Char8 as APC 14 | import qualified Data.ByteString.Char8 as BC 15 | import qualified Data.Binary.Parser as BP 16 | import qualified Data.Binary.Parser.Char8 as BPC 17 | import Network.HTTP.Types.Version (HttpVersion, http11) 18 | import qualified Scanner as SC 19 | 20 | headers :: IO [Benchmark] 21 | headers = do 22 | req <- BC.readFile =<< pathTo "http-request.txt" 23 | return [ 24 | bench "http-req/attoparsec" $ nf (AP.parseOnly attoRequest) req 25 | , bench "http-req/binary-parsers" $ nf (BP.parseOnly bpRequest) req 26 | , bench "http-req/scanner" $ nf (SC.scanOnly scRequest) req 27 | , bench "http-req/warp" $ nfIO (parseHeaderLines (BC.lines req)) 28 | ] 29 | 30 | -------------------------------------------------------------------------------- 31 | 32 | instance NFData HttpVersion where 33 | rnf !_ = () 34 | 35 | attoHeader = do 36 | name <- APC.takeWhile1 (APC.inClass "a-zA-Z0-9_-") <* APC.char ':' <* APC.skipSpace 37 | body <- attoBodyLine 38 | return (name, body) 39 | 40 | attoBodyLine = APC.takeTill (\c -> c == '\r' || c == '\n') <* APC.endOfLine 41 | 42 | attoReqLine = do 43 | m <- (APC.takeTill APC.isSpace <* APC.char ' ') 44 | (p,q) <- BC.break (=='?') <$> (APC.takeTill APC.isSpace <* APC.char ' ') 45 | v <- attoHttpVersion 46 | return (m,p,q,v) 47 | 48 | attoHttpVersion = http11 <$ APC.string "HTTP/1.1" 49 | 50 | attoRequest = (,) <$> (attoReqLine <* APC.endOfLine) <*> attoManyHeader 51 | 52 | attoManyHeader = do 53 | c <- APC.peekChar' 54 | if c == '\r' || c == '\n' 55 | then return [] 56 | 57 | else (:) <$> attoHeader <*> attoManyHeader 58 | 59 | -------------------------------------------------------------------------------- 60 | 61 | bpHeader = do 62 | name <- BPC.takeWhile1 isHeaderChar <* BPC.char ':' <* BP.skipSpaces 63 | body <- bpBodyLine 64 | return (name, body) 65 | where 66 | isHeaderChar c = ('a' <= c && c <= 'z') 67 | || ('A' <= c && c <= 'Z') 68 | || ('0' <= c && c <= '0') 69 | || c == '_' || c == '-' 70 | 71 | bpBodyLine = BPC.takeTill (\c -> c == '\r' || c == '\n') <* BP.endOfLine 72 | 73 | bpReqLine = do 74 | m <- (BPC.takeTill BPC.isSpace <* BPC.char ' ') 75 | (p,q) <- BC.break (=='?') <$> (BPC.takeTill BPC.isSpace <* BPC.char ' ') 76 | v <- bpHttpVersion 77 | return (m,p,q,v) 78 | 79 | bpHttpVersion = http11 <$ BP.string "HTTP/1.1" 80 | 81 | bpRequest = (,) <$> (bpReqLine <* BP.endOfLine) <*> bpManyHeader 82 | 83 | bpManyHeader = do 84 | c <- BPC.peek 85 | if c == '\r' || c == '\n' 86 | then return [] 87 | else (:) <$> bpHeader <*> bpManyHeader 88 | 89 | -------------------------------------------------------------------------------- 90 | 91 | scHeader = do 92 | name <- takeWhile1 (isHeaderChar . w2c) <* SC.char8 ':' <* SC.skipSpace 93 | body <- scBodyLine 94 | return (name, body) 95 | where 96 | isHeaderChar c = ('a' <= c && c <= 'z') 97 | || ('A' <= c && c <= 'Z') 98 | || ('0' <= c && c <= '0') 99 | || c == '_' || c == '-' 100 | 101 | takeWhile1 p = do 102 | bs <- SC.takeWhile p 103 | if BC.null bs then fail "takeWhile1" else return bs 104 | 105 | scEndOfLine = do -- scanner doesn't provide endOfLine, so we roll one here 106 | w <- SC.anyWord8 107 | case w of 108 | 10 -> return () 109 | 13 -> SC.word8 10 110 | _ -> fail "endOfLine" 111 | {-# INLINE scEndOfLine #-} 112 | 113 | scBodyLine = SC.takeWhile (\w -> let c = w2c w in c /= '\r' && c /= '\n') <* scEndOfLine 114 | 115 | scReqLine = do 116 | m <- (SC.takeWhile (not . BP.isSpace) <* SC.char8 ' ') 117 | (p,q) <- BC.break (=='?') <$> (SC.takeWhile (not . BP.isSpace) <* SC.char8 ' ') 118 | v <- scHttpVersion 119 | return (m,p,q,v) 120 | 121 | scHttpVersion = http11 <$ SC.string "HTTP/1.1" 122 | 123 | scRequest = (,) <$> (scReqLine <* scEndOfLine) <*> scManyHeader 124 | 125 | scManyHeader = do 126 | w <- SC.lookAhead 127 | case w of 128 | Just w' -> do 129 | let c = w2c w' 130 | if c == '\r' || c == '\n' 131 | then return [] 132 | else (:) <$> scHeader <*> scManyHeader 133 | _ -> fail "scManyHeader" 134 | -------------------------------------------------------------------------------- /binary-parser-bench/Network/Wai/Handler/Warp/ReadInt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE MagicHash #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | 5 | -- Copyright : Erik de Castro Lopo 6 | -- License : BSD3 7 | 8 | module Network.Wai.Handler.Warp.ReadInt ( 9 | readInt 10 | , readInt64 11 | ) where 12 | 13 | -- This function lives in its own file because the MagicHash pragma interacts 14 | -- poorly with the CPP pragma. 15 | 16 | import Data.ByteString (ByteString) 17 | import qualified Data.ByteString as S 18 | import Data.Int (Int64) 19 | import GHC.Prim 20 | import GHC.Types 21 | import GHC.Word 22 | 23 | {-# INLINE readInt #-} 24 | readInt :: Integral a => ByteString -> a 25 | readInt bs = fromIntegral $ readInt64 bs 26 | 27 | -- This function is used to parse the Content-Length field of HTTP headers and 28 | -- is a performance hot spot. It should only be replaced with something 29 | -- significantly and provably faster. 30 | -- 31 | -- It needs to be able work correctly on 32 bit CPUs for file sizes > 2G so we 32 | -- use Int64 here and then make a generic 'readInt' that allows conversion to 33 | -- Int and Integer. 34 | 35 | {-# NOINLINE readInt64 #-} 36 | readInt64 :: ByteString -> Int64 37 | readInt64 bs = S.foldl' (\ !i !c -> i * 10 + fromIntegral (mhDigitToInt c)) 0 38 | $ S.takeWhile isDigit bs 39 | 40 | data Table = Table !Addr# 41 | 42 | {-# NOINLINE mhDigitToInt #-} 43 | mhDigitToInt :: Word8 -> Int 44 | mhDigitToInt (W8# i) = I# (word2Int# (indexWord8OffAddr# addr (word2Int# i))) 45 | where 46 | !(Table addr) = table 47 | table :: Table 48 | table = Table 49 | "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ 50 | \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ 51 | \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ 52 | \\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x00\x00\x00\x00\x00\x00\ 53 | \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ 54 | \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ 55 | \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ 56 | \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ 57 | \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ 58 | \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ 59 | \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ 60 | \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ 61 | \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ 62 | \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ 63 | \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ 64 | \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# 65 | 66 | isDigit :: Word8 -> Bool 67 | isDigit w = w >= 48 && w <= 57 68 | -------------------------------------------------------------------------------- /binary-parser-bench/Network/Wai/Handler/Warp/RequestHeader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | 5 | module Network.Wai.Handler.Warp.RequestHeader ( 6 | parseHeaderLines 7 | , parseByteRanges 8 | ) where 9 | 10 | import Control.Exception (Exception, throwIO) 11 | import Control.Monad (when) 12 | import Data.Typeable (Typeable) 13 | import qualified Data.ByteString as S 14 | import qualified Data.ByteString.Char8 as B (unpack, readInteger) 15 | import Data.ByteString.Internal (ByteString(..), memchr) 16 | import qualified Data.CaseInsensitive as CI 17 | import Data.Word (Word8) 18 | import Foreign.ForeignPtr (withForeignPtr) 19 | import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr) 20 | import Foreign.Storable (peek) 21 | import qualified Network.HTTP.Types as H 22 | -- import Network.Wai.Handler.Warp.Types 23 | import qualified Network.HTTP.Types.Header as HH 24 | -- $setup 25 | -- >>> :set -XOverloadedStrings 26 | 27 | data InvalidRequest = NotEnoughLines [String] 28 | | BadFirstLine String 29 | | NonHttp 30 | | IncompleteHeaders 31 | | ConnectionClosedByPeer 32 | | OverLargeHeader 33 | deriving (Eq, Typeable, Show) 34 | 35 | instance Exception InvalidRequest 36 | 37 | ---------------------------------------------------------------- 38 | 39 | parseHeaderLines :: [ByteString] 40 | -> IO (H.Method 41 | ,ByteString -- Path 42 | ,ByteString -- Path, parsed 43 | ,ByteString -- Query 44 | ,H.HttpVersion 45 | ,H.RequestHeaders 46 | ) 47 | parseHeaderLines [] = throwIO $ NotEnoughLines [] 48 | parseHeaderLines (firstLine:otherLines) = do 49 | (method, path', query, httpversion) <- parseRequestLine firstLine 50 | let path = H.extractPath path' 51 | hdr = map parseHeader otherLines 52 | return (method, path', path, query, httpversion, hdr) 53 | 54 | ---------------------------------------------------------------- 55 | 56 | -- | 57 | -- 58 | -- >>> parseRequestLine "GET / HTTP/1.1" 59 | -- ("GET","/","",HTTP/1.1) 60 | -- >>> parseRequestLine "POST /cgi/search.cgi?key=foo HTTP/1.0" 61 | -- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0) 62 | -- >>> parseRequestLine "GET " 63 | -- *** Exception: Warp: Invalid first line of request: "GET " 64 | -- >>> parseRequestLine "GET /NotHTTP UNKNOWN/1.1" 65 | -- *** Exception: Warp: Request line specified a non-HTTP request 66 | parseRequestLine :: ByteString 67 | -> IO (H.Method 68 | ,ByteString -- Path 69 | ,ByteString -- Query 70 | ,H.HttpVersion) 71 | parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do 72 | when (len < 14) $ throwIO baderr 73 | let methodptr = ptr `plusPtr` off 74 | limptr = methodptr `plusPtr` len 75 | lim0 = fromIntegral len 76 | 77 | pathptr0 <- memchr methodptr 32 lim0 -- ' ' 78 | when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $ 79 | throwIO baderr 80 | let pathptr = pathptr0 `plusPtr` 1 81 | lim1 = fromIntegral (limptr `minusPtr` pathptr0) 82 | 83 | httpptr0 <- memchr pathptr 32 lim1 -- ' ' 84 | when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $ 85 | throwIO baderr 86 | let httpptr = httpptr0 `plusPtr` 1 87 | lim2 = fromIntegral (httpptr0 `minusPtr` pathptr) 88 | 89 | checkHTTP httpptr 90 | !hv <- httpVersion httpptr 91 | queryptr <- memchr pathptr 63 lim2 -- '?' 92 | 93 | let !method = bs ptr methodptr pathptr0 94 | !path 95 | | queryptr == nullPtr = bs ptr pathptr httpptr0 96 | | otherwise = bs ptr pathptr queryptr 97 | !query 98 | | queryptr == nullPtr = S.empty 99 | | otherwise = bs ptr queryptr httpptr0 100 | 101 | return (method,path,query,hv) 102 | where 103 | baderr = BadFirstLine $ B.unpack requestLine 104 | check :: Ptr Word8 -> Int -> Word8 -> IO () 105 | check p n w = do 106 | w0 <- peek $ p `plusPtr` n 107 | when (w0 /= w) $ throwIO NonHttp 108 | checkHTTP httpptr = do 109 | check httpptr 0 72 -- 'H' 110 | check httpptr 1 84 -- 'T' 111 | check httpptr 2 84 -- 'T' 112 | check httpptr 3 80 -- 'P' 113 | check httpptr 4 47 -- '/' 114 | check httpptr 6 46 -- '.' 115 | httpVersion httpptr = do 116 | major <- peek $ httpptr `plusPtr` 5 117 | minor <- peek $ httpptr `plusPtr` 7 118 | return $ if major == (49 :: Word8) && minor == (49 :: Word8) then 119 | H.http11 120 | else 121 | H.http10 122 | bs ptr p0 p1 = PS fptr o l 123 | where 124 | o = p0 `minusPtr` ptr 125 | l = p1 `minusPtr` p0 126 | 127 | ---------------------------------------------------------------- 128 | 129 | -- | 130 | -- 131 | -- >>> parseHeader "Content-Length:47" 132 | -- ("Content-Length","47") 133 | -- >>> parseHeader "Accept-Ranges: bytes" 134 | -- ("Accept-Ranges","bytes") 135 | -- >>> parseHeader "Host: example.com:8080" 136 | -- ("Host","example.com:8080") 137 | -- >>> parseHeader "NoSemiColon" 138 | -- ("NoSemiColon","") 139 | 140 | parseHeader :: ByteString -> H.Header 141 | parseHeader s = 142 | let (k, rest) = S.break (== 58) s -- ':' 143 | rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest 144 | in (CI.mk k, rest') 145 | 146 | parseByteRanges :: S.ByteString -> Maybe HH.ByteRanges 147 | parseByteRanges bs1 = do 148 | bs2 <- stripPrefix "bytes=" bs1 149 | (r, bs3) <- range bs2 150 | ranges (r:) bs3 151 | where 152 | range bs2 = 153 | case stripPrefix "-" bs2 of 154 | Just bs3 -> do 155 | (i, bs4) <- B.readInteger bs3 156 | Just (HH.ByteRangeSuffix i, bs4) 157 | Nothing -> do 158 | (i, bs3) <- B.readInteger bs2 159 | bs4 <- stripPrefix "-" bs3 160 | case B.readInteger bs4 of 161 | Nothing -> Just (HH.ByteRangeFrom i, bs4) 162 | Just (j, bs5) -> Just (HH.ByteRangeFromTo i j, bs5) 163 | ranges front bs3 = 164 | case stripPrefix "," bs3 of 165 | Nothing -> Just (front []) 166 | Just bs4 -> do 167 | (r, bs5) <- range bs4 168 | ranges (front . (r:)) bs5 169 | 170 | stripPrefix x y 171 | | x `S.isPrefixOf` y = Just (S.drop (S.length x) y) 172 | | otherwise = Nothing 173 | -------------------------------------------------------------------------------- /binary-parser-bench/http-request.txt: -------------------------------------------------------------------------------- 1 | GET / HTTP/1.1 2 | Host: twitter.com 3 | Accept: text/html, application/xhtml+xml, application/xml; q=0.9, image/webp, */*; q=0.8 4 | Accept-Encoding: gzip,deflate,sdch 5 | Accept-Language: en-GB,en-US;q=0.8,en;q=0.6 6 | Cache-Control: max-age=0 7 | Cookie: guest_id=v1%3A139; _twitter_sess=BAh7CSIKZmxhc2hJQz-e1e1; __utma=43838368.452555194.1399611824.1; __utmb=43838368; __utmc=43838368; __utmz=1399611824.1.1.utmcsr=(direct)|utmcmd=(none) 8 | User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10_8_5) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/35.0.1916.86 Safari/537.36 9 | 10 | -------------------------------------------------------------------------------- /binary-parser-bench/json-data/dates-fract.json: -------------------------------------------------------------------------------- 1 | ["2015-02-02T09:10:11.123Z","2015-02-03T09:10:11.000+0000","2014-01-02T09:10:11.333Z","2014-01-03T02:09:12.000-02:00","2013-05-06T07:08:09.444Z","2015-02-02T09:10:11.66+03:00","2015-02-03T09:10:11.66Z","2014-01-02T09:10:11.66-1200","2014-01-03T02:09:12.66Z","2013-05-06T07:08:09.66+00:00"] 2 | -------------------------------------------------------------------------------- /binary-parser-bench/json-data/dates.json: -------------------------------------------------------------------------------- 1 | ["2015-02-02T09:10:11Z","2015-02-03T09:10:11+0000","2014-01-02T09:10:11Z","2014-01-03T02:09:12-0300","2013-05-06T07:08:09Z","2015-02-02T09:10:11+04:00","2015-02-03T09:10:11Z","2014-01-02T09:10:11-11:45","2014-01-03T02:09:12Z","2013-05-06T07:08:09+0000"] 2 | -------------------------------------------------------------------------------- /binary-parser-bench/json-data/example.json: -------------------------------------------------------------------------------- 1 | {"web-app": { 2 | "servlet": [ 3 | { 4 | "servlet-name": "cofaxCDS", 5 | "servlet-class": "org.cofax.cds.CDSServlet", 6 | "init-param": { 7 | "configGlossary:installationAt": "Philadelphia, PA", 8 | "configGlossary:adminEmail": "ksm@pobox.com", 9 | "configGlossary:poweredBy": "Cofax", 10 | "configGlossary:poweredByIcon": "/images/cofax.gif", 11 | "configGlossary:staticPath": "/content/static", 12 | "templateProcessorClass": "org.cofax.WysiwygTemplate", 13 | "templateLoaderClass": "org.cofax.FilesTemplateLoader", 14 | "templatePath": "templates", 15 | "templateOverridePath": "", 16 | "defaultListTemplate": "listTemplate.htm", 17 | "defaultFileTemplate": "articleTemplate.htm", 18 | "useJSP": false, 19 | "jspListTemplate": "listTemplate.jsp", 20 | "jspFileTemplate": "articleTemplate.jsp", 21 | "cachePackageTagsTrack": 200, 22 | "cachePackageTagsStore": 200, 23 | "cachePackageTagsRefresh": 60, 24 | "cacheTemplatesTrack": 100, 25 | "cacheTemplatesStore": 50, 26 | "cacheTemplatesRefresh": 15, 27 | "cachePagesTrack": 200, 28 | "cachePagesStore": 100, 29 | "cachePagesRefresh": 10, 30 | "cachePagesDirtyRead": 10, 31 | "searchEngineListTemplate": "forSearchEnginesList.htm", 32 | "searchEngineFileTemplate": "forSearchEngines.htm", 33 | "searchEngineRobotsDb": "WEB-INF/robots.db", 34 | "useDataStore": true, 35 | "dataStoreClass": "org.cofax.SqlDataStore", 36 | "redirectionClass": "org.cofax.SqlRedirection", 37 | "dataStoreName": "cofax", 38 | "dataStoreDriver": "com.microsoft.jdbc.sqlserver.SQLServerDriver", 39 | "dataStoreUrl": "jdbc:microsoft:sqlserver://LOCALHOST:1433;DatabaseName=goon", 40 | "dataStoreUser": "sa", 41 | "dataStorePassword": "dataStoreTestQuery", 42 | "dataStoreTestQuery": "SET NOCOUNT ON;select test='test';", 43 | "dataStoreLogFile": "/usr/local/tomcat/logs/datastore.log", 44 | "dataStoreInitConns": 10, 45 | "dataStoreMaxConns": 100, 46 | "dataStoreConnUsageLimit": 100, 47 | "dataStoreLogLevel": "debug", 48 | "maxUrlLength": 500}}, 49 | { 50 | "servlet-name": "cofaxEmail", 51 | "servlet-class": "org.cofax.cds.EmailServlet", 52 | "init-param": { 53 | "mailHost": "mail1", 54 | "mailHostOverride": "mail2"}}, 55 | { 56 | "servlet-name": "cofaxAdmin", 57 | "servlet-class": "org.cofax.cds.AdminServlet"}, 58 | 59 | { 60 | "servlet-name": "fileServlet", 61 | "servlet-class": "org.cofax.cds.FileServlet"}, 62 | { 63 | "servlet-name": "cofaxTools", 64 | "servlet-class": "org.cofax.cms.CofaxToolsServlet", 65 | "init-param": { 66 | "templatePath": "toolstemplates/", 67 | "log": 1, 68 | "logLocation": "/usr/local/tomcat/logs/CofaxTools.log", 69 | "logMaxSize": "", 70 | "dataLog": 1, 71 | "dataLogLocation": "/usr/local/tomcat/logs/dataLog.log", 72 | "dataLogMaxSize": "", 73 | "removePageCache": "/content/admin/remove?cache=pages&id=", 74 | "removeTemplateCache": "/content/admin/remove?cache=templates&id=", 75 | "fileTransferFolder": "/usr/local/tomcat/webapps/content/fileTransferFolder", 76 | "lookInContext": 1, 77 | "adminGroupID": 4, 78 | "betaServer": true}}], 79 | "servlet-mapping": { 80 | "cofaxCDS": "/", 81 | "cofaxEmail": "/cofaxutil/aemail/*", 82 | "cofaxAdmin": "/admin/*", 83 | "fileServlet": "/static/*", 84 | "cofaxTools": "/tools/*"}, 85 | 86 | "taglib": { 87 | "taglib-uri": "cofax.tld", 88 | "taglib-location": "/WEB-INF/tlds/cofax.tld"}}} 89 | -------------------------------------------------------------------------------- /binary-parser-bench/json-data/integers.json: -------------------------------------------------------------------------------- 1 | [1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 6, 6, 7, 7, 7, 8, 9, 9, 10, 10, 11, 12, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 23, 24, 26, 27, 29, 31, 33, 35, 37, 39, 42, 44, 47, 50, 53, 56, 60, 63, 67, 72, 76, 81, 86, 91, 96, 102, 109, 115, 122, 130, 138, 146, 155, 165, 175, 186, 197, 209, 222, 236, 250, 266, 282, 299, 318, 337, 358, 380, 403, 428, 454, 482, 511, 543, 576, 611, 649, 688, 730, 775, 823, 873, 926, 983, 1043, 1107, 1175, 1247, 1323, 1404, 1490, 1582, 1679, 1781, 1890, 2006, 2129, 2259, 2398, 2544, 2700, 2865, 3041, 3227, 3425, 3634, 3857, 4093, 4343, 4609, 4891, 5191, 5509, 5846, 6204, 6583, 6986, 7414, 7868, 8349, 8860, 9403, 9978, 10589, 11237, 11925, 12655, 13430, 14252, 15124, 16050, 17032, 18075, 19181, 20355, 21601, 22923, 24326, 25815, 27396, 29072, 30852, 32740, 34744, 36871, 39128, 41523, 44064, 46762, 49624, 52661, 55884, 59305, 62935, 66787, 70875, 75213, 79817, 84702, 89887, 95389, 101227, 107423, 113998, 120976, 128381, 136239, 144578, 153427, 162818, 172784, 183360, 194583, 206493, 219132, 232545, 246778, 261883, 277912, 294923, 312975, 332131, 352460, 374034, 396928, 421223, 447005, 474365, 503400, 534212, 566911, 601610, 638433, 677511, 718980, 762987, 809688, 859247, 911840, 967652, 1026880, 1089734, 1156434, 1227217, 1302333, 1382046, 1466638, 1556408, 1651673, 1752769, 1860052, 1973902, 2094721, 2222934, 2358996, 2503385, 2656613, 2819219, 2991777, 3174898, 3369227, 3575451, 3794297, 4026539, 4272995, 4534536, 4812086, 5106625, 5419191, 5750889, 6102889, 6476435, 6872845, 7293518, 7739939, 8213686, 8716429, 9249944, 9816115, 10416939, 11054539, 11731166, 12449207, 13211198, 14019829, 14877955, 15788605, 16754994, 17780533, 18868844, 20023768, 21249383, 22550016, 23930257, 25394980, 26949356, 28598872, 30349352, 32206975, 34178300, 36270285, 38490317, 40846232, 43346349, 45999492, 48815029, 51802899, 54973651, 58338478, 61909260, 65698602, 69719882, 73987297, 78515911, 83321713, 88421668, 93833782, 99577160, 105672079, 112140056, 119003924, 126287916, 134017747, 142220706, 150925751, 160163614, 169966908, 180370243, 191410345, 203126189, 215559137, 228753081, 242754599, 257613123, 273381107, 290114218, 307871529, 326715729, 346713346, 367934976, 390455540, 414354543, 439716356, 466630515, 495192035, 525501749, 557666661, 591800322, 628023236, 666463282, 707256166, 750545902, 796485316, 845236589, 896971830, 951873682, 1010135966, 1071964368, 1137577163, 1207205986, 1281096650, 1359510014, 1442722903, 1531029087, 1624740315, 1724187420, 1829721484, 1941715077, 2060563573, 2186686548, 2320529259, 2462564214, 2613292844, 2773247272, 2942992191, 3123126858, 3314287206, 3517148098, 3732425698, 3960880011, 4203317554, 4460594215, 4733618266, 5023353573, 5330822998, 5657112012, 6003372524, 6370826950, 6760772526, 7174585891, 7613727944, 8079749004, 8574294281, 9099109685, 9656047991, 10247075377, 10874278366, 11539871197, 12246203633, 12995769265, 13791214310, 14635346955, 15531147272, 16481777734, 17490594386, 18561158687, 19697250088, 20902879371, 22182302812, 23540037202, 24980875800, 26509905246, 28132523526, 29854459026, 31681790754, 33620969802, 35678842122, 37862672691, 40180171161, 42639519077, 45249398761, 48019023960, 50958172379, 54077220194, 57387178688, 60899733121, 64627283986, 68582990784, 72780818484, 77235586822, 81963022620, 86979815309, 92303675844, 97953399235, 103948930895, 110311437058, 117063379497, 124228594829, 131832378662, 139901574895, 148464670491, 157551896043, 167195332496, 177429024407, 188289100133, 199813899374, 212044108527, 225022904322, 238796106249, 253412338321, 268923200725, 285383451995, 302851202324, 321388118716, 341059642687, 361935221296, 384088552321, 407597844432, 432546093294, 459021374572, 487117154867, 516932621682, 548573033590, 582150091830, 617782334651, 655595555791, 695723248569, 738307077168, 783497376747, 831453684183, 882345301285, 936351892486, 993664119121, 1054484312524, 1119027188325, 1187520604468, 1260206365627, 1337341076854, 1419197049486, 1506063262491, 1598246382662, 1696071847252, 1799885012878, 1910052374747, 2026962860500, 2151029203266, 2282689398739, 2422408251457, 2570679015712, 2728025136906, 2895002099486, 3072199387991, 3260242568131, 3459795495242, 3671562657914, 3896291665080, 4134775885316, 4387857247705, 4656429214122, 4941439933460, 5243895588908, 5564863950114, 5905478142772, 6266940648935, 6650527552175, 7057593042589, 7489574197539, 7947996055022, 8434476997558, 8950734465625, 9498591020797, 10079980779998, 10696956243580, 11351695541337, 12046510122031, 12783852913581, 13566326982715, 14396694724673, 15277887615381, 16213016560543, 17205382878181, 18258489953389, 19376055606456, 20562025218016, 21820585657560, 23156180064488, 24573523533875, 26077619762337, 27673778712750, 29367635360200, 31165169585327, 33072727285306, 35097042776985, 37245262571278, 39524970602741, 41944215003394, 44511536515321, 47235998642351, 50127219647252, 53195406507421, 56451390948928, 59906667686130, 63573435001862, 67464637811456, 71594013362620, 75976139732519, 80626487293267, 85561473327514, 90798519986944, 96356115798305, 102253880934088, 108512636478302, 115154477931865, 122202853217119, 129682645456833, 137620260819954, 146043721744222, 154982765864743, 164468950997792, 174535766550465, 185218751749486, 196555621106568, 208586397563259, 221353553785311, 234902162105402, 249280053643550, 264537987166964, 280729828285480, 297912739615178, 316147382581544, 335498131574595, 356033301212013, 377825387512598, 400951323831468, 425492752460545, 451536312853150, 479173947490266, 508503226468250, 539627691953919, 572657223723034, 607708427072674, 644905044476938, 684378392439283, 726267825083707, 770721226121430, 817895530929871, 867957280587026, 921083209817197, 977460870923688, 1037289295911185, 1100779699135317, 1168156222959992, 1239656729054927, 1315533638126921, 1396054821049394, 1481504544536185, 1572184474698156, 1668414742025481, 1770535071555377, 1878905982215138, 1993910059574563, 2115953306501003, 2245466576485316, 2382907094698829, 2528760072151156, 2683540418647385, 2847794560591953] 2 | -------------------------------------------------------------------------------- /binary-parser-bench/json-data/twitter1.json: -------------------------------------------------------------------------------- 1 | {"results":[{"from_user_id_str":"80430860","profile_image_url":"http://a2.twimg.com/profile_images/536455139/icon32_normal.png","created_at":"Wed, 26 Jan 2011 07:07:02 +0000","from_user":"kazu_yamamoto","id_str":"30159761706061824","metadata":{"result_type":"recent"},"to_user_id":null,"text":"Haskell Server Pages \u3063\u3066\u3001\u307e\u3060\u7d9a\u3044\u3066\u3044\u305f\u306e\u304b\uff01","id":30159761706061824,"from_user_id":80430860,"geo":null,"iso_language_code":"no","to_user_id_str":null,"source":"<a href="http://twitter.com/">web</a>"}],"max_id":30159761706061824,"since_id":0,"refresh_url":"?since_id=30159761706061824&q=haskell","next_page":"?page=2&max_id=30159761706061824&rpp=1&q=haskell","results_per_page":1,"page":1,"completed_in":0.012606,"since_id_str":"0","max_id_str":"30159761706061824","query":"haskell"} 2 | -------------------------------------------------------------------------------- /binary-parser-bench/json-data/twitter10.json: -------------------------------------------------------------------------------- 1 | {"results":[{"from_user_id_str":"207858021","profile_image_url":"http://a3.twimg.com/sticky/default_profile_images/default_profile_2_normal.png","created_at":"Wed, 26 Jan 2011 04:30:38 +0000","from_user":"pboudarga","id_str":"30120402839666689","metadata":{"result_type":"recent"},"to_user_id":null,"text":"I'm at Rolla Sushi Grill (27737 Bouquet Canyon Road, #106, Btw Haskell Canyon and Rosedell Drive, Saugus) http://4sq.com/gqqdhs","id":30120402839666689,"from_user_id":207858021,"geo":null,"iso_language_code":"en","to_user_id_str":null,"source":"<a href="http://foursquare.com" rel="nofollow">foursquare</a>"},{"from_user_id_str":"69988683","profile_image_url":"http://a0.twimg.com/profile_images/1211955817/avatar_7888_normal.gif","created_at":"Wed, 26 Jan 2011 04:25:23 +0000","from_user":"YNK33","id_str":"30119083059978240","metadata":{"result_type":"recent"},"to_user_id":null,"text":"hsndfile 0.5.0: Free and open source Haskell bindings for libsndfile http://bit.ly/gHaBWG Mac Os","id":30119083059978240,"from_user_id":69988683,"geo":null,"iso_language_code":"en","to_user_id_str":null,"source":"<a href="http://twitterfeed.com" rel="nofollow">twitterfeed</a>"},{"from_user_id_str":"81492","profile_image_url":"http://a1.twimg.com/profile_images/423894208/Picture_7_normal.jpg","created_at":"Wed, 26 Jan 2011 04:24:28 +0000","from_user":"satzz","id_str":"30118851488251904","metadata":{"result_type":"recent"},"to_user_id":null,"text":"Emacs\u306e\u30e2\u30fc\u30c9\u8868\u793a\u304c\u4eca(Ruby Controller Outputz RoR Flymake REl hs)\u3068\u306a\u3063\u3066\u3066\u3088\u304f\u308f\u304b\u3089\u306a\u3044\u3093\u3060\u3051\u3069\u6700\u5f8c\u306eREl\u3068\u304bhs\u3063\u3066\u4f55\u3060\u308d\u3046\u2026haskell\u3068\u304b2\u5e74\u4ee5\u4e0a\u66f8\u3044\u3066\u306a\u3044\u3051\u3069\u2026","id":30118851488251904,"from_user_id":81492,"geo":null,"iso_language_code":"ja","to_user_id_str":null,"source":"<a href="http://www.hootsuite.com" rel="nofollow">HootSuite</a>"},{"from_user_id_str":"9518356","profile_image_url":"http://a2.twimg.com/profile_images/119165723/ocaml-icon_normal.png","created_at":"Wed, 26 Jan 2011 04:19:19 +0000","from_user":"planet_ocaml","id_str":"30117557788741632","metadata":{"result_type":"recent"},"to_user_id":null,"text":"I so miss #haskell type classes in #ocaml - i want to do something like refinement. Also why does ocaml not have... http://bit.ly/geYRwt","id":30117557788741632,"from_user_id":9518356,"geo":null,"iso_language_code":"en","to_user_id_str":null,"source":"<a href="http://twitterfeed.com" rel="nofollow">twitterfeed</a>"},{"from_user_id_str":"218059","profile_image_url":"http://a1.twimg.com/profile_images/1053837723/twitter-icon9_normal.jpg","created_at":"Wed, 26 Jan 2011 04:16:32 +0000","from_user":"aprikip","id_str":"30116854940835840","metadata":{"result_type":"recent"},"to_user_id":null,"text":"yatex-mode\u3084haskell-mode\u306e\u3053\u3068\u3067\u3059\u306d\u3001\u308f\u304b\u308a\u307e\u3059\u3002","id":30116854940835840,"from_user_id":218059,"geo":null,"iso_language_code":"ja","to_user_id_str":null,"source":"<a href="http://sites.google.com/site/yorufukurou/" rel="nofollow">YoruFukurou</a>"},{"from_user_id_str":"216363","profile_image_url":"http://a1.twimg.com/profile_images/72454310/Tim-Avatar_normal.png","created_at":"Wed, 26 Jan 2011 04:15:30 +0000","from_user":"dysinger","id_str":"30116594684264448","metadata":{"result_type":"recent"},"to_user_id":null,"text":"Haskell in Hawaii tonight for me... #fun","id":30116594684264448,"from_user_id":216363,"geo":null,"iso_language_code":"en","to_user_id_str":null,"source":"<a href="http://www.nambu.com/" rel="nofollow">Nambu</a>"},{"from_user_id_str":"1774820","profile_image_url":"http://a2.twimg.com/profile_images/61169291/dan_desert_thumb_normal.jpg","created_at":"Wed, 26 Jan 2011 04:13:36 +0000","from_user":"DanMil","id_str":"30116117682851840","metadata":{"result_type":"recent"},"to_user_id":1594784,"text":"@ojrac @chewedwire @tomheon Haskell isn't a language, it's a belief system. A seductive one...","id":30116117682851840,"from_user_id":1774820,"to_user":"ojrac","geo":null,"iso_language_code":"en","to_user_id_str":"1594784","source":"<a href="http://twitter.com/">web</a>"},{"from_user_id_str":"659256","profile_image_url":"http://a0.twimg.com/profile_images/746976711/angular-final_normal.jpg","created_at":"Wed, 26 Jan 2011 04:11:06 +0000","from_user":"djspiewak","id_str":"30115488931520512","metadata":{"result_type":"recent"},"to_user_id":null,"text":"One of the very nice things about Haskell as opposed to SML is the reduced proliferation of identifiers (e.g. andb, orb, etc). #typeclasses","id":30115488931520512,"from_user_id":659256,"geo":null,"iso_language_code":"en","to_user_id_str":null,"source":"<a href="http://itunes.apple.com/us/app/twitter/id409789998?mt=12" rel="nofollow">Twitter for Mac</a>"},{"from_user_id_str":"144546280","profile_image_url":"http://a1.twimg.com/a/1295051201/images/default_profile_1_normal.png","created_at":"Wed, 26 Jan 2011 04:06:12 +0000","from_user":"listwarenet","id_str":"30114255890026496","metadata":{"result_type":"recent"},"to_user_id":null,"text":"http://www.listware.net/201101/haskell-cafe/84752-re-haskell-cafe-gpl-license-of-h-matrix-and-prelude-numeric.html Re: Haskell-c","id":30114255890026496,"from_user_id":144546280,"geo":null,"iso_language_code":"no","to_user_id_str":null,"source":"<a href="http://1e10.org/cloud/" rel="nofollow">1e10</a>"},{"from_user_id_str":"1594784","profile_image_url":"http://a2.twimg.com/profile_images/378515773/square-profile_normal.jpg","created_at":"Wed, 26 Jan 2011 04:01:29 +0000","from_user":"ojrac","id_str":"30113067333324800","metadata":{"result_type":"recent"},"to_user_id":null,"text":"RT @tomheon: @ojrac @chewedwire Don't worry, learning Haskell will not give you any clear idea what monad means.","id":30113067333324800,"from_user_id":1594784,"geo":null,"iso_language_code":"en","to_user_id_str":null,"source":"<a href="http://twitter.com/">web</a>"}],"max_id":30120402839666689,"since_id":0,"refresh_url":"?since_id=30120402839666689&q=haskell","next_page":"?page=2&max_id=30120402839666689&rpp=10&q=haskell","results_per_page":10,"page":1,"completed_in":0.012714,"since_id_str":"0","max_id_str":"30120402839666689","query":"haskell"} 2 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-compat": { 4 | "flake": false, 5 | "locked": { 6 | "lastModified": 1673956053, 7 | "narHash": "sha256-4gtG9iQuiKITOjNQQeQIpoIB6b16fm+504Ch3sNKLd8=", 8 | "owner": "edolstra", 9 | "repo": "flake-compat", 10 | "rev": "35bb57c0c8d8b62bbfd284272c928ceb64ddbde9", 11 | "type": "github" 12 | }, 13 | "original": { 14 | "owner": "edolstra", 15 | "repo": "flake-compat", 16 | "type": "github" 17 | } 18 | }, 19 | "nixpkgs": { 20 | "locked": { 21 | "lastModified": 1691155369, 22 | "narHash": "sha256-CIuJO5pgwCMsZM8flIU2OiZ79QfDCesXPsAiokCzlNM=", 23 | "owner": "nixos", 24 | "repo": "nixpkgs", 25 | "rev": "7d050b98e51cdbdd88ad960152d398d41c7ff5b4", 26 | "type": "github" 27 | }, 28 | "original": { 29 | "owner": "nixos", 30 | "ref": "nixpkgs-unstable", 31 | "repo": "nixpkgs", 32 | "type": "github" 33 | } 34 | }, 35 | "root": { 36 | "inputs": { 37 | "flake-compat": "flake-compat", 38 | "nixpkgs": "nixpkgs" 39 | } 40 | } 41 | }, 42 | "root": "root", 43 | "version": 7 44 | } 45 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | # I used chatgpt to generate this template and then just 2 | # modified to how I normally use these things. 3 | { 4 | description = "My Haskell project"; 5 | 6 | inputs = { 7 | nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; 8 | flake-compat = { 9 | url = "github:edolstra/flake-compat"; 10 | flake = false; 11 | }; 12 | }; 13 | 14 | outputs = { self, nixpkgs, flake-compat }: 15 | let 16 | pkgs = nixpkgs.legacyPackages.x86_64-linux; 17 | hpkgs = pkgs.haskellPackages.override { 18 | overrides = hnew: hold: { 19 | mysql-haskell = hnew.callCabal2nix "mysql-haskell" ./. { }; 20 | # untill they figure out how to compile the test suite 21 | crypton-x509 = pkgs.haskell.lib.markUnbroken (pkgs.haskell.lib.dontCheck hold.crypton-x509); 22 | 23 | # need to override untill nixpkgs merges in the new tls 24 | # do to the cryptonite/crypton clusterfuck 25 | tls = (hold.callHackageDirect { 26 | pkg = "tls"; 27 | ver = "1.7.1"; 28 | sha256 = "sha256-l8+Kgx7A8zg2tl64mC7t/S0gJNCS10fQ/2I65bTMpjY="; 29 | } {}); 30 | 31 | }; 32 | }; 33 | in 34 | { 35 | defaultPackage.x86_64-linux = hpkgs.mysql-haskell; 36 | inherit pkgs; 37 | devShell.x86_64-linux = hpkgs.shellFor { 38 | packages = ps : [ ps."mysql-haskell" ]; 39 | # TODO disabled untill crypton/crytponite clusterfuck is resolved 40 | # withHoogle = true; 41 | 42 | buildInputs = [ 43 | hpkgs.haskell-language-server 44 | pkgs.ghcid 45 | pkgs.cabal-install 46 | ]; 47 | }; 48 | }; 49 | } 50 | -------------------------------------------------------------------------------- /mysql-haskell.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: mysql-haskell 3 | version: 1.1.6 4 | synopsis: pure haskell MySQL driver 5 | description: pure haskell MySQL driver. 6 | license: BSD-3-Clause 7 | license-file: LICENSE 8 | author: winterland1989 9 | maintainer: hi@jappie.me 10 | copyright: (c) 2016 Winterland 11 | category: Database 12 | build-type: Simple 13 | extra-doc-files: ChangeLog.md 14 | extra-source-files: 15 | mozillaCAStore.pem 16 | README.md 17 | test/cert/ca-key.pem 18 | test/cert/ca.pem 19 | test/cert/server-cert.pem 20 | test/cert/server-key.pem 21 | test/cert/server-req.pem 22 | test/json-data/buffer-builder.json 23 | test/json-data/dates-fract.json 24 | test/json-data/dates.json 25 | test/json-data/example.json 26 | test/json-data/geometry.json 27 | test/json-data/integers.json 28 | test/json-data/jp10.json 29 | test/json-data/jp100.json 30 | test/json-data/jp50.json 31 | test/json-data/numbers.json 32 | test/json-data/twitter1.json 33 | test/json-data/twitter10.json 34 | test/json-data/twitter100.json 35 | test/json-data/twitter20.json 36 | test/json-data/twitter50.json 37 | 38 | homepage: https://github.com/winterland1989/mysql-haskell 39 | bug-reports: https://github.com/winterland1989/mysql-haskell/issues 40 | 41 | source-repository head 42 | type: git 43 | location: git://github.com/winterland1989/mysql-haskell.git 44 | 45 | library 46 | exposed-modules: 47 | Data.Binary.Parser 48 | Data.Binary.Parser.Numeric 49 | Data.Binary.Parser.Word8 50 | Data.Connection 51 | Data.Int.Int24 52 | Data.TLSSetting 53 | Data.Word.Word24 54 | Database.MySQL.Base 55 | Database.MySQL.BinLog 56 | Database.MySQL.BinLogProtocol.BinLogEvent 57 | Database.MySQL.BinLogProtocol.BinLogMeta 58 | Database.MySQL.BinLogProtocol.BinLogValue 59 | Database.MySQL.Connection 60 | Database.MySQL.Protocol.Auth 61 | Database.MySQL.Protocol.ColumnDef 62 | Database.MySQL.Protocol.Command 63 | Database.MySQL.Protocol.Escape 64 | Database.MySQL.Protocol.MySQLValue 65 | Database.MySQL.Protocol.Packet 66 | Database.MySQL.TLS 67 | System.IO.Streams.TCP 68 | System.IO.Streams.TLS 69 | 70 | other-modules: Paths_mysql_haskell 71 | autogen-modules: Paths_mysql_haskell 72 | hs-source-dirs: src 73 | other-modules: Database.MySQL.Query 74 | build-depends: 75 | base >=4.7 && <4.19.0 || ^>=4.19.0 || ^>=4.20.0, 76 | binary >=0.8.3 && <0.9, 77 | blaze-textual >=0.2 && <0.3, 78 | bytestring >=0.10.2.0 && <0.12 || ^>=0.12.0, 79 | bytestring-lexing >=0.5 && <0.6, 80 | crypton >=0.31 && <0.40 || ^>=1.0.0, 81 | crypton-x509 >=1.5 && <2.0, 82 | crypton-x509-store >=1.5 && <2.0, 83 | crypton-x509-system >=1.5 && <2.0, 84 | data-default-class >=0.1.2 && <0.2, 85 | deepseq >=1.4.6 && <1.5 || ^>=1.5.0, 86 | io-streams >=1.2 && <2.0, 87 | memory >=0.14.4 && <0.19, 88 | monad-loops >=0.4 && <0.5, 89 | network >=2.3 && <4.0, 90 | pem >=0.2.4 && <0.3, 91 | scientific >=0.3 && <0.4, 92 | text >=1.1 && <2.1 || ^>=2.1, 93 | time >=1.5.0 && <1.12 || ^>=1.12.2 || ^>=1.14, 94 | tls >=1.7.0 && <1.8 || ^>=1.8.0 || ^>=1.9.0 || ^>=2.0.0 || ^>=2.1.0, 95 | vector >=0.8 && <0.13 || ^>=0.13.0, 96 | word-compat >=0.0 && <0.1 97 | 98 | default-language: Haskell2010 99 | default-extensions: 100 | DeriveDataTypeable 101 | DeriveGeneric 102 | MultiWayIf 103 | OverloadedStrings 104 | 105 | ghc-options: 106 | -Wall -Wincomplete-uni-patterns 107 | -Wincomplete-record-updates -Widentities -Wredundant-constraints 108 | -Wcpp-undef -fwarn-tabs -Wpartial-fields 109 | -Wunused-packages -fenable-th-splice-warnings 110 | 111 | test-suite test 112 | type: exitcode-stdio-1.0 113 | main-is: Main.hs 114 | other-modules: 115 | Aeson 116 | AesonBP 117 | BinaryRow 118 | BinaryRowNew 119 | BinLog 120 | BinLogNew 121 | ExecuteMany 122 | JSON 123 | MysqlTests 124 | QC.ByteString 125 | QC.Combinator 126 | QC.Common 127 | QCUtils 128 | TCPStreams 129 | TextRow 130 | TextRowNew 131 | Word24 132 | 133 | hs-source-dirs: test 134 | build-depends: 135 | attoparsec, 136 | base, 137 | binary >=0.8, 138 | bytestring >=0.10, 139 | bytestring-lexing >=0.5, 140 | containers, 141 | deepseq, 142 | directory, 143 | filepath, 144 | io-streams, 145 | mysql-haskell, 146 | network, 147 | QuickCheck >=2.7, 148 | quickcheck-instances, 149 | scientific >=0.3.0, 150 | tasty >=0.11 && <2.0, 151 | tasty-hunit, 152 | tasty-quickcheck >=0.8, 153 | text, 154 | time, 155 | unordered-containers, 156 | vector 157 | 158 | default-extensions: 159 | MultiWayIf 160 | OverloadedStrings 161 | 162 | ghc-options: -threaded 163 | default-language: Haskell2010 164 | 165 | benchmark binary-parsers-bench 166 | other-modules: 167 | Aeson 168 | AesonBP 169 | Common 170 | HttpReq 171 | Network.Wai.Handler.Warp.ReadInt 172 | Network.Wai.Handler.Warp.RequestHeader 173 | 174 | build-depends: 175 | attoparsec, 176 | base, 177 | binary, 178 | bytestring, 179 | case-insensitive, 180 | criterion >=1.1 && <1.2 || ^>=1.6.3, 181 | deepseq, 182 | directory, 183 | filepath, 184 | http-types, 185 | mysql-haskell, 186 | scanner, 187 | scientific, 188 | text, 189 | unordered-containers, 190 | vector 191 | 192 | default-language: Haskell2010 193 | hs-source-dirs: binary-parser-bench 194 | main-is: Bench.hs 195 | type: exitcode-stdio-1.0 196 | ghc-options: -O2 197 | 198 | benchmark bench24 199 | default-language: Haskell2010 200 | type: exitcode-stdio-1.0 201 | hs-source-dirs: word24-bench 202 | main-is: Benchmark.hs 203 | build-depends: 204 | base, 205 | criterion >=1.1, 206 | deepseq >=1.2 && <2, 207 | mysql-haskell 208 | 209 | ghc-options: -O2 210 | -------------------------------------------------------------------------------- /src/Data/Binary/Parser/Numeric.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | 3 | -- Module : Data.Binary.Parser.Numeric 4 | -- Copyright : Bryan O'Sullivan 2007-2015, Winterland 2016 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : drkoster@qq.com 8 | -- Stability : experimental 9 | -- Portability : unknown 10 | -- 11 | -- Simple, efficient combinator parsing for numeric values. 12 | -- 13 | module Data.Binary.Parser.Numeric where 14 | 15 | import Control.Applicative 16 | import Control.Monad 17 | import Data.Binary.Get.Internal 18 | import qualified Data.Binary.Parser.Word8 as W 19 | import qualified Data.ByteString as B 20 | import qualified Data.ByteString.Lex.Integral as LexInt 21 | import Data.Int 22 | import Data.Scientific (Scientific (..)) 23 | import qualified Data.Scientific as Sci 24 | import Data.Word 25 | 26 | #define MINUS 45 27 | #define PLUS 43 28 | #define LITTLE_E 101 29 | #define BIG_E 69 30 | #define DOT 46 31 | 32 | -- | Parse and decode an unsigned hexadecimal number. The hex digits 33 | -- @\'a\'@ through @\'f\'@ may be upper or lower case. 34 | -- 35 | -- This parser does not accept a leading @\"0x\"@ string. 36 | -- 37 | hexadecimal :: (Integral a) => Get a 38 | hexadecimal = do 39 | bs <- W.takeWhile1 W.isHexDigit 40 | case LexInt.readHexadecimal bs of 41 | Just (x, _) -> return x 42 | Nothing -> fail "hexadecimal: impossible" 43 | {-# SPECIALISE hexadecimal :: Get Int #-} 44 | {-# SPECIALISE hexadecimal :: Get Int8 #-} 45 | {-# SPECIALISE hexadecimal :: Get Int16 #-} 46 | {-# SPECIALISE hexadecimal :: Get Int32 #-} 47 | {-# SPECIALISE hexadecimal :: Get Int64 #-} 48 | {-# SPECIALISE hexadecimal :: Get Integer #-} 49 | {-# SPECIALISE hexadecimal :: Get Word #-} 50 | {-# SPECIALISE hexadecimal :: Get Word8 #-} 51 | {-# SPECIALISE hexadecimal :: Get Word16 #-} 52 | {-# SPECIALISE hexadecimal :: Get Word32 #-} 53 | {-# SPECIALISE hexadecimal :: Get Word64 #-} 54 | 55 | -- | Parse and decode an unsigned decimal number. 56 | -- 57 | decimal :: Integral a => Get a 58 | decimal = do 59 | bs <- W.takeWhile1 W.isDigit 60 | return $! LexInt.readDecimal_ bs 61 | {-# SPECIALISE decimal :: Get Int #-} 62 | {-# SPECIALISE decimal :: Get Int8 #-} 63 | {-# SPECIALISE decimal :: Get Int16 #-} 64 | {-# SPECIALISE decimal :: Get Int32 #-} 65 | {-# SPECIALISE decimal :: Get Int64 #-} 66 | {-# SPECIALISE decimal :: Get Integer #-} 67 | {-# SPECIALISE decimal :: Get Word #-} 68 | {-# SPECIALISE decimal :: Get Word8 #-} 69 | {-# SPECIALISE decimal :: Get Word16 #-} 70 | {-# SPECIALISE decimal :: Get Word32 #-} 71 | {-# SPECIALISE decimal :: Get Word64 #-} 72 | 73 | -- | Parse a number with an optional leading @\'+\'@ or @\'-\'@ sign 74 | -- character. 75 | -- 76 | signed :: Num a => Get a -> Get a 77 | signed p = do 78 | w <- W.peek 79 | if w == MINUS 80 | then W.skipN 1 >> negate <$> p 81 | else if w == PLUS then W.skipN 1 >> p else p 82 | {-# SPECIALISE signed :: Get Int -> Get Int #-} 83 | {-# SPECIALISE signed :: Get Int8 -> Get Int8 #-} 84 | {-# SPECIALISE signed :: Get Int16 -> Get Int16 #-} 85 | {-# SPECIALISE signed :: Get Int32 -> Get Int32 #-} 86 | {-# SPECIALISE signed :: Get Int64 -> Get Int64 #-} 87 | {-# SPECIALISE signed :: Get Integer -> Get Integer #-} 88 | 89 | -- | Parse a rational number. 90 | -- 91 | -- The syntax accepted by this parser is the same as for 'double'. 92 | -- 93 | -- /Note/: this parser is not safe for use with inputs from untrusted 94 | -- sources. An input with a suitably large exponent such as 95 | -- @"1e1000000000"@ will cause a huge 'Integer' to be allocated, 96 | -- resulting in what is effectively a denial-of-service attack. 97 | -- 98 | -- In most cases, it is better to use 'double' or 'scientific' 99 | -- instead. 100 | -- 101 | rational :: Fractional a => Get a 102 | rational = scientifically realToFrac 103 | {-# SPECIALIZE rational :: Get Double #-} 104 | {-# SPECIALIZE rational :: Get Float #-} 105 | {-# SPECIALIZE rational :: Get Rational #-} 106 | {-# SPECIALIZE rational :: Get Scientific #-} 107 | 108 | -- | Parse a rational number and round to 'Double'. 109 | -- 110 | -- This parser accepts an optional leading sign character, followed by 111 | -- at least one decimal digit. The syntax similar to that accepted by 112 | -- the 'read' function, with the exception that a trailing @\'.\'@ or 113 | -- @\'e\'@ /not/ followed by a number is not consumed. 114 | -- 115 | -- Examples with behaviour identical to 'read': 116 | -- 117 | -- >parseOnly double "3" == Right ("",1,3.0) 118 | -- >parseOnly double "3.1" == Right ("",3,3.1) 119 | -- >parseOnly double "3e4" == Right ("",3,30000.0) 120 | -- >parseOnly double "3.1e4" == Right ("",5,31000.0) 121 | -- 122 | -- >parseOnly double ".3" == Left (".3",0,"takeWhile1") 123 | -- >parseOnly double "e3" == Left ("e3",0,"takeWhile1") 124 | -- 125 | -- Examples of differences from 'read': 126 | -- 127 | -- >parseOnly double "3.foo" == Right (".foo",1,3.0) 128 | -- >parseOnly double "3e" == Right ("e",1,3.0) 129 | -- 130 | -- This function does not accept string representations of \"NaN\" or 131 | -- \"Infinity\". 132 | -- 133 | double :: Get Double 134 | double = scientifically Sci.toRealFloat 135 | 136 | -- | Parse a scientific number. 137 | -- 138 | -- The syntax accepted by this parser is the same as for 'double'. 139 | -- 140 | scientific :: Get Scientific 141 | scientific = scientifically id 142 | 143 | -- | Parse a scientific number and convert to result using a user supply function. 144 | -- 145 | -- The syntax accepted by this parser is the same as for 'double'. 146 | -- 147 | scientifically :: (Scientific -> a) -> Get a 148 | scientifically h = do 149 | sign <- W.peek 150 | when (sign == PLUS || sign == MINUS) (W.skipN 1) 151 | intPart <- decimal 152 | sci <- (do fracDigits <- W.word8 DOT >> W.takeWhile1 W.isDigit 153 | let e' = B.length fracDigits 154 | intPart' = intPart * (10 ^ e') 155 | fracPart = LexInt.readDecimal_ fracDigits 156 | parseE (intPart' + fracPart) e' 157 | ) <|> (parseE intPart 0) 158 | 159 | if sign /= MINUS then return $! h sci else return $! h (negate sci) 160 | where 161 | parseE c e = 162 | (do _ <- W.satisfy (\w -> w == LITTLE_E || w == BIG_E) 163 | (Sci.scientific c . (subtract e) <$> signed decimal)) <|> return (Sci.scientific c (negate e)) 164 | {-# INLINE parseE #-} 165 | {-# INLINE scientifically #-} 166 | -------------------------------------------------------------------------------- /src/Data/Connection.hs: -------------------------------------------------------------------------------- 1 | module Data.Connection where 2 | 3 | import qualified Data.ByteString as B 4 | import qualified Data.ByteString.Lazy.Internal as L 5 | import qualified System.IO.Streams as S 6 | 7 | -- | A simple connection abstraction. 8 | -- 9 | -- 'Connection' s from this package are supposed to have following properties: 10 | -- 11 | -- * 'S.InputStream' is choosen to simplify streaming processing. 12 | -- You can easily push back some data with 'S.unRead', 13 | -- reading 'S.InputStream' will block until GHC IO manager find data is ready, for example: 14 | -- @'S.readExactly' 1024@ will block until at least 1024 bytes are available. 15 | -- 16 | -- * The type @'L.ByteString' -> 'IO' ()@ is choosen because it worked well with haskell's builder infrastructure. 17 | -- 18 | -- is used automatically when there's more than one chunk to send to save system call. 19 | -- 20 | -- * 'connExtraInfo' field store extra data about the connection, 'N.SockAddr' for example. 21 | -- You can also use this field as a type tag to distinguish different type of connection. 22 | -- 23 | -- * 'close' should close connection resource, thus the 'Connection' shouldn't be used anymore 24 | -- after 'close' is called. 25 | -- 26 | -- * You should make sure there's no pending recv/send before you 'close' a 'Connection'. 27 | -- That means either you call 'close' in the same thread you recv/send, or use async exception 28 | -- to terminate recv/send thread before call 'close' in other thread(such as a reaper thread). 29 | -- Otherwise you may run into 30 | -- . 31 | -- 32 | -- * Exception or closed by other peer during recv/send will NOT close underline socket, 33 | -- you should always use 'close' with 'E.bracket' to ensure safety. 34 | -- 35 | -- @since 1.0 36 | -- 37 | data Connection a = Connection 38 | { source :: {-# UNPACK #-} !(S.InputStream B.ByteString) -- ^ receive data as 'S.InputStream' 39 | , send :: L.ByteString -> IO () -- ^ send data with connection 40 | , close :: IO () -- ^ close connection 41 | , connExtraInfo :: a -- ^ extra info 42 | } 43 | -------------------------------------------------------------------------------- /src/Data/TLSSetting.hs: -------------------------------------------------------------------------------- 1 | -- | Helpers for setting up a tls connection with @tls@ package, 2 | -- for further customization, please refer to @tls@ package. 3 | -- 4 | -- Note, functions in this module will throw error if can't load certificates or CA store. 5 | -- 6 | module Data.TLSSetting 7 | ( -- * Choose a CAStore 8 | TrustedCAStore(..) 9 | -- * Make TLS settings 10 | , makeClientParams 11 | , makeClientParams' 12 | , makeServerParams 13 | , makeServerParams' 14 | -- * Internal 15 | , mozillaCAStorePath 16 | ) where 17 | 18 | import qualified Data.ByteString as B 19 | import Data.Default.Class (def) 20 | import qualified Data.PEM as X509 21 | import qualified Data.X509 as X509 22 | import qualified Data.X509.CertificateStore as X509 23 | import qualified Network.TLS as TLS 24 | import qualified Network.TLS.Extra as TLS 25 | import Paths_mysql_haskell (getDataFileName) 26 | import qualified System.X509 as X509 27 | 28 | -- | The whole point of TLS is that: a peer should have already trusted 29 | -- some certificates, which can be used for validating other peer's certificates. 30 | -- if the certificates sent by other side form a chain. and one of them is issued 31 | -- by one of 'TrustedCAStore', Then the peer will be trusted. 32 | -- 33 | data TrustedCAStore 34 | = SystemCAStore -- ^ provided by your operating system. 35 | | MozillaCAStore -- ^ provided by . 36 | | CustomCAStore FilePath -- ^ provided by your self, the CA file can contain multiple certificates. 37 | deriving (Show, Eq) 38 | 39 | -- | Get the built-in mozilla CA's path. 40 | mozillaCAStorePath :: IO FilePath 41 | mozillaCAStorePath = getDataFileName "mozillaCAStore.pem" 42 | 43 | makeCAStore :: TrustedCAStore -> IO X509.CertificateStore 44 | makeCAStore SystemCAStore = X509.getSystemCertificateStore 45 | makeCAStore MozillaCAStore = makeCAStore . CustomCAStore =<< mozillaCAStorePath 46 | makeCAStore (CustomCAStore fp) = do 47 | bs <- B.readFile fp 48 | let pems = case X509.pemParseBS bs of 49 | Right pms -> pms 50 | Left err -> error err 51 | case mapM (X509.decodeSignedCertificate . X509.pemContent) pems of 52 | Right cas -> return (X509.makeCertificateStore cas) 53 | Left err -> error err 54 | 55 | -- | make a simple tls 'TLS.ClientParams' that will validate server and use tls connection 56 | -- without providing client's own certificate. suitable for connecting server which don't 57 | -- validate clients. 58 | -- 59 | -- we defer setting of 'TLS.clientServerIdentification' to connecting phase. 60 | -- 61 | -- Note, tls's default validating method require server has v3 certificate. 62 | -- you can use openssl's V3 extension to issue such a certificate. or change 'TLS.ClientParams' 63 | -- before connecting. 64 | -- 65 | makeClientParams :: TrustedCAStore -- ^ trusted certificates. 66 | -> IO TLS.ClientParams 67 | makeClientParams tca = do 68 | caStore <- makeCAStore tca 69 | return (TLS.defaultParamsClient "" B.empty) 70 | { TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_default } 71 | , TLS.clientShared = def 72 | { TLS.sharedCAStore = caStore 73 | , TLS.sharedValidationCache = def 74 | } 75 | } 76 | 77 | -- | make a simple tls 'TLS.ClientParams' that will validate server and use tls connection 78 | -- while providing client's own certificate as well. suitable for connecting server which 79 | -- validate clients. 80 | -- 81 | -- Also only accept v3 certificate. 82 | -- 83 | makeClientParams' :: FilePath -- ^ public certificate (X.509 format). 84 | -> [FilePath] -- ^ chain certificates (X.509 format). 85 | -- the root of your certificate chain should be 86 | -- already trusted by server, or tls will fail. 87 | -> FilePath -- ^ private key associated. 88 | -> TrustedCAStore -- ^ trusted certificates. 89 | -> IO TLS.ClientParams 90 | makeClientParams' pub certs priv tca = do 91 | p <- makeClientParams tca 92 | c <- TLS.credentialLoadX509Chain pub certs priv 93 | case c of 94 | Right c' -> 95 | return p 96 | { TLS.clientShared = (TLS.clientShared p) 97 | { 98 | TLS.sharedCredentials = TLS.Credentials [c'] 99 | } 100 | } 101 | Left err -> error err 102 | 103 | -- | make a simple tls 'TLS.ServerParams' without validating client's certificate. 104 | -- 105 | makeServerParams :: FilePath -- ^ public certificate (X.509 format). 106 | -> [FilePath] -- ^ chain certificates (X.509 format). 107 | -- the root of your certificate chain should be 108 | -- already trusted by client, or tls will fail. 109 | -> FilePath -- ^ private key associated. 110 | -> IO TLS.ServerParams 111 | makeServerParams pub certs priv = do 112 | c <- TLS.credentialLoadX509Chain pub certs priv 113 | case c of 114 | Right c'@(X509.CertificateChain c'', _) -> 115 | return def 116 | { TLS.serverCACertificates = c'' 117 | , TLS.serverShared = def 118 | { 119 | TLS.sharedCredentials = TLS.Credentials [c'] 120 | } 121 | , TLS.serverSupported = def { TLS.supportedCiphers = TLS.ciphersuite_strong } 122 | } 123 | Left err -> error err 124 | 125 | -- | make a tls 'TLS.ServerParams' that also validating client's certificate. 126 | -- 127 | makeServerParams' :: FilePath -- ^ public certificate (X.509 format). 128 | -> [FilePath] -- ^ chain certificates (X.509 format). 129 | -> FilePath -- ^ private key associated. 130 | -> TrustedCAStore -- ^ server will use these certificates to validate clients. 131 | -> IO TLS.ServerParams 132 | makeServerParams' pub certs priv tca = do 133 | caStore <- makeCAStore tca 134 | p <- makeServerParams pub certs priv 135 | return p 136 | { TLS.serverWantClientCert = True 137 | , TLS.serverShared = (TLS.serverShared p) 138 | { TLS.sharedCAStore = caStore 139 | } 140 | } 141 | -------------------------------------------------------------------------------- /src/Database/MySQL/BinLogProtocol/BinLogMeta.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -funbox-strict-fields #-} 2 | 3 | {-| 4 | Module : Database.MySQL.BinLogProtocol.BinLogMeta 5 | Description : Binlog protocol column meta 6 | Copyright : (c) Winterland, 2016 7 | License : BSD 8 | Maintainer : drkoster@qq.com 9 | Stability : experimental 10 | Portability : PORTABLE 11 | 12 | This module provide column meta decoder for binlog protocol. 13 | 14 | There're certain type won't appear in binlog event, and some types are compressed into 'mySQLTypeString' 15 | , please take python version as a reference: 16 | 17 | You will not directly meet following 'FieldType' namely: 18 | 19 | * mySQLTypeDecimal 20 | * mySQLTypeNewdate 21 | * mySQLTypeEnum 22 | * mySQLTypeSet 23 | * mySQLTypeTinyBlob 24 | * mySQLTypeMediumBlOb 25 | * mySQLTypeLongBlob 26 | 27 | -} 28 | 29 | module Database.MySQL.BinLogProtocol.BinLogMeta where 30 | 31 | import Data.Binary.Get 32 | import Data.Bits 33 | import Data.Word 34 | import Database.MySQL.Protocol.ColumnDef 35 | 36 | -- | An intermedia date type for decoding row-based event's values. 37 | -- 38 | data BinLogMeta 39 | = BINLOG_TYPE_TINY 40 | | BINLOG_TYPE_SHORT 41 | | BINLOG_TYPE_INT24 42 | | BINLOG_TYPE_LONG 43 | | BINLOG_TYPE_LONGLONG 44 | | BINLOG_TYPE_FLOAT !Word8 -- ^ size 45 | | BINLOG_TYPE_DOUBLE !Word8 -- ^ size 46 | | BINLOG_TYPE_BIT !Word16 !Word8 -- ^ bits, bytes 47 | | BINLOG_TYPE_TIMESTAMP 48 | | BINLOG_TYPE_DATETIME 49 | | BINLOG_TYPE_DATE 50 | | BINLOG_TYPE_TIME 51 | | BINLOG_TYPE_TIMESTAMP2 !Word8 -- ^ fsp 52 | | BINLOG_TYPE_DATETIME2 !Word8 -- ^ fsp 53 | | BINLOG_TYPE_TIME2 !Word8 -- ^ fsp 54 | | BINLOG_TYPE_YEAR 55 | | BINLOG_TYPE_NEWDECIMAL !Word8 !Word8 -- ^ precision, scale 56 | | BINLOG_TYPE_ENUM !Word8 -- ^ 1 or 2('Word8' or 'Word16'), enum index size 57 | | BINLOG_TYPE_SET !Word16 !Word8 -- ^ bitmap bits, bytes 58 | | BINLOG_TYPE_BLOB !Word8 -- ^ length size 59 | | BINLOG_TYPE_STRING !Word16 -- ^ meta length(if < 256, then length is 8bit, 60 | -- if > 256 then length is 16bit) 61 | | BINLOG_TYPE_GEOMETRY !Word8 -- ^ length size 62 | deriving (Show, Eq) 63 | 64 | getBinLogMeta :: FieldType -> Get BinLogMeta 65 | getBinLogMeta t 66 | | t == mySQLTypeTiny = pure BINLOG_TYPE_TINY 67 | | t == mySQLTypeShort = pure BINLOG_TYPE_SHORT 68 | | t == mySQLTypeInt24 = pure BINLOG_TYPE_INT24 69 | | t == mySQLTypeLong = pure BINLOG_TYPE_LONG 70 | | t == mySQLTypeLongLong = pure BINLOG_TYPE_LONGLONG 71 | | t == mySQLTypeFloat = BINLOG_TYPE_FLOAT <$> getWord8 72 | | t == mySQLTypeDouble = BINLOG_TYPE_DOUBLE <$> getWord8 73 | 74 | | t == mySQLTypeBit = do 75 | byte0 <- getWord8 76 | byte1 <- getWord8 77 | let nbits = (fromIntegral byte1 `shiftL` 3) .|. fromIntegral byte0 78 | nbytes = fromIntegral $ (nbits + 7) `shiftR` 3 79 | pure (BINLOG_TYPE_BIT nbits nbytes) 80 | 81 | | t == mySQLTypeTimestamp = pure BINLOG_TYPE_TIMESTAMP 82 | | t == mySQLTypeDateTime = pure BINLOG_TYPE_DATETIME 83 | | t == mySQLTypeDate = pure BINLOG_TYPE_DATE 84 | | t == mySQLTypeTime = pure BINLOG_TYPE_TIME 85 | | t == mySQLTypeTimestamp2 = BINLOG_TYPE_TIMESTAMP2 <$> getWord8 86 | | t == mySQLTypeDateTime2 = BINLOG_TYPE_DATETIME2 <$> getWord8 87 | | t == mySQLTypeTime2 = BINLOG_TYPE_TIME2 <$> getWord8 88 | | t == mySQLTypeYear = pure BINLOG_TYPE_YEAR 89 | | t == mySQLTypeNewDecimal = BINLOG_TYPE_NEWDECIMAL <$> getWord8 <*> getWord8 90 | | t == mySQLTypeVarChar = BINLOG_TYPE_STRING <$> getWord16le 91 | | t == mySQLTypeVarString = BINLOG_TYPE_STRING <$> getWord16le 92 | 93 | | t == mySQLTypeString = do 94 | byte0 <- getWord8 95 | byte1 <- getWord8 96 | -- http://bugs.mysql.com/37426 97 | if byte0 > 0 98 | then if (byte0 .&. 0x30) /= 0x30 99 | then if FieldType (byte0 .|. 0x30) == mySQLTypeString 100 | then let len = fromIntegral $ (byte0 .&. 0x30) `xor` 0x30 101 | len' = len `shiftL` 4 .|. fromIntegral byte1 102 | in pure $! BINLOG_TYPE_STRING len' 103 | else let len = fromIntegral byte0 `shiftL` 8 :: Word16 104 | len' = len .|. fromIntegral byte1 105 | in pure $! BINLOG_TYPE_STRING len' 106 | else let t' = FieldType byte0 107 | in if | t' == mySQLTypeSet -> let nbits = fromIntegral byte1 `shiftL` 3 108 | nbytes = fromIntegral $ (nbits + 7) `shiftR` 8 109 | in pure (BINLOG_TYPE_SET nbits nbytes) 110 | | t' == mySQLTypeEnum -> pure (BINLOG_TYPE_ENUM byte1) 111 | | t' == mySQLTypeString -> pure (BINLOG_TYPE_STRING (fromIntegral byte1)) 112 | | otherwise -> fail $ "Database.MySQL.BinLogProtocol.BinLogMeta:\ 113 | \ impossible type inside binlog string: " ++ show t' 114 | else pure (BINLOG_TYPE_STRING (fromIntegral byte1)) 115 | 116 | | t == mySQLTypeBlob = BINLOG_TYPE_BLOB <$> getWord8 117 | | t == mySQLTypeGeometry = BINLOG_TYPE_GEOMETRY <$> getWord8 118 | | otherwise = fail $ "Database.MySQL.BinLogProtocol.BinLogMeta:\ 119 | \ impossible type in binlog: " ++ show t 120 | -------------------------------------------------------------------------------- /src/Database/MySQL/Protocol/Command.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -funbox-strict-fields #-} 2 | 3 | {-| 4 | Module : Database.MySQL.Protocol.Command 5 | Description : MySQL commands 6 | Copyright : (c) Winterland, 2016 7 | License : BSD 8 | Maintainer : drkoster@qq.com 9 | Stability : experimental 10 | Portability : PORTABLE 11 | 12 | Common MySQL commands supports. 13 | 14 | -} 15 | 16 | module Database.MySQL.Protocol.Command where 17 | 18 | import Control.Monad 19 | import Data.Binary 20 | import Data.Binary.Get 21 | import Data.Binary.Parser 22 | import Data.Binary.Put 23 | import Data.ByteString (ByteString) 24 | import qualified Data.ByteString.Lazy as L 25 | import Database.MySQL.Protocol.MySQLValue 26 | import Database.MySQL.Protocol.Packet 27 | 28 | -------------------------------------------------------------------------------- 29 | -- Commands 30 | 31 | type StmtID = Word32 32 | 33 | -- | All support MySQL commands. 34 | -- 35 | data Command 36 | = COM_QUIT -- ^ 0x01 37 | | COM_INIT_DB !ByteString -- ^ 0x02 38 | | COM_QUERY !L.ByteString -- ^ 0x03 39 | | COM_PING -- ^ 0x0E 40 | | COM_BINLOG_DUMP !Word32 !Word16 !Word32 !ByteString -- ^ 0x12 41 | -- binlog-pos, flags(0x01), server-id, binlog-filename 42 | | COM_REGISTER_SLAVE !Word32 !ByteString !ByteString !ByteString !Word16 !Word32 !Word32 -- ^ 0x15 43 | -- server-id, slaves hostname, slaves user, slaves password, slaves port, replication rank(ignored), master-id(usually 0) 44 | | COM_STMT_PREPARE !L.ByteString -- ^ 0x16 statement 45 | | COM_STMT_EXECUTE !StmtID ![MySQLValue] !BitMap -- ^ 0x17 stmtId, params 46 | | COM_STMT_CLOSE !StmtID -- ^ 0x19 stmtId 47 | | COM_STMT_RESET !StmtID -- ^ 0x1A stmtId 48 | | COM_UNSUPPORTED 49 | deriving (Show, Eq) 50 | 51 | putCommand :: Command -> Put 52 | putCommand COM_QUIT = putWord8 0x01 53 | putCommand (COM_INIT_DB db) = putWord8 0x02 >> putByteString db 54 | putCommand (COM_QUERY q) = putWord8 0x03 >> putLazyByteString q 55 | putCommand COM_PING = putWord8 0x0E 56 | putCommand (COM_BINLOG_DUMP pos flags sid fname) = do 57 | putWord8 0x12 58 | putWord32le pos 59 | putWord16le flags 60 | putWord32le sid 61 | putByteString fname 62 | putCommand (COM_REGISTER_SLAVE sid shost susr spass sport rrank mid) = do 63 | putWord8 0x15 64 | putWord32le sid 65 | putLenEncBytes shost 66 | putLenEncBytes susr 67 | putLenEncBytes spass 68 | putWord16le sport 69 | putWord32le rrank 70 | putWord32le mid 71 | putCommand (COM_STMT_PREPARE stmt) = putWord8 0x16 >> putLazyByteString stmt 72 | putCommand (COM_STMT_EXECUTE stid params nullmap) = do 73 | putWord8 0x17 74 | putWord32le stid 75 | putWord8 0x00 -- we only use @CURSOR_TYPE_NO_CURSOR@ here 76 | putWord32le 1 -- const 1 77 | unless (null params) $ do 78 | putByteString (fromBitMap nullmap) 79 | putWord8 0x01 -- always use new-params-bound-flag 80 | mapM_ putParamMySQLType params 81 | forM_ params putBinaryField 82 | 83 | putCommand (COM_STMT_CLOSE stid) = putWord8 0x19 >> putWord32le stid 84 | putCommand (COM_STMT_RESET stid) = putWord8 0x1A >> putWord32le stid 85 | putCommand _ = error "unsupported command" 86 | 87 | -------------------------------------------------------------------------------- 88 | -- Prepared statment related 89 | 90 | -- | call 'isOK' with this packet return true 91 | data StmtPrepareOK = StmtPrepareOK 92 | { stmtId :: !StmtID 93 | , stmtColumnCnt :: !Int 94 | , stmtParamCnt :: !Int 95 | , stmtWarnCnt :: !Int 96 | } deriving (Show, Eq) 97 | 98 | getStmtPrepareOK :: Get StmtPrepareOK 99 | getStmtPrepareOK = do 100 | skipN 1 -- OK byte 101 | stmtid <- getWord32le 102 | cc <- fromIntegral <$> getWord16le 103 | pc <- fromIntegral <$> getWord16le 104 | skipN 1 -- reserved 105 | wc <- fromIntegral <$> getWord16le 106 | return (StmtPrepareOK stmtid cc pc wc) 107 | {-# INLINE getStmtPrepareOK #-} 108 | -------------------------------------------------------------------------------- /src/Database/MySQL/Protocol/Escape.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | 4 | {-| 5 | Module : Database.MySQL.Protocol.Escape 6 | Description : Pure haskell mysql escape 7 | Copyright : (c) Winterland, 2016 8 | License : BSD 9 | Maintainer : drkoster@qq.com 10 | Stability : experimental 11 | Portability : PORTABLE 12 | 13 | This module provide escape machinery for bytes and text types. 14 | 15 | reference: 16 | 17 | * Escape Sequence Character Represented by Sequence 18 | * \0 An ASCII NUL (X'00') character 19 | * \' A single quote (“'”) character 20 | * \" A double quote (“"”) character 21 | * \b A backspace character 22 | * \n A newline (linefeed) character 23 | * \r A carriage return character 24 | * \t A tab character 25 | * \Z ASCII 26 (Control+Z); see note following the table 26 | * \\ A backslash (“\”) character 27 | * \% A “%” character; see note following the table 28 | * \_ A “_” character; see note following the table 29 | 30 | The @\%@ and @\_@ sequences are used to search for literal instances of @%@ and @_@ in pattern-matching contexts where they would otherwise be interpreted as wildcard characters, so we won't auto escape @%@ or @_@ here. 31 | 32 | -} 33 | 34 | module Database.MySQL.Protocol.Escape where 35 | 36 | import Control.Monad (forM_) 37 | import Data.ByteString (ByteString) 38 | import qualified Data.ByteString.Internal as B 39 | import Data.Text (Text) 40 | import qualified Data.Text.Array as TA 41 | import qualified Data.Text.Internal as T 42 | import Data.Word 43 | import Foreign.ForeignPtr (withForeignPtr) 44 | import Foreign.Ptr (Ptr, minusPtr, plusPtr) 45 | import Foreign.Storable (peek, poke, pokeByteOff) 46 | import GHC.IO (unsafeDupablePerformIO) 47 | 48 | escapeText :: Text -> Text 49 | #if MIN_VERSION_text(2,0,0) 50 | escapeText (T.Text arr off len) 51 | | len <= 0 = T.empty 52 | | otherwise = 53 | let (arr', len') = TA.run2 $ do 54 | marr <- TA.new (len * 2) 55 | loop arr (off + len) marr off 0 56 | in T.Text arr' 0 len' 57 | where 58 | escape c marr ix = do 59 | TA.unsafeWrite marr ix 92 60 | TA.unsafeWrite marr (ix+1) c 61 | 62 | loop oarr oend marr !ix !ix' 63 | | ix == oend = return (marr, ix') 64 | | otherwise = do 65 | let c = TA.unsafeIndex oarr ix 66 | cs = c : [ TA.unsafeIndex oarr (ix+1) | c >= 0xC0 ] 67 | ++ [ TA.unsafeIndex oarr (ix+2) | c >= 0xE0 ] 68 | ++ [ TA.unsafeIndex oarr (ix+3) | c >= 0xF0 ] 69 | go2 = loop oarr oend marr (ix+1) (ix'+2) 70 | goN = do 71 | forM_ (zip [0..4] cs) $ \(di,c') -> TA.unsafeWrite marr (ix' + di) c' 72 | loop oarr oend marr (ix + length cs) (ix' + length cs) 73 | if | c == 0 74 | || c == 39 75 | || c == 34 -> escape c marr ix' >> go2 -- \0 \' \" 76 | | c == 8 -> escape 98 marr ix' >> go2 -- \b 77 | | c == 10 -> escape 110 marr ix' >> go2 -- \n 78 | | c == 13 -> escape 114 marr ix' >> go2 -- \r 79 | | c == 9 -> escape 116 marr ix' >> go2 -- \t 80 | | c == 26 -> escape 90 marr ix' >> go2 -- \Z 81 | | c == 92 -> escape 92 marr ix' >> go2 -- \\ 82 | 83 | | otherwise -> goN 84 | #else 85 | escapeText (T.Text arr off len) 86 | | len <= 0 = T.empty 87 | | otherwise = 88 | let (arr', len') = TA.run2 $ do 89 | marr <- TA.new (len * 2) 90 | loop arr (off + len) marr off 0 91 | in T.Text arr' 0 len' 92 | where 93 | escape c marr ix = do 94 | TA.unsafeWrite marr ix 92 95 | TA.unsafeWrite marr (ix+1) c 96 | 97 | loop oarr oend marr !ix !ix' 98 | | ix == oend = return (marr, ix') 99 | | otherwise = do 100 | let c = TA.unsafeIndex oarr ix 101 | go1 = loop oarr oend marr (ix+1) (ix'+1) 102 | go2 = loop oarr oend marr (ix+1) (ix'+2) 103 | if | c >= 0xD800 && c <= 0xDBFF -> do let c2 = TA.unsafeIndex oarr (ix+1) 104 | TA.unsafeWrite marr ix' c 105 | TA.unsafeWrite marr (ix'+1) c2 106 | loop oarr oend marr (ix+2) (ix'+2) 107 | | c == 0 108 | || c == 39 109 | || c == 34 -> escape c marr ix' >> go2 -- \0 \' \" 110 | | c == 8 -> escape 98 marr ix' >> go2 -- \b 111 | | c == 10 -> escape 110 marr ix' >> go2 -- \n 112 | | c == 13 -> escape 114 marr ix' >> go2 -- \r 113 | | c == 9 -> escape 116 marr ix' >> go2 -- \t 114 | | c == 26 -> escape 90 marr ix' >> go2 -- \Z 115 | | c == 92 -> escape 92 marr ix' >> go2 -- \\ 116 | 117 | | otherwise -> TA.unsafeWrite marr ix' c >> go1 118 | #endif 119 | 120 | escapeBytes :: ByteString -> ByteString 121 | escapeBytes (B.PS fp s len) = unsafeDupablePerformIO $ withForeignPtr fp $ \ a -> 122 | B.createUptoN (len * 2) $ \ b -> do 123 | b' <- loop (a `plusPtr` s) (a `plusPtr` s `plusPtr` len) b 124 | return (b' `minusPtr` b) 125 | where 126 | escape :: Word8 -> Ptr Word8 -> IO (Ptr Word8) 127 | escape c p = do 128 | poke p 92 129 | pokeByteOff p 1 c 130 | return (p `plusPtr` 2) 131 | 132 | loop !a aend !b 133 | | a == aend = return b 134 | | otherwise = do 135 | c <- peek a 136 | if | c == 0 137 | || c == 39 138 | || c == 34 -> escape c b >>= loop (a `plusPtr` 1) aend -- \0 \' \" 139 | | c == 8 -> escape 98 b >>= loop (a `plusPtr` 1) aend -- \b 140 | | c == 10 -> escape 110 b >>= loop (a `plusPtr` 1) aend -- \n 141 | | c == 13 -> escape 114 b >>= loop (a `plusPtr` 1) aend -- \r 142 | | c == 9 -> escape 116 b >>= loop (a `plusPtr` 1) aend -- \t 143 | | c == 26 -> escape 90 b >>= loop (a `plusPtr` 1) aend -- \Z 144 | | c == 92 -> escape 92 b >>= loop (a `plusPtr` 1) aend -- \\ 145 | 146 | | otherwise -> poke b c >> loop (a `plusPtr` 1) aend (b `plusPtr` 1) 147 | -------------------------------------------------------------------------------- /src/Database/MySQL/Query.hs: -------------------------------------------------------------------------------- 1 | module Database.MySQL.Query where 2 | 3 | import Data.String (IsString (..)) 4 | import Control.Exception (throw, Exception) 5 | import Data.Typeable 6 | import qualified Data.ByteString.Lazy as L 7 | import qualified Data.ByteString.Lazy.Char8 as LC 8 | import qualified Data.ByteString.Builder as BB 9 | import Control.Arrow (first) 10 | import Database.MySQL.Protocol.MySQLValue 11 | import Data.Binary.Put 12 | 13 | -- | Query string type borrowed from @mysql-simple@. 14 | -- 15 | -- This type is intended to make it difficult to 16 | -- construct a SQL query by concatenating string fragments, as that is 17 | -- an extremely common way to accidentally introduce SQL injection 18 | -- vulnerabilities into an application. 19 | -- 20 | -- This type is an instance of 'IsString', so the easiest way to 21 | -- construct a query is to enable the @OverloadedStrings@ language 22 | -- extension and then simply write the query in double quotes. 23 | -- 24 | -- The underlying type is a 'L.ByteString', and literal Haskell strings 25 | -- that contain Unicode characters will be correctly transformed to 26 | -- UTF-8. 27 | -- 28 | newtype Query = Query { fromQuery :: L.ByteString } deriving (Eq, Ord, Typeable) 29 | 30 | instance Show Query where 31 | show = show . fromQuery 32 | 33 | instance Read Query where 34 | readsPrec i = fmap (first Query) . readsPrec i 35 | 36 | instance IsString Query where 37 | fromString = Query . BB.toLazyByteString . BB.stringUtf8 38 | 39 | -- | A type to wrap a query parameter in to allow for single and multi-valued parameters. 40 | -- 41 | -- The behavior of 'Param' can be illustrated by following example: 42 | -- 43 | -- @ 44 | -- render $ One (MySQLText "hello") = hello 45 | -- render $ Many [MySQLText "hello", MySQLText "world"] = hello, world 46 | -- render $ Many [] = null 47 | -- @ 48 | -- 49 | -- So you can now write a query like this: @ SELECT * FROM test WHERE _id IN (?, 888) @ 50 | -- and use 'Many' 'Param' to fill the hole. There's no equivalent for prepared statement sadly. 51 | -- 52 | data Param = One MySQLValue 53 | | Many [MySQLValue] 54 | 55 | -- | A type that may be used as a single parameter to a SQL query. Inspired from @mysql-simple@. 56 | class QueryParam a where 57 | render :: a -> Put 58 | -- ^ Prepare a value for substitution into a query string. 59 | 60 | instance QueryParam Param where 61 | render (One x) = putTextField x 62 | render (Many []) = putTextField MySQLNull 63 | render (Many (x:[]))= putTextField x 64 | render (Many (x:xs))= do putTextField x 65 | mapM_ (\f -> putCharUtf8 ',' >> putTextField f) xs 66 | 67 | instance QueryParam MySQLValue where 68 | render = putTextField 69 | 70 | renderParams :: QueryParam p => Query -> [p] -> Query 71 | renderParams (Query qry) params = 72 | let fragments = LC.split '?' qry 73 | in Query . runPut $ merge fragments params 74 | where 75 | merge [x] [] = putLazyByteString x 76 | merge (x:xs) (y:ys) = putLazyByteString x >> render y >> merge xs ys 77 | merge _ _ = throw WrongParamsCount 78 | 79 | data WrongParamsCount = WrongParamsCount deriving (Show, Typeable) 80 | instance Exception WrongParamsCount 81 | -------------------------------------------------------------------------------- /src/Database/MySQL/TLS.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Database.MySQL.Connection 3 | Description : TLS support for mysql-haskell via @tls@ package. 4 | Copyright : (c) Winterland, 2016 5 | License : BSD 6 | Maintainer : drkoster@qq.com 7 | Stability : experimental 8 | Portability : PORTABLE 9 | 10 | This module provides secure MySQL connection using 'tls' package, please make sure your certificate is v3 extension enabled. 11 | 12 | -} 13 | 14 | module Database.MySQL.TLS ( 15 | connect 16 | , connectDetail 17 | , module Data.TLSSetting 18 | ) where 19 | 20 | import Control.Exception (bracketOnError, throwIO) 21 | import qualified Data.Binary as Binary 22 | import qualified Data.Binary.Put as Binary 23 | import qualified Data.Connection as Conn 24 | import Data.IORef (newIORef) 25 | import Data.TLSSetting 26 | import Database.MySQL.Connection hiding (connect, connectDetail) 27 | import Database.MySQL.Protocol.Auth 28 | import Database.MySQL.Protocol.Packet 29 | import qualified Network.TLS as TLS 30 | import qualified System.IO.Streams.TCP as TCP 31 | import qualified Data.Connection as TCP 32 | import qualified System.IO.Streams.TLS as TLS 33 | 34 | -------------------------------------------------------------------------------- 35 | 36 | -- | Provide a 'TLS.ClientParams' and a subject name to establish a TLS connection. 37 | -- 38 | connect :: ConnectInfo -> (TLS.ClientParams, String) -> IO MySQLConn 39 | connect c cp = fmap snd (connectDetail c cp) 40 | 41 | connectDetail :: ConnectInfo -> (TLS.ClientParams, String) -> IO (Greeting, MySQLConn) 42 | connectDetail (ConnectInfo host port db user pass charset) (cparams, subName) = 43 | bracketOnError (connectWithBufferSize host port bUFSIZE) 44 | (TCP.close) $ \ c -> do 45 | let is = TCP.source c 46 | is' <- decodeInputStream is 47 | p <- readPacket is' 48 | greet <- decodeFromPacket p 49 | if supportTLS (greetingCaps greet) 50 | then do 51 | let cparams' = cparams { 52 | TLS.clientUseServerNameIndication = False 53 | , TLS.clientServerIdentification = (subName, "") 54 | } 55 | let (sock, sockAddr) = Conn.connExtraInfo c 56 | write c (encodeToPacket 1 $ sslRequest charset) 57 | bracketOnError (TLS.contextNew sock cparams') 58 | ( \ ctx -> TLS.bye ctx >> TCP.close c ) $ \ ctx -> do 59 | TLS.handshake ctx 60 | tc <- TLS.tLsToConnection (ctx, sockAddr) 61 | let tlsIs = TCP.source tc 62 | tlsIs' <- decodeInputStream tlsIs 63 | let auth = mkAuth db user pass charset greet 64 | write tc (encodeToPacket 2 auth) 65 | q <- readPacket tlsIs' 66 | if isOK q 67 | then do 68 | consumed <- newIORef True 69 | let conn = MySQLConn tlsIs' (write tc) (TCP.close tc) consumed 70 | return (greet, conn) 71 | else TCP.close c >> decodeFromPacket q >>= throwIO . ERRException 72 | else error "Database.MySQL.TLS: server doesn't support TLS connection" 73 | where 74 | connectWithBufferSize h p bs = TCP.connectSocket h p >>= TCP.socketToConnection bs 75 | write c a = TCP.send c $ Binary.runPut . Binary.put $ a 76 | -------------------------------------------------------------------------------- /src/System/IO/Streams/TCP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE CPP #-} 3 | 4 | -- | This module provides convenience functions for interfacing raw tcp. 5 | -- 6 | -- Please use 'E.bracket' or its friends to ensure exception safety. 7 | -- 8 | -- This module is intended to be imported @qualified@, e.g.: 9 | -- 10 | -- @ 11 | -- import "Data.Connection" 12 | -- import qualified "System.IO.Streams.TCP" as TCP 13 | -- @ 14 | -- 15 | module System.IO.Streams.TCP 16 | ( TCPConnection 17 | -- * client 18 | , connect 19 | , connectSocket 20 | , socketToConnection 21 | , defaultChunkSize 22 | -- * server 23 | , bindAndListen 24 | , bindAndListenWith 25 | , accept 26 | , acceptWith 27 | ) where 28 | 29 | import qualified Control.Exception as E 30 | import Control.Monad 31 | import Data.Connection 32 | import qualified Data.ByteString as B 33 | import qualified Data.ByteString.Lazy.Internal as L 34 | import qualified Network.Socket as N 35 | import qualified Network.Socket.ByteString as NB 36 | import qualified Network.Socket.ByteString.Lazy as NL 37 | import qualified System.IO.Streams as S 38 | import Foreign.Storable (sizeOf) 39 | 40 | addrAny :: N.HostAddress 41 | #if MIN_VERSION_network(2,7,0) 42 | addrAny = N.tupleToHostAddress (0,0,0,0) 43 | #else 44 | addrAny = N.iNADDR_ANY 45 | #endif 46 | 47 | -- | Type alias for tcp connection. 48 | -- 49 | -- Normally you shouldn't use 'N.Socket' in 'connExtraInfo' directly, this field is 50 | -- intend for used with 'N.setSocketOption' if you need to. 51 | -- 52 | type TCPConnection = Connection (N.Socket, N.SockAddr) 53 | 54 | -- | The chunk size used for I\/O, less the memory management overhead. 55 | -- 56 | -- Currently set to 32k. 57 | -- 58 | defaultChunkSize :: Int 59 | defaultChunkSize = 32 * k - chunkOverhead 60 | where 61 | k = 1024 62 | chunkOverhead = 2 * sizeOf (undefined :: Int) 63 | 64 | -- | Initiating an raw TCP connection to the given @('HostName', 'PortNumber')@ combination. 65 | -- 66 | -- It use 'N.getAddrInfo' to resolve host/service name 67 | -- with 'N.AI_ADDRCONFIG', 'N.AI_NUMERICSERV' hint set, so it should be able to 68 | -- resolve both numeric IPv4/IPv6 hostname and domain name. 69 | -- 70 | -- `TCP_NODELAY` are enabled by default. you can use 'N.setSocketOption' to adjust. 71 | -- 72 | connectSocket :: N.HostName -- ^ hostname to connect to 73 | -> N.PortNumber -- ^ port number to connect to 74 | -> IO (N.Socket, N.SockAddr) 75 | connectSocket host port = do 76 | (family, socketType, protocol, addr) <- resolveAddrInfo host port 77 | E.bracketOnError (N.socket family socketType protocol) 78 | N.close 79 | (\sock -> do N.connect sock addr 80 | N.setSocketOption sock N.NoDelay 1 81 | return (sock, addr) 82 | ) 83 | where 84 | resolveAddrInfo host' port' = do 85 | -- Partial function here OK, network will throw an exception rather than 86 | -- return the empty list here. 87 | (addrInfo:_) <- N.getAddrInfo (Just hints) (Just host') (Just $ show port') 88 | let family = N.addrFamily addrInfo 89 | let socketType = N.addrSocketType addrInfo 90 | let protocol = N.addrProtocol addrInfo 91 | let addr = N.addrAddress addrInfo 92 | return (family, socketType, protocol, addr) 93 | where 94 | hints = N.defaultHints { 95 | N.addrFlags = [N.AI_ADDRCONFIG, N.AI_NUMERICSERV] 96 | , N.addrSocketType = N.Stream 97 | } 98 | {-# INLINABLE resolveAddrInfo #-} 99 | 100 | -- | Make a 'Connection' from a 'Socket' with given buffer size. 101 | -- 102 | socketToConnection 103 | :: Int -- ^ receive buffer size 104 | -> (N.Socket, N.SockAddr) -- ^ socket address pair 105 | -> IO TCPConnection 106 | socketToConnection bufsiz (sock, addr) = do 107 | is <- S.makeInputStream $ do 108 | s <- NB.recv sock bufsiz 109 | return $! if B.null s then Nothing else Just s 110 | return (Connection is (send' sock) (N.close sock) (sock, addr)) 111 | where 112 | send' _ (L.Empty) = return () 113 | send' sock' (L.Chunk bs L.Empty) = unless (B.null bs) (NB.sendAll sock' bs) 114 | send' sock' lbs = NL.sendAll sock' lbs 115 | 116 | -- | Connect to server using 'defaultChunkSize'. 117 | -- 118 | connect :: N.HostName -- ^ hostname to connect to 119 | -> N.PortNumber -- ^ port number to connect to 120 | -> IO TCPConnection 121 | connect host port = connectSocket host port >>= socketToConnection defaultChunkSize 122 | 123 | -- | Bind and listen on port with a limit on connection count. 124 | -- 125 | -- This function will set @SO_REUSEADDR@, @TCP_NODELAY@ before binding. 126 | -- 127 | bindAndListen :: Int -- ^ connection limit 128 | -> N.PortNumber -- ^ port number 129 | -> IO N.Socket 130 | bindAndListen = bindAndListenWith $ \ sock -> do 131 | N.setSocketOption sock N.ReuseAddr 1 132 | N.setSocketOption sock N.NoDelay 1 133 | 134 | -- | Bind and listen on port with a limit on connection count. 135 | -- 136 | -- Note: The following socket options are inherited by a connected TCP socket from the listening socket: 137 | -- 138 | -- @ 139 | -- SO_DEBUG 140 | -- SO_DONTROUTE 141 | -- SO_KEEPALIVE 142 | -- SO_LINGER 143 | -- SO_OOBINLINE 144 | -- SO_RCVBUF 145 | -- SO_RCVLOWAT 146 | -- SO_SNDBUF 147 | -- SO_SNDLOWAT 148 | -- TCP_MAXSEG 149 | -- TCP_NODELAY 150 | -- @ 151 | -- 152 | bindAndListenWith :: (N.Socket -> IO ()) -- ^ set socket options before binding 153 | -> Int -- ^ connection limit 154 | -> N.PortNumber -- ^ port number 155 | -> IO N.Socket 156 | bindAndListenWith f maxc port = 157 | E.bracketOnError (N.socket N.AF_INET N.Stream 0) 158 | N.close 159 | (\sock -> do f sock 160 | N.bind sock (N.SockAddrInet port addrAny) 161 | N.listen sock maxc 162 | return sock 163 | ) 164 | 165 | -- | Accept a connection with 'defaultChunkSize'. 166 | -- 167 | accept :: N.Socket -> IO TCPConnection 168 | accept = acceptWith (socketToConnection defaultChunkSize) 169 | 170 | -- | Accept a connection with user customization. 171 | -- 172 | acceptWith :: ((N.Socket, N.SockAddr) -> IO TCPConnection) -- ^ set socket options, adjust receive buffer, etc. 173 | -> N.Socket 174 | -> IO TCPConnection 175 | acceptWith f = f <=< N.accept 176 | -------------------------------------------------------------------------------- /src/System/IO/Streams/TLS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | -- | This module provides convenience functions for interfacing @tls@. 4 | -- 5 | -- This module is intended to be imported @qualified@, e.g.: 6 | -- 7 | -- @ 8 | -- import "Data.Connection" 9 | -- import qualified "System.IO.Streams.TLS" as TLS 10 | -- @ 11 | -- 12 | module System.IO.Streams.TLS 13 | ( TLSConnection 14 | -- * client 15 | , connect 16 | , connectTLS 17 | , tLsToConnection 18 | -- * server 19 | , accept 20 | -- * re-export 21 | , module Data.TLSSetting 22 | ) where 23 | 24 | import qualified Control.Exception as E 25 | import Data.Connection 26 | import qualified Data.ByteString as B 27 | import qualified Data.ByteString.Char8 as BC 28 | import Data.TLSSetting 29 | import qualified Network.Socket as N 30 | import Network.TLS (ClientParams, Context, ServerParams) 31 | import qualified Network.TLS as TLS 32 | import qualified System.IO.Streams as Stream 33 | import qualified System.IO.Streams.TCP as TCP 34 | 35 | 36 | -- | Type alias for tls connection. 37 | -- 38 | -- Normally you shouldn't use 'TLS.Context' in 'connExtraInfo' directly. 39 | -- 40 | type TLSConnection = Connection (TLS.Context, N.SockAddr) 41 | 42 | -- | Make a 'Connection' from a 'Context'. 43 | -- 44 | tLsToConnection :: (Context, N.SockAddr) -- ^ TLS connection / socket address pair 45 | -> IO TLSConnection 46 | tLsToConnection (ctx, addr) = do 47 | is <- Stream.makeInputStream input 48 | return (Connection is write (closeTLS ctx) (ctx, addr)) 49 | where 50 | input = (do 51 | s <- TLS.recvData ctx 52 | return $! if B.null s then Nothing else Just s 53 | ) `E.catch` (\(_::E.SomeException) -> return Nothing) 54 | write s = TLS.sendData ctx s 55 | 56 | -- | Close a TLS 'Context' and its underlying socket. 57 | -- 58 | closeTLS :: Context -> IO () 59 | closeTLS ctx = (TLS.bye ctx >> TLS.contextClose ctx) -- sometimes socket was closed before 'TLS.bye' 60 | `E.catch` (\(_::E.SomeException) -> return ()) -- so we catch the 'Broken pipe' error here 61 | 62 | -- | Convenience function for initiating an TLS connection to the given 63 | -- @('HostName', 'PortNumber')@ combination. 64 | -- 65 | -- This operation may throw 'TLS.TLSException' on failure. 66 | -- 67 | connectTLS :: ClientParams -- ^ check "Data.TLSSetting" 68 | -> Maybe String -- ^ Optional certificate subject name, if set to 'Nothing' 69 | -- then we will try to verify 'HostName' as subject name 70 | -> N.HostName -- ^ hostname to connect to 71 | -> N.PortNumber -- ^ port number to connect to 72 | -> IO (Context, N.SockAddr) 73 | connectTLS prms subname host port = do 74 | let subname' = maybe host id subname 75 | prms' = prms { TLS.clientServerIdentification = (subname', BC.pack (show port)) } 76 | (sock, addr) <- TCP.connectSocket host port 77 | E.bracketOnError (TLS.contextNew sock prms') closeTLS $ \ ctx -> do 78 | TLS.handshake ctx 79 | return (ctx, addr) 80 | 81 | -- | Connect to server using TLS and return a 'Connection'. 82 | -- 83 | connect :: ClientParams -- ^ check "Data.TLSSetting" 84 | -> Maybe String -- ^ Optional certificate subject name, if set to 'Nothing' 85 | -- then we will try to verify 'HostName' as subject name 86 | -> N.HostName -- ^ hostname to connect to 87 | -> N.PortNumber -- ^ port number to connect to 88 | -> IO TLSConnection 89 | connect prms subname host port = connectTLS prms subname host port >>= tLsToConnection 90 | 91 | -- | Accept a new TLS connection from remote client with listening socket. 92 | -- 93 | -- This operation may throw 'TLS.TLSException' on failure. 94 | -- 95 | accept :: ServerParams -- ^ check "Data.TLSSetting" 96 | -> N.Socket -- ^ the listening 'Socket' 97 | -> IO TLSConnection 98 | accept prms sock = do 99 | (sock', addr) <- N.accept sock 100 | E.bracketOnError (TLS.contextNew sock' prms) closeTLS $ \ ctx -> do 101 | TLS.handshake ctx 102 | conn <- tLsToConnection (ctx, addr) 103 | return conn 104 | -------------------------------------------------------------------------------- /tcp-streams-bench/TCPLoopBack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main (main) where 4 | 5 | ------------------------------------------------------------------------------ 6 | import Control.Monad 7 | import Control.Concurrent (forkIO, newEmptyMVar, putMVar,threadDelay, 8 | takeMVar) 9 | import qualified Control.Exception as E 10 | import qualified Network.Socket as N 11 | import qualified Data.ByteString as B 12 | import qualified Data.ByteString.Lazy as L 13 | ------------------------------------------------------------------------------ 14 | import Data.Connection 15 | import qualified System.IO.Streams as Stream 16 | import qualified System.IO.Streams.TCP as TCP 17 | 18 | main :: IO () 19 | main = N.withSocketsDo $ do 20 | portMVar <- newEmptyMVar 21 | resultMVar <- newEmptyMVar 22 | forkIO $ server portMVar 23 | client portMVar resultMVar 24 | takeMVar resultMVar 25 | where 26 | chunk = replicate 1024 $ B.replicate (1024 * 1024) 64 27 | client mvar resultMVar = do 28 | _ <- takeMVar mvar 29 | conn <- TCP.connect "127.0.0.1" 8123 30 | send conn (L.fromChunks chunk) 31 | echo <- Stream.readExactly (1024 * 1024 * 1024) (source conn) 32 | print (B.length echo) 33 | putMVar resultMVar () 34 | close conn 35 | 36 | server mvar = do 37 | sock <- TCP.bindAndListen 1024 8123 38 | putMVar mvar () 39 | conn <- TCP.accept sock 40 | echo <- Stream.readExactly (1024 * 1024 * 1024) (source conn) 41 | send conn (L.fromStrict echo) 42 | -------------------------------------------------------------------------------- /tcp-streams-bench/tcp-streams-bench.cabal: -------------------------------------------------------------------------------- 1 | name: tcp-streams 2 | version: 0.5.0.0 3 | synopsis: One stop solution for tcp client and server with tls support. 4 | description: One stop solution for tcp client and server with tls support. 5 | license: BSD3 6 | license-file: LICENSE 7 | author: winterland1989 8 | maintainer: winterland1989@gmail.com 9 | -- copyright: 10 | category: Network 11 | build-type: Simple 12 | extra-source-files: ChangeLog.md 13 | , README.md 14 | , test/cert/*.pem 15 | , test/cert/*.crt 16 | , test/cert/*.key 17 | 18 | data-files: mozillaCAStore.pem 19 | cabal-version: >=1.10 20 | 21 | flag openssl 22 | description: Enable openssl support via @HsOpenSSL@ 23 | default: True 24 | 25 | source-repository head 26 | type: git 27 | location: git://github.com/didi-FP/tcp-streams.git 28 | 29 | library 30 | hs-source-dirs: ../ 31 | exposed-modules: Data.TLSSetting 32 | , Data.Connection 33 | , System.IO.Streams.TCP 34 | , System.IO.Streams.TLS 35 | 36 | other-modules: Paths_tcp_streams 37 | -- other-extensions: 38 | build-depends: base >=4.7 && < 5.0 39 | , network >=2.3 && < 3.0 40 | , bytestring >= 0.10.2.0 41 | , io-streams >= 1.2 && < 2.0 42 | , tls >= 1.3 && < 2.0 43 | , data-default-class 44 | , x509 >= 1.5 && < 2.0 45 | , x509-system >= 1.5 && < 2.0 46 | , x509-store >= 1.5 && < 2.0 47 | , pem 48 | 49 | ghc-options: -Wall 50 | -- hs-source-dirs: 51 | default-language: Haskell2010 52 | 53 | executable bench 54 | build-depends: base, tcp-streams, io-streams, bytestring, network 55 | default-language: Haskell2010 56 | hs-source-dirs: . 57 | main-is: TCPLoopBack.hs 58 | ghc-options: -O2 -threaded -rtsopts 59 | 60 | -------------------------------------------------------------------------------- /test/BinLogNew.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NegativeLiterals #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module BinLogNew where 5 | 6 | import Control.Applicative 7 | import Control.Exception 8 | import Control.Monad 9 | import Data.Time.Clock.POSIX 10 | import Data.Time.Format 11 | import Data.Time.LocalTime 12 | import Database.MySQL.Base 13 | import Database.MySQL.BinLog 14 | import qualified System.IO.Streams as Stream 15 | import Test.Tasty.HUnit 16 | 17 | eventProducer :: IO () 18 | eventProducer = do 19 | c <- connect defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell"} 20 | execute_ c q1 21 | execute_ c q2 22 | execute_ c q3 23 | return () 24 | 25 | tests :: MySQLConn -> Assertion 26 | tests c = do 27 | Just blt <- getLastBinLogTracker c 28 | x@(fd, _, _) <- dumpBinLog c 1002 blt False 29 | rowEventStream <- decodeRowBinLogEvent x 30 | 31 | let Just t = parseTimeM True defaultTimeLocale "%F %T%Q" "2016-08-08 17:25:59.1234" :: Maybe LocalTime 32 | z <- getCurrentTimeZone 33 | let timestamp = round $ utcTimeToPOSIXSeconds (localTimeToUTC z t) 34 | 35 | Just (RowUpdateEvent _ _ tme ue) <- Stream.read rowEventStream 36 | assertEqual "decode update event cloumn" (updateColumnCnt ue) 4 37 | assertEqual "decode update event rows" (updateRowData ue) 38 | [ 39 | ( 40 | [ BinLogLong 0 41 | , BinLogNull 42 | , BinLogNull 43 | , BinLogNull 44 | ], [ BinLogLong 0 45 | , BinLogDateTime2 2016 8 8 17 25 59 120000 46 | , BinLogTimeStamp2 timestamp 123400 47 | , BinLogTime2 0 199 59 59 123456 48 | ] 49 | ) 50 | ] 51 | 52 | Just (RowUpdateEvent _ _ tme ue) <- Stream.read rowEventStream 53 | assertEqual "decode update event rows" (updateRowData ue) 54 | [ 55 | ( 56 | [ BinLogLong 0 57 | , BinLogDateTime2 2016 8 8 17 25 59 120000 58 | , BinLogTimeStamp2 timestamp 123400 59 | , BinLogTime2 0 199 59 59 123456 60 | ], [ BinLogLong 0 61 | , BinLogDateTime2 2016 8 8 17 25 59 100000 62 | , BinLogTimeStamp2 timestamp 123000 63 | , BinLogTime2 1 199 59 59 123450 64 | ] 65 | ) 66 | ] 67 | 68 | Just (RowUpdateEvent _ _ tme ue) <- Stream.read rowEventStream 69 | assertEqual "decode update event rows" (updateRowData ue) 70 | [ 71 | ( 72 | [ BinLogLong 0 73 | , BinLogDateTime2 2016 8 8 17 25 59 100000 74 | , BinLogTimeStamp2 timestamp 123000 75 | , BinLogTime2 1 199 59 59 123450 76 | ], [ BinLogLong 0 77 | , BinLogNull 78 | , BinLogNull 79 | , BinLogTime2 0 0 59 59 123450 80 | ] 81 | ) 82 | ] 83 | 84 | q1 :: Query 85 | q1 = "UPDATE test_new SET \ 86 | \__datetime = '2016-08-08 17:25:59.12' ,\ 87 | \__timestamp = '2016-08-08 17:25:59.1234' ,\ 88 | \__time = '-199:59:59.123456' WHERE __id=0;" 89 | 90 | q2 :: Query 91 | q2 = "UPDATE test_new SET \ 92 | \__datetime = '2016-08-08 17:25:59.1' ,\ 93 | \__timestamp = '2016-08-08 17:25:59.123' ,\ 94 | \__time = '199:59:59.12345' WHERE __id=0;" 95 | 96 | 97 | q3 :: Query 98 | q3 = "UPDATE test_new SET \ 99 | \__datetime = null ,\ 100 | \__timestamp = null ,\ 101 | \__time = '-00:59:59.12345' WHERE __id=0;" 102 | -------------------------------------------------------------------------------- /test/BinaryRowNew.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NegativeLiterals #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module BinaryRowNew where 5 | 6 | import Control.Applicative 7 | import Data.Time.Calendar (fromGregorian) 8 | import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..)) 9 | import Database.MySQL.Base 10 | import qualified System.IO.Streams as Stream 11 | import Test.Tasty.HUnit 12 | 13 | tests :: MySQLConn -> Assertion 14 | tests c = do 15 | selStmt <- prepareStmt c "SELECT * FROM test_new" 16 | 17 | (f, is) <- queryStmt c selStmt [] 18 | assertEqual "decode Field types" (columnType <$> f) 19 | [ mySQLTypeLong 20 | , mySQLTypeDateTime 21 | , mySQLTypeTimestamp 22 | , mySQLTypeTime 23 | ] 24 | 25 | Just v <- Stream.read is 26 | assertEqual "decode NULL values" v 27 | [ MySQLInt32 0 28 | , MySQLNull 29 | , MySQLNull 30 | , MySQLNull 31 | ] 32 | 33 | Stream.skipToEof is 34 | 35 | execute_ c "UPDATE test_new SET \ 36 | \__datetime = '2016-08-08 17:25:59.12' ,\ 37 | \__timestamp = '2016-08-08 17:25:59.1234' ,\ 38 | \__time = '-199:59:59.123456' WHERE __id=0" 39 | 40 | (_, is) <- queryStmt c selStmt [] 41 | Just v <- Stream.read is 42 | 43 | assertEqual "decode binary protocol" v 44 | [ MySQLInt32 0 45 | , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12)) 46 | , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1234)) 47 | , MySQLTime 1 (TimeOfDay 199 59 59.123456) 48 | ] 49 | 50 | Stream.skipToEof is 51 | 52 | execute_ c "UPDATE test_new SET \ 53 | \__datetime = '2016-08-08 17:25:59.1' ,\ 54 | \__timestamp = '2016-08-08 17:25:59.12' ,\ 55 | \__time = '199:59:59.123' WHERE __id=0" 56 | 57 | (_, is) <- queryStmt c selStmt [] 58 | Just v <- Stream.read is 59 | 60 | assertEqual "decode binary protocol 2" v 61 | [ MySQLInt32 0 62 | , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1)) 63 | , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12)) 64 | , MySQLTime 0 (TimeOfDay 199 59 59.123) 65 | ] 66 | 67 | Stream.skipToEof is 68 | 69 | updStmt <- prepareStmt c 70 | "UPDATE test_new SET \ 71 | \__datetime = ? ,\ 72 | \__timestamp = ? ,\ 73 | \__time = ? WHERE __id=0" 74 | 75 | executeStmt c updStmt 76 | [ MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12)) 77 | , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1234)) 78 | , MySQLTime 1 (TimeOfDay 199 59 59.123456) 79 | ] 80 | 81 | 82 | (_, is) <- queryStmt c selStmt [] 83 | Just v <- Stream.read is 84 | 85 | assertEqual "roundtrip binary protocol" v 86 | [ MySQLInt32 0 87 | , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12)) 88 | , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1234)) 89 | , MySQLTime 1 (TimeOfDay 199 59 59.123456) 90 | ] 91 | 92 | Stream.skipToEof is 93 | 94 | executeStmt c updStmt 95 | [ MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1)) 96 | , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12)) 97 | , MySQLTime 0 (TimeOfDay 199 59 59.1234) 98 | ] 99 | 100 | 101 | (_, is) <- queryStmt c selStmt [] 102 | Just v <- Stream.read is 103 | 104 | assertEqual "roundtrip binary protocol 2" v 105 | [ MySQLInt32 0 106 | , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1)) 107 | , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12)) 108 | , MySQLTime 0 (TimeOfDay 199 59 59.1234) 109 | ] 110 | 111 | Stream.skipToEof is 112 | -------------------------------------------------------------------------------- /test/ExecuteMany.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NegativeLiterals #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module ExecuteMany where 5 | 6 | import Control.Applicative 7 | import Data.Time.Calendar (fromGregorian) 8 | import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..)) 9 | import Database.MySQL.Base 10 | import qualified System.IO.Streams as Stream 11 | import Test.Tasty.HUnit 12 | 13 | tests :: MySQLConn -> Assertion 14 | tests c = do 15 | 16 | oks <- withTransaction c $ executeMany c "INSERT INTO test VALUES(\ 17 | \? ,\ 18 | \? ,\ 19 | \? ,\ 20 | \? ,\ 21 | \? ,\ 22 | \? ,\ 23 | \? ,\ 24 | \? ,\ 25 | \? ,\ 26 | \? ,\ 27 | \? ,\ 28 | \? ,\ 29 | \? ,\ 30 | \? ,\ 31 | \? ,\ 32 | \? ,\ 33 | \? ,\ 34 | \? ,\ 35 | \? ,\ 36 | \? ,\ 37 | \? ,\ 38 | \? ,\ 39 | \? ,\ 40 | \? ,\ 41 | \? ,\ 42 | \? ,\ 43 | \? ,\ 44 | \? ,\ 45 | \? ,\ 46 | \?)" 47 | (replicate 50000 48 | [ MySQLInt32 0 49 | , MySQLBit 255 50 | , MySQLInt8 (-128) 51 | , MySQLInt8U 255 52 | , MySQLInt16 (-32768) 53 | , MySQLInt16U 65535 54 | , MySQLInt32 (-8388608) 55 | , MySQLInt32U 16777215 56 | , MySQLInt32 (-2147483648) 57 | , MySQLInt32U 4294967295 58 | , MySQLInt64 (-9223372036854775808) 59 | , MySQLInt64U 18446744073709551615 60 | , MySQLDecimal 1234567890.0123456789 61 | , MySQLFloat 3.14159 62 | , MySQLDouble 3.1415926535 63 | , MySQLDate (fromGregorian 2016 08 08) 64 | , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59)) 65 | , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59)) 66 | , MySQLTime 1 (TimeOfDay 199 59 59) 67 | , MySQLYear 1999 68 | , MySQLText "12345678" 69 | , MySQLText "韩冬真赞" 70 | , MySQLBytes "12345678" 71 | , MySQLBytes "12345678" 72 | , MySQLBytes "12345678" 73 | , MySQLText "韩冬真赞" 74 | , MySQLBytes "12345678" 75 | , MySQLText "韩冬真赞" 76 | , MySQLText "foo" 77 | , MySQLText "foo,bar" 78 | ] 79 | ) 80 | assertEqual "executeMany affected rows" (sum $ map okAffectedRows oks) 50000 81 | -------------------------------------------------------------------------------- /test/JSON.hs: -------------------------------------------------------------------------------- 1 | module JSON where 2 | 3 | import Control.Monad 4 | import Control.Applicative 5 | import qualified Data.ByteString as B 6 | import Test.Tasty.HUnit 7 | import Test.Tasty (TestTree) 8 | import System.Directory (getDirectoryContents, doesDirectoryExist) 9 | import System.FilePath (()) 10 | import qualified Aeson as A 11 | import qualified Data.Attoparsec.ByteString as A 12 | import qualified AesonBP as B 13 | import qualified Data.Binary.Parser as B 14 | import Data.List 15 | 16 | 17 | pathTo :: String -> IO FilePath 18 | pathTo wat = do 19 | exists <- doesDirectoryExist "test" 20 | return $ if exists 21 | then "test" wat 22 | else wat 23 | 24 | tests :: IO [TestTree] 25 | tests = do 26 | path <- pathTo "json-data" 27 | names <- sort . filter (`notElem` [".", ".."]) <$> getDirectoryContents path 28 | forM names $ \name -> do 29 | bs <- B.readFile (path name) 30 | return $ testCase name $ 31 | assertEqual name (A.parseOnly A.jsonEOF' bs) (B.parseOnly B.jsonEOF' bs) 32 | 33 | 34 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import qualified QC.ByteString as ByteString 4 | import qualified QC.Combinator as Combinator 5 | import Test.Tasty (defaultMain, testGroup) 6 | import qualified JSON 7 | import qualified MysqlTests 8 | import qualified Word24 9 | import qualified TCPStreams 10 | 11 | main :: IO () 12 | main = do 13 | jsonTests <- JSON.tests 14 | defaultMain $ testGroup "tests" [ 15 | testGroup "binary-parser" [ 16 | testGroup "bs" ByteString.tests 17 | , testGroup "combinator" Combinator.tests 18 | , testGroup "JSON" jsonTests 19 | ], 20 | testGroup "mysql" [ 21 | -- TODO figure out how to run the tests that need a mysql 22 | -- db 23 | -- MysqlTests.tests 24 | ], 25 | testGroup "word24" 26 | Word24.tests 27 | , testGroup "tcp-streams" 28 | [ 29 | TCPStreams.tests 30 | ] 31 | ] 32 | -------------------------------------------------------------------------------- /test/MysqlTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module MysqlTests(tests) where 4 | 5 | import qualified BinaryRow 6 | import qualified BinaryRowNew 7 | import qualified BinLog 8 | import qualified BinLogNew 9 | import Control.Concurrent (forkIO, threadDelay) 10 | import Control.Exception (bracket, catch) 11 | import Control.Monad 12 | import qualified Data.ByteString as B 13 | import Database.MySQL.Base 14 | import Database.MySQL.BinLog 15 | import System.Environment 16 | import qualified System.IO.Streams as Stream 17 | import Test.Tasty 18 | import Test.Tasty.HUnit 19 | import qualified TextRow 20 | import qualified ExecuteMany 21 | import qualified TextRowNew 22 | 23 | tests :: TestTree 24 | tests = testCaseSteps "mysql-haskell test suit" $ \step -> do 25 | 26 | step "preparing table..." 27 | (greet, c) <- connectDetail defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell"} 28 | 29 | let ver = greetingVersion greet 30 | isNew = "5.6" `B.isPrefixOf` ver 31 | || "5.7" `B.isPrefixOf` ver -- from MySQL 5.6.4 and up 32 | -- TIME, DATETIME, and TIMESTAMP support fractional seconds 33 | 34 | 35 | execute_ c "DROP TABLE IF EXISTS test" 36 | execute_ c "DROP TABLE IF EXISTS test_new" 37 | 38 | execute_ c "CREATE TABLE test(\ 39 | \__id INT,\ 40 | \__bit BIT(16),\ 41 | \__tinyInt TINYINT,\ 42 | \__tinyIntU TINYINT UNSIGNED,\ 43 | \__smallInt SMALLINT,\ 44 | \__smallIntU SMALLINT UNSIGNED,\ 45 | \__mediumInt MEDIUMINT,\ 46 | \__mediumIntU MEDIUMINT UNSIGNED,\ 47 | \__int INT,\ 48 | \__intU INT UNSIGNED,\ 49 | \__bigInt BIGINT,\ 50 | \__bigIntU BIGINT UNSIGNED,\ 51 | \__decimal DECIMAL(20,10),\ 52 | \__float FLOAT,\ 53 | \__double DOUBLE,\ 54 | \__date DATE,\ 55 | \__datetime DATETIME,\ 56 | \__timestamp TIMESTAMP NULL,\ 57 | \__time TIME,\ 58 | \__year YEAR(4),\ 59 | \__char CHAR(8),\ 60 | \__varchar VARCHAR(1024),\ 61 | \__binary BINARY(8),\ 62 | \__varbinary VARBINARY(1024),\ 63 | \__tinyblob TINYBLOB,\ 64 | \__tinytext TINYTEXT,\ 65 | \__blob BLOB(1000000),\ 66 | \__text TEXT(1000000),\ 67 | \__enum ENUM('foo', 'bar', 'qux'),\ 68 | \__set SET('foo', 'bar', 'qux')\ 69 | \) CHARACTER SET utf8" 70 | 71 | resetTestTable c 72 | 73 | step "testing executeMany" 74 | ExecuteMany.tests c 75 | 76 | resetTestTable c 77 | 78 | step "testing text protocol" 79 | TextRow.tests c 80 | 81 | resetTestTable c 82 | 83 | step "testing binary protocol" 84 | BinaryRow.tests c 85 | 86 | resetTestTable c 87 | 88 | 89 | when isNew $ do 90 | execute_ c "CREATE TABLE test_new(\ 91 | \__id INT,\ 92 | \__datetime DATETIME(2),\ 93 | \__timestamp TIMESTAMP(4) NULL,\ 94 | \__time TIME(6)\ 95 | \) CHARACTER SET utf8" 96 | 97 | resetTest57Table c 98 | 99 | step "testing MySQL5.7 extra text protocol" 100 | TextRowNew.tests c 101 | 102 | resetTest57Table c 103 | 104 | step "testing MySQL5.7 extra binary protocol" 105 | BinaryRowNew.tests c 106 | 107 | void $ resetTest57Table c 108 | 109 | step "testing binlog protocol" 110 | 111 | if isNew 112 | then do 113 | forkIO BinLogNew.eventProducer 114 | BinLogNew.tests c 115 | else do 116 | forkIO BinLog.eventProducer 117 | BinLog.tests c 118 | 119 | close c 120 | 121 | (greet, c) <- connectDetail defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell"} 122 | execute_ c "SET PASSWORD = PASSWORD('123456abcdefg???')" 123 | close c 124 | 125 | let loginFailMsg = "ERRException (ERR {errCode = 1045, errState = \"28000\", \ 126 | \errMsg = \"Access denied for user 'testMySQLHaskell'@'localhost' (using password: YES)\"})" 127 | 128 | (greet, c) <- connectDetail 129 | defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell", ciPassword = "123456abcdefg???"} 130 | execute_ c "SET PASSWORD = PASSWORD('')" 131 | close c 132 | 133 | catch 134 | (void $ connectDetail 135 | defaultConnectInfo 136 | {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell", ciPassword = "wrongPassWord"}) 137 | (\ (e :: ERRException) -> assertEqual "wrong password should fail to login" (show e) loginFailMsg) 138 | 139 | where 140 | resetTestTable c = do 141 | execute_ c "DELETE FROM test WHERE __id=0" 142 | execute_ c "INSERT INTO test VALUES(\ 143 | \0,\ 144 | \NULL,\ 145 | \NULL,\ 146 | \NULL,\ 147 | \NULL,\ 148 | \NULL,\ 149 | \NULL,\ 150 | \NULL,\ 151 | \NULL,\ 152 | \NULL,\ 153 | \NULL,\ 154 | \NULL,\ 155 | \NULL,\ 156 | \NULL,\ 157 | \NULL,\ 158 | \NULL,\ 159 | \NULL,\ 160 | \NULL,\ 161 | \NULL,\ 162 | \NULL,\ 163 | \NULL,\ 164 | \NULL,\ 165 | \NULL,\ 166 | \NULL,\ 167 | \NULL,\ 168 | \NULL,\ 169 | \NULL,\ 170 | \NULL,\ 171 | \NULL,\ 172 | \NULL\ 173 | \)" 174 | 175 | resetTest57Table c = do 176 | execute_ c "DELETE FROM test_new WHERE __id=0" 177 | execute_ c "INSERT INTO test_new VALUES(\ 178 | \0,\ 179 | \NULL,\ 180 | \NULL,\ 181 | \NULL\ 182 | \)" 183 | 184 | 185 | -------------------------------------------------------------------------------- /test/QC/Combinator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, OverloadedStrings #-} 2 | 3 | module QC.Combinator where 4 | 5 | #if !MIN_VERSION_base(4,8,0) 6 | import Control.Applicative 7 | #endif 8 | import qualified Control.Monad as M (replicateM) 9 | import Data.Maybe (fromJust, isJust) 10 | import Data.Word (Word8) 11 | import QC.Common (Repack, parseBS, repackBS, toLazyBS) 12 | import Test.Tasty (TestTree) 13 | import Test.Tasty.QuickCheck (testProperty) 14 | import Test.QuickCheck 15 | import qualified Data.Binary.Parser as P 16 | import qualified Data.ByteString as B 17 | import qualified Data.ByteString.Char8 as B8 18 | import qualified Data.Foldable as Foldable (asum) 19 | 20 | asum :: NonEmptyList (NonEmptyList Word8) -> Gen Property 21 | asum (NonEmpty xs) = do 22 | let ys = map (B.pack . getNonEmpty) xs 23 | return . forAll (repackBS <$> arbitrary <*> elements ys) $ 24 | maybe False (`elem` ys) . parseBS (Foldable.asum (map (\s -> P.string s *> pure s) ys)) 25 | 26 | replicateM :: Positive (Small Int) -> Repack -> B.ByteString -> Bool 27 | replicateM (Positive (Small n)) rs s = 28 | (length <$> parseBS (M.replicateM n (P.string s)) input) == Just n 29 | where input = repackBS rs (B.concat (replicate (n+1) s)) 30 | 31 | lookAhead :: NonEmptyList Word8 -> Bool 32 | lookAhead (NonEmpty xs) = 33 | let ys = B.pack xs 34 | withLookAheadThenConsume = (\x y -> (x, y)) <$> P.lookAhead (P.string ys) <*> P.string ys 35 | mr = parseBS withLookAheadThenConsume $ toLazyBS ys 36 | in isJust mr && fst (fromJust mr) == snd (fromJust mr) 37 | 38 | tests :: [TestTree] 39 | tests = [ 40 | testProperty "asum" asum 41 | , testProperty "replicateM" replicateM 42 | , testProperty "lookAhead" lookAhead 43 | ] 44 | -------------------------------------------------------------------------------- /test/QC/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, FlexibleInstances #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | module QC.Common 4 | ( 5 | ASCII(..) 6 | , parseBS 7 | , toLazyBS 8 | , toStrictBS 9 | , Repack 10 | , repackBS 11 | , repackBS_ 12 | , liftOp 13 | ) where 14 | 15 | #if !MIN_VERSION_base(4,8,0) 16 | import Control.Applicative 17 | #endif 18 | import Data.Char (isAlpha) 19 | import Test.QuickCheck 20 | import Test.QuickCheck.Instances () 21 | import qualified Data.ByteString as B 22 | import qualified Data.ByteString.Lazy as BL 23 | import qualified Data.Binary.Parser as P 24 | 25 | #if !MIN_VERSION_base(4,4,0) 26 | -- This should really be a dependency on the random package :-( 27 | instance Random Word8 where 28 | randomR = integralRandomR 29 | random = randomR (minBound,maxBound) 30 | 31 | instance Arbitrary Word8 where 32 | arbitrary = choose (minBound, maxBound) 33 | #endif 34 | 35 | parseBS :: P.Get r -> BL.ByteString -> Maybe r 36 | parseBS p lbs = case P.parseLazy p lbs of 37 | Left _ -> Nothing 38 | Right v -> Just v 39 | 40 | toStrictBS :: BL.ByteString -> B.ByteString 41 | toStrictBS = B.concat . BL.toChunks 42 | 43 | toLazyBS :: B.ByteString -> BL.ByteString 44 | toLazyBS = BL.fromChunks . (:[]) 45 | 46 | newtype ASCII a = ASCII { fromASCII :: a } 47 | deriving (Eq, Ord, Show) 48 | 49 | instance Arbitrary (ASCII B.ByteString) where 50 | arbitrary = (ASCII . B.pack) <$> listOf (choose (0,127)) 51 | shrink = map (ASCII . B.pack) . shrink . B.unpack . fromASCII 52 | 53 | instance Arbitrary (ASCII BL.ByteString) where 54 | arbitrary = ASCII <$> (repackBS <$> arbitrary <*> (fromASCII <$> arbitrary)) 55 | shrink = map (ASCII . BL.pack) . shrink . BL.unpack . fromASCII 56 | 57 | type Repack = NonEmptyList (Positive (Small Int)) 58 | 59 | repackBS :: Repack -> B.ByteString -> BL.ByteString 60 | repackBS (NonEmpty bs) = 61 | BL.fromChunks . repackBS_ (map (getSmall . getPositive) bs) 62 | 63 | repackBS_ :: [Int] -> B.ByteString -> [B.ByteString] 64 | repackBS_ = go . cycle 65 | where go (b:bs) s 66 | | B.null s = [] 67 | | otherwise = let (h,t) = B.splitAt b s 68 | in h : go bs t 69 | go _ _ = error "unpossible" 70 | 71 | liftOp :: (Show a, Testable prop) => 72 | String -> (a -> a -> prop) -> a -> a -> Property 73 | liftOp name f x y = counterexample desc (f x y) 74 | where op = case name of 75 | (c:_) | isAlpha c -> " `" ++ name ++ "` " 76 | | otherwise -> " " ++ name ++ " " 77 | _ -> " ??? " 78 | desc = "not (" ++ show x ++ op ++ show y ++ ")" 79 | -------------------------------------------------------------------------------- /test/QCUtils.hs: -------------------------------------------------------------------------------- 1 | module QCUtils where 2 | 3 | import Test.QuickCheck 4 | import Test.QuickCheck.Arbitrary 5 | import Test.QuickCheck.Gen 6 | 7 | import Data.Int 8 | import Data.Int.Int24 9 | import Data.Word 10 | import Data.Word.Word24 11 | 12 | -- Arbitrary/CoArbitrary instances for Int24 and Word24 13 | 14 | instance Arbitrary Int24 where 15 | arbitrary = arbitraryBoundedIntegral 16 | shrink = shrinkIntegral 17 | 18 | instance CoArbitrary Int24 where 19 | coarbitrary = coarbitraryIntegral 20 | 21 | instance Arbitrary Word24 where 22 | arbitrary = arbitraryBoundedIntegral 23 | shrink = shrinkIntegral 24 | 25 | instance CoArbitrary Word24 where 26 | coarbitrary = coarbitraryIntegral 27 | -------------------------------------------------------------------------------- /test/TCPStreams.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module TCPStreams (tests) where 5 | 6 | ------------------------------------------------------------------------------ 7 | import Control.Concurrent (forkIO, newEmptyMVar, putMVar, 8 | takeMVar) 9 | import qualified Network.Socket as N 10 | import System.Timeout (timeout) 11 | import Test.Tasty 12 | import Test.Tasty.HUnit hiding (Test) 13 | import qualified Data.ByteString as B 14 | import qualified Data.ByteString.Lazy as L 15 | import System.Directory (removeFile) 16 | ------------------------------------------------------------------------------ 17 | import qualified Data.TLSSetting as TLS 18 | import Data.Connection 19 | import qualified System.IO.Streams as Stream 20 | import qualified System.IO.Streams.TCP as TCP 21 | import qualified System.IO.Streams.TLS as TLS 22 | ------------------------------------------------------------------------------ 23 | 24 | tests :: TestTree 25 | tests = testGroup "tests" [ testGroup "TCP" tcpTests 26 | , testGroup "TLS" tlsTests 27 | ] 28 | 29 | ------------------------------------------------------------------------------ 30 | 31 | tcpTests :: [TestTree] 32 | tcpTests = [ testTCPSocket ] 33 | 34 | testTCPSocket :: TestTree 35 | testTCPSocket = testCase "network/socket" $ 36 | N.withSocketsDo $ do 37 | x <- timeout (10 * 10^(6::Int)) go 38 | assertEqual "ok" (Just ()) x 39 | 40 | where 41 | go = do 42 | portMVar <- newEmptyMVar 43 | resultMVar <- newEmptyMVar 44 | forkIO $ client portMVar resultMVar 45 | server portMVar 46 | l <- takeMVar resultMVar 47 | assertEqual "testSocket" l ["ok"] 48 | 49 | client mvar resultMVar = do 50 | _ <- takeMVar mvar 51 | conn <- TCP.connect "127.0.0.1" 8888 52 | send conn "ok" 53 | Stream.toList (source conn) >>= putMVar resultMVar 54 | close conn 55 | 56 | server mvar = do 57 | sock <- TCP.bindAndListen 1024 8888 58 | putMVar mvar () 59 | conn <- TCP.accept sock 60 | req <- Stream.readExactly 2 (source conn) 61 | send conn (L.fromStrict req) 62 | close conn 63 | 64 | ------------------------------------------------------------------------------ 65 | 66 | tlsTests :: [TestTree] 67 | tlsTests = [ testTLSSocket 68 | -- TODO disabled because won't work in a nix container 69 | -- , testHTTPS 70 | ] 71 | 72 | testTLSSocket :: TestTree 73 | testTLSSocket = testCase "network/socket" $ 74 | N.withSocketsDo $ do 75 | x <- timeout (10 * 10^(6::Int)) go 76 | assertEqual "ok" (Just ()) x 77 | 78 | where 79 | go = do 80 | portMVar <- newEmptyMVar 81 | resultMVar <- newEmptyMVar 82 | forkIO $ client portMVar resultMVar 83 | server portMVar 84 | l <- takeMVar resultMVar 85 | assertEqual "testSocket" l ["ok"] 86 | 87 | client mvar resultMVar = do 88 | _ <- takeMVar mvar 89 | cp <- TLS.makeClientParams (TLS.CustomCAStore "./test/cert/ca.pem") 90 | conn <- TLS.connect cp (Just "Winter") "127.0.0.1" 8889 91 | send conn "ok" 92 | Stream.toList (source conn) >>= putMVar resultMVar 93 | close conn 94 | 95 | server mvar = do 96 | sp <- TLS.makeServerParams "./test/cert/server-cert.pem" [] "./test/cert/server-key.pem" 97 | sock <- TCP.bindAndListen 1024 8889 98 | putMVar mvar () 99 | conn <- TLS.accept sp sock 100 | req <- Stream.readExactly 2 (source conn) 101 | send conn (L.fromStrict req) 102 | close conn 103 | 104 | testHTTPS :: TestTree 105 | testHTTPS = testCase "network/https" $ 106 | N.withSocketsDo $ do 107 | x <- timeout (10 * 10^(6::Int)) go 108 | assertEqual "ok" (Just 1024) x 109 | where 110 | go = do 111 | cp <- TLS.makeClientParams TLS.MozillaCAStore 112 | conn <- TLS.connect cp Nothing "www.bing.com" 443 113 | send conn ("GET / HTTP/1.1\r\n") 114 | send conn ("Host: www.bing.com\r\n") 115 | send conn ("\r\n") 116 | bs <- Stream.readExactly 1024 (source conn) 117 | close conn 118 | return (B.length bs) 119 | -------------------------------------------------------------------------------- /test/TextRowNew.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NegativeLiterals #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module TextRowNew where 5 | 6 | import Control.Applicative 7 | import Data.Time.Calendar (fromGregorian) 8 | import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..)) 9 | import Database.MySQL.Base 10 | import qualified System.IO.Streams as Stream 11 | import Test.Tasty.HUnit 12 | 13 | tests :: MySQLConn -> Assertion 14 | tests c = do 15 | (f, is) <- query_ c "SELECT * FROM test_new" 16 | 17 | assertEqual "decode Field types" (columnType <$> f) 18 | [ mySQLTypeLong 19 | , mySQLTypeDateTime 20 | , mySQLTypeTimestamp 21 | , mySQLTypeTime 22 | ] 23 | 24 | Just v <- Stream.read is 25 | assertEqual "decode NULL values" v 26 | [ MySQLInt32 0 27 | , MySQLNull 28 | , MySQLNull 29 | , MySQLNull 30 | ] 31 | 32 | Stream.skipToEof is 33 | 34 | execute_ c "UPDATE test_new SET \ 35 | \__datetime = '2016-08-08 17:25:59.12' ,\ 36 | \__timestamp = '2016-08-08 17:25:59.1234' ,\ 37 | \__time = '-199:59:59.123456' WHERE __id=0" 38 | 39 | (_, is) <- query_ c "SELECT * FROM test_new" 40 | Just v <- Stream.read is 41 | 42 | assertEqual "decode text protocol" v 43 | [ MySQLInt32 0 44 | , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12)) 45 | , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1234)) 46 | , MySQLTime 1 (TimeOfDay 199 59 59.123456) 47 | ] 48 | 49 | Stream.skipToEof is 50 | 51 | execute_ c "UPDATE test_new SET \ 52 | \__datetime = '2016-08-08 17:25:59.1' ,\ 53 | \__timestamp = '2016-08-08 17:25:59.12' ,\ 54 | \__time = '199:59:59.1234' WHERE __id=0" 55 | 56 | (_, is) <- query_ c "SELECT * FROM test_new" 57 | Just v <- Stream.read is 58 | 59 | assertEqual "decode text protocol 2" v 60 | [ MySQLInt32 0 61 | , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1)) 62 | , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12)) 63 | , MySQLTime 0 (TimeOfDay 199 59 59.1234) 64 | ] 65 | 66 | Stream.skipToEof is 67 | 68 | execute c "UPDATE test_new SET \ 69 | \__datetime = ? ,\ 70 | \__timestamp = ? ,\ 71 | \__time = ? WHERE __id=0" 72 | [ MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12)) 73 | , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1234)) 74 | , MySQLTime 1 (TimeOfDay 199 59 59.123456) 75 | ] 76 | 77 | 78 | (_, is) <- query_ c "SELECT * FROM test_new" 79 | Just v <- Stream.read is 80 | 81 | assertEqual "roundtrip text protocol" v 82 | [ MySQLInt32 0 83 | , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12)) 84 | , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1234)) 85 | , MySQLTime 1 (TimeOfDay 199 59 59.123456) 86 | ] 87 | 88 | Stream.skipToEof is 89 | 90 | execute c "UPDATE test_new SET \ 91 | \__datetime = ? ,\ 92 | \__timestamp = ? ,\ 93 | \__time = ? WHERE __id=0" 94 | [ MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1)) 95 | , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12)) 96 | , MySQLTime 0 (TimeOfDay 199 59 59.1234) 97 | ] 98 | 99 | (_, is) <- query_ c "SELECT * FROM test_new" 100 | Just v <- Stream.read is 101 | 102 | assertEqual "roundtrip text protocol 2" v 103 | [ MySQLInt32 0 104 | , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1)) 105 | , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12)) 106 | , MySQLTime 0 (TimeOfDay 199 59 59.1234) 107 | ] 108 | 109 | Stream.skipToEof is 110 | 111 | let row0 = 112 | [ MySQLInt32 0 113 | , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.10)) 114 | , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12)) 115 | , MySQLTime 0 (TimeOfDay 199 59 59.1234) 116 | ] 117 | let row1 = 118 | [ MySQLInt32 1 119 | , MySQLDateTime (LocalTime (fromGregorian 2016 08 09) (TimeOfDay 18 25 59.10)) 120 | , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 09) (TimeOfDay 18 25 59.12)) 121 | , MySQLTime 0 (TimeOfDay 299 59 59.1234) 122 | ] 123 | execute c "UPDATE test_new SET \ 124 | \__id = ? ,\ 125 | \__datetime = ? ,\ 126 | \__timestamp = ? ,\ 127 | \__time = ? WHERE __id=0" 128 | row0 129 | execute c "INSERT INTO test_new VALUES(\ 130 | \?,\ 131 | \?,\ 132 | \?,\ 133 | \? \ 134 | \)" 135 | row1 136 | 137 | (_, is) <- query c "SELECT * FROM test_new WHERE __id IN (?) ORDER BY __id" [Many [MySQLInt32 0, MySQLInt32 1]] 138 | Just v0 <- Stream.read is 139 | Just v1 <- Stream.read is 140 | 141 | assertEqual "select list of ids" [v0, v1] [row0, row1] 142 | 143 | Stream.skipToEof is 144 | execute_ c "DELETE FROM test_new where __id=1" 145 | 146 | return () 147 | -------------------------------------------------------------------------------- /test/cert/ca-key.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN RSA PRIVATE KEY----- 2 | MIIEpAIBAAKCAQEAro5f0Xvee3jDWdcbfAUriec9Hle2gwGH1gWhkVJvt8e6WfSi 3 | LJEwEQJozgj3Mo8LNcd6J1/CwD7njNXE7IoGV9mqaC2b15EwzSkVFGz7M9EFH3rK 4 | PsipFIlevgCNpIvjHPIaGXJ6g5iVm4MxnG1k5TjNrJFHV7MeYi/aJRaLQ1ZStMRS 5 | U8e8b59XOzJ9jJBYE+p+KWWOzRMNkIUJEM1gOPSUrWChwD01LzMeyInpEkH305Or 6 | DTF4KfUXqWD9xMk1/l3Qk0yMWi6nEjNb3oI6yk3VzXKv6UAuy5XlEYF7ldLKezCb 7 | 4sBXPzVXMu7TCHnQR7R4X/3pIQSIaezDvNil4QIDAQABAoIBAQCNIoasvQe1M35X 8 | 3InXa+K5HKOZLfhe0lT/IgxxkILNyIqPAzJA8J85kYYl2K/uTCQXNpM41L+FaxcT 9 | EyCm1C6ux0p18zKHSFh5+VaW7krpqX4H5uMxglLbTPqyi4X63jQiikm5+4q9bhjA 10 | 5YGuZfDnOVdqyQgzC5tsbh5mUGUHaqREdecoWPkE5etId+zWOgq2yVTYgJaTYga1 11 | sS9rtlHQTdgI5ZuEQe11X8JT40ghApo5glXXZnSPWeSA4hNJIKKTBllxrwBG0ZYI 12 | BVf/pSiGciEz+fYrzv9JmPTjWEWutyr2AV5OMMnv1HTY5pkFFmylQTU8AHjFfUGD 13 | Vlf7xmpFAoGBAOb0FZqBs6HWkU4FnWKe+48sO1bMEsAu3MO6Nk+o3eTd47J+bSXe 14 | 17UyGDSzGdnH1MxVeHmEqmfiXwkP9LEVr5ywbEqgzxFyRpXOXW+DxWs2boCJoGdW 15 | FDdzjcJxigub/auSJasynowOjpYWLvWhlutVlhXC0XOhTejPUTh/xGKLAoGBAMF8 16 | iuRLnIGIJ9anYo4RsKp26g/wW9JcwZS1HOeKH0sqmeFGwZDoDT2Dzq844tWSMfF0 17 | eFoGWYZkvrtFogWGPjTLDWbagErDkSP6Y9qZkQFv+68nT8/G4k322ec6jx9H0/Z7 18 | aWhlvGzPSpOnZc6XSu40MhMlCbCjPySr4To6hYLDAoGAZVReTiXt/Gm54vOPs/9w 19 | +8Y6WsC60Vs+PRnsTlMW2B2Kk3vow57cIYHTIPwbsXN9qBEwBJDyexXVAJLhlvie 20 | zi6RtMSNVWhAE+YxFIZKDdoZ7Yd0uyIHSLUIU3GhUaqlR6udn1lcOrMAWFVvURIO 21 | tz4b1XxejU8OccDUL+fO8DUCgYB+oM6ZiK6dy4kfH58NkaBIf9jBo7HEY/ZBJ6MK 22 | GchPPktFNzR5bJU1vCypWpaB5dMPzgTyDhPLM+Xr1C+sY+YUUQutU7UAuSslG7r8 23 | FuLiyPIz+ItwVR5InhSQEzAV7cFYH/6lV2fQ4n1RUw36/eMJMFnRU70awEwT6PVX 24 | UXONVwKBgQCgVuQEukqt9NB8Hjte9w4MhAR22ML9XUvlDbQM2LL/eKj166SxXZqL 25 | dPaV2pcBvET1NT4UMnSZTTS4ZqsTuuE6B9Dm9lWUqMPbBDtBKykOUWSTY88rRXSW 26 | X0HdhQ/ycxHGN8Iv/wVZKo1ZSgEcEUM4jGvWclMgsnkWuaLBZPF/dA== 27 | -----END RSA PRIVATE KEY----- 28 | -------------------------------------------------------------------------------- /test/cert/ca.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIIDfzCCAmegAwIBAgIJAJkP4Ih73MLQMA0GCSqGSIb3DQEBCwUAMFYxCzAJBgNV 3 | BAYTAkNOMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBX 4 | aWRnaXRzIFB0eSBMdGQxDzANBgNVBAMMBldpbnRlcjAeFw0xNzA3MjUxMjU3NDRa 5 | Fw0yNzA2MDMxMjU3NDRaMFYxCzAJBgNVBAYTAkNOMRMwEQYDVQQIDApTb21lLVN0 6 | YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBXaWRnaXRzIFB0eSBMdGQxDzANBgNVBAMM 7 | BldpbnRlcjCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAK6OX9F73nt4 8 | w1nXG3wFK4nnPR5XtoMBh9YFoZFSb7fHuln0oiyRMBECaM4I9zKPCzXHeidfwsA+ 9 | 54zVxOyKBlfZqmgtm9eRMM0pFRRs+zPRBR96yj7IqRSJXr4AjaSL4xzyGhlyeoOY 10 | lZuDMZxtZOU4zayRR1ezHmIv2iUWi0NWUrTEUlPHvG+fVzsyfYyQWBPqfilljs0T 11 | DZCFCRDNYDj0lK1gocA9NS8zHsiJ6RJB99OTqw0xeCn1F6lg/cTJNf5d0JNMjFou 12 | pxIzW96COspN1c1yr+lALsuV5RGBe5XSynswm+LAVz81VzLu0wh50Ee0eF/96SEE 13 | iGnsw7zYpeECAwEAAaNQME4wHQYDVR0OBBYEFCj3eNkh8tyrzQMsEKirVA1ilVZA 14 | MB8GA1UdIwQYMBaAFCj3eNkh8tyrzQMsEKirVA1ilVZAMAwGA1UdEwQFMAMBAf8w 15 | DQYJKoZIhvcNAQELBQADggEBAFUf6Q6Og8PKYlGFLq177k+DIBJKMXqDUIWuZq/Z 16 | o11vks/4uE9LRXkicPJUbjK7Iv6mw5gHwYSxAkrJaeY6wQpiV8PoSOD1AIm448da 17 | 4SLLJMnB4vPPqrnDhoHNNOWonsZYyV6avD97+kTxM6WgJYhdwM4L1mxGGGT37nuf 18 | JtcZHLnI3PrHj3M89xwk4BFRXnb6+X/uWZxeF0AFCWZgMtzB+iMMz0VnBmBst8RI 19 | Xs+gYzBXN1Mq1KMcSP5r+BGE1GAM46Q5EEI29M/5Fw/38MoZlMvg4K+rdqg7GAKF 20 | fM3q9cMZ7Uv924KcQmF5ZKoZjFjp/PfaC8WZplF6yH+y3gA= 21 | -----END CERTIFICATE----- 22 | -------------------------------------------------------------------------------- /test/cert/server-cert.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIIDQTCCAimgAwIBAgIBATANBgkqhkiG9w0BAQsFADBWMQswCQYDVQQGEwJDTjET 3 | MBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0cyBQ 4 | dHkgTHRkMQ8wDQYDVQQDDAZXaW50ZXIwHhcNMTcwNzI1MTI1ODExWhcNMjcwNjAz 5 | MTI1ODExWjBWMQswCQYDVQQGEwJDTjETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8G 6 | A1UECgwYSW50ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMQ8wDQYDVQQDDAZXaW50ZXIw 7 | ggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQDCD3Wlrhbz++Z360JuvsXD 8 | M/CMquiGJU9XSA35g5lw7nIEsNYKzOW3dGuTzTLo/ZCw006H7eLVIZn0AZVSBSnk 9 | teEvOHUdn56E3XVvCGBxBdbTbVrT+2hDClVg230102SYLqNwwH1fOCGVnq74sHSA 10 | 86FRLlt+uFuZCpflaXsZ6lz/dNWAP4Lwu2bA05YJAn3mxEkrlxxbsLL4X+MKpUMg 11 | WRed+eykaFTY8G+pXmJZPLYblv5Vy+Jm5sbBuIqUElFkfHtHTpdCvahe2hcOmDcG 12 | eKmoSav2kolFb1xov7tOXCC9DdhfuNPLE0KGAWBLu8nMDmk7apOI33U6+4OCS8Xn 13 | AgMBAAGjGjAYMAkGA1UdEwQCMAAwCwYDVR0PBAQDAgXgMA0GCSqGSIb3DQEBCwUA 14 | A4IBAQBOKHB1StdKjQzk9cDFroR8jvbTb0PTANQYFsyAtN/VXcRLK9GxkW8Hxn/o 15 | SO+gTStOUu4ZaS6EymJ/z0z1oHDTCifoPo3R9o3SCUH7XDM3PV3ulgG59c2tfzRw 16 | dpK+ttfCe1e228YKfP3WI1hNnMjVnijKCJMROumQiY4CQhtUDdaAdK5jF2yvtThb 17 | kyHuimeIoyBESBmPuGnkFtcwzxXW43Qt9Y2uJg7WxyEgoNfXL73Enx++Hv6UJSPM 18 | sUPItS8M5wFoNJw4hpjPvXxQLrVnWd2Qs8p3LmohBpogg9C7GTzTrsM3wySxRTEA 19 | rrbjCtYnbrs4+HD9mlbzKi9mrcXi 20 | -----END CERTIFICATE----- 21 | -------------------------------------------------------------------------------- /test/cert/server-key.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN RSA PRIVATE KEY----- 2 | MIIEogIBAAKCAQEAwg91pa4W8/vmd+tCbr7FwzPwjKrohiVPV0gN+YOZcO5yBLDW 3 | Cszlt3Rrk80y6P2QsNNOh+3i1SGZ9AGVUgUp5LXhLzh1HZ+ehN11bwhgcQXW021a 4 | 0/toQwpVYNt9NdNkmC6jcMB9XzghlZ6u+LB0gPOhUS5bfrhbmQqX5Wl7Gepc/3TV 5 | gD+C8LtmwNOWCQJ95sRJK5ccW7Cy+F/jCqVDIFkXnfnspGhU2PBvqV5iWTy2G5b+ 6 | VcviZubGwbiKlBJRZHx7R06XQr2oXtoXDpg3BnipqEmr9pKJRW9caL+7TlwgvQ3Y 7 | X7jTyxNChgFgS7vJzA5pO2qTiN91OvuDgkvF5wIDAQABAoIBAFG0gpscPivBrlpl 8 | IhZQmiFC2A/R0Y7RXKNqAgBA6TTEIBtbfPMVK87e5IBZUAsK34WjohfXD78eo5w5 9 | om3jIK1b6pCgG6c6Ulqsh0oVY82SYM2p6CkCW/aF/kaGgyRLebodQNEzKlYR4woE 10 | wrSQTq0QZqYwd3NWGbLI5AVCMQNKjk/ogHOGAxwNGAzB3KHG55zQL68iu77vSJFa 11 | gf9MtSgaqxosWedtdRWVo9N2jm3BhrebK85J5bZQUp6xHvHSgbW/PGWQMiJUzuzo 12 | wzmBhkE4RM5hgBtBBUs6lP/trxzl1eKEkDSQdsxpZ5bIz0dhe3ZUqHM/apTVoD1n 13 | OBYTfWkCgYEA8Ue08d2C44wJTqyY1a+Tf0kSrNFEYjqWTKe19nzlQ7mFoUP6ORIw 14 | z6pLvliFSFFxQrB2uAzgJGIYdUY62XCV7Cm7gIfQxJEv2jUJ8ZNFTyZGKvBVxQu6 15 | 98CDkmsK5Zgjd/fhZb/7c6a9tdNm6C0Z/tcvi/CqhCiK5UmBYTXOeuUCgYEAzeZH 16 | buv65edEsxesHxZjSFIekEnvUUQw8JpRn/Cr9nzOem9quBwp85PNAoEPkBiDeq6C 17 | 2xE6wFO0C17cw5oPahkTg0C+PbKmNA3HWZLYXjAEke+bXponEGiBKtrcuoXPiRVi 18 | dLXVQyZ09sSd9QFVz0zb+yhnxmB8ckz6m3Qn1NsCgYBiMBo0qz5Ot3g6KgbwPsk5 19 | bVVKOscnakwr2bw1GNJ74w28eNtlSj/O4rB8P63Npkb/KqzFbYfxhnIJl5DvV9/L 20 | AZiqT5rnw2XD2P2474OvGBZJ9xAQZhuqIw/oD+OZV3Znpdp1+9CqWdquGd+w8Fm5 21 | 2Xwh6Mibi5wqfuVF2A20+QKBgCXlQjR6Hj1+KTjFHJrEJhXDd3ibAv70DAXcgTVs 22 | uFmvctk59GxaUqZQB6V0V4bv3BMSV2c2bpfDUBnfpcYibr/aSasYmWsFnG1sM8qa 23 | qlP7hnvNm8z3lkUA1vUqPwHdausSEoLkjJHFXDWmzmOvkTmMLdi2AROT4pOu81j1 24 | MfeNAoGAIbS1Gngub9JDeoyWPRPNkZaNXIaPdkXOXmwJvigbnWstgbHsgu24HfJc 25 | LCkS8MIYWVSbceDZflkSaJ9ZF0dGEJPPNdsfPi3x2iWTYHp8as9+8JnSsG4C8fvA 26 | gQZLrF0JxP7B4ZmHYNawtQBVnrcKldwCuotP16V7lH+we3xuezQ= 27 | -----END RSA PRIVATE KEY----- 28 | -------------------------------------------------------------------------------- /test/cert/server-req.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE REQUEST----- 2 | MIICmzCCAYMCAQAwVjELMAkGA1UEBhMCQ04xEzARBgNVBAgMClNvbWUtU3RhdGUx 3 | ITAfBgNVBAoMGEludGVybmV0IFdpZGdpdHMgUHR5IEx0ZDEPMA0GA1UEAwwGV2lu 4 | dGVyMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAwg91pa4W8/vmd+tC 5 | br7FwzPwjKrohiVPV0gN+YOZcO5yBLDWCszlt3Rrk80y6P2QsNNOh+3i1SGZ9AGV 6 | UgUp5LXhLzh1HZ+ehN11bwhgcQXW021a0/toQwpVYNt9NdNkmC6jcMB9XzghlZ6u 7 | +LB0gPOhUS5bfrhbmQqX5Wl7Gepc/3TVgD+C8LtmwNOWCQJ95sRJK5ccW7Cy+F/j 8 | CqVDIFkXnfnspGhU2PBvqV5iWTy2G5b+VcviZubGwbiKlBJRZHx7R06XQr2oXtoX 9 | Dpg3BnipqEmr9pKJRW9caL+7TlwgvQ3YX7jTyxNChgFgS7vJzA5pO2qTiN91OvuD 10 | gkvF5wIDAQABoAAwDQYJKoZIhvcNAQELBQADggEBAIjdOfU/dtQcP/Da1IIXlLji 11 | wFCHk5/jlC+oxSIXKtF+3ZBrCx3R/pm7V9ERbeJWXswlhd+8Rkeyde+L3PnDly77 12 | F2oKa1jKcp3lituP1V7tVM8WvScZbLC3RAKFioapN9+Jbwhs8DVtKryNiAtndjFl 13 | jRG3+7xS5rOijgVTStzqvYfRqcUJvvgdT62EV2oSq59ZjNmYkvj8ZAUuI8feKDNm 14 | TdTdGnaC0Br83XNiTKtsSLKk9p0WudzZkiCaeR07hOA1AoJ30DSnsQE+BG/5f/nn 15 | 1RbEybGDaFPTULYGXsoZ4TTcr5sxgfXmhomBn/iF/Ns5LEvNosKqwOOPPM4P0eI= 16 | -----END CERTIFICATE REQUEST----- 17 | -------------------------------------------------------------------------------- /test/json-data/dates-fract.json: -------------------------------------------------------------------------------- 1 | ["2015-02-02T09:10:11.123Z","2015-02-03T09:10:11.000+0000","2014-01-02T09:10:11.333Z","2014-01-03T02:09:12.000-02:00","2013-05-06T07:08:09.444Z","2015-02-02T09:10:11.66+03:00","2015-02-03T09:10:11.66Z","2014-01-02T09:10:11.66-1200","2014-01-03T02:09:12.66Z","2013-05-06T07:08:09.66+00:00"] 2 | -------------------------------------------------------------------------------- /test/json-data/dates.json: -------------------------------------------------------------------------------- 1 | ["2015-02-02T09:10:11Z","2015-02-03T09:10:11+0000","2014-01-02T09:10:11Z","2014-01-03T02:09:12-0300","2013-05-06T07:08:09Z","2015-02-02T09:10:11+04:00","2015-02-03T09:10:11Z","2014-01-02T09:10:11-11:45","2014-01-03T02:09:12Z","2013-05-06T07:08:09+0000"] 2 | -------------------------------------------------------------------------------- /test/json-data/example.json: -------------------------------------------------------------------------------- 1 | {"web-app": { 2 | "servlet": [ 3 | { 4 | "servlet-name": "cofaxCDS", 5 | "servlet-class": "org.cofax.cds.CDSServlet", 6 | "init-param": { 7 | "configGlossary:installationAt": "Philadelphia, PA", 8 | "configGlossary:adminEmail": "ksm@pobox.com", 9 | "configGlossary:poweredBy": "Cofax", 10 | "configGlossary:poweredByIcon": "/images/cofax.gif", 11 | "configGlossary:staticPath": "/content/static", 12 | "templateProcessorClass": "org.cofax.WysiwygTemplate", 13 | "templateLoaderClass": "org.cofax.FilesTemplateLoader", 14 | "templatePath": "templates", 15 | "templateOverridePath": "", 16 | "defaultListTemplate": "listTemplate.htm", 17 | "defaultFileTemplate": "articleTemplate.htm", 18 | "useJSP": false, 19 | "jspListTemplate": "listTemplate.jsp", 20 | "jspFileTemplate": "articleTemplate.jsp", 21 | "cachePackageTagsTrack": 200, 22 | "cachePackageTagsStore": 200, 23 | "cachePackageTagsRefresh": 60, 24 | "cacheTemplatesTrack": 100, 25 | "cacheTemplatesStore": 50, 26 | "cacheTemplatesRefresh": 15, 27 | "cachePagesTrack": 200, 28 | "cachePagesStore": 100, 29 | "cachePagesRefresh": 10, 30 | "cachePagesDirtyRead": 10, 31 | "searchEngineListTemplate": "forSearchEnginesList.htm", 32 | "searchEngineFileTemplate": "forSearchEngines.htm", 33 | "searchEngineRobotsDb": "WEB-INF/robots.db", 34 | "useDataStore": true, 35 | "dataStoreClass": "org.cofax.SqlDataStore", 36 | "redirectionClass": "org.cofax.SqlRedirection", 37 | "dataStoreName": "cofax", 38 | "dataStoreDriver": "com.microsoft.jdbc.sqlserver.SQLServerDriver", 39 | "dataStoreUrl": "jdbc:microsoft:sqlserver://LOCALHOST:1433;DatabaseName=goon", 40 | "dataStoreUser": "sa", 41 | "dataStorePassword": "dataStoreTestQuery", 42 | "dataStoreTestQuery": "SET NOCOUNT ON;select test='test';", 43 | "dataStoreLogFile": "/usr/local/tomcat/logs/datastore.log", 44 | "dataStoreInitConns": 10, 45 | "dataStoreMaxConns": 100, 46 | "dataStoreConnUsageLimit": 100, 47 | "dataStoreLogLevel": "debug", 48 | "maxUrlLength": 500}}, 49 | { 50 | "servlet-name": "cofaxEmail", 51 | "servlet-class": "org.cofax.cds.EmailServlet", 52 | "init-param": { 53 | "mailHost": "mail1", 54 | "mailHostOverride": "mail2"}}, 55 | { 56 | "servlet-name": "cofaxAdmin", 57 | "servlet-class": "org.cofax.cds.AdminServlet"}, 58 | 59 | { 60 | "servlet-name": "fileServlet", 61 | "servlet-class": "org.cofax.cds.FileServlet"}, 62 | { 63 | "servlet-name": "cofaxTools", 64 | "servlet-class": "org.cofax.cms.CofaxToolsServlet", 65 | "init-param": { 66 | "templatePath": "toolstemplates/", 67 | "log": 1, 68 | "logLocation": "/usr/local/tomcat/logs/CofaxTools.log", 69 | "logMaxSize": "", 70 | "dataLog": 1, 71 | "dataLogLocation": "/usr/local/tomcat/logs/dataLog.log", 72 | "dataLogMaxSize": "", 73 | "removePageCache": "/content/admin/remove?cache=pages&id=", 74 | "removeTemplateCache": "/content/admin/remove?cache=templates&id=", 75 | "fileTransferFolder": "/usr/local/tomcat/webapps/content/fileTransferFolder", 76 | "lookInContext": 1, 77 | "adminGroupID": 4, 78 | "betaServer": true}}], 79 | "servlet-mapping": { 80 | "cofaxCDS": "/", 81 | "cofaxEmail": "/cofaxutil/aemail/*", 82 | "cofaxAdmin": "/admin/*", 83 | "fileServlet": "/static/*", 84 | "cofaxTools": "/tools/*"}, 85 | 86 | "taglib": { 87 | "taglib-uri": "cofax.tld", 88 | "taglib-location": "/WEB-INF/tlds/cofax.tld"}}} 89 | -------------------------------------------------------------------------------- /test/json-data/integers.json: -------------------------------------------------------------------------------- 1 | [1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 6, 6, 7, 7, 7, 8, 9, 9, 10, 10, 11, 12, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 23, 24, 26, 27, 29, 31, 33, 35, 37, 39, 42, 44, 47, 50, 53, 56, 60, 63, 67, 72, 76, 81, 86, 91, 96, 102, 109, 115, 122, 130, 138, 146, 155, 165, 175, 186, 197, 209, 222, 236, 250, 266, 282, 299, 318, 337, 358, 380, 403, 428, 454, 482, 511, 543, 576, 611, 649, 688, 730, 775, 823, 873, 926, 983, 1043, 1107, 1175, 1247, 1323, 1404, 1490, 1582, 1679, 1781, 1890, 2006, 2129, 2259, 2398, 2544, 2700, 2865, 3041, 3227, 3425, 3634, 3857, 4093, 4343, 4609, 4891, 5191, 5509, 5846, 6204, 6583, 6986, 7414, 7868, 8349, 8860, 9403, 9978, 10589, 11237, 11925, 12655, 13430, 14252, 15124, 16050, 17032, 18075, 19181, 20355, 21601, 22923, 24326, 25815, 27396, 29072, 30852, 32740, 34744, 36871, 39128, 41523, 44064, 46762, 49624, 52661, 55884, 59305, 62935, 66787, 70875, 75213, 79817, 84702, 89887, 95389, 101227, 107423, 113998, 120976, 128381, 136239, 144578, 153427, 162818, 172784, 183360, 194583, 206493, 219132, 232545, 246778, 261883, 277912, 294923, 312975, 332131, 352460, 374034, 396928, 421223, 447005, 474365, 503400, 534212, 566911, 601610, 638433, 677511, 718980, 762987, 809688, 859247, 911840, 967652, 1026880, 1089734, 1156434, 1227217, 1302333, 1382046, 1466638, 1556408, 1651673, 1752769, 1860052, 1973902, 2094721, 2222934, 2358996, 2503385, 2656613, 2819219, 2991777, 3174898, 3369227, 3575451, 3794297, 4026539, 4272995, 4534536, 4812086, 5106625, 5419191, 5750889, 6102889, 6476435, 6872845, 7293518, 7739939, 8213686, 8716429, 9249944, 9816115, 10416939, 11054539, 11731166, 12449207, 13211198, 14019829, 14877955, 15788605, 16754994, 17780533, 18868844, 20023768, 21249383, 22550016, 23930257, 25394980, 26949356, 28598872, 30349352, 32206975, 34178300, 36270285, 38490317, 40846232, 43346349, 45999492, 48815029, 51802899, 54973651, 58338478, 61909260, 65698602, 69719882, 73987297, 78515911, 83321713, 88421668, 93833782, 99577160, 105672079, 112140056, 119003924, 126287916, 134017747, 142220706, 150925751, 160163614, 169966908, 180370243, 191410345, 203126189, 215559137, 228753081, 242754599, 257613123, 273381107, 290114218, 307871529, 326715729, 346713346, 367934976, 390455540, 414354543, 439716356, 466630515, 495192035, 525501749, 557666661, 591800322, 628023236, 666463282, 707256166, 750545902, 796485316, 845236589, 896971830, 951873682, 1010135966, 1071964368, 1137577163, 1207205986, 1281096650, 1359510014, 1442722903, 1531029087, 1624740315, 1724187420, 1829721484, 1941715077, 2060563573, 2186686548, 2320529259, 2462564214, 2613292844, 2773247272, 2942992191, 3123126858, 3314287206, 3517148098, 3732425698, 3960880011, 4203317554, 4460594215, 4733618266, 5023353573, 5330822998, 5657112012, 6003372524, 6370826950, 6760772526, 7174585891, 7613727944, 8079749004, 8574294281, 9099109685, 9656047991, 10247075377, 10874278366, 11539871197, 12246203633, 12995769265, 13791214310, 14635346955, 15531147272, 16481777734, 17490594386, 18561158687, 19697250088, 20902879371, 22182302812, 23540037202, 24980875800, 26509905246, 28132523526, 29854459026, 31681790754, 33620969802, 35678842122, 37862672691, 40180171161, 42639519077, 45249398761, 48019023960, 50958172379, 54077220194, 57387178688, 60899733121, 64627283986, 68582990784, 72780818484, 77235586822, 81963022620, 86979815309, 92303675844, 97953399235, 103948930895, 110311437058, 117063379497, 124228594829, 131832378662, 139901574895, 148464670491, 157551896043, 167195332496, 177429024407, 188289100133, 199813899374, 212044108527, 225022904322, 238796106249, 253412338321, 268923200725, 285383451995, 302851202324, 321388118716, 341059642687, 361935221296, 384088552321, 407597844432, 432546093294, 459021374572, 487117154867, 516932621682, 548573033590, 582150091830, 617782334651, 655595555791, 695723248569, 738307077168, 783497376747, 831453684183, 882345301285, 936351892486, 993664119121, 1054484312524, 1119027188325, 1187520604468, 1260206365627, 1337341076854, 1419197049486, 1506063262491, 1598246382662, 1696071847252, 1799885012878, 1910052374747, 2026962860500, 2151029203266, 2282689398739, 2422408251457, 2570679015712, 2728025136906, 2895002099486, 3072199387991, 3260242568131, 3459795495242, 3671562657914, 3896291665080, 4134775885316, 4387857247705, 4656429214122, 4941439933460, 5243895588908, 5564863950114, 5905478142772, 6266940648935, 6650527552175, 7057593042589, 7489574197539, 7947996055022, 8434476997558, 8950734465625, 9498591020797, 10079980779998, 10696956243580, 11351695541337, 12046510122031, 12783852913581, 13566326982715, 14396694724673, 15277887615381, 16213016560543, 17205382878181, 18258489953389, 19376055606456, 20562025218016, 21820585657560, 23156180064488, 24573523533875, 26077619762337, 27673778712750, 29367635360200, 31165169585327, 33072727285306, 35097042776985, 37245262571278, 39524970602741, 41944215003394, 44511536515321, 47235998642351, 50127219647252, 53195406507421, 56451390948928, 59906667686130, 63573435001862, 67464637811456, 71594013362620, 75976139732519, 80626487293267, 85561473327514, 90798519986944, 96356115798305, 102253880934088, 108512636478302, 115154477931865, 122202853217119, 129682645456833, 137620260819954, 146043721744222, 154982765864743, 164468950997792, 174535766550465, 185218751749486, 196555621106568, 208586397563259, 221353553785311, 234902162105402, 249280053643550, 264537987166964, 280729828285480, 297912739615178, 316147382581544, 335498131574595, 356033301212013, 377825387512598, 400951323831468, 425492752460545, 451536312853150, 479173947490266, 508503226468250, 539627691953919, 572657223723034, 607708427072674, 644905044476938, 684378392439283, 726267825083707, 770721226121430, 817895530929871, 867957280587026, 921083209817197, 977460870923688, 1037289295911185, 1100779699135317, 1168156222959992, 1239656729054927, 1315533638126921, 1396054821049394, 1481504544536185, 1572184474698156, 1668414742025481, 1770535071555377, 1878905982215138, 1993910059574563, 2115953306501003, 2245466576485316, 2382907094698829, 2528760072151156, 2683540418647385, 2847794560591953] 2 | -------------------------------------------------------------------------------- /test/json-data/twitter1.json: -------------------------------------------------------------------------------- 1 | {"results":[{"from_user_id_str":"80430860","profile_image_url":"http://a2.twimg.com/profile_images/536455139/icon32_normal.png","created_at":"Wed, 26 Jan 2011 07:07:02 +0000","from_user":"kazu_yamamoto","id_str":"30159761706061824","metadata":{"result_type":"recent"},"to_user_id":null,"text":"Haskell Server Pages \u3063\u3066\u3001\u307e\u3060\u7d9a\u3044\u3066\u3044\u305f\u306e\u304b\uff01","id":30159761706061824,"from_user_id":80430860,"geo":null,"iso_language_code":"no","to_user_id_str":null,"source":"<a href="http://twitter.com/">web</a>"}],"max_id":30159761706061824,"since_id":0,"refresh_url":"?since_id=30159761706061824&q=haskell","next_page":"?page=2&max_id=30159761706061824&rpp=1&q=haskell","results_per_page":1,"page":1,"completed_in":0.012606,"since_id_str":"0","max_id_str":"30159761706061824","query":"haskell"} 2 | -------------------------------------------------------------------------------- /test/json-data/twitter10.json: -------------------------------------------------------------------------------- 1 | {"results":[{"from_user_id_str":"207858021","profile_image_url":"http://a3.twimg.com/sticky/default_profile_images/default_profile_2_normal.png","created_at":"Wed, 26 Jan 2011 04:30:38 +0000","from_user":"pboudarga","id_str":"30120402839666689","metadata":{"result_type":"recent"},"to_user_id":null,"text":"I'm at Rolla Sushi Grill (27737 Bouquet Canyon Road, #106, Btw Haskell Canyon and Rosedell Drive, Saugus) http://4sq.com/gqqdhs","id":30120402839666689,"from_user_id":207858021,"geo":null,"iso_language_code":"en","to_user_id_str":null,"source":"<a href="http://foursquare.com" rel="nofollow">foursquare</a>"},{"from_user_id_str":"69988683","profile_image_url":"http://a0.twimg.com/profile_images/1211955817/avatar_7888_normal.gif","created_at":"Wed, 26 Jan 2011 04:25:23 +0000","from_user":"YNK33","id_str":"30119083059978240","metadata":{"result_type":"recent"},"to_user_id":null,"text":"hsndfile 0.5.0: Free and open source Haskell bindings for libsndfile http://bit.ly/gHaBWG Mac Os","id":30119083059978240,"from_user_id":69988683,"geo":null,"iso_language_code":"en","to_user_id_str":null,"source":"<a href="http://twitterfeed.com" rel="nofollow">twitterfeed</a>"},{"from_user_id_str":"81492","profile_image_url":"http://a1.twimg.com/profile_images/423894208/Picture_7_normal.jpg","created_at":"Wed, 26 Jan 2011 04:24:28 +0000","from_user":"satzz","id_str":"30118851488251904","metadata":{"result_type":"recent"},"to_user_id":null,"text":"Emacs\u306e\u30e2\u30fc\u30c9\u8868\u793a\u304c\u4eca(Ruby Controller Outputz RoR Flymake REl hs)\u3068\u306a\u3063\u3066\u3066\u3088\u304f\u308f\u304b\u3089\u306a\u3044\u3093\u3060\u3051\u3069\u6700\u5f8c\u306eREl\u3068\u304bhs\u3063\u3066\u4f55\u3060\u308d\u3046\u2026haskell\u3068\u304b2\u5e74\u4ee5\u4e0a\u66f8\u3044\u3066\u306a\u3044\u3051\u3069\u2026","id":30118851488251904,"from_user_id":81492,"geo":null,"iso_language_code":"ja","to_user_id_str":null,"source":"<a href="http://www.hootsuite.com" rel="nofollow">HootSuite</a>"},{"from_user_id_str":"9518356","profile_image_url":"http://a2.twimg.com/profile_images/119165723/ocaml-icon_normal.png","created_at":"Wed, 26 Jan 2011 04:19:19 +0000","from_user":"planet_ocaml","id_str":"30117557788741632","metadata":{"result_type":"recent"},"to_user_id":null,"text":"I so miss #haskell type classes in #ocaml - i want to do something like refinement. Also why does ocaml not have... http://bit.ly/geYRwt","id":30117557788741632,"from_user_id":9518356,"geo":null,"iso_language_code":"en","to_user_id_str":null,"source":"<a href="http://twitterfeed.com" rel="nofollow">twitterfeed</a>"},{"from_user_id_str":"218059","profile_image_url":"http://a1.twimg.com/profile_images/1053837723/twitter-icon9_normal.jpg","created_at":"Wed, 26 Jan 2011 04:16:32 +0000","from_user":"aprikip","id_str":"30116854940835840","metadata":{"result_type":"recent"},"to_user_id":null,"text":"yatex-mode\u3084haskell-mode\u306e\u3053\u3068\u3067\u3059\u306d\u3001\u308f\u304b\u308a\u307e\u3059\u3002","id":30116854940835840,"from_user_id":218059,"geo":null,"iso_language_code":"ja","to_user_id_str":null,"source":"<a href="http://sites.google.com/site/yorufukurou/" rel="nofollow">YoruFukurou</a>"},{"from_user_id_str":"216363","profile_image_url":"http://a1.twimg.com/profile_images/72454310/Tim-Avatar_normal.png","created_at":"Wed, 26 Jan 2011 04:15:30 +0000","from_user":"dysinger","id_str":"30116594684264448","metadata":{"result_type":"recent"},"to_user_id":null,"text":"Haskell in Hawaii tonight for me... #fun","id":30116594684264448,"from_user_id":216363,"geo":null,"iso_language_code":"en","to_user_id_str":null,"source":"<a href="http://www.nambu.com/" rel="nofollow">Nambu</a>"},{"from_user_id_str":"1774820","profile_image_url":"http://a2.twimg.com/profile_images/61169291/dan_desert_thumb_normal.jpg","created_at":"Wed, 26 Jan 2011 04:13:36 +0000","from_user":"DanMil","id_str":"30116117682851840","metadata":{"result_type":"recent"},"to_user_id":1594784,"text":"@ojrac @chewedwire @tomheon Haskell isn't a language, it's a belief system. A seductive one...","id":30116117682851840,"from_user_id":1774820,"to_user":"ojrac","geo":null,"iso_language_code":"en","to_user_id_str":"1594784","source":"<a href="http://twitter.com/">web</a>"},{"from_user_id_str":"659256","profile_image_url":"http://a0.twimg.com/profile_images/746976711/angular-final_normal.jpg","created_at":"Wed, 26 Jan 2011 04:11:06 +0000","from_user":"djspiewak","id_str":"30115488931520512","metadata":{"result_type":"recent"},"to_user_id":null,"text":"One of the very nice things about Haskell as opposed to SML is the reduced proliferation of identifiers (e.g. andb, orb, etc). #typeclasses","id":30115488931520512,"from_user_id":659256,"geo":null,"iso_language_code":"en","to_user_id_str":null,"source":"<a href="http://itunes.apple.com/us/app/twitter/id409789998?mt=12" rel="nofollow">Twitter for Mac</a>"},{"from_user_id_str":"144546280","profile_image_url":"http://a1.twimg.com/a/1295051201/images/default_profile_1_normal.png","created_at":"Wed, 26 Jan 2011 04:06:12 +0000","from_user":"listwarenet","id_str":"30114255890026496","metadata":{"result_type":"recent"},"to_user_id":null,"text":"http://www.listware.net/201101/haskell-cafe/84752-re-haskell-cafe-gpl-license-of-h-matrix-and-prelude-numeric.html Re: Haskell-c","id":30114255890026496,"from_user_id":144546280,"geo":null,"iso_language_code":"no","to_user_id_str":null,"source":"<a href="http://1e10.org/cloud/" rel="nofollow">1e10</a>"},{"from_user_id_str":"1594784","profile_image_url":"http://a2.twimg.com/profile_images/378515773/square-profile_normal.jpg","created_at":"Wed, 26 Jan 2011 04:01:29 +0000","from_user":"ojrac","id_str":"30113067333324800","metadata":{"result_type":"recent"},"to_user_id":null,"text":"RT @tomheon: @ojrac @chewedwire Don't worry, learning Haskell will not give you any clear idea what monad means.","id":30113067333324800,"from_user_id":1594784,"geo":null,"iso_language_code":"en","to_user_id_str":null,"source":"<a href="http://twitter.com/">web</a>"}],"max_id":30120402839666689,"since_id":0,"refresh_url":"?since_id=30120402839666689&q=haskell","next_page":"?page=2&max_id=30120402839666689&rpp=10&q=haskell","results_per_page":10,"page":1,"completed_in":0.012714,"since_id_str":"0","max_id_str":"30120402839666689","query":"haskell"} 2 | -------------------------------------------------------------------------------- /word24-bench/Benchmark.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Criterion.Main 4 | import Control.DeepSeq 5 | import Data.Int.Int24 6 | import Data.Word.Word24 7 | import Data.Int 8 | import Data.Word 9 | import Data.List 10 | 11 | main = defaultMain 12 | [ bgroup "Int24" intses 13 | , bgroup "Word24" wordses 14 | , bgroup "Int16" baseses 15 | , bgroup "Word16" basessW 16 | ] 17 | 18 | benches :: (Enum i, Num i, NFData i, Integral i) => i -> [Benchmark] 19 | benches x = 20 | [ bench "Add" $ nf (\i -> foldl' (+) i [1..100]) x 21 | , bench "Mul" $ nf (\i -> foldl' (*) i [1..100]) x 22 | , bench "quot" $ nf (\i -> map (flip quot i) [1..25]) x 23 | , bench "rem" $ nf (\i -> map (flip rem i) [1..25]) x 24 | , bench "div" $ nf (\i -> map (flip div i) [1..25]) x 25 | , bench "mod" $ nf (\i -> map (flip mod i) [1..25]) x 26 | ] 27 | {-# INLINE benches #-} 28 | 29 | intses = benches (1 :: Int24) 30 | wordses = benches (1 :: Word24) 31 | baseses = benches (1 :: Int16) 32 | basessW = benches (1 :: Word16) 33 | --------------------------------------------------------------------------------