packages feed

postgresql-simple 0.1.3 → 0.1.4

raw patch · 14 files changed

+779/−75 lines, 14 filesdep −pcre-lightdep ~attoparsecdep ~basedep ~time

Dependencies removed: pcre-light

Dependency ranges changed: attoparsec, base, time

Files

postgresql-simple.cabal view
@@ -1,5 +1,5 @@ Name:                postgresql-simple-Version:             0.1.3+Version:             0.1.4 Synopsis:            Mid-Level PostgreSQL client library Description:     Mid-Level PostgreSQL client library, forked from mysql-simple.@@ -25,6 +25,8 @@      Database.PostgreSQL.Simple.Notification      Database.PostgreSQL.Simple.Ok      Database.PostgreSQL.Simple.SqlQQ+     Database.PostgreSQL.Simple.Time+     Database.PostgreSQL.Simple.Time.Internal      Database.PostgreSQL.Simple.ToField      Database.PostgreSQL.Simple.ToRow      Database.PostgreSQL.Simple.Types@@ -33,6 +35,7 @@    Other-modules:      Database.PostgreSQL.Simple.Compat+     Database.PostgreSQL.Simple.Time.Implementation    Build-depends:     attoparsec >= 0.8.5.3,@@ -42,7 +45,6 @@     bytestring >= 0.9,     containers,     postgresql-libpq >= 0.6.2,-    pcre-light,     old-locale,     template-haskell,     text >= 0.11.1,@@ -62,7 +64,7 @@ source-repository this   type:     git   location: http://github.com/lpsmith/postgresql-simple-  tag:      v0.1.3+  tag:      v0.1.4  test-suite test   type:           exitcode-stdio-1.0@@ -72,7 +74,9 @@   other-modules:     Common     Bytea+    ExecuteMany     Notify+    Time    ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind @@ -88,3 +92,4 @@                , HUnit                , postgresql-simple                , text+               , time
src/Database/PostgreSQL/Simple.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE DeriveDataTypeable, RecordWildCards, NamedFieldPuns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}  ------------------------------------------------------------------------------ -- |@@ -131,7 +136,6 @@                    ( Binary(..), In(..), Only(..), Query(..), (:.)(..) ) import           Database.PostgreSQL.Simple.Internal as Base import qualified Database.PostgreSQL.LibPQ as PQ-import           Text.Regex.PCRE.Light (compile, caseless, match) import qualified Data.ByteString.Char8 as B import qualified Data.Text          as T import qualified Data.Text.Encoding as TE@@ -182,18 +186,108 @@ formatMany :: (ToRow q) => Connection -> Query -> [q] -> IO ByteString formatMany _ q [] = fmtError "no rows supplied" q [] formatMany conn q@(Query template) qs = do-  case match re template [] of-    Just [_,before,qbits,after] -> do+  case parseTemplate template of+    Just (before, qbits, after) -> do       bs <- mapM (buildQuery conn q qbits . toRow) qs       return . toByteString . mconcat $ fromByteString before :                                         intersperse (fromChar ',') bs ++                                         [fromByteString after]-    _ -> error "foo"+    Nothing -> fmtError "syntax error in query template for executeMany" q []++-- Split the input string into three pieces, @before@, @qbits@, and @after@,+-- following this grammar:+--+-- start: ^ before qbits after $+--     before: ([^?]* [^?\w])? 'VALUES' \s*+--     qbits:  '(' \s* '?' \s* (',' \s* '?' \s*)* ')'+--     after:  [^?]*+--+-- \s: [ \t\n\r\f]+-- \w: [A-Z] | [a-z] | [\x80-\xFF] | '_' | '$' | [0-9]+--+-- This would be much more concise with some sort of regex engine.+-- 'formatMany' used to use pcre-light instead of this hand-written parser,+-- but pcre is a hassle to install on Windows.+parseTemplate :: ByteString -> Maybe (ByteString, ByteString, ByteString)+parseTemplate template =+    -- Convert input string to uppercase, to facilitate searching.+    search $ B.map toUpper_ascii template   where-   re = compile "^([^?]+\\bvalues\\s*)\-                 \(\\(\\s*[?](?:\\s*,\\s*[?])*\\s*\\))\-                 \([^?]*)$"-        [caseless]+    -- Search for the next occurrence of "VALUES"+    search bs =+        case B.breakSubstring "VALUES" bs of+            (x, y)+                -- If "VALUES" is not present in the string, or any '?' characters+                -- were encountered prior to it, fail.+                | B.null y || ('?' `B.elem` x)+               -> Nothing++                -- If "VALUES" is preceded by an identifier character (a.k.a. \w),+                -- try the next occurrence.+                | not (B.null x) && isIdent (B.last x)+               -> search $ B.drop 6 y++                -- Otherwise, we have a legitimate "VALUES" token.+                | otherwise+               -> parseQueryBits $ skipSpace $ B.drop 6 y++    -- Parse '(' \s* '?' \s* .  If this doesn't match+    -- (and we don't consume a '?'), look for another "VALUES".+    --+    -- qb points to the open paren (if present), meaning it points to the+    -- beginning of the "qbits" production described above.  This is why we+    -- pass it down to finishQueryBits.+    parseQueryBits qb+        | Just ('(', skipSpace -> bs1) <- B.uncons qb+        , Just ('?', skipSpace -> bs2) <- B.uncons bs1+        = finishQueryBits qb bs2+        | otherwise+        = search qb++    -- Parse (',' \s* '?' \s*)* ')' [^?]* .+    --+    -- Since we've already consumed at least one '?', there's no turning back.+    -- The parse has to succeed here, or the whole thing fails+    -- (because we don't allow '?' to appear outside of the VALUES list).+    finishQueryBits qb bs0+        | Just (')', bs1) <- B.uncons bs0+        = if '?' `B.elem` bs1+              then Nothing+              else Just $ slice3 template qb bs1+        | Just (',', skipSpace -> bs1) <- B.uncons bs0+        , Just ('?', skipSpace -> bs2) <- B.uncons bs1+        = finishQueryBits qb bs2+        | otherwise+        = Nothing++    -- Slice a string into three pieces, given the start offset of the second+    -- and third pieces.  Each "offset" is actually a tail of the uppercase+    -- version of the template string.  Its length is used to infer the offset.+    --+    -- It is important to note that we only slice the original template.+    -- We don't want our all-caps trick messing up the actual query string.+    slice3 source p1 p2 =+        (s1, s2, source'')+      where+        (s1, source')  = B.splitAt (B.length source - B.length p1) source+        (s2, source'') = B.splitAt (B.length p1     - B.length p2) source'++    toUpper_ascii c | c >= 'a' && c <= 'z' = toEnum (fromEnum c - 32)+                    | otherwise            = c++    -- Based on the definition of {ident_cont} in src/backend/parser/scan.l+    -- in the PostgreSQL source.  No need to check [a-z], since we converted+    -- the whole string to uppercase.+    isIdent c = (c >= '0'    && c <= '9')+             || (c >= 'A'    && c <= 'Z')+             || (c >= '\x80' && c <= '\xFF')+             || c == '_'+             || c == '$'++    -- Based on {space} in scan.l+    isSpace_ascii c = (c == ' ') || (c >= '\t' && c <= '\r')++    skipSpace = B.dropWhile isSpace_ascii  escapeStringConn :: Connection -> ByteString -> IO (Either ByteString ByteString) escapeStringConn conn s =
src/Database/PostgreSQL/Simple/FromField.hs view
@@ -42,7 +42,7 @@ #include "MachDeps.h"  import           Control.Applicative-                   ( Applicative, (<|>), (<$>), (<*>), (<*), pure )+                   ( Applicative, (<|>), (<$>), pure ) import           Control.Exception (SomeException(..), Exception) import           Data.Attoparsec.Char8 hiding (Result) import           Data.Bits ((.&.), (.|.), shiftL)@@ -51,19 +51,17 @@ import           Data.Int (Int16, Int32, Int64) import           Data.List (foldl') import           Data.Ratio (Ratio)-import           Data.Time.Calendar (Day, fromGregorian)-import           Data.Time.Clock (UTCTime)-import           Data.Time.Format (parseTime)-import           Data.Time.LocalTime (ZonedTime, TimeOfDay, makeTimeOfDayValid)+import           Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay+                           , localTimeToUTC, utc ) import           Data.Typeable (Typeable, typeOf) import           Data.Word (Word64) import           Database.PostgreSQL.Simple.Internal import           Database.PostgreSQL.Simple.BuiltinTypes import           Database.PostgreSQL.Simple.Ok import           Database.PostgreSQL.Simple.Types (Binary(..), Null(..))+import           Database.PostgreSQL.Simple.Time import qualified Database.PostgreSQL.LibPQ as PQ import           System.IO.Unsafe (unsafePerformIO)-import           System.Locale (defaultTimeLocale) import qualified Data.ByteString as SB import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as LB@@ -196,50 +194,54 @@     fromField f dat = ST.unpack <$> fromField f dat  instance FromField UTCTime where-    fromField f =-        case oid2builtin (typeOid f) of-          Just Timestamp             -> doIt "%F %T%Q"   id-          Just TimestampWithTimeZone -> doIt "%F %T%Q%z" (++ "00")-          _ -> const $ returnError Incompatible f "types incompatible"-        where-          doIt _   _          Nothing   = returnError UnexpectedNull f ""-          doIt fmt preprocess (Just bs) =-              case parseTime defaultTimeLocale fmt str of-                Just t  -> pure t-                Nothing -> returnError ConversionFailed f "could not parse"-              where str = preprocess (B8.unpack bs)+  fromField f =+    case oid2builtin (typeOid f) of+      Just TimestampWithTimeZone -> doIt id parseUTCTime+      Just Timestamp -> doIt (localTimeToUTC utc) parseLocalTime  -- deprecated+      _ -> const $ returnError Incompatible f ""+    where+      doIt _finish _parse Nothing+        = returnError UnexpectedNull f ""+      doIt finish parse (Just bs)+        = either (returnError ConversionFailed f) (pure . finish) (parse bs)  instance FromField ZonedTime where-    fromField f =-        case oid2builtin (typeOid f) of-          Just TimestampWithTimeZone -> doIt "%F %T%Q%z" (++ "00")-          _ -> const $ returnError Incompatible f "types incompatible"-        where-          doIt _   _          Nothing   = returnError UnexpectedNull f ""-          doIt fmt preprocess (Just bs) =-              case parseTime defaultTimeLocale fmt str of-                Just t  -> pure t-                Nothing -> returnError ConversionFailed f "could not parse"-              where str = preprocess (B8.unpack bs)+  fromField = ff TimestampWithTimeZone "ZonedTime" parseZonedTime +instance FromField LocalTime where+  fromField = ff Timestamp "LocalTime" parseLocalTime+ instance FromField Day where-    fromField f = atto ok date f-        where ok = mkCompats [Date]-              date = fromGregorian <$> (decimal <* char '-')-                                   <*> (decimal <* char '-')-                                   <*> decimal+  fromField = ff Date "Day" parseDay  instance FromField TimeOfDay where-    fromField f = atto' ok time f-        where ok = mkCompats [Time]-              time = do-                hours <- decimal <* char ':'-                mins <- decimal <* char ':'-                secs <- decimal :: Parser Int-                case makeTimeOfDayValid hours mins (fromIntegral secs) of-                  Just t -> return (pure t)-                  _      -> return (returnError ConversionFailed f "could not parse")+  fromField = ff Time "TimeOfDay" parseTimeOfDay +instance FromField UTCTimestamp where+  fromField = ff TimestampWithTimeZone "UTCTimestamp" parseUTCTimestamp++instance FromField ZonedTimestamp where+  fromField = ff TimestampWithTimeZone "ZonedTimestamp" parseZonedTimestamp++instance FromField LocalTimestamp where+  fromField = ff Timestamp "LocalTimestamp" parseLocalTimestamp++instance FromField Date where+  fromField = ff Date "Date" parseDate++ff :: BuiltinType -> String -> (B8.ByteString -> Either String a)+   -> Field -> Maybe B8.ByteString -> Ok a+ff pgType hsType parse f mstr+    | typeOid f /= builtin2oid pgType+    = left (Incompatible   (B8.unpack (typename f)) hsType "")+    | Nothing <- mstr+    = left (UnexpectedNull (B8.unpack (typename f)) hsType "")+    | Just str <- mstr+    = case parse str of+        Left msg -> left (ConversionFailed (B8.unpack (typename f)) hsType msg)+        Right val -> return val+{-# INLINE ff #-}+ instance (FromField a, FromField b) => FromField (Either a b) where     fromField f dat =   (Right <$> fromField f dat)                     <|> (Left  <$> fromField f dat)@@ -299,14 +301,3 @@         case parseOnly p s of           Left err -> returnError ConversionFailed f err           Right  v -> pure v--atto' :: forall a. (Typeable a)-     => Compat -> Parser (Ok a) -> Field -> Maybe ByteString-     -> Ok a-atto' types p0 f dat = doFromField f types (go p0) dat-  where-    go :: Parser (Ok a) -> ByteString -> Ok a-    go p s =-        case parseOnly p s of-          Left err -> returnError ConversionFailed f err-          Right  v -> v
src/Database/PostgreSQL/Simple/Internal.hs view
@@ -153,7 +153,8 @@           connectionHandle  <- newMVar conn           connectionObjects <- newMVar (IntMap.empty)           let wconn = Connection{..}-          _ <- execute_ wconn "SET standard_conforming_strings TO on"+          _ <- execute_ wconn "SET standard_conforming_strings TO on;\+                              \SET datestyle TO ISO"           return Connection{..}       _ -> do           msg <- maybe "connectPostgreSQL error" id <$> PQ.errorMessage conn
+ src/Database/PostgreSQL/Simple/Time.hs view
@@ -0,0 +1,60 @@+------------------------------------------------------------------------------+-- |+-- Module:      Database.PostgreSQL.Simple.Time+-- Copyright:   (c) 2012 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+-- Time types that supports positive and negative infinity.   Also includes+-- new time parsers and printers with better performance than GHC's time package.+-- The parsers only understand the specific variant of ISO 8601 that PostgreSQL+-- emits,  and the printers attempt to duplicate this syntax.  These likely have+-- problems and shortcomings.  Some that I know of:+--+-- 1. Timestamps with time zones before @1883-Nov-18 12:00:00-05@, the moment+--    Standard Railway Time went live,  cannot be parsed.  This is because+--    PostgreSQL will emit @1883-11-18 12:03:57-04:56:02@ instead of+--    @1883-11-18 11:59:59-05@,  and the timezone parser is incomplete.+--    Timestamps without time zones do not have this problem.+--+-- 2. Dates an times surrounding @1582-Feb-24@,  the date the Gregorian+--    Calendar was introduced,  should be investigated for conversion errors.+--+-- 3. Points in time Before Christ are not also not supported.  For example,+--    PostgreSQL will emit @0045-01-01 BC@ for a value of a @date@ type.+--    This is the year that the Julian Calendar was adopted.+--+-- However, it should be noted that the old parsers also had these issues.+--+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.Time+     ( Unbounded(..)+     , Date+     , UTCTimestamp+     , ZonedTimestamp+     , LocalTimestamp+     , parseDay+     , parseUTCTime+     , parseZonedTime+     , parseLocalTime+     , parseTimeOfDay+     , parseDate+     , parseUTCTimestamp+     , parseZonedTimestamp+     , parseLocalTimestamp+     , dayToBuilder+     , utcTimeToBuilder+     , zonedTimeToBuilder+     , localTimeToBuilder+     , timeOfDayToBuilder+     , timeZoneToBuilder+     , dateToBuilder+     , utcTimestampToBuilder+     , zonedTimestampToBuilder+     , localTimestampToBuilder+     , unboundedToBuilder+     ) where++import Database.PostgreSQL.Simple.Time.Implementation
+ src/Database/PostgreSQL/Simple/Time/Implementation.hs view
@@ -0,0 +1,280 @@+------------------------------------------------------------------------------+-- |+-- Module:      Database.PostgreSQL.Simple.Time.Implementation+-- Copyright:   (c) 2011 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+------------------------------------------------------------------------------++{-# LANGUAGE DeriveDataTypeable #-}++module Database.PostgreSQL.Simple.Time.Implementation where++import Prelude hiding (take, (++))+import Blaze.ByteString.Builder(Builder, fromByteString)+import Blaze.ByteString.Builder.Char8(fromChar)+import Blaze.Text.Int(integral)+import Control.Arrow((***))+import Control.Applicative+import Control.Monad(when)+import Data.Bits((.&.))+import qualified Data.ByteString as B+import Data.ByteString.Internal (c2w, w2c)+import Data.Time hiding (getTimeZone, getZonedTime)+import Data.Typeable+import Data.Word(Word8)+import qualified Data.Attoparsec.Char8 as A+import Data.Monoid(Monoid(..))+import Data.Fixed (Pico)+import Unsafe.Coerce++(++) :: Monoid a => a -> a -> a+(++) = mappend+infixr 5 ++++data Unbounded a+   = NegInfinity+   | Finite !a+   | PosInfinity+     deriving (Eq, Ord, Typeable)++instance Show a => Show (Unbounded a) where+  showsPrec prec x rest+    = case x of+        NegInfinity -> "-infinity" ++ rest+        Finite time -> showsPrec prec time rest+        PosInfinity ->  "infinity" ++ rest++instance Read a => Read (Unbounded a) where+  readsPrec prec = readParen False $ \str -> case str of+    ('-':'i':'n':'f':'i':'n':'i':'t':'y':xs)  -> [(NegInfinity,xs)]+    (    'i':'n':'f':'i':'n':'i':'t':'y':xs)  -> [(PosInfinity,xs)]+    xs -> map (Finite *** id) (readsPrec prec xs)++type LocalTimestamp = Unbounded LocalTime+type UTCTimestamp   = Unbounded UTCTime+type ZonedTimestamp = Unbounded ZonedTime+type Date           = Unbounded Day++parseUTCTime   :: B.ByteString -> Either String UTCTime+parseUTCTime   = A.parseOnly (getUTCTime <* A.endOfInput)++parseZonedTime :: B.ByteString -> Either String ZonedTime+parseZonedTime = A.parseOnly (getZonedTime <* A.endOfInput)++parseLocalTime :: B.ByteString -> Either String LocalTime+parseLocalTime = A.parseOnly (getLocalTime <* A.endOfInput)++parseDay :: B.ByteString -> Either String Day+parseDay = A.parseOnly (getDay <* A.endOfInput)++parseTimeOfDay :: B.ByteString -> Either String TimeOfDay+parseTimeOfDay = A.parseOnly (getTimeOfDay <* A.endOfInput)++parseUTCTimestamp   :: B.ByteString -> Either String UTCTimestamp+parseUTCTimestamp   = A.parseOnly (getUTCTimestamp <* A.endOfInput)++parseZonedTimestamp :: B.ByteString -> Either String ZonedTimestamp+parseZonedTimestamp = A.parseOnly (getZonedTimestamp <* A.endOfInput)++parseLocalTimestamp :: B.ByteString -> Either String LocalTimestamp+parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput)++parseDate :: B.ByteString -> Either String Date+parseDate = A.parseOnly (getDate <* A.endOfInput)++getUnbounded :: A.Parser a -> A.Parser (Unbounded a)+getUnbounded getFinite+    =     (pure NegInfinity <* A.string "-infinity")+      <|> (pure PosInfinity <* A.string  "infinity")+      <|> (Finite <$> getFinite)++getDay :: A.Parser Day+getDay = do+    yearStr <- A.takeWhile A.isDigit+    when (B.length yearStr < 4) (fail "year must consist of at least 4 digits")++    let !year = toNum yearStr+    _       <- A.char '-'+    month   <- digits "month"+    _       <- A.char '-'+    day     <- digits "day"++    case fromGregorianValid year month day of+      Nothing -> fail "invalid date"+      Just x  -> return $! x++getDate :: A.Parser Date+getDate = getUnbounded getDay++decimal :: Fractional a => B.ByteString -> a+decimal str = toNum str / 10^(B.length str)+{-# INLINE decimal #-}++getTimeOfDay :: A.Parser TimeOfDay+getTimeOfDay = do+    hour   <- digits "hours"+    _      <- A.char ':'+    minute <- digits "minutes"+    _      <- A.char ':'+    second <- digits "seconds"+    subsec <- (A.char '.' *> (decimal <$> A.takeWhile1 A.isDigit)) <|> return 0++    let !picos' = second + subsec++    case makeTimeOfDayValid hour minute picos' of+      Nothing -> fail "invalid time of day"+      Just x  -> return $! x++getLocalTime :: A.Parser LocalTime+getLocalTime = LocalTime <$> getDay <*> (A.char ' ' *> getTimeOfDay)++getLocalTimestamp :: A.Parser LocalTimestamp+getLocalTimestamp = getUnbounded getLocalTime++getTimeZone :: A.Parser TimeZone+getTimeZone = do+    sign   <- A.satisfy (\c -> c == '+' || c == '-')+    offset <- digits "timezone"+    let !minutes = 60 * if sign == '+' then offset else -offset+    return $! minutesToTimeZone minutes++getZonedTime :: A.Parser ZonedTime+getZonedTime = ZonedTime <$> getLocalTime <*> getTimeZone++getZonedTimestamp :: A.Parser ZonedTimestamp+getZonedTimestamp = getUnbounded getZonedTime++getUTCTime :: A.Parser UTCTime+getUTCTime = do+    day  <- getDay+    _    <- A.char ' '+    time <- getTimeOfDay+    zone <- getTimeZone+    let (!dayDelta,!time') = localToUTCTimeOfDay zone time+    let !day' = addDays dayDelta day+    let !time'' = timeOfDayToTime time'+    return (UTCTime day' time'')++getUTCTimestamp :: A.Parser UTCTimestamp+getUTCTimestamp = getUnbounded getUTCTime++toNum :: Num n => B.ByteString -> n+toNum = B.foldl' (\a c -> 10*a + digit c) 0+{-# INLINE toNum #-}++digit :: Num n => Word8 -> n+digit c = fromIntegral (c .&. 0x0f)+{-# INLINE digit #-}++digits :: Num n => String -> A.Parser n+digits msg = do+  x <- A.anyChar+  y <- A.anyChar+  if A.isDigit x && A.isDigit y+  then return $! (10 * digit (c2w x) + digit (c2w y))+  else fail (msg ++ " is not 2 digits")+{-# INLINE digits #-}++dayToBuilder :: Day -> Builder+dayToBuilder (toGregorian -> (y,m,d)) = do+    pad4 y ++ fromChar '-' ++ pad2 m ++ fromChar '-' ++ pad2 d++timeOfDayToBuilder :: TimeOfDay -> Builder+timeOfDayToBuilder (TimeOfDay h m s) = do+    pad2 h ++ fromChar ':' ++ pad2 m ++ fromChar ':' ++ showSeconds s++timeZoneToBuilder :: TimeZone -> Builder+timeZoneToBuilder tz+    | m == 0     =  sign h ++ pad2 (abs h)+    | otherwise  =  sign h ++ pad2 (abs h) ++ fromChar ':' ++ pad2 (abs m)+  where+    (h,m) = timeZoneMinutes tz `quotRem` 60+    sign h | h >= 0    = fromChar '+'+           | otherwise = fromChar '-'++utcTimeToBuilder :: UTCTime -> Builder+utcTimeToBuilder (UTCTime day time) =+    dayToBuilder day ++ fromChar ' '+    ++ timeOfDayToBuilder (timeToTimeOfDay time) ++ fromByteString "+00"++zonedTimeToBuilder :: ZonedTime -> Builder+zonedTimeToBuilder (ZonedTime localTime tz) =+    localTimeToBuilder localTime ++ timeZoneToBuilder tz++localTimeToBuilder :: LocalTime -> Builder+localTimeToBuilder (LocalTime day tod) =+    dayToBuilder day ++ fromChar ' ' ++ timeOfDayToBuilder tod++unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder)+unboundedToBuilder finiteToBuilder unbounded+    = case unbounded of+        NegInfinity -> fromByteString "-infinity"+        Finite a    -> finiteToBuilder a+        PosInfinity -> fromByteString  "infinity"++utcTimestampToBuilder :: UTCTimestamp -> Builder+utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder++zonedTimestampToBuilder :: ZonedTimestamp -> Builder+zonedTimestampToBuilder = unboundedToBuilder zonedTimeToBuilder++localTimestampToBuilder :: LocalTimestamp -> Builder+localTimestampToBuilder = unboundedToBuilder localTimeToBuilder++dateToBuilder  :: Date -> Builder+dateToBuilder  = unboundedToBuilder dayToBuilder++showSeconds :: Pico -> Builder+showSeconds xyz+    | yz == 0   = pad2 x+    | z  == 0   = pad2 x ++ fromChar '.' ++  showD6 y+    | otherwise = pad2 x ++ fromChar '.' ++  pad6   y ++ showD6 z+  where+    -- A kludge to work around the fact that Data.Fixed isn't very fast and+    -- doesn't give me access to the MkFixed constructor.+    (x_,yz) = (unsafeCoerce xyz :: Integer)     `quotRem` 1000000000000+    x = fromIntegral x_ :: Int+    (fromIntegral -> y, fromIntegral -> z) = yz `quotRem` 1000000++pad6 :: Int -> Builder+pad6 xy = let (x,y) = xy `quotRem` 1000+           in pad3 x ++ pad3 y++showD6 :: Int -> Builder+showD6 xy = case xy `quotRem` 1000 of+              (x,0) -> showD3 x+              (x,y) -> pad3 x ++ showD3 y++pad3 :: Int -> Builder+pad3 abc = let (ab,c) = abc `quotRem` 10+               (a,b)  = ab  `quotRem` 10+            in p a ++ p b ++ p c++showD3 :: Int -> Builder+showD3 abc = case abc `quotRem` 100 of+              (a, 0) -> p a+              (a,bc) -> case bc `quotRem` 10 of+                          (b,0) -> p a ++ p b+                          (b,c) -> p a ++ p b ++ p c++-- | p assumes its input is in the range [0..9]+p :: Integral n => n -> Builder+p n = fromChar (w2c (fromIntegral (n + 48)))+{-# INLINE p #-}++-- | pad2 assumes its input is in the range [0..99]+pad2 :: Integral n => n -> Builder+pad2 n = let (a,b) = n `quotRem` 10 in p a ++ p b+{-# INLINE pad2 #-}++-- | pad4 assumes its input is positive+pad4 :: (Integral n, Show n) => n -> Builder+pad4 abcd | abcd >= 10000 = integral abcd+          | otherwise     = p a ++ p b ++ p c ++ p d+  where (ab,cd) = abcd `quotRem` 100+        (a,b)   = ab   `quotRem` 10+        (c,d)   = cd   `quotRem` 10+{-# INLINE pad4 #-}
+ src/Database/PostgreSQL/Simple/Time/Internal.hs view
@@ -0,0 +1,24 @@+------------------------------------------------------------------------------+-- |+-- Module:      Database.PostgreSQL.Simple.Time.Internal+-- Copyright:   (c) 2012 Leon P Smith+-- License:     BSD3+-- Maintainer:  Leon P Smith <leon@melding-monads.com>+-- Stability:   experimental+--+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.Time.Internal+     ( getDay+     , getDate+     , getTimeOfDay+     , getLocalTime+     , getLocalTimestamp+     , getTimeZone+     , getZonedTime+     , getZonedTimestamp+     , getUTCTime+     , getUTCTimestamp+     ) where++import Database.PostgreSQL.Simple.Time.Implementation
src/Database/PostgreSQL/Simple/ToField.hs view
@@ -28,10 +28,7 @@ import Data.Int (Int8, Int16, Int32, Int64) import Data.List (intersperse) import Data.Monoid (mappend)-import Data.Time.Calendar (Day, showGregorian)-import Data.Time.Clock (UTCTime)-import Data.Time.Format (formatTime)-import Data.Time.LocalTime (TimeOfDay, ZonedTime)+import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime) import Data.Typeable (Typeable) import Data.Word (Word, Word8, Word16, Word32, Word64) import Database.PostgreSQL.Simple.Types (Binary(..), In(..), Null)@@ -43,6 +40,7 @@ import qualified Data.Text.Encoding as ST import qualified Data.Text.Lazy as LT import qualified Database.PostgreSQL.LibPQ as PQ+import           Database.PostgreSQL.Simple.Time  -- | How to render an element when substituting it into a query. data Action =@@ -188,19 +186,39 @@     {-# INLINE toField #-}  instance ToField UTCTime where-    toField = Plain . Utf8.fromString . formatTime defaultTimeLocale "'%F %T%Q+00'"+    toField = Plain . inQuotes . utcTimeToBuilder     {-# INLINE toField #-}  instance ToField ZonedTime where-    toField = Plain . Utf8.fromString . formatTime defaultTimeLocale "'%F %T%Q%z'"+    toField = Plain . inQuotes . zonedTimeToBuilder     {-# INLINE toField #-} +instance ToField LocalTime where+    toField = Plain . inQuotes . localTimeToBuilder+    {-# INLINE toField #-}+ instance ToField Day where-    toField = Plain . inQuotes . Utf8.fromString . showGregorian+    toField = Plain . inQuotes . dayToBuilder     {-# INLINE toField #-}  instance ToField TimeOfDay where-    toField = Plain . inQuotes . Utf8.fromString . show+    toField = Plain . inQuotes . timeOfDayToBuilder+    {-# INLINE toField #-}++instance ToField UTCTimestamp where+    toField = Plain . inQuotes . utcTimestampToBuilder+    {-# INLINE toField #-}++instance ToField ZonedTimestamp where+    toField = Plain . inQuotes . zonedTimestampToBuilder+    {-# INLINE toField #-}++instance ToField LocalTimestamp where+    toField = Plain . inQuotes . localTimestampToBuilder+    {-# INLINE toField #-}++instance ToField Date where+    toField = Plain . inQuotes . dateToBuilder     {-# INLINE toField #-}  -- | Surround a string with single-quote characters: \"@'@\"
+ test/Bytea.hs view
@@ -0,0 +1,25 @@+module Bytea (testBytea) where++import Common+import qualified Data.ByteString as B++testBytea :: TestEnv -> Test+testBytea TestEnv{..} = TestList+    [ testStr "empty"                  []+    , testStr "\"hello\""              $ map (fromIntegral . fromEnum) ("hello" :: String)+    , testStr "ascending"              [0..255]+    , testStr "descending"             [255,254..0]+    , testStr "ascending, doubled up"  $ doubleUp [0..255]+    , testStr "descending, doubled up" $ doubleUp [255,254..0]+    ]+  where+    testStr label bytes = TestLabel label $ TestCase $ do+        let bs = B.pack bytes++        [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs]+        assertBool "Haskell -> SQL conversion altered the string" $ md5 bs == h++        [Only (Binary r)] <- query conn "SELECT ?::bytea" [Binary bs]+        assertBool "SQL -> Haskell conversion altered the string" $ bs == r++    doubleUp = concatMap (\x -> [x, x])
+ test/Common.hs view
@@ -0,0 +1,32 @@+module Common (+    module Database.PostgreSQL.Simple,+    module Test.HUnit,+    TestEnv(..),+    md5,+) where++import Data.ByteString              (ByteString)+import Data.Text                    (Text)+import Database.PostgreSQL.Simple+import Test.HUnit++import qualified Crypto.Hash.MD5        as MD5+import qualified Data.ByteString.Base16 as Base16+import qualified Data.Text.Encoding     as TE++data TestEnv+    = TestEnv+        { conn     :: Connection+            -- ^ Connection shared by all the tests+        , withConn :: forall a. (Connection -> IO a) -> IO a+            -- ^ Bracket for spawning additional connections+        }++-- | Return the MD5 hash of a 'ByteString', in lowercase hex format.+--+-- Example:+--+-- >[Only hash] <- query_ conn "SELECT md5('hi')"+-- >assertEqual "md5('hi')" (md5 "hi") hash+md5 :: ByteString -> Text+md5 = TE.decodeUtf8 . Base16.encode . MD5.hash
+ test/ExecuteMany.hs view
@@ -0,0 +1,23 @@+module ExecuteMany (testExecuteMany) where++import Common++import Data.ByteString (ByteString)++testExecuteMany :: TestEnv -> Test+testExecuteMany TestEnv{..} = TestCase $ do+    execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)"++    let rows :: [(Int, String, Binary ByteString)]+        rows = [ (1, "hello", Binary "bye")+               , (2, "world", Binary "\0\r\t\n")+               , (3, "?",     Binary "")+               ]++    count <- executeMany conn "INSERT INTO tmp_executeMany VALUES (?, ?, ?)" rows+    assertEqual "count" (fromIntegral $ length rows) count++    rows' <- query_ conn "SELECT * FROM tmp_executeMany"+    assertEqual "rows" rows rows'++    return ()
+ test/Main.hs view
@@ -0,0 +1,42 @@+import Common+import Control.Exception            (bracket)+import Control.Monad                (when)+import System.Exit                  (exitFailure)+import System.IO++import Bytea+import ExecuteMany+import Notify+import Time++tests :: [TestEnv -> Test]+tests =+    [ TestLabel "Bytea"         . testBytea+    , TestLabel "Notify"        . testNotify+    , TestLabel "ExecuteMany"   . testExecuteMany+    , TestLabel "Time"          . testTime+    ]++-- | Action for connecting to the database that will be used for testing.+--+-- Note that some tests, such as Notify, use multiple connections, and assume+-- that 'testConnect' connects to the same database every time it is called.+testConnect :: IO Connection+testConnect = connectPostgreSQL ""++withTestEnv :: (TestEnv -> IO a) -> IO a+withTestEnv cb =+    withConn $ \conn ->+        cb TestEnv+            { conn     = conn+            , withConn = withConn+            }+  where+    withConn = bracket testConnect close++main :: IO ()+main = do+    mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr]+    Counts{cases, tried, errors, failures} <-+        withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests+    when (cases /= tried || errors /= 0 || failures /= 0) $ exitFailure
+ test/Notify.hs view
@@ -0,0 +1,42 @@+module Notify (testNotify) where++import Common++import Control.Applicative+import Control.Concurrent+import Control.Monad+import Data.Function+import Data.List+import Database.PostgreSQL.Simple.Notification++import qualified Data.ByteString as B++-- TODO: Test with payload, but only for PostgreSQL >= 9.0+-- (when that feature was introduced).++testNotify :: TestEnv -> Test+testNotify TestEnv{..} =+    TestCase $+    withConn $ \conn2 -> do+        execute_ conn "LISTEN foo"+        execute_ conn "LISTEN bar"++        results_mv <- newEmptyMVar+        forkIO $ replicateM 2 (getNotification conn)+             >>= putMVar results_mv++        threadDelay 100000++        execute_ conn2 "NOTIFY foo"+        execute_ conn2 "NOTIFY bar"++        [n1, n2] <- sortBy (compare `on` notificationChannel)+                <$> takeMVar results_mv++        assertEqual "n1" "bar" (notificationChannel n1)+        assertEqual "n2" "foo" (notificationChannel n2)++        -- Other sanity checks+        assertEqual "Server PIDs match" (notificationPid n1) (notificationPid n2)+        assertBool "notificationData is empty" $+            all (B.null . notificationData) [n1, n2]
+ test/Time.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE QuasiQuotes, ScopedTypeVariables #-}++{-++Testing strategies:++fromString . toString == id           ** Todo?++toString . fromString == almost id    ** Todo?++postgresql -> haskell -> postgresql   *  Done++haskell -> postgresql -> haskell      ** Todo?++But still,  what we really want to establish is that the two values+correspond;  for example,  a conversion that consistently added hour+when printed to a string and subtracted an hour when parsed from string+would still pass these tests.++-}++module Time (testTime) where++import Common+import Control.Monad(forM_, replicateM_)+import Data.Time+import Data.ByteString(ByteString)+import Database.PostgreSQL.Simple.SqlQQ++numTests :: Int+numTests = 200++testTime :: TestEnv -> Test+testTime env@TestEnv{..} = TestCase $ do+  initializeTable env+  execute_ conn "SET timezone TO 'UTC'"+  checkRoundTrips env+  execute_ conn "SET timezone TO 'America/Chicago'"+  checkRoundTrips env+  execute_ conn "SET timezone TO 'Asia/Tokyo'"+  checkRoundTrips env++initializeTable :: TestEnv -> IO ()+initializeTable TestEnv{..} = withTransaction conn $ do+  execute_ conn+     [sql| CREATE TEMPORARY TABLE testtime+             ( x serial, y timestamptz, PRIMARY KEY(x) ) |]+  let pop :: ByteString ->  Double -> IO () = \x y ->+               replicateM_ numTests $ execute conn+                 [sql| INSERT INTO testtime (y) VALUES+                         ('1900-01-01 00:00:00+00'::timestamptz+                          + ?::interval * ROUND(RANDOM() * ?)) |] (x,y)+  pop   "1 microsecond"  6.3113904e15+  pop  "10 microseconds" 6.3113904e14+  pop "100 microseconds" 6.3113904e13+  pop   "1 millisecond"  6.3113904e12+  pop  "10 milliseconds" 6.3113904e11+  pop "100 milliseconds" 6.3113904e10+  pop   "1 second"       6.3113904e9++checkRoundTrips :: TestEnv -> IO ()+checkRoundTrips TestEnv{..} = do+  yxs :: [(UTCTime, Int)] <- query_ conn [sql| SELECT y, x FROM testtime |]+  forM_ yxs $ \yx -> do+      res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx+      assertBool "UTCTime did not round-trip from SQL to Haskell and back" $+                 res == [Only True]