diff --git a/selda-postgresql.cabal b/selda-postgresql.cabal --- a/selda-postgresql.cabal +++ b/selda-postgresql.cabal @@ -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: diff --git a/src/Database/Selda/PostgreSQL.hs b/src/Database/Selda/PostgreSQL.hs --- a/src/Database/Selda/PostgreSQL.hs +++ b/src/Database/Selda/PostgreSQL.hs @@ -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 diff --git a/src/Database/Selda/PostgreSQL/Encoding.hs b/src/Database/Selda/PostgreSQL/Encoding.hs --- a/src/Database/Selda/PostgreSQL/Encoding.hs +++ b/src/Database/Selda/PostgreSQL/Encoding.hs @@ -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