diff --git a/postgresql-simple.cabal b/postgresql-simple.cabal --- a/postgresql-simple.cabal +++ b/postgresql-simple.cabal @@ -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 diff --git a/src/Database/PostgreSQL/Simple.hs b/src/Database/PostgreSQL/Simple.hs --- a/src/Database/PostgreSQL/Simple.hs +++ b/src/Database/PostgreSQL/Simple.hs @@ -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 = diff --git a/src/Database/PostgreSQL/Simple/FromField.hs b/src/Database/PostgreSQL/Simple/FromField.hs --- a/src/Database/PostgreSQL/Simple/FromField.hs +++ b/src/Database/PostgreSQL/Simple/FromField.hs @@ -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 diff --git a/src/Database/PostgreSQL/Simple/Internal.hs b/src/Database/PostgreSQL/Simple/Internal.hs --- a/src/Database/PostgreSQL/Simple/Internal.hs +++ b/src/Database/PostgreSQL/Simple/Internal.hs @@ -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 diff --git a/src/Database/PostgreSQL/Simple/Time.hs b/src/Database/PostgreSQL/Simple/Time.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Time.hs @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.Time +-- Copyright: (c) 2012 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- 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 diff --git a/src/Database/PostgreSQL/Simple/Time/Implementation.hs b/src/Database/PostgreSQL/Simple/Time/Implementation.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Time/Implementation.hs @@ -0,0 +1,280 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.Time.Implementation +-- Copyright: (c) 2011 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- 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 #-} diff --git a/src/Database/PostgreSQL/Simple/Time/Internal.hs b/src/Database/PostgreSQL/Simple/Time/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Time/Internal.hs @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.Time.Internal +-- Copyright: (c) 2012 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- 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 diff --git a/src/Database/PostgreSQL/Simple/ToField.hs b/src/Database/PostgreSQL/Simple/ToField.hs --- a/src/Database/PostgreSQL/Simple/ToField.hs +++ b/src/Database/PostgreSQL/Simple/ToField.hs @@ -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: \"@'@\" diff --git a/test/Bytea.hs b/test/Bytea.hs new file mode 100644 --- /dev/null +++ b/test/Bytea.hs @@ -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]) diff --git a/test/Common.hs b/test/Common.hs new file mode 100644 --- /dev/null +++ b/test/Common.hs @@ -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 diff --git a/test/ExecuteMany.hs b/test/ExecuteMany.hs new file mode 100644 --- /dev/null +++ b/test/ExecuteMany.hs @@ -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 () diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/test/Notify.hs b/test/Notify.hs new file mode 100644 --- /dev/null +++ b/test/Notify.hs @@ -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] diff --git a/test/Time.hs b/test/Time.hs new file mode 100644 --- /dev/null +++ b/test/Time.hs @@ -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]