packages feed

mysql-pure (empty) → 1.0.0

raw patch · 53 files changed

+9998/−0 lines, 53 filesdep +QuickCheckdep +attoparsecdep +base

Dependencies added: QuickCheck, attoparsec, base, binary, binary-ieee754, blaze-textual, bytestring, bytestring-lexing, case-insensitive, cereal, cereal-conduit, conduit, conduit-extra, containers, criterion, crypton, deepseq, directory, filepath, http-types, io-streams, memory, monad-loops, mysql-pure, network, quickcheck-instances, scanner, scientific, tasty, tasty-hunit, tasty-quickcheck, tcp-streams, text, time, tls, transformers, unordered-containers, vector, word-compat, word24

Files

+ ChangeLog.md view
@@ -0,0 +1,107 @@+# Revision history for mysql-pure++## 1.0.0.0 -- 2023.08.12 +++ Fork from mysql-haskell into mysql-pure++ add flake++ merge packages:+  + word24+  + binary-parsers+  + wirestreams+  +  This involved copying over all source files,+  furthermore I copied in all tests and benchmarks.+  The tests are now one giant test suite.+  I temporarly disabled the mysql tests as they need a mysql+  database to run which won't work nicely with CI right now.+  However you can run these locally by uncommenting that line.++ Add CI which relies on native cabal instead of stack++ Add an action to automatically bump version.++ Add nightly build cron job.++## 0.8.4.3 -- 2020-11-04++* Fix build with GHC 8.8.++## 0.8.4.2 -- 2019-01-22++* Fix [stackage#4312](https://github.com/commercialhaskell/stackage/issues/4312): Relax `network` bounds.++## 0.8.4.1 -- 2018-10-23++* Relax `tasty` version bound to build with latest stackage. [#26](https://github.com/winterland1989/mysql-haskell/pull/26)++## 0.8.4.0  -- 2018-10-23++* Add `executeMany_` to execute batch SQLs, [#26](https://github.com/winterland1989/mysql-haskell/issues/26).+* Optimize connection closing sequence, [#20](https://github.com/winterland1989/mysql-haskell/pull/20), [#25](https://github.com/winterland1989/mysql-haskell/pull/25).++## 0.8.3.0  -- 2017-10-09++* Remove unnecessary exports from `Database.MySQL.Base`.+* Reuse TCP connection when using TLS.+* Clean up some compiler warnings.++## 0.8.2.0  -- 2017-10-09++Courtesy of naushadh, `mysql-haskell` will be on stackage again.++* Update to use `tcp-streams-1.x`.+* Fix compatibility with new  `tls/memory` version.++## 0.8.1.0  -- 2016-11-09++* Add `Show` instance to `ConnectInfo`.+* Add proper version bound for `binary`.++## 0.8.0.0  -- 2016-11-09++* Add `ciCharset` field to support `utf8mb4` charset.+* Add `BitMap` field to `COM_STMT_EXECUTE`, and [#8](https://github.com/winterland1989/mysql-haskell/pull/8) by [alexbiehl](https://github.com/alexbiehl).++## 0.7.1.0 -- 2016-11-21++* Add `QueryParam` class and `Param` datatype for multi-valued parameter(s) by [naushadh](https://github.com/naushadh).++## 0.7.0.0 -- 2016-11-09++* Split openssl support to [mysql-haskell-openssl](http://hackage.haskell.org/package/mysql-haskell-openssl).+* Expose `Database.MySQL.Connection` module due to this split, it shouldn't be used by user directly.++## 0.6.0.0 -- 2016-10-25++* Use binary-ieee754 for older binary compatibility.+* Clean up `Database.MySQL.Protocol.MySQLValue` 's export.++## 0.5.1.0 -- 2016-10-20++* Add `queryVector`, `queryVector_` and `queryStmtVector`.+* Use binary-parsers to speed up binary parsers.++## 0.5.0.0 -- 2016-8-22++* Export exception types.+* Fix a regression cause password authentication failed, add tests.+* Fix a reading order bug cause 'prepareStmt/prepareStmtDetail' failed.++## 0.4.0.0 -- 2016-8-22++* Enable TLS support via `tls` package, add benchmarks.++## 0.3.0.0  -- 2016-8-22++* Fix tls connection, change TLS implementation to HsOpenSSL, add benchmarks.+* Fix a bug in 'putLenEncInt' which cause sending large field fail.+* Various optimizations.++## 0.2.0.0  -- 2016-8-19++* Fix OK packet decoder.+* Fix sending large packet(>16M).+* Add `executeMany`, `withTransaction` to Base module.+* Add timestamp field to `RowBinLogEvent`.+* Add test, add insert benchmark.++## 0.1.0.0  -- 2016-8-16++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Winterland++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of winterland1989 nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,207 @@+mysql-pure+=============++This is a fork of [mysql-haskell](https://hackage.haskell.org/package/mysql-haskell).+It merges in:+  + [word24](https://hackage.haskell.org/package/word24)+  + [binary-parsers](https://hackage.haskell.org/package/binary-parsers-0.2.4.0)+  + [wirestreams](https://hackage.haskell.org/package/wire-streams)++this makes maintenance easier.+It remains backwards compatible,+so this package can be used as a drop in replacement for any listed above,+with the difference that it's maintained.++[![Hackage](https://img.shields.io/hackage/v/mysql-pure.svg?style=flat)](http://hackage.haskell.org/package/mysql-pure)+[![Build Status](https://travis-ci.org/winterland1989/mysql-pure.svg)](https://travis-ci.org/winterland1989/mysql-pure)++`mysql-pure` is a MySQL driver written entirely in haskell.++Is it fast?+----------++In short, `select`(decode) is about 1.5 times slower than pure c/c++ but 5 times faster than `mysql-simple`, `insert` (encode) is about 1.5 times slower than pure c/c++, there're many factors involved(tls, prepared statment, batch using multiple statement):++<img src="https://github.com/jappeace/mysql-pure/blob/master/benchmark/result.png?raw=true" width="100%">++Above figures showed the time to:++* perform a "select * from employees" from a [sample table](https://github.com/datacharmer/test_db)+* insert 1000 rows into a 29-columns table per thread with auto-commit off.++The benchmarks are run by my MacBook Pro 13' 2015.++Motivation+----------++While MySQL may not be the most advanced sql database, it's widely used among China companies, including but not limited to Baidu, Alibaba, Tecent etc., but haskell's MySQL support is not ideal, we only have a very basic MySQL binding written by Bryan O'Sullivan, and some higher level wrapper built on it, which have some problems:+++ lack of prepared statment and binary protocol support.+++ limited concurrency due to FFI.+++ no replication protocol support.++`mysql-pure` is intended to solve these problems, and provide foundation for higher level libraries such as groundhog and persistent, so that accessing MySQL is both fast and easy in haskell.++Guide+-----++The `Database.MySQL.Base` module provides everything you need to start making queries:++```haskell+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Database.MySQL.Base+import qualified System.IO.Streams as Streams++main :: IO () +main = do+    conn <- connect+        defaultConnectInfo {ciUser = "username", ciPassword = "password", ciDatabase = "dbname"}+    (defs, is) <- query_ conn "SELECT * FROM some_table"+    print =<< Streams.toList is+```++`query/query_` will return a column definition list, and an `InputStream` of rows, you should consume this stream completely before start new queries.++It's recommanded to use prepared statement to improve query speed:++```haskell+    ...+    s <- prepareStmt conn "SELECT * FROM some_table where person_age > ?"+    ...+    (defs, is) <- queryStmt conn s [MySQLInt32U 18]+    ...+```++If you want to do batch inserting/deleting/updating, you can use `executeMany` to save considerable time.++The `Database.MySQL.BinLog` module provides binlog listenning functions and row-based event decoder, following program will automatically get last binlog position, and print every row event it receives:++```haskell+{-# LANGUAGE LambdaCase #-}+module Main where++import           Control.Monad         (forever)+import qualified Database.MySQL.BinLog as MySQL+import qualified System.IO.Streams     as Streams++main :: IO () +main = do+    conn <- MySQL.connect +        MySQL.defaultConnectInfo+          { MySQL.ciUser = "username"+          , MySQL.ciPassword = "password"+          , MySQL.ciDatabase = "dbname"+          }+    MySQL.getLastBinLogTracker conn >>= \ case+        Just tracker -> do+            es <- MySQL.decodeRowBinLogEvent =<< MySQL.dumpBinLog conn 1024 tracker False+            forever $ do+                Streams.read es >>= \ case+                    Just v  -> print v+                    Nothing -> return ()+        Nothing -> error "can't get latest binlog position"+```++Build Test Benchmark+--------------------++Just use the old way:++```bash+git clone https://github.com/winterland1989/mysql-pure.git+cd mysql-pure+cabal install --enable-tests --only-dependencies+cabal build+```++Running tests require:++* A local MySQL server, a user `testMySQLHaskell` and a database `testMySQLHaskell`, you can do it use following script:++```bash+mysql -u root -e "CREATE DATABASE IF NOT EXISTS testMySQLHaskell;"+mysql -u root -e "CREATE USER 'testMySQLHaskell'@'localhost' IDENTIFIED BY ''"+mysql -u root -e "GRANT ALL PRIVILEGES ON testMySQLHaskell.* TO 'testMySQLHaskell'@'localhost'"+mysql -u root -e "FLUSH PRIVILEGES"+```++* Enable binlog by adding `log_bin = filename` to `my.cnf` or add `--log-bin=filename` to the server, and grant replication access to `testMySQLHaskell` with:++```bash+mysql -u root -e "GRANT REPLICATION SLAVE, REPLICATION CLIENT ON *.* TO 'testMySQLHaskell'@'localhost';"+```++* Set `binlog_format` to `ROW`.++* Set `max_allowed_packet` to larger than 256M(for test large packet).++New features will be automatically tested by inspecting MySQL server's version, travis is keeping an eye on following combinations:+++ CABALVER=1.18 GHCVER=7.8.4  MYSQLVER=5.5++ CABALVER=1.22 GHCVER=7.10.2 MYSQLVER=5.5++ CABALVER=1.24 GHCVER=8.0.1  MYSQLVER=5.5++ CABALVER=1.24 GHCVER=8.0.1  MYSQLVER=5.6++ CABALVER=1.24 GHCVER=8.0.1  MYSQLVER=5.7++Please reference `.travis.yml` if you have problems with setting up test environment.++Enter benchmark directory and run `./bench.sh` to benchmark 1) c++ version 2) mysql-pure 3) FFI version mysql, you may need to:+++ Modify `bench.sh`(change the include path) to get c++ version compiled.++ Modify `mysql-pure-bench.cabal`(change the openssl's lib path) to get haskell version compiled.++ Setup MySQL's TLS support, modify `MySQLHaskellOpenSSL.hs/MySQLHaskellTLS.hs` to change the CA file's path, and certificate's subject name.++ Adjust rts options `-N` to get best results.++With `-N10` on my company's 24-core machine, binary protocol performs almost identical to c version!++Reference+---------++[MySQL official site](https://dev.mysql.com/doc/internals/en/) provided intensive document, but without following project, `mysql-pure` may not be written at all:+++ [mysql-binlog-connector-java](https://github.com/shyiko/mysql-binlog-connector-java)+++ [canal](https://github.com/alibaba/canal)+++ [go mysql toolkit](https://github.com/siddontang/go-mysql)+++ [python binlog parser](https://github.com/noplay/python-mysql-replication)++License+-------++Copyright (c) 2016, winterland1989++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of winterland1989 nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ binary-parser-bench/Aeson.hs view
@@ -0,0 +1,361 @@+{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}++module Aeson+    (+      aeson+    , aesonLazy+    , value'+    ) where++import Data.ByteString.Builder+  (Builder, byteString, toLazyByteString, charUtf8, word8)++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((*>), (<$>), (<*), pure)+import Data.Monoid (mappend, mempty)+#endif++import Control.Applicative (liftA2)+import Control.DeepSeq (NFData(..))+import Control.Monad (forM)+import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific,+                                         skipSpace, string)+import Data.Bits ((.|.), shiftL)+import Data.ByteString (ByteString)+import Data.Char (chr)+import Data.List (sort)+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8')+import Data.Vector as Vector (Vector, foldl', fromList)+import Data.Word (Word8)+import System.Directory (getDirectoryContents, doesDirectoryExist)+import System.FilePath ((</>), dropExtension)+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.Lazy as L+import qualified Data.Attoparsec.Zepto as Z+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Unsafe as B+import qualified Data.HashMap.Strict as H+import Criterion.Main+import Common (pathTo)++#define BACKSLASH 92+#define CLOSE_CURLY 125+#define CLOSE_SQUARE 93+#define COMMA 44+#define DOUBLE_QUOTE 34+#define OPEN_CURLY 123+#define OPEN_SQUARE 91+#define C_0 48+#define C_9 57+#define C_A 65+#define C_F 70+#define C_a 97+#define C_f 102+#define C_n 110+#define C_t 116++data Result a = Error String+              | Success a+                deriving (Eq, Show)+++-- | A JSON \"object\" (key\/value map).+type Object = H.HashMap Text Value++-- | A JSON \"array\" (sequence).+type Array = Vector Value++-- | A JSON value represented as a Haskell value.+data Value = Object !Object+           | Array !Array+           | String !Text+           | Number !Scientific+           | Bool !Bool+           | Null+             deriving (Eq, Show)++instance NFData Value where+    rnf (Object o) = rnf o+    rnf (Array a)  = Vector.foldl' (\x y -> rnf y `seq` x) () a+    rnf (String s) = rnf s+    rnf (Number n) = rnf n+    rnf (Bool b)   = rnf b+    rnf Null       = ()++-- | Parse a top-level JSON value.  This must be either an object or+-- an array, per RFC 4627.+--+-- The conversion of a parsed value to a Haskell value is deferred+-- until the Haskell value is needed.  This may improve performance if+-- only a subset of the results of conversions are needed, but at a+-- cost in thunk allocation.+json :: Parser Value+json = json_ object_ array_++-- | Parse a top-level JSON value.  This must be either an object or+-- an array, per RFC 4627.+--+-- This is a strict version of 'json' which avoids building up thunks+-- during parsing; it performs all conversions immediately.  Prefer+-- this version if most of the JSON data needs to be accessed.+json' :: Parser Value+json' = json_ object_' array_'++json_ :: Parser Value -> Parser Value -> Parser Value+json_ obj ary = do+  w <- skipSpace *> A.satisfy (\w -> w == OPEN_CURLY || w == OPEN_SQUARE)+  if w == OPEN_CURLY+    then obj+    else ary+{-# INLINE json_ #-}++object_ :: Parser Value+object_ = {-# SCC "object_" #-} Object <$> objectValues jstring value++object_' :: Parser Value+object_' = {-# SCC "object_'" #-} do+  !vals <- objectValues jstring' value'+  return (Object vals)+ where+  jstring' = do+    !s <- jstring+    return s++objectValues :: Parser Text -> Parser Value -> Parser (H.HashMap Text Value)+objectValues str val = do+  skipSpace+  let pair = liftA2 (,) (str <* skipSpace) (char ':' *> skipSpace *> val)+  H.fromList <$> commaSeparated pair CLOSE_CURLY+{-# INLINE objectValues #-}++array_ :: Parser Value+array_ = {-# SCC "array_" #-} Array <$> arrayValues value++array_' :: Parser Value+array_' = {-# SCC "array_'" #-} do+  !vals <- arrayValues value'+  return (Array vals)++commaSeparated :: Parser a -> Word8 -> Parser [a]+commaSeparated item endByte = do+  w <- A.peekWord8'+  if w == endByte+    then A.anyWord8 >> return []+    else loop+  where+    loop = do+      v <- item <* skipSpace+      ch <- A.satisfy $ \w -> w == COMMA || w == endByte+      if ch == COMMA+        then skipSpace >> (v:) <$> loop+        else return [v]+{-# INLINE commaSeparated #-}++arrayValues :: Parser Value -> Parser (Vector Value)+arrayValues val = do+  skipSpace+  Vector.fromList <$> commaSeparated val CLOSE_SQUARE+{-# INLINE arrayValues #-}++-- | Parse any JSON value.  You should usually 'json' in preference to+-- this function, as this function relaxes the object-or-array+-- requirement of RFC 4627.+--+-- In particular, be careful in using this function if you think your+-- code might interoperate with Javascript.  A na&#xef;ve Javascript+-- library that parses JSON data using @eval@ is vulnerable to attack+-- unless the encoded data represents an object or an array.  JSON+-- implementations in other languages conform to that same restriction+-- to preserve interoperability and security.+value :: Parser Value+value = do+  w <- A.peekWord8'+  case w of+    DOUBLE_QUOTE  -> A.anyWord8 *> (String <$> jstring_)+    OPEN_CURLY    -> A.anyWord8 *> object_+    OPEN_SQUARE   -> A.anyWord8 *> array_+    C_f           -> string "false" *> pure (Bool False)+    C_t           -> string "true" *> pure (Bool True)+    C_n           -> string "null" *> pure Null+    _              | w >= 48 && w <= 57 || w == 45+                  -> Number <$> scientific+      | otherwise -> fail "not a valid json value"++-- | Strict version of 'value'. See also 'json''.+value' :: Parser Value+value' = do+  w <- A.peekWord8'+  case w of+    DOUBLE_QUOTE  -> do+                     !s <- A.anyWord8 *> jstring_+                     return (String s)+    OPEN_CURLY    -> A.anyWord8 *> object_'+    OPEN_SQUARE   -> A.anyWord8 *> array_'+    C_f           -> string "false" *> pure (Bool False)+    C_t           -> string "true" *> pure (Bool True)+    C_n           -> string "null" *> pure Null+    _              | w >= 48 && w <= 57 || w == 45+                  -> do+                     !n <- scientific+                     return (Number n)+      | otherwise -> fail "not a valid json value"++-- | Parse a quoted JSON string.+jstring :: Parser Text+jstring = A.word8 DOUBLE_QUOTE *> jstring_++-- | Parse a string without a leading quote.+jstring_ :: Parser Text+jstring_ = {-# SCC "jstring_" #-} do+  s <- A.scan False $ \s c -> if s then Just False+                                   else if c == DOUBLE_QUOTE+                                        then Nothing+                                        else Just (c == BACKSLASH)+  _ <- A.word8 DOUBLE_QUOTE+  s1 <- if BACKSLASH `B.elem` s+        then case Z.parse unescape s of+            Right r  -> return r+            Left err -> fail err+         else return s++  case decodeUtf8' s1 of+      Right r  -> return r+      Left err -> fail $ show err++{-# INLINE jstring_ #-}++unescape :: Z.Parser ByteString+unescape = toByteString <$> go mempty where+  go acc = do+    h <- Z.takeWhile (/=BACKSLASH)+    let rest = do+          start <- Z.take 2+          let !slash = B.unsafeHead start+              !t = B.unsafeIndex start 1+              escape = case B.findIndex (==t) "\"\\/ntbrfu" of+                         Just i -> i+                         _      -> 255+          if slash /= BACKSLASH || escape == 255+            then fail "invalid JSON escape sequence"+            else do+            let cont m = go (acc `mappend` byteString h `mappend` m)+                {-# INLINE cont #-}+            if t /= 117 -- 'u'+              then cont (word8 (B.unsafeIndex mapping escape))+              else do+                   a <- hexQuad+                   if a < 0xd800 || a > 0xdfff+                     then cont (charUtf8 (chr a))+                     else do+                       b <- Z.string "\\u" *> hexQuad+                       if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff+                         then let !c = ((a - 0xd800) `shiftL` 10) ++                                       (b - 0xdc00) + 0x10000+                              in cont (charUtf8 (chr c))+                         else fail "invalid UTF-16 surrogates"+    done <- Z.atEnd+    if done+      then return (acc `mappend` byteString h)+      else rest+  mapping = "\"\\/\n\t\b\r\f"++hexQuad :: Z.Parser Int+hexQuad = do+  s <- Z.take 4+  let hex n | w >= C_0 && w <= C_9 = w - C_0+            | w >= C_a && w <= C_f = w - 87+            | w >= C_A && w <= C_F = w - 55+            | otherwise          = 255+        where w = fromIntegral $ B.unsafeIndex s n+      a = hex 0; b = hex 1; c = hex 2; d = hex 3+  if (a .|. b .|. c .|. d) /= 255+    then return $! d .|. (c `shiftL` 4) .|. (b `shiftL` 8) .|. (a `shiftL` 12)+    else fail "invalid hex escape"++decodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString -> Maybe a+decodeWith p to s =+    case L.parse p s of+      L.Done _ v -> case to v of+                      Success a -> Just a+                      _         -> Nothing+      _          -> Nothing+{-# INLINE decodeWith #-}++decodeStrictWith :: Parser Value -> (Value -> Result a) -> B.ByteString+                 -> Maybe a+decodeStrictWith p to s =+    case either Error to (A.parseOnly p s) of+      Success a -> Just a+      Error _ -> Nothing+{-# INLINE decodeStrictWith #-}++eitherDecodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString+                 -> Either String a+eitherDecodeWith p to s =+    case L.parse p s of+      L.Done _ v -> case to v of+                      Success a -> Right a+                      Error msg -> Left msg+      L.Fail _ _ msg -> Left msg+{-# INLINE eitherDecodeWith #-}++eitherDecodeStrictWith :: Parser Value -> (Value -> Result a) -> B.ByteString+                       -> Either String a+eitherDecodeStrictWith p to s =+    case either Error to (A.parseOnly p s) of+      Success a -> Right a+      Error msg -> Left msg+{-# INLINE eitherDecodeStrictWith #-}++-- $lazy+--+-- The 'json' and 'value' parsers decouple identification from+-- conversion.  Identification occurs immediately (so that an invalid+-- JSON document can be rejected as early as possible), but conversion+-- to a Haskell value is deferred until that value is needed.+--+-- This decoupling can be time-efficient if only a smallish subset of+-- elements in a JSON value need to be inspected, since the cost of+-- conversion is zero for uninspected elements.  The trade off is an+-- increase in memory usage, due to allocation of thunks for values+-- that have not yet been converted.++-- $strict+--+-- The 'json'' and 'value'' parsers combine identification with+-- conversion.  They consume more CPU cycles up front, but have a+-- smaller memory footprint.++-- | Parse a top-level JSON value followed by optional whitespace and+-- end-of-input.  See also: 'json'.+jsonEOF :: Parser Value+jsonEOF = json <* skipSpace <* endOfInput++-- | Parse a top-level JSON value followed by optional whitespace and+-- end-of-input.  See also: 'json''.+jsonEOF' :: Parser Value+jsonEOF' = json' <* skipSpace <* endOfInput++toByteString :: Builder -> ByteString+toByteString = L.toStrict . toLazyByteString+{-# INLINE toByteString #-}++aeson :: IO [Benchmark]+aeson = do+  path <- pathTo "json-data"+  names <- sort . filter (`notElem` [".", ".."]) <$> getDirectoryContents path+  forM names $ \name -> do+    bs <- B.readFile (path </> name)+    return . bench ("attoparsec/" ++ dropExtension name) $ nf (A.parseOnly jsonEOF') bs++aesonLazy :: IO [Benchmark]+aesonLazy = do+  path <- pathTo "json-data"+  names <- sort . filter (`notElem` [".", ".."]) <$> getDirectoryContents path+  forM names $ \name -> do+    bs <- L.readFile (path </> name)+    return . bench ("attoparsec/lazy-bytestring/" ++ dropExtension name) $ nf (L.parse jsonEOF') bs
+ binary-parser-bench/AesonBP.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}++module AesonBP+    (+      aeson+    , aesonLazy+    , value'+    ) where++import Data.ByteString.Builder+  (Builder, byteString, toLazyByteString, charUtf8, word8)++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((*>), (<$>), (<*), pure)+import Data.Monoid (mappend, mempty)+#endif++import Control.Applicative (liftA2)+import Control.DeepSeq (NFData(..))+import Control.Monad (forM)+import Data.Bits ((.|.), shiftL)+import Data.ByteString (ByteString)+import Data.Char (chr)+import Data.List (sort)+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8')+import Data.Vector as Vector (Vector, foldl', fromList)+import Data.Word (Word8)+import System.Directory (getDirectoryContents, doesDirectoryExist)+import System.FilePath ((</>), dropExtension)+import qualified Data.Attoparsec.Zepto as Z+import Data.Binary.Get (Get)+import qualified Data.Binary.Parser as BP+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Unsafe as B+import qualified Data.HashMap.Strict as H+import Criterion.Main+import Common (pathTo)++#define BACKSLASH 92+#define CLOSE_CURLY 125+#define CLOSE_SQUARE 93+#define COMMA 44+#define COLON 58+#define DOUBLE_QUOTE 34+#define OPEN_CURLY 123+#define OPEN_SQUARE 91+#define C_0 48+#define C_9 57+#define C_A 65+#define C_F 70+#define C_a 97+#define C_f 102+#define C_n 110+#define C_t 116++data Result a = Error String+              | Success a+                deriving (Eq, Show)+++-- | A JSON \"object\" (key\/value map).+type Object = H.HashMap Text Value++-- | A JSON \"array\" (sequence).+type Array = Vector Value++-- | A JSON value represented as a Haskell value.+data Value = Object !Object+           | Array !Array+           | String !Text+           | Number !Scientific+           | Bool !Bool+           | Null+             deriving (Eq, Show)++instance NFData Value where+    rnf (Object o) = rnf o+    rnf (Array a)  = Vector.foldl' (\x y -> rnf y `seq` x) () a+    rnf (String s) = rnf s+    rnf (Number n) = rnf n+    rnf (Bool b)   = rnf b+    rnf Null       = ()++-- | Parse a top-level JSON value.  This must be either an object or+-- an array, per RFC 4627.+--+-- The conversion of a parsed value to a Haskell value is deferred+-- until the Haskell value is needed.  This may improve performance if+-- only a subset of the results of conversions are needed, but at a+-- cost in thunk allocation.+json :: Get Value+json = json_ object_ array_++-- | Parse a top-level JSON value.  This must be either an object or+-- an array, per RFC 4627.+--+-- This is a strict version of 'json' which avoids building up thunks+-- during parsing; it performs all conversions immediately.  Prefer+-- this version if most of the JSON data needs to be accessed.+json' :: Get Value+json' = json_ object_' array_'++json_ :: Get Value -> Get Value -> Get Value+json_ obj ary = do+  w <- BP.skipSpaces *> BP.satisfy (\w -> w == OPEN_CURLY || w == OPEN_SQUARE)+  if w == OPEN_CURLY+    then obj+    else ary+{-# INLINE json_ #-}++object_ :: Get Value+object_ = {-# SCC "object_" #-} Object <$> objectValues jstring value++object_' :: Get Value+object_' = {-# SCC "object_'" #-} do+  !vals <- objectValues jstring' value'+  return (Object vals)+ where+  jstring' = do+    !s <- jstring+    return s++objectValues :: Get Text -> Get Value -> Get (H.HashMap Text Value)+objectValues str val = do+  BP.skipSpaces+  let pair = liftA2 (,) (str <* BP.skipSpaces) (BP.word8 COLON *> BP.skipSpaces *> val)+  H.fromList <$> commaSeparated pair CLOSE_CURLY+{-# INLINE objectValues #-}++array_ :: Get Value+array_ = {-# SCC "array_" #-} Array <$> arrayValues value++array_' :: Get Value+array_' = {-# SCC "array_'" #-} do+  !vals <- arrayValues value'+  return (Array vals)++commaSeparated :: Get a -> Word8 -> Get [a]+commaSeparated item endByte = do+  w <- BP.peek+  if w == endByte+    then BP.skipN 1 >> return []+    else loop+  where+    loop = do+      v <- item <* BP.skipSpaces+      ch <- BP.satisfy $ \w -> w == COMMA || w == endByte+      if ch == COMMA+        then BP.skipSpaces >> (v:) <$> loop+        else return [v]+{-# INLINE commaSeparated #-}++arrayValues :: Get Value -> Get (Vector Value)+arrayValues val = do+  BP.skipSpaces+  Vector.fromList <$> commaSeparated val CLOSE_SQUARE+{-# INLINE arrayValues #-}++-- | Parse any JSON value.  You should usually 'json' in preference to+-- this function, as this function relaxes the object-or-array+-- requirement of RFC 4627.+--+-- In particular, be careful in using this function if you think your+-- code might interoperate with Javascript.  A na&#xef;ve Javascript+-- library that parses JSON data using @eval@ is vulnerable to attack+-- unless the encoded data represents an object or an array.  JSON+-- implementations in other languages conform to that same restriction+-- to preserve interoperability and security.+value :: Get Value+value = do+  w <- BP.peek+  case w of+    DOUBLE_QUOTE  -> BP.skipN 1 *> (String <$> jstring_)+    OPEN_CURLY    -> BP.skipN 1 *> object_+    OPEN_SQUARE   -> BP.skipN 1 *> array_+    C_f           -> BP.string "false" *> pure (Bool False)+    C_t           -> BP.string "true" *> pure (Bool True)+    C_n           -> BP.string "null" *> pure Null+    _              | w >= 48 && w <= 57 || w == 45+                  -> Number <$> BP.scientific+      | otherwise -> fail "not a valid json value"++-- | Strict version of 'value'. See also 'json''.+value' :: Get Value+value' = do+  w <- BP.peek+  case w of+    DOUBLE_QUOTE  -> do+                     !s <- BP.skipN 1 *> jstring_+                     return (String s)+    OPEN_CURLY    -> BP.skipN 1 *> object_'+    OPEN_SQUARE   -> BP.skipN 1 *> array_'+    C_f           -> BP.string "false" *> pure (Bool False)+    C_t           -> BP.string "true" *> pure (Bool True)+    C_n           -> BP.string "null" *> pure Null+    _              | w >= 48 && w <= 57 || w == 45+                  -> do+                     !n <- BP.scientific+                     return (Number n)+      | otherwise -> fail "not a valid json value"++-- | Parse a quoted JSON string.+jstring :: Get Text+jstring = BP.word8 DOUBLE_QUOTE *> jstring_++-- | Parse a string without a leading quote.+jstring_ :: Get Text+jstring_ = {-# SCC "jstring_" #-} do+  s <- BP.scan False $ \s c -> if s then Just False+                                   else if c == DOUBLE_QUOTE+                                        then Nothing+                                        else Just (c == BACKSLASH)+  BP.word8 DOUBLE_QUOTE+  s1 <- if BACKSLASH `B.elem` s+        then case Z.parse unescape s of+            Right r  -> return r+            Left err -> fail err+         else return s++  case decodeUtf8' s1 of+      Right r  -> return r+      Left err -> fail $ show err++{-# INLINE jstring_ #-}++unescape :: Z.Parser ByteString+unescape = toByteString <$> go mempty where+  go acc = do+    h <- Z.takeWhile (/=BACKSLASH)+    let rest = do+          start <- Z.take 2+          let !slash = B.unsafeHead start+              !t = B.unsafeIndex start 1+              escape = case B.findIndex (==t) "\"\\/ntbrfu" of+                         Just i -> i+                         _      -> 255+          if slash /= BACKSLASH || escape == 255+            then fail "invalid JSON escape sequence"+            else do+            let cont m = go (acc `mappend` byteString h `mappend` m)+                {-# INLINE cont #-}+            if t /= 117 -- 'u'+              then cont (word8 (B.unsafeIndex mapping escape))+              else do+                   a <- hexQuad+                   if a < 0xd800 || a > 0xdfff+                     then cont (charUtf8 (chr a))+                     else do+                       b <- Z.string "\\u" *> hexQuad+                       if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff+                         then let !c = ((a - 0xd800) `shiftL` 10) ++                                       (b - 0xdc00) + 0x10000+                              in cont (charUtf8 (chr c))+                         else fail "invalid UTF-16 surrogates"+    done <- Z.atEnd+    if done+      then return (acc `mappend` byteString h)+      else rest+  mapping = "\"\\/\n\t\b\r\f"++hexQuad :: Z.Parser Int+hexQuad = do+  s <- Z.take 4+  let hex n | w >= C_0 && w <= C_9 = w - C_0+            | w >= C_a && w <= C_f = w - 87+            | w >= C_A && w <= C_F = w - 55+            | otherwise          = 255+        where w = fromIntegral $ B.unsafeIndex s n+      a = hex 0; b = hex 1; c = hex 2; d = hex 3+  if (a .|. b .|. c .|. d) /= 255+    then return $! d .|. (c `shiftL` 4) .|. (b `shiftL` 8) .|. (a `shiftL` 12)+    else fail "invalid hex escape"++-- $lazy+--+-- The 'json' and 'value' parsers decouple identification from+-- conversion.  Identification occurs immediately (so that an invalid+-- JSON document can be rejected as early as possible), but conversion+-- to a Haskell value is deferred until that value is needed.+--+-- This decoupling can be time-efficient if only a smallish subset of+-- elements in a JSON value need to be inspected, since the cost of+-- conversion is zero for uninspected elements.  The trade off is an+-- increase in memory usage, due to allocation of thunks for values+-- that have not yet been converted.++-- $strict+--+-- The 'json'' and 'value'' parsers combine identification with+-- conversion.  They consume more CPU cycles up front, but have a+-- smaller memory footprint.++-- | Parse a top-level JSON value followed by optional whitespace and+-- end-of-input.  See also: 'json'.+jsonEOF :: Get Value+jsonEOF = json <* BP.skipSpaces++-- | Parse a top-level JSON value followed by optional whitespace and+-- end-of-input.  See also: 'json''.+jsonEOF' :: Get Value+jsonEOF' = json' <* BP.skipSpaces++toByteString :: Builder -> ByteString+toByteString = L.toStrict . toLazyByteString+{-# INLINE toByteString #-}++aeson :: IO [Benchmark]+aeson = do+  path <- pathTo "json-data"+  names <- sort . filter (`notElem` [".", ".."]) <$> getDirectoryContents path+  forM names $ \name -> do+    bs <- B.readFile (path </> name)+    return . bench ("binary-parser/" ++ dropExtension name) $ nf (BP.parseOnly jsonEOF') bs++aesonLazy :: IO [Benchmark]+aesonLazy = do+  path <- pathTo "json-data"+  names <- sort . filter (`notElem` [".", ".."]) <$> getDirectoryContents path+  forM names $ \name -> do+    bs <- L.readFile (path </> name)+    return . bench ("binary-parser/lazy-bytestring/" ++ dropExtension name) $ nf (BP.parseLazy jsonEOF') bs
+ binary-parser-bench/Bench.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Criterion.Main+import qualified Aeson+import qualified AesonBP+import qualified HttpReq+import Data.List++main :: IO ()+main = do+    http <- HttpReq.headers++    putStrLn "start benchmark http request parser"++    defaultMain http++    putStrLn "start benchmark JSON parser"++    aeson <- Aeson.aeson+    aesonbp <- AesonBP.aeson+    aesonLazy <- Aeson.aesonLazy+    aesonbpLazy <- AesonBP.aesonLazy++    (defaultMain . concat . transpose) [ aeson, aesonbp, aesonLazy, aesonbpLazy ]
+ binary-parser-bench/Common.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Common (+      chunksOf+    , pathTo+    , rechunkBS+    , rechunkT+    ) where++import Control.DeepSeq (NFData(rnf))+import System.Directory (doesDirectoryExist)+import System.FilePath ((</>))+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++#if !MIN_VERSION_bytestring(0,10,0)+import Data.ByteString.Internal (ByteString(..))++instance NFData ByteString where+    rnf (PS _ _ _) = ()+#endif++chunksOf :: Int -> [a] -> [[a]]+chunksOf k = go+  where go xs = case splitAt k xs of+                  ([],_)  -> []+                  (y, ys) -> y : go ys++rechunkBS :: Int -> B.ByteString -> BL.ByteString+rechunkBS n = BL.fromChunks . map B.pack . chunksOf n . B.unpack++rechunkT :: Int -> T.Text -> TL.Text+rechunkT n = TL.fromChunks . map T.pack . chunksOf n . T.unpack++pathTo :: String -> IO FilePath+pathTo wat = do+  exists <- doesDirectoryExist "bench"+  return $ if exists+           then "bench" </> wat+           else wat
+ binary-parser-bench/HttpReq.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+module HttpReq (headers) where++import Common (pathTo, rechunkBS)+import Control.Applicative+import Criterion.Main (bench, bgroup, nf, nfIO)+import Control.DeepSeq (NFData(..))+import Criterion.Types (Benchmark)+import Network.Wai.Handler.Warp.RequestHeader (parseHeaderLines)+import Data.ByteString.Internal (c2w, w2c)+import qualified Data.Attoparsec.ByteString as AP+import qualified Data.Attoparsec.ByteString.Char8 as APC+import qualified Data.ByteString.Char8 as BC+import qualified Data.Binary.Parser as BP+import qualified Data.Binary.Parser.Char8 as BPC+import Network.HTTP.Types.Version (HttpVersion, http11)+import qualified Scanner as SC++headers :: IO [Benchmark]+headers = do+  req <- BC.readFile =<< pathTo "http-request.txt"+  return [+        bench "http-req/attoparsec" $ nf (AP.parseOnly attoRequest) req+      , bench "http-req/binary-parsers" $ nf (BP.parseOnly bpRequest) req+      , bench "http-req/scanner" $ nf (SC.scanOnly scRequest) req+      , bench "http-req/warp" $ nfIO (parseHeaderLines (BC.lines req))+      ]++--------------------------------------------------------------------------------++instance NFData HttpVersion where+    rnf !_ = ()++attoHeader = do+  name <- APC.takeWhile1 (APC.inClass "a-zA-Z0-9_-") <* APC.char ':' <* APC.skipSpace+  body <- attoBodyLine+  return (name, body)++attoBodyLine = APC.takeTill (\c -> c == '\r' || c == '\n') <* APC.endOfLine++attoReqLine = do+  m <- (APC.takeTill APC.isSpace <* APC.char ' ')+  (p,q) <- BC.break (=='?') <$> (APC.takeTill APC.isSpace <* APC.char ' ')+  v <- attoHttpVersion+  return (m,p,q,v)++attoHttpVersion = http11 <$ APC.string "HTTP/1.1"++attoRequest = (,) <$> (attoReqLine <* APC.endOfLine) <*> attoManyHeader++attoManyHeader = do+  c <- APC.peekChar'+  if c == '\r' || c == '\n'+    then return []++    else (:) <$> attoHeader <*> attoManyHeader++--------------------------------------------------------------------------------++bpHeader = do+  name <- BPC.takeWhile1 isHeaderChar <* BPC.char ':' <* BP.skipSpaces+  body <- bpBodyLine+  return (name, body)+  where+    isHeaderChar c = ('a' <= c && c <= 'z')+                  || ('A' <= c && c <= 'Z')+                  || ('0' <= c && c <= '0')+                  || c == '_' || c == '-'++bpBodyLine = BPC.takeTill (\c -> c == '\r' || c == '\n') <* BP.endOfLine++bpReqLine = do+  m <- (BPC.takeTill BPC.isSpace <* BPC.char ' ')+  (p,q) <- BC.break (=='?') <$> (BPC.takeTill BPC.isSpace <* BPC.char ' ')+  v <- bpHttpVersion+  return (m,p,q,v)++bpHttpVersion = http11 <$ BP.string "HTTP/1.1"++bpRequest = (,) <$> (bpReqLine <* BP.endOfLine) <*> bpManyHeader++bpManyHeader = do+  c <- BPC.peek+  if c == '\r' || c == '\n'+    then return []+    else (:) <$> bpHeader <*> bpManyHeader++--------------------------------------------------------------------------------++scHeader = do+  name <- takeWhile1 (isHeaderChar . w2c) <* SC.char8 ':' <* SC.skipSpace+  body <- scBodyLine+  return (name, body)+  where+    isHeaderChar c = ('a' <= c && c <= 'z')+                  || ('A' <= c && c <= 'Z')+                  || ('0' <= c && c <= '0')+                  || c == '_' || c == '-'++    takeWhile1 p = do+        bs <- SC.takeWhile p+        if BC.null bs then fail "takeWhile1" else return bs++scEndOfLine = do        -- scanner doesn't provide endOfLine, so we roll one here+    w <- SC.anyWord8+    case w of+        10 -> return ()+        13 -> SC.word8 10+        _  -> fail "endOfLine"+{-# INLINE scEndOfLine #-}++scBodyLine = SC.takeWhile (\w -> let c = w2c w in c /= '\r' && c /= '\n') <* scEndOfLine++scReqLine = do+  m <- (SC.takeWhile (not . BP.isSpace) <* SC.char8 ' ')+  (p,q) <- BC.break (=='?') <$> (SC.takeWhile (not . BP.isSpace) <* SC.char8 ' ')+  v <- scHttpVersion+  return (m,p,q,v)++scHttpVersion = http11 <$ SC.string "HTTP/1.1"++scRequest = (,) <$> (scReqLine <* scEndOfLine) <*> scManyHeader++scManyHeader = do+  w <- SC.lookAhead+  case w of+    Just w' -> do+      let c = w2c w'+      if c == '\r' || c == '\n'+        then return []+        else (:) <$> scHeader <*> scManyHeader+    _ -> fail "scManyHeader"
+ binary-parser-bench/Network/Wai/Handler/Warp/ReadInt.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}++-- Copyright     : Erik de Castro Lopo <erikd@mega-nerd.com>+-- License       : BSD3++module Network.Wai.Handler.Warp.ReadInt (+    readInt+  , readInt64+  ) where++-- This function lives in its own file because the MagicHash pragma interacts+-- poorly with the CPP pragma.++import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import Data.Int (Int64)+import GHC.Prim+import GHC.Types+import GHC.Word++{-# INLINE readInt #-}+readInt :: Integral a => ByteString -> a+readInt bs = fromIntegral $ readInt64 bs++-- This function is used to parse the Content-Length field of HTTP headers and+-- is a performance hot spot. It should only be replaced with something+-- significantly and provably faster.+--+-- It needs to be able work correctly on 32 bit CPUs for file sizes > 2G so we+-- use Int64 here and then make a generic 'readInt' that allows conversion to+-- Int and Integer.++{-# NOINLINE readInt64 #-}+readInt64 :: ByteString -> Int64+readInt64 bs = S.foldl' (\ !i !c -> i * 10 + fromIntegral (mhDigitToInt c)) 0+             $ S.takeWhile isDigit bs++data Table = Table !Addr#++{-# NOINLINE mhDigitToInt #-}+mhDigitToInt :: Word8 -> Int+mhDigitToInt (W8# i) = I# (word2Int# (indexWord8OffAddr# addr (word2Int# i)))+  where+    !(Table addr) = table+    table :: Table+    table = Table+        "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++isDigit :: Word8 -> Bool+isDigit w = w >= 48 && w <= 57
+ binary-parser-bench/Network/Wai/Handler/Warp/RequestHeader.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}++module Network.Wai.Handler.Warp.RequestHeader (+      parseHeaderLines+    , parseByteRanges+    ) where++import Control.Exception (Exception, throwIO)+import Control.Monad (when)+import Data.Typeable (Typeable)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as B (unpack, readInteger)+import Data.ByteString.Internal (ByteString(..), memchr)+import qualified Data.CaseInsensitive as CI+import Data.Word (Word8)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)+import Foreign.Storable (peek)+import qualified Network.HTTP.Types as H+-- import Network.Wai.Handler.Warp.Types+import qualified Network.HTTP.Types.Header as HH+-- $setup+-- >>> :set -XOverloadedStrings++data InvalidRequest = NotEnoughLines [String]+                    | BadFirstLine String+                    | NonHttp+                    | IncompleteHeaders+                    | ConnectionClosedByPeer+                    | OverLargeHeader+                    deriving (Eq, Typeable, Show)++instance Exception InvalidRequest++----------------------------------------------------------------++parseHeaderLines :: [ByteString]+                 -> IO (H.Method+                       ,ByteString  --  Path+                       ,ByteString  --  Path, parsed+                       ,ByteString  --  Query+                       ,H.HttpVersion+                       ,H.RequestHeaders+                       )+parseHeaderLines [] = throwIO $ NotEnoughLines []+parseHeaderLines (firstLine:otherLines) = do+    (method, path', query, httpversion) <- parseRequestLine firstLine+    let path = H.extractPath path'+        hdr = map parseHeader otherLines+    return (method, path', path, query, httpversion, hdr)++----------------------------------------------------------------++-- |+--+-- >>> parseRequestLine "GET / HTTP/1.1"+-- ("GET","/","",HTTP/1.1)+-- >>> parseRequestLine "POST /cgi/search.cgi?key=foo HTTP/1.0"+-- ("POST","/cgi/search.cgi","?key=foo",HTTP/1.0)+-- >>> parseRequestLine "GET "+-- *** Exception: Warp: Invalid first line of request: "GET "+-- >>> parseRequestLine "GET /NotHTTP UNKNOWN/1.1"+-- *** Exception: Warp: Request line specified a non-HTTP request+parseRequestLine :: ByteString+                 -> IO (H.Method+                       ,ByteString -- Path+                       ,ByteString -- Query+                       ,H.HttpVersion)+parseRequestLine requestLine@(PS fptr off len) = withForeignPtr fptr $ \ptr -> do+    when (len < 14) $ throwIO baderr+    let methodptr = ptr `plusPtr` off+        limptr = methodptr `plusPtr` len+        lim0 = fromIntegral len++    pathptr0 <- memchr methodptr 32 lim0 -- ' '+    when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $+        throwIO baderr+    let pathptr = pathptr0 `plusPtr` 1+        lim1 = fromIntegral (limptr `minusPtr` pathptr0)++    httpptr0 <- memchr pathptr 32 lim1 -- ' '+    when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $+        throwIO baderr+    let httpptr = httpptr0 `plusPtr` 1+        lim2 = fromIntegral (httpptr0 `minusPtr` pathptr)++    checkHTTP httpptr+    !hv <- httpVersion httpptr+    queryptr <- memchr pathptr 63 lim2 -- '?'++    let !method = bs ptr methodptr pathptr0+        !path+          | queryptr == nullPtr = bs ptr pathptr httpptr0+          | otherwise           = bs ptr pathptr queryptr+        !query+          | queryptr == nullPtr = S.empty+          | otherwise           = bs ptr queryptr httpptr0++    return (method,path,query,hv)+  where+    baderr = BadFirstLine $ B.unpack requestLine+    check :: Ptr Word8 -> Int -> Word8 -> IO ()+    check p n w = do+        w0 <- peek $ p `plusPtr` n+        when (w0 /= w) $ throwIO NonHttp+    checkHTTP httpptr = do+        check httpptr 0 72 -- 'H'+        check httpptr 1 84 -- 'T'+        check httpptr 2 84 -- 'T'+        check httpptr 3 80 -- 'P'+        check httpptr 4 47 -- '/'+        check httpptr 6 46 -- '.'+    httpVersion httpptr = do+        major <- peek $ httpptr `plusPtr` 5+        minor <- peek $ httpptr `plusPtr` 7+        return $ if major == (49 :: Word8) && minor == (49 :: Word8) then+            H.http11+          else+            H.http10+    bs ptr p0 p1 = PS fptr o l+      where+        o = p0 `minusPtr` ptr+        l = p1 `minusPtr` p0++----------------------------------------------------------------++-- |+--+-- >>> parseHeader "Content-Length:47"+-- ("Content-Length","47")+-- >>> parseHeader "Accept-Ranges: bytes"+-- ("Accept-Ranges","bytes")+-- >>> parseHeader "Host:  example.com:8080"+-- ("Host","example.com:8080")+-- >>> parseHeader "NoSemiColon"+-- ("NoSemiColon","")++parseHeader :: ByteString -> H.Header+parseHeader s =+    let (k, rest) = S.break (== 58) s -- ':'+        rest' = S.dropWhile (\c -> c == 32 || c == 9) $ S.drop 1 rest+     in (CI.mk k, rest')++parseByteRanges :: S.ByteString -> Maybe HH.ByteRanges+parseByteRanges bs1 = do+    bs2 <- stripPrefix "bytes=" bs1+    (r, bs3) <- range bs2+    ranges (r:) bs3+  where+    range bs2 =+        case stripPrefix "-" bs2 of+            Just bs3 -> do+                (i, bs4) <- B.readInteger bs3+                Just (HH.ByteRangeSuffix i, bs4)+            Nothing -> do+                (i, bs3) <- B.readInteger bs2+                bs4 <- stripPrefix "-" bs3+                case B.readInteger bs4 of+                    Nothing -> Just (HH.ByteRangeFrom i, bs4)+                    Just (j, bs5) -> Just (HH.ByteRangeFromTo i j, bs5)+    ranges front bs3 =+        case stripPrefix "," bs3 of+            Nothing -> Just (front [])+            Just bs4 -> do+                (r, bs5) <- range bs4+                ranges (front . (r:)) bs5++    stripPrefix x y+        | x `S.isPrefixOf` y = Just (S.drop (S.length x) y)+        | otherwise = Nothing
+ mysql-pure.cabal view
@@ -0,0 +1,198 @@+cabal-version:      2.2+name:               mysql-pure+version:            1.0.0+synopsis:           pure haskell MySQL driver+description:        pure haskell MySQL driver.+license:            BSD-3-Clause+license-file:       LICENSE+author:             winterland1989+maintainer:         hi@jappie.me+copyright:          (c) 2016 Winterland+category:           Database+build-type:         Simple+extra-doc-files:+  ChangeLog.md+extra-source-files:+  README.md++homepage:           https://github.com/jappeace/mysql-pure+bug-reports:        https://github.com/jappeace/mysql-pure/issues++source-repository head+  type:     git+  location: git://github.com/jappeace/mysql-pure.git++library+  exposed-modules:+    Data.Binary.Parser+    Data.Binary.Parser.Char8+    Data.Binary.Parser.Numeric+    Data.Binary.Parser.Word8+    Data.Int.Int24+    Data.Word.Word24+    Database.MySQL.Base+    Database.MySQL.BinLog+    Database.MySQL.BinLogProtocol.BinLogEvent+    Database.MySQL.BinLogProtocol.BinLogMeta+    Database.MySQL.BinLogProtocol.BinLogValue+    Database.MySQL.Connection+    Database.MySQL.Protocol.Auth+    Database.MySQL.Protocol.ColumnDef+    Database.MySQL.Protocol.Command+    Database.MySQL.Protocol.Escape+    Database.MySQL.Protocol.MySQLValue+    Database.MySQL.Protocol.Packet+    Database.MySQL.TLS+    System.IO.Streams.Binary++  hs-source-dirs:     src+  other-modules:      Database.MySQL.Query+  build-depends:+    , base               >=4.7      && <4.19.0+    , binary             >=0.8.3    && <0.9+    , binary-ieee754     >=0.1.0    && <0.2+    , blaze-textual      >=0.2      && <0.3+    , bytestring         >=0.10.2.0 && <0.12+    , bytestring-lexing  >=0.5      && <0.6+    , crypton            >=0.31     && <0.40+    , deepseq            >=1.4.6    && <1.5+    , io-streams         >=1.2      && <2.0+    , memory             >=0.14.4   && <0.19+    , monad-loops        >=0.4      && <0.5+    , network            >=2.3      && <4.0+    , scientific         >=0.3      && <0.4+    , tcp-streams        >=1.0      && <1.1+    , text               >=1.1      && <2.1+    , time               >=1.5.0    && <1.12+    , tls                >=1.3.5    && <1.7+    , vector             >=0.8      && <0.13+    , word-compat        >=0.0      && <0.1++  default-language:   Haskell2010+  default-extensions:+    DeriveDataTypeable+    DeriveGeneric+    MultiWayIf+    OverloadedStrings++  ghc-options:        -Wall++test-suite test+  type:               exitcode-stdio-1.0+  main-is:            Main.hs+  other-modules:+    Aeson+    AesonBP+    BinaryRow+    BinaryRowNew+    BinLog+    BinLogNew+    ExecuteMany+    JSON+    MysqlTests+    QC.ByteString+    QC.Combinator+    QC.Common+    QCUtils+    TextRow+    TextRowNew+    WireStreams+    Word24++  hs-source-dirs:     test+  build-depends:+    , attoparsec+    , base+    , binary                >=0.8+    , bytestring            >=0.10+    , bytestring-lexing     >=0.5+    , containers+    , deepseq+    , directory+    , filepath+    , io-streams+    , mysql-pure+    , QuickCheck            >=2.7+    , quickcheck-instances+    , scientific            >=0.3.0+    , tasty                 >=0.11  && <2.0+    , tasty-hunit+    , tasty-quickcheck      >=0.8+    , text+    , time+    , unordered-containers+    , vector++  default-extensions:+    MultiWayIf+    OverloadedStrings++  ghc-options:        -threaded+  default-language:   Haskell2010++benchmark binary-parsers-bench+  other-modules:+    Aeson+    AesonBP+    Common+    HttpReq+    Network.Wai.Handler.Warp.ReadInt+    Network.Wai.Handler.Warp.RequestHeader++  build-depends:+    , attoparsec+    , base+    , binary+    , bytestring+    , case-insensitive+    , criterion             >=1.1 && <1.2+    , deepseq+    , directory+    , filepath+    , http-types+    , mysql-pure+    , scanner+    , scientific+    , text+    , unordered-containers+    , vector++  default-language: Haskell2010+  hs-source-dirs:   binary-parser-bench+  main-is:          Bench.hs+  type:             exitcode-stdio-1.0+  ghc-options:      -O2++benchmark bench-wirestream+  type:             exitcode-stdio-1.0+  main-is:          Main.hs+  other-modules:    System.IO.Streams.Cereal+  hs-source-dirs:   wire-streams-bench+  default-language: Haskell2010+  build-depends:+    , base+    , binary+    , bytestring+    , cereal+    , cereal-conduit+    , conduit+    , conduit-extra+    , criterion       >=1.0.2.0+    , io-streams+    , mysql-pure+    , transformers++  ghc-options:      -rtsopts -Wall++benchmark bench24+  default-language: Haskell2010+  type:             exitcode-stdio-1.0+  hs-source-dirs:   word24-bench+  main-is:          Benchmark.hs+  build-depends:+    , base+    , criterion  >=1.1+    , deepseq    >=1.2 && <2+    , word24++  ghc-options:      -O2
+ src/Data/Binary/Parser.hs view
@@ -0,0 +1,386 @@+{-# LANGUAGE BangPatterns #-}+-- |+-- Module      :  Data.Binary.Parser+-- Copyright   :  Daan Leijen 1999-2001, Bryan O'Sullivan 2007-2015, Winterland 2016+-- License     :  BSD3+--+-- Maintainer  :  drkoster@qq.com+-- Stability   :  experimental+-- Portability :  portable+--+-- This library provide parsec\/attoparsec style parsing combinators for+-- <http://hackage.haskell.org/package/binary binary>+-- package. By default, this module export combinators in "Data.Binary.Get",+-- "Data.Binary.Parser.Word8" and "Data.Binary.Parser.Numeric", for additional ASCII char parser,+-- please check "Data.Binary.Parser.Char8" module.+--+-- The behaviour of parsers here is different to that of the+-- similarly-named parser in Parsec, as this one is all-or-nothing.+-- To illustrate the difference, the following parser will fail under+-- Parsec given an input of @\"for\"@:+--+-- >string "foo" <|> string "for"+--+-- The reason for its failure is that the first branch is a+-- partial match, and will consume the letters @\'f\'@ and @\'o\'@+-- before failing.  In binary-parsers, the above parser will /succeed/ on+-- that input, because the failed first branch will consume nothing.+--+-- There're some redundant combinators get removed, for example:+--+-- @+-- choice == asum+-- count == replicateM+-- atEnd == isEmpty+-- take == getByteString+-- many1 == some+-- @+--+-- For fast byte set operations, please use <http://hackage.haskell.org/package/charset charset>+-- package.+--+-- It's recommanded to use 'parseOnly', 'parseDetail'... functions to run your parsers since these+-- functions are faster than binary's counter part by avoiding a small constant overhead.+-- Check 'parse' for detail.+--+-- = A few words on performance and backtracking+--+-- There's a common belief that parsers which support backtracking are slow, but it's not neccessarily+-- true in binary, because binary doesn't do book keeping if you doesn't use '<|>', 'lookAhead' or their+-- friends. Combinators in this library like 'peek', 'string'... also try to avoid backtracking so+-- it's faster to use them rather than do backtracking yourself, for example, 'peek' is faster than+-- @'lookAhead' 'getWord8'@. In practice, protocols are often designed to avoid backtracking.+-- For example, if you have following parser:+--+-- >branch1 <|> branch2 <|> (skipN 1 >> branch3)+--+-- And if you can select the right branch just by looking ahead one byte, then you can rewrite it to:+--+-- @+-- w <- peek+-- if  | w == b1 -> branch1+--     | w == b2 -> branch2+--     | w == b3 -> skipN 1 >> branch3+-- @+--+-- Binary performs as fast as a non-backtracking parser as long as you construct your parser+-- without using backtracking. And sometime backtracking is indeed neccessary, for example 'scientifically'+-- is almost impossible to implement correctly if you don't do backtracking.+--+module Data.Binary.Parser+    (+    -- * Running parsers+      Parser+    , parseOnly+    , parseLazy+    , parseDetail+    , parseDetailLazy+    , parse+    -- * Decoder conversion+    , maybeDecoder+    , eitherDecoder+    -- * Combinators+    , (<?>)+    , endOfInput+    , option+    , eitherP+    , match+    , many'+    , some'+    , sepBy+    , sepBy'+    , sepBy1+    , sepBy1'+    , manyTill+    , manyTill'+    , skipMany+    , skipMany1+    -- * Re-exports+    , module Data.Binary.Get+    , module Data.Binary.Parser.Word8+    , module Data.Binary.Parser.Numeric+    ) where++import           Control.Applicative+import           Control.Monad+import           Data.Binary.Get+import qualified Data.Binary.Get.Internal   as I+import           Data.Binary.Parser.Numeric+import           Data.Binary.Parser.Word8+import qualified Data.ByteString            as B+import qualified Data.ByteString.Lazy       as L+import qualified Data.ByteString.Lazy.Internal as L (ByteString(..))++--------------------------------------------------------------------------------++-- | Alias to 'Get' for attoparsec compatibility.+type Parser a = Get a++-- | Run a parser on 'B.ByteString'.+--+-- This function does not force a parser to consume all of its input.+-- Instead, any residual input will be discarded.  To force a parser+-- to consume all of its input, use something like this:+--+-- @parseOnly (myParser <* endOfInput)@+--+parseOnly :: Get a -> B.ByteString -> Either String a+parseOnly g bs =+    case pushEndOfInput (parse g bs) of+        Fail _ _ err -> Left err+        Done _ _ a -> Right a+        _ -> error "parseOnly: impossible error!"+{-# INLINE parseOnly #-}+++-- | Similar to 'parseOnly', but run a parser on lazy 'L.ByteString'.+--+parseLazy :: Get a -> L.ByteString -> Either String a+parseLazy g (L.Chunk bs lbs) =+    case pushEndOfInput (pushChunks (parse g bs) lbs) of+        Fail _ _ err -> Left err+        Done _ _ a -> Right a+        _ -> error "parseOnly: impossible error!"+parseLazy g L.Empty =+    case pushEndOfInput (parse g B.empty) of+        Fail _ _ err -> Left err+        Done _ _ a -> Right a+        _ -> error "parseOnly: impossible error!"+{-# INLINE parseLazy #-}++-- | Run a parser on 'B.ByteString'.+--+-- This function return full parsing results: the rest of input, stop offest and fail+-- message or parsing result.+--+-- /Since: 0.2.1.0/+--+parseDetail :: Get a+            -> B.ByteString+            -> Either (B.ByteString, ByteOffset, String) (B.ByteString, ByteOffset, a)+parseDetail g bs =+    case pushEndOfInput (parse g bs) of+        Fail rest offset err -> Left (rest, offset, err)+        Done rest offset a   -> Right (rest, offset, a)+        _ -> error "parseOnly: impossible error!"+{-# INLINE parseDetail #-}++-- | Similar to 'parseDetail', but run a parser on lazy 'L.ByteString'.+--+-- /Since: 0.2.1.0/+--+parseDetailLazy :: Get a+                -> L.ByteString+                -> Either (B.ByteString, ByteOffset, String) (B.ByteString, ByteOffset, a)+parseDetailLazy g (L.Chunk bs lbs) =+    case pushEndOfInput (pushChunks (parse g bs) lbs) of+        Fail rest offset err -> Left (rest, offset, err)+        Done rest offset a   -> Right (rest, offset, a)+        _ -> error "parseOnly: impossible error!"+parseDetailLazy g L.Empty =+    case pushEndOfInput (parse g B.empty) of+        Fail rest offset err -> Left (rest, offset, err)+        Done rest offset a   -> Right (rest, offset, a)+        _ -> error "parseOnly: impossible error!"+{-# INLINE parseDetailLazy #-}++-- | Run a 'Get' monad. See 'Decoder' for what to do next, like providing+-- input, handling decoding errors and to get the output value.+--+-- This's faster than 'runGetIncremental' becuase it provides an initial chunk rather+-- than feeding 'B.empty' and waiting for chunks, this overhead is noticeable when you're+-- running small getters over short 'ByteString' s.+--+-- /Since: 0.2.1.0/+--+parse :: Get a -> B.ByteString -> Decoder a+parse g bs = calculateOffset (loop (I.runCont g bs I.Done)) (fromIntegral $ B.length bs)+  where+    calculateOffset r !acc = case r of+        I.Done inp a -> Done inp (acc - fromIntegral (B.length inp)) a+        I.Fail inp s -> Fail inp (acc - fromIntegral (B.length inp)) s+        I.Partial k -> Partial $ \ms -> case ms of+                Nothing -> calculateOffset (k Nothing) acc+                Just i -> calculateOffset (k ms) (acc + fromIntegral (B.length i))+        I.BytesRead unused k -> calculateOffset (k $! (acc - unused)) acc++    loop r = case r of+        I.Partial k -> I.Partial $ \ms -> case ms of Just _ -> loop (k ms)+                                                     Nothing -> completeLoop (k ms)+        I.BytesRead n k -> I.BytesRead n (loop . k)+        I.Done _ _ -> r+        I.Fail _ _ -> r++    completeLoop r = case r of+        I.Partial k -> completeLoop (k Nothing)+        I.BytesRead n k -> I.BytesRead n (completeLoop . k)+        I.Fail _ _ -> r+        I.Done _ _ -> r++--------------------------------------------------------------------------------++-- | Convert a 'Decoder' value to a 'Maybe' value. A 'Partial' result+-- is treated as failure.+--+-- /Since: 0.2.3.0/+--+maybeDecoder :: Decoder r -> Maybe r+maybeDecoder (Done _ _ r) = Just r+maybeDecoder _            = Nothing+{-# INLINE maybeDecoder #-}++-- | Convert a 'Decoder' value to an 'Either' value. A 'Partial'+-- result is treated as failure.+--+-- /Since: 0.2.3.0/+--+eitherDecoder :: Decoder r -> Either String r+eitherDecoder (Done _ _ r)   = Right r+eitherDecoder (Fail _ _ msg) = Left msg+eitherDecoder _              = Left "Decoder: incomplete input"+{-# INLINE eitherDecoder #-}++--------------------------------------------------------------------------------++-- | Name the parser, in case failure occurs.+(<?>) :: Get a -> String -> Get a+(<?>) = flip label+infix 0 <?>+{-# INLINE (<?>) #-}++-- | Match only if all input has been consumed.+endOfInput :: Get ()+endOfInput = do+    e <- isEmpty+    unless e (fail "endOfInput")+{-# INLINE endOfInput #-}++-- | @option x p@ tries to apply action @p@. If @p@ fails without+-- consuming input, it returns the value @x@, otherwise the value+-- returned by @p@.+--+-- > priority  = option 0 (digitToInt <$> digit)+option :: Alternative f => a -> f a -> f a+option x p = p <|> pure x+{-# SPECIALIZE option :: a -> Get a -> Get a #-}++-- | Combine two alternatives.+eitherP :: (Alternative f) => f a -> f b -> f (Either a b)+eitherP a b = (Left <$> a) <|> (Right <$> b)+{-# INLINE eitherP #-}++-- | Return both the result of a parse and the portion of the input+-- that was consumed while it was being parsed.+match :: Get a -> Get (B.ByteString, a)+match p = do+    pos1 <- bytesRead+    (x, pos2) <- lookAhead $ (,) <$> p <*> bytesRead+    (,) <$> (getByteString . fromIntegral) (pos2 - pos1) <*> pure x+{-# INLINE match #-}++-- | A version of 'liftM2' that is strict in the result of its first+-- action.+liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c+liftM2' f a b = do+  !x <- a+  y <- b+  return (f x y)+{-# INLINE liftM2' #-}++-- | @many' p@ applies the action @p@ /zero/ or more times. Returns a+-- list of the returned values of @p@. The value returned by @p@ is+-- forced to WHNF.+--+-- >  word  = many' letter+many' :: (MonadPlus m) => m a -> m [a]+many' p = many_p+  where many_p = some_p `mplus` return []+        some_p = liftM2' (:) p many_p+{-# INLINE many' #-}++-- | @some' p@ applies the action @p@ /one/ or more times. Returns a+-- list of the returned values of @p@. The value returned by @p@ is+-- forced to WHNF.+--+-- >  word  = some' letter+some' :: (MonadPlus m) => m a -> m [a]+some' p = liftM2' (:) p (many' p)+{-# INLINE some' #-}++-- | @sepBy p sep@ applies /zero/ or more occurrences of @p@, separated+-- by @sep@. Returns a list of the values returned by @p@.+--+-- > commaSep p  = p `sepBy` (char ',')+sepBy :: Alternative f => f a -> f s -> f [a]+sepBy p s = liftA2 (:) p ((s *> sepBy1 p s) <|> pure []) <|> pure []+{-# SPECIALIZE sepBy :: Get a -> Get s -> Get [a] #-}++-- | @sepBy' p sep@ applies /zero/ or more occurrences of @p@, separated+-- by @sep@. Returns a list of the values returned by @p@. The value+-- returned by @p@ is forced to WHNF.+--+-- > commaSep p  = p `sepBy'` (char ',')+sepBy' :: (MonadPlus m) => m a -> m s -> m [a]+sepBy' p s = go `mplus` return []+  where go = liftM2' (:) p ((s >> sepBy1' p s) `mplus` return [])+{-# SPECIALIZE sepBy' :: Get a -> Get s -> Get [a] #-}++-- | @sepBy1 p sep@ applies /one/ or more occurrences of @p@, separated+-- by @sep@. Returns a list of the values returned by @p@.+--+-- > commaSep p  = p `sepBy1` (char ',')+sepBy1 :: Alternative f => f a -> f s -> f [a]+sepBy1 p s = go+    where go = liftA2 (:) p ((s *> go) <|> pure [])+{-# SPECIALIZE sepBy1 :: Get a -> Get s -> Get [a] #-}++-- | @sepBy1' p sep@ applies /one/ or more occurrences of @p@, separated+-- by @sep@. Returns a list of the values returned by @p@. The value+-- returned by @p@ is forced to WHNF.+--+-- > commaSep p  = p `sepBy1'` (char ',')+sepBy1' :: (MonadPlus m) => m a -> m s -> m [a]+sepBy1' p s = go+    where go = liftM2' (:) p ((s >> go) `mplus` return [])+{-# SPECIALIZE sepBy1' :: Get a -> Get s -> Get [a] #-}++-- | @manyTill p end@ applies action @p@ /zero/ or more times until+-- action @end@ succeeds, and returns the list of values returned by+-- @p@.  This can be used to scan comments:+--+-- >  simpleComment   = string "<!--" *> manyTill anyChar (string "-->")+--+-- (Note the overlapping parsers @anyChar@ and @string \"-->\"@.+-- While this will work, it is not very efficient, as it will cause a+-- lot of backtracking.)+manyTill :: Alternative f => f a -> f b -> f [a]+manyTill p end = go+    where go = (end *> pure []) <|> liftA2 (:) p go+{-# SPECIALIZE manyTill :: Get a -> Get b -> Get [a] #-}++-- | @manyTill' p end@ applies action @p@ /zero/ or more times until+-- action @end@ succeeds, and returns the list of values returned by+-- @p@.  This can be used to scan comments:+--+-- >  simpleComment   = string "<!--" *> manyTill' anyChar (string "-->")+--+-- (Note the overlapping parsers @anyChar@ and @string \"-->\"@.+-- While this will work, it is not very efficient, as it will cause a+-- lot of backtracking.)+--+-- The value returned by @p@ is forced to WHNF.+manyTill' :: (MonadPlus m) => m a -> m b -> m [a]+manyTill' p end = go+    where go = (end >> return []) `mplus` liftM2' (:) p go+{-# SPECIALIZE manyTill' :: Get a -> Get b -> Get [a] #-}++-- | Skip zero or more instances of an action.+skipMany :: Alternative f => f a -> f ()+skipMany p = go+    where go = (p *> go) <|> pure ()+{-# SPECIALIZE skipMany :: Get a -> Get () #-}++-- | Skip one or more instances of an action.+skipMany1 :: Alternative f => f a -> f ()+skipMany1 p = p *> skipMany p+{-# SPECIALIZE skipMany1 :: Get a -> Get () #-}
+ src/Data/Binary/Parser/Char8.hs view
@@ -0,0 +1,167 @@+-- |+-- Module      :  Data.Binary.Parser.Char8+-- Copyright   :  Bryan O'Sullivan 2007-2015, Winterland 2016+-- License     :  BSD3+--+-- Maintainer  :  drkoster@qq.com+-- Stability   :  experimental+-- Portability :  unknown+--+-- This module is intended for parsing text that is+-- represented using an 8-bit character set, e.g. ASCII or+-- ISO-8859-15.  It /does not/ make any attempt to deal with character+-- encodings, multibyte characters, or wide characters.  In+-- particular, all attempts to use characters above code point U+00FF+-- will give wrong answers.+--+-- Code points below U+0100 are simply translated to and from their+-- numeric values, so e.g. the code point U+00A4 becomes the byte+-- @0xA4@ (which is the Euro symbol in ISO-8859-15, but the generic+-- currency sign in ISO-8859-1).  Haskell 'Char' values above U+00FF+-- are truncated, so e.g. U+1D6B7 is truncated to the byte @0xB7@.++module Data.Binary.Parser.Char8 where++import           Control.Applicative+import qualified Data.Binary.Get          as BG+import           Data.Binary.Get.Internal+import qualified Data.Binary.Parser.Word8 as W+import           Data.ByteString          (ByteString)+import qualified Data.ByteString          as B+import           Data.ByteString.Internal (c2w, w2c)+import qualified Data.ByteString.Unsafe   as B+import           Prelude                  hiding (takeWhile)++--------------------------------------------------------------------------------++-- | Match any char, to perform lookahead. Returns 'Nothing' if end of+-- input has been reached. Does not consume any input.+--+peekMaybe :: Get (Maybe Char)+peekMaybe = fmap w2c <$> W.peekMaybe+{-# INLINE peekMaybe #-}++-- | Match any char, to perform lookahead.  Does not consume any+-- input, but will fail if end of input has been reached.+--+peek :: Get Char+peek = w2c <$> W.peek+{-# INLINE peek #-}++-- | The parser @satisfy p@ succeeds for any char for which the+-- predicate @p@ returns 'True'. Returns the char that is actually+-- parsed.+--+satisfy :: (Char -> Bool) -> Get Char+satisfy p = w2c <$> W.satisfy (p . w2c)+{-# INLINE satisfy #-}++-- | The parser @satisfyWith f p@ transforms a char, and succeeds if+-- the predicate @p@ returns 'True' on the transformed value. The+-- parser returns the transformed char that was parsed.+--+satisfyWith :: (Char -> a) -> (a -> Bool) -> Get a+satisfyWith f = W.satisfyWith (f . w2c)+{-# INLINE satisfyWith #-}++-- | Match a specific character.+--+char :: Char -> Get ()+char c = W.word8 (c2w c)+{-# INLINE char #-}++-- | Match any character.+--+anyChar :: Get Char+anyChar = w2c <$> BG.getWord8+{-# INLINE anyChar #-}++-- | The parser @skipChar p@ succeeds for any char for which the predicate @p@ returns 'True'.+--+skipChar :: (Char -> Bool) -> Get ()+skipChar p = W.skipWord8 (p . w2c)+{-# INLINE skipChar #-}++--------------------------------------------------------------------------------++-- | Consume input as long as the predicate returns 'False' or reach the end of input,+-- and return the consumed input.+--+takeTill :: (Char -> Bool) -> Get ByteString+takeTill p = W.takeTill (p . w2c)+{-# INLINE takeTill #-}++-- | Consume input as long as the predicate returns 'True' or reach the end of input,+-- and return the consumed input.+--+takeWhile :: (Char -> Bool) -> Get ByteString+takeWhile p = W.takeWhile (p . w2c)+{-# INLINE takeWhile #-}++-- Similar to 'takeWhile', but requires the predicate to succeed on at least one char+-- of input: it will fail if the predicate never returns 'True' or reach the end of input+--+takeWhile1 :: (Char -> Bool) -> Get ByteString+takeWhile1 p = W.takeWhile1 (p . w2c)+{-# INLINE takeWhile1 #-}++-- | Skip past input for as long as the predicate returns 'True'.+--+skipWhile :: (Char -> Bool) -> Get ()+skipWhile p = W.skipWhile (p . w2c)+{-# INLINE skipWhile #-}++-- | Satisfy a literal string but ignoring case.+--+stringCI :: ByteString -> Get ByteString+stringCI bs = do+    let l = B.length bs+    ensureN l+    bs' <- B.unsafeTake l <$> get+    if B.map toLower bs' == B.map toLower bs+    then put (B.unsafeDrop l bs') >> return bs'+    else fail "stringCI"+  where+    toLower w | w >= 65 && w <= 90 = w + 32+              | otherwise          = w+{-# INLINE stringCI #-}++--------------------------------------------------------------------------------++-- | Fast predicate for matching ASCII space characters.+--+-- /Note/: This predicate only gives correct answers for the ASCII+-- encoding.  For instance, it does not recognise U+00A0 (non-breaking+-- space) as a space character, even though it is a valid ISO-8859-15+-- byte. For a Unicode-aware and only slightly slower predicate,+-- use 'Data.Char.isSpace'+--+isSpace :: Char -> Bool+isSpace c = (c == ' ') || ('\t' <= c && c <= '\r')+{-# INLINE isSpace #-}++-- | Decimal digit predicate.+--+isDigit :: Char -> Bool+isDigit c = c >= '0' && c <= '9'+{-# INLINE isDigit #-}++-- | Hex digit predicate.+--+isHexDigit :: Char -> Bool+isHexDigit c = (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F')+{-# INLINE isHexDigit #-}++-- | A predicate that matches either a space @\' \'@ or horizontal tab+-- @\'\\t\'@ character.+--+isHorizontalSpace :: Char -> Bool+isHorizontalSpace c = c == ' ' || c == '\t'+{-# INLINE isHorizontalSpace #-}++-- | A predicate that matches either a carriage return @\'\\r\'@ or+-- newline @\'\\n\'@ character.+--+isEndOfLine :: Char -> Bool+isEndOfLine c = c == '\r' || c == '\n'+{-# INLINE isEndOfLine #-}
+ src/Data/Binary/Parser/Numeric.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE CPP          #-}+-- |+-- Module      :  Data.Binary.Parser.Numeric+-- Copyright   :  Bryan O'Sullivan 2007-2015, Winterland 2016+-- License     :  BSD3+--+-- Maintainer  :  drkoster@qq.com+-- Stability   :  experimental+-- Portability :  unknown+--+-- Simple, efficient combinator parsing for numeric values.+--+module Data.Binary.Parser.Numeric where++import           Control.Applicative+import           Control.Monad+import           Data.Binary.Get.Internal+import qualified Data.Binary.Parser.Word8     as W+import           Data.Bits+import qualified Data.ByteString              as B+import qualified Data.ByteString.Lex.Integral as LexInt+import           Data.Int+import           Data.Scientific              (Scientific (..))+import qualified Data.Scientific              as Sci+import           Data.Word++#define  MINUS    45+#define  PLUS     43+#define  LITTLE_E 101+#define  BIG_E    69+#define  DOT      46++-- | Parse and decode an unsigned hexadecimal number.  The hex digits+-- @\'a\'@ through @\'f\'@ may be upper or lower case.+--+-- This parser does not accept a leading @\"0x\"@ string.+--+hexadecimal :: (Integral a, Bits a) => Get a+hexadecimal = do+    bs <- W.takeWhile1 W.isHexDigit+    case LexInt.readHexadecimal bs of+        Just (x, _) -> return x+        Nothing -> fail "hexadecimal: impossible"+{-# SPECIALISE hexadecimal :: Get Int #-}+{-# SPECIALISE hexadecimal :: Get Int8 #-}+{-# SPECIALISE hexadecimal :: Get Int16 #-}+{-# SPECIALISE hexadecimal :: Get Int32 #-}+{-# SPECIALISE hexadecimal :: Get Int64 #-}+{-# SPECIALISE hexadecimal :: Get Integer #-}+{-# SPECIALISE hexadecimal :: Get Word #-}+{-# SPECIALISE hexadecimal :: Get Word8 #-}+{-# SPECIALISE hexadecimal :: Get Word16 #-}+{-# SPECIALISE hexadecimal :: Get Word32 #-}+{-# SPECIALISE hexadecimal :: Get Word64 #-}++-- | Parse and decode an unsigned decimal number.+--+decimal :: Integral a => Get a+decimal = do+    bs <- W.takeWhile1 W.isDigit+    return $! LexInt.readDecimal_ bs+{-# SPECIALISE decimal :: Get Int #-}+{-# SPECIALISE decimal :: Get Int8 #-}+{-# SPECIALISE decimal :: Get Int16 #-}+{-# SPECIALISE decimal :: Get Int32 #-}+{-# SPECIALISE decimal :: Get Int64 #-}+{-# SPECIALISE decimal :: Get Integer #-}+{-# SPECIALISE decimal :: Get Word #-}+{-# SPECIALISE decimal :: Get Word8 #-}+{-# SPECIALISE decimal :: Get Word16 #-}+{-# SPECIALISE decimal :: Get Word32 #-}+{-# SPECIALISE decimal :: Get Word64 #-}++-- | Parse a number with an optional leading @\'+\'@ or @\'-\'@ sign+-- character.+--+signed :: Num a => Get a -> Get a+signed p = do+    w <- W.peek+    if w == MINUS+        then W.skipN 1 >> negate <$> p+        else if w == PLUS then W.skipN 1 >> p else p+{-# SPECIALISE signed :: Get Int -> Get Int #-}+{-# SPECIALISE signed :: Get Int8 -> Get Int8 #-}+{-# SPECIALISE signed :: Get Int16 -> Get Int16 #-}+{-# SPECIALISE signed :: Get Int32 -> Get Int32 #-}+{-# SPECIALISE signed :: Get Int64 -> Get Int64 #-}+{-# SPECIALISE signed :: Get Integer -> Get Integer #-}++-- | Parse a rational number.+--+-- The syntax accepted by this parser is the same as for 'double'.+--+-- /Note/: this parser is not safe for use with inputs from untrusted+-- sources.  An input with a suitably large exponent such as+-- @"1e1000000000"@ will cause a huge 'Integer' to be allocated,+-- resulting in what is effectively a denial-of-service attack.+--+-- In most cases, it is better to use 'double' or 'scientific'+-- instead.+--+rational :: Fractional a => Get a+rational = scientifically realToFrac+{-# SPECIALIZE rational :: Get Double #-}+{-# SPECIALIZE rational :: Get Float #-}+{-# SPECIALIZE rational :: Get Rational #-}+{-# SPECIALIZE rational :: Get Scientific #-}++-- | Parse a rational number and round to 'Double'.+--+-- This parser accepts an optional leading sign character, followed by+-- at least one decimal digit.  The syntax similar to that accepted by+-- the 'read' function, with the exception that a trailing @\'.\'@ or+-- @\'e\'@ /not/ followed by a number is not consumed.+--+-- Examples with behaviour identical to 'read':+--+-- >parseOnly double "3"     == Right ("",1,3.0)+-- >parseOnly double "3.1"   == Right ("",3,3.1)+-- >parseOnly double "3e4"   == Right ("",3,30000.0)+-- >parseOnly double "3.1e4" == Right ("",5,31000.0)+--+-- >parseOnly double ".3"    == Left (".3",0,"takeWhile1")+-- >parseOnly double "e3"    == Left ("e3",0,"takeWhile1")+--+-- Examples of differences from 'read':+--+-- >parseOnly double "3.foo" == Right (".foo",1,3.0)+-- >parseOnly double "3e"    == Right ("e",1,3.0)+--+-- This function does not accept string representations of \"NaN\" or+-- \"Infinity\".+--+double :: Get Double+double = scientifically Sci.toRealFloat++-- | Parse a scientific number.+--+-- The syntax accepted by this parser is the same as for 'double'.+--+scientific :: Get Scientific+scientific = scientifically id++-- | Parse a scientific number and convert to result using a user supply function.+--+-- The syntax accepted by this parser is the same as for 'double'.+--+scientifically :: (Scientific -> a) -> Get a+scientifically h = do+    sign <- W.peek+    when (sign == PLUS || sign == MINUS) (W.skipN 1)+    intPart <- decimal+    sci <- (do fracDigits <- W.word8 DOT >> W.takeWhile1 W.isDigit+               let e' = B.length fracDigits+                   intPart' = intPart * (10 ^ e')+                   fracPart = LexInt.readDecimal_ fracDigits+               parseE (intPart' + fracPart) e'+           ) <|> (parseE intPart 0)++    if sign /= MINUS then return $! h sci else return $! h (negate sci)+  where+    parseE c e =+        (do _ <- W.satisfy (\w -> w ==  LITTLE_E || w == BIG_E)+            (Sci.scientific c . (subtract e) <$> signed decimal)) <|> return (Sci.scientific c (negate e))+    {-# INLINE parseE #-}+{-# INLINE scientifically #-}
+ src/Data/Binary/Parser/Word8.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP          #-}+-- |+-- Module      :  Data.Binary.Parser.Word8+-- Copyright   :  Bryan O'Sullivan 2007-2015, Winterland 2016+-- License     :  BSD3+--+-- Maintainer  :  drkoster@qq.com+-- Stability   :  experimental+-- Portability :  unknown+--+-- Simple, efficient combinator parsing for 'B.ByteString' strings.+--+module Data.Binary.Parser.Word8 where++import           Control.Applicative+import           Control.Monad+import           Data.Binary.Get+import           Data.Binary.Get.Internal+import           Data.ByteString          (ByteString)+import qualified Data.ByteString          as B+import           Data.ByteString.Internal (ByteString (..))+import qualified Data.ByteString.Unsafe   as B+import           Data.Word+import           Foreign.ForeignPtr       (withForeignPtr)+import           Foreign.Ptr              (minusPtr, plusPtr)+import qualified Foreign.Storable         as Storable (Storable (peek))+import           Prelude                  hiding (takeWhile)++#if MIN_VERSION_bytestring(0,10,6)+import           Data.ByteString.Internal (accursedUnutterablePerformIO)+#else+import           Data.ByteString.Internal (inlinePerformIO)++{-# INLINE accursedUnutterablePerformIO #-}+-- | You must be truly desperate to come to me for help.+accursedUnutterablePerformIO :: IO a -> a+accursedUnutterablePerformIO = inlinePerformIO+#endif++--------------------------------------------------------------------------------++-- | Match any byte, to perform lookahead. Returns 'Nothing' if end of+-- input has been reached. Does not consume any input.+--+peekMaybe :: Get (Maybe Word8)+peekMaybe = do+    e <- isEmpty+    if e then return Nothing+         else Just <$> peek+{-# INLINE peekMaybe #-}++-- | Match any byte, to perform lookahead.  Does not consume any+-- input, but will fail if end of input has been reached.+--+peek :: Get Word8+peek = do+    ensureN 1+    bs <- get+    return (B.unsafeHead bs)+{-# INLINE peek #-}++-- | The parser @satisfy p@ succeeds for any byte for which the+-- predicate @p@ returns 'True'. Returns the byte that is actually+-- parsed.+--+-- >digit = satisfy isDigit+-- >    where isDigit w = w >= 48 && w <= 57+--+satisfy :: (Word8 -> Bool) -> Get Word8+satisfy p = do+    ensureN 1+    bs <- get+    let w = B.unsafeHead bs+    if p w then put (B.unsafeTail bs) >> return w+           else fail "satisfy"+{-# INLINE satisfy #-}++-- | The parser @satisfyWith f p@ transforms a byte, and succeeds if+-- the predicate @p@ returns 'True' on the transformed value. The+-- parser returns the transformed byte that was parsed.+--+satisfyWith :: (Word8 -> a) -> (a -> Bool) -> Get a+satisfyWith f p = do+    ensureN 1+    bs <- get+    let w = B.unsafeHead bs+        r = f w+    if p r then put (B.unsafeTail bs) >> return r+           else fail "satisfyWith"+{-# INLINE satisfyWith #-}++-- | Match a specific byte.+--+word8 :: Word8 -> Get ()+word8 c = do+    ensureN 1+    bs <- get+    let w = B.unsafeHead bs+    if c == w then put (B.unsafeTail bs)+              else fail "word8"+{-# INLINE word8 #-}++-- | Match any byte.+--+anyWord8 :: Get Word8+anyWord8 = getWord8+{-# INLINE anyWord8 #-}++-- | The parser @skipWord8 p@ succeeds for any byte for which the predicate @p@ returns 'True'.+--+skipWord8 :: (Word8 -> Bool) -> Get ()+skipWord8 p = do+    ensureN 1+    bs <- get+    let w = B.unsafeHead bs+    if p w then put (B.unsafeTail bs)+              else fail "skip"+{-# INLINE skipWord8 #-}++--------------------------------------------------------------------------------++-- | This is a faster version of 'skip' for small N (smaller than chunk size).+--+skipN :: Int -> Get ()+skipN n = do+    bs <- get+    let l = B.length bs+    if l > n then put (B.unsafeDrop n bs)+             else skip n+{-# INLINE skipN #-}++-- | Consume input as long as the predicate returns 'False' or reach the end of input,+-- and return the consumed input.+--+takeTill :: (Word8 -> Bool) -> Get ByteString+takeTill p = do+    bs <- get+    let (want, rest) = B.break p bs+    put rest+    if B.null rest then B.concat . reverse <$> go [want] else return want+  where+    go acc = do+        e <- isEmpty -- isEmpty will draw input here+        if e+        then return acc+        else do+            bs <- get+            let (want, rest) = B.break p bs+                acc' = want : acc+            put rest+            if B.null rest then go acc' else return acc'+{-# INLINE takeTill #-}++-- | Consume input as long as the predicate returns 'True' or reach the end of input,+-- and return the consumed input.+--+takeWhile :: (Word8 -> Bool) -> Get ByteString+takeWhile p = do+    bs <- get+    let (want, rest) = B.span p bs+    put rest+    if B.null rest then B.concat . reverse <$> go [want] else return want+  where+    go acc = do+        e <- isEmpty+        if e+        then return acc+        else do+            bs <- get+            let (want, rest) = B.span p bs+                acc' = want : acc+            put rest+            if B.null rest then go acc' else return acc'+{-# INLINE takeWhile #-}++-- | Similar to 'takeWhile', but requires the predicate to succeed on at least one byte+-- of input: it will fail if the predicate never returns 'True' or reach the end of input+--+takeWhile1 :: (Word8 -> Bool) -> Get ByteString+takeWhile1 p = do+    bs <- takeWhile p+    if B.null bs then fail "takeWhile1" else return bs+{-# INLINE takeWhile1 #-}++-- | Skip past input for as long as the predicate returns 'True'.+--+skipWhile :: (Word8 -> Bool) -> Get ()+skipWhile p = do+    bs <- get+    let rest = B.dropWhile p bs+    put rest+    when (B.null rest) go+  where+    go = do+        e <- isEmpty+        unless e $ do+            bs <- get+            let rest = B.dropWhile p bs+            put rest+            when (B.null rest) go+{-# INLINE skipWhile #-}++-- | Skip over white space using 'isSpace'.+--+skipSpaces :: Get ()+skipSpaces = skipWhile isSpace+{-# INLINE skipSpaces #-}++-- | @string s@ parses a sequence of bytes that identically match @s@.+--+string :: ByteString -> Get ()+string bs = do+    let l = B.length bs+    bs' <- get+    if l <= B.length bs'              -- current chunk is enough+    then if B.unsafeTake l bs' == bs+        then put (B.unsafeDrop l bs')+        else fail "string"+    else do+        ensureN l+        bs'' <- get+        if B.unsafeTake l bs'' == bs+        then put (B.unsafeDrop l bs'')+        else fail "string"+{-# INLINE string #-}++-- | A stateful scanner.  The predicate consumes and transforms a+-- state argument, and each transformed state is passed to successive+-- invocations of the predicate on each byte of the input until one+-- returns 'Nothing' or the input ends.+--+-- This parser does not fail.  It will return an empty string if the+-- predicate returns 'Nothing' on the first byte of input.+--+scan :: s -> (s -> Word8 -> Maybe s) -> Get ByteString+scan s0 consume = withInputChunks s0 consume' B.concat (return . B.concat)+  where+    consume' s1 (PS fp off len) = accursedUnutterablePerformIO $+        withForeignPtr fp $ \ptr0 -> do+            let start = ptr0 `plusPtr` off+                end   = start `plusPtr` len+            go fp off start end start s1+    go fp off start end ptr !s+        | ptr < end = do+            w <- Storable.peek ptr+            case consume s w of+                Just s' -> go fp off start end (ptr `plusPtr` 1) s'+                _       -> do+                    let !len1 = ptr `minusPtr` start+                        !off2 = off + len1+                        !len2 = end `minusPtr` ptr+                    return (Right (PS fp off len1, PS fp off2 len2))+        | otherwise = return (Left s)+{-# INLINE scan #-}++-- | Similar to 'scan', but working on 'ByteString' chunks, The predicate+-- consumes a 'ByteString' chunk and transforms a state argument,+-- and each transformed state is passed to successive invocations of+-- the predicate on each chunk of the input until one chunk got splited to+-- @Right (ByteString, ByteString)@ or the input ends.+--+scanChunks :: s -> Consume s -> Get ByteString+scanChunks s consume = withInputChunks s consume B.concat (return . B.concat)+{-# INLINE scanChunks #-}++--------------------------------------------------------------------------------++-- | Fast 'Word8' predicate for matching ASCII space characters+--+-- >isSpace w = w == 32 || w - 9 <= 4+--+isSpace :: Word8 -> Bool+isSpace w = w == 32 || w - 9 <= 4+{-# INLINE isSpace #-}++-- | Decimal digit predicate.+--+isDigit :: Word8 -> Bool+isDigit w = w - 48 <= 9+{-# INLINE isDigit #-}++-- | Hex digit predicate.+--+isHexDigit :: Word8 -> Bool+isHexDigit w = (w >= 48 && w <= 57) || (w >= 97 && w <= 102) || (w >= 65 && w <= 70)+{-# INLINE isHexDigit #-}++-- | A predicate that matches either a space @\' \'@ or horizontal tab+-- @\'\\t\'@ character.+--+isHorizontalSpace :: Word8 -> Bool+isHorizontalSpace w = w == 32 || w == 9+{-# INLINE isHorizontalSpace #-}++-- | A predicate that matches either a carriage return @\'\\r\'@ or+-- newline @\'\\n\'@ character.+--+isEndOfLine :: Word8 -> Bool+isEndOfLine w = w == 13 || w == 10+{-# INLINE isEndOfLine #-}++--------------------------------------------------------------------------------++-- | Match either a single newline byte @\'\\n\'@, or a carriage+-- return followed by a newline byte @\"\\r\\n\"@.+endOfLine :: Get ()+endOfLine = do+    w <- getWord8+    case w of+        10 -> return ()+        13 -> word8 10+        _  -> fail "endOfLine"+{-# INLINE endOfLine #-}
+ src/Data/Int/Int24.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE MagicHash         #-}+{-# LANGUAGE NoImplicitPrelude #-}++#if !MIN_VERSION_base(4,8,0)+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Int.Int24+-- Copyright   :  (c) The University of Glasgow 1997-2002+-- License     :  see src/Data/LICENSE+--+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- The 24 bit integral datatype, 'Int24'.+--+-----------------------------------------------------------------------------++module Data.Int.Int24 (+  -- * Int24 type+  Int24(..)+  -- * Internal helper+  , narrow24Int#+  ) where++import           Data.Bits+import           Data.Data+import           Data.Maybe+import           Data.Word.Word24+import           Foreign.Storable++import           GHC.Arr+import           GHC.Base+import           GHC.Enum+import           GHC.Int.Compat+import           GHC.Integer (smallInteger, integerToInt)+import           GHC.Num hiding (integerToInt)+import           GHC.Ptr+import           GHC.Read+import           GHC.Real+import           GHC.Show+import           GHC.Word.Compat++import           Control.DeepSeq++#if !MIN_VERSION_base(4,8,0)+import           Data.Typeable+#endif++------------------------------------------------------------------------++-- Int24 is represented in the same way as Int. Operations may assume+-- and must ensure that it holds only values from its logical range.++-- | 24-bit signed integer type+data Int24 = I24# Int# deriving (Eq, Ord)++#if !MIN_VERSION_base(4,8,0)+deriving instance Typeable Int24+#endif++instance NFData Int24  where rnf !_ = ()++int24Type :: DataType+int24Type = mkIntType "Data.Word.Int24.Int24"++instance Data Int24 where+  toConstr x = mkIntegralConstr int24Type x+  gunfold _ z c = case constrRep c of+                    (IntConstr x) -> z (fromIntegral x)+                    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c+                                 ++ " is not of type Int24."+  dataTypeOf _ = int24Type++-- the narrowings are primops in GHC; I don't have that luxury.+-- if the 24th bit (from right) is on, the value is negative, so+-- fill the uppermost bits with 1s.  Otherwise clear them to 0s.+narrow24Int# :: Int# -> Int#+narrow24Int# x# = if isTrue# ((x'# `and#` mask#) `eqWord#` mask#)+    then word2Int# (x'# `or#`  int2Word# m1#)+    else word2Int# (x'# `and#` int2Word# m2#)+  where+    !x'#   = int2Word# x#+    !mask# = int2Word# 0x00800000#+    !(I# m1#) = -8388608+    !(I# m2#) = 16777215++instance Show Int24 where+    showsPrec p x = showsPrec p (fromIntegral x :: Int)++instance Num Int24 where+    (I24# x#) + (I24# y#)  = I24# (narrow24Int# (x# +# y#))+    (I24# x#) - (I24# y#)  = I24# (narrow24Int# (x# -# y#))+    (I24# x#) * (I24# y#)  = I24# (narrow24Int# (x# *# y#))+    negate (I24# x#)       = I24# (narrow24Int# (negateInt# x#))+    abs x | x >= 0         = x+          | otherwise      = negate x+    signum x | x > 0       = 1+    signum 0               = 0+    signum _               = -1+    fromInteger i          = I24# (narrow24Int# (integerToInt i))++instance Real Int24 where+    toRational x = toInteger x % 1++instance Enum Int24 where+    succ x+        | x /= maxBound = x + 1+        | otherwise     = succError "Int24"+    pred x+        | x /= minBound = x - 1+        | otherwise     = predError "Int24"+    toEnum i@(I# i#)+        | i >= fromIntegral (minBound::Int24) && i <= fromIntegral (maxBound::Int24)+                        = I24# i#+        | otherwise     = toEnumError "Int24" i (minBound::Int24, maxBound::Int24)+    fromEnum (I24# x#)  = I# x#+    enumFrom            = boundedEnumFrom+    enumFromThen        = boundedEnumFromThen++instance Integral Int24 where+    quot    x@(I24# x#) y@(I24# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I24# (narrow24Int# (x# `quotInt#` y#))+    rem     x@(I24# x#) y@(I24# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I24# (narrow24Int# (x# `remInt#` y#))+    div     x@(I24# x#) y@(I24# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I24# (narrow24Int# (x# `divInt#` y#))+    mod     x@(I24# x#) y@(I24# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = I24# (narrow24Int# (x# `modInt#` y#))+    quotRem x@(I24# x#) y@(I24# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I24# (narrow24Int# (x# `quotInt#` y#)),+                                        I24# (narrow24Int# (x# `remInt#` y#)))+    divMod  x@(I24# x#) y@(I24# y#)+        | y == 0                     = divZeroError+        | x == minBound && y == (-1) = overflowError+        | otherwise                  = (I24# (narrow24Int# (x# `divInt#` y#)),+                                        I24# (narrow24Int# (x# `modInt#` y#)))+    toInteger (I24# x#)              = smallInteger x#++instance Bounded Int24 where+    minBound = -0x800000+    maxBound =  0x7FFFFF++instance Ix Int24 where+    range (m,n)         = [m..n]+    unsafeIndex (m,_) i = fromIntegral i - fromIntegral m+    inRange (m,n) i     = m <= i && i <= n++instance Read Int24 where+    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]++instance Bits Int24 where+    {-# INLINE shift #-}+    {-# INLINE bit #-}+    {-# INLINE testBit #-}++    (I24# x#) .&.   (I24# y#)  = I24# (word2Int# (int2Word# x# `and#` int2Word# y#))+    (I24# x#) .|.   (I24# y#)  = I24# (word2Int# (int2Word# x# `or#`  int2Word# y#))+    (I24# x#) `xor` (I24# y#)  = I24# (word2Int# (int2Word# x# `xor#` int2Word# y#))+    complement (I24# x#)       = I24# (word2Int# (not# (int2Word# x#)))+    (I24# x#) `shift` (I# i#)+        | isTrue# (i# >=# 0#)  = I24# (narrow24Int# (x# `iShiftL#` i#))+        | otherwise            = I24# (x# `iShiftRA#` negateInt# i#)+    (I24# x#) `shiftL`       (I# i#) = I24# (narrow24Int# (x# `iShiftL#` i#))+    (I24# x#) `unsafeShiftL` (I# i#) = I24# (narrow24Int# (x# `uncheckedIShiftL#` i#))+    (I24# x#) `shiftR`       (I# i#) = I24# (x# `iShiftRA#` i#)+    (I24# x#) `unsafeShiftR` (I# i#) = I24# (x# `uncheckedIShiftRA#` i#)+    (I24# x#) `rotate` i+        | isTrue# (i'# ==# 0#) = I24# x#+        | otherwise = I24# (narrow24Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`+                                         (x'# `uncheckedShiftRL#` (24# -# i'#)))))+      where+        !x'# = narrow24Word# (int2Word# x#)+        !(I# i'#) = i `mod` 24+    bitSizeMaybe i             = Just (finiteBitSize i)+    bitSize                    = finiteBitSize+    isSigned _                 = True+    popCount (I24# x#)         = I# (word2Int# (popCnt24# (int2Word# x#)))+    bit                        = bitDefault+    testBit                    = testBitDefault++instance FiniteBits Int24 where+    finiteBitSize _ = 24+#if MIN_VERSION_base(4,8,0)+    countLeadingZeros  (I24# x#) = I# (word2Int# (clz24# (int2Word# x#)))+    countTrailingZeros (I24# x#) = I# (word2Int# (ctz24# (int2Word# x#)))+#endif++{-# RULES+"fromIntegral/Word8->Int24"   fromIntegral = \(W8# x#) -> I24# (word2Int# x#)+"fromIntegral/Word16->Int24"  fromIntegral = \(W16# x#) -> I24# (word2Int# x#)+"fromIntegral/Int8->Int24"    fromIntegral = \(I8# x#) -> I24# x#+"fromIntegral/Int16->Int24"   fromIntegral = \(I16# x#) -> I24# x#+"fromIntegral/Int24->Int24"   fromIntegral = id :: Int24 -> Int24+"fromIntegral/a->Int24"       fromIntegral = \x -> case fromIntegral x of I# x# -> I24# (narrow24Int# x#)+"fromIntegral/Int24->a"       fromIntegral = \(I24# x#) -> fromIntegral (I# x#)+  #-}++{-# RULES+"properFraction/Float->(Int24,Float)"+    properFraction = \x ->+                      case properFraction x of {+                        (n, y) -> ((fromIntegral :: Int -> Int24) n, y :: Float) }+"truncate/Float->Int24"+    truncate = (fromIntegral :: Int -> Int24) . (truncate :: Float -> Int)+"floor/Float->Int24"+    floor    = (fromIntegral :: Int -> Int24) . (floor :: Float -> Int)+"ceiling/Float->Int24"+    ceiling  = (fromIntegral :: Int -> Int24) . (ceiling :: Float -> Int)+"round/Float->Int24"+    round    = (fromIntegral :: Int -> Int24) . (round  :: Float -> Int)+  #-}++{-# RULES+"properFraction/Double->(Int24,Double)"+    properFraction = \x ->+                      case properFraction x of {+                        (n, y) -> ((fromIntegral :: Int -> Int24) n, y :: Double) }+"truncate/Double->Int24"+    truncate = (fromIntegral :: Int -> Int24) . (truncate :: Double -> Int)+"floor/Double->Int24"+    floor    = (fromIntegral :: Int -> Int24) . (floor :: Double -> Int)+"ceiling/Double->Int24"+    ceiling  = (fromIntegral :: Int -> Int24) . (ceiling :: Double -> Int)+"round/Double->Int24"+    round    = (fromIntegral :: Int -> Int24) . (round  :: Double -> Int)+  #-}++instance Storable Int24 where+  sizeOf _ = 3+  alignment _ = 3+  peek p = fmap fromIntegral $ peek ((castPtr p) :: Ptr Word24)+  poke p v = poke (castPtr p :: Ptr Word24) (fromIntegral v)
+ src/Data/Word/Word24.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE MagicHash         #-}+{-# LANGUAGE NoImplicitPrelude #-}++#if !MIN_VERSION_base(4,8,0)+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+#endif++-- |+-- Module      : Data.Word.Word24+-- License     : see  src/Data/LICENSE+-- Stability   : experimental+-- Portability : non-portable (GHC Extensions)++-- Provide a 24-bit unsigned integral type: 'Word24', analagous to Word8,+-- Word16, etc.+--++module Data.Word.Word24 (+  -- * Word24 type+    Word24(..)+  , byteSwap24+  , byteSwap24#+  -- * Internal helpers+  , narrow24Word#+#if MIN_VERSION_base(4,8,0)+  , clz24#+  , ctz24#+#endif+  , popCnt24#+  )++where++import           Data.Bits+import           Data.Data+import           Data.Maybe+import           Foreign.Storable++import           GHC.Arr+import           GHC.Base+import           GHC.Enum+import           GHC.Num hiding (integerToWord)+import           GHC.Ptr+import           GHC.Read+import           GHC.Real+import           GHC.Show+import           GHC.Word.Compat+import           GHC.Integer (smallInteger, integerToWord)++import           Control.DeepSeq++#if !MIN_VERSION_base(4,8,0)+import           Data.Typeable+#endif++------------------------------------------------------------------------++-- Word24 is represented in the same way as Word.  Operations may assume and+-- must ensure that it holds only values in its logical range.++-- | 24-bit unsigned integer type+--+data Word24 = W24# Word# deriving (Eq, Ord)++#if !MIN_VERSION_base(4,8,0)+deriving instance Typeable Word24+#endif++instance NFData Word24 where rnf !_ = ()++word24Type :: DataType+word24Type = mkIntType "Data.Word.Word24.Word24"++instance Data Word24 where+  toConstr x = mkIntegralConstr word24Type x+  gunfold _ z c = case constrRep c of+                    (IntConstr x) -> z (fromIntegral x)+                    _ -> error $ "Data.Data.gunfold: Constructor " ++ show c+                                 ++ " is not of type Word24."+  dataTypeOf _ = word24Type++-- | narrowings represented as primop 'and#' in GHC.+narrow24Word# :: Word# -> Word#+narrow24Word# = and# 0xFFFFFF##++#if MIN_VERSION_base(4,8,0)+-- | count leading zeros+--+clz24# :: Word# -> Word#+clz24# w# = clz32# (narrow24Word# w#) `minusWord#` 8##++-- | count trailing zeros+--+ctz24# :: Word# -> Word#+ctz24# w# = ctz# (w# `or#` 0x1000000##)+#endif++-- | the number of set bits+--+popCnt24# :: Word# -> Word#+popCnt24# w# = popCnt# (narrow24Word# w#)++instance Show Word24 where+  showsPrec p x = showsPrec p (fromIntegral x :: Int)++instance Num Word24 where+  (W24# x#) + (W24# y#) = W24# (narrow24Word# (x# `plusWord#` y#))+  (W24# x#) - (W24# y#) = W24# (narrow24Word# (x# `minusWord#` y#))+  (W24# x#) * (W24# y#) = W24# (narrow24Word# (x# `timesWord#` y#))+  negate (W24# x#)      = W24# (narrow24Word# (int2Word# (negateInt# (word2Int# x#))))+  abs x                 = x+  signum 0              = 0+  signum _              = 1+  fromInteger i         = W24# (narrow24Word# (integerToWord i))++instance Real Word24 where+  toRational x = toInteger x % 1++instance Enum Word24 where+  succ x+    | x /= maxBound  = x + 1+    | otherwise      = succError "Word24"+  pred x+    | x /= minBound  = x - 1+    | otherwise      = predError "Word24"+  toEnum i@(I# i#)+    | i >= 0 && i <= fromIntegral (maxBound :: Word24)+                     = W24# (int2Word# i#)+    | otherwise      = toEnumError "Word24" i (minBound::Word24, maxBound::Word24)+  fromEnum (W24# x#) = I# (word2Int# x#)+  enumFrom           = boundedEnumFrom+  enumFromThen       = boundedEnumFromThen++instance Integral Word24 where+  quot (W24# x#) y@(W24# y#)+    | y /= 0                 = W24# (x# `quotWord#` y#)+    | otherwise              = divZeroError+  rem (W24# x#) y@(W24# y#)+    | y /= 0                 = W24# (x# `remWord#` y#)+    | otherwise              = divZeroError+  div (W24# x#) y@(W24# y#)+    | y /= 0                 = W24# (x# `quotWord#` y#)+    | otherwise              = divZeroError+  mod (W24# x#) y@(W24# y#)+    | y /= 0                 = W24# (x# `remWord#` y#)+    | otherwise              = divZeroError+  quotRem (W24# x#) y@(W24# y#)+    | y /= 0                 = (W24# (x# `quotWord#` y#), W24# (x# `remWord#` y#))+    | otherwise              = divZeroError+  divMod (W24# x#) y@(W24# y#)+    | y /= 0                 = (W24# (x# `quotWord#` y#), W24# (x# `remWord#` y#))+    | otherwise              = divZeroError+  toInteger (W24# x#)        = smallInteger (word2Int# x#)++instance Bounded Word24 where+  minBound = 0+  maxBound = 0xFFFFFF++instance Ix Word24 where+  range (m,n)         = [m..n]+  unsafeIndex (m,_) i = fromIntegral (i - m)+  inRange (m,n) i     = m <= i && i <= n++instance Read Word24 where+  readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]++instance Bits Word24 where+    {-# INLINE shift #-}+    {-# INLINE bit #-}+    {-# INLINE testBit #-}++    (W24# x#) .&.   (W24# y#)  = W24# (x# `and#` y#)+    (W24# x#) .|.   (W24# y#)  = W24# (x# `or#`  y#)+    (W24# x#) `xor` (W24# y#)  = W24# (x# `xor#` y#)+    complement (W24# x#)       = W24# (x# `xor#` mb#) where !(W24# mb#) = maxBound+    (W24# x#) `shift` (I# i#)+        | isTrue# (i# >=# 0#)  = W24# (narrow24Word# (x# `shiftL#` i#))+        | otherwise            = W24# (x# `shiftRL#` negateInt# i#)+    (W24# x#) `shiftL` (I# i#)       = W24# (narrow24Word# (x# `shiftL#` i#))+    (W24# x#) `unsafeShiftL` (I# i#) =+        W24# (narrow24Word# (x# `uncheckedShiftL#` i#))+    (W24# x#) `shiftR`       (I# i#) = W24# (x# `shiftRL#` i#)+    (W24# x#) `unsafeShiftR` (I# i#) = W24# (x# `uncheckedShiftRL#` i#)+    (W24# x#) `rotate`       i+        | isTrue# (i'# ==# 0#) = W24# x#+        | otherwise  = W24# (narrow24Word# ((x# `uncheckedShiftL#` i'#) `or#`+                                            (x# `uncheckedShiftRL#` (24# -# i'#))))+      where+        !(I# i'#) = i `mod` 24+    bitSizeMaybe i            = Just (finiteBitSize i)+    bitSize                   = finiteBitSize+    isSigned _                = False+    popCount (W24# x#)        = I# (word2Int# (popCnt24# x#))+    bit                       = bitDefault+    testBit                   = testBitDefault++instance FiniteBits Word24 where+    finiteBitSize _ = 24+#if MIN_VERSION_base(4,8,0)+    countLeadingZeros  (W24# x#) = I# (word2Int# (clz24# x#))+    countTrailingZeros (W24# x#) = I# (word2Int# (ctz24# x#))+#endif++-- | Swap bytes in 'Word24'.+--+byteSwap24 :: Word24 -> Word24+byteSwap24 (W24# w#) = W24# (byteSwap24# w#)++byteSwap24# :: Word# -> Word#+byteSwap24# w# = let byte0 = uncheckedShiftL# (and# w# 0x0000ff##) 16#+                     byte1 = and# w# 0x00ff00##+                     byte2 = uncheckedShiftRL# (and# w# 0xff0000##) 16#+                 in byte0 `or#` byte1 `or#` byte2++{-# RULES+"fromIntegral/Word8->Word24"    fromIntegral = \(W8# x#) -> W24# x#+"fromIntegral/Word16->Word24"   fromIntegral = \(W16# x#) -> W24# x#+"fromIntegral/Word24->Word24"   fromIntegral = id :: Word24 -> Word24+"fromIntegral/Word24->Integer"  fromIntegral = toInteger :: Word24 -> Integer+"fromIntegral/a->Word24"        fromIntegral = \x -> case fromIntegral x of W# x# -> W24# (narrow24Word# x#)+"fromIntegral/Word24->a"        fromIntegral = \(W24# x#) -> fromIntegral (W# x#)+  #-}++{-# RULES+"properFraction/Float->(Word24,Float)"+    properFraction = \x ->+                      case properFraction x of {+                        (n, y) -> ((fromIntegral :: Int -> Word24) n, y :: Float) }+"truncate/Float->Word24"+    truncate = (fromIntegral :: Int -> Word24) . (truncate :: Float -> Int)+"floor/Float->Word24"+    floor    = (fromIntegral :: Int -> Word24) . (floor :: Float -> Int)+"ceiling/Float->Word24"+    ceiling  = (fromIntegral :: Int -> Word24) . (ceiling :: Float -> Int)+"round/Float->Word24"+    round    = (fromIntegral :: Int -> Word24) . (round  :: Float -> Int)+  #-}++{-# RULES+"properFraction/Double->(Word24,Double)"+    properFraction = \x ->+                      case properFraction x of {+                        (n, y) -> ((fromIntegral :: Int -> Word24) n, y :: Double) }+"truncate/Double->Word24"+    truncate = (fromIntegral :: Int -> Word24) . (truncate :: Double -> Int)+"floor/Double->Word24"+    floor    = (fromIntegral :: Int -> Word24) . (floor :: Double -> Int)+"ceiling/Double->Word24"+    ceiling  = (fromIntegral :: Int -> Word24) . (ceiling :: Double -> Int)+"round/Double->Word24"+    round    = (fromIntegral :: Int -> Word24) . (round  :: Double -> Int)+  #-}++readWord24OffPtr :: Ptr Word24 -> IO Word24+readWord24OffPtr p = do+  let p' = castPtr p :: Ptr Word8+  w1 <- peekElemOff p' 0+  w2 <- peekElemOff p' 1+  w3 <- peekElemOff p' 2+  let w1' = (fromIntegral :: (Word8 -> Word24)) w1+      w2' = (fromIntegral :: (Word8 -> Word24)) w2+      w3' = (fromIntegral :: (Word8 -> Word24)) w3+      w = w1' .|. (w2' `shiftL` 8) .|. (w3' `shiftL` 16)+  return w++writeWord24ToPtr :: Ptr Word24 -> Word24 -> IO ()+writeWord24ToPtr p v = do+    let w1 = fromIntegral (v .&. 0x0000FF) :: Word8+        w2 = fromIntegral ((v .&. 0x00FF00) `shiftR` 8) :: Word8+        w3 = fromIntegral ((v .&. 0xFF0000) `shiftR` 16) :: Word8+    pokeByteOff p 0 w1+    pokeByteOff p 1 w2+    pokeByteOff p 2 w3++instance Storable Word24 where+  sizeOf _    = 3+  alignment _ = 3+  peek        = readWord24OffPtr+  poke        = writeWord24ToPtr+
+ src/Database/MySQL/Base.hs view
@@ -0,0 +1,326 @@+{-|+Module      : Database.MySQL.Base+Description : Prelude of mysql-haskell+Copyright   : (c) Winterland, 2016+License     : BSD+Maintainer  : drkoster@qq.com+Stability   : experimental+Portability : PORTABLE++This module provide common MySQL operations,++NOTEs on 'Exception's: This package use 'Exception' to deal with unexpected situations,+but you shouldn't try to catch them if you don't have a recovery plan,+for example: there's no meaning to catch a 'ERRException' during authentication unless you want to try different passwords.+By using this library you will meet:++    * 'NetworkException':  underline network is broken.+    * 'UnconsumedResultSet':  you should consume previous resultset before sending new command.+    * 'ERRException':  you receive a 'ERR' packet when you shouldn't.+    * 'UnexpectedPacket':  you receive a unexpected packet when you shouldn't.+    * 'DecodePacketException': there's a packet we can't decode.+    * 'WrongParamsCount': you're giving wrong number of params to 'renderParams'.++Both 'UnexpectedPacket' and 'DecodePacketException' may indicate a bug of this library rather your code, so please report!++-}+module Database.MySQL.Base+    ( -- * Setting up and control connection+      MySQLConn+    , ConnectInfo(..)+    , defaultConnectInfo+    , defaultConnectInfoMB4+    , connect+    , connectDetail+    , close+    , ping+      -- * Direct query+    , execute+    , executeMany+    , executeMany_+    , execute_+    , query_+    , queryVector_+    , query+    , queryVector+      -- * Prepared query statement+    , prepareStmt+    , prepareStmtDetail+    , executeStmt+    , queryStmt+    , queryStmtVector+    , closeStmt+    , resetStmt+      -- * Helpers+    , withTransaction+    , QueryParam(..)+    , Param (..)+    , Query(..)+    , renderParams+    , command+    , Stream.skipToEof+      -- * Exceptions+    , NetworkException(..)+    , UnconsumedResultSet(..)+    , ERRException(..)+    , UnexpectedPacket(..)+    , DecodePacketException(..)+    , WrongParamsCount(..)+      -- * MySQL protocol+    , module  Database.MySQL.Protocol.Auth+    , module  Database.MySQL.Protocol.Command+    , module  Database.MySQL.Protocol.ColumnDef+    , module  Database.MySQL.Protocol.Packet+    , module  Database.MySQL.Protocol.MySQLValue+    ) where++import           Control.Applicative+import           Control.Exception                  (mask, onException, throwIO)+import           Control.Monad+import qualified Data.ByteString.Lazy               as L+import           Data.IORef                         (writeIORef)+import           Database.MySQL.Connection+import           Database.MySQL.Protocol.Auth+import           Database.MySQL.Protocol.ColumnDef+import           Database.MySQL.Protocol.Command+import           Database.MySQL.Protocol.MySQLValue+import           Database.MySQL.Protocol.Packet++import           Database.MySQL.Query+import           System.IO.Streams                  (InputStream)+import qualified System.IO.Streams                  as Stream+import qualified Data.Vector                        as V++--------------------------------------------------------------------------------++-- | Execute a MySQL query with parameters which don't return a result-set.+--+-- The query may contain placeholders @?@, for filling up parameters, the parameters+-- will be escaped before get filled into the query, please DO NOT enable @NO_BACKSLASH_ESCAPES@,+-- and you should consider using prepared statement if this's not an one shot query.+--+execute :: QueryParam p => MySQLConn -> Query -> [p] -> IO OK+execute conn qry params = execute_ conn (renderParams qry params)++{-# SPECIALIZE execute :: MySQLConn -> Query -> [MySQLValue] -> IO OK #-}+{-# SPECIALIZE execute :: MySQLConn -> Query -> [Param]      -> IO OK #-}++-- | Execute a multi-row query which don't return result-set.+--+-- Leverage MySQL's multi-statement support to do batch insert\/update\/delete,+-- you may want to use 'withTransaction' to make sure it's atomic, and+-- use @sum . map okAffectedRows@ to get all affected rows count.+--+-- @since 0.2.0.0+--+executeMany :: QueryParam p => MySQLConn -> Query -> [[p]] -> IO [OK]+executeMany conn@(MySQLConn is os _ _) qry paramsList = do+    guardUnconsumed conn+    let qry' = L.intercalate ";" $ map (fromQuery . renderParams qry) paramsList+    writeCommand (COM_QUERY qry') os+    mapM (\ _ -> waitCommandReply is) paramsList++{-# SPECIALIZE executeMany :: MySQLConn -> Query -> [[MySQLValue]] -> IO [OK] #-}+{-# SPECIALIZE executeMany :: MySQLConn -> Query -> [[Param]]      -> IO [OK] #-}++-- | Execute multiple querys (without param) which don't return result-set.+--+-- This's useful when your want to execute multiple SQLs without params, e.g. from a+-- SQL dump, or a table migration plan.+--+-- @since 0.8.4.0+--+executeMany_ :: MySQLConn -> Query -> IO [OK]+executeMany_ conn@(MySQLConn is os _ _) qry = do+    guardUnconsumed conn+    writeCommand (COM_QUERY (fromQuery qry)) os+    waitCommandReplys is++-- | Execute a MySQL query which don't return a result-set.+--+execute_ :: MySQLConn -> Query -> IO OK+execute_ conn (Query qry) = command conn (COM_QUERY qry)++-- | Execute a MySQL query which return a result-set with parameters.+--+-- Note that you must fully consumed the result-set before start a new query on+-- the same 'MySQLConn', or an 'UnconsumedResultSet' will be thrown.+-- if you want to skip the result-set, use 'Stream.skipToEof'.+--+query :: QueryParam p => MySQLConn -> Query -> [p] -> IO ([ColumnDef], InputStream [MySQLValue])+query conn qry params = query_ conn (renderParams qry params)++{-# SPECIALIZE query :: MySQLConn -> Query -> [MySQLValue] -> IO ([ColumnDef], InputStream [MySQLValue]) #-}+{-# SPECIALIZE query :: MySQLConn -> Query -> [Param]      -> IO ([ColumnDef], InputStream [MySQLValue]) #-}++-- | 'V.Vector' version of 'query'.+--+-- @since 0.5.1.0+--+queryVector :: QueryParam p => MySQLConn -> Query -> [p] -> IO (V.Vector ColumnDef, InputStream (V.Vector MySQLValue))+queryVector conn qry params = queryVector_ conn (renderParams qry params)++{-# SPECIALIZE queryVector :: MySQLConn -> Query -> [MySQLValue] -> IO (V.Vector ColumnDef, InputStream (V.Vector MySQLValue)) #-}+{-# SPECIALIZE queryVector :: MySQLConn -> Query -> [Param]      -> IO (V.Vector ColumnDef, InputStream (V.Vector MySQLValue)) #-}++-- | Execute a MySQL query which return a result-set.+--+query_ :: MySQLConn -> Query -> IO ([ColumnDef], InputStream [MySQLValue])+query_ conn@(MySQLConn is os _ consumed) (Query qry) = do+    guardUnconsumed conn+    writeCommand (COM_QUERY qry) os+    p <- readPacket is+    if isERR p+    then decodeFromPacket p >>= throwIO . ERRException+    else do+        len <- getFromPacket getLenEncInt p+        fields <- replicateM len $ (decodeFromPacket <=< readPacket) is+        _ <- readPacket is -- eof packet, we don't verify this though+        writeIORef consumed False+        rows <- Stream.makeInputStream $ do+            q <- readPacket is+            if  | isEOF q  -> writeIORef consumed True >> return Nothing+                | isERR q  -> decodeFromPacket q >>= throwIO . ERRException+                | otherwise -> Just <$> getFromPacket (getTextRow fields) q+        return (fields, rows)++-- | 'V.Vector' version of 'query_'.+--+-- @since 0.5.1.0+--+queryVector_ :: MySQLConn -> Query -> IO (V.Vector ColumnDef, InputStream (V.Vector MySQLValue))+queryVector_ conn@(MySQLConn is os _ consumed) (Query qry) = do+    guardUnconsumed conn+    writeCommand (COM_QUERY qry) os+    p <- readPacket is+    if isERR p+    then decodeFromPacket p >>= throwIO . ERRException+    else do+        len <- getFromPacket getLenEncInt p+        fields <- V.replicateM len $ (decodeFromPacket <=< readPacket) is+        _ <- readPacket is -- eof packet, we don't verify this though+        writeIORef consumed False+        rows <- Stream.makeInputStream $ do+            q <- readPacket is+            if  | isEOF q  -> writeIORef consumed True >> return Nothing+                | isERR q  -> decodeFromPacket q >>= throwIO . ERRException+                | otherwise -> Just <$> getFromPacket (getTextRowVector fields) q+        return (fields, rows)++-- | Ask MySQL to prepare a query statement.+--+prepareStmt :: MySQLConn -> Query -> IO StmtID+prepareStmt conn@(MySQLConn is os _ _) (Query stmt) = do+    guardUnconsumed conn+    writeCommand (COM_STMT_PREPARE stmt) os+    p <- readPacket is+    if isERR p+    then decodeFromPacket p >>= throwIO . ERRException+    else do+        StmtPrepareOK stid colCnt paramCnt _ <- getFromPacket getStmtPrepareOK p+        _ <- replicateM_ paramCnt (readPacket is)+        _ <- unless (paramCnt == 0) (void (readPacket is))  -- EOF+        _ <- replicateM_ colCnt (readPacket is)+        _ <- unless (colCnt == 0) (void (readPacket is))  -- EOF+        return stid++-- | Ask MySQL to prepare a query statement.+--+-- All details from @COM_STMT_PREPARE@ Response are returned: the 'StmtPrepareOK' packet,+-- params's 'ColumnDef', result's 'ColumnDef'.+--+prepareStmtDetail :: MySQLConn -> Query -> IO (StmtPrepareOK, [ColumnDef], [ColumnDef])+prepareStmtDetail conn@(MySQLConn is os _ _) (Query stmt) = do+    guardUnconsumed conn+    writeCommand (COM_STMT_PREPARE stmt) os+    p <- readPacket is+    if isERR p+    then decodeFromPacket p >>= throwIO . ERRException+    else do+        sOK@(StmtPrepareOK _ colCnt paramCnt _) <- getFromPacket getStmtPrepareOK p+        pdefs <- replicateM paramCnt ((decodeFromPacket <=< readPacket) is)+        _ <- unless (paramCnt == 0) (void (readPacket is))  -- EOF+        cdefs <- replicateM colCnt ((decodeFromPacket <=< readPacket) is)+        _ <- unless (colCnt == 0) (void (readPacket is))  -- EOF+        return (sOK, pdefs, cdefs)++-- | Ask MySQL to closed a query statement.+--+closeStmt :: MySQLConn -> StmtID -> IO ()+closeStmt (MySQLConn _ os _ _) stid = do+    writeCommand (COM_STMT_CLOSE stid) os++-- | Ask MySQL to reset a query statement, all previous resultset will be cleared.+--+resetStmt :: MySQLConn -> StmtID -> IO ()+resetStmt (MySQLConn is os _ consumed) stid = do+    writeCommand (COM_STMT_RESET stid) os  -- previous result-set may still be unconsumed+    p <- readPacket is+    if isERR p+    then decodeFromPacket p >>= throwIO . ERRException+    else writeIORef consumed True++-- | Execute prepared query statement with parameters, expecting no resultset.+--+executeStmt :: MySQLConn -> StmtID -> [MySQLValue] -> IO OK+executeStmt conn stid params =+  command conn (COM_STMT_EXECUTE stid params (makeNullMap params))++-- | Execute prepared query statement with parameters, expecting resultset.+--+-- Rules about 'UnconsumedResultSet' applied here too.+--+queryStmt :: MySQLConn -> StmtID -> [MySQLValue] -> IO ([ColumnDef], InputStream [MySQLValue])+queryStmt conn@(MySQLConn is os _ consumed) stid params = do+    guardUnconsumed conn+    writeCommand (COM_STMT_EXECUTE stid params (makeNullMap params)) os+    p <- readPacket is+    if isERR p+    then decodeFromPacket p >>= throwIO . ERRException+    else do+        len <- getFromPacket getLenEncInt p+        fields <- replicateM len $ (decodeFromPacket <=< readPacket) is+        _ <- readPacket is -- eof packet, we don't verify this though+        writeIORef consumed False+        rows <- Stream.makeInputStream $ do+            q <- readPacket is+            if  | isOK  q  -> Just <$> getFromPacket (getBinaryRow fields len) q+                | isEOF q  -> writeIORef consumed True >> return Nothing+                | isERR q  -> decodeFromPacket q >>= throwIO . ERRException+                | otherwise -> throwIO (UnexpectedPacket q)+        return (fields, rows)++-- | 'V.Vector' version of 'queryStmt'+--+-- @since 0.5.1.0+--+queryStmtVector :: MySQLConn -> StmtID -> [MySQLValue] -> IO (V.Vector ColumnDef, InputStream (V.Vector MySQLValue))+queryStmtVector conn@(MySQLConn is os _ consumed) stid params = do+    guardUnconsumed conn+    writeCommand (COM_STMT_EXECUTE stid params (makeNullMap params)) os+    p <- readPacket is+    if isERR p+    then decodeFromPacket p >>= throwIO . ERRException+    else do+        len <- getFromPacket getLenEncInt p+        fields <- V.replicateM len $ (decodeFromPacket <=< readPacket) is+        _ <- readPacket is -- eof packet, we don't verify this though+        writeIORef consumed False+        rows <- Stream.makeInputStream $ do+            q <- readPacket is+            if  | isOK  q  -> Just <$> getFromPacket (getBinaryRowVector fields len) q+                | isEOF q  -> writeIORef consumed True >> return Nothing+                | isERR q  -> decodeFromPacket q >>= throwIO . ERRException+                | otherwise -> throwIO (UnexpectedPacket q)+        return (fields, rows)++-- | Run querys inside a transaction, querys will be rolled back if exception arise.+--+-- @since 0.2.0.0+--+withTransaction :: MySQLConn -> IO a -> IO a+withTransaction conn procedure = mask $ \restore -> do+  _ <- execute_ conn "BEGIN"+  r <- restore procedure `onException` (execute_ conn "ROLLBACK")+  _ <- execute_ conn "COMMIT"+  pure r
+ src/Database/MySQL/BinLog.hs view
@@ -0,0 +1,214 @@+{-|+Module      : Database.MySQL.BinLog+Description : Binary protocol toolkit+Copyright   : (c) Winterland, 2016+License     : BSD+Maintainer  : drkoster@qq.com+Stability   : experimental+Portability : PORTABLE++This module provide tools for binlog listening and row based binlog decoding.+-}++module Database.MySQL.BinLog+    ( -- * binlog utilities+      SlaveID+    , BinLogTracker(..)+    , registerPesudoSlave+    , dumpBinLog+    , RowBinLogEvent(..)+    , decodeRowBinLogEvent+    -- * helpers+    , getLastBinLogTracker+    , isCheckSumEnabled+    , isSemiSyncEnabled+    -- * re-export+    , module Database.MySQL.BinLogProtocol.BinLogEvent+    , module Database.MySQL.BinLogProtocol.BinLogValue+    , module Database.MySQL.BinLogProtocol.BinLogMeta+    ) where++import           Control.Applicative+import           Control.Exception                         (throwIO)+import           Control.Monad+import           Data.Binary.Put+import           Data.ByteString                           (ByteString)+import           Data.IORef                                (IORef, newIORef,+                                                            readIORef,+                                                            writeIORef)+import           Data.Text.Encoding                        (encodeUtf8)+import           Data.Word+import           Database.MySQL.Base+import           Database.MySQL.BinLogProtocol.BinLogEvent+import           Database.MySQL.BinLogProtocol.BinLogMeta+import           Database.MySQL.BinLogProtocol.BinLogValue+import           Database.MySQL.Connection+import           GHC.Generics                              (Generic)+import           System.IO.Streams                         (InputStream)+import qualified System.IO.Streams                         as Stream++type SlaveID = Word32++-- | binlog filename and position to start listening.+--+data BinLogTracker = BinLogTracker+    { btFileName :: {-# UNPACK #-} !ByteString+    , btNextPos  :: {-# UNPACK #-} !Word32+    } deriving (Show, Eq, Generic)++-- | Register a pesudo slave to master, although MySQL document suggests you should call this+-- before calling 'dumpBinLog', but it seems it's not really necessary.+--+registerPesudoSlave :: MySQLConn -> SlaveID -> IO OK+registerPesudoSlave conn sid = command conn (COM_REGISTER_SLAVE sid "" "" "" 0 0 0)++-- | Setup binlog listening on given connection, during listening+-- the connection CAN NOT be used to do query, or an 'UnconsumedResultSet' will be thrown.+--+dumpBinLog :: MySQLConn               -- ^ connection to be listened+           -> SlaveID                 -- ^ a number for our pesudo slave.+           -> BinLogTracker           -- ^ binlog position+           -> Bool                    -- ^ if master support semi-ack, do we want to enable it?+                                      -- if master doesn't support, this parameter will be ignored.+           -> IO (FormatDescription, IORef ByteString, InputStream BinLogPacket)+                -- ^ 'FormatDescription', 'IORef' contains current binlog filename, 'BinLogPacket' stream.+dumpBinLog conn@(MySQLConn is wp _ consumed) sid (BinLogTracker initfn initpos) wantAck = do+    guardUnconsumed conn+    checksum <- isCheckSumEnabled conn+    when checksum $ void $ execute_ conn "SET @master_binlog_checksum = @@global.binlog_checksum"+    semiAck  <- isSemiSyncEnabled conn+    let needAck = semiAck && wantAck+    when needAck . void $ execute_ conn "SET @rpl_semi_sync_slave = 1"+    writeCommand (COM_BINLOG_DUMP initpos 0x00 sid initfn) wp+    writeIORef consumed False++    rp <- skipToPacketT (readBinLogPacket checksum needAck is) BINLOG_ROTATE_EVENT+    re <- getFromBinLogPacket getRotateEvent rp+    fref <- newIORef (rFileName re)++    p <- skipToPacketT (readBinLogPacket checksum needAck is) BINLOG_FORMAT_DESCRIPTION_EVENT+    replyAck needAck p fref wp+    fmt <- getFromBinLogPacket getFormatDescription p++    es <- Stream.makeInputStream $ do+        q <- readBinLogPacket checksum needAck is+        case q of+            Nothing   -> writeIORef consumed True >> return Nothing+            Just q' -> do when (blEventType q' == BINLOG_ROTATE_EVENT) $ do+                                e <- getFromBinLogPacket getRotateEvent q'+                                writeIORef' fref (rFileName e)+                          replyAck needAck q' fref wp+                          return q+    return (fmt, fref, es)+  where+    skipToPacketT iop typ = do+        p <- iop+        case p of+            Just p' -> do+                if blEventType p' == typ then return p' else skipToPacketT iop typ+            Nothing -> throwIO NetworkException++    replyAck needAck p fref wp' = when (needAck && blSemiAck p) $ do+        fn <- readIORef fref+        wp' (makeSemiAckPacket (blLogPos p) fn)++    makeSemiAckPacket pos fn = putToPacket 0 $ do+        putWord8 0xEF      -- semi-ack+        putWord64le pos+        putByteString fn++    readBinLogPacket checksum needAck is' = do+        p <- readPacket is'+        if  | isOK p -> Just <$> getFromPacket (getBinLogPacket checksum needAck) p+            | isEOF p -> return Nothing+            | isERR p -> decodeFromPacket p >>= throwIO . ERRException++-- | Row based binlog event type.+--+-- It's recommended to enable row query event before 'dumpBinLog', so that you can get+-- 'RowQueryEvent' in row based binlog(it's important for detect a table change for example),+-- more information please refer <http://dev.mysql.com/doc/refman/5.7/en/replication-options-binary-log.html#sysvar_binlog_rows_query_log_events sysvar_binlog_rows_query_log_events>+--+-- A 'BinLogTracker' is included so that you can roll up your own HA solutions,+-- for example, writing the tracker to zookeeper when you done with an event.+--+-- The first 'Word32' field is a timestamp present when this event is logged.+--+data RowBinLogEvent+    = RowQueryEvent  {-# UNPACK #-} !Word32 !BinLogTracker !QueryEvent'+    | RowDeleteEvent {-# UNPACK #-} !Word32 !BinLogTracker !TableMapEvent !DeleteRowsEvent+    | RowWriteEvent  {-# UNPACK #-} !Word32 !BinLogTracker !TableMapEvent !WriteRowsEvent+    | RowUpdateEvent {-# UNPACK #-} !Word32 !BinLogTracker !TableMapEvent !UpdateRowsEvent+  deriving (Show, Eq, Generic)++-- | decode row based event from 'BinLogPacket' stream.+decodeRowBinLogEvent :: (FormatDescription, IORef ByteString, InputStream BinLogPacket)+                     -> IO (InputStream RowBinLogEvent)+decodeRowBinLogEvent (fd', fref', is') = Stream.makeInputStream (loop fd' fref' is')+  where+    loop fd fref is = do+        p <- Stream.read is+        case p of+            Nothing -> return Nothing+            Just p' -> do+                let t = blEventType p'+                if  | t == BINLOG_ROWS_QUERY_EVENT -> do+                        tr <- track p' fref+                        e <- getFromBinLogPacket getQueryEvent' p'+                        pure (Just (RowQueryEvent (blTimestamp p') tr e))+                    | t == BINLOG_TABLE_MAP_EVENT -> do+                        tme <- getFromBinLogPacket (getTableMapEvent fd) p'+                        q <- Stream.read is+                        case q of+                            Nothing -> return Nothing+                            Just q' -> do+                                let u = blEventType q'+                                if  | u == BINLOG_WRITE_ROWS_EVENTv1 || u == BINLOG_WRITE_ROWS_EVENTv2 -> do+                                        tr <- track q' fref+                                        e <- getFromBinLogPacket' (getWriteRowEvent fd tme) q'+                                        pure (Just (RowWriteEvent (blTimestamp q') tr tme e))+                                    | u == BINLOG_DELETE_ROWS_EVENTv1 || u == BINLOG_DELETE_ROWS_EVENTv2 -> do+                                        tr <- track q' fref+                                        e <- getFromBinLogPacket' (getDeleteRowEvent fd tme) q'+                                        pure (Just (RowDeleteEvent (blTimestamp q') tr tme e))+                                    | u == BINLOG_UPDATE_ROWS_EVENTv1 || u == BINLOG_UPDATE_ROWS_EVENTv2 -> do+                                        tr <- track q' fref+                                        e <- getFromBinLogPacket' (getUpdateRowEvent fd tme) q'+                                        pure (Just (RowUpdateEvent (blTimestamp q') tr tme e))+                                    | otherwise -> loop fd fref is+                    | otherwise -> loop fd fref is++    track p fref = BinLogTracker <$> readIORef fref <*> (pure . fromIntegral . blLogPos) p++-- | Get latest master's binlog filename and position.+--+getLastBinLogTracker :: MySQLConn -> IO (Maybe BinLogTracker)+getLastBinLogTracker conn = do+    (_, is) <- query_ conn "SHOW MASTER STATUS"+    row <- Stream.read is+    Stream.skipToEof is+    case row of+        Just (MySQLText fn : MySQLInt64U pos : _) -> return . Just $ BinLogTracker (encodeUtf8 fn) (fromIntegral pos)+        _                                         -> return Nothing++-- | Return True if binlog_checksum = CRC32. Only for MySQL > 5.6+--+isCheckSumEnabled :: MySQLConn -> IO Bool+isCheckSumEnabled conn = do+    (_, is) <- query_ conn "SHOW GLOBAL VARIABLES LIKE 'binlog_checksum'"+    row <- Stream.read is+    Stream.skipToEof is+    case row of+        Just [_, MySQLText "CRC32"] -> return True+        _                           -> return False++-- | Return True if rpl_semi_sync_master_enabled = ON. Only for MySQL > 5.5+--+isSemiSyncEnabled :: MySQLConn -> IO Bool+isSemiSyncEnabled conn = do+    (_, is) <- query_ conn "SHOW VARIABLES LIKE 'rpl_semi_sync_master_enabled'"+    row <- Stream.read is+    Stream.skipToEof is+    case row of+        Just [_, MySQLText "ON"] -> return True+        _                        -> return False
+ src/Database/MySQL/BinLogProtocol/BinLogEvent.hs view
@@ -0,0 +1,291 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++{-|+Module      : Database.MySQL.BinLogProtocol.BinLogEvent+Description : Binlog event+Copyright   : (c) Winterland, 2016+License     : BSD+Maintainer  : drkoster@qq.com+Stability   : experimental+Portability : PORTABLE++Binlog event type+-}++module Database.MySQL.BinLogProtocol.BinLogEvent where++import           Control.Applicative+import           Control.Monad+import           Control.Monad.Loops                       (untilM)+import           Data.Binary+import           Data.Binary.Parser+import           Data.Bits+import           Data.ByteString                           (ByteString)+import qualified Data.ByteString                           as B+import qualified Data.ByteString.Lazy                      as L+import qualified Data.ByteString.Unsafe                    as B+import           Database.MySQL.BinLogProtocol.BinLogMeta+import           Database.MySQL.BinLogProtocol.BinLogValue+import           Database.MySQL.Protocol.Packet+import           Database.MySQL.Protocol.MySQLValue+import           Database.MySQL.Protocol.ColumnDef++import           Control.Exception                         (throwIO)+import           Database.MySQL.Query+import           GHC.Generics                              (Generic)++--------------------------------------------------------------------------------+-- | binlog tyoe+--+data BinLogEventType+    = BINLOG_UNKNOWN_EVENT+    | BINLOG_START_EVENT_V3+    | BINLOG_QUERY_EVENT+    | BINLOG_STOP_EVENT+    | BINLOG_ROTATE_EVENT+    | BINLOG_INTVAR_EVENT+    | BINLOG_LOAD_EVENT+    | BINLOG_SLAVE_EVENT+    | BINLOG_CREATE_FILE_EVENT+    | BINLOG_APPEND_BLOCK_EVENT+    | BINLOG_EXEC_LOAD_EVENT+    | BINLOG_DELETE_FILE_EVENT+    | BINLOG_NEW_LOAD_EVENT+    | BINLOG_RAND_EVENT+    | BINLOG_USER_VAR_EVENT+    | BINLOG_FORMAT_DESCRIPTION_EVENT+    | BINLOG_XID_EVENT+    | BINLOG_BEGIN_LOAD_QUERY_EVENT+    | BINLOG_EXECUTE_LOAD_QUERY_EVENT+    | BINLOG_TABLE_MAP_EVENT+    | BINLOG_WRITE_ROWS_EVENTv0+    | BINLOG_UPDATE_ROWS_EVENTv0+    | BINLOG_DELETE_ROWS_EVENTv0+    | BINLOG_WRITE_ROWS_EVENTv1+    | BINLOG_UPDATE_ROWS_EVENTv1+    | BINLOG_DELETE_ROWS_EVENTv1+    | BINLOG_INCIDENT_EVENT+    | BINLOG_HEARTBEAT_EVENT+    | BINLOG_IGNORABLE_EVENT+    | BINLOG_ROWS_QUERY_EVENT+    | BINLOG_WRITE_ROWS_EVENTv2+    | BINLOG_UPDATE_ROWS_EVENTv2+    | BINLOG_DELETE_ROWS_EVENTv2+    | BINLOG_GTID_EVENT+    | BINLOG_ANONYMOUS_GTID_EVENT+    | BINLOG_PREVIOUS_GTIDS_EVENT+  deriving (Show, Eq, Enum)++data BinLogPacket = BinLogPacket+    { blTimestamp :: !Word32+    , blEventType :: !BinLogEventType+    , blServerId  :: !Word32+    , blEventSize :: !Word32+    , blLogPos    :: !Word64   -- ^ for future GTID compatibility+    , blFlags     :: !Word16+    , blBody      :: !L.ByteString+    , blSemiAck   :: !Bool+    } deriving (Show, Eq)++putSemiAckResp :: Word32 -> ByteString -> Put+putSemiAckResp pos fn = put pos >> put fn++getBinLogPacket :: Bool -> Bool -> Get BinLogPacket+getBinLogPacket checksum semi = do+    _  <- getWord8     -- OK byte+    ack <- if semi+        then getWord8 >> (== 0x01) <$> getWord8+        else return False+    ts <- getWord32le+    typ <- toEnum . fromIntegral <$> getWord8+    sid <- getWord32le+    size <- getWord32le+    pos <- getWord32le+    flgs <- getWord16le+    body <- getLazyByteString (fromIntegral size - if checksum then 23 else 19)+    return (BinLogPacket ts typ sid size (fromIntegral pos) flgs body ack)++getFromBinLogPacket :: Get a -> BinLogPacket -> IO a+getFromBinLogPacket g (BinLogPacket _ _ _ _ _ _ body _ ) =+    case parseDetailLazy g body  of+        Left  (buf, offset, errmsg) -> throwIO (DecodePacketFailed buf offset errmsg)+        Right (_,   _,      r     ) -> return r++getFromBinLogPacket' :: (BinLogEventType -> Get a) -> BinLogPacket -> IO a+getFromBinLogPacket' g (BinLogPacket _ typ _ _ _ _ body _ ) =+    case parseDetailLazy (g typ) body  of+        Left  (buf, offset, errmsg) -> throwIO (DecodePacketFailed buf offset errmsg)+        Right (_,   _,      r     ) -> return r++--------------------------------------------------------------------------------++data FormatDescription = FormatDescription+    { fdVersion              :: !Word16+    , fdMySQLVersion         :: !ByteString+    , fdCreateTime           :: !Word32+    -- , eventHeaderLen :: !Word8  -- const 19+    , fdEventHeaderLenVector :: !ByteString  -- ^ a array indexed by Binlog Event Type - 1+                                             -- to extract the length of the event specific header.+    } deriving (Show, Eq, Generic)++getFormatDescription :: Get FormatDescription+getFormatDescription = FormatDescription <$> getWord16le+                                         <*> getByteString 50+                                         <*> getWord32le+                                         <*  getWord8+                                         <*> (L.toStrict <$> getRemainingLazyByteString)++eventHeaderLen :: FormatDescription -> BinLogEventType -> Word8+eventHeaderLen fd typ = B.unsafeIndex (fdEventHeaderLenVector fd) (fromEnum typ - 1)++data RotateEvent = RotateEvent+    { rPos :: !Word64, rFileName :: !ByteString } deriving (Show, Eq)++getRotateEvent :: Get RotateEvent+getRotateEvent = RotateEvent <$> getWord64le <*> getRemainingByteString++-- | This's query parser for statement based binlog's query event, it's actually+-- not used in row based binlog.+--+data QueryEvent = QueryEvent+    { qSlaveProxyId :: !Word32+    , qExecTime     :: !Word32+    , qErrCode      :: !Word16+    , qStatusVars   :: !ByteString+    , qSchemaName   :: !ByteString+    , qQuery        :: !Query+    } deriving (Show, Eq, Generic)++getQueryEvent :: Get QueryEvent+getQueryEvent = do+    pid <- getWord32le+    tim <- getWord32le+    slen <- getWord8+    ecode <- getWord16le+    vlen <- getWord16le+    svar <- getByteString (fromIntegral vlen)+    schema <- getByteString (fromIntegral slen)+    _ <- getWord8+    qry <- getRemainingLazyByteString+    return (QueryEvent pid tim ecode svar schema (Query qry))++-- | This's the query event in row based binlog.+--+data QueryEvent' = QueryEvent' { qQuery' :: !Query } deriving (Show, Eq)++getQueryEvent' :: Get QueryEvent'+getQueryEvent' = do+    _ <- getWord8+    QueryEvent' . Query <$> getRemainingLazyByteString++data TableMapEvent = TableMapEvent+    { tmTableId    :: !Word64+    , tmFlags      :: !Word16+    , tmSchemaName :: !ByteString+    , tmTableName  :: !ByteString+    , tmColumnCnt  :: !Int+    , tmColumnType :: ![FieldType]+    , tmColumnMeta :: ![BinLogMeta]+    , tmNullMap    :: !ByteString+    } deriving (Show, Eq, Generic)++getTableMapEvent :: FormatDescription -> Get TableMapEvent+getTableMapEvent fd = do+    let hlen = eventHeaderLen fd BINLOG_TABLE_MAP_EVENT+    tid <- if hlen == 6 then fromIntegral <$> getWord32le else getWord48le+    flgs <- getWord16le+    slen <- getWord8+    schema <- getByteString (fromIntegral slen)+    _ <- getWord8 -- 0x00+    tlen <- getWord8+    table <- getByteString (fromIntegral tlen)+    _ <- getWord8 -- 0x00+    cc <- getLenEncInt+    colTypBS <- getByteString cc+    let typs = map FieldType (B.unpack colTypBS)+    colMetaBS <- getLenEncBytes++    metas <- case runGetOrFail (forM typs getBinLogMeta) (L.fromStrict colMetaBS) of+        Left (_, _, errmsg) -> fail errmsg+        Right (_, _, r)     -> return r++    nullmap <- getByteString ((cc + 7) `div` 8)+    return (TableMapEvent tid flgs schema table cc typs metas nullmap)++data DeleteRowsEvent = DeleteRowsEvent+    { deleteTableId    :: !Word64+    , deleteFlags      :: !Word16+    -- , deleteExtraData   :: !RowsEventExtraData+    , deleteColumnCnt  :: !Int+    , deletePresentMap :: !BitMap+    , deleteRowData    :: ![[BinLogValue]]+    } deriving (Show, Eq, Generic)++getDeleteRowEvent :: FormatDescription -> TableMapEvent -> BinLogEventType -> Get DeleteRowsEvent+getDeleteRowEvent fd tme typ = do+    let hlen = eventHeaderLen fd typ+    tid <- if hlen == 6 then fromIntegral <$> getWord32le else getWord48le+    flgs <- getWord16le+    when (typ == BINLOG_DELETE_ROWS_EVENTv2) $ do+        extraLen <- getWord16le+        void $ getByteString (fromIntegral extraLen - 2)+    colCnt <- getLenEncInt+    let (plen, poffset) = (fromIntegral colCnt + 7) `quotRem` 8+    pmap <- getPresentMap plen poffset+    DeleteRowsEvent tid flgs colCnt pmap <$> untilM (getBinLogRow (tmColumnMeta tme) pmap) isEmpty++data WriteRowsEvent = WriteRowsEvent+    { writeTableId    :: !Word64+    , writeFlags      :: !Word16+    -- , writeExtraData   :: !RowsEventExtraData+    , writeColumnCnt  :: !Int+    , writePresentMap :: !BitMap+    , writeRowData    :: ![[BinLogValue]]+    } deriving (Show, Eq, Generic)++getWriteRowEvent :: FormatDescription -> TableMapEvent -> BinLogEventType -> Get WriteRowsEvent+getWriteRowEvent fd tme typ = do+    let hlen = eventHeaderLen fd typ+    tid <- if hlen == 6 then fromIntegral <$> getWord32le else getWord48le+    flgs <- getWord16le+    when (typ == BINLOG_WRITE_ROWS_EVENTv2) $ do+        extraLen <- getWord16le+        void $ getByteString (fromIntegral extraLen - 2)+    colCnt <- getLenEncInt+    let (plen, poffset) = (fromIntegral colCnt + 7) `quotRem` 8+    pmap <- getPresentMap plen poffset+    WriteRowsEvent tid flgs colCnt pmap <$> untilM (getBinLogRow (tmColumnMeta tme) pmap) isEmpty++data UpdateRowsEvent = UpdateRowsEvent+    { updateTableId    :: !Word64+    , updateFlags      :: !Word16+    -- , updateExtraData   :: !RowsEventExtraData+    , updateColumnCnt  :: !Int+    , updatePresentMap :: !(BitMap, BitMap)+    , updateRowData    :: ![ ([BinLogValue], [BinLogValue]) ]+    } deriving (Show, Eq, Generic)++getUpdateRowEvent :: FormatDescription -> TableMapEvent -> BinLogEventType -> Get UpdateRowsEvent+getUpdateRowEvent fd tme typ = do+    let hlen = eventHeaderLen fd typ+    tid <- if hlen == 6 then fromIntegral <$> getWord32le else getWord48le+    flgs <- getWord16le+    when (typ == BINLOG_UPDATE_ROWS_EVENTv2) $ do+        extraLen <- getWord16le+        void $ getByteString (fromIntegral extraLen - 2)+    colCnt <- getLenEncInt+    let (plen, poffset) = (fromIntegral colCnt + 7) `quotRem` 8+    pmap <- getPresentMap plen poffset+    pmap' <- getPresentMap plen poffset+    UpdateRowsEvent tid flgs colCnt (pmap, pmap') <$>+        untilM ((,) <$> getBinLogRow (tmColumnMeta tme) pmap <*> getBinLogRow (tmColumnMeta tme) pmap')+               isEmpty++getPresentMap :: Int -> Int -> Get BitMap+getPresentMap plen poffset = do+    pmap <- getByteString plen+    let pmap' = if B.null pmap+                then B.empty+                else B.init pmap `B.snoc` (B.last pmap .&. 0xFF `shiftR` (7 - poffset))+    pure (BitMap pmap')+
+ src/Database/MySQL/BinLogProtocol/BinLogMeta.hs view
@@ -0,0 +1,120 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++{-|+Module      : Database.MySQL.BinLogProtocol.BinLogMeta+Description : Binlog protocol column meta+Copyright   : (c) Winterland, 2016+License     : BSD+Maintainer  : drkoster@qq.com+Stability   : experimental+Portability : PORTABLE++This module provide column meta decoder for binlog protocol.++There're certain type won't appear in binlog event, and some types are compressed into 'mySQLTypeString'+, please take python version as a reference:  <https://github.com/noplay/python-mysql-replication>++You will not directly meet following 'FieldType' namely:++    * mySQLTypeDecimal+    * mySQLTypeNewdate+    * mySQLTypeEnum+    * mySQLTypeSet+    * mySQLTypeTinyBlob+    * mySQLTypeMediumBlOb+    * mySQLTypeLongBlob++-}++module Database.MySQL.BinLogProtocol.BinLogMeta where++import           Control.Applicative+import           Data.Binary.Get+import           Data.Bits+import           Data.Word+import           Database.MySQL.Protocol.ColumnDef++-- | An intermedia date type for decoding row-based event's values.+--+data BinLogMeta+    = BINLOG_TYPE_TINY+    | BINLOG_TYPE_SHORT+    | BINLOG_TYPE_INT24+    | BINLOG_TYPE_LONG+    | BINLOG_TYPE_LONGLONG+    | BINLOG_TYPE_FLOAT       !Word8         -- ^ size+    | BINLOG_TYPE_DOUBLE      !Word8         -- ^ size+    | BINLOG_TYPE_BIT         !Word16 !Word8 -- ^ bits, bytes+    | BINLOG_TYPE_TIMESTAMP+    | BINLOG_TYPE_DATETIME+    | BINLOG_TYPE_DATE+    | BINLOG_TYPE_TIME+    | BINLOG_TYPE_TIMESTAMP2  !Word8         -- ^ fsp+    | BINLOG_TYPE_DATETIME2   !Word8         -- ^ fsp+    | BINLOG_TYPE_TIME2       !Word8         -- ^ fsp+    | BINLOG_TYPE_YEAR+    | BINLOG_TYPE_NEWDECIMAL  !Word8 !Word8  -- ^ precision, scale+    | BINLOG_TYPE_ENUM        !Word8         -- ^ 1 or 2('Word8' or 'Word16'), enum index size+    | BINLOG_TYPE_SET         !Word16 !Word8 -- ^ bitmap bits, bytes+    | BINLOG_TYPE_BLOB        !Word8         -- ^ length size+    | BINLOG_TYPE_STRING      !Word16        -- ^ meta length(if < 256, then length is 8bit,+                                             -- if > 256 then length is 16bit)+    | BINLOG_TYPE_GEOMETRY    !Word8         -- ^ length size+  deriving (Show, Eq)++getBinLogMeta :: FieldType -> Get BinLogMeta+getBinLogMeta t+    | t == mySQLTypeTiny       = pure BINLOG_TYPE_TINY+    | t == mySQLTypeShort      = pure BINLOG_TYPE_SHORT+    | t == mySQLTypeInt24      = pure BINLOG_TYPE_INT24+    | t == mySQLTypeLong       = pure BINLOG_TYPE_LONG+    | t == mySQLTypeLongLong   = pure BINLOG_TYPE_LONGLONG+    | t == mySQLTypeFloat      = BINLOG_TYPE_FLOAT <$> getWord8+    | t == mySQLTypeDouble     = BINLOG_TYPE_DOUBLE <$> getWord8++    | t == mySQLTypeBit        = do+        byte0 <- getWord8+        byte1 <- getWord8+        let nbits = (fromIntegral byte1 `shiftL` 3) .|.  fromIntegral byte0+            nbytes = fromIntegral $ (nbits + 7) `shiftR` 3+        pure (BINLOG_TYPE_BIT nbits nbytes)++    | t == mySQLTypeTimestamp  = pure BINLOG_TYPE_TIMESTAMP+    | t == mySQLTypeDateTime   = pure BINLOG_TYPE_DATETIME+    | t == mySQLTypeDate       = pure BINLOG_TYPE_DATE+    | t == mySQLTypeTime       = pure BINLOG_TYPE_TIME+    | t == mySQLTypeTimestamp2 = BINLOG_TYPE_TIMESTAMP2 <$> getWord8+    | t == mySQLTypeDateTime2  = BINLOG_TYPE_DATETIME2 <$> getWord8+    | t == mySQLTypeTime2      = BINLOG_TYPE_TIME2 <$> getWord8+    | t == mySQLTypeYear       = pure BINLOG_TYPE_YEAR+    | t == mySQLTypeNewDecimal = BINLOG_TYPE_NEWDECIMAL <$> getWord8 <*> getWord8+    | t == mySQLTypeVarChar    = BINLOG_TYPE_STRING <$> getWord16le+    | t == mySQLTypeVarString  = BINLOG_TYPE_STRING <$> getWord16le++    | t == mySQLTypeString     = do+        byte0 <- getWord8+        byte1 <- getWord8+        -- http://bugs.mysql.com/37426+        if  byte0 > 0+        then if (byte0 .&. 0x30) /= 0x30+             then if FieldType (byte0 .|. 0x30) == mySQLTypeString+                  then let len = fromIntegral $ (byte0 .&. 0x30) `xor` 0x30+                           len' = len `shiftL` 4 .|. fromIntegral byte1+                       in pure $! BINLOG_TYPE_STRING len'+                  else let len = fromIntegral byte0 `shiftL` 8 :: Word16+                           len' = len .|. fromIntegral byte1+                       in pure $! BINLOG_TYPE_STRING len'+             else let t' = FieldType byte0+                  in if | t' == mySQLTypeSet    -> let nbits = fromIntegral byte1 `shiftL` 3+                                                       nbytes = fromIntegral $ (nbits + 7) `shiftR` 8+                                                   in pure (BINLOG_TYPE_SET nbits nbytes)+                        | t' == mySQLTypeEnum   -> pure (BINLOG_TYPE_ENUM byte1)+                        | t' == mySQLTypeString -> pure (BINLOG_TYPE_STRING (fromIntegral byte1))+                        | otherwise             -> fail $ "Database.MySQL.BinLogProtocol.BinLogMeta:\+                                                           \ impossible type inside binlog string: " ++ show t'+        else pure (BINLOG_TYPE_STRING (fromIntegral byte1))++    | t == mySQLTypeBlob       = BINLOG_TYPE_BLOB <$> getWord8+    | t == mySQLTypeGeometry   = BINLOG_TYPE_GEOMETRY <$> getWord8+    | otherwise                = fail $ "Database.MySQL.BinLogProtocol.BinLogMeta:\+                                        \ impossible type in binlog: " ++ show t
+ src/Database/MySQL/BinLogProtocol/BinLogValue.hs view
@@ -0,0 +1,325 @@+{-|+Module      : Database.MySQL.BinLogProtocol.BinLogValue+Description : Binlog protocol+Copyright   : (c) Winterland, 2016+License     : BSD+Maintainer  : drkoster@qq.com+Stability   : experimental+Portability : PORTABLE++Binlog protocol++-}++module Database.MySQL.BinLogProtocol.BinLogValue where++import           Control.Applicative+import           Data.Binary.Get+import           Data.Binary.IEEE754+import           Data.Binary.Put                          ()+import           Data.Bits+import           Data.ByteString                          (ByteString)+import qualified Data.ByteString                          as B+import qualified Data.ByteString.Unsafe                   as B+import           Data.Int+import           Data.Int.Int24+import           Data.Scientific+import           Data.Word+import           Database.MySQL.BinLogProtocol.BinLogMeta+import           Database.MySQL.Protocol.MySQLValue+import           Database.MySQL.Protocol.Packet+import           GHC.Generics                             (Generic)++-- | Data type for representing binlog values.+--+-- This data type DOES NOT try to parse binlog values into detailed haskell values,+-- because you may not want to waste performance in situations like database middleware.+--+-- Due to the lack of signedness infomation in binlog meta, we cannot distinguish,+-- for example, between unsigned tiny 255 and tiny -1, so we use int to present+-- @TINY,SHORT,INT,LONG@. If you have unsigned columns, use 'fromIntegral' to convert it+-- to word to get real unsigned value back, for example, @fromIntegral (-1 :: Int) == 255 :: Word@+--+-- For above reason, we use 'Int24' to present MySQL's @INT24@ type, you can get back the+-- unsigned value using @word24@ package's 'Word24' type.+--+-- Timestamp types('BinLogTimeStamp' and 'BinLogTimeStamp2') are values converted into UTC already,+-- see 'MySQLVaule' 's note.+--+-- There's also no infomation about charset, so we use 'ByteString' to present both text+-- and blob types, if you want to get text representation back, you have to query column charset+-- infomation, and use icu or iconv to decode. IT MAY NOT BE UTF-8.+--+-- The @SET@ and @ENUM@ values are presented by their index's value and bitmap respectively,+-- if you need get the string value back, you have to perform a 'DESC tablename' to get the+-- set or enum table.+--+data BinLogValue+    = BinLogTiny       !Int8+    | BinLogShort      !Int16+    | BinLogInt24      !Int24+    | BinLogLong       !Int32+    | BinLogLongLong   !Int64+    | BinLogFloat      !Float+    | BinLogDouble     !Double+    | BinLogBit        !Word64          -- ^ a 64bit bitmap.+    | BinLogTimeStamp  !Word32          -- ^ a utc timestamp, note 0 doesn't mean @1970-01-01 00:00:00@,+                                        -- because mysql choose 0 to present '0000-00-00 00:00:00'+    | BinLogTimeStamp2 !Word32 !Word32  -- ^ like 'BinLogTimeStamp' with an addtional microseconds field.+    | BinLogDateTime   !Word16 !Word8 !Word8 !Word8 !Word8 !Word8         -- ^ YYYY MM DD hh mm ss+    | BinLogDateTime2  !Word16 !Word8 !Word8 !Word8 !Word8 !Word8 !Word32 -- ^ YYYY MM DD hh mm ss microsecond+    | BinLogDate       !Word16 !Word8 !Word8                   -- ^ YYYY MM DD+    | BinLogTime       !Word8  !Word16 !Word8 !Word8           -- ^ sign(1= non-negative, 0= negative) hh mm ss+    | BinLogTime2      !Word8  !Word16 !Word8 !Word8 !Word32   -- ^ sign(1= non-negative, 0= negative) hh mm ss microsecond+    | BinLogYear       !Word16                                 -- ^ year value, 0 stand for '0000'+    | BinLogNewDecimal !Scientific                             -- ^ sign(1= non-negative, 0= negative) integeral part, fractional part+    | BinLogEnum       !Word16                                 -- ^ enum indexing value+    | BinLogSet        !Word64                                 -- ^ set indexing 64bit bitmap.+    | BinLogBytes      !ByteString                             -- ^ all string and blob values.+    | BinLogGeometry   !ByteString+    | BinLogNull+  deriving (Show, Eq, Generic)++--------------------------------------------------------------------------------+-- | BinLog protocol decoder+--+getBinLogField :: BinLogMeta -> Get BinLogValue+getBinLogField BINLOG_TYPE_TINY                = BinLogTiny     <$> getInt8+getBinLogField BINLOG_TYPE_SHORT               = BinLogShort    <$> getInt16le+getBinLogField BINLOG_TYPE_INT24               = BinLogInt24 . fromIntegral <$> getWord24le+getBinLogField BINLOG_TYPE_LONG                = BinLogLong     <$> getInt32le+getBinLogField BINLOG_TYPE_LONGLONG            = BinLogLongLong <$> getInt64le+getBinLogField (BINLOG_TYPE_FLOAT  _         ) = BinLogFloat <$> getFloatle+getBinLogField (BINLOG_TYPE_DOUBLE _         ) = BinLogDouble <$> getDoublele+getBinLogField (BINLOG_TYPE_BIT    _    bytes) = BinLogBit <$> getBits' bytes+getBinLogField BINLOG_TYPE_TIMESTAMP           = BinLogTimeStamp <$> getWord32le++-- A integer in @YYYYMMDD@ format, for example:+-- 99991231 stand for @9999-12-31@+getBinLogField BINLOG_TYPE_DATE = do+    i <- getWord24le+    let (i', dd) = i `quotRem` 32+        (yyyy, mm) = i' `quotRem` 16+    pure (BinLogDate (fromIntegral yyyy)+                     (fromIntegral mm)+                     (fromIntegral dd))++getBinLogField (BINLOG_TYPE_TIMESTAMP2  fsp) = do+    s <- getWord32be -- big-endian here!+    ms <- fromIntegral <$> getMicroSecond fsp+    pure (BinLogTimeStamp2 s ms)++-- A integer in @YYYYMMDDhhmmss@, for example:+-- 99991231235959 stand for @9999-12-31 23:59:59@+getBinLogField BINLOG_TYPE_DATETIME = do+    i <- getWord64le+    let (yyyy, i')   = i      `quotRem` 10000000000+        (mm, i'')    = i'     `quotRem` 100000000+        (dd, i''')   = i''    `quotRem` 1000000+        (h, i'''')   = i'''   `quotRem` 10000+        (m, s)       = i''''  `quotRem` 100+    pure (BinLogDateTime (fromIntegral yyyy)+                         (fromIntegral mm)+                         (fromIntegral dd)+                         (fromIntegral h)+                         (fromIntegral m)+                         (fromIntegral s))++-- BINLOG_TYPE_DATETIME2(big endian)+--+-- 1 bit sign (used when on disk)+-- 17 bits year * 13 + month (year 0-9999, month 0-12)+-- 5 bits day (0-31)+-- 5 bits hour (0-23)+-- 6 bits minute (0-59)+-- 6 bits second (0-59)+-- (5 bytes in total)+--+-- fractional-seconds storage (size depends on meta)+--+getBinLogField (BINLOG_TYPE_DATETIME2 fsp) = do+    iPart <- getWord40be+    let yyyymm = iPart `shiftR` 22 .&. 0x01FFFF -- 0b011111111111111111+        (yyyy, mm) = yyyymm `quotRem` 13+        yyyy' = fromIntegral yyyy+        mm' = fromIntegral mm+        dd = fromIntegral $ iPart `shiftR` 17 .&. 0x1F -- 0b00011111+        h =  fromIntegral $ iPart `shiftR` 12 .&. 0x1F -- 0b00011111+        m =  fromIntegral $ iPart `shiftR` 6 .&. 0x3F  -- 0b00111111+        s =  fromIntegral $ iPart .&. 0x3F             -- 0b00111111+    ms <- fromIntegral <$> getMicroSecond fsp+    pure (BinLogDateTime2 yyyy' mm' dd h m s ms)++-- A integer in @hhmmss@ format(can be negative), for example:+-- 8385959 stand for @838:59:59@+getBinLogField BINLOG_TYPE_TIME = do+    i <- getWord24le+    let i' =  fromIntegral i :: Int24+        sign = if i' >= 0 then 1 else 0+    let (h, i'')     = i'     `quotRem` 10000+        (m, s)       = i''    `quotRem` 100+    pure (BinLogTime sign (fromIntegral (abs h))+                          (fromIntegral (abs m))+                          (fromIntegral (abs s)))++-- BINLOG_TYPE_TIME2(big endian)+--+-- 1 bit sign  (1= non-negative, 0= negative)+-- 1 bit unused (Reserved for wider hour range, e.g. for intervals)+-- 10 bit hour (0-836)+-- 6 bit minute (0-59)+-- 6 bit second (0-59)+-- (3 bytes in total)+--+-- fractional-seconds storage (size depends on meta)+--+getBinLogField (BINLOG_TYPE_TIME2 fsp) = do+    iPart <- getWord24be+    let sign = fromIntegral $ iPart `shiftR` 23+        iPart' = if sign == 0 then 0x800000 - iPart - 1 else iPart+        h = fromIntegral (iPart' `shiftR` 12) .&. 0x03FF -- 0b0000001111111111+        m = fromIntegral (iPart' `shiftR` 6) .&. 0x3F    -- 0b00111111+        s = fromIntegral iPart' .&. 0x3F               -- 0b00111111+    ms <- abs <$> getMicroSecond fsp+    let ms' = abs (fromIntegral ms :: Int)+    pure (BinLogTime2 sign h m s (fromIntegral ms'))++getBinLogField BINLOG_TYPE_YEAR                = do+    y <- getWord8+    pure $! if y == 0 then BinLogYear 0 else BinLogYear (1900 + fromIntegral y)++-- Decimal representation in binlog seems to be as follows:+--+-- 1st bit - sign such that set == +, unset == -+-- every 4 bytes represent 9 digits in big-endian order.+--+-- 80 00 00 05 1b 38 b0 60 00 means:+--+--   0x80 - positive+--   0x00000005 - 5+--   0x1b38b060 - 456700000+--   0x00       - 0+--+-- 54567000000 / 10^{10} = 5.4567+--+-- if there're < 9 digits at first, it will be compressed into suitable length words+-- following a simple lookup table.+--+getBinLogField (BINLOG_TYPE_NEWDECIMAL precision scale) = do+    let i = fromIntegral (precision - scale)+        (ucI, cI) = i `quotRem` digitsPerInteger+        (ucF, cF) = scale `quotRem` digitsPerInteger+        ucISize = fromIntegral (ucI `shiftL` 2)+        ucFSize = fromIntegral (ucF `shiftL` 2)+        cISize = fromIntegral (sizeTable `B.unsafeIndex` fromIntegral cI)+        cFSize = fromIntegral (sizeTable `B.unsafeIndex` fromIntegral cF)+        len = ucISize + cISize + ucFSize + cFSize++    buf <- getByteString (fromIntegral len)++    let fb = buf `B.unsafeIndex` 0+        sign = if fb .&. 0x80 == 0x80 then 1 else 0 :: Word8+        buf' = (fb `xor` 0x80) `B.cons` B.tail buf+        buf'' = if sign == 1 then buf'+                            else B.map (xor 0xFF) buf'++        iPart = fromIntegral (getCompressed cISize (B.unsafeTake cISize buf'')) * (blockSize ^ ucI)+              + getUncompressed ucI (B.unsafeDrop cISize buf'')++    let buf''' = B.unsafeDrop (ucISize + cISize) buf''++        fPart = getUncompressed ucF (B.unsafeTake ucFSize buf''') * (10 ^ cF)+              + fromIntegral (getCompressed cFSize (B.unsafeDrop ucFSize buf'''))++    let sci = scientific (iPart * 10 ^ scale + fPart) (negate $ fromIntegral scale)+        sci' = if sign == 0 then negate sci else sci+    pure (BinLogNewDecimal sci')+  where+    digitsPerInteger = 9+    blockSize = fromIntegral $ (10 :: Int32) ^ (9 :: Int)+    sizeTable = B.pack [0, 1, 1, 2, 2, 3, 3, 4, 4, 4]++    getCompressed :: Int -> ByteString -> Word64+    getCompressed 0 _  = 0+    getCompressed x bs = let fb = bs `B.unsafeIndex` 0+                             x' = x - 1+                         in fromIntegral fb `shiftL` (8 * x') .|. getCompressed x' (B.unsafeDrop 1 bs)++    getUncompressed :: Word8 -> ByteString -> Integer+    getUncompressed 0 _ = 0+    getUncompressed x bs = let v = getCompressed 4 (B.unsafeTake 4 bs)+                               x' = x - 1+                           in fromIntegral v * (blockSize ^ x') + getUncompressed x' (B.unsafeDrop 4 bs)+++getBinLogField (BINLOG_TYPE_ENUM size) =+    if  | size == 1 -> BinLogEnum . fromIntegral <$> getWord8+        | size == 2 -> BinLogEnum . fromIntegral <$> getWord16be+        | otherwise -> fail $ "Database.MySQL.BinLogProtocol.BinLogValue: wrong \+                              \BINLOG_TYPE_ENUM size: " ++ show size+++getBinLogField (BINLOG_TYPE_SET _ bytes) = BinLogSet <$> getBits' bytes+getBinLogField (BINLOG_TYPE_BLOB lensize) = do+    len <- if  | lensize == 1 -> fromIntegral <$> getWord8+               | lensize == 2 -> fromIntegral <$> getWord16le+               | lensize == 3 -> fromIntegral <$> getWord24le+               | lensize == 4 -> fromIntegral <$> getWord32le+               | otherwise    -> fail $ "Database.MySQL.BinLogProtocol.BinLogValue: \+                                        \wrong BINLOG_TYPE_BLOB length size: " ++ show lensize+    BinLogBytes <$> getByteString len++getBinLogField (BINLOG_TYPE_STRING size) = do+    len <- if | size < 256 -> fromIntegral <$> getWord8+              | otherwise  -> fromIntegral <$> getWord16le+    BinLogBytes <$> getByteString len++getBinLogField (BINLOG_TYPE_GEOMETRY lensize) = do+    len <- if | lensize == 1 -> fromIntegral <$> getWord8+              | lensize == 2 -> fromIntegral <$> getWord16le+              | lensize == 3 -> fromIntegral <$> getWord24le+              | lensize == 4 -> fromIntegral <$> getWord32le+              | otherwise    -> fail $  "Database.MySQL.BinLogProtocol.BinLogValue: \+                                        \wrong BINLOG_TYPE_GEOMETRY length size: " ++ show lensize+    BinLogGeometry <$> getByteString len++getMicroSecond :: Word8 -> Get Int32+getMicroSecond 0 = pure 0+getMicroSecond 1 = (* 100000) . fromIntegral <$> getInt8+getMicroSecond 2 = (* 10000) . fromIntegral <$> getInt8+getMicroSecond 3 = (* 1000) . fromIntegral <$> getInt16be+getMicroSecond 4 = (* 100) . fromIntegral <$> getInt16be+getMicroSecond 5 = (* 10) . fromIntegral <$> getInt24be+getMicroSecond 6 = fromIntegral <$> getInt24be+getMicroSecond _ = pure 0++getBits' :: Word8 -> Get Word64+getBits' bytes = if bytes <= 8+    then getBits (fromIntegral bytes)+    else fail $  "Database.MySQL.BinLogProtocol.BinLogValue: \+                 \wrong bit length size: " ++ show bytes++--------------------------------------------------------------------------------+-- | BinLog row decoder+--+getBinLogRow :: [BinLogMeta] -> BitMap -> Get [BinLogValue]+getBinLogRow metas pmap = do+    let plen = B.foldl' (\acc word8 -> acc + popCount word8) 0 (fromBitMap pmap)+        maplen = (plen + 7) `shiftR` 3+    nullmap <- getByteString maplen+    go metas (BitMap nullmap) 0 pmap 0+  where+    go :: [BinLogMeta] -> BitMap -> Int -> BitMap -> Int -> Get [BinLogValue]+    go []     _       _       _     _    = pure []+    go (f:fs) nullmap nullpos pmap' ppos = do+        let ppos' = ppos + 1+        if isColumnSet pmap' ppos+        then do+            r <- if isColumnSet nullmap nullpos+                    then return BinLogNull+                    else getBinLogField f+            let nullpos' = nullpos + 1+            rest <- nullpos' `seq` ppos' `seq` go fs nullmap nullpos' pmap' ppos'+            return (rest `seq` (r : rest))+        else ppos' `seq` go fs nullmap nullpos pmap' ppos'+
+ src/Database/MySQL/Connection.hs view
@@ -0,0 +1,275 @@+{-|+Module      : Database.MySQL.Connection+Description : Connection managment+Copyright   : (c) Winterland, 2016+License     : BSD+Maintainer  : drkoster@qq.com+Stability   : experimental+Portability : PORTABLE++This is an internal module, the 'MySQLConn' type should not directly acessed to user.++-}++module Database.MySQL.Connection where++import           Control.Applicative+import           Control.Exception               (Exception, bracketOnError,+                                                  throwIO, catch, SomeException)+import           Control.Monad+import qualified Crypto.Hash                     as Crypto+import qualified Data.Binary                     as Binary+import qualified Data.Binary.Put                 as Binary+import           Data.Bits+import qualified Data.ByteArray                  as BA+import           Data.ByteString                 (ByteString)+import qualified Data.ByteString                 as B+import qualified Data.ByteString.Lazy            as L+import qualified Data.ByteString.Unsafe          as B+import           Data.IORef                      (IORef, newIORef, readIORef,+                                                  writeIORef)+import           Data.Typeable+import           Data.Word+import           Database.MySQL.Protocol.Auth+import           Database.MySQL.Protocol.Command+import           Database.MySQL.Protocol.Packet+import           Network.Socket                  (HostName, PortNumber)+import           System.IO.Streams               (InputStream)+import qualified System.IO.Streams               as Stream+import qualified System.IO.Streams.TCP           as TCP+import qualified Data.Connection                 as TCP++--------------------------------------------------------------------------------++-- | 'MySQLConn' wrap both 'InputStream' and 'OutputStream' for MySQL 'Packet'.+--+-- You shouldn't use one 'MySQLConn' in different thread, if you do that,+-- consider protecting it with a @MVar@.+--+data MySQLConn = MySQLConn {+        mysqlRead        :: {-# UNPACK #-} !(InputStream  Packet)+    ,   mysqlWrite       :: (Packet -> IO ())+    ,   mysqlCloseSocket :: IO ()+    ,   isConsumed       :: {-# UNPACK #-} !(IORef Bool)+    }++-- | Everything you need to establish a MySQL connection.+--+-- To setup a TLS connection, use module "Database.MySQL.TLS" or "Database.MySQL.OpenSSL".+--+data ConnectInfo = ConnectInfo+    { ciHost     :: HostName+    , ciPort     :: PortNumber+    , ciDatabase :: ByteString+    , ciUser     :: ByteString+    , ciPassword :: ByteString+    , ciCharset  :: Word8+    } deriving Show++-- | A simple 'ConnectInfo' targeting localhost with @user=root@ and empty password.+--+--  Default charset is set to @utf8_general_ci@ to support older(< 5.5.3) MySQL versions,+--  but be aware this is a partial utf8 encoding, you may want to use 'defaultConnectInfoMB4'+--  instead to support full utf8 charset(emoji, etc.). You can query your server's support+--  with @SELECT id, collation_name FROM information_schema.collations ORDER BY id;@+--+defaultConnectInfo :: ConnectInfo+defaultConnectInfo = ConnectInfo "127.0.0.1" 3306 "" "root" "" utf8_general_ci++-- | 'defaultConnectInfo' with charset set to @utf8mb4_unicode_ci@+--+-- This is recommanded on any MySQL server version >= 5.5.3.+--+defaultConnectInfoMB4 :: ConnectInfo+defaultConnectInfoMB4 = ConnectInfo "127.0.0.1" 3306 "" "root" "" utf8mb4_unicode_ci++utf8_general_ci :: Word8+utf8_general_ci = 33++utf8mb4_unicode_ci :: Word8+utf8mb4_unicode_ci = 224++--------------------------------------------------------------------------------++-- | Socket buffer size.+--+-- maybe exposed to 'ConnectInfo' laster?+--+bUFSIZE :: Int+bUFSIZE = 16384++-- | Establish a MySQL connection.+--+connect :: ConnectInfo -> IO MySQLConn+connect = fmap snd . connectDetail++-- | Establish a MySQL connection with 'Greeting' back, so you can find server's version .etc.+--+connectDetail :: ConnectInfo -> IO (Greeting, MySQLConn)+connectDetail (ConnectInfo host port db user pass charset)+    = bracketOnError open TCP.close go+  where+    open  = connectWithBufferSize host port bUFSIZE+    go c  = do+        let is = TCP.source c+        is' <- decodeInputStream is+        p <- readPacket is'+        greet <- decodeFromPacket p+        let auth = mkAuth db user pass charset greet+        write c $ encodeToPacket 1 auth+        q <- readPacket is'+        if isOK q+        then do+            consumed <- newIORef True+            let waitNotMandatoryOK = catch+                    (void (waitCommandReply is'))           -- server will either reply an OK packet+                    ((\ _ -> return ()) :: SomeException -> IO ())   -- or directy close the connection+                conn = MySQLConn is'+                    (write c)+                    (writeCommand COM_QUIT (write c) >> waitNotMandatoryOK >> TCP.close c)+                    consumed+            return (greet, conn)+        else TCP.close c >> decodeFromPacket q >>= throwIO . ERRException++    connectWithBufferSize h p bs = TCP.connectSocket h p >>= TCP.socketToConnection bs+    write c a = TCP.send c $ Binary.runPut . Binary.put $ a++mkAuth :: ByteString -> ByteString -> ByteString -> Word8 -> Greeting -> Auth+mkAuth db user pass charset greet =+    let salt = greetingSalt1 greet `B.append` greetingSalt2 greet+        scambleBuf = scramble salt pass+    in Auth clientCap clientMaxPacketSize charset user scambleBuf db+  where+    scramble :: ByteString -> ByteString -> ByteString+    scramble salt pass'+        | B.null pass' = B.empty+        | otherwise   = B.pack (B.zipWith xor sha1pass withSalt)+        where sha1pass = sha1 pass'+              withSalt = sha1 (salt `B.append` sha1 sha1pass)++    sha1 :: ByteString -> ByteString+    sha1 = BA.convert . (Crypto.hash :: ByteString -> Crypto.Digest Crypto.SHA1)++-- | A specialized 'decodeInputStream' here for speed+decodeInputStream :: InputStream ByteString -> IO (InputStream Packet)+decodeInputStream is = Stream.makeInputStream $ do+    bs <- Stream.readExactly 4 is+    let len =  fromIntegral (bs `B.unsafeIndex` 0)+           .|. fromIntegral (bs `B.unsafeIndex` 1) `shiftL` 8+           .|. fromIntegral (bs `B.unsafeIndex` 2) `shiftL` 16+        seqN = bs `B.unsafeIndex` 3+    body <- loopRead [] len is+    return . Just $ Packet len seqN body+  where+    loopRead acc 0 _  = return $! L.fromChunks (reverse acc)+    loopRead acc k is' = do+        bs <- Stream.read is'+        case bs of Nothing -> throwIO NetworkException+                   Just bs' -> do let l = fromIntegral (B.length bs')+                                  if l >= k+                                  then do+                                      let (a, rest) = B.splitAt (fromIntegral k) bs'+                                      unless (B.null rest) (Stream.unRead rest is')+                                      return $! L.fromChunks (reverse (a:acc))+                                  else do+                                      let k' = k - l+                                      k' `seq` loopRead (bs':acc) k' is'++-- | Close a MySQL connection.+--+close :: MySQLConn -> IO ()+close (MySQLConn _ _ closeSocket _) = closeSocket++-- | Send a 'COM_PING'.+--+ping :: MySQLConn -> IO OK+ping = flip command COM_PING++--------------------------------------------------------------------------------+-- helpers++-- | Send a 'Command' which don't return a resultSet.+--+command :: MySQLConn -> Command -> IO OK+command conn@(MySQLConn is os _ _) cmd = do+    guardUnconsumed conn+    writeCommand cmd os+    waitCommandReply is+{-# INLINE command #-}++waitCommandReply :: InputStream Packet -> IO OK+waitCommandReply is = do+    p <- readPacket is+    if  | isERR p -> decodeFromPacket p >>= throwIO . ERRException+        | isOK  p -> decodeFromPacket p+        | otherwise -> throwIO (UnexpectedPacket p)+{-# INLINE waitCommandReply #-}++waitCommandReplys :: InputStream Packet -> IO [OK]+waitCommandReplys is = do+    p <- readPacket is+    if  | isERR p -> decodeFromPacket p >>= throwIO . ERRException+        | isOK  p -> do ok <- decodeFromPacket p+                        if isThereMore ok+                        then (ok :) <$> waitCommandReplys is+                        else return [ok]+        | otherwise -> throwIO (UnexpectedPacket p)+{-# INLINE waitCommandReplys #-}++readPacket :: InputStream Packet -> IO Packet+readPacket is = Stream.read is >>= maybe+    (throwIO NetworkException)+    (\ p@(Packet len _ bs) -> if len < 16777215 then return p else go len [bs])+  where+    go len acc = Stream.read is >>= maybe+        (throwIO NetworkException)+        (\ (Packet len' seqN bs) -> do+            let len'' = len + len'+                acc' = bs:acc+            if len' < 16777215+            then return (Packet len'' seqN (L.concat . reverse $ acc'))+            else len'' `seq` go len'' acc'+        )+{-# INLINE readPacket #-}++writeCommand :: Command -> (Packet -> IO ()) -> IO ()+writeCommand a writePacket = let bs = Binary.runPut (putCommand a) in+    go (fromIntegral (L.length bs)) 0 bs writePacket+  where+    go len seqN bs writePacket' = do+        if len < 16777215+        then writePacket (Packet len seqN bs)+        else do+            let (bs', rest) = L.splitAt 16777215 bs+                seqN' = seqN + 1+                len'  = len - 16777215++            writePacket (Packet 16777215 seqN bs')+            seqN' `seq` len' `seq` go len' seqN' rest writePacket'+{-# INLINE writeCommand #-}++guardUnconsumed :: MySQLConn -> IO ()+guardUnconsumed (MySQLConn _ _ _ consumed) = do+    c <- readIORef consumed+    unless c (throwIO UnconsumedResultSet)+{-# INLINE guardUnconsumed #-}++writeIORef' :: IORef a -> a -> IO ()+writeIORef' ref x = x `seq` writeIORef ref x+{-# INLINE writeIORef' #-}++--------------------------------------------------------------------------------+-- Exceptions++data NetworkException = NetworkException deriving (Typeable, Show)+instance Exception NetworkException++data UnconsumedResultSet = UnconsumedResultSet deriving (Typeable, Show)+instance Exception UnconsumedResultSet++data ERRException = ERRException ERR deriving (Typeable, Show)+instance Exception ERRException++data UnexpectedPacket = UnexpectedPacket Packet deriving (Typeable, Show)+instance Exception UnexpectedPacket+
+ src/Database/MySQL/Protocol/Auth.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}++{-|+Module      : Database.MySQL.Protocol.Auth+Description : MySQL Auth Packets+Copyright   : (c) Winterland, 2016+License     : BSD+Maintainer  : drkoster@qq.com+Stability   : experimental+Portability : PORTABLE++Auth related packet.++-}++module Database.MySQL.Protocol.Auth where++import           Control.Applicative+import           Control.Monad+import           Data.Binary+import           Data.Binary.Get+import           Data.Binary.Parser+import           Data.Binary.Put+import qualified Data.ByteString                as B+import           Data.ByteString.Char8          as BC+import           Data.Bits+import           Database.MySQL.Protocol.Packet++--------------------------------------------------------------------------------+-- Authentications++#define CLIENT_LONG_PASSWORD                  0x00000001+#define CLIENT_FOUND_ROWS                     0x00000002+#define CLIENT_LONG_FLAG                      0x00000004+#define CLIENT_CONNECT_WITH_DB                0x00000008+#define CLIENT_NO_SCHEMA                      0x00000010+#define CLIENT_COMPRESS                       0x00000020+#define CLIENT_ODBC                           0x00000040+#define CLIENT_LOCAL_FILES                    0x00000080+#define CLIENT_IGNORE_SPACE                   0x00000100+#define CLIENT_PROTOCOL_41                    0x00000200+#define CLIENT_INTERACTIVE                    0x00000400+#define CLIENT_SSL                            0x00000800+#define CLIENT_IGNORE_SIGPIPE                 0x00001000+#define CLIENT_TRANSACTIONS                   0x00002000+#define CLIENT_RESERVED                       0x00004000+#define CLIENT_SECURE_CONNECTION              0x00008000+#define CLIENT_MULTI_STATEMENTS               0x00010000+#define CLIENT_MULTI_RESULTS                  0x00020000+#define CLIENT_PS_MULTI_RESULTS               0x00040000+#define CLIENT_PLUGIN_AUTH                    0x00080000+#define CLIENT_CONNECT_ATTRS                  0x00100000+#define CLIENT_PLUGIN_AUTH_LENENC_CLIENT_DATA 0x00200000++data Greeting = Greeting+    { greetingProtocol :: !Word8+    , greetingVersion  :: !B.ByteString+    , greetingConnId   :: !Word32+    , greetingSalt1    :: !B.ByteString+    , greetingCaps     :: !Word32+    , greetingCharset  :: !Word8+    , greetingStatus   :: !Word16+    , greetingSalt2    :: !B.ByteString+    , greetingAuthPlugin :: !B.ByteString+    } deriving (Show, Eq)++putGreeting :: Greeting -> Put+putGreeting (Greeting pv sv cid salt1 cap charset st salt2 authPlugin) = do+    putWord8 pv+    putByteString sv+    putWord8 0x00+    putWord32le cid+    putByteString salt1+    let capL = fromIntegral cap .|. 0xFF+        capH = fromIntegral (cap `shiftR` 16) .|. 0xFF+    putWord16le capL+    putWord8 charset+    putWord16le st+    putWord16le capH+    putWord8 (fromIntegral $ B.length salt2)+    replicateM_ 10 (putWord8 0x00)+    when (cap .&. CLIENT_SECURE_CONNECTION /= 0)+        (putByteString salt2)+    when (cap .&. CLIENT_PLUGIN_AUTH /= 0)+        (putByteString authPlugin)++getGreeting :: Get Greeting+getGreeting = do+    pv <- getWord8+    sv <- getByteStringNul+    cid <- getWord32le+    salt1 <- getByteString 8+    skipN 1  -- 0x00+    capL <- getWord16le+    charset <- getWord8+    status <- getWord16le+    capH <- getWord16le+    let cap = fromIntegral capH `shiftL` 16 .|. fromIntegral capL+    authPluginLen <- getWord8   -- this will issue an unused warning, see the notes below+    skipN 10 -- 10 * 0x00+    salt2 <- if (cap .&. CLIENT_SECURE_CONNECTION) == 0+        then pure B.empty+        else getByteStringNul   -- This is different with the MySQL document here+                                -- The doc said we should expect a MAX(13, length of auth-plugin-data - 8)+                                -- length bytes, but doing so stop us from login+                                -- anyway 'getByteStringNul' works perfectly here.++    authPlugin <- if (cap .&. CLIENT_PLUGIN_AUTH) == 0+        then pure B.empty+        else getByteStringNul++    return (Greeting pv sv cid salt1 cap charset status salt2 authPlugin)++instance Binary Greeting where+    get = getGreeting+    put = putGreeting++data Auth = Auth+    { authCaps      :: !Word32+    , authMaxPacket :: !Word32+    , authCharset   :: !Word8+    , authName      :: !ByteString+    , authPassword  :: !ByteString+    , authSchema    :: !ByteString+    } deriving (Show, Eq)++getAuth :: Get Auth+getAuth = do+    a <- getWord32le+    m <- getWord32le+    c <- getWord8+    skipN 23+    n <- getByteStringNul+    return $ Auth a m c n B.empty B.empty++putAuth :: Auth -> Put+putAuth (Auth cap m c n p s) = do+    putWord32le cap+    putWord32le m+    putWord8 c+    replicateM_ 23 (putWord8 0x00)+    putByteString n >> putWord8 0x00+    putWord8 $ fromIntegral (B.length p)+    putByteString p+    putByteString s+    putWord8 0x00++instance Binary Auth where+    get = getAuth+    put = putAuth++data SSLRequest = SSLRequest+    { sslReqCaps      :: !Word32+    , sslReqMaxPacket :: !Word32+    , sslReqCharset   :: !Word8+    } deriving (Show, Eq)++getSSLRequest :: Get SSLRequest+getSSLRequest = SSLRequest <$> getWord32le <*> getWord32le <*> getWord8 <* skipN 23++putSSLRequest :: SSLRequest -> Put+putSSLRequest (SSLRequest cap m c) = do+    putWord32le cap+    putWord32le m+    putWord8 c+    replicateM_ 23 (putWord8 0x00)++instance Binary SSLRequest where+    get = getSSLRequest+    put = putSSLRequest++--------------------------------------------------------------------------------+-- default Capability Flags++clientCap :: Word32+clientCap =  CLIENT_LONG_PASSWORD+                .|. CLIENT_LONG_FLAG+                .|. CLIENT_CONNECT_WITH_DB+                .|. CLIENT_IGNORE_SPACE+                .|. CLIENT_PROTOCOL_41+                .|. CLIENT_TRANSACTIONS+                .|. CLIENT_MULTI_STATEMENTS+                .|. CLIENT_MULTI_RESULTS+                .|. CLIENT_SECURE_CONNECTION++clientMaxPacketSize :: Word32+clientMaxPacketSize = 0x00ffffff :: Word32+++supportTLS :: Word32 -> Bool+supportTLS x = (x .&. CLIENT_SSL) /= 0++sslRequest :: Word8 -> SSLRequest+sslRequest charset = SSLRequest (clientCap .|. CLIENT_SSL) clientMaxPacketSize charset
+ src/Database/MySQL/Protocol/ColumnDef.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}++{-|+Module      : Database.MySQL.Protocol.ColumnDef+Description : MySQL field type+Copyright   : (c) Winterland, 2016+License     : BSD+Maintainer  : drkoster@qq.com+Stability   : experimental+Portability : PORTABLE++Column definition(aka. field type).++-}++module Database.MySQL.Protocol.ColumnDef where++import           Control.Applicative+import           Data.Binary+import           Data.Binary.Get+import           Data.Binary.Parser+import           Data.Binary.Put+import           Data.Bits                      ((.&.))+import           Data.ByteString                (ByteString)+import           Database.MySQL.Protocol.Packet++--------------------------------------------------------------------------------+--  Resultset++-- | A description of a field (column) of a table.+data ColumnDef = ColumnDef+    { -- fieldCatalog :: !ByteString              -- ^ const 'def'+      columnDB        ::  !ByteString             -- ^ Database for table.+    , columnTable     ::  !ByteString             -- ^ Table of column, if column was a field.+    , columnOrigTable ::  !ByteString             -- ^ Original table name, if table was an alias.+    , columnName      ::  !ByteString             -- ^ Name of column.+    , columnOrigName  ::  !ByteString             -- ^ Original column name, if an alias.+    , columnCharSet   ::  !Word16                 -- ^ Character set number.+    , columnLength    ::  !Word32                 -- ^ Width of column (create length).+    , columnType      ::  !FieldType+    , columnFlags     ::  !Word16                 -- ^ Div flags.+    , columnDecimals  ::  !Word8                  -- ^ Number of decimals in field.+    } deriving (Show, Eq)++getField :: Get ColumnDef+getField = ColumnDef+        <$> (skipN 4                 -- const "def"+         *> getLenEncBytes)         -- db+        <*> getLenEncBytes          -- table+        <*> getLenEncBytes          -- origTable+        <*> getLenEncBytes          -- name+        <*> getLenEncBytes          -- origName+        <*  skipN 1                  -- const 0x0c+        <*> getWord16le             -- charset+        <*> getWord32le             -- length+        <*> getFieldType            -- type+        <*> getWord16le             -- flags+        <*> getWord8                -- decimals+        <* skipN 2                   -- const 0x00 0x00+{-# INLINE getField #-}++putField :: ColumnDef -> Put+putField (ColumnDef db tbl otbl name oname charset len typ flags dec) = do+    putLenEncBytes "def"+    putLenEncBytes db+    putLenEncBytes tbl+    putLenEncBytes otbl+    putLenEncBytes name+    putLenEncBytes oname+    putWord16le charset+    putWord32le len+    putFieldType typ+    putWord16le  flags+    putWord8 dec+    putWord16le 0X0000+{-# INLINE putField #-}++instance Binary ColumnDef where+    get = getField+    {-# INLINE get #-}+    put = putField+    {-# INLINE put #-}++-- | @newtype@ around 'Word8' for represent @MySQL_TYPE@, We don't use sum type here for speed reason.+--+newtype FieldType = FieldType Word8 deriving (Show, Eq)++mySQLTypeDecimal, mySQLTypeTiny, mySQLTypeShort, mySQLTypeLong, mySQLTypeFloat :: FieldType+mySQLTypeDouble, mySQLTypeNull, mySQLTypeTimestamp, mySQLTypeLongLong, mySQLTypeInt24 :: FieldType+mySQLTypeDate, mySQLTypeTime, mySQLTypeDateTime, mySQLTypeYear, mySQLTypeNewDate, mySQLTypeVarChar :: FieldType+mySQLTypeBit, mySQLTypeTimestamp2, mySQLTypeDateTime2, mySQLTypeTime2, mySQLTypeNewDecimal :: FieldType+mySQLTypeEnum, mySQLTypeSet, mySQLTypeTinyBlob, mySQLTypeMediumBlob, mySQLTypeLongBlob :: FieldType+mySQLTypeBlob, mySQLTypeVarString, mySQLTypeString, mySQLTypeGeometry :: FieldType++mySQLTypeDecimal        = FieldType 0x00+mySQLTypeTiny           = FieldType 0x01+mySQLTypeShort          = FieldType 0x02+mySQLTypeLong           = FieldType 0x03+mySQLTypeFloat          = FieldType 0x04+mySQLTypeDouble         = FieldType 0x05+mySQLTypeNull           = FieldType 0x06+mySQLTypeTimestamp      = FieldType 0x07+mySQLTypeLongLong       = FieldType 0x08+mySQLTypeInt24          = FieldType 0x09+mySQLTypeDate           = FieldType 0x0a+mySQLTypeTime           = FieldType 0x0b+mySQLTypeDateTime       = FieldType 0x0c+mySQLTypeYear           = FieldType 0x0d+mySQLTypeNewDate        = FieldType 0x0e+mySQLTypeVarChar        = FieldType 0x0f+mySQLTypeBit            = FieldType 0x10+mySQLTypeTimestamp2     = FieldType 0x11+mySQLTypeDateTime2      = FieldType 0x12+mySQLTypeTime2          = FieldType 0x13+mySQLTypeNewDecimal     = FieldType 0xf6+mySQLTypeEnum           = FieldType 0xf7+mySQLTypeSet            = FieldType 0xf8+mySQLTypeTinyBlob       = FieldType 0xf9+mySQLTypeMediumBlob     = FieldType 0xfa+mySQLTypeLongBlob       = FieldType 0xfb+mySQLTypeBlob           = FieldType 0xfc+mySQLTypeVarString      = FieldType 0xfd+mySQLTypeString         = FieldType 0xfe+mySQLTypeGeometry       = FieldType 0xff++getFieldType :: Get FieldType+getFieldType = FieldType <$> getWord8+{-# INLINE getFieldType #-}++putFieldType :: FieldType -> Put+putFieldType (FieldType t) = putWord8 t+{-# INLINE putFieldType #-}++instance Binary FieldType where+    get = getFieldType+    {-# INLINE get #-}+    put = putFieldType+    {-# INLINE put #-}++--------------------------------------------------------------------------------+--  Field flags++#define NOT_NULL_FLAG         1+#define PRI_KEY_FLAG          2+#define UNIQUE_KEY_FLAG       4+#define MULT_KEY_FLAG         8+#define BLOB_FLAG             16+#define UNSIGNED_FLAG         32+#define ZEROFILL_FLAG         64+#define BINARY_FLAG           128+#define ENUM_FLAG             256+#define AUTO_INCREMENT_FLAG   512+#define TIMESTAMP_FLAG        1024+#define SET_FLAG              2048+#define NO_DEFAULT_VALUE_FLAG 4096+#define PART_KEY_FLAG         16384+#define NUM_FLAG              32768++flagNotNull, flagPrimaryKey, flagUniqueKey, flagMultipleKey, flagBlob, flagUnsigned, flagZeroFill :: Word16 -> Bool+flagBinary, flagEnum, flagAutoIncrement, flagTimeStamp, flagSet, flagNoDefaultValue, flagPartKey, flagNumeric :: Word16 -> Bool+flagNotNull        flags = flags .&. NOT_NULL_FLAG         == NOT_NULL_FLAG+flagPrimaryKey     flags = flags .&. PRI_KEY_FLAG          == PRI_KEY_FLAG+flagUniqueKey      flags = flags .&. UNIQUE_KEY_FLAG       == UNIQUE_KEY_FLAG+flagMultipleKey    flags = flags .&. MULT_KEY_FLAG         == MULT_KEY_FLAG+flagBlob           flags = flags .&. BLOB_FLAG             == BLOB_FLAG+flagUnsigned       flags = flags .&. UNSIGNED_FLAG         == UNSIGNED_FLAG+flagZeroFill       flags = flags .&. ZEROFILL_FLAG         == ZEROFILL_FLAG+flagBinary         flags = flags .&. BINARY_FLAG           == BINARY_FLAG+flagEnum           flags = flags .&. ENUM_FLAG             == ENUM_FLAG+flagAutoIncrement  flags = flags .&. AUTO_INCREMENT_FLAG   == AUTO_INCREMENT_FLAG+flagTimeStamp      flags = flags .&. TIMESTAMP_FLAG        == TIMESTAMP_FLAG+flagSet            flags = flags .&. SET_FLAG              == SET_FLAG+flagNoDefaultValue flags = flags .&. NO_DEFAULT_VALUE_FLAG == NO_DEFAULT_VALUE_FLAG+flagPartKey        flags = flags .&. PART_KEY_FLAG         == PART_KEY_FLAG+flagNumeric        flags = flags .&. NUM_FLAG              == NUM_FLAG
+ src/Database/MySQL/Protocol/Command.hs view
@@ -0,0 +1,108 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++{-|+Module      : Database.MySQL.Protocol.Command+Description : MySQL commands+Copyright   : (c) Winterland, 2016+License     : BSD+Maintainer  : drkoster@qq.com+Stability   : experimental+Portability : PORTABLE++Common MySQL commands supports.++-}++module Database.MySQL.Protocol.Command where++import           Control.Applicative+import           Control.Monad+import           Data.Binary+import           Data.Binary.Get+import           Data.Binary.Parser+import           Data.Binary.Put+import           Data.ByteString                    (ByteString)+import qualified Data.ByteString.Lazy               as L+import           Database.MySQL.Protocol.MySQLValue+import           Database.MySQL.Protocol.Packet++--------------------------------------------------------------------------------+--  Commands++type StmtID = Word32++-- | All support MySQL commands.+--+data Command+    = COM_QUIT                                    -- ^ 0x01+    | COM_INIT_DB        !ByteString              -- ^ 0x02+    | COM_QUERY          !L.ByteString            -- ^ 0x03+    | COM_PING                                    -- ^ 0x0E+    | COM_BINLOG_DUMP    !Word32 !Word16 !Word32 !ByteString -- ^ 0x12+            -- binlog-pos, flags(0x01), server-id, binlog-filename+    | COM_REGISTER_SLAVE !Word32 !ByteString !ByteString !ByteString !Word16 !Word32 !Word32 -- ^ 0x15+            -- server-id, slaves hostname, slaves user, slaves password,  slaves port, replication rank(ignored), master-id(usually 0)+    | COM_STMT_PREPARE   !L.ByteString            -- ^ 0x16 statement+    | COM_STMT_EXECUTE   !StmtID ![MySQLValue] !BitMap -- ^ 0x17 stmtId, params+    | COM_STMT_CLOSE     !StmtID                  -- ^ 0x19 stmtId+    | COM_STMT_RESET     !StmtID                  -- ^ 0x1A stmtId+    | COM_UNSUPPORTED+   deriving (Show, Eq)++putCommand :: Command -> Put+putCommand COM_QUIT              = putWord8 0x01+putCommand (COM_INIT_DB db)      = putWord8 0x02 >> putByteString db+putCommand (COM_QUERY q)         = putWord8 0x03 >> putLazyByteString q+putCommand COM_PING              = putWord8 0x0E+putCommand (COM_BINLOG_DUMP pos flags sid fname) = do+    putWord8 0x12+    putWord32le pos+    putWord16le flags+    putWord32le sid+    putByteString fname+putCommand (COM_REGISTER_SLAVE sid shost susr spass sport rrank mid) = do+    putWord8 0x15+    putWord32le sid+    putLenEncBytes shost+    putLenEncBytes susr+    putLenEncBytes spass+    putWord16le sport+    putWord32le rrank+    putWord32le mid+putCommand (COM_STMT_PREPARE stmt) = putWord8 0x16 >> putLazyByteString stmt+putCommand (COM_STMT_EXECUTE stid params nullmap) = do+    putWord8 0x17+    putWord32le stid+    putWord8 0x00 -- we only use @CURSOR_TYPE_NO_CURSOR@ here+    putWord32le 1 -- const 1+    unless (null params) $ do+        putByteString (fromBitMap nullmap)+        putWord8 0x01    -- always use new-params-bound-flag+        mapM_ putParamMySQLType params+        forM_ params putBinaryField++putCommand (COM_STMT_CLOSE stid) = putWord8 0x19 >> putWord32le stid+putCommand (COM_STMT_RESET stid) = putWord8 0x1A >> putWord32le stid+putCommand _                     = error "unsupported command"++--------------------------------------------------------------------------------+--  Prepared statment related++-- | call 'isOK' with this packet return true+data StmtPrepareOK = StmtPrepareOK+    { stmtId        :: !StmtID+    , stmtColumnCnt :: !Int+    , stmtParamCnt  :: !Int+    , stmtWarnCnt   :: !Int+    } deriving (Show, Eq)++getStmtPrepareOK :: Get StmtPrepareOK+getStmtPrepareOK = do+    skipN 1 -- OK byte+    stmtid <- getWord32le+    cc <- fromIntegral <$> getWord16le+    pc <- fromIntegral <$> getWord16le+    skipN 1 -- reserved+    wc <- fromIntegral <$> getWord16le+    return (StmtPrepareOK stmtid cc pc wc)+{-# INLINE getStmtPrepareOK #-}
+ src/Database/MySQL/Protocol/Escape.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE BangPatterns #-}++{-|+Module      : Database.MySQL.Protocol.Escape+Description : Pure haskell mysql escape+Copyright   : (c) Winterland, 2016+License     : BSD+Maintainer  : drkoster@qq.com+Stability   : experimental+Portability : PORTABLE++This module provide escape machinery for bytes and text types.++reference: <http://dev.mysql.com/doc/refman/5.7/en/string-literals.html>++    * Escape Sequence	Character Represented by Sequence+    * \0              	An ASCII NUL (X'00') character+    * \'              	A single quote (“'”) character+    * \"              	A double quote (“"”) character+    * \b              	A backspace character+    * \n              	A newline (linefeed) character+    * \r              	A carriage return character+    * \t              	A tab character+    * \Z              	ASCII 26 (Control+Z); see note following the table+    * \\              	A backslash (“\”) character+    * \%              	A “%” character; see note following the table+    * \_              	A “_” character; see note following the table++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.++-}++module Database.MySQL.Protocol.Escape where++import           Data.ByteString          (ByteString)+import qualified Data.ByteString.Internal as B+import           Data.Text                (Text)+import qualified Data.Text.Array          as TA+import qualified Data.Text.Internal       as T+import           Data.Word+import           Foreign.ForeignPtr       (withForeignPtr)+import           Foreign.Ptr              (Ptr, minusPtr, plusPtr)+import           Foreign.Storable         (peek, poke, pokeByteOff)+import           GHC.IO                   (unsafeDupablePerformIO)++escapeText :: Text -> Text+escapeText (T.Text arr off len)+    | len <= 0  = T.empty+    | otherwise =+        let (arr', len') =  TA.run2 $ do+                marr <- TA.new (len * 2)+                loop arr (off + len) marr off 0+        in T.Text arr' 0 len'+  where+    escape c marr ix = do+        TA.unsafeWrite marr ix 92+        TA.unsafeWrite marr (ix+1) c++    loop oarr oend marr !ix !ix'+        | ix == oend = return (marr, ix')+        | otherwise  = do+            let c = TA.unsafeIndex oarr ix+                go1 = loop oarr oend marr (ix+1) (ix'+1)+                go2 = loop oarr oend marr (ix+1) (ix'+2)+            if  | c >= 0xD800 && c <= 0xDBFF  -> do let c2 = TA.unsafeIndex oarr (ix+1)+                                                    TA.unsafeWrite marr ix' c+                                                    TA.unsafeWrite marr (ix'+1) c2+                                                    loop oarr oend marr (ix+2) (ix'+2)+                | c == 0+                    || c == 39+                    || c == 34 -> escape c   marr ix' >> go2 -- \0 \' \"+                | c == 8       -> escape 98  marr ix' >> go2 -- \b+                | c == 10      -> escape 110 marr ix' >> go2 -- \n+                | c == 13      -> escape 114 marr ix' >> go2 -- \r+                | c == 9       -> escape 116 marr ix' >> go2 -- \t+                | c == 26      -> escape 90  marr ix' >> go2 -- \Z+                | c == 92      -> escape 92  marr ix' >> go2 -- \\++                | otherwise    -> TA.unsafeWrite marr ix' c >> go1++escapeBytes :: ByteString -> ByteString+escapeBytes (B.PS fp s len) = unsafeDupablePerformIO $ withForeignPtr fp $ \ a ->+    B.createUptoN (len * 2) $ \ b -> do+        b' <- loop (a `plusPtr` s) (a `plusPtr` s `plusPtr` len) b+        return (b' `minusPtr` b)+  where+    escape :: Word8 -> Ptr Word8 -> IO (Ptr Word8)+    escape c p = do+        poke p 92+        pokeByteOff p 1 c+        return (p `plusPtr` 2)++    loop !a aend !b+        | a == aend = return b+        | otherwise = do+            c <- peek a+            if  | c == 0+                    || c == 39+                    || c == 34 -> escape c   b >>= loop (a `plusPtr` 1) aend -- \0 \' \"+                | c == 8       -> escape 98  b >>= loop (a `plusPtr` 1) aend -- \b+                | c == 10      -> escape 110 b >>= loop (a `plusPtr` 1) aend -- \n+                | c == 13      -> escape 114 b >>= loop (a `plusPtr` 1) aend -- \r+                | c == 9       -> escape 116 b >>= loop (a `plusPtr` 1) aend -- \t+                | c == 26      -> escape 90  b >>= loop (a `plusPtr` 1) aend -- \Z+                | c == 92      -> escape 92  b >>= loop (a `plusPtr` 1) aend -- \\++                | otherwise    -> poke b c >> loop (a `plusPtr` 1) aend (b `plusPtr` 1)
+ src/Database/MySQL/Protocol/MySQLValue.hs view
@@ -0,0 +1,567 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++{-|+Module      : Database.MySQL.Protocol.MySQLValue+Description : Text and binary protocol+Copyright   : (c) Winterland, 2016+License     : BSD+Maintainer  : drkoster@qq.com+Stability   : experimental+Portability : PORTABLE++Core text and binary row decoder/encoder machinery.++-}++module Database.MySQL.Protocol.MySQLValue+  ( -- * MySQLValue decoder and encoder+    MySQLValue(..)+  , putParamMySQLType+  , getTextField+  , putTextField+  , getTextRow+  , getTextRowVector+  , getBinaryField+  , putBinaryField+  , getBinaryRow+  , getBinaryRowVector+  -- * Internal utilities+  , getBits+  , BitMap(..)+  , isColumnSet+  , isColumnNull+  , makeNullMap+  ) where++import qualified Blaze.Text                         as Textual+import           Control.Applicative+import           Control.Monad+import           Data.Binary.Put+import           Data.Binary.Parser+import           Data.Binary.IEEE754+import           Data.Bits+import           Data.ByteString                    (ByteString)+import qualified Data.ByteString                    as B+import qualified Data.ByteString.Builder            as BB+import           Data.ByteString.Builder.Scientific (FPFormat (..),+                                                     formatScientificBuilder)+import qualified Data.ByteString.Char8              as BC+import qualified Data.ByteString.Lazy               as L+import qualified Data.ByteString.Lex.Fractional     as LexFrac+import qualified Data.ByteString.Lex.Integral       as LexInt+import qualified Data.ByteString.Unsafe             as B+import           Data.Fixed                         (Pico)+import           Data.Int+import           Data.Scientific                    (Scientific)+import           Data.Text                          (Text)+import qualified Data.Text.Encoding                 as T+import           Data.Time.Calendar                 (Day, fromGregorian,+                                                     toGregorian)+import           Data.Time.Format                   (defaultTimeLocale,+                                                     formatTime)+import           Data.Time.LocalTime                (LocalTime (..),+                                                     TimeOfDay (..))+import           Data.Word+import           Database.MySQL.Protocol.ColumnDef+import           Database.MySQL.Protocol.Escape+import           Database.MySQL.Protocol.Packet+import           GHC.Generics                       (Generic)+import qualified Data.Vector                        as V++--------------------------------------------------------------------------------+-- | Data type mapping between MySQL values and haskell values.+--+-- There're some subtle differences between MySQL values and haskell values:+--+-- MySQL's @DATETIME@ and @TIMESTAMP@ are different on timezone handling:+--+--  * DATETIME and DATE is just a represent of a calendar date, it has no timezone information involved,+--  you always get the same value as you put no matter what timezone you're using with MySQL.+--+--  * MySQL converts TIMESTAMP values from the current time zone to UTC for storage,+--  and back from UTC to the current time zone for retrieval. If you put a TIMESTAMP with timezone A,+--  then read it with timezone B, you may get different result because of this conversion, so always+--  be careful about setting up the right timezone with MySQL, you can do it with a simple @SET time_zone = timezone;@+--  for more info on timezone support, please read <http://dev.mysql.com/doc/refman/5.7/en/time-zone-support.html>+--+--  So we use 'LocalTime' to present both @DATETIME@ and @TIMESTAMP@, but the local here is different.+--+-- MySQL's @TIME@ type can present time of day, but also elapsed time or a time interval between two events.+-- @TIME@ values may range from @-838:59:59@ to @838:59:59@, so 'MySQLTime' values consist of a sign and a+-- 'TimeOfDay' whose hour part may exceeded 24. you can use @timeOfDayToTime@ to get the absolute time interval.+--+-- Under MySQL >= 5.7, @DATETIME@, @TIMESTAMP@ and @TIME@ may contain fractional part, which matches haskell's+-- precision.+--+data MySQLValue+    = MySQLDecimal       !Scientific   -- ^ DECIMAL, NEWDECIMAL+    | MySQLInt8U         !Word8        -- ^ Unsigned TINY+    | MySQLInt8          !Int8         -- ^ TINY+    | MySQLInt16U        !Word16       -- ^ Unsigned SHORT+    | MySQLInt16         !Int16        -- ^ SHORT+    | MySQLInt32U        !Word32       -- ^ Unsigned LONG, INT24+    | MySQLInt32         !Int32        -- ^ LONG, INT24+    | MySQLInt64U        !Word64       -- ^ Unsigned LONGLONG+    | MySQLInt64         !Int64        -- ^ LONGLONG+    | MySQLFloat         !Float        -- ^ IEEE 754 single precision format+    | MySQLDouble        !Double       -- ^ IEEE 754 double precision format+    | MySQLYear          !Word16       -- ^ YEAR+    | MySQLDateTime      !LocalTime    -- ^ DATETIME+    | MySQLTimeStamp     !LocalTime    -- ^ TIMESTAMP+    | MySQLDate          !Day              -- ^ DATE+    | MySQLTime          !Word8 !TimeOfDay -- ^ sign(0 = non-negative, 1 = negative) hh mm ss microsecond+                                           -- The sign is OPPOSITE to binlog one !!!+    | MySQLGeometry      !ByteString       -- ^ todo: parsing to something meanful+    | MySQLBytes         !ByteString+    | MySQLBit           !Word64+    | MySQLText          !Text+    | MySQLNull+  deriving (Show, Eq, Generic)++-- | Put 'FieldType' and usigned bit(0x80/0x00) for 'MySQLValue's.+--+putParamMySQLType :: MySQLValue -> Put+putParamMySQLType (MySQLDecimal      _)  = putFieldType mySQLTypeDecimal  >> putWord8 0x00+putParamMySQLType (MySQLInt8U        _)  = putFieldType mySQLTypeTiny     >> putWord8 0x80+putParamMySQLType (MySQLInt8         _)  = putFieldType mySQLTypeTiny     >> putWord8 0x00+putParamMySQLType (MySQLInt16U       _)  = putFieldType mySQLTypeShort    >> putWord8 0x80+putParamMySQLType (MySQLInt16        _)  = putFieldType mySQLTypeShort    >> putWord8 0x00+putParamMySQLType (MySQLInt32U       _)  = putFieldType mySQLTypeLong     >> putWord8 0x80+putParamMySQLType (MySQLInt32        _)  = putFieldType mySQLTypeLong     >> putWord8 0x00+putParamMySQLType (MySQLInt64U       _)  = putFieldType mySQLTypeLongLong >> putWord8 0x80+putParamMySQLType (MySQLInt64        _)  = putFieldType mySQLTypeLongLong >> putWord8 0x00+putParamMySQLType (MySQLFloat        _)  = putFieldType mySQLTypeFloat    >> putWord8 0x00+putParamMySQLType (MySQLDouble       _)  = putFieldType mySQLTypeDouble   >> putWord8 0x00+putParamMySQLType (MySQLYear         _)  = putFieldType mySQLTypeYear     >> putWord8 0x80+putParamMySQLType (MySQLDateTime     _)  = putFieldType mySQLTypeDateTime >> putWord8 0x00+putParamMySQLType (MySQLTimeStamp    _)  = putFieldType mySQLTypeTimestamp>> putWord8 0x00+putParamMySQLType (MySQLDate         _)  = putFieldType mySQLTypeDate     >> putWord8 0x00+putParamMySQLType (MySQLTime       _ _)  = putFieldType mySQLTypeTime     >> putWord8 0x00+putParamMySQLType (MySQLBytes        _)  = putFieldType mySQLTypeBlob     >> putWord8 0x00+putParamMySQLType (MySQLGeometry     _)  = putFieldType mySQLTypeGeometry >> putWord8 0x00+putParamMySQLType (MySQLBit          _)  = putFieldType mySQLTypeBit      >> putWord8 0x00+putParamMySQLType (MySQLText         _)  = putFieldType mySQLTypeString   >> putWord8 0x00+putParamMySQLType MySQLNull              = putFieldType mySQLTypeNull     >> putWord8 0x00++--------------------------------------------------------------------------------+-- | Text protocol decoder+getTextField :: ColumnDef -> Get MySQLValue+getTextField f+    | t == mySQLTypeNull            = pure MySQLNull+    | t == mySQLTypeDecimal+        || t == mySQLTypeNewDecimal = feedLenEncBytes t MySQLDecimal fracLexer+    | t == mySQLTypeTiny            = if isUnsigned then feedLenEncBytes t MySQLInt8U intLexer+                                                    else feedLenEncBytes t MySQLInt8 intLexer+    | t == mySQLTypeShort           = if isUnsigned then feedLenEncBytes t MySQLInt16U intLexer+                                                    else feedLenEncBytes t MySQLInt16 intLexer+    | t == mySQLTypeLong+        || t == mySQLTypeInt24      = if isUnsigned then feedLenEncBytes t MySQLInt32U intLexer+                                                    else feedLenEncBytes t MySQLInt32 intLexer+    | t == mySQLTypeLongLong        = if isUnsigned then feedLenEncBytes t MySQLInt64U intLexer+                                                    else feedLenEncBytes t MySQLInt64 intLexer+    | t == mySQLTypeFloat           = feedLenEncBytes t MySQLFloat fracLexer+    | t == mySQLTypeDouble          = feedLenEncBytes t MySQLDouble fracLexer+    | t == mySQLTypeYear            = feedLenEncBytes t MySQLYear intLexer+    | t == mySQLTypeTimestamp+        || t == mySQLTypeTimestamp2 = feedLenEncBytes t MySQLTimeStamp $ \ bs ->+                                          LocalTime <$> dateParser bs <*> timeParser (B.unsafeDrop 11 bs)+    | t == mySQLTypeDateTime+        || t == mySQLTypeDateTime2  = feedLenEncBytes t MySQLDateTime $ \ bs ->+                                          LocalTime <$> dateParser bs <*> timeParser (B.unsafeDrop 11 bs)+    | t == mySQLTypeDate+        || t == mySQLTypeNewDate    = feedLenEncBytes t MySQLDate dateParser+    | t == mySQLTypeTime+        || t == mySQLTypeTime2      = feedLenEncBytes t id $ \ bs ->+                                          if bs `B.unsafeIndex` 0 == 45  -- '-'+                                               then MySQLTime 1 <$> timeParser (B.unsafeDrop 1 bs)+                                               else MySQLTime 0 <$> timeParser bs++    | t == mySQLTypeGeometry        = MySQLGeometry <$> getLenEncBytes+    | t == mySQLTypeVarChar+        || t == mySQLTypeEnum+        || t == mySQLTypeSet+        || t == mySQLTypeTinyBlob+        || t == mySQLTypeMediumBlob+        || t == mySQLTypeLongBlob+        || t == mySQLTypeBlob+        || t == mySQLTypeVarString+        || t == mySQLTypeString     = (if isText then MySQLText . T.decodeUtf8 else MySQLBytes) <$> getLenEncBytes++    | t == mySQLTypeBit             = MySQLBit <$> (getBits =<< getLenEncInt)++    | otherwise                     = fail $ "Database.MySQL.Protocol.MySQLValue: missing text decoder for " ++ show t+  where+    t = columnType f+    isUnsigned = flagUnsigned (columnFlags f)+    isText = columnCharSet f /= 63+    intLexer bs = fst <$> LexInt.readSigned LexInt.readDecimal bs+    fracLexer bs = fst <$> LexFrac.readSigned LexFrac.readDecimal bs+    dateParser bs = do+        (yyyy, rest) <- LexInt.readDecimal bs+        (mm, rest') <- LexInt.readDecimal (B.unsafeTail rest)+        (dd, _) <- LexInt.readDecimal (B.unsafeTail rest')+        return (fromGregorian yyyy mm dd)++    timeParser bs = do+        (hh, rest) <- LexInt.readDecimal bs+        (mm, rest') <- LexInt.readDecimal (B.unsafeTail rest)+        (ss, _) <- LexFrac.readDecimal (B.unsafeTail rest')+        return (TimeOfDay hh mm ss)+++feedLenEncBytes :: FieldType -> (t -> b) -> (ByteString -> Maybe t) -> Get b+feedLenEncBytes typ con parser = do+    bs <- getLenEncBytes+    case parser bs of+        Just v -> return (con v)+        Nothing -> fail $ "Database.MySQL.Protocol.MySQLValue: parsing " ++ show typ ++ " failed, \+                          \input: " ++ BC.unpack bs+{-# INLINE feedLenEncBytes #-}++--------------------------------------------------------------------------------+-- | Text protocol encoder+putTextField :: MySQLValue -> Put+putTextField (MySQLDecimal    n) = putBuilder (formatScientificBuilder Fixed Nothing n)+putTextField (MySQLInt8U      n) = putBuilder (Textual.integral n)+putTextField (MySQLInt8       n) = putBuilder (Textual.integral n)+putTextField (MySQLInt16U     n) = putBuilder (Textual.integral n)+putTextField (MySQLInt16      n) = putBuilder (Textual.integral n)+putTextField (MySQLInt32U     n) = putBuilder (Textual.integral n)+putTextField (MySQLInt32      n) = putBuilder (Textual.integral n)+putTextField (MySQLInt64U     n) = putBuilder (Textual.integral n)+putTextField (MySQLInt64      n) = putBuilder (Textual.integral n)+putTextField (MySQLFloat      x) = putBuilder (Textual.float x)+putTextField (MySQLDouble     x) = putBuilder (Textual.double x)+putTextField (MySQLYear       n) = putBuilder (Textual.integral n)+putTextField (MySQLDateTime  dt) = putInQuotes $+                                      putByteString (BC.pack (formatTime defaultTimeLocale "%F %T%Q" dt))+putTextField (MySQLTimeStamp dt) = putInQuotes $+                                      putByteString (BC.pack (formatTime defaultTimeLocale "%F %T%Q" dt))+putTextField (MySQLDate       d) = putInQuotes $+                                      putByteString (BC.pack (formatTime defaultTimeLocale "%F" d))+putTextField (MySQLTime  sign t) = putInQuotes $ do+                                      when (sign == 1) (putCharUtf8 '-')+                                      putByteString (BC.pack (formatTime defaultTimeLocale "%T%Q" t))+                                      -- this works even for hour > 24+putTextField (MySQLGeometry  bs) = putInQuotes $ putByteString . escapeBytes $ bs+putTextField (MySQLBytes     bs) = putInQuotes $ putByteString . escapeBytes $ bs+putTextField (MySQLText       t) = putInQuotes $+                                      putByteString . T.encodeUtf8 . escapeText $ t+putTextField (MySQLBit        b) = do putBuilder "b\'"+                                      putBuilder . execPut $ putTextBits b+                                      putCharUtf8 '\''+  where+    putTextBits :: Word64 -> Put+    putTextBits word = forM_ [63,62..0] $ \ pos ->+            if word `testBit` pos then putCharUtf8 '1' else putCharUtf8 '0'+    {-# INLINE putTextBits #-}++putTextField MySQLNull           = putBuilder "NULL"++putInQuotes :: Put -> Put+putInQuotes p = putCharUtf8 '\'' >> p >> putCharUtf8 '\''+{-# INLINE putInQuotes #-}++--------------------------------------------------------------------------------+-- | Text row decoder+getTextRow :: [ColumnDef] -> Get [MySQLValue]+getTextRow fs = forM fs $ \ f -> do+    p <- peek+    if p == 0xFB+    then skipN 1 >> return MySQLNull+    else getTextField f+{-# INLINE getTextRow #-}++getTextRowVector :: V.Vector ColumnDef -> Get (V.Vector MySQLValue)+getTextRowVector fs = V.forM fs $ \ f -> do+    p <- peek+    if p == 0xFB+    then skipN 1 >> return MySQLNull+    else getTextField f+{-# INLINE getTextRowVector #-}++--------------------------------------------------------------------------------+-- | Binary protocol decoder+getBinaryField :: ColumnDef -> Get MySQLValue+getBinaryField f+    | t == mySQLTypeNull              = pure MySQLNull+    | t == mySQLTypeDecimal+        || t == mySQLTypeNewDecimal   = feedLenEncBytes t MySQLDecimal fracLexer+    | t == mySQLTypeTiny              = if isUnsigned then MySQLInt8U <$> getWord8+                                                      else MySQLInt8  <$> getInt8+    | t == mySQLTypeShort             = if isUnsigned then MySQLInt16U <$> getWord16le+                                                      else MySQLInt16  <$> getInt16le+    | t == mySQLTypeLong+        || t == mySQLTypeInt24        = if isUnsigned then MySQLInt32U <$> getWord32le+                                                      else MySQLInt32  <$> getInt32le+    | t == mySQLTypeYear              = MySQLYear . fromIntegral <$> getWord16le+    | t == mySQLTypeLongLong          = if isUnsigned then MySQLInt64U <$> getWord64le+                                                      else MySQLInt64  <$> getInt64le+    | t == mySQLTypeFloat             = MySQLFloat  <$> getFloatle+    | t == mySQLTypeDouble            = MySQLDouble <$> getDoublele+    | t == mySQLTypeTimestamp+        || t == mySQLTypeTimestamp2   = do+            n <- getLenEncInt+            case n of+               0 -> pure $ MySQLTimeStamp (LocalTime (fromGregorian 0 0 0) (TimeOfDay 0 0 0))+               4 -> do+                   d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8'+                   pure $ MySQLTimeStamp (LocalTime d (TimeOfDay 0 0 0))+               7 -> do+                   d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8'+                   td <- TimeOfDay <$> getInt8' <*> getInt8' <*> getSecond4+                   pure $ MySQLTimeStamp (LocalTime d td)+               11 -> do+                   d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8'+                   td <- TimeOfDay <$> getInt8' <*> getInt8' <*> getSecond8+                   pure $ MySQLTimeStamp (LocalTime d td)+               _ -> fail "Database.MySQL.Protocol.MySQLValue: wrong TIMESTAMP length"+    | t == mySQLTypeDateTime+        || t == mySQLTypeDateTime2    = do+            n <- getLenEncInt+            case n of+               0 -> pure $ MySQLDateTime (LocalTime (fromGregorian 0 0 0) (TimeOfDay 0 0 0))+               4 -> do+                   d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8'+                   pure $ MySQLDateTime (LocalTime d (TimeOfDay 0 0 0))+               7 -> do+                   d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8'+                   td <- TimeOfDay <$> getInt8' <*> getInt8' <*> getSecond4+                   pure $ MySQLDateTime (LocalTime d td)+               11 -> do+                   d <- fromGregorian <$> getYear <*> getInt8' <*> getInt8'+                   td <- TimeOfDay <$> getInt8' <*> getInt8' <*> getSecond8+                   pure $ MySQLDateTime (LocalTime d td)+               _ -> fail "Database.MySQL.Protocol.MySQLValue: wrong DATETIME length"++    | t == mySQLTypeDate+        || t == mySQLTypeNewDate      = do+            n <- getLenEncInt+            case n of+               0 -> pure $ MySQLDate (fromGregorian 0 0 0)+               4 -> MySQLDate <$> (fromGregorian <$> getYear <*> getInt8' <*> getInt8')+               _ -> fail "Database.MySQL.Protocol.MySQLValue: wrong DATE length"++    | t == mySQLTypeTime+        || t == mySQLTypeTime2        = do+            n <- getLenEncInt+            case n of+               0 -> pure $ MySQLTime 0 (TimeOfDay 0 0 0)+               8 -> do+                   sign <- getWord8   -- is_negative(1 if minus, 0 for plus)+                   d <- fromIntegral <$> getWord32le+                   h <-  getInt8'+                   MySQLTime sign <$> (TimeOfDay (d*24 + h) <$> getInt8' <*> getSecond4)++               12 -> do+                   sign <- getWord8   -- is_negative(1 if minus, 0 for plus)+                   d <- fromIntegral <$> getWord32le+                   h <-  getInt8'+                   MySQLTime sign <$> (TimeOfDay (d*24 + h) <$> getInt8' <*> getSecond8)+               _ -> fail "Database.MySQL.Protocol.MySQLValue: wrong TIME length"++    | t == mySQLTypeGeometry          = MySQLGeometry <$> getLenEncBytes+    | t == mySQLTypeVarChar+        || t == mySQLTypeEnum+        || t == mySQLTypeSet+        || t == mySQLTypeTinyBlob+        || t == mySQLTypeMediumBlob+        || t == mySQLTypeLongBlob+        || t == mySQLTypeBlob+        || t == mySQLTypeVarString+        || t == mySQLTypeString       = if isText then MySQLText . T.decodeUtf8 <$> getLenEncBytes+                                                  else MySQLBytes <$> getLenEncBytes+    | t == mySQLTypeBit               = MySQLBit <$> (getBits =<< getLenEncInt)+    | otherwise                       = fail $ "Database.MySQL.Protocol.MySQLValue:\+                                               \ missing binary decoder for " ++ show t+  where+    t = columnType f+    isUnsigned = flagUnsigned (columnFlags f)+    isText = columnCharSet f /= 63+    fracLexer bs = fst <$> LexFrac.readSigned LexFrac.readDecimal bs+    getYear :: Get Integer+    getYear = fromIntegral <$> getWord16le+    getInt8' :: Get Int+    getInt8' = fromIntegral <$> getWord8+    getSecond4 :: Get Pico+    getSecond4 = realToFrac <$> getWord8+    getSecond8 :: Get Pico+    getSecond8 = realToFrac <$> do+        s <- getInt8'+        ms <- fromIntegral <$> getWord32le :: Get Int+        pure $! (realToFrac s + realToFrac ms / 1000000 :: Pico)+++-- | Get a bit sequence as a Word64+--+-- Since 'Word64' has a @Bits@ instance, it's easier to deal with in haskell.+--+getBits :: Int -> Get Word64+getBits bytes =+    if  | bytes == 0 || bytes == 1 -> fromIntegral <$> getWord8+        | bytes == 2 -> fromIntegral <$> getWord16be+        | bytes == 3 -> fromIntegral <$> getWord24be+        | bytes == 4 -> fromIntegral <$> getWord32be+        | bytes == 5 -> fromIntegral <$> getWord40be+        | bytes == 6 -> fromIntegral <$> getWord48be+        | bytes == 7 -> fromIntegral <$> getWord56be+        | bytes == 8 -> fromIntegral <$> getWord64be+        | otherwise  -> fail $  "Database.MySQL.Protocol.MySQLValue: \+                                \wrong bit length size: " ++ show bytes+{-# INLINE getBits #-}+++--------------------------------------------------------------------------------+-- | Binary protocol encoder+putBinaryField :: MySQLValue -> Put+putBinaryField (MySQLDecimal    n) = putLenEncBytes . L.toStrict . BB.toLazyByteString $+                                        formatScientificBuilder Fixed Nothing n+putBinaryField (MySQLInt8U      n) = putWord8 n+putBinaryField (MySQLInt8       n) = putWord8 (fromIntegral n)+putBinaryField (MySQLInt16U     n) = putWord16le n+putBinaryField (MySQLInt16      n) = putInt16le n+putBinaryField (MySQLInt32U     n) = putWord32le n+putBinaryField (MySQLInt32      n) = putInt32le n+putBinaryField (MySQLInt64U     n) = putWord64le n+putBinaryField (MySQLInt64      n) = putInt64le n+putBinaryField (MySQLFloat      x) = putFloatle x+putBinaryField (MySQLDouble     x) = putDoublele x+putBinaryField (MySQLYear       n) = putLenEncBytes . L.toStrict . BB.toLazyByteString $+                                        Textual.integral n  -- this's really weird, it's not documented anywhere+                                                            -- we must encode year into string in binary mode!+putBinaryField (MySQLTimeStamp (LocalTime date time)) = do putWord8 11    -- always put full+                                                           putBinaryDay date+                                                           putBinaryTime' time+putBinaryField (MySQLDateTime  (LocalTime date time)) = do putWord8 11    -- always put full+                                                           putBinaryDay date+                                                           putBinaryTime' time+putBinaryField (MySQLDate    d)    = do putWord8 4+                                        putBinaryDay d+putBinaryField (MySQLTime sign t)  = do putWord8 12    -- always put full+                                        putWord8 sign+                                        putBinaryTime t+putBinaryField (MySQLGeometry bs)  = putLenEncBytes bs+putBinaryField (MySQLBytes  bs)    = putLenEncBytes bs+putBinaryField (MySQLBit    word)  = do putWord8 8     -- always put full+                                        putWord64be word+putBinaryField (MySQLText    t)    = putLenEncBytes (T.encodeUtf8 t)+putBinaryField MySQLNull           = return ()++putBinaryDay :: Day -> Put+putBinaryDay d = do let (yyyy, mm, dd) = toGregorian d+                    putWord16le (fromIntegral yyyy)+                    putWord8 (fromIntegral mm)+                    putWord8 (fromIntegral dd)+{-# INLINE putBinaryDay #-}++putBinaryTime' :: TimeOfDay -> Put+putBinaryTime' (TimeOfDay hh mm ss) = do let s = floor ss+                                             ms = floor $ (ss - realToFrac s) * 1000000+                                         putWord8 (fromIntegral hh)+                                         putWord8 (fromIntegral mm)+                                         putWord8 s+                                         putWord32le ms+{-# INLINE putBinaryTime' #-}++putBinaryTime :: TimeOfDay -> Put+putBinaryTime (TimeOfDay hh mm ss) = do let s = floor ss+                                            ms = floor $ (ss - realToFrac s) * 1000000+                                            (d, h) = hh `quotRem` 24  -- hour may exceed 24 here+                                        putWord32le (fromIntegral d)+                                        putWord8 (fromIntegral h)+                                        putWord8 (fromIntegral mm)+                                        putWord8 s+                                        putWord32le ms+{-# INLINE putBinaryTime #-}++--------------------------------------------------------------------------------+-- | Binary row decoder+--+-- MySQL use a special null bitmap without offset = 2 here.+--+getBinaryRow :: [ColumnDef] -> Int -> Get [MySQLValue]+getBinaryRow fields flen = do+    skipN 1           -- 0x00+    let maplen = (flen + 7 + 2) `shiftR` 3+    nullmap <- BitMap <$> getByteString maplen+    go fields nullmap 0+  where+    go :: [ColumnDef] -> BitMap -> Int -> Get [MySQLValue]+    go []     _       _   = pure []+    go (f:fs) nullmap pos = do+        r <- if isColumnNull nullmap pos+                then return MySQLNull+                else getBinaryField f+        let pos' = pos + 1+        rest <- pos' `seq` go fs nullmap pos'+        return (r `seq` (r : rest))+{-# INLINE getBinaryRow #-}++getBinaryRowVector :: V.Vector ColumnDef -> Int -> Get (V.Vector MySQLValue)+getBinaryRowVector fields flen = do+    skipN 1           -- 0x00+    let maplen = (flen + 7 + 2) `shiftR` 3+    nullmap <- BitMap <$> getByteString maplen+    (`V.imapM` fields) $ \ pos f ->+        if isColumnNull nullmap pos then return MySQLNull else getBinaryField f+{-# INLINE getBinaryRowVector #-}++--------------------------------------------------------------------------------+-- | Use 'ByteString' to present a bitmap.+--+-- When used for represent bits values, the underlining 'ByteString' follows:+--+--  * byteString: head       -> tail+--  * bit:        high bit   -> low bit+--+-- When used as a null-map/present-map, every bit inside a byte+-- is mapped to a column, the mapping order is following:+--+--  * byteString: head -> tail+--  * column:     left -> right+--+-- We don't use 'Int64' here because there maybe more than 64 columns.+--+newtype BitMap = BitMap { fromBitMap :: ByteString } deriving (Eq, Show)++-- | Test if a column is set(binlog protocol).+--+-- The number counts from left to right.+--+isColumnSet :: BitMap -> Int -> Bool+isColumnSet (BitMap bitmap) pos =+  let i = pos `unsafeShiftR` 3+      j = pos .&. 7+  in (bitmap `B.unsafeIndex` i) `testBit` j+{-# INLINE isColumnSet #-}++-- | Test if a column is null(binary protocol).+--+-- The number counts from left to right.+--+isColumnNull :: BitMap -> Int -> Bool+isColumnNull (BitMap nullmap) pos =+  let+    pos' = pos + 2+    i    = pos' `unsafeShiftR` 3+    j    = pos' .&. 7+  in (nullmap `B.unsafeIndex` i) `testBit` j+{-# INLINE isColumnNull #-}++-- | Make a nullmap for params(binary protocol) without offset.+--+makeNullMap :: [MySQLValue] -> BitMap+makeNullMap values = BitMap . B.pack $ go values 0x00 0+  where+    go :: [MySQLValue] -> Word8 -> Int -> [Word8]+    go []             byte   8  = [byte]+    go vs             byte   8  = byte : go vs 0x00 0+    go []             byte   _  = [byte]+    go (MySQLNull:vs) byte pos  = let pos' = pos + 1+                                      byte' = byte .|. bit pos+                                  in pos' `seq` byte' `seq` go vs byte' pos'+    go (_        :vs) byte pos  = let pos' = pos + 1 in pos' `seq` go vs byte pos'++--------------------------------------------------------------------------------+-- TODO: add helpers to parse mySQLTypeGEOMETRY+-- reference: https://github.com/felixge/node-mysql/blob/master/lib/protocol/Parser.js
+ src/Database/MySQL/Protocol/Packet.hs view
@@ -0,0 +1,300 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++{-|+Module      : Database.MySQL.Protocol.Packet+Description : MySQL packet type and various helpers.+Copyright   : (c) Winterland, 2016+License     : BSD+Maintainer  : drkoster@qq.com+Stability   : experimental+Portability : PORTABLE++MySQL packet decoder&encoder, and varities utility.++-}++module Database.MySQL.Protocol.Packet where++import           Control.Applicative+import           Control.Exception     (Exception (..), throwIO)+import           Data.Binary.Parser+import           Data.Binary.Put+import           Data.Binary           (Binary(..), encode)+import           Data.Bits+import qualified Data.ByteString       as B+import           Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy  as L+import           Data.Int.Int24+import           Data.Int+import           Data.Word+import           Data.Typeable+import           Data.Word.Word24++--------------------------------------------------------------------------------+-- | MySQL packet type+--+data Packet = Packet+    { pLen  :: !Int64+    , pSeqN :: !Word8+    , pBody :: !L.ByteString+    } deriving (Show, Eq)++putPacket :: Packet -> Put+putPacket (Packet len seqN body)  = do+    putWord24le (fromIntegral len)+    putWord8 seqN+    putLazyByteString body+{-# INLINE putPacket #-}++getPacket :: Get Packet+getPacket = do+    len <- fromIntegral <$> getWord24le+    seqN <- getWord8+    body <- getLazyByteString (fromIntegral len)+    return (Packet len seqN body)+{-# INLINE getPacket #-}++instance Binary Packet where+    put = putPacket+    {-# INLINE put #-}+    get = getPacket+    {-# INLINE get #-}++isERR :: Packet -> Bool+isERR p = L.index (pBody p) 0 == 0xFF+{-# INLINE isERR #-}++isOK :: Packet -> Bool+isOK p  = L.index (pBody p) 0 == 0x00+{-# INLINE isOK #-}++isEOF :: Packet -> Bool+isEOF p = L.index (pBody p) 0 == 0xFE+{-# INLINE isEOF #-}++-- | Is there more packet to be read?+--+--  https://dev.mysql.com/doc/internals/en/status-flags.html+isThereMore :: OK -> Bool+isThereMore p  = okStatus p .&. 0x08 /= 0+{-# INLINE isThereMore #-}++-- | Decoding packet inside IO, throw 'DecodePacketException' on fail parsing,+-- here we choose stability over correctness by omit incomplete consumed case:+-- if we successful parse a packet, then we don't care if there're bytes left.+--+decodeFromPacket :: Binary a => Packet -> IO a+decodeFromPacket = getFromPacket get+{-# INLINE decodeFromPacket #-}++getFromPacket :: Get a -> Packet -> IO a+getFromPacket g (Packet _ _ body) = case parseDetailLazy g body of+    Left  (buf, offset, errmsg) -> throwIO (DecodePacketFailed buf offset errmsg)+    Right (_,   _,      r     ) -> return r+{-# INLINE getFromPacket #-}++data DecodePacketException = DecodePacketFailed ByteString ByteOffset String+  deriving (Typeable, Show)+instance Exception DecodePacketException++encodeToPacket :: Binary a => Word8 -> a -> Packet+encodeToPacket seqN payload =+    let s = encode payload+        l = L.length s+    in Packet (fromIntegral l) seqN s+{-# INLINE encodeToPacket #-}++putToPacket :: Word8 -> Put -> Packet+putToPacket seqN payload =+    let s = runPut payload+        l = L.length s+    in Packet (fromIntegral l) seqN s+{-# INLINE putToPacket #-}++--------------------------------------------------------------------------------+-- OK, ERR, EOF++-- | You may get interested in 'OK' packet because it provides information about+-- successful operations.+--+data OK = OK+    { okAffectedRows :: !Int      -- ^ affected row number+    , okLastInsertID :: !Int      -- ^ last insert's ID+    , okStatus       :: !Word16+    , okWarningCnt   :: !Word16+    } deriving (Show, Eq)++getOK :: Get OK+getOK = OK <$ skipN 1+           <*> getLenEncInt+           <*> getLenEncInt+           <*> getWord16le+           <*> getWord16le+{-# INLINE getOK #-}++putOK :: OK -> Put+putOK (OK row lid stat wcnt) = do+    putWord8 0x00+    putLenEncInt row+    putLenEncInt lid+    putWord16le stat+    putWord16le wcnt+{-# INLINE putOK #-}++instance Binary OK where+    get = getOK+    {-# INLINE get #-}+    put = putOK+    {-# INLINE put #-}++data ERR = ERR+    { errCode  :: !Word16+    , errState :: !ByteString+    , errMsg   :: !ByteString+    } deriving (Show, Eq)++getERR :: Get ERR+getERR = ERR <$  skipN 1+             <*> getWord16le+             <*  skipN 1+             <*> getByteString 5+             <*> getRemainingByteString+{-# INLINE getERR #-}++putERR :: ERR -> Put+putERR (ERR code stat msg) = do+    putWord8 0xFF+    putWord16le code+    putWord8 35 -- '#'+    putByteString stat+    putByteString msg+{-# INLINE putERR #-}++instance Binary ERR where+    get = getERR+    {-# INLINE get #-}+    put = putERR+    {-# INLINE put #-}++data EOF = EOF+    { eofWarningCnt :: !Word16+    , eofStatus     :: !Word16+    } deriving (Show, Eq)++getEOF :: Get EOF+getEOF = EOF <$  skipN 1+             <*> getWord16le+             <*> getWord16le+{-# INLINE getEOF #-}++putEOF :: EOF -> Put+putEOF (EOF wcnt stat) = do+    putWord8 0xFE+    putWord16le wcnt+    putWord16le stat+{-# INLINE putEOF #-}++instance Binary EOF where+    get = getEOF+    {-# INLINE get #-}+    put = putEOF+    {-# INLINE put #-}++--------------------------------------------------------------------------------+--  Helpers++getByteStringNul :: Get ByteString+getByteStringNul = L.toStrict <$> getLazyByteStringNul+{-# INLINE getByteStringNul #-}++getRemainingByteString :: Get ByteString+getRemainingByteString = L.toStrict <$> getRemainingLazyByteString+{-# INLINE getRemainingByteString #-}++putLenEncBytes :: ByteString -> Put+putLenEncBytes c = do+    putLenEncInt (B.length c)+    putByteString c+{-# INLINE putLenEncBytes #-}++getLenEncBytes :: Get ByteString+getLenEncBytes = getLenEncInt >>= getByteString+{-# INLINE getLenEncBytes #-}++-- | length encoded int+-- https://dev.mysql.com/doc/internals/en/integer.html#packet-Protocol::LengthEncodedInteger+getLenEncInt:: Get Int+getLenEncInt = getWord8 >>= word2Len+  where+    word2Len l+         | l <  0xFB  = pure (fromIntegral l)+         | l == 0xFC  = fromIntegral <$> getWord16le+         | l == 0xFD  = fromIntegral <$> getWord24le+         | l == 0xFE  = fromIntegral <$> getWord64le+         | otherwise = fail $ "invalid length val " ++ show l+{-# INLINE getLenEncInt #-}++putLenEncInt:: Int -> Put+putLenEncInt x+         | x <  251      = putWord8 (fromIntegral x)+         | x < 65536     = putWord8 0xFC >> putWord16le (fromIntegral x)+         | x < 16777216  = putWord8 0xFD >> putWord24le (fromIntegral x)+         | otherwise     = putWord8 0xFE >> putWord64le (fromIntegral x)+{-# INLINE putLenEncInt #-}++putWord24le :: Word32 -> Put+putWord24le v = do+    putWord16le $ fromIntegral v+    putWord8 $ fromIntegral (v `shiftR` 16)+{-# INLINE putWord24le #-}++getWord24le :: Get Word32+getWord24le = do+    a <- fromIntegral <$> getWord16le+    b <- fromIntegral <$> getWord8+    return $! a .|. (b `shiftL` 16)+{-# INLINE getWord24le #-}++putWord48le :: Word64 -> Put+putWord48le v = do+    putWord32le $ fromIntegral v+    putWord16le $ fromIntegral (v `shiftR` 32)+{-# INLINE putWord48le #-}++getWord48le :: Get Word64+getWord48le = do+    a <- fromIntegral <$> getWord32le+    b <- fromIntegral <$> getWord16le+    return $! a .|. (b `shiftL` 32)+{-# INLINE getWord48le #-}++getWord24be :: Get Word24+getWord24be = do+    a <- fromIntegral <$> getWord16be+    b <- fromIntegral <$> getWord8+    return $! b .|. (a `shiftL` 8)+{-# INLINE getWord24be #-}++getInt24be :: Get Int24+getInt24be = do+    a <- fromIntegral <$> getWord16be+    b <- fromIntegral <$> getWord8+    return $! fromIntegral $ (b .|. (a `shiftL` 8) :: Word24)+{-# INLINE getInt24be #-}++getWord40be, getWord48be, getWord56be :: Get Word64+getWord40be = do+    a <- fromIntegral <$> getWord32be+    b <- fromIntegral <$> getWord8+    return $! (a `shiftL` 8) .|. b+getWord48be = do+    a <- fromIntegral <$> getWord32be+    b <- fromIntegral <$> getWord16be+    return $! (a `shiftL` 16) .|. b+getWord56be = do+    a <- fromIntegral <$> getWord32be+    b <- fromIntegral <$> getWord24be+    return $! (a `shiftL` 24) .|. b+{-# INLINE getWord40be #-}+{-# INLINE getWord48be #-}+{-# INLINE getWord56be #-}
+ src/Database/MySQL/Query.hs view
@@ -0,0 +1,80 @@+module Database.MySQL.Query where++import           Data.String               (IsString (..))+import           Control.Exception         (throw, Exception)+import           Data.Typeable+import qualified Data.ByteString.Lazy      as L+import qualified Data.ByteString.Lazy.Char8     as LC+import qualified Data.ByteString.Builder   as BB+import           Control.Arrow             (first)+import           Database.MySQL.Protocol.MySQLValue+import           Data.Binary.Put++-- | Query string type borrowed from @mysql-simple@.+--+-- This type is intended to make it difficult to+-- construct a SQL query by concatenating string fragments, as that is+-- an extremely common way to accidentally introduce SQL injection+-- vulnerabilities into an application.+--+-- This type is an instance of 'IsString', so the easiest way to+-- construct a query is to enable the @OverloadedStrings@ language+-- extension and then simply write the query in double quotes.+--+-- The underlying type is a 'L.ByteString', and literal Haskell strings+-- that contain Unicode characters will be correctly transformed to+-- UTF-8.+--+newtype Query = Query { fromQuery :: L.ByteString } deriving (Eq, Ord, Typeable)++instance Show Query where+    show = show . fromQuery++instance Read Query where+    readsPrec i = fmap (first Query) . readsPrec i++instance IsString Query where+    fromString = Query . BB.toLazyByteString . BB.stringUtf8++-- | A type to wrap a query parameter in to allow for single and multi-valued parameters.+--+-- The behavior of 'Param' can be illustrated by following example:+--+-- @+--    render $ One (MySQLText "hello") = hello+--    render $ Many [MySQLText "hello", MySQLText "world"] = hello, world+--    render $ Many [] = null+-- @+--+-- So you can now write a query like this: @ SELECT * FROM test WHERE _id IN (?, 888) @+-- and use 'Many' 'Param' to fill the hole. There's no equivalent for prepared statement sadly.+--+data Param = One  MySQLValue+           | Many [MySQLValue]++-- | A type that may be used as a single parameter to a SQL query. Inspired from @mysql-simple@.+class QueryParam a where+    render :: a -> Put+    -- ^ Prepare a value for substitution into a query string.++instance QueryParam Param where+    render (One x)      = putTextField x+    render (Many [])    = putTextField MySQLNull+    render (Many (x:[]))= putTextField x+    render (Many (x:xs))= do putTextField x+                             mapM_ (\f -> putCharUtf8 ',' >> putTextField f) xs++instance QueryParam MySQLValue where+    render = putTextField++renderParams :: QueryParam p => Query -> [p] -> Query+renderParams (Query qry) params =+    let fragments = LC.split '?' qry+    in Query . runPut $ merge fragments params+  where+    merge [x]    []     = putLazyByteString x+    merge (x:xs) (y:ys) = putLazyByteString x >> render y >> merge xs ys+    merge _     _       = throw WrongParamsCount++data WrongParamsCount = WrongParamsCount deriving (Show, Typeable)+instance Exception WrongParamsCount
+ src/Database/MySQL/TLS.hs view
@@ -0,0 +1,75 @@+{-|+Module      : Database.MySQL.Connection+Description : TLS support for mysql-haskell via @tls@ package.+Copyright   : (c) Winterland, 2016+License     : BSD+Maintainer  : drkoster@qq.com+Stability   : experimental+Portability : PORTABLE++This module provides secure MySQL connection using 'tls' package, please make sure your certificate is v3 extension enabled.++-}++module Database.MySQL.TLS (+      connect+    , connectDetail+    , module Data.TLSSetting+    ) where++import           Control.Exception              (bracketOnError, throwIO)+import qualified Data.Binary                    as Binary+import qualified Data.Binary.Put                as Binary+import qualified Data.Connection                as Conn+import           Data.IORef                     (newIORef)+import           Data.TLSSetting+import           Database.MySQL.Connection      hiding (connect, connectDetail)+import           Database.MySQL.Protocol.Auth+import           Database.MySQL.Protocol.Packet+import qualified Network.TLS                    as TLS+import qualified System.IO.Streams.TCP          as TCP+import qualified Data.Connection                as TCP+import qualified System.IO.Streams.TLS          as TLS++--------------------------------------------------------------------------------++-- | Provide a 'TLS.ClientParams' and a subject name to establish a TLS connection.+--+connect :: ConnectInfo -> (TLS.ClientParams, String) -> IO MySQLConn+connect c cp = fmap snd (connectDetail c cp)++connectDetail :: ConnectInfo -> (TLS.ClientParams, String) -> IO (Greeting, MySQLConn)+connectDetail (ConnectInfo host port db user pass charset) (cparams, subName) =+    bracketOnError (connectWithBufferSize host port bUFSIZE)+       (TCP.close) $ \ c -> do+            let is = TCP.source c+            is' <- decodeInputStream is+            p <- readPacket is'+            greet <- decodeFromPacket p+            if supportTLS (greetingCaps greet)+            then do+                let cparams' = cparams {+                            TLS.clientUseServerNameIndication = False+                        ,   TLS.clientServerIdentification = (subName, "")+                        }+                let (sock, sockAddr) = Conn.connExtraInfo c+                write c (encodeToPacket 1 $ sslRequest charset)+                bracketOnError (TLS.contextNew sock cparams')+                               ( \ ctx -> TLS.bye ctx >> TCP.close c ) $ \ ctx -> do+                    TLS.handshake ctx+                    tc <- TLS.tLsToConnection (ctx, sockAddr)+                    let tlsIs = TCP.source tc+                    tlsIs' <- decodeInputStream tlsIs+                    let auth = mkAuth db user pass charset greet+                    write tc (encodeToPacket 2 auth)+                    q <- readPacket tlsIs'+                    if isOK q+                    then do+                        consumed <- newIORef True+                        let conn = MySQLConn tlsIs' (write tc) (TCP.close tc) consumed+                        return (greet, conn)+                    else TCP.close c >> decodeFromPacket q >>= throwIO . ERRException+            else error "Database.MySQL.TLS: server doesn't support TLS connection"+  where+    connectWithBufferSize h p bs = TCP.connectSocket h p >>= TCP.socketToConnection bs+    write c a = TCP.send c $ Binary.runPut . Binary.put $ a
+ src/System/IO/Streams/Binary.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings  #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Sytem.IO.Streams.Binary+-- Copyright   :  Petter Bergman, Winterland+-- License     :  BSD3+--+-- Maintainer  :  Winterland+-- Stability   :  experimental+--+-- Use binary to encode/decode io-streams.+--------------------------------------------------------------------------------++module System.IO.Streams.Binary (+    -- * single element encode/decode+      getFromStream+    , decodeFromStream+    , putToStream+    -- * 'InputStream' encode/decode+    , getInputStream+    , decodeInputStream+    -- * 'OutputStream' encode+    , putOutputStream+    , encodeOutputStream+    -- * exception type+    , DecodeException(..)+    ) where++--------------------------------------------------------------------------------++import           Control.Exception            (Exception, throwIO)+import           Control.Monad                (unless)+import           Data.Binary                  (Binary, get, put)+import qualified Data.Binary.Parser           as P+import           Data.Binary.Get              (ByteOffset, Decoder(..), Get)+import           Data.Binary.Put              (runPut, Put)+import           Data.ByteString              (ByteString)+import qualified Data.ByteString              as S+import           Data.Typeable                (Typeable)+import           System.IO.Streams            (InputStream, OutputStream)+import qualified System.IO.Streams            as Streams+import           System.IO.Streams.ByteString (writeLazyByteString)++--------------------------------------------------------------------------------++-- | An Exception raised when binary decoding fails.+--+-- it contains offset information where cereal don't.+data DecodeException = DecodeException ByteString ByteOffset String+  deriving (Typeable)++instance Show DecodeException where+  show (DecodeException buf offset message) =+        "DecodeException\nbuf:" ++ show buf ++ "\noffset:" ++ show offset ++ "\nmessage:" ++ show message++instance Exception DecodeException++--------------------------------------------------------------------------------++-- | Write an instance of 'Binary' to an 'OutputStream'.+putToStream :: Binary a => Maybe a -> OutputStream ByteString -> IO ()+putToStream Nothing  os = Streams.write Nothing os+putToStream (Just x) os = writeLazyByteString ((runPut . put) x) os+{-# INLINE putToStream #-}++--------------------------------------------------------------------------------++-- | Take a 'Get' and an 'InputStream' and decode a+-- value. Consumes only as much input as necessary to decode the+-- value. Unconsumed input will be unread. If there is+-- an error while deserializing, a 'DecodeException' is thrown, and+-- unconsumed part will be unread. binary decoder use 'Nothing'+-- to indicate input end, so EOFs/Nothing will close a binary decoder.+-- Examples:+--+-- >>> import qualified System.IO.Streams as Streams+-- >>> getFromStream (get :: Get String) =<< Streams.fromLazyByteString (Data.ByteString.Lazy.drop 1 $ runPut $ put "encode me")+-- *** Exception: System.IO.Streams.Binary: binary decode exception: offset 16, "not enough bytes"+--+getFromStream :: Get a -> InputStream ByteString -> IO (Maybe a)+getFromStream g is = Streams.read is >>= maybe (return Nothing) (go . P.parse g)+  where go (Fail s offset message) = do+            unless (S.null s) (Streams.unRead s is)+            throwIO $ DecodeException s offset message+        go (Done s _ x) = do+            unless (S.null s) (Streams.unRead s is)+            return (Just x)+        go (Partial p) = Streams.read is >>= go .  p+{-# INLINE getFromStream #-}++-- | typeclass version of 'getFromStream'+decodeFromStream :: Binary a => InputStream ByteString -> IO (Maybe a)+decodeFromStream = getFromStream get+{-# INLINE decodeFromStream #-}++--------------------------------------------------------------------------------++-- | Convert a stream of individual encoded 'ByteString's to a stream+-- of Results. Throws a 'DecodeException' on error.+getInputStream :: Get a -> InputStream ByteString -> IO (InputStream a)+getInputStream g = Streams.makeInputStream . getFromStream g+{-# INLINE getInputStream #-}++-- | typeclass version of 'getInputStream'+decodeInputStream :: Binary a => InputStream ByteString -> IO (InputStream a)+decodeInputStream = Streams.makeInputStream . decodeFromStream+{-# INLINE decodeInputStream #-}++--------------------------------------------------------------------------------++-- | create an 'OutputStream' of serializable values from an 'OutputStream'+-- of bytestrings with a 'Putter'.+putOutputStream :: (a -> Put) -> OutputStream ByteString -> IO (OutputStream a)+putOutputStream p os = Streams.makeOutputStream $ \ ma ->+    case ma of Nothing -> Streams.write Nothing os+               Just a -> writeLazyByteString (runPut (p a)) os+{-# INLINE putOutputStream #-}++-- | typeclass version of 'putOutputStream'+encodeOutputStream :: Binary a => OutputStream ByteString -> IO (OutputStream a)+encodeOutputStream = putOutputStream put+{-# INLINE encodeOutputStream #-}
+ test/Aeson.hs view
@@ -0,0 +1,346 @@+{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}++module Aeson where++import Data.ByteString.Builder+  (Builder, byteString, toLazyByteString, charUtf8, word8)++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((*>), (<$>), (<*), pure)+import Data.Monoid (mappend, mempty)+#endif++import Control.Applicative (liftA2)+import Control.DeepSeq (NFData(..))+import Control.Monad (forM)+import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific,+                                         skipSpace, string)+import Data.Bits ((.|.), shiftL)+import Data.ByteString (ByteString)+import Data.Char (chr)+import Data.List (sort)+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8')+import Data.Vector as Vector (Vector, foldl', fromList)+import Data.Word (Word8)+import System.Directory (getDirectoryContents)+import System.FilePath ((</>), dropExtension)+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.Lazy as L+import qualified Data.Attoparsec.Zepto as Z+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Unsafe as B+import qualified Data.HashMap.Strict as H+import System.Directory (doesDirectoryExist)++#define BACKSLASH 92+#define CLOSE_CURLY 125+#define CLOSE_SQUARE 93+#define COMMA 44+#define DOUBLE_QUOTE 34+#define OPEN_CURLY 123+#define OPEN_SQUARE 91+#define C_0 48+#define C_9 57+#define C_A 65+#define C_F 70+#define C_a 97+#define C_f 102+#define C_n 110+#define C_t 116++pathTo :: String -> IO FilePath+pathTo wat = do+  exists <- doesDirectoryExist "bench"+  return $ if exists+           then "bench" </> wat+           else wat++data Result a = Error String+              | Success a+                deriving (Eq, Show)+++-- | A JSON \"object\" (key\/value map).+type Object = H.HashMap Text Value++-- | A JSON \"array\" (sequence).+type Array = Vector Value++-- | A JSON value represented as a Haskell value.+data Value = Object !Object+           | Array !Array+           | String !Text+           | Number !Scientific+           | Bool !Bool+           | Null+             deriving (Eq, Show)++instance NFData Value where+    rnf (Object o) = rnf o+    rnf (Array a)  = Vector.foldl' (\x y -> rnf y `seq` x) () a+    rnf (String s) = rnf s+    rnf (Number n) = rnf n+    rnf (Bool b)   = rnf b+    rnf Null       = ()++-- | Parse a top-level JSON value.  This must be either an object or+-- an array, per RFC 4627.+--+-- The conversion of a parsed value to a Haskell value is deferred+-- until the Haskell value is needed.  This may improve performance if+-- only a subset of the results of conversions are needed, but at a+-- cost in thunk allocation.+json :: Parser Value+json = json_ object_ array_++-- | Parse a top-level JSON value.  This must be either an object or+-- an array, per RFC 4627.+--+-- This is a strict version of 'json' which avoids building up thunks+-- during parsing; it performs all conversions immediately.  Prefer+-- this version if most of the JSON data needs to be accessed.+json' :: Parser Value+json' = json_ object_' array_'++json_ :: Parser Value -> Parser Value -> Parser Value+json_ obj ary = do+  w <- skipSpace *> A.satisfy (\w -> w == OPEN_CURLY || w == OPEN_SQUARE)+  if w == OPEN_CURLY+    then obj+    else ary+{-# INLINE json_ #-}++object_ :: Parser Value+object_ = {-# SCC "object_" #-} Object <$> objectValues jstring value++object_' :: Parser Value+object_' = {-# SCC "object_'" #-} do+  !vals <- objectValues jstring' value'+  return (Object vals)+ where+  jstring' = do+    !s <- jstring+    return s++objectValues :: Parser Text -> Parser Value -> Parser (H.HashMap Text Value)+objectValues str val = do+  skipSpace+  let pair = liftA2 (,) (str <* skipSpace) (char ':' *> skipSpace *> val)+  H.fromList <$> commaSeparated pair CLOSE_CURLY+{-# INLINE objectValues #-}++array_ :: Parser Value+array_ = {-# SCC "array_" #-} Array <$> arrayValues value++array_' :: Parser Value+array_' = {-# SCC "array_'" #-} do+  !vals <- arrayValues value'+  return (Array vals)++commaSeparated :: Parser a -> Word8 -> Parser [a]+commaSeparated item endByte = do+  w <- A.peekWord8'+  if w == endByte+    then A.anyWord8 >> return []+    else loop+  where+    loop = do+      v <- item <* skipSpace+      ch <- A.satisfy $ \w -> w == COMMA || w == endByte+      if ch == COMMA+        then skipSpace >> (v:) <$> loop+        else return [v]+{-# INLINE commaSeparated #-}++arrayValues :: Parser Value -> Parser (Vector Value)+arrayValues val = do+  skipSpace+  Vector.fromList <$> commaSeparated val CLOSE_SQUARE+{-# INLINE arrayValues #-}++-- | Parse any JSON value.  You should usually 'json' in preference to+-- this function, as this function relaxes the object-or-array+-- requirement of RFC 4627.+--+-- In particular, be careful in using this function if you think your+-- code might interoperate with Javascript.  A na&#xef;ve Javascript+-- library that parses JSON data using @eval@ is vulnerable to attack+-- unless the encoded data represents an object or an array.  JSON+-- implementations in other languages conform to that same restriction+-- to preserve interoperability and security.+value :: Parser Value+value = do+  w <- A.peekWord8'+  case w of+    DOUBLE_QUOTE  -> A.anyWord8 *> (String <$> jstring_)+    OPEN_CURLY    -> A.anyWord8 *> object_+    OPEN_SQUARE   -> A.anyWord8 *> array_+    C_f           -> string "false" *> pure (Bool False)+    C_t           -> string "true" *> pure (Bool True)+    C_n           -> string "null" *> pure Null+    _              | w >= 48 && w <= 57 || w == 45+                  -> Number <$> scientific+      | otherwise -> fail "not a valid json value"++-- | Strict version of 'value'. See also 'json''.+value' :: Parser Value+value' = do+  w <- A.peekWord8'+  case w of+    DOUBLE_QUOTE  -> do+                     !s <- A.anyWord8 *> jstring_+                     return (String s)+    OPEN_CURLY    -> A.anyWord8 *> object_'+    OPEN_SQUARE   -> A.anyWord8 *> array_'+    C_f           -> string "false" *> pure (Bool False)+    C_t           -> string "true" *> pure (Bool True)+    C_n           -> string "null" *> pure Null+    _              | w >= 48 && w <= 57 || w == 45+                  -> do+                     !n <- scientific+                     return (Number n)+      | otherwise -> fail "not a valid json value"++-- | Parse a quoted JSON string.+jstring :: Parser Text+jstring = A.word8 DOUBLE_QUOTE *> jstring_++-- | Parse a string without a leading quote.+jstring_ :: Parser Text+jstring_ = {-# SCC "jstring_" #-} do+  s <- A.scan False $ \s c -> if s then Just False+                                   else if c == DOUBLE_QUOTE+                                        then Nothing+                                        else Just (c == BACKSLASH)+  _ <- A.word8 DOUBLE_QUOTE+  s1 <- if BACKSLASH `B.elem` s+        then case Z.parse unescape s of+            Right r  -> return r+            Left err -> fail err+         else return s++  case decodeUtf8' s1 of+      Right r  -> return r+      Left err -> fail $ show err++{-# INLINE jstring_ #-}++unescape :: Z.Parser ByteString+unescape = toByteString <$> go mempty where+  go acc = do+    h <- Z.takeWhile (/=BACKSLASH)+    let rest = do+          start <- Z.take 2+          let !slash = B.unsafeHead start+              !t = B.unsafeIndex start 1+              escape = case B.findIndex (==t) "\"\\/ntbrfu" of+                         Just i -> i+                         _      -> 255+          if slash /= BACKSLASH || escape == 255+            then fail "invalid JSON escape sequence"+            else do+            let cont m = go (acc `mappend` byteString h `mappend` m)+                {-# INLINE cont #-}+            if t /= 117 -- 'u'+              then cont (word8 (B.unsafeIndex mapping escape))+              else do+                   a <- hexQuad+                   if a < 0xd800 || a > 0xdfff+                     then cont (charUtf8 (chr a))+                     else do+                       b <- Z.string "\\u" *> hexQuad+                       if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff+                         then let !c = ((a - 0xd800) `shiftL` 10) ++                                       (b - 0xdc00) + 0x10000+                              in cont (charUtf8 (chr c))+                         else fail "invalid UTF-16 surrogates"+    done <- Z.atEnd+    if done+      then return (acc `mappend` byteString h)+      else rest+  mapping = "\"\\/\n\t\b\r\f"++hexQuad :: Z.Parser Int+hexQuad = do+  s <- Z.take 4+  let hex n | w >= C_0 && w <= C_9 = w - C_0+            | w >= C_a && w <= C_f = w - 87+            | w >= C_A && w <= C_F = w - 55+            | otherwise          = 255+        where w = fromIntegral $ B.unsafeIndex s n+      a = hex 0; b = hex 1; c = hex 2; d = hex 3+  if (a .|. b .|. c .|. d) /= 255+    then return $! d .|. (c `shiftL` 4) .|. (b `shiftL` 8) .|. (a `shiftL` 12)+    else fail "invalid hex escape"++decodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString -> Maybe a+decodeWith p to s =+    case L.parse p s of+      L.Done _ v -> case to v of+                      Success a -> Just a+                      _         -> Nothing+      _          -> Nothing+{-# INLINE decodeWith #-}++decodeStrictWith :: Parser Value -> (Value -> Result a) -> B.ByteString+                 -> Maybe a+decodeStrictWith p to s =+    case either Error to (A.parseOnly p s) of+      Success a -> Just a+      Error _ -> Nothing+{-# INLINE decodeStrictWith #-}++eitherDecodeWith :: Parser Value -> (Value -> Result a) -> L.ByteString+                 -> Either String a+eitherDecodeWith p to s =+    case L.parse p s of+      L.Done _ v -> case to v of+                      Success a -> Right a+                      Error msg -> Left msg+      L.Fail _ _ msg -> Left msg+{-# INLINE eitherDecodeWith #-}++eitherDecodeStrictWith :: Parser Value -> (Value -> Result a) -> B.ByteString+                       -> Either String a+eitherDecodeStrictWith p to s =+    case either Error to (A.parseOnly p s) of+      Success a -> Right a+      Error msg -> Left msg+{-# INLINE eitherDecodeStrictWith #-}++-- $lazy+--+-- The 'json' and 'value' parsers decouple identification from+-- conversion.  Identification occurs immediately (so that an invalid+-- JSON document can be rejected as early as possible), but conversion+-- to a Haskell value is deferred until that value is needed.+--+-- This decoupling can be time-efficient if only a smallish subset of+-- elements in a JSON value need to be inspected, since the cost of+-- conversion is zero for uninspected elements.  The trade off is an+-- increase in memory usage, due to allocation of thunks for values+-- that have not yet been converted.++-- $strict+--+-- The 'json'' and 'value'' parsers combine identification with+-- conversion.  They consume more CPU cycles up front, but have a+-- smaller memory footprint.++-- | Parse a top-level JSON value followed by optional whitespace and+-- end-of-input.  See also: 'json'.+jsonEOF :: Parser Value+jsonEOF = json <* skipSpace <* endOfInput++-- | Parse a top-level JSON value followed by optional whitespace and+-- end-of-input.  See also: 'json''.+jsonEOF' :: Parser Value+jsonEOF' = json' <* skipSpace <* endOfInput++toByteString :: Builder -> ByteString+toByteString = L.toStrict . toLazyByteString+{-# INLINE toByteString #-}
+ test/AesonBP.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}++module AesonBP where++import Data.ByteString.Builder+  (Builder, byteString, toLazyByteString, charUtf8, word8)++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((*>), (<$>), (<*), pure)+import Data.Monoid (mappend, mempty)+#endif++import Control.Applicative (liftA2)+import Control.DeepSeq (NFData(..))+import Control.Monad (forM)+import Data.Bits ((.|.), shiftL)+import Data.ByteString (ByteString)+import Data.Char (chr)+import Data.List (sort)+import Data.Scientific (Scientific)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8')+import Data.Vector as Vector (Vector, foldl', fromList)+import Data.Word (Word8)+import System.Directory (getDirectoryContents)+import System.FilePath ((</>), dropExtension)+import qualified Data.Attoparsec.Zepto as Z+import Data.Binary.Get (Get)+import qualified Data.Binary.Parser as BP+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Unsafe as B+import qualified Data.HashMap.Strict as H+import System.Directory (doesDirectoryExist)+import Aeson (Value(..))++#define BACKSLASH 92+#define CLOSE_CURLY 125+#define CLOSE_SQUARE 93+#define COMMA 44+#define COLON 58+#define DOUBLE_QUOTE 34+#define OPEN_CURLY 123+#define OPEN_SQUARE 91+#define C_0 48+#define C_9 57+#define C_A 65+#define C_F 70+#define C_a 97+#define C_f 102+#define C_n 110+#define C_t 116++pathTo :: String -> IO FilePath+pathTo wat = do+  exists <- doesDirectoryExist "bench"+  return $ if exists+           then "bench" </> wat+           else wat++data Result a = Error String+              | Success a+                deriving (Eq, Show)+++-- | A JSON \"object\" (key\/value map).+type Object = H.HashMap Text Value++-- | A JSON \"array\" (sequence).+type Array = Vector Value++-- | Parse a top-level JSON value.  This must be either an object or+-- an array, per RFC 4627.+--+-- The conversion of a parsed value to a Haskell value is deferred+-- until the Haskell value is needed.  This may improve performance if+-- only a subset of the results of conversions are needed, but at a+-- cost in thunk allocation.+json :: Get Value+json = json_ object_ array_++-- | Parse a top-level JSON value.  This must be either an object or+-- an array, per RFC 4627.+--+-- This is a strict version of 'json' which avoids building up thunks+-- during parsing; it performs all conversions immediately.  Prefer+-- this version if most of the JSON data needs to be accessed.+json' :: Get Value+json' = json_ object_' array_'++json_ :: Get Value -> Get Value -> Get Value+json_ obj ary = do+  w <- BP.skipSpaces *> BP.satisfy (\w -> w == OPEN_CURLY || w == OPEN_SQUARE)+  if w == OPEN_CURLY+    then obj+    else ary+{-# INLINE json_ #-}++object_ :: Get Value+object_ = {-# SCC "object_" #-} Object <$> objectValues jstring value++object_' :: Get Value+object_' = {-# SCC "object_'" #-} do+  !vals <- objectValues jstring' value'+  return (Object vals)+ where+  jstring' = do+    !s <- jstring+    return s++objectValues :: Get Text -> Get Value -> Get (H.HashMap Text Value)+objectValues str val = do+  BP.skipSpaces+  let pair = liftA2 (,) (str <* BP.skipSpaces) (BP.word8 COLON *> BP.skipSpaces *> val)+  H.fromList <$> commaSeparated pair CLOSE_CURLY+{-# INLINE objectValues #-}++array_ :: Get Value+array_ = {-# SCC "array_" #-} Array <$> arrayValues value++array_' :: Get Value+array_' = {-# SCC "array_'" #-} do+  !vals <- arrayValues value'+  return (Array vals)++commaSeparated :: Get a -> Word8 -> Get [a]+commaSeparated item endByte = do+  w <- BP.peek+  if w == endByte+    then BP.skipN 1 >> return []+    else loop+  where+    loop = do+      v <- item <* BP.skipSpaces+      ch <- BP.satisfy $ \w -> w == COMMA || w == endByte+      if ch == COMMA+        then BP.skipSpaces >> (v:) <$> loop+        else return [v]+{-# INLINE commaSeparated #-}++arrayValues :: Get Value -> Get (Vector Value)+arrayValues val = do+  BP.skipSpaces+  Vector.fromList <$> commaSeparated val CLOSE_SQUARE+{-# INLINE arrayValues #-}++-- | Parse any JSON value.  You should usually 'json' in preference to+-- this function, as this function relaxes the object-or-array+-- requirement of RFC 4627.+--+-- In particular, be careful in using this function if you think your+-- code might interoperate with Javascript.  A na&#xef;ve Javascript+-- library that parses JSON data using @eval@ is vulnerable to attack+-- unless the encoded data represents an object or an array.  JSON+-- implementations in other languages conform to that same restriction+-- to preserve interoperability and security.+value :: Get Value+value = do+  w <- BP.peek+  case w of+    DOUBLE_QUOTE  -> BP.skipN 1 *> (String <$> jstring_)+    OPEN_CURLY    -> BP.skipN 1 *> object_+    OPEN_SQUARE   -> BP.skipN 1 *> array_+    C_f           -> BP.string "false" *> pure (Bool False)+    C_t           -> BP.string "true" *> pure (Bool True)+    C_n           -> BP.string "null" *> pure Null+    _              | w >= 48 && w <= 57 || w == 45+                  -> Number <$> BP.scientific+      | otherwise -> fail "not a valid json value"++-- | Strict version of 'value'. See also 'json''.+value' :: Get Value+value' = do+  w <- BP.peek+  case w of+    DOUBLE_QUOTE  -> do+                     !s <- BP.skipN 1 *> jstring_+                     return (String s)+    OPEN_CURLY    -> BP.skipN 1 *> object_'+    OPEN_SQUARE   -> BP.skipN 1 *> array_'+    C_f           -> BP.string "false" *> pure (Bool False)+    C_t           -> BP.string "true" *> pure (Bool True)+    C_n           -> BP.string "null" *> pure Null+    _              | w >= 48 && w <= 57 || w == 45+                  -> do+                     !n <- BP.scientific+                     return (Number n)+      | otherwise -> fail "not a valid json value"++-- | Parse a quoted JSON string.+jstring :: Get Text+jstring = BP.word8 DOUBLE_QUOTE *> jstring_++-- | Parse a string without a leading quote.+jstring_ :: Get Text+jstring_ = {-# SCC "jstring_" #-} do+  s <- BP.scan False $ \s c -> if s then Just False+                                   else if c == DOUBLE_QUOTE+                                        then Nothing+                                        else Just (c == BACKSLASH)+  BP.word8 DOUBLE_QUOTE+  s1 <- if BACKSLASH `B.elem` s+        then case Z.parse unescape s of+            Right r  -> return r+            Left err -> fail err+         else return s++  case decodeUtf8' s1 of+      Right r  -> return r+      Left err -> fail $ show err++{-# INLINE jstring_ #-}++unescape :: Z.Parser ByteString+unescape = toByteString <$> go mempty where+  go acc = do+    h <- Z.takeWhile (/=BACKSLASH)+    let rest = do+          start <- Z.take 2+          let !slash = B.unsafeHead start+              !t = B.unsafeIndex start 1+              escape = case B.findIndex (==t) "\"\\/ntbrfu" of+                         Just i -> i+                         _      -> 255+          if slash /= BACKSLASH || escape == 255+            then fail "invalid JSON escape sequence"+            else do+            let cont m = go (acc `mappend` byteString h `mappend` m)+                {-# INLINE cont #-}+            if t /= 117 -- 'u'+              then cont (word8 (B.unsafeIndex mapping escape))+              else do+                   a <- hexQuad+                   if a < 0xd800 || a > 0xdfff+                     then cont (charUtf8 (chr a))+                     else do+                       b <- Z.string "\\u" *> hexQuad+                       if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff+                         then let !c = ((a - 0xd800) `shiftL` 10) ++                                       (b - 0xdc00) + 0x10000+                              in cont (charUtf8 (chr c))+                         else fail "invalid UTF-16 surrogates"+    done <- Z.atEnd+    if done+      then return (acc `mappend` byteString h)+      else rest+  mapping = "\"\\/\n\t\b\r\f"++hexQuad :: Z.Parser Int+hexQuad = do+  s <- Z.take 4+  let hex n | w >= C_0 && w <= C_9 = w - C_0+            | w >= C_a && w <= C_f = w - 87+            | w >= C_A && w <= C_F = w - 55+            | otherwise          = 255+        where w = fromIntegral $ B.unsafeIndex s n+      a = hex 0; b = hex 1; c = hex 2; d = hex 3+  if (a .|. b .|. c .|. d) /= 255+    then return $! d .|. (c `shiftL` 4) .|. (b `shiftL` 8) .|. (a `shiftL` 12)+    else fail "invalid hex escape"++-- $lazy+--+-- The 'json' and 'value' parsers decouple identification from+-- conversion.  Identification occurs immediately (so that an invalid+-- JSON document can be rejected as early as possible), but conversion+-- to a Haskell value is deferred until that value is needed.+--+-- This decoupling can be time-efficient if only a smallish subset of+-- elements in a JSON value need to be inspected, since the cost of+-- conversion is zero for uninspected elements.  The trade off is an+-- increase in memory usage, due to allocation of thunks for values+-- that have not yet been converted.++-- $strict+--+-- The 'json'' and 'value'' parsers combine identification with+-- conversion.  They consume more CPU cycles up front, but have a+-- smaller memory footprint.++-- | Parse a top-level JSON value followed by optional whitespace and+-- end-of-input.  See also: 'json'.+jsonEOF :: Get Value+jsonEOF = json <* BP.skipSpaces++-- | Parse a top-level JSON value followed by optional whitespace and+-- end-of-input.  See also: 'json''.+jsonEOF' :: Get Value+jsonEOF' = json' <* BP.skipSpaces++toByteString :: Builder -> ByteString+toByteString = L.toStrict . toLazyByteString+{-# INLINE toByteString #-}
+ test/BinLog.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE NegativeLiterals    #-}+{-# LANGUAGE ScopedTypeVariables #-}++module BinLog where++import           Control.Applicative+import           Control.Exception+import           Control.Monad+import           Data.Text.Encoding    (encodeUtf8)+import           Data.Time.Clock.POSIX+import           Data.Time.Format+import           Data.Time.LocalTime+import           Database.MySQL.Base+import           Database.MySQL.BinLog+import qualified System.IO.Streams     as Stream+import           Test.Tasty.HUnit++eventProducer :: IO ()+eventProducer = do+    c <- connect defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell"}+    execute_ c q1+    execute_ c q2+    return ()++tests :: MySQLConn -> Assertion+tests c = do+    Just blt <- getLastBinLogTracker c+    x@(fd, _, _) <- dumpBinLog c 1002 blt False+    rowEventStream <- decodeRowBinLogEvent x++    let Just t = parseTimeM True defaultTimeLocale  "%F %T" "2016-08-08 17:25:59" :: Maybe LocalTime+    z <- getCurrentTimeZone+    let timestamp = round $ utcTimeToPOSIXSeconds (localTimeToUTC z t)++    Just (RowUpdateEvent _ _ tme ue) <- Stream.read rowEventStream+    assertEqual "decode update event cloumn" (updateColumnCnt ue) 30+    assertEqual "decode update event rows" (updateRowData ue)+        [+            (+                [ BinLogLong 0+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                , BinLogNull+                ], [ BinLogLong 0+                , BinLogBit 224+                , BinLogTiny (-128)+                , BinLogTiny (-1)+                , BinLogShort (-32768)+                , BinLogShort (-1)+                , BinLogInt24 (-8388608)+                , BinLogInt24 (-1)+                , BinLogLong (-2147483648)+                , BinLogLong (-1)+                , BinLogLongLong (-9223372036854775808)+                , BinLogLongLong (-1)+                , BinLogNewDecimal 1.2345678900123456789e9+                , BinLogFloat 3.14159+                , BinLogDouble 3.1415926535+                , BinLogDate 2016 8 8+                , BinLogDateTime 2016 8 8 17 25 59+                , BinLogTimeStamp timestamp+                , BinLogTime 0 199 59 59+                , BinLogYear 1999+                , BinLogBytes "12345678"+                , BinLogBytes (encodeUtf8 "韩冬真赞")+                , BinLogBytes "12345678"+                , BinLogBytes "12345678"+                , BinLogBytes "12345678"+                , BinLogBytes (encodeUtf8 "韩冬真赞")+                , BinLogBytes "12345678"+                , BinLogBytes (encodeUtf8 "韩冬真赞")+                , BinLogEnum 1+                , BinLogSet 3+                ]+            )+        ]++    Just (RowUpdateEvent _ _ tme ue) <- Stream.read rowEventStream+    assertEqual "decode update event rows" (updateRowData ue)+        [+            (+                [ BinLogLong 0+                , BinLogBit 224   -- 0b11100000+                , BinLogTiny (-128)+                , BinLogTiny (-1)+                , BinLogShort (-32768)+                , BinLogShort (-1)+                , BinLogInt24 (-8388608)+                , BinLogInt24 (-1)+                , BinLogLong (-2147483648)+                , BinLogLong (-1)+                , BinLogLongLong (-9223372036854775808)+                , BinLogLongLong (-1)+                , BinLogNewDecimal 1.2345678900123456789e9+                , BinLogFloat 3.14159+                , BinLogDouble 3.1415926535+                , BinLogDate 2016 8 8+                , BinLogDateTime 2016 8 8 17 25 59+                , BinLogTimeStamp timestamp+                , BinLogTime 0 199 59 59+                , BinLogYear 1999+                , BinLogBytes "12345678"+                , BinLogBytes (encodeUtf8 "韩冬真赞")+                , BinLogBytes "12345678"+                , BinLogBytes "12345678"+                , BinLogBytes "12345678"+                , BinLogBytes (encodeUtf8 "韩冬真赞")+                , BinLogBytes "12345678"+                , BinLogBytes (encodeUtf8 "韩冬真赞")+                , BinLogEnum 1+                , BinLogSet 3+                ],  [ BinLogLong 0+                , BinLogBit 57514   -- 0b1110000010101010+                , BinLogTiny (-1)+                , BinLogTiny (-1)+                , BinLogShort (-32768)+                , BinLogShort (-1)+                , BinLogInt24 (-1)+                , BinLogInt24 (-1)+                , BinLogLong (-1)+                , BinLogLong (-1)+                , BinLogLongLong (-9223372036854775808)+                , BinLogLongLong (-1)+                , BinLogNewDecimal -1.2345678900123456789e9+                , BinLogFloat -3.14159+                , BinLogDouble -3.1415926535+                , BinLogDate 1800 8 8+                , BinLogDateTime 1800 8 8 17 25 59+                , BinLogTimeStamp timestamp+                , BinLogTime 1 199 59 59+                , BinLogYear 1901+                , BinLogBytes "12345678"+                , BinLogBytes (encodeUtf8 "韩冬真赞")+                , BinLogBytes "12345678"+                , BinLogBytes "12345678"+                , BinLogBytes "12345678"+                , BinLogBytes (encodeUtf8 "韩冬真赞")+                , BinLogBytes "12345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123"+                , BinLogBytes (encodeUtf8 "韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞")+                , BinLogEnum 1+                , BinLogSet 3+                ]+            )+        ]+q1 :: Query+q1 =  "UPDATE test SET \+            \__bit        = b'11100000'                            ,\+            \__tinyInt    = -128                                   ,\+            \__tinyIntU   = 255                                    ,\+            \__smallInt   = -32768                                 ,\+            \__smallIntU  = 65535                                  ,\+            \__mediumInt  = -8388608                               ,\+            \__mediumIntU = 16777215                               ,\+            \__int        = -2147483648                            ,\+            \__intU       = 4294967295                             ,\+            \__bigInt     = -9223372036854775808                   ,\+            \__bigIntU    = 18446744073709551615                   ,\+            \__decimal    = 1234567890.0123456789                  ,\+            \__float      = 3.14159                                ,\+            \__double     = 3.1415926535                           ,\+            \__date       = '2016-08-08'                           ,\+            \__datetime   = '2016-08-08 17:25:59'                  ,\+            \__timestamp  = '2016-08-08 17:25:59'                  ,\+            \__time       = '-199:59:59'                           ,\+            \__year       = 1999                                   ,\+            \__char       = '12345678'                             ,\+            \__varchar    = '韩冬真赞'                             ,\+            \__binary     = '12345678'                             ,\+            \__varbinary  = '12345678'                             ,\+            \__tinyblob   = '12345678'                             ,\+            \__tinytext   = '韩冬真赞'                             ,\+            \__blob       = '12345678'                             ,\+            \__text       = '韩冬真赞'                             ,\+            \__enum       = 'foo'                                  ,\+            \__set        = 'foo,bar' WHERE __id=0"+++q2 :: Query+q2 =  "UPDATE test SET \+            \__bit        = b'1110000010101010'                    ,\+            \__tinyInt    = -1                                     ,\+            \__tinyIntU   = 255                                    ,\+            \__smallInt   = -32768                                 ,\+            \__smallIntU  = 65535                                  ,\+            \__mediumInt  = -1                                     ,\+            \__mediumIntU = 16777215                               ,\+            \__int        = -1                                     ,\+            \__intU       = 4294967295                             ,\+            \__bigInt     = -9223372036854775808                   ,\+            \__bigIntU    = 18446744073709551615                   ,\+            \__decimal    = -1234567890.0123456789                 ,\+            \__float      = -3.14159                                ,\+            \__double     = -3.1415926535                           ,\+            \__date       = '1800-08-08'                           ,\+            \__datetime   = '1800-08-08 17:25:59'                  ,\+            \__timestamp  = '2016-08-08 17:25:59'                  ,\+            \__time       = '199:59:59'                            ,\+            \__year       = 1901                                   ,\+            \__char       = '12345678'                             ,\+            \__varchar    = '韩冬真赞'                             ,\+            \__binary     = '12345678'                             ,\+            \__varbinary  = '12345678'                             ,\+            \__tinyblob   = '12345678'                             ,\+            \__tinytext   = '韩冬真赞'                             ,\+            \__blob       = '12345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123456781234567812345678123'                             ,\+            \__text       = '韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞韩冬真赞'                              ,\+            \__enum       = 'foo'                                  ,\+            \__set        = 'foo,bar' WHERE __id=0"
+ test/BinLogNew.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE NegativeLiterals    #-}+{-# LANGUAGE ScopedTypeVariables #-}++module BinLogNew where++import           Control.Applicative+import           Control.Exception+import           Control.Monad+import           Data.Time.Clock.POSIX+import           Data.Time.Format+import           Data.Time.LocalTime+import           Database.MySQL.Base+import           Database.MySQL.BinLog+import qualified System.IO.Streams     as Stream+import           Test.Tasty.HUnit++eventProducer :: IO ()+eventProducer = do+    c <- connect defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell"}+    execute_ c q1+    execute_ c q2+    execute_ c q3+    return ()++tests :: MySQLConn -> Assertion+tests c = do+    Just blt <- getLastBinLogTracker c+    x@(fd, _, _) <- dumpBinLog c 1002 blt False+    rowEventStream <- decodeRowBinLogEvent x++    let Just t = parseTimeM True defaultTimeLocale  "%F %T%Q" "2016-08-08 17:25:59.1234" :: Maybe LocalTime+    z <- getCurrentTimeZone+    let timestamp = round $ utcTimeToPOSIXSeconds (localTimeToUTC z t)++    Just (RowUpdateEvent _ _ tme ue) <- Stream.read rowEventStream+    assertEqual "decode update event cloumn" (updateColumnCnt ue) 4+    assertEqual "decode update event rows" (updateRowData ue)+        [+            (+                [ BinLogLong 0+                , BinLogNull+                , BinLogNull+                , BinLogNull+                ], [ BinLogLong 0+                   , BinLogDateTime2 2016 8 8 17 25 59 120000+                   , BinLogTimeStamp2 timestamp 123400+                   , BinLogTime2 0 199 59 59 123456+                   ]+            )+        ]++    Just (RowUpdateEvent _ _ tme ue) <- Stream.read rowEventStream+    assertEqual "decode update event rows" (updateRowData ue)+        [+            (+                [ BinLogLong 0+                  , BinLogDateTime2 2016 8 8 17 25 59 120000+                  , BinLogTimeStamp2 timestamp 123400+                  , BinLogTime2 0 199 59 59 123456+                ], [ BinLogLong 0+                  , BinLogDateTime2 2016 8 8 17 25 59 100000+                  , BinLogTimeStamp2 timestamp 123000+                  , BinLogTime2 1 199 59 59 123450+                ]+            )+        ]++    Just (RowUpdateEvent _ _ tme ue) <- Stream.read rowEventStream+    assertEqual "decode update event rows" (updateRowData ue)+        [+            (+                [ BinLogLong 0+                  , BinLogDateTime2 2016 8 8 17 25 59 100000+                  , BinLogTimeStamp2 timestamp 123000+                  , BinLogTime2 1 199 59 59 123450+                ], [ BinLogLong 0+                  , BinLogNull+                  , BinLogNull+                  , BinLogTime2 0 0 59 59 123450+                ]+            )+        ]++q1 :: Query+q1 = "UPDATE test_new SET \+     \__datetime   = '2016-08-08 17:25:59.12'                  ,\+     \__timestamp  = '2016-08-08 17:25:59.1234'                ,\+     \__time       = '-199:59:59.123456' WHERE __id=0;"++q2 :: Query+q2 = "UPDATE test_new SET \+     \__datetime   = '2016-08-08 17:25:59.1'                  ,\+     \__timestamp  = '2016-08-08 17:25:59.123'                ,\+     \__time       = '199:59:59.12345' WHERE __id=0;"+++q3 :: Query+q3 = "UPDATE test_new SET \+     \__datetime   = null                  ,\+     \__timestamp  = null                  ,\+     \__time       = '-00:59:59.12345' WHERE __id=0;"
+ test/BinaryRow.hs view
@@ -0,0 +1,419 @@+{-# LANGUAGE NegativeLiterals    #-}+{-# LANGUAGE ScopedTypeVariables #-}++module BinaryRow where++import           Control.Applicative+import           Control.Exception+import           Control.Monad+import           Data.Time.Calendar  (fromGregorian)+import           Data.Time.LocalTime (LocalTime (..), TimeOfDay (..))+import           Database.MySQL.Base+import qualified System.IO.Streams   as Stream+import           Test.Tasty.HUnit+import qualified Data.Text as T+import qualified Data.ByteString as B+import qualified Data.Vector as V++tests :: MySQLConn -> Assertion+tests c = do+    selStmt <- prepareStmt c "SELECT * FROM test"++    (f, is) <- queryStmt c selStmt []+    assertEqual "decode Field types" (columnType <$> f)+        [ mySQLTypeLong+        , mySQLTypeBit+        , mySQLTypeTiny+        , mySQLTypeTiny+        , mySQLTypeShort+        , mySQLTypeShort+        , mySQLTypeInt24+        , mySQLTypeInt24+        , mySQLTypeLong+        , mySQLTypeLong+        , mySQLTypeLongLong+        , mySQLTypeLongLong+        , mySQLTypeNewDecimal+        , mySQLTypeFloat+        , mySQLTypeDouble+        , mySQLTypeDate+        , mySQLTypeDateTime+        , mySQLTypeTimestamp+        , mySQLTypeTime+        , mySQLTypeYear+        , mySQLTypeString+        , mySQLTypeVarString+        , mySQLTypeString+        , mySQLTypeVarString+        , mySQLTypeBlob+        , mySQLTypeBlob+        , mySQLTypeBlob+        , mySQLTypeBlob+        , mySQLTypeString+        , mySQLTypeString+        ]++    Just v <- Stream.read is+    assertEqual "decode NULL values" v+        [ MySQLInt32 0+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        ]++    Stream.skipToEof is+--------------------------------------------------------------------------------+    let bitV = 43744 -- 0b1010101011100000++    execute_ c "UPDATE test SET \+                \__bit        = b'1010101011100000'                    ,\+                \__tinyInt    = -128                                   ,\+                \__tinyIntU   = 255                                    ,\+                \__smallInt   = -32768                                 ,\+                \__smallIntU  = 65535                                  ,\+                \__mediumInt  = -8388608                               ,\+                \__mediumIntU = 16777215                               ,\+                \__int        = -2147483648                            ,\+                \__intU       = 4294967295                             ,\+                \__bigInt     = -9223372036854775808                   ,\+                \__bigIntU    = 18446744073709551615                   ,\+                \__decimal    = 1234567890.0123456789                  ,\+                \__float      = 3.14159                                ,\+                \__double     = 3.1415926535                           ,\+                \__date       = '2016-08-08'                           ,\+                \__datetime   = '2016-08-08 17:25:59'                  ,\+                \__timestamp  = '2016-08-08 17:25:59'                  ,\+                \__time       = '-199:59:59'                           ,\+                \__year       = 1999                                   ,\+                \__char       = '12345678'                             ,\+                \__varchar    = '韩冬真赞'                             ,\+                \__binary     = '12345678'                             ,\+                \__varbinary  = '12345678'                             ,\+                \__tinyblob   = '12345678'                             ,\+                \__tinytext   = '韩冬真赞'                             ,\+                \__blob       = '12345678'                             ,\+                \__text       = '韩冬真赞'                             ,\+                \__enum       = 'foo'                                  ,\+                \__set        = 'foo,bar' WHERE __id=0"++    (_, is) <- queryStmt c selStmt []+    Just v <- Stream.read is++    assertEqual "decode binary protocol" v+        [ MySQLInt32 0+        , MySQLBit bitV+        , MySQLInt8 (-128)+        , MySQLInt8U 255+        , MySQLInt16 (-32768)+        , MySQLInt16U 65535+        , MySQLInt32 (-8388608)+        , MySQLInt32U 16777215+        , MySQLInt32 (-2147483648)+        , MySQLInt32U 4294967295+        , MySQLInt64 (-9223372036854775808)+        , MySQLInt64U 18446744073709551615+        , MySQLDecimal 1234567890.0123456789+        , MySQLFloat 3.14159+        , MySQLDouble 3.1415926535+        , MySQLDate (fromGregorian 2016 08 08)+        , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+        , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+        , MySQLTime 1 (TimeOfDay 199 59 59)+        , MySQLYear 1999+        , MySQLText "12345678"+        , MySQLText "韩冬真赞"+        , MySQLBytes "12345678"+        , MySQLBytes "12345678"+        , MySQLBytes "12345678"+        , MySQLText "韩冬真赞"+        , MySQLBytes "12345678"+        , MySQLText "韩冬真赞"+        , MySQLText "foo"+        , MySQLText "foo,bar"]+    Stream.skipToEof is++    (_, is') <- queryStmtVector c selStmt []+    Just v' <- Stream.read is'+    Stream.skipToEof is'++    assertEqual "decode binary protocol(queryStmtVector)" v (V.toList v')++--------------------------------------------------------------------------------+    updStmt <- prepareStmt c+            "UPDATE test SET \+            \__bit        = ?     ,\+            \__tinyInt    = ?     ,\+            \__tinyIntU   = ?     ,\+            \__smallInt   = ?     ,\+            \__smallIntU  = ?     ,\+            \__mediumInt  = ?     ,\+            \__mediumIntU = ?     ,\+            \__int        = ?     ,\+            \__intU       = ?     ,\+            \__bigInt     = ?     ,\+            \__bigIntU    = ?     ,\+            \__decimal    = ?     ,\+            \__float      = ?     ,\+            \__double     = ?     ,\+            \__date       = ?     ,\+            \__datetime   = ?     ,\+            \__timestamp  = ?     ,\+            \__time       = ?     ,\+            \__year       = ?     ,\+            \__char       = ?     ,\+            \__varchar    = ?     ,\+            \__binary     = ?     ,\+            \__varbinary  = ?     ,\+            \__tinyblob   = ?     ,\+            \__tinytext   = ?     ,\+            \__blob       = ?     ,\+            \__text       = ?     ,\+            \__enum       = ?     ,\+            \__set        = ? WHERE __id=0"++    executeStmt c updStmt+                [ MySQLBit bitV+                , MySQLInt8 (-128)+                , MySQLInt8U 255+                , MySQLInt16 (-32768)+                , MySQLInt16U 65535+                , MySQLInt32 (-8388608)+                , MySQLInt32U 16777215+                , MySQLInt32 (-2147483648)+                , MySQLInt32U 4294967295+                , MySQLInt64 (-9223372036854775808)+                , MySQLInt64U 18446744073709551615+                , MySQLDecimal 1234567890.0123456789+                , MySQLFloat 3.14159+                , MySQLDouble 3.1415926535+                , MySQLDate (fromGregorian 2016 08 08)+                , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+                , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+                , MySQLTime 1 (TimeOfDay 199 59 59)+                , MySQLYear 1999+                , MySQLText "12345678"+                , MySQLText "韩冬真赞"+                , MySQLBytes "12345678"+                , MySQLBytes "12345678"+                , MySQLBytes "12345678"+                , MySQLText "韩冬真赞"+                , MySQLBytes "12345678"+                , MySQLText "韩冬真赞"+                , MySQLText "foo"+                , MySQLText "foo,bar"+                ]++++    (_, is) <- queryStmt c selStmt []+    Just v <- Stream.read is++    assertEqual "roundtrip binary protocol" v+        [ MySQLInt32 0+        , MySQLBit bitV+        , MySQLInt8 (-128)+        , MySQLInt8U 255+        , MySQLInt16 (-32768)+        , MySQLInt16U 65535+        , MySQLInt32 (-8388608)+        , MySQLInt32U 16777215+        , MySQLInt32 (-2147483648)+        , MySQLInt32U 4294967295+        , MySQLInt64 (-9223372036854775808)+        , MySQLInt64U 18446744073709551615+        , MySQLDecimal 1234567890.0123456789+        , MySQLFloat 3.14159+        , MySQLDouble 3.1415926535+        , MySQLDate (fromGregorian 2016 08 08)+        , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+        , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+        , MySQLTime 1 (TimeOfDay 199 59 59)+        , MySQLYear 1999+        , MySQLText "12345678"+        , MySQLText "韩冬真赞"+        , MySQLBytes "12345678"+        , MySQLBytes "12345678"+        , MySQLBytes "12345678"+        , MySQLText "韩冬真赞"+        , MySQLBytes "12345678"+        , MySQLText "韩冬真赞"+        , MySQLText "foo"+        , MySQLText "foo,bar"+        ]++    Stream.skipToEof is+--------------------------------------------------------------------------------+    execute_ c "UPDATE test SET \+        \__mediumInt  = null         ,\+        \__double     = null         ,\+        \__text = null WHERE __id=0"++    (_, is) <- queryStmt c selStmt []+    Just v <- Stream.read is++    assertEqual "decode binary protocol with null" v+        [ MySQLInt32 0+        , MySQLBit bitV+        , MySQLInt8 (-128)+        , MySQLInt8U 255+        , MySQLInt16 (-32768)+        , MySQLInt16U 65535+        , MySQLNull+        , MySQLInt32U 16777215+        , MySQLInt32 (-2147483648)+        , MySQLInt32U 4294967295+        , MySQLInt64 (-9223372036854775808)+        , MySQLInt64U 18446744073709551615+        , MySQLDecimal 1234567890.0123456789+        , MySQLFloat 3.14159+        , MySQLNull+        , MySQLDate (fromGregorian 2016 08 08)+        , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+        , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+        , MySQLTime 1 (TimeOfDay 199 59 59)+        , MySQLYear 1999+        , MySQLText "12345678"+        , MySQLText "韩冬真赞"+        , MySQLBytes "12345678"+        , MySQLBytes "12345678"+        , MySQLBytes "12345678"+        , MySQLText "韩冬真赞"+        , MySQLBytes "12345678"+        , MySQLNull+        , MySQLText "foo"+        , MySQLText "foo,bar"+        ]++    Stream.skipToEof is+--------------------------------------------------------------------------------+    updStmt1 <- prepareStmt c "UPDATE test SET \+        \__decimal  = ?         ,\+        \__date     = ?         ,\+        \__timestamp = ? WHERE __id=0"+    executeStmt c updStmt1 [MySQLNull, MySQLNull, MySQLNull]++    (_, is) <- queryStmt c selStmt []+    Just v <- Stream.read is++    assertEqual "roundtrip binary protocol with null" v+        [ MySQLInt32 0+        , MySQLBit bitV+        , MySQLInt8 (-128)+        , MySQLInt8U 255+        , MySQLInt16 (-32768)+        , MySQLInt16U 65535+        , MySQLNull+        , MySQLInt32U 16777215+        , MySQLInt32 (-2147483648)+        , MySQLInt32U 4294967295+        , MySQLInt64 (-9223372036854775808)+        , MySQLInt64U 18446744073709551615+        , MySQLNull+        , MySQLFloat 3.14159+        , MySQLNull+        , MySQLNull+        , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+        , MySQLNull+        , MySQLTime 1 (TimeOfDay 199 59 59)+        , MySQLYear 1999+        , MySQLText "12345678"+        , MySQLText "韩冬真赞"+        , MySQLBytes "12345678"+        , MySQLBytes "12345678"+        , MySQLBytes "12345678"+        , MySQLText "韩冬真赞"+        , MySQLBytes "12345678"+        , MySQLNull+        , MySQLText "foo"+        , MySQLText "foo,bar"+        ]+--------------------------------------------------------------------------------+    Stream.skipToEof is+    execute_ c "UPDATE test SET \+        \__time       = '199:59:59'     ,\+        \__year       = 0  WHERE __id=0"++    selStmt2 <- prepareStmt c "SELECT __time, __year FROM test"+    (_, is) <- queryStmt c selStmt2 []+    Just v <- Stream.read is++    assertEqual "decode binary protocol 2" v+            [ MySQLTime 0 (TimeOfDay 199 59 59)+            , MySQLYear 0+            ]++    Stream.skipToEof is+--------------------------------------------------------------------------------+    updStmt2 <- prepareStmt c "UPDATE test SET \+                \__time       = ?     ,\+                \__year       = ?  WHERE __id=0"++    executeStmt c updStmt2 [ MySQLTime 0 (TimeOfDay 00 00 00), MySQLYear 2055]++    (_, is) <- queryStmt c selStmt2 []+    Just v <- Stream.read is+    assertEqual "roundtrip binary protocol 2" v+            [ MySQLTime 0 (TimeOfDay 00 00 00)+            , MySQLYear 2055+            ]++    Stream.skipToEof is+--------------------------------------------------------------------------------+    execute_ c "UPDATE test SET \+        \__text       = ''     ,\+        \__blob       = ''  WHERE __id=0"++    selStmt3 <- prepareStmt c "SELECT __text, __blob FROM test"+    (_, is) <- queryStmt c selStmt3 []+    Just v <- Stream.read is++    assertEqual "decode binary protocol 3" v+            [ MySQLText ""+            , MySQLBytes ""+            ]++    Stream.skipToEof is+--------------------------------------------------------------------------------+    updStmt3 <- prepareStmt c "UPDATE test SET \+                \__text       = ?     ,\+                \__blob       = ?  WHERE __id=0"++    executeStmt c updStmt3+        [ MySQLText (T.replicate 100000 "xyz")+        , MySQLBytes (B.replicate 1000000 64)+        ]++    (_, is) <- queryStmt c selStmt3 []+    Just v <- Stream.read is+    assertEqual "roundtrip binary protocol 3" v+        [ MySQLText (T.replicate 100000 "xyz")+        , MySQLBytes (B.replicate 1000000 64)+        ]++    Stream.skipToEof is
+ test/BinaryRowNew.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE NegativeLiterals    #-}+{-# LANGUAGE ScopedTypeVariables #-}++module BinaryRowNew where++import           Control.Applicative+import           Data.Time.Calendar  (fromGregorian)+import           Data.Time.LocalTime (LocalTime (..), TimeOfDay (..))+import           Database.MySQL.Base+import qualified System.IO.Streams   as Stream+import           Test.Tasty.HUnit++tests :: MySQLConn -> Assertion+tests c = do+    selStmt <- prepareStmt c "SELECT * FROM test_new"++    (f, is) <- queryStmt c selStmt []+    assertEqual "decode Field types" (columnType <$> f)+        [ mySQLTypeLong+        , mySQLTypeDateTime+        , mySQLTypeTimestamp+        , mySQLTypeTime+        ]++    Just v <- Stream.read is+    assertEqual "decode NULL values" v+        [ MySQLInt32 0+        , MySQLNull+        , MySQLNull+        , MySQLNull+        ]++    Stream.skipToEof is++    execute_ c "UPDATE test_new SET \+                \__datetime   = '2016-08-08 17:25:59.12'                  ,\+                \__timestamp  = '2016-08-08 17:25:59.1234'                ,\+                \__time       = '-199:59:59.123456' WHERE __id=0"++    (_, is) <- queryStmt c selStmt []+    Just v <- Stream.read is++    assertEqual "decode binary protocol" v+        [ MySQLInt32 0+        , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+        , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1234))+        , MySQLTime 1 (TimeOfDay 199 59 59.123456)+        ]++    Stream.skipToEof is++    execute_ c "UPDATE test_new SET \+                \__datetime   = '2016-08-08 17:25:59.1'                  ,\+                \__timestamp  = '2016-08-08 17:25:59.12'                ,\+                \__time       = '199:59:59.123' WHERE __id=0"++    (_, is) <- queryStmt c selStmt []+    Just v <- Stream.read is++    assertEqual "decode binary protocol 2" v+        [ MySQLInt32 0+        , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1))+        , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+        , MySQLTime 0 (TimeOfDay 199 59 59.123)+        ]++    Stream.skipToEof is++    updStmt <- prepareStmt c+            "UPDATE test_new SET \+            \__datetime   = ?     ,\+            \__timestamp  = ?     ,\+            \__time       = ? WHERE __id=0"++    executeStmt c updStmt+                [ MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+                , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1234))+                , MySQLTime 1 (TimeOfDay 199 59 59.123456)+                ]+++    (_, is) <- queryStmt c selStmt []+    Just v <- Stream.read is++    assertEqual "roundtrip binary protocol" v+        [ MySQLInt32 0+        , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+        , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1234))+        , MySQLTime 1 (TimeOfDay 199 59 59.123456)+        ]++    Stream.skipToEof is++    executeStmt c updStmt+                [ MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1))+                , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+                , MySQLTime 0 (TimeOfDay 199 59 59.1234)+                ]+++    (_, is) <- queryStmt c selStmt []+    Just v <- Stream.read is++    assertEqual "roundtrip binary protocol 2" v+        [ MySQLInt32 0+        , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1))+        , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+        , MySQLTime 0 (TimeOfDay 199 59 59.1234)+        ]++    Stream.skipToEof is
+ test/ExecuteMany.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE NegativeLiterals    #-}+{-# LANGUAGE ScopedTypeVariables #-}++module ExecuteMany where++import           Control.Applicative+import           Data.Time.Calendar  (fromGregorian)+import           Data.Time.LocalTime (LocalTime (..), TimeOfDay (..))+import           Database.MySQL.Base+import qualified System.IO.Streams   as Stream+import           Test.Tasty.HUnit++tests :: MySQLConn -> Assertion+tests c = do++    oks <- withTransaction c $ executeMany c "INSERT INTO test VALUES(\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?     ,\+            \?)"+            (replicate 50000+                [ MySQLInt32 0+                , MySQLBit 255+                , MySQLInt8 (-128)+                , MySQLInt8U 255+                , MySQLInt16 (-32768)+                , MySQLInt16U 65535+                , MySQLInt32 (-8388608)+                , MySQLInt32U 16777215+                , MySQLInt32 (-2147483648)+                , MySQLInt32U 4294967295+                , MySQLInt64 (-9223372036854775808)+                , MySQLInt64U 18446744073709551615+                , MySQLDecimal 1234567890.0123456789+                , MySQLFloat 3.14159+                , MySQLDouble 3.1415926535+                , MySQLDate (fromGregorian 2016 08 08)+                , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+                , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+                , MySQLTime 1 (TimeOfDay 199 59 59)+                , MySQLYear 1999+                , MySQLText "12345678"+                , MySQLText "韩冬真赞"+                , MySQLBytes "12345678"+                , MySQLBytes "12345678"+                , MySQLBytes "12345678"+                , MySQLText "韩冬真赞"+                , MySQLBytes "12345678"+                , MySQLText "韩冬真赞"+                , MySQLText "foo"+                , MySQLText "foo,bar"+                ]+            )+    assertEqual "executeMany affected rows" (sum $ map okAffectedRows oks) 50000
+ test/JSON.hs view
@@ -0,0 +1,33 @@+module JSON where++import Control.Monad+import Control.Applicative+import qualified Data.ByteString as B+import Test.Tasty.HUnit+import Test.Tasty (TestTree)+import System.Directory (getDirectoryContents, doesDirectoryExist)+import System.FilePath ((</>))+import qualified Aeson as A+import qualified Data.Attoparsec.ByteString as A+import qualified AesonBP as B+import qualified Data.Binary.Parser as B+import Data.List+++pathTo :: String -> IO FilePath+pathTo wat = do+  exists <- doesDirectoryExist "test"+  return $ if exists+           then "test" </> wat+           else wat++tests :: IO [TestTree]+tests = do+    path <- pathTo "json-data"+    names <- sort . filter (`notElem` [".", ".."]) <$> getDirectoryContents path+    forM names $ \name -> do+        bs <- B.readFile (path </> name)+        return $ testCase name $+            assertEqual name (A.parseOnly A.jsonEOF' bs) (B.parseOnly B.jsonEOF' bs)++
+ test/Main.hs view
@@ -0,0 +1,30 @@+module Main (main) where++import qualified QC.ByteString as ByteString+import qualified QC.Combinator as Combinator+import Test.Tasty (defaultMain, testGroup)+import qualified JSON+import qualified MysqlTests+import qualified WireStreams+import qualified Word24++main :: IO ()+main = do+    jsonTests <- JSON.tests+    defaultMain $ testGroup "tests" [+      testGroup "binary-parser" [+        testGroup "bs" ByteString.tests+      , testGroup "combinator" Combinator.tests+      , testGroup "JSON" jsonTests+      ],+      testGroup "wire-stream" [+         WireStreams.tests+      ],+      testGroup "mysql" [+          -- TODO figure out how to run the tests that need a mysql+          -- db+          -- MysqlTests.tests+      ],+      testGroup "word24"+         Word24.tests+      ]
+ test/MysqlTests.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE ScopedTypeVariables #-}++module MysqlTests(tests)  where++import qualified BinaryRow+import qualified BinaryRowNew+import qualified BinLog+import qualified BinLogNew+import           Control.Concurrent    (forkIO, threadDelay)+import           Control.Exception     (bracket, catch)+import           Control.Monad+import qualified Data.ByteString       as B+import           Database.MySQL.Base+import           Database.MySQL.BinLog+import           System.Environment+import qualified System.IO.Streams as Stream+import           Test.Tasty+import           Test.Tasty.HUnit+import qualified TextRow+import qualified ExecuteMany+import qualified TextRowNew++tests :: TestTree+tests = testCaseSteps "mysql-haskell test suit" $ \step -> do++    step "preparing table..."+    (greet, c) <- connectDetail defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell"}++    let ver = greetingVersion greet+        isNew = "5.6" `B.isPrefixOf` ver+                || "5.7" `B.isPrefixOf` ver  -- from MySQL 5.6.4 and up+                                             -- TIME, DATETIME, and TIMESTAMP support fractional seconds+++    execute_ c "DROP TABLE IF EXISTS test"+    execute_ c "DROP TABLE IF EXISTS test_new"++    execute_ c  "CREATE TABLE test(\+                \__id           INT,\+                \__bit          BIT(16),\+                \__tinyInt      TINYINT,\+                \__tinyIntU     TINYINT UNSIGNED,\+                \__smallInt     SMALLINT,\+                \__smallIntU    SMALLINT UNSIGNED,\+                \__mediumInt    MEDIUMINT,\+                \__mediumIntU   MEDIUMINT UNSIGNED,\+                \__int          INT,\+                \__intU         INT UNSIGNED,\+                \__bigInt       BIGINT,\+                \__bigIntU      BIGINT UNSIGNED,\+                \__decimal      DECIMAL(20,10),\+                \__float        FLOAT,\+                \__double       DOUBLE,\+                \__date         DATE,\+                \__datetime     DATETIME,\+                \__timestamp    TIMESTAMP NULL,\+                \__time         TIME,\+                \__year         YEAR(4),\+                \__char         CHAR(8),\+                \__varchar      VARCHAR(1024),\+                \__binary       BINARY(8),\+                \__varbinary    VARBINARY(1024),\+                \__tinyblob     TINYBLOB,\+                \__tinytext     TINYTEXT,\+                \__blob         BLOB(1000000),\+                \__text         TEXT(1000000),\+                \__enum         ENUM('foo', 'bar', 'qux'),\+                \__set          SET('foo', 'bar', 'qux')\+                \) CHARACTER SET utf8"++    resetTestTable c++    step "testing executeMany"+    ExecuteMany.tests c++    resetTestTable c++    step "testing text protocol"+    TextRow.tests c++    resetTestTable c++    step "testing binary protocol"+    BinaryRow.tests c++    resetTestTable c+++    when isNew $ do+        execute_ c "CREATE TABLE test_new(\+                   \__id           INT,\+                   \__datetime     DATETIME(2),\+                   \__timestamp    TIMESTAMP(4) NULL,\+                   \__time         TIME(6)\+                   \) CHARACTER SET utf8"++        resetTest57Table c++        step "testing MySQL5.7 extra text protocol"+        TextRowNew.tests c++        resetTest57Table c++        step "testing MySQL5.7 extra binary protocol"+        BinaryRowNew.tests c++        void $ resetTest57Table c++    step "testing binlog protocol"++    if isNew+    then do+        forkIO BinLogNew.eventProducer+        BinLogNew.tests c+    else do+        forkIO BinLog.eventProducer+        BinLog.tests c++    close c++    (greet, c) <- connectDetail defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell"}+    execute_ c "SET PASSWORD = PASSWORD('123456abcdefg???')"+    close c++    let loginFailMsg = "ERRException (ERR {errCode = 1045, errState = \"28000\", \+            \errMsg = \"Access denied for user 'testMySQLHaskell'@'localhost' (using password: YES)\"})"++    (greet, c) <- connectDetail+        defaultConnectInfo {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell", ciPassword = "123456abcdefg???"}+    execute_ c "SET PASSWORD = PASSWORD('')"+    close c++    catch+        (void $ connectDetail+                    defaultConnectInfo+                        {ciUser = "testMySQLHaskell", ciDatabase = "testMySQLHaskell", ciPassword = "wrongPassWord"})+        (\ (e :: ERRException) -> assertEqual "wrong password should fail to login" (show e) loginFailMsg)++  where+    resetTestTable c = do+            execute_ c  "DELETE FROM test WHERE __id=0"+            execute_ c  "INSERT INTO test VALUES(\+                    \0,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL,\+                    \NULL\+                    \)"++    resetTest57Table c = do+            execute_ c  "DELETE FROM test_new WHERE __id=0"+            execute_ c  "INSERT INTO test_new VALUES(\+                        \0,\+                        \NULL,\+                        \NULL,\+                        \NULL\+                        \)"++
+ test/QC/ByteString.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}+module QC.ByteString (tests) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Data.Char (chr, ord, toUpper)+import Data.Int (Int64)+import Data.Word (Word8)+import Prelude hiding (take, takeWhile)+import QC.Common (ASCII(..), liftOp, parseBS, toStrictBS)+import Test.Tasty (TestTree)+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck+import qualified Data.Scientific as Sci+import qualified Data.ByteString.Builder.Scientific as Sci+import qualified Data.Binary.Parser as P+import qualified Data.Binary.Parser.Char8 as P8+import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as L8++newtype ASCIIChar = ASCIIChar Char+    deriving (Eq, Ord, Show, Read)+instance Arbitrary ASCIIChar where+    arbitrary = ASCIIChar <$> choose ('\0', '\127')+    shrink (ASCIIChar c) = ASCIIChar <$> shrink c++-- Basic byte-level combinators.++satisfy :: Word8 -> L.ByteString -> Property+satisfy w s = parseBS (P.satisfy (<=w)) (L.cons w s) === Just w++satisfyWith :: ASCIIChar -> L.ByteString -> Property+satisfyWith (ASCIIChar c) s = parseBS (P.satisfyWith (chr . fromIntegral) (<=c))+                         (L.cons (fromIntegral (ord c)) s) === Just c++word8 :: Word8 -> L.ByteString -> Property+word8 w s = parseBS (P.word8 w *> pure w) (L.cons w s) === Just w++skipWord8 :: Word8 -> L.ByteString -> Property+skipWord8 w s =+  case (parseBS (P.skipWord8 (<w)) s, L.uncons s) of+    (Nothing, mcs) -> maybe (property True) (expectFailure . it) mcs+    (Just _,  mcs) -> maybe (property False) it mcs+  where it cs = liftOp "<" (<) (fst cs) w++anyWord8 :: L.ByteString -> Property+anyWord8 s+    | L.null s  = p === Nothing+    | otherwise = p === Just (L.head s)+  where p = parseBS P.anyWord8 s++peekMaybe :: L.ByteString -> Property+peekMaybe s+    | L.null s  = p === Just (Nothing, s)+    | otherwise = p === Just (Just (L.head s), s)+  where p = parseBS ((,) <$> P.peekMaybe <*> P.getRemainingLazyByteString) s++peek :: L.ByteString -> Property+peek s = parseBS P.peek s === (fst <$> L.uncons s)++string :: L.ByteString -> L.ByteString -> Property+string s t = parseBS (P.string s' *> pure s') (s `L.append` t) === Just s'+  where s' = toStrictBS s++stringCI :: ASCII L.ByteString -> ASCII L.ByteString -> Property+stringCI (ASCII s) (ASCII t) =+    parseBS (P8.stringCI up) (s `L.append` t) === Just s'+  where s' = toStrictBS s+        up = B8.map toUpper s'++strings :: L.ByteString -> L.ByteString -> L.ByteString -> Property+strings s t u =+    parseBS (P.string (toStrictBS s) >> (P.string t' *> pure t')) (L.concat [s,t,u])+    === Just t'+  where t' = toStrictBS t++skipWhile :: Word8 -> L.ByteString -> Property+skipWhile w s =+    let t = L.dropWhile (<=w) s+    in case P.runGetOrFail (P.skipWhile (<=w)) s of+         Right (t', _, _) -> t === t'+         Left  _          -> property False++takeCount :: Positive Int -> L.ByteString -> Property+takeCount (Positive k) s =+    case parseBS (P.getByteString k) s of+      Nothing -> liftOp ">" (>) (fromIntegral k) (L.length s)+      Just _s -> liftOp "<=" (<=) (fromIntegral k) (L.length s)++takeWhile :: Word8 -> L.ByteString -> Property+takeWhile w s =+    let (h,t) = L.span (==w) s+    in case P.runGetOrFail (P.takeWhile (==w)) s of+         Right (t', _, h') -> t === t' .&&. toStrictBS h === h'+         Left _            -> property False++take :: Int -> L.ByteString -> Property+take n s = maybe (property $ L.length s < fromIntegral n)+           (=== B.take n (toStrictBS s)) $+           parseBS (P.getByteString n) s++remaining :: L.ByteString -> Property+remaining s = maybe (property False) (=== s) .+                       parseBS P.getRemainingLazyByteString $ s++takeWhile1 :: Word8 -> L.ByteString -> Property+takeWhile1 w s =+    let s'    = L.cons w s+        (h,t) = L.span (<=w) s'+    in case P.runGetOrFail (P.takeWhile1 (<=w)) s' of+         Right (t', _, h') -> t === t' .&&. toStrictBS h === h'+         _                 -> property False++takeTill :: Word8 -> L.ByteString -> Property+takeTill w s =+    let (h,t) = L.break (==w) s+    in case P.runGetOrFail (P.takeTill (==w)) s of+         Right (t', _, h') -> t === t' .&&. toStrictBS h === h'+         _                 -> property False++takeWhile1_empty :: Property+takeWhile1_empty = parseBS (P.takeWhile1 undefined) L.empty === Nothing++endOfInput :: L.ByteString -> Property+endOfInput s = parseBS P.endOfInput s === if L.null s+                                          then Just ()+                                          else Nothing++endOfLine :: L.ByteString -> Property+endOfLine s =+  case (parseBS P.endOfLine s, L8.uncons s) of+    (Nothing, mcs) -> maybe (property True) (expectFailure . eol) mcs+    (Just _,  mcs) -> maybe (property False) eol mcs+  where eol (c,s') = c === '\n' .||.+                     (c, fst <$> L8.uncons s') === ('\r', Just '\n')++scan :: L.ByteString -> Positive Int64 -> Property+scan s (Positive k) = parseBS p s === Just (toStrictBS $ L.take k s)+  where p = P.scan k $ \ n _ ->+            if n > 0 then let !n' = n - 1 in Just n' else Nothing++decimal :: Integer -> Property+decimal d =+    let dBS = BB.toLazyByteString $ BB.integerDec d+    in parseBS (P.signed P.decimal) dBS === Just d++double :: Double -> Property+double d =+    let dBS = BB.toLazyByteString $ BB.doubleDec d+    in parseBS P.double dBS === Just d++scientific :: Sci.Scientific -> Property+scientific sci =+    let sciBS = BB.toLazyByteString $ Sci.formatScientificBuilder Sci.Generic Nothing sci+    in parseBS P.scientific sciBS === Just sci++tests :: [TestTree]+tests = [+      testProperty "anyWord8" anyWord8+    , testProperty "endOfInput" endOfInput+    , testProperty "endOfLine" endOfLine+    , testProperty "peekMaybe" peekMaybe+    , testProperty "peek" peek+    , testProperty "satisfy" satisfy+    , testProperty "satisfyWith" satisfyWith+    , testProperty "scan" scan+    , testProperty "skipWord8" skipWord8+    , testProperty "skipWhile" skipWhile+    , testProperty "string" string+    , testProperty "stringCI" stringCI+    , testProperty "strings" strings+    , testProperty "take" take+    , testProperty "takeCount" takeCount+    , testProperty "remaining" remaining+    , testProperty "takeTill" takeTill+    , testProperty "takeWhile" takeWhile+    , testProperty "takeWhile1" takeWhile1+    , testProperty "takeWhile1_empty" takeWhile1_empty+    , testProperty "word8" word8+    , testProperty "decimal" decimal+    , testProperty "double" double+    , testProperty "scientific" scientific+  ]
+ test/QC/Combinator.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE CPP, OverloadedStrings #-}++module QC.Combinator where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import qualified Control.Monad as M (replicateM)+import Data.Maybe (fromJust, isJust)+import Data.Word (Word8)+import QC.Common (Repack, parseBS, repackBS, toLazyBS)+import Test.Tasty (TestTree)+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck+import qualified Data.Binary.Parser.Char8 as C+import qualified Data.Binary.Parser as P+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.Foldable as Foldable (asum)++asum :: NonEmptyList (NonEmptyList Word8) -> Gen Property+asum (NonEmpty xs) = do+  let ys = map (B.pack . getNonEmpty) xs+  return . forAll (repackBS <$> arbitrary <*> elements ys) $+    maybe False (`elem` ys) . parseBS (Foldable.asum (map (\s -> P.string s *> pure s) ys))++replicateM :: Positive (Small Int) -> Repack -> B.ByteString -> Bool+replicateM (Positive (Small n)) rs s =+    (length <$> parseBS (M.replicateM n (P.string s)) input) == Just n+  where input = repackBS rs (B.concat (replicate (n+1) s))++lookAhead :: NonEmptyList Word8 -> Bool+lookAhead (NonEmpty xs) =+  let ys = B.pack xs+      withLookAheadThenConsume = (\x y -> (x, y)) <$> P.lookAhead (P.string ys) <*> P.string ys+      mr = parseBS withLookAheadThenConsume $ toLazyBS ys+  in isJust mr && fst (fromJust mr) == snd (fromJust mr)++match :: Int -> NonNegative Int -> NonNegative Int -> Repack -> Bool+match n (NonNegative x) (NonNegative y) rs =+    parseBS (P.match parser) (repackBS rs input) == Just (input, n)+  where parser = C.skipWhile (=='x') *> P.signed P.decimal <*+                 C.skipWhile (=='y')+        input = B.concat [+            B8.replicate x 'x', B8.pack (show n), B8.replicate y 'y'+          ]++tests :: [TestTree]+tests = [+    testProperty "asum" asum+  , testProperty "replicateM" replicateM+  , testProperty "lookAhead" lookAhead+  , testProperty "match" match+  ]
+ test/QC/Common.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE CPP, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module QC.Common+    (+      ASCII(..)+    , parseBS+    , toLazyBS+    , toStrictBS+    , Repack+    , repackBS+    , repackBS_+    , liftOp+    ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Data.Char (isAlpha)+import Test.QuickCheck+import Test.QuickCheck.Instances ()+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Binary.Parser as P++#if !MIN_VERSION_base(4,4,0)+-- This should really be a dependency on the random package :-(+instance Random Word8 where+  randomR = integralRandomR+  random = randomR (minBound,maxBound)++instance Arbitrary Word8 where+    arbitrary = choose (minBound, maxBound)+#endif++parseBS :: P.Get r -> BL.ByteString -> Maybe r+parseBS p lbs = case P.parseLazy p lbs of+    Left _ -> Nothing+    Right v -> Just v++toStrictBS :: BL.ByteString -> B.ByteString+toStrictBS = B.concat . BL.toChunks++toLazyBS :: B.ByteString -> BL.ByteString+toLazyBS = BL.fromChunks . (:[])++newtype ASCII a = ASCII { fromASCII :: a }+                  deriving (Eq, Ord, Show)++instance Arbitrary (ASCII B.ByteString) where+    arbitrary = (ASCII . B.pack) <$> listOf (choose (0,127))+    shrink = map (ASCII . B.pack) . shrink . B.unpack . fromASCII++instance Arbitrary (ASCII BL.ByteString) where+    arbitrary = ASCII <$> (repackBS <$> arbitrary <*> (fromASCII <$> arbitrary))+    shrink = map (ASCII . BL.pack) . shrink . BL.unpack . fromASCII++type Repack = NonEmptyList (Positive (Small Int))++repackBS :: Repack -> B.ByteString -> BL.ByteString+repackBS (NonEmpty bs) =+    BL.fromChunks . repackBS_ (map (getSmall . getPositive) bs)++repackBS_ :: [Int] -> B.ByteString -> [B.ByteString]+repackBS_ = go . cycle+  where go (b:bs) s+          | B.null s = []+          | otherwise = let (h,t) = B.splitAt b s+                        in h : go bs t+        go _ _ = error "unpossible"++liftOp :: (Show a, Testable prop) =>+          String -> (a -> a -> prop) -> a -> a -> Property+liftOp name f x y = counterexample desc (f x y)+  where op = case name of+               (c:_) | isAlpha c -> " `" ++ name ++ "` "+                     | otherwise -> " " ++ name ++ " "+               _ -> " ??? "+        desc = "not (" ++ show x ++ op ++ show y ++ ")"
+ test/QCUtils.hs view
@@ -0,0 +1,26 @@+module QCUtils where++import Test.QuickCheck+import Test.QuickCheck.Arbitrary+import Test.QuickCheck.Gen++import Data.Int+import Data.Int.Int24+import Data.Word+import Data.Word.Word24++-- Arbitrary/CoArbitrary instances for Int24 and Word24++instance Arbitrary Int24 where+  arbitrary = arbitraryBoundedIntegral+  shrink = shrinkIntegral++instance CoArbitrary Int24 where+  coarbitrary = coarbitraryIntegral++instance Arbitrary Word24 where+  arbitrary = arbitraryBoundedIntegral+  shrink = shrinkIntegral++instance CoArbitrary Word24 where+  coarbitrary = coarbitraryIntegral
+ test/TextRow.hs view
@@ -0,0 +1,392 @@+{-# LANGUAGE NegativeLiterals    #-}+{-# LANGUAGE ScopedTypeVariables #-}++module TextRow where++import           Control.Applicative+import           Data.Time.Calendar  (fromGregorian)+import           Data.Time.LocalTime (LocalTime (..), TimeOfDay (..))+import           Database.MySQL.Base+import qualified System.IO.Streams   as Stream+import           Test.Tasty.HUnit+import qualified Data.Vector as V++tests :: MySQLConn -> Assertion+tests c = do+    (f, is) <- query_ c "SELECT * FROM test"++    assertEqual "decode Field types" (columnType <$> f)+        [ mySQLTypeLong+        , mySQLTypeBit+        , mySQLTypeTiny+        , mySQLTypeTiny+        , mySQLTypeShort+        , mySQLTypeShort+        , mySQLTypeInt24+        , mySQLTypeInt24+        , mySQLTypeLong+        , mySQLTypeLong+        , mySQLTypeLongLong+        , mySQLTypeLongLong+        , mySQLTypeNewDecimal+        , mySQLTypeFloat+        , mySQLTypeDouble+        , mySQLTypeDate+        , mySQLTypeDateTime+        , mySQLTypeTimestamp+        , mySQLTypeTime+        , mySQLTypeYear+        , mySQLTypeString+        , mySQLTypeVarString+        , mySQLTypeString+        , mySQLTypeVarString+        , mySQLTypeBlob+        , mySQLTypeBlob+        , mySQLTypeBlob+        , mySQLTypeBlob+        , mySQLTypeString+        , mySQLTypeString+        ]++    Just v <- Stream.read is+    assertEqual "decode NULL values" v+        [ MySQLInt32 0+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        , MySQLNull+        ]++    Stream.skipToEof is++    let bitV = 57514 -- 0b1110000010101010++    execute_ c "UPDATE test SET \+                \__bit        = b'1110000010101010'                    ,\+                \__tinyInt    = -128                                   ,\+                \__tinyIntU   = 255                                    ,\+                \__smallInt   = -32768                                 ,\+                \__smallIntU  = 65535                                  ,\+                \__mediumInt  = -8388608                               ,\+                \__mediumIntU = 16777215                               ,\+                \__int        = -2147483648                            ,\+                \__intU       = 4294967295                             ,\+                \__bigInt     = -9223372036854775808                   ,\+                \__bigIntU    = 18446744073709551615                   ,\+                \__decimal    = 1234567890.0123456789                  ,\+                \__float      = 3.14159                                ,\+                \__double     = 3.1415926535                           ,\+                \__date       = '2016-08-08'                           ,\+                \__datetime   = '2016-08-08 17:25:59'                  ,\+                \__timestamp  = '2016-08-08 17:25:59'                  ,\+                \__time       = '-199:59:59'                           ,\+                \__year       = 1999                                   ,\+                \__char       = '12345678'                             ,\+                \__varchar    = '韩冬真赞'                             ,\+                \__binary     = '12345678'                             ,\+                \__varbinary  = '12345678'                             ,\+                \__tinyblob   = '12345678'                             ,\+                \__tinytext   = '韩冬真赞'                             ,\+                \__blob       = '12345678'                             ,\+                \__text       = '韩冬真赞'                             ,\+                \__enum       = 'foo'                                  ,\+                \__set        = 'foo,bar' WHERE __id=0"++    (_, is) <- query_ c "SELECT * FROM test"+    Just v <- Stream.read is++    assertEqual "decode text protocol" v+        [ MySQLInt32 0+        , MySQLBit bitV+        , MySQLInt8 (-128)+        , MySQLInt8U 255+        , MySQLInt16 (-32768)+        , MySQLInt16U 65535+        , MySQLInt32 (-8388608)+        , MySQLInt32U 16777215+        , MySQLInt32 (-2147483648)+        , MySQLInt32U 4294967295+        , MySQLInt64 (-9223372036854775808)+        , MySQLInt64U 18446744073709551615+        , MySQLDecimal 1234567890.0123456789+        , MySQLFloat 3.14159+        , MySQLDouble 3.1415926535+        , MySQLDate (fromGregorian 2016 08 08)+        , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+        , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+        , MySQLTime 1 (TimeOfDay 199 59 59)+        , MySQLYear 1999+        , MySQLText "12345678"+        , MySQLText "韩冬真赞"+        , MySQLBytes "12345678"+        , MySQLBytes "12345678"+        , MySQLBytes "12345678"+        , MySQLText "韩冬真赞"+        , MySQLBytes "12345678"+        , MySQLText "韩冬真赞"+        , MySQLText "foo"+        , MySQLText "foo,bar"+        ]++    Stream.skipToEof is++    (_, is') <- queryVector_ c "SELECT * FROM test"+    Just v' <- Stream.read is'+    Stream.skipToEof is'++    assertEqual "decode text protocol(queryVector_)" v (V.toList v')++    execute c "UPDATE test SET \+            \__bit        = ?     ,\+            \__tinyInt    = ?     ,\+            \__tinyIntU   = ?     ,\+            \__smallInt   = ?     ,\+            \__smallIntU  = ?     ,\+            \__mediumInt  = ?     ,\+            \__mediumIntU = ?     ,\+            \__int        = ?     ,\+            \__intU       = ?     ,\+            \__bigInt     = ?     ,\+            \__bigIntU    = ?     ,\+            \__decimal    = ?     ,\+            \__float      = ?     ,\+            \__double     = ?     ,\+            \__date       = ?     ,\+            \__datetime   = ?     ,\+            \__timestamp  = ?     ,\+            \__time       = ?     ,\+            \__year       = ?     ,\+            \__char       = ?     ,\+            \__varchar    = ?     ,\+            \__binary     = ?     ,\+            \__varbinary  = ?     ,\+            \__tinyblob   = ?     ,\+            \__tinytext   = ?     ,\+            \__blob       = ?     ,\+            \__text       = ?     ,\+            \__enum       = ?     ,\+            \__set        = ? WHERE __id=0"+                [ MySQLBit bitV+                , MySQLInt8 (-128)+                , MySQLInt8U 255+                , MySQLInt16 (-32768)+                , MySQLInt16U 65535+                , MySQLInt32 (-8388608)+                , MySQLInt32U 16777215+                , MySQLInt32 (-2147483648)+                , MySQLInt32U 4294967295+                , MySQLInt64 (-9223372036854775808)+                , MySQLInt64U 18446744073709551615+                , MySQLDecimal 1234567890.0123456789+                , MySQLFloat 3.14159+                , MySQLDouble 3.1415926535+                , MySQLDate (fromGregorian 2016 08 08)+                , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+                , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+                , MySQLTime 1 (TimeOfDay 199 59 59)+                , MySQLYear 1999+                , MySQLText "12345678"+                , MySQLText "韩冬真赞"+                , MySQLBytes "12345678"+                , MySQLBytes "12345678"+                , MySQLBytes "12345678"+                , MySQLText "韩冬真赞"+                , MySQLBytes "12345678"+                , MySQLText "韩冬真赞"+                , MySQLText "foo"+                , MySQLText "foo,bar"+                ]++    (_, is) <- query_ c "SELECT * FROM test"+    Just v <- Stream.read is++    assertEqual "roundtrip text protocol" v+        [ MySQLInt32 0+        , MySQLBit bitV+        , MySQLInt8 (-128)+        , MySQLInt8U 255+        , MySQLInt16 (-32768)+        , MySQLInt16U 65535+        , MySQLInt32 (-8388608)+        , MySQLInt32U 16777215+        , MySQLInt32 (-2147483648)+        , MySQLInt32U 4294967295+        , MySQLInt64 (-9223372036854775808)+        , MySQLInt64U 18446744073709551615+        , MySQLDecimal 1234567890.0123456789+        , MySQLFloat 3.14159+        , MySQLDouble 3.1415926535+        , MySQLDate (fromGregorian 2016 08 08)+        , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+        , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+        , MySQLTime 1 (TimeOfDay 199 59 59)+        , MySQLYear 1999+        , MySQLText "12345678"+        , MySQLText "韩冬真赞"+        , MySQLBytes "12345678"+        , MySQLBytes "12345678"+        , MySQLBytes "12345678"+        , MySQLText "韩冬真赞"+        , MySQLBytes "12345678"+        , MySQLText "韩冬真赞"+        , MySQLText "foo"+        , MySQLText "foo,bar"+        ]++    Stream.skipToEof is+++    execute_ c "UPDATE test SET \+        \__mediumInt  = null         ,\+        \__double     = null         ,\+        \__text = null WHERE __id=0"++    (_, is) <- query_ c "SELECT * FROM test"+    Just v <- Stream.read is++    assertEqual "decode text protocol with null" v+        [ MySQLInt32 0+        , MySQLBit bitV+        , MySQLInt8 (-128)+        , MySQLInt8U 255+        , MySQLInt16 (-32768)+        , MySQLInt16U 65535+        , MySQLNull+        , MySQLInt32U 16777215+        , MySQLInt32 (-2147483648)+        , MySQLInt32U 4294967295+        , MySQLInt64 (-9223372036854775808)+        , MySQLInt64U 18446744073709551615+        , MySQLDecimal 1234567890.0123456789+        , MySQLFloat 3.14159+        , MySQLNull+        , MySQLDate (fromGregorian 2016 08 08)+        , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+        , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+        , MySQLTime 1 (TimeOfDay 199 59 59)+        , MySQLYear 1999+        , MySQLText "12345678"+        , MySQLText "韩冬真赞"+        , MySQLBytes "12345678"+        , MySQLBytes "12345678"+        , MySQLBytes "12345678"+        , MySQLText "韩冬真赞"+        , MySQLBytes "12345678"+        , MySQLNull+        , MySQLText "foo"+        , MySQLText "foo,bar"+        ]++    Stream.skipToEof is++    execute c "UPDATE test SET \+        \__decimal  = ?         ,\+        \__date     = ?         ,\+        \__timestamp = ? WHERE __id=0"+        [MySQLNull, MySQLNull, MySQLNull]++    (_, is) <- query_ c "SELECT * FROM test"+    Just v <- Stream.read is++    assertEqual "roundtrip text protocol with null" v+        [ MySQLInt32 0+        , MySQLBit bitV+        , MySQLInt8 (-128)+        , MySQLInt8U 255+        , MySQLInt16 (-32768)+        , MySQLInt16U 65535+        , MySQLNull+        , MySQLInt32U 16777215+        , MySQLInt32 (-2147483648)+        , MySQLInt32U 4294967295+        , MySQLInt64 (-9223372036854775808)+        , MySQLInt64U 18446744073709551615+        , MySQLNull+        , MySQLFloat 3.14159+        , MySQLNull+        , MySQLNull+        , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59))+        , MySQLNull+        , MySQLTime 1 (TimeOfDay 199 59 59)+        , MySQLYear 1999+        , MySQLText "12345678"+        , MySQLText "韩冬真赞"+        , MySQLBytes "12345678"+        , MySQLBytes "12345678"+        , MySQLBytes "12345678"+        , MySQLText "韩冬真赞"+        , MySQLBytes "12345678"+        , MySQLNull+        , MySQLText "foo"+        , MySQLText "foo,bar"+        ]++    Stream.skipToEof is++    execute_ c "UPDATE test SET \+        \__time       = '199:59:59'     ,\+        \__year       = 0  WHERE __id=0"++    (_, is) <- query_ c "SELECT __time, __year FROM test"+    Just v <- Stream.read is++    assertEqual "decode text protocol 2" v+            [ MySQLTime 0 (TimeOfDay 199 59 59)+            , MySQLYear 0+            ]++    Stream.skipToEof is++    execute_ c "UPDATE test SET \+        \__text       = ''     ,\+        \__blob       = ''  WHERE __id=0"++    (_, is) <- query_ c "SELECT __text, __blob FROM test"+    Just v <- Stream.read is++    assertEqual "decode text protocol 3" v+            [ MySQLText ""+            , MySQLBytes ""+            ]++    Stream.skipToEof is++    execute c "UPDATE test SET \+        \__time       = ?     ,\+        \__year       = ?  WHERE __id=0"+        [ MySQLTime 0 (TimeOfDay 199 59 59), MySQLYear 0]++    (_, is) <- query_ c "SELECT __time, __year FROM test"+    Just v <- Stream.read is++    assertEqual "roundtrip text protocol 2" v+            [ MySQLTime 0 (TimeOfDay 199 59 59)+            , MySQLYear 0+            ]++    Stream.skipToEof is
+ test/TextRowNew.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE NegativeLiterals    #-}+{-# LANGUAGE ScopedTypeVariables #-}++module TextRowNew where++import           Control.Applicative+import           Data.Time.Calendar  (fromGregorian)+import           Data.Time.LocalTime (LocalTime (..), TimeOfDay (..))+import           Database.MySQL.Base+import qualified System.IO.Streams   as Stream+import           Test.Tasty.HUnit++tests :: MySQLConn -> Assertion+tests c = do+    (f, is) <- query_ c "SELECT * FROM test_new"++    assertEqual "decode Field types" (columnType <$> f)+        [ mySQLTypeLong+        , mySQLTypeDateTime+        , mySQLTypeTimestamp+        , mySQLTypeTime+        ]++    Just v <- Stream.read is+    assertEqual "decode NULL values" v+        [ MySQLInt32 0+        , MySQLNull+        , MySQLNull+        , MySQLNull+        ]++    Stream.skipToEof is++    execute_ c "UPDATE test_new SET \+                \__datetime   = '2016-08-08 17:25:59.12'                  ,\+                \__timestamp  = '2016-08-08 17:25:59.1234'                ,\+                \__time       = '-199:59:59.123456' WHERE __id=0"++    (_, is) <- query_ c "SELECT * FROM test_new"+    Just v <- Stream.read is++    assertEqual "decode text protocol" v+        [ MySQLInt32 0+        , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+        , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1234))+        , MySQLTime 1 (TimeOfDay 199 59 59.123456)+        ]++    Stream.skipToEof is++    execute_ c "UPDATE test_new SET \+                \__datetime   = '2016-08-08 17:25:59.1'                  ,\+                \__timestamp  = '2016-08-08 17:25:59.12'                ,\+                \__time       = '199:59:59.1234' WHERE __id=0"++    (_, is) <- query_ c "SELECT * FROM test_new"+    Just v <- Stream.read is++    assertEqual "decode text protocol 2" v+        [ MySQLInt32 0+        , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1))+        , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+        , MySQLTime 0 (TimeOfDay 199 59 59.1234)+        ]++    Stream.skipToEof is++    execute c "UPDATE test_new SET \+            \__datetime   = ?     ,\+            \__timestamp  = ?     ,\+            \__time       = ?  WHERE __id=0"+                [ MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+                , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1234))+                , MySQLTime 1 (TimeOfDay 199 59 59.123456)+                ]+++    (_, is) <- query_ c "SELECT * FROM test_new"+    Just v <- Stream.read is++    assertEqual "roundtrip text protocol" v+        [ MySQLInt32 0+        , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+        , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1234))+        , MySQLTime 1 (TimeOfDay 199 59 59.123456)+        ]++    Stream.skipToEof is++    execute c "UPDATE test_new SET \+            \__datetime   = ?     ,\+            \__timestamp  = ?     ,\+            \__time       = ?  WHERE __id=0"+                [ MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1))+                , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+                , MySQLTime 0 (TimeOfDay 199 59 59.1234)+                ]++    (_, is) <- query_ c "SELECT * FROM test_new"+    Just v <- Stream.read is++    assertEqual "roundtrip text protocol 2" v+        [ MySQLInt32 0+        , MySQLDateTime (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.1))+        , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+        , MySQLTime 0 (TimeOfDay 199 59 59.1234)+        ]++    Stream.skipToEof is++    let row0 =+            [ MySQLInt32 0+            , MySQLDateTime  (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.10))+            , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 08) (TimeOfDay 17 25 59.12))+            , MySQLTime 0 (TimeOfDay 199 59 59.1234)+            ]+    let row1 =+            [ MySQLInt32 1+            , MySQLDateTime  (LocalTime (fromGregorian 2016 08 09) (TimeOfDay 18 25 59.10))+            , MySQLTimeStamp (LocalTime (fromGregorian 2016 08 09) (TimeOfDay 18 25 59.12))+            , MySQLTime 0 (TimeOfDay 299 59 59.1234)+            ]+    execute c "UPDATE test_new SET \+            \__id         = ?     ,\+            \__datetime   = ?     ,\+            \__timestamp  = ?     ,\+            \__time       = ?  WHERE __id=0"+            row0+    execute c "INSERT INTO test_new VALUES(\+            \?,\+            \?,\+            \?,\+            \? \+            \)"+            row1++    (_, is) <- query c "SELECT * FROM test_new WHERE __id IN (?) ORDER BY __id" [Many [MySQLInt32 0, MySQLInt32 1]]+    Just v0 <- Stream.read is+    Just v1 <- Stream.read is++    assertEqual "select list of ids" [v0, v1] [row0, row1]++    Stream.skipToEof is+    execute_ c "DELETE FROM test_new where __id=1"++    return ()
+ test/WireStreams.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE ScopedTypeVariables #-}+module WireStreams ( tests ) where++import           Control.Exception        (catch, evaluate)+import           Data.Binary              (Binary)+import           Data.ByteString          (ByteString)+import qualified Data.ByteString          as S+import           System.IO.Streams        (write)+import           System.IO.Streams.Binary (DecodeException, decodeInputStream,+                                           encodeOutputStream)+import           System.IO.Streams.List   (fromList, outputToList, toList,+                                           writeList)+import           Test.QuickCheck.Monadic  (assert, monadicIO, run)+import           Test.QuickCheck.Property (Property)+import           Test.Tasty+import           Test.Tasty.QuickCheck    (testProperty)+++-- Using binary-streams, decode from a list of bytestrings+decode :: Binary a => [ByteString] -> IO [a]+decode ss = fromList ss >>= decodeInputStream >>= toList++-- Using binary-streams, encode to a list of bytestrings+encode :: Binary a => [a] -> IO [ByteString]+encode xs = outputToList $ \os ->+  do+    bos <- encodeOutputStream os+    writeList xs bos+    write Nothing bos++-- Encode something, then decode it and make sure we get the same thing back.+encodeDecodeEq :: (Binary a,Eq a) => [a] -> Property+encodeDecodeEq xs = monadicIO $ do+  xs' <- run go+  assert $ xs == xs'+  where go = encode xs >>= decode++-- corrupt something, remove the last byte of the last bytestring+corrupt :: [ByteString] -> [ByteString]+corrupt = reverse . go . reverse+  where go (h:t) = ((S.reverse $ S.drop 1 $ S.reverse h):t)+        go [] = []++-- Encode something, corrupt the encoded data, and make sure we get a+-- decode error when we try do decode it.+encodeDecodeError :: forall a. (Binary a,Eq a) => [a] -> Property+encodeDecodeError [] = monadicIO $ return ()+encodeDecodeError xs = monadicIO $ do+  run $ catch go $ \(_ :: DecodeException) -> return ()+  where go =+         do+           bList <- encode xs+           (xs' :: [a]) <- decode $ corrupt bList+           evaluate xs'+           fail "decoding succeeded when it should fail"++tests :: TestTree+tests = testGroup "tests" [+         testProperty "encode-decode-equality Int"+         (encodeDecodeEq :: [Int] -> Property),+         testProperty "encode-decode-equality String"+         (encodeDecodeEq :: [String] -> Property),+         testProperty "encode-decode-equality Maybe Int"+         (encodeDecodeEq :: [Maybe Int] -> Property),+         testProperty "encode-decode-equality Either Int String"+         (encodeDecodeEq :: [Either Int String] -> Property),+         testProperty "encode-decode-equality (Int,Int)"+         (encodeDecodeEq :: [(Int,Int)] -> Property),+         testProperty "encode-decode-equality (String,String)"+         (encodeDecodeEq :: [(Int,Int)] -> Property),+         testProperty "encode-decode-error Int"+         (encodeDecodeError :: [Int] -> Property),+         testProperty "encode-decode-error String"+         (encodeDecodeError :: [String] -> Property),+         testProperty "encode-decode-error Maybe Int"+         (encodeDecodeError :: [Maybe Int] -> Property),+         testProperty "encode-decode-error Either Int String"+         (encodeDecodeError :: [Either Int String] -> Property),+         testProperty "encode-decode-error (Int,Int)"+         (encodeDecodeError :: [(Int,Int)] -> Property),+         testProperty "encode-decode-error (String,String)"+         (encodeDecodeError :: [(String,String)] -> Property)]
+ test/Word24.hs view
@@ -0,0 +1,439 @@+{-# LANGUAGE CPP #-}++module Word24(tests) where++import Prelude as P++import Test.Tasty+import           Test.Tasty.QuickCheck    (testProperty)++import Test.QuickCheck hiding ((.&.))++import QCUtils+import Data.Int+import Data.Int.Int24+import Data.Word+import Data.Word.Word24+import Data.Bits+import Foreign.Storable+import GHC.Real++-- ----------------------------------------+-- Word24 Properties++prop_addIdent a = a - a == 0+  where types = a :: Word24++prop_multIdent a = a * 1 == a+  where types = a :: Word24++prop_unsigned a = a >= 0+  where types = a :: Word24++prop_smaller a = (fromIntegral ((fromIntegral a) :: Word24) :: Word16) == a++prop_show a = show a == show (fromIntegral a :: Word24)+  where types = a :: Word16++prop_read a = a == (read . show) a+  where types = a :: Word24++prop_adder a b = (a < ub) && (b < ub) ==>+                 fromIntegral (a + b) ==+                 ((fromIntegral a + fromIntegral b) :: Word24)+  where types = (a :: Word16, b :: Word16)+        ub :: Word16+        ub = maxBound `div` 2++prop_negate a = a == negate (negate a)+  where types = a :: Word24++prop_abs a = a == abs a+  where types = a :: Word24++prop_signum a = if a == 0 then signum a == a else signum a == 1+  where types = a :: Word24++prop_real a = let r = toRational a in numerator r == fromIntegral a+  where types = a :: Word24++-- Word24 Enum properties+prop_enum1 a = a < maxBound ==> succ a == a + 1+  where types = a :: Word24++prop_enum2 a = a > minBound ==> pred a == a - 1+  where types = a :: Word24++prop_enum3 a = let a' = abs a in+               toEnum a' == fromIntegral a'+  where types = a :: Int++prop_enum4 a = a < maxBound ==> take 2 (enumFrom a) == [a, a+1]+  where types = a :: Word24++prop_enum5 a b = let b' = fromIntegral b in+                 enumFromTo a (a + b') ==+                 map fromIntegral (enumFromTo (fromIntegral a :: Integer)+                                             (fromIntegral (a + b') :: Integer))+  where types = (a :: Word24, b :: Word8)++prop_enum6 a b = take 2 (enumFromThen a b) == [a,b]+  where types = (a :: Word24, b :: Word24)++-- Word24 Integral properties+prop_quot a b =+  quot a b == fromIntegral (quot (fromIntegral a :: Word32) (fromIntegral b :: Word32))+  where types = a :: Word24++prop_rem a b =+  rem a b == fromIntegral (rem (fromIntegral a :: Word32) (fromIntegral b :: Word32))+  where types = a :: Word24++prop_div a b =+  div a b == fromIntegral (div (fromIntegral a :: Word32) (fromIntegral b :: Word32))+  where types = a :: Word24++prop_mod a b =+  mod a b == fromIntegral (mod (fromIntegral a :: Word32) (fromIntegral b :: Word32))+  where types = a :: Word24++prop_quotrem a b = let (j, k) = quotRem a b in+  a == (b * j) + k+  where types = (a :: Word24, b :: Word24)++prop_divmod a b =+  divMod a b == (div a b, mod a b)+  where types = (a :: Word24, b :: Word24)++-- binary Word properties+prop_and a b = (a .&. b) == fromIntegral ( (fromIntegral a :: Word24) .&. (fromIntegral b :: Word24))+  where types = (a :: Word16, b :: Word16)++prop_or a b = (a .|. b) == fromIntegral ( (fromIntegral a :: Word24) .|. (fromIntegral b :: Word24))+  where types = (a :: Word16, b :: Word16)++prop_xor a b = (a `xor` b) == fromIntegral ( (fromIntegral a :: Word24) `xor` (fromIntegral b :: Word24))+  where types = (a :: Word16, b :: Word16)++prop_xor_ident a b = (a `xor` b) `xor` b == a+  where types = (a :: Word24, b :: Word24)++prop_shiftL a = a `shiftL` 1 == a * 2+  where types = a :: Word24++prop_shiftR a = a < maxBound `div` 2 ==>+  (a * 2) `shift` (-1) == a+  where types = a :: Word24++prop_shiftR2 a n = n >= 0 ==> a `shiftR` n == a `shift` (negate n)+  where types = a :: Word24++prop_shiftL_ident a = a `shiftL` 0 == a+  where types = a :: Word24++prop_rotate a b = (a `rotate` b) `rotate` (negate b) == a+  where types = (a :: Word24, b :: Int)++prop_comp a = complement (complement a) == a+  where types = a :: Word24++prop_byteSwap a = byteSwap24 (byteSwap24 a) == a+  where types = a :: Word24++#if MIN_VERSION_base(4,8,0)+prop_clz a = countLeadingZeros a == countLeadingZeros' a+  where+    countLeadingZeros' :: Word24 -> Int+    countLeadingZeros' x = (w-1) - go (w-1)+      where+        go i | i < 0       = i -- no bit set+             | testBit x i = i+             | otherwise   = go (i-1)++        w = finiteBitSize x++prop_ctz a = countTrailingZeros a == countTrailingZeros' a+  where+    countTrailingZeros' :: Word24 -> Int+    countTrailingZeros' x = go 0+      where+        go i | i >= w      = i+             | testBit x i = i+             | otherwise   = go (i+1)+        w = finiteBitSize x+#endif++prop_bit_ident q (NonNegative j) = testBit (bit j `asTypeOf` q) j == (j < 24)++prop_popCount s t a = if a >= 0+  then popCount (a `asTypeOf` s) == popCount (fromIntegral a `asTypeOf` t)+  else+    bitSize s - popCount (a `asTypeOf` s) == bitSize t - popCount (fromIntegral a `asTypeOf` t)++-- Word Storable properties+prop_sizeOf a = sizeOf a == 3+  where types = a :: Word24++prop_align a = alignment a == 3+  where types = a :: Word24++++-- ----------------------------------------+-- Int24 Properties++prop_addIdentI a = a - a == 0+  where types = a :: Int24++prop_multIdentI a = a * 1 == a+  where types = a :: Int24++prop_smallerI a = (fromIntegral ((fromIntegral a) :: Int24) :: Int16) == a++prop_showI a = show a == show (fromIntegral a :: Int24)+  where types = a :: Int16++prop_readI a = a == (read . show) a+  where types = a :: Int24++prop_adderI a b = ((fromIntegral a + fromIntegral b) :: Int) ==+                  fromIntegral ((fromIntegral a + fromIntegral b) :: Int24)+  where types = (a :: Int16, b :: Int16)++prop_negateI a = a == negate (negate a)+  where types = a :: Int24++prop_absI a = if a >= 0 then a == abs a else a == negate (abs a)+  where types = a :: Int24++prop_signumI a = signum a == fromIntegral (signum (fromIntegral a :: Int))+  where types = a :: Int24++prop_realI a = let r = toRational a in numerator r == fromIntegral a+  where types = a :: Int24++-- Int24 Enum Properties+prop_enum1I a = a < maxBound ==> succ a == a + 1+  where types = a :: Int24++prop_enum2I a = a > minBound ==> pred a == a - 1+  where types = a :: Int24++prop_enum3I a = let a' = abs a in+               toEnum a' == fromIntegral a'+  where types = a :: Int++prop_enum4I a = a < maxBound ==> take 2 (enumFrom a) == [a, a+1]+  where types = a :: Int24++prop_enum5I a b = let b' = fromIntegral b in+                 enumFromTo a (a + b') ==+                 map fromIntegral (enumFromTo (fromIntegral a :: Integer)+                                             (fromIntegral (a + b') :: Integer))+  where types = (a :: Int24, b :: Word8)++prop_enum6I a b = take 2 (enumFromThen a b) == [a,b]+  where types = (a :: Int24, b :: Int24)++-- Int24 Integral properties+prop_quotI a b =+  quot a b == fromIntegral (quot (fromIntegral a :: Int32) (fromIntegral b :: Int32))+  where types = a :: Int24++prop_remI a b =+  rem a b == fromIntegral (rem (fromIntegral a :: Int32) (fromIntegral b :: Int32))+  where types = a :: Int24++prop_divI a b =+  div a b == fromIntegral (div (fromIntegral a :: Int32) (fromIntegral b :: Int32))+  where types = a :: Int24++prop_modI a b =+  mod a b == fromIntegral (mod (fromIntegral a :: Int32) (fromIntegral b :: Int32))+  where types = a :: Int24++prop_quotremI a b = let (j, k) = quotRem a b in+  a == (b * j) + k+  where types = (a :: Int24, b :: Int24)++prop_divmodI a b =+  divMod a b == (div a b, mod a b)+  where types = (a :: Int24, b :: Int24)+++-- binary Int properties+prop_andI a b = (a .&. b) == fromIntegral ( (fromIntegral a :: Int24) .&. (fromIntegral b :: Int24))+  where types = (a :: Int16, b :: Int16)++prop_orI a b = (a .|. b) == fromIntegral ( (fromIntegral a :: Int24) .|. (fromIntegral b :: Int24))+  where types = (a :: Int16, b :: Int16)++prop_xorI a b = (a `xor` b) == fromIntegral ( (fromIntegral a :: Int24) `xor` (fromIntegral b :: Int24))+  where types = (a :: Int16, b :: Int16)++prop_xor_identI a b = (a `xor` b) `xor` b == a+  where types = (a :: Int24, b :: Int24)++prop_shiftLI a = a `shiftL` 1 == a * 2+  where types = a :: Int24++prop_shiftL_identI a = a `shiftL` 0 == a+  where types = a :: Int24++prop_shiftRI a = (a < maxBound `div` 2) && (a > minBound `div` 2) ==>+  (a * 2) `shift` (-1) == a+  where types = a :: Int24++prop_shiftR2I a n = n >= 0 ==> a `shiftR` n == a `shift` (negate n)+  where types = a :: Int24++prop_rotateI a b = (a `rotate` b) `rotate` (negate b) == a+  where types = (a :: Int24, b :: Int)++prop_compI a = complement (complement a) == a+  where types = a :: Int24++#if MIN_VERSION_base(4,8,0)+prop_clzI a = countLeadingZeros a == countLeadingZeros' a+  where+    countLeadingZeros' :: Int24 -> Int+    countLeadingZeros' x = (w-1) - go (w-1)+      where+        go i | i < 0       = i -- no bit set+             | testBit x i = i+             | otherwise   = go (i-1)++        w = finiteBitSize x++prop_ctzI a = countTrailingZeros a == countTrailingZeros' a+  where+    countTrailingZeros' :: Int24 -> Int+    countTrailingZeros' x = go 0+      where+        go i | i >= w      = i+             | testBit x i = i+             | otherwise   = go (i+1)+        w = finiteBitSize x+#endif++-- Int Storable properties+prop_sizeOfI a = sizeOf a == 3+  where types = a :: Int24++prop_alignI a = alignment a == 3+  where types = a :: Int24+++-- ----------------------------------------+-- tests+tests = [+ testGroup "Word24"+  [ testGroup "basic" [+    testProperty "add. identity" prop_addIdent+    ,testProperty "mult. identity" prop_multIdent+    ,testProperty "unsigned" prop_unsigned+    ,testProperty "Word16/Word24 conversion" prop_smaller+    ,testProperty "Show" prop_show+    ,testProperty "Read" prop_read+    ,testProperty "addition" prop_adder+    ,testProperty "negate identity" prop_negate+    ,testProperty "absolute value" prop_abs+    ,testProperty "signum" prop_signum+    ,testProperty "Real identity" prop_real+    ]+  ,testGroup "Integral instance" [+    testProperty  "quot" prop_quot+    ,testProperty "rem" prop_rem+    ,testProperty "div" prop_div+    ,testProperty "mod" prop_mod+    ,testProperty "quotRem" prop_quotrem+    ,testProperty "divmod" prop_divmod+    ]+  ,testGroup "Enum instance" [+    testProperty "enum succ" prop_enum1+    ,testProperty "enum pred" prop_enum2+    ,testProperty "toEnum" prop_enum3+    ,testProperty "enumFrom " prop_enum4+    ,testProperty "enumFromTo" prop_enum5+    ,testProperty "enumFromThen" prop_enum6+    ]+  ,testGroup "Bits instance" [+    testProperty "binary and" prop_and+    ,testProperty "binary or" prop_or+    ,testProperty "binary xor" prop_xor+    ,testProperty "binary xor identity" prop_xor_ident+    ,testProperty "binary shiftL" prop_shiftL+    ,testProperty "binary shiftL identity" prop_shiftL_ident+    ,testProperty "binary shift right" prop_shiftR+    ,testProperty "binary shiftR" prop_shiftR2+    ,testProperty "binary rotate" prop_rotate+    ,testProperty "binary complement" prop_comp+    ,testProperty "binary byteSwap24" prop_byteSwap+#if MIN_VERSION_base(4,8,0)+    ,testProperty "binary countLeadingZeros" prop_clz+    ,testProperty "binary countTrailingZeros" prop_ctz+    ,testProperty "binary countTrailingZeros 0" (prop_ctz (0::Word24))+#endif+    ,testProperty "bit/testBit" (prop_bit_ident (0::Word24))+    ,testProperty "popCount"    (prop_popCount (0::Word24) (0::Word))+    ]+  ,testGroup "Storable instance" [+    testProperty  "sizeOf Word24" prop_sizeOf+    ,testProperty "aligntment" prop_align+    ]+  ]+ ,testGroup "Int24"+  [testGroup "basic" [+    testProperty "add. identity" prop_addIdentI+    ,testProperty "mult. identity" prop_multIdentI+    ,testProperty "Int16/Int24 conversion" prop_smallerI+    ,testProperty "Show" prop_showI+    ,testProperty "Read" prop_readI+    ,testProperty "addition" prop_adderI+    ,testProperty "negate identity" prop_negateI+    ,testProperty "absolute value" prop_absI+    ,testProperty "signum" prop_signumI+    ,testProperty "Real identity" prop_realI+    ]+  ,testGroup "Integral instance" [+    testProperty  "quot" prop_quotI+    ,testProperty "rem" prop_remI+    ,testProperty "div" prop_divI+    ,testProperty "mod" prop_modI+    ,testProperty "quotRem" prop_quotremI+    ,testProperty "divmod" prop_divmodI+    ]+  ,testGroup "Enum instance" [+    testProperty "enum succ" prop_enum1I+    ,testProperty "enum pred" prop_enum2I+    ,testProperty "toEnum" prop_enum3I+    ,testProperty "enumFrom " prop_enum4I+    ,testProperty "enumFromTo" prop_enum5I+    ,testProperty "enumFromThen" prop_enum6I+    ]+  ,testGroup "Bits instance" [+    testProperty "binary and" prop_andI+    ,testProperty "binary or" prop_orI+    ,testProperty "binary xor" prop_xorI+    ,testProperty "binary xor identity" prop_xor_identI+    ,testProperty "binary shiftL" prop_shiftLI+    ,testProperty "binary shiftL identity" prop_shiftL_identI+    ,testProperty "binary shift right" prop_shiftRI+    ,testProperty "binary shiftR" prop_shiftR2I+    ,testProperty "binary rotate" prop_rotateI+    ,testProperty "binary complement" prop_compI+#if MIN_VERSION_base(4,8,0)+    ,testProperty "binary countLeadingZeros" prop_clzI+    ,testProperty "binary countTrailingZeros" prop_ctzI+    ,testProperty "binary countTrailingZeros 0" (prop_ctzI (0::Int24))+#endif+    ,testProperty "bit/testBit" (prop_bit_ident (0::Int24))+    ,testProperty "popCount"    (prop_popCount (0::Int24) (0::Int))+    ]+  ,testGroup "Storable instance" [+    testProperty  "sizeOf Int24" prop_sizeOfI+    ,testProperty "aligntment" prop_alignI+    ]+  ]+ ]+
+ wire-streams-bench/Main.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++-------------------------------------------------------------------------------++import           Control.Exception        (evaluate)+import           Control.Monad            (replicateM_)+import           Control.Monad.IO.Class+import           Criterion.Main+import           Data.Binary              (Binary)+import           Data.ByteString          (ByteString)+import qualified Data.ByteString.Lazy     as BL+import           Data.Conduit+import qualified Data.Conduit.Binary      as Conduit+import qualified Data.Conduit.Cereal      as Conduit+import           Data.Serialize           (Serialize)+import           Data.Serialize           (Get, get, put, runPutLazy)+import           GHC.Generics++-------------------------------------------------------------------------------++import qualified System.IO.Streams        as Streams+import qualified System.IO.Streams.Binary as Binary+import qualified System.IO.Streams.Cereal as Cereal++-------------------------------------------------------------------------------++main :: IO ()+main = do+  let lstring = BL.concat $ map (runPutLazy . put) foos+      foos = map exFoo [0..1000]+      exFoo x = Foo x "oh look, a Foo!"+  defaultMain+    [ bgroup "decode one element wire-streams/cereal" [+         bench "1000 items" $ whnfIO $ benchCS lstring ]+    , bgroup "decode one element wire-streams/binary" [+         bench "1000 items" $ whnfIO $ benchBS lstring ]+    , bgroup "decode one element cereal-conduit" [+         bench "1000 items" $ whnfIO $ benchCC lstring ]+    , bgroup "decode 1000 elements from wire-streams/cereal" [+         bench "1000 items" $ whnfIO $ benchCSA lstring ]+    , bgroup "decode 1000 elements from wire-streams/binary" [+         bench "1000 items" $ whnfIO $ benchBSA lstring ]+    , bgroup "decode 1000 elements cereal-conduit" [+         bench "1000 items" $ whnfIO $ benchCCA lstring ]+    ]++benchCS lstring = do+    s <- Cereal.decodeInputStream =<< Streams.fromLazyByteString lstring+    a <- Streams.read s :: IO (Maybe Foo)+    evaluate a++benchBS lstring = do+    s <- Binary.decodeInputStream =<< Streams.fromLazyByteString lstring+    a <- Streams.read s :: IO (Maybe Foo)+    evaluate a++benchCC lstring = do+    Conduit.sourceLbs lstring =$= Conduit.conduitGet2 (get :: Get Foo) $$ do+        a <- await+        liftIO (evaluate a)++benchCSA lstring = do+    s <- Cereal.decodeInputStream =<< Streams.fromLazyByteString lstring+    replicateM_ 1000 $ do+        a <- Streams.read s :: IO (Maybe Foo)+        evaluate a++benchBSA lstring = do+    s <- Binary.decodeInputStream =<< Streams.fromLazyByteString lstring+    replicateM_ 1000 $ do+        a <- Streams.read s :: IO (Maybe Foo)+        evaluate a++benchCCA lstring = do+    Conduit.sourceLbs lstring =$= Conduit.conduitGet2 (get :: Get Foo) $$+        replicateM_ 1000 $ do+            a <- await+            liftIO (evaluate a)++-------------------------------------------------------------------------------++data Foo = Foo Int ByteString deriving (Generic, Show, Eq)++instance Serialize Foo+instance Binary    Foo
+ wire-streams-bench/System/IO/Streams/Cereal.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings  #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Sytem.IO.Streams.Cereal+-- Copyright   :  Soostone Inc, Winterland+-- License     :  BSD3+--+-- Maintainer  :  Winterland+-- Stability   :  experimental+--+-- Use cereal to encode/decode io-streams.+----------------------------------------------------------------------------++module System.IO.Streams.Cereal (+    -- * single element encode/decode+      getFromStream+    , decodeFromStream+    , putToStream+    -- * 'InputStream' encode/decode+    , getInputStream+    , decodeInputStream+    -- * 'OutputStream' encode+    , putOutputStream+    , encodeOutputStream+    -- * exception type+    , DecodeException(..)+    ) where++-------------------------------------------------------------------------------++import           Control.Exception      (Exception, throwIO)+import           Control.Monad          (unless)+import           Data.ByteString        (ByteString)+import qualified Data.ByteString.Char8  as S+import           Data.Serialize+import           Data.Typeable+import qualified System.IO.Streams      as Streams+import           System.IO.Streams.Core++-------------------------------------------------------------------------------++-- | An Exception raised when cereal decoding fails.+data DecodeException = DecodeException String+  deriving (Typeable)++instance Show DecodeException where+    show (DecodeException s) = "System.IO.Streams.Cereal: cereal decode exception: " ++ s++instance Exception DecodeException++-------------------------------------------------------------------------------++-- | write a instance of 'Serialize' to an 'OutputStream'+--+putToStream :: Serialize a => Maybe a -> OutputStream ByteString -> IO ()+putToStream Nothing  = Streams.write Nothing+putToStream (Just a) = (Streams.writeLazyByteString . runPutLazy . put) a+{-# INLINE putToStream #-}++-------------------------------------------------------------------------------++-- | Take a 'Get' and an 'InputStream' and decode a+-- value. Consumes only as much input as necessary to decode the+-- value. Unconsumed input will be unread. If there is+-- an error while deserializing, a 'DecodeException' is thrown, and+-- unconsumed part will be unread. To simplify upstream generation,+-- all empty 'ByteString' will be filtered out and not passed to cereal,+-- only EOFs/Nothing will close a cereal decoder.+--+-- Examples:+--+-- >>> import qualified System.IO.Streams as Streams+-- >>> getFromStream (get :: Get String) =<< Streams.fromByteString (Data.ByteString.drop 1 $ runPut $ put "encode me")+-- *** Exception: System.IO.Streams.Cereal: cereal decode exception: too few bytes+-- From:	demandInput+-- <BLANKLINE>+--+getFromStream :: Get a -> InputStream ByteString -> IO (Maybe a)+getFromStream g is =+    Streams.read is >>= maybe (return Nothing) (go . runGetPartial g)+  where+    go (Fail msg s) = do+        unless (S.null s) (Streams.unRead s is)+        throwIO (DecodeException msg)+    go (Done r s) = do+         unless (S.null s) (Streams.unRead s is)+         return (Just r)+    go c@(Partial cont) =+        Streams.read is >>= maybe (go (cont S.empty))   -- use 'empty' to notify cereal ending.+        (\ s -> if S.null s then go c else go (cont s))+{-# INLINE getFromStream #-}++-- | typeclass version of 'getFromStream'+decodeFromStream :: Serialize a => InputStream ByteString -> IO (Maybe a)+decodeFromStream = getFromStream get+{-# INLINE decodeFromStream #-}++-------------------------------------------------------------------------------++-- | Convert a stream of individual encoded 'ByteString's to a stream+-- of Results. Throws a 'DecodeException' on error.+getInputStream :: Get a -> InputStream ByteString -> IO (InputStream a)+getInputStream g is = makeInputStream (getFromStream g is)+{-# INLINE getInputStream #-}++-- | typeclass version of 'getInputStream'+decodeInputStream :: Serialize a => InputStream ByteString -> IO (InputStream a)+decodeInputStream = getInputStream get+{-# INLINE decodeInputStream #-}++-------------------------------------------------------------------------------++-- | create an 'OutputStream' of serializable values from an 'OutputStream'+-- of bytestrings with a 'Putter'.+putOutputStream :: Putter a -> OutputStream ByteString -> IO (OutputStream a)+putOutputStream p os = Streams.makeOutputStream $ \ ma ->+    case ma of Nothing -> Streams.write Nothing os+               Just a  -> Streams.writeLazyByteString (runPutLazy (p a)) os+{-# INLINE putOutputStream #-}++-- | typeclass version of 'putOutputStream'+encodeOutputStream :: Serialize a => OutputStream ByteString -> IO (OutputStream a)+encodeOutputStream = putOutputStream put+{-# INLINE encodeOutputStream #-}
+ word24-bench/Benchmark.hs view
@@ -0,0 +1,32 @@+module Main where++import Criterion.Main+import Control.DeepSeq+import Data.Int.Int24+import Data.Word.Word24+import Data.Int+import Data.Word+import Data.List++main = defaultMain+  [ bgroup "Int24" intses+  , bgroup "Word24" wordses+  , bgroup "Int16"    baseses+  , bgroup "Word16" basessW+  ]++benches :: (Enum i, Num i, NFData i, Integral i) => i -> [Benchmark]+benches x =+   [ bench "Add" $ nf (\i -> foldl' (+) i [1..100]) x+   , bench "Mul" $ nf (\i -> foldl' (*) i [1..100]) x+   , bench "quot" $ nf (\i -> map (flip quot i) [1..25]) x+   , bench "rem" $ nf (\i -> map (flip rem i) [1..25]) x+   , bench "div" $ nf (\i -> map (flip div i) [1..25]) x+   , bench "mod" $ nf (\i -> map (flip mod i) [1..25]) x+   ]+{-# INLINE benches #-}++intses  = benches (1 :: Int24)+wordses = benches (1 :: Word24)+baseses = benches (1 :: Int16)+basessW = benches (1 :: Word16)