selda-postgresql 0.1.7.3 → 0.1.8.0

raw patch · 3 files changed

+204/−163 lines, 3 filesdep +postgresql-binarydep +selda-jsondep +timedep −transformersdep ~basedep ~seldaPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: postgresql-binary, selda-json, time, uuid-types

Dependencies removed: transformers

Dependency ranges changed: base, selda

API changes (from Hackage documentation)

Files

• selda-postgresql.cabal +11/−10
• src/Database/Selda/PostgreSQL.hs +119/−74
• src/Database/Selda/PostgreSQL/Encoding.hs +74/−79

@@ -1,5 +1,5 @@ name:                selda-postgresql-version:             0.1.7.3+version:             0.1.8.0 synopsis:            PostgreSQL backend for the Selda database EDSL. description:         PostgreSQL backend for the Selda database EDSL.                      Requires the PostgreSQL @libpq@ development libraries to be@@ -28,17 +28,18 @@     OverloadedStrings     CPP   build-depends:-      base       >=4.8     && <5-    , bytestring >=0.9     && <0.11-    , exceptions >=0.8     && <0.11-    , selda      >=0.3.0.0 && <0.4-    , text       >=1.0     && <1.3+      base       >=4.9 && <5+    , bytestring >=0.9 && <0.11+    , exceptions >=0.8 && <0.11+    , selda      >=0.4 && <0.5+    , selda-json >=0.1 && <0.2+    , text       >=1.0 && <1.3   if !flag(haste)     build-depends:-      postgresql-libpq >=0.9 && <0.10-  if impl(ghc < 7.11)-    build-depends:-      transformers  >=0.4 && <0.6+        postgresql-binary >=0.12 && <0.13+      , postgresql-libpq  >=0.9  && <0.10+      , time              >=1.5  && <1.10+      , uuid-types        >=1.0  && <1.1   hs-source-dirs:     src   default-language:

@@ -1,27 +1,39 @@ {-# LANGUAGE OverloadedStrings, RecordWildCards, GADTs, CPP #-} -- | PostgreSQL backend for Selda. module Database.Selda.PostgreSQL-  ( PGConnectInfo (..)+  ( PG, PGConnectInfo (..)   , withPostgreSQL, on, auth   , pgOpen, pgOpen', seldaClose   , pgConnString, pgPPConfig   ) where-import qualified Data.ByteString.Char8 as BS-import Data.Dynamic-import Data.Foldable (for_)+#if !MIN_VERSION_base(4, 11, 0) import Data.Monoid+#endif+import Data.ByteString (ByteString) import qualified Data.Text as T-import Data.Text.Encoding-import Database.Selda.Backend-import Control.Monad (forM_, void)+import Database.Selda.Backend hiding (toText)+import Database.Selda.JSON+import Database.Selda.Unsafe as Selda (cast, operator) import Control.Monad.Catch import Control.Monad.IO.Class  #ifndef __HASTE__+import Control.Monad (void)+import qualified Data.ByteString as BS (foldl')+import qualified Data.ByteString.Char8 as BS (pack, unpack)+import Data.Dynamic+import Data.Foldable (for_)+import Data.Text.Encoding import Database.Selda.PostgreSQL.Encoding import Database.PostgreSQL.LibPQ hiding (user, pass, db, host) #endif +data PG++instance JSONBackend PG where+  (~>) = operator "->"+  jsonToText = Selda.cast+ -- | PostgreSQL connection information. data PGConnectInfo = PGConnectInfo   { -- | Host to connect to.@@ -69,7 +81,7 @@ infixl 4 `auth`  -- | Convert `PGConnectInfo` into `ByteString`-pgConnString :: PGConnectInfo -> BS.ByteString+pgConnString :: PGConnectInfo -> ByteString #ifdef __HASTE__ pgConnString PGConnectInfo{..} = error "pgConnString called in JS context" #else@@ -91,8 +103,10 @@ -- | Perform the given computation over a PostgreSQL database. --   The database connection is guaranteed to be closed when the computation --   terminates.-withPostgreSQL :: (MonadIO m, MonadThrow m, MonadMask m)-               => PGConnectInfo -> SeldaT m a -> m a+withPostgreSQL :: (MonadIO m, MonadMask m)+               => PGConnectInfo+               -> SeldaT PG m a+               -> m a #ifdef __HASTE__ withPostgreSQL _ _ = return $ error "withPostgreSQL called in JS context" #else@@ -102,13 +116,18 @@ -- | Open a new PostgreSQL connection. The connection will persist across --   calls to 'runSeldaT', and must be explicitly closed using 'seldaClose' --   when no longer needed.-pgOpen :: (MonadIO m, MonadMask m) => PGConnectInfo -> m SeldaConnection-#ifdef __HASTE__-pgOpen _ = return $ error "pgOpen called in JS context"-#else+pgOpen :: (MonadIO m, MonadMask m) => PGConnectInfo -> m (SeldaConnection PG) pgOpen ci = pgOpen' (pgSchema ci) (pgConnString ci) -pgOpen' :: (MonadIO m, MonadMask m) => Maybe T.Text -> BS.ByteString -> m SeldaConnection+pgPPConfig :: PPConfig+pgOpen' :: (MonadIO m, MonadMask m)+        => Maybe T.Text+        -> ByteString+        -> m (SeldaConnection PG)+#ifdef __HASTE__+pgOpen' _ _ = return $ error "pgOpen' called in JS context"+pgPPConfig = error "pgPPConfig evaluated in JS context"+#else pgOpen' schema connStr =   bracketOnError (liftIO $ connectdb connStr) (liftIO . finish) $ \conn -> do     st <- liftIO $ status conn@@ -129,7 +148,6 @@         [ "unable to connect to postgres server: " ++ show f         ] -pgPPConfig :: PPConfig pgPPConfig = defPPConfig     { ppType = pgColType defPPConfig     , ppTypeHook = pgTypeHook@@ -146,15 +164,19 @@     pgTypeHook :: SqlTypeRep -> [ColAttr] -> (SqlTypeRep -> T.Text) -> T.Text     pgTypeHook ty attrs fun       | isGenericIntPrimaryKey ty attrs = pgColTypePK pgPPConfig TRowID-      | otherwise = fun ty+      | otherwise                       = pgTypeRenameHook fun ty +    pgTypeRenameHook _ TDateTime = "timestamp with time zone"+    pgTypeRenameHook _ TTime     = "time with time zone"+    pgTypeRenameHook f ty        = f ty+     pgColAttrsHook :: SqlTypeRep -> [ColAttr] -> ([ColAttr] -> T.Text) -> T.Text     pgColAttrsHook ty attrs fun-      | isGenericIntPrimaryKey ty attrs = fun [Primary]-      | otherwise = fun $ filter (/= AutoIncrement) attrs+      | isGenericIntPrimaryKey ty attrs = fun [AutoPrimary Strong]+      | otherwise = fun attrs      bigserialQue :: [ColAttr]-    bigserialQue = [Primary,AutoIncrement,Required,Unique]+    bigserialQue = [AutoPrimary Strong, Required]      -- For when we use 'autoPrimaryGen' on 'Int' field     isGenericIntPrimaryKey :: SqlTypeRep -> [ColAttr] -> Bool@@ -162,7 +184,7 @@  -- | Create a `SeldaBackend` for PostgreSQL `Connection` pgBackend :: Connection   -- ^ PostgreSQL connection object.-          -> SeldaBackend+          -> SeldaBackend PG pgBackend c = SeldaBackend   { runStmt         = \q ps -> right <$> pgQueryRunner c False q ps   , runStmtWithPK   = \q ps -> left <$> pgQueryRunner c True q ps@@ -186,7 +208,7 @@ disableFKs c True = do     void $ pgQueryRunner c False "BEGIN TRANSACTION;" []     void $ pgQueryRunner c False create []-    void $ pgQueryRunner c False drop []+    void $ pgQueryRunner c False dropTbl []   where     create = mconcat       [ "create table if not exists __selda_dropped_fks ("@@ -194,7 +216,7 @@       , "        sql text"       , ");"       ]-    drop = mconcat+    dropTbl = mconcat       [ "do $$ declare t record;"       , "begin"       , "    for t in select conrelid::regclass::varchar table_name, conname constraint_name,"@@ -225,20 +247,35 @@       , "end $$;"       ] -pgGetTableInfo :: Connection -> T.Text -> IO [ColumnInfo]+pgGetTableInfo :: Connection -> T.Text -> IO TableInfo pgGetTableInfo c tbl = do     Right (_, vals) <- pgQueryRunner c False tableinfo []     if null vals       then do-        pure []+        pure $ TableInfo [] [] []       else do-        Right (_, [[SqlString pk]]) <- pgQueryRunner c False pkquery []-        Right (_, uniques) <- pgQueryRunner c False uniquequery []+        Right (_, pkInfo) <- pgQueryRunner c False pkquery []+        Right (_, us) <- pgQueryRunner c False uniquequery []+        let uniques = map splitNames us         Right (_, fks) <- pgQueryRunner c False fkquery []         Right (_, ixs) <- pgQueryRunner c False ixquery []-        mapM (describe pk fks (map toText ixs) (map toText uniques)) vals+        colInfos <- mapM (describe fks (map toText ixs)) vals+        x <- pure $ TableInfo+          { tableColumnInfos = colInfos+          , tableUniqueGroups = map (map mkColName) uniques+          , tablePrimaryKey = [mkColName pk | [SqlString pk] <- pkInfo]+          }+        pure x   where+    splitNames = breakNames . toText+    -- TODO: this is super ugly; should really be fixed+    breakNames s =+      case T.break (== '"') s of+        (n, ns) | T.null n  -> []+                | T.null ns -> [n]+                | otherwise -> n : breakNames (T.tail ns)     toText [SqlString s] = s+    toText _             = error "toText: unreachable"     tableinfo = mconcat       [ "SELECT column_name, data_type, is_nullable "       , "FROM information_schema.columns "@@ -249,16 +286,18 @@       , "FROM pg_index i "       , "JOIN pg_attribute a ON a.attrelid = i.indrelid "       , "  AND a.attnum = ANY(i.indkey) "-      , "WHERE i.indrelid = '", tbl, "'::regclass "+      , "WHERE i.indrelid = '\"", tbl, "\"'::regclass "       , "  AND i.indisprimary;"       ]     uniquequery = mconcat-      [ "SELECT a.attname "+      [ "SELECT string_agg(a.attname, '\"') "       , "FROM pg_index i "       , "JOIN pg_attribute a ON a.attrelid = i.indrelid "       , "  AND a.attnum = ANY(i.indkey) "-      , "WHERE i.indrelid = '", tbl, "'::regclass "-      , "  AND i.indisunique;"+      , "WHERE i.indrelid = '\"", tbl, "\"'::regclass "+      , "  AND i.indisunique "+      , "  AND NOT i.indisprimary "+      , "GROUP BY i.indkey;"       ]     fkquery = mconcat       [ "SELECT kcu.column_name, ccu.table_name, ccu.column_name "@@ -278,30 +317,31 @@       , "and a.attrelid = t.oid "       , "and a.attnum = ANY(ix.indkey) "       , "and t.relkind = 'r' "+      , "and not ix.indisunique "+      , "and not ix.indisprimary "+      , "and t.relkind = 'r' "       , "and t.relname = '", tbl , "';"       ]-    describe pk fks ixs us [SqlString name, SqlString ty, SqlString nullable] =+    describe fks ixs [SqlString name, SqlString ty, SqlString nullable] =       return $ ColumnInfo         { colName = mkColName name-        , colType = mkTypeRep (pk == name) ty'-        , colIsPK = pk == name-        , colIsAutoIncrement = ty' == "bigserial"-        , colIsUnique = name `elem` us-        , colIsNullable = readBool (encodeUtf8 (T.toLower nullable))+        , colType = mkTypeRep ty'+        , colIsAutoPrimary = ty' == "bigserial"+        , colIsNullable = readBool nullable         , colHasIndex = name `elem` ixs         , colFKs =-            [ (mkTableName tbl, mkColName col)-            | [SqlString cname, SqlString tbl, SqlString col] <- fks+            [ (mkTableName tblname, mkColName col)+            | [SqlString cname, SqlString tblname, SqlString col] <- fks             , name == cname             ]         }       where ty' = T.toLower ty-    describe _ _ _ _ results =+    describe _ _ results =       throwM $ SqlError $ "bad result from table info query: " ++ show results  pgQueryRunner :: Connection -> Bool -> T.Text -> [Param] -> IO (Either Int (Int, [[SqlValue]])) pgQueryRunner c return_lastid q ps = do-    mres <- execParams c (encodeUtf8 q') [fromSqlValue p | Param p <- ps] Text+    mres <- execParams c (encodeUtf8 q') [fromSqlValue p | Param p <- ps] Binary     unlessError c errmsg mres $ \res -> do       if return_lastid         then Left <$> getLastId res@@ -311,12 +351,12 @@     q' | return_lastid = q <> " RETURNING LASTVAL();"        | otherwise     = q -    getLastId res = (readInt . maybe "0" id) <$> getvalue res 0 0+    getLastId res = (maybe 0 id . fmap readInt) <$> getvalue res 0 0  pgRun :: Connection -> Dynamic -> [Param] -> IO (Int, [[SqlValue]]) pgRun c hdl ps = do     let Just sid = fromDynamic hdl :: Maybe StmtID-    mres <- execPrepared c (BS.pack $ show sid) (map mkParam ps) Text+    mres <- execPrepared c (BS.pack $ show sid) (map mkParam ps) Binary     unlessError c errmsg mres $ getRows   where     errmsg = "error executing prepared statement"@@ -327,16 +367,19 @@ -- | Get all rows from a result. getRows :: Result -> IO (Int, [[SqlValue]]) getRows res = do-  rows <- ntuples res-  cols <- nfields res-  types <- mapM (ftype res) [0..cols-1]-  affected <- cmdTuples res-  result <- mapM (getRow res types cols) [0..rows-1]-  pure $ case affected of-    Just "" -> (0, result)-    Just s  -> (readInt s, result)-    _       -> (0, result)+    rows <- ntuples res+    cols <- nfields res+    types <- mapM (ftype res) [0..cols-1]+    affected <- cmdTuples res+    result <- mapM (getRow res types cols) [0..rows-1]+    pure $ case affected of+      Just "" -> (0, result)+      Just s  -> (bsToPositiveInt s, result)+      _       -> (0, result)+  where+    bsToPositiveInt = BS.foldl' (\a x -> a*10+fromIntegral x-48) 0 + -- | Get all columns for the given row. getRow :: Result -> [Oid] -> Column -> Row -> IO [SqlValue] getRow res types cols row = do@@ -379,21 +422,21 @@     , maybe "" ((": " ++) . BS.unpack) me     ] -mkTypeRep :: Bool -> T.Text ->  Either T.Text SqlTypeRep-mkTypeRep True  "bigint"           = Right TRowID-mkTypeRep True  "bigserial"        = Right TRowID-mkTypeRep True  "int8"             = Right TRowID-mkTypeRep _ispk "int8"             = Right TInt-mkTypeRep _ispk "bigint"           = Right TInt-mkTypeRep _ispk "float8"           = Right TFloat-mkTypeRep _ispk "double precision" = Right TFloat-mkTypeRep _ispk "timestamp"        = Right TDateTime-mkTypeRep _ispk "bytea"            = Right TBlob-mkTypeRep _ispk "text"             = Right TText-mkTypeRep _ispk "boolean"          = Right TBool-mkTypeRep _ispk "date"             = Right TDate-mkTypeRep _ispk "time"             = Right TTime-mkTypeRep _ispk typ                = Left typ+mkTypeRep :: T.Text ->  Either T.Text SqlTypeRep+mkTypeRep "bigserial"                = Right TRowID+mkTypeRep "int8"                     = Right TInt+mkTypeRep "bigint"                   = Right TInt+mkTypeRep "float8"                   = Right TFloat+mkTypeRep "double precision"         = Right TFloat+mkTypeRep "timestamp with time zone" = Right TDateTime+mkTypeRep "bytea"                    = Right TBlob+mkTypeRep "text"                     = Right TText+mkTypeRep "boolean"                  = Right TBool+mkTypeRep "date"                     = Right TDate+mkTypeRep "time with time zone"      = Right TTime+mkTypeRep "uuid"                     = Right TUUID+mkTypeRep "jsonb"                    = Right TJSON+mkTypeRep typ                        = Left typ  -- | Custom column types for postgres. pgColType :: PPConfig -> SqlTypeRep -> T.Text@@ -402,16 +445,18 @@ pgColType _ TFloat    = "FLOAT8" pgColType _ TDateTime = "TIMESTAMP" pgColType _ TBlob     = "BYTEA"+pgColType _ TUUID     = "UUID"+pgColType _ TJSON     = "JSONB" pgColType cfg t       = ppType cfg t  -- | Custom attribute types for postgres. pgColAttr :: ColAttr -> T.Text-pgColAttr Primary       = "PRIMARY KEY"-pgColAttr AutoIncrement = ""-pgColAttr Required      = "NOT NULL"-pgColAttr Optional      = "NULL"-pgColAttr Unique        = "UNIQUE"-pgColAttr (Indexed _)   = ""+pgColAttr Primary         = ""+pgColAttr (AutoPrimary _) = "PRIMARY KEY"+pgColAttr Required        = "NOT NULL"+pgColAttr Optional        = "NULL"+pgColAttr Unique          = "UNIQUE"+pgColAttr (Indexed _)     = ""  -- | Custom column types (primary key position) for postgres. pgColTypePK :: PPConfig -> SqlTypeRep -> T.Text

@@ -1,34 +1,36 @@ {-# LANGUAGE GADTs, BangPatterns, OverloadedStrings, CPP #-} -- | Encoding/decoding for PostgreSQL. module Database.Selda.PostgreSQL.Encoding-  ( toSqlValue, fromSqlValue, fromSqlType-  , readInt, readBool+  ( toSqlValue, fromSqlValue, fromSqlType, readInt, readBool   ) where #ifdef __HASTE__ -toSqlValue, fromSqlValue, fromSqlType, readInt :: a+toSqlValue, fromSqlValue, fromSqlType, readInt, readBool :: a toSqlValue = undefined fromSqlValue = undefined fromSqlType = undefined readInt = undefined+readBool = undefined  #else +import Control.Applicative ((<|>)) import qualified Data.ByteString as BS-import Data.ByteString.Builder-import Data.ByteString.Char8 (unpack)-import qualified Data.ByteString.Char8 as BSC (map) import qualified Data.ByteString.Lazy as LBS import Data.Char (toLower)-import qualified Data.Text as Text-import Data.Text.Encoding-import Database.PostgreSQL.LibPQ (Oid (..), Format (..))+import qualified Data.Text as T+import Data.Time (utc, localToUTCTimeOfDay)+import Database.PostgreSQL.LibPQ (Oid (..), Format (Binary)) import Database.Selda.Backend-import Unsafe.Coerce+import PostgreSQL.Binary.Encoding as Enc+import PostgreSQL.Binary.Decoding as Dec+import qualified Data.UUID.Types as UUID (toByteString)+import Data.Int (Int16, Int32, Int64)  -- | OIDs for all types used by Selda. blobType, boolType, intType, int32Type, int16Type, textType, doubleType,-  dateType, timeType, timestampType, nameType, varcharType :: Oid+  dateType, timeType, timestampType, nameType, varcharType, uuidType,+  jsonbType :: Oid boolType      = Oid 16 intType       = Oid 20 int32Type     = Oid 23@@ -37,24 +39,37 @@ nameType      = Oid 19 doubleType    = Oid 701 dateType      = Oid 1082-timeType      = Oid 1083-timestampType = Oid 1114+timeType      = Oid 1266+timestampType = Oid 1184 blobType      = Oid 17 varcharType   = Oid 1043+uuidType      = Oid 2950+jsonbType     = Oid 3802 +bytes :: Enc.Encoding -> BS.ByteString+bytes = Enc.encodingBytes+ -- | Convert a parameter into an postgres parameter triple. fromSqlValue :: Lit a -> Maybe (Oid, BS.ByteString, Format)-fromSqlValue (LBool b)     = Just (boolType, toBS $ if b then word8 1 else word8 0, Binary)-fromSqlValue (LInt n)      = Just (intType, toBS $ int64BE (fromIntegral n), Binary)-fromSqlValue (LDouble f)   = Just (doubleType, toBS $ int64BE (unsafeCoerce f), Binary)-fromSqlValue (LText s)     = Just (textType, encodeUtf8 $ Text.filter (/= '\0') s, Binary)-fromSqlValue (LDateTime s) = Just (timestampType, encodeUtf8 s, Text)-fromSqlValue (LTime s)     = Just (timeType, encodeUtf8 s, Text)-fromSqlValue (LDate s)     = Just (dateType, encodeUtf8 s, Text)-fromSqlValue (LBlob b)     = Just (blobType, b, Binary)+fromSqlValue (LBool b)     = Just (boolType, bytes $ Enc.bool b, Binary)+fromSqlValue (LInt n)      = Just ( intType+                                  , bytes $ Enc.int8_int64 $ fromIntegral n+                                  , Binary)+fromSqlValue (LDouble f)   = Just (doubleType, bytes $ Enc.float8 f, Binary)+fromSqlValue (LText s)     = Just (textType, bytes $ Enc.text_strict s, Binary)+fromSqlValue (LDateTime t) = Just ( timestampType+                                  , bytes $ Enc.timestamptz_int t+                                  , Binary)+fromSqlValue (LTime t)     = Just (timeType, bytes $ Enc.timetz_int (t, utc), Binary)+fromSqlValue (LDate d)     = Just (dateType, bytes $ Enc.date d, Binary)+fromSqlValue (LUUID x)     = Just (uuidType, bytes $ Enc.uuid x, Binary)+fromSqlValue (LBlob b)     = Just (blobType, bytes $ Enc.bytea_strict b, Binary) fromSqlValue (LNull)       = Nothing fromSqlValue (LJust x)     = fromSqlValue x-fromSqlValue (LCustom l)   = fromSqlValue l+fromSqlValue (LCustom TJSON (LBlob b)) = Just ( jsonbType+                                              , bytes $ Enc.jsonb_bytes b+                                              , Binary)+fromSqlValue (LCustom _ l) = fromSqlValue l  -- | Get the corresponding OID for an SQL type representation. fromSqlType :: SqlTypeRep -> Oid@@ -67,71 +82,51 @@ fromSqlType TTime     = timeType fromSqlType TBlob     = blobType fromSqlType TRowID    = intType+fromSqlType TUUID     = uuidType+fromSqlType TJSON     = jsonbType  -- | Convert the given postgres return value and type to an @SqlValue@. toSqlValue :: Oid -> BS.ByteString -> SqlValue toSqlValue t val-  | t == boolType    = SqlBool $ readBool (BSC.map toLower val)-  | t == intType     = SqlInt $ readInt val-  | t == int32Type   = SqlInt $ readInt val-  | t == int16Type   = SqlInt $ readInt val-  | t == doubleType  = SqlFloat $ read (unpack val)-  | t == blobType    = SqlBlob $ pgDecode val-  | t `elem` textish = SqlString (decodeUtf8 val)-  | otherwise        = error $ "BUG: result with unknown type oid: " ++ show t+  | t == boolType      = SqlBool    $ parse Dec.bool val+  | t == intType       = SqlInt     $ fromIntegral $ parse (Dec.int :: Value Int64) val+  | t == int32Type     = SqlInt     $ fromIntegral $ parse (Dec.int :: Value Int32) val+  | t == int16Type     = SqlInt     $ fromIntegral $ parse (Dec.int :: Value Int16) val+  | t == doubleType    = SqlFloat   $ parse Dec.float8 val+  | t == blobType      = SqlBlob    $ parse Dec.bytea_strict val+  | t == uuidType      = SqlBlob    $ uuid2bs $ parse Dec.uuid val+  | t == timestampType = SqlUTCTime $ parse parseTimestamp val+  | t == timeType      = SqlTime    $ toTime $ parse parseTime val+  | t == dateType      = SqlDate    $ parse Dec.date val+  | t == jsonbType     = SqlBlob    $ parse (Dec.jsonb_bytes pure) val+  | t `elem` textish   = SqlString  $ parse Dec.text_strict val+  | otherwise          = error $ "BUG: result with unknown type oid: " ++ show t   where-    -- PostgreSQL hex strings are of the format \xdeadbeefdeadbeefdeadbeef...-    pgDecode s-      | BS.index s 0 == 92 && BS.index s 1 == 120 =-        BS.pack $ go $ BS.drop 2 s-      | otherwise =-        error $ "bad blob string from postgres: " ++ show s-      where-        hex n x =-          case BS.index x n of-            c | c >= 97   -> c - 87 -- c >= 'a'-              | c >= 65   -> c - 55 -- c >= 'A'-              | otherwise -> c - 48 -- c is numeric-        go x-          | BS.length x >= 2 = (16*hex 0 x + (hex 1 x)) : go (BS.drop 2 x)-          | otherwise        = []-    textish = [textType, timestampType, timeType, dateType, nameType, varcharType]+    parseTimestamp = Dec.timestamptz_int <|> Dec.timestamptz_float+    parseTime = Dec.timetz_int <|> Dec.timetz_float+    toTime (tod, tz) = snd $ localToUTCTimeOfDay tz tod+    uuid2bs = LBS.toStrict . UUID.toByteString+    textish = [textType, nameType, varcharType] --- | Attempt to make sense of a bool-ish value.---   Note that values should all be in lowercase.-readBool :: BS.ByteString -> Bool-readBool "f"     = False-readBool "0"     = False-readBool "false" = False-readBool "n"     = False-readBool "no"    = False-readBool "off"   = False-readBool _       = True+parse :: Value a -> BS.ByteString -> a+parse p x =+  case valueParser p x of+    Right x' -> x'+    Left _   -> error "unable to decode value" --- | Read an integer from a strict bytestring.---   Assumes that the bytestring does, in fact, contain an integer.+-- | Read an Int from a binary encoded pgint8. readInt :: BS.ByteString -> Int-readInt s-  | BS.head s == asciiDash = negate $! go 1 0-  | otherwise              = go 0 0-  where-    !len = BS.length s-    !asciiZero = 48-    !asciiDash = 45-    go !i !acc-      | len > i   = go (i+1) (acc * 10 + fromIntegral (BS.index s i - asciiZero))-      | otherwise = acc+readInt = fromIntegral . parse (Dec.int :: Value Int64) --- | Reify a builder to a strict bytestring.-toBS :: Builder -> BS.ByteString-toBS = unChunk . toLazyByteString+readBool :: T.Text -> Bool+readBool = go . T.map toLower+  where+    go "f"     = False+    go "0"     = False+    go "false" = False+    go "n"     = False+    go "no"    = False+    go "off"   = False+    go _       = True --- | Convert a lazy bytestring to a strict one.---   Avoids the copying overhead of 'LBS.toStrict' when there's only a single---   chunk, which should always be the case when serializing single parameters.-unChunk :: LBS.ByteString -> BS.ByteString-unChunk bs =-  case LBS.toChunks bs of-    [bs'] -> bs'-    bss   -> BS.concat bss #endif