diff --git a/Database/SQLite/Simple.hs b/Database/SQLite/Simple.hs --- a/Database/SQLite/Simple.hs +++ b/Database/SQLite/Simple.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} ------------------------------------------------------------------------------ -- | @@ -8,7 +8,6 @@ -- (c) 2012-2013 Janne Hellsten -- License: BSD3 -- Maintainer: Janne Hellsten --- Stability: experimental -- Portability: portable -- ------------------------------------------------------------------------------ @@ -37,6 +36,10 @@ -- ** Type conversions -- $types + + -- *** Conversion to/from UTCTime + -- $utctime + Query(..) , Connection(..) , ToRow(..) @@ -55,12 +58,13 @@ , query , query_ , lastInsertRowId + -- * Queries that stream results + , fold + , fold_ -- * Statements that do not return results , execute , execute_ , field - , fold - , fold_ -- * Low-level statement API for stream access and prepared statements , openStatement , closeStatement @@ -332,20 +336,32 @@ convertRow :: (FromRow r) => [Base.SQLData] -> Int -> IO r convertRow rowRes ncols = do - let rw = Row rowRes - case runStateT (runReaderT (unRP fromRow) rw) 0 of - Ok (val,col) | col == ncols -> return val - | otherwise -> do - let vals = map (\f -> (gettypename f, f)) rowRes - throwIO (ConversionFailed - (show ncols ++ " values: " ++ show vals) - (show col ++ " slots in target type") - "mismatch between number of columns to \ - \convert and number in target type") + let rw = RowParseRO ncols + case runStateT (runReaderT (unRP fromRow) rw) (0, rowRes) of + Ok (val,(col,_)) + | col == ncols -> return val + | otherwise -> errorColumnMismatch (ColumnOutOfBounds col) Errors [] -> throwIO $ ConversionFailed "" "" "unknown error" - Errors [x] -> throwIO x + Errors [x] -> + throw x `catch` (\e -> errorColumnMismatch (e :: ColumnOutOfBounds)) Errors xs -> throwIO $ ManyErrors xs + where + errorColumnMismatch :: ColumnOutOfBounds -> IO r + errorColumnMismatch (ColumnOutOfBounds c) = do + let vals = map (\f -> (gettypename f, ellipsis f)) rowRes + throwIO (ConversionFailed + (show ncols ++ " values: " ++ show vals) + ("at least " ++ show c ++ " slots in target type") + "mismatch between number of columns to convert and number in target type") + ellipsis :: Base.SQLData -> T.Text + ellipsis sql + | T.length bs > 20 = T.take 15 bs `T.append` "[...]" + | otherwise = bs + where + bs = T.pack $ show sql + + -- | Returns the rowid of the most recent successful INSERT on the -- given database connection. -- @@ -572,3 +588,38 @@ -- -- You can extend conversion support to your own types be adding your -- own 'FromField' / 'ToField' instances. + +-- $utctime +-- +-- SQLite's datetime allows for multiple string representations of UTC +-- time. The following formats are supported for reading SQLite times +-- into Haskell UTCTime values: +-- +-- * YYYY-MM-DD HH:MM +-- +-- * YYYY-MM-DD HH:MM:SS +-- +-- * YYYY-MM-DD HH:MM:SS.SSS +-- +-- * YYYY-MM-DDTHH:MM +-- +-- * YYYY-MM-DDTHH:MM:SS +-- +-- * YYYY-MM-DDTHH:MM:SS.SSS +-- +-- The above may also be optionally followed by a timezone indicator +-- of the form \"[+-]HH:MM\" or just \"Z\". +-- +-- When Haskell UTCTime values are converted into SQLite values (e.g., +-- parameters for a 'query'), the following format is used: +-- +-- * YYYY-MM-DD HH:MM:SS.SSS +-- +-- The last \".SSS\" subsecond part is dropped if it's zero. No +-- timezone indicator is used when converting from a UTCTime value +-- into an SQLite string. SQLite assumes all datetimes are in UTC +-- time. +-- +-- The parser and printers are implemented in . +-- +-- Read more about SQLite's time strings in diff --git a/Database/SQLite/Simple/FromField.hs b/Database/SQLite/Simple/FromField.hs --- a/Database/SQLite/Simple/FromField.hs +++ b/Database/SQLite/Simple/FromField.hs @@ -10,7 +10,6 @@ -- (c) 2012-2013 Janne Hellsten -- License: BSD3 -- Maintainer: Janne Hellsten --- Stability: experimental -- Portability: portable -- -- The 'FromField' typeclass, for converting a single value in a row @@ -42,18 +41,16 @@ import qualified Data.ByteString.Lazy as LB import Data.Int (Int16, Int32, Int64) import Data.Time (UTCTime, Day) -import Data.Time.Format (parseTime) import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Data.Typeable (Typeable, typeOf) import GHC.Float (double2Float) -import System.Locale (defaultTimeLocale) - import Database.SQLite3 as Base import Database.SQLite.Simple.Types import Database.SQLite.Simple.Internal import Database.SQLite.Simple.Ok +import Database.SQLite.Simple.Time -- | Exception thrown if conversion from a SQL value to a Haskell -- value fails. @@ -164,18 +161,19 @@ instance FromField UTCTime where fromField f@(Field (SQLText t) _) = - case parseTime defaultTimeLocale "%F %X%Q" . T.unpack $ t of - Just t -> Ok t - Nothing -> returnError ConversionFailed f "couldn't parse UTCTime field" + case parseUTCTime t of + Right t -> Ok t + Left e -> returnError ConversionFailed f ("couldn't parse UTCTime field: " ++ e) - fromField f = returnError ConversionFailed f "expecting SQLText column type" + fromField f = returnError ConversionFailed f "expecting SQLText column type" instance FromField Day where fromField f@(Field (SQLText t) _) = - case parseTime defaultTimeLocale "%Y-%m-%d" . T.unpack $ t of - Just t -> Ok t - Nothing -> returnError ConversionFailed f "couldn't parse Day field" + case parseDay t of + Right t -> Ok t + Left e -> returnError ConversionFailed f ("couldn't parse Day field: " ++ e) + fromField f = returnError ConversionFailed f "expecting SQLText column type" fieldTypename :: Field -> String diff --git a/Database/SQLite/Simple/FromRow.hs b/Database/SQLite/Simple/FromRow.hs --- a/Database/SQLite/Simple/FromRow.hs +++ b/Database/SQLite/Simple/FromRow.hs @@ -7,7 +7,6 @@ -- (c) 2012-2013 Janne Hellsten -- License: BSD3 -- Maintainer: Janne Hellsten --- Stability: experimental -- Portability: portable -- -- The 'FromRow' typeclass, for converting a row of results @@ -31,14 +30,11 @@ import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Class -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B import Database.SQLite.Simple.FromField import Database.SQLite.Simple.Internal import Database.SQLite.Simple.Ok import Database.SQLite.Simple.Types -import qualified Database.SQLite3 as Base -- | A collection type that can be converted from a sequence of fields. -- Instances are provided for tuples up to 10 elements and lists of any length. @@ -64,42 +60,25 @@ fieldWith :: FieldParser a -> RowParser a fieldWith fieldP = RP $ do - Row{..} <- ask - column <- lift get - lift (put (column + 1)) - let ncols = length rowresult - if column >= ncols - then do - let vals = map (\c -> (gettypename (rowresult !! c) - , ellipsis (rowresult !! c))) - [0..ncols-1] - convertError = ConversionFailed - (show ncols ++ " values: " ++ show vals) - ("at least " ++ show (column + 1) - ++ " slots in target type") - "mismatch between number of columns to \ - \convert and number in target type" - lift (lift (Errors [SomeException convertError])) + RowParseRO{..} <- ask + (column, remaining) <- lift get + lift (put (column + 1, tail remaining)) + if column >= nColumns + then + lift (lift (Errors [SomeException (ColumnOutOfBounds (column+1))])) else do - let r = rowresult !! column + let r = head remaining field = Field r column lift (lift (fieldP field)) field :: FromField a => RowParser a field = fieldWith fromField -ellipsis :: Base.SQLData -> ByteString -ellipsis sql - | B.length bs > 15 = B.take 10 bs `B.append` "[...]" - | otherwise = bs - where - bs = B.pack $ show sql - numFieldsRemaining :: RowParser Int numFieldsRemaining = RP $ do - Row{..} <- ask - column <- lift get - return $! length rowresult - column + RowParseRO{..} <- ask + (columnIdx,_) <- lift get + return $! nColumns - columnIdx instance (FromField a) => FromRow (Only a) where fromRow = Only <$> field diff --git a/Database/SQLite/Simple/Internal.hs b/Database/SQLite/Simple/Internal.hs --- a/Database/SQLite/Simple/Internal.hs +++ b/Database/SQLite/Simple/Internal.hs @@ -6,7 +6,6 @@ -- (c) 2012-2013 Janne Hellsten -- License: BSD3 -- Maintainer: Janne Hellsten --- Stability: experimental -- Portability: portable -- -- Internal bits. This interface is less stable and can change at any time. @@ -22,10 +21,12 @@ import Prelude hiding (catch) +import Control.Exception (Exception) import Control.Monad import Control.Applicative import Data.ByteString (ByteString) import Data.ByteString.Char8() +import Data.Typeable (Typeable) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader @@ -42,16 +43,22 @@ -- discouraged. newtype Connection = Connection { connectionHandle :: Base.Database } --- | A Field represents metadata about a particular field +data ColumnOutOfBounds = ColumnOutOfBounds { errorColumnIndex :: Int } + deriving (Eq, Show, Typeable) +instance Exception ColumnOutOfBounds + +-- | A Field represents metadata about a particular field data Field = Field { result :: Base.SQLData , column :: {-# UNPACK #-} !Int } -newtype Row = Row { rowresult :: [Base.SQLData] } +-- Named type for holding RowParser read-only state. Just for making +-- it easier to make sense out of types in FromRow. +newtype RowParseRO = RowParseRO { nColumns :: Int } -newtype RowParser a = RP { unRP :: ReaderT Row (StateT Int Ok) a } +newtype RowParser a = RP { unRP :: ReaderT RowParseRO (StateT (Int, [Base.SQLData]) Ok) a } deriving ( Functor, Applicative, Alternative, Monad, MonadPlus ) gettypename :: Base.SQLData -> ByteString diff --git a/Database/SQLite/Simple/Ok.hs b/Database/SQLite/Simple/Ok.hs --- a/Database/SQLite/Simple/Ok.hs +++ b/Database/SQLite/Simple/Ok.hs @@ -8,7 +8,6 @@ -- (c) 2012-2013 Janne Hellsten -- License: BSD3 -- Maintainer: Janne Hellsten --- Stability: experimental -- -- The 'Ok' type is a simple error handler, basically equivalent to -- @Either [SomeException]@. diff --git a/Database/SQLite/Simple/Time.hs b/Database/SQLite/Simple/Time.hs new file mode 100644 --- /dev/null +++ b/Database/SQLite/Simple/Time.hs @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Database.SQLite.Simple.Time +-- Copyright: (c) 2012 Leon P Smith +-- (c) 2012-2014 Janne Hellsten +-- License: BSD3 +-- Maintainer: Janne Hellsten +-- +-- Conversions to/from Haskell 'UTCTime' and 'Day' types for SQLite3. +-- Offers better performance than direct use of time package's +-- 'read'/'show' functionality. +-- +-- The parsers are heavily adapted for the specific variant of ISO 8601 that +-- SQLite uses, and the printers attempt to duplicate this syntax. +------------------------------------------------------------------------------ + +module Database.SQLite.Simple.Time ( + module Database.SQLite.Simple.Time.Implementation + ) where + +import Database.SQLite.Simple.Time.Implementation diff --git a/Database/SQLite/Simple/Time/Implementation.hs b/Database/SQLite/Simple/Time/Implementation.hs new file mode 100644 --- /dev/null +++ b/Database/SQLite/Simple/Time/Implementation.hs @@ -0,0 +1,200 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Database.SQLite.Simple.Time.Implementation +-- Copyright: (c) 2012 Leon P Smith +-- (c) 2012-2014 Janne Hellsten +-- License: BSD3 +-- Maintainer: Janne Hellsten +-- +-- Adapted from Leon P Smith's code for SQLite. +-- +-- See for date formats used in SQLite. +------------------------------------------------------------------------------ + +module Database.SQLite.Simple.Time.Implementation ( + parseUTCTime + , parseDay + , utcTimeToBuilder + , dayToBuilder + , timeOfDayToBuilder + , timeZoneToBuilder + ) where +import Blaze.ByteString.Builder (Builder) +import Blaze.ByteString.Builder.Char8 (fromChar) +import Blaze.Text.Int (integral) +import Control.Applicative +import Control.Monad (when) +import qualified Data.Attoparsec.Text as A +import Data.Bits ((.&.)) +import Data.ByteString.Internal (w2c) +import Data.Char (isDigit, ord) +import Data.Fixed (Pico) +import Data.Monoid (Monoid(..)) +import qualified Data.Text as T +import Data.Time hiding (getTimeZone, getZonedTime) +import Prelude hiding (take, (++)) +import Unsafe.Coerce + +(++) :: Monoid a => a -> a -> a +(++) = mappend +infixr 5 ++ + +parseUTCTime :: T.Text -> Either String UTCTime +parseUTCTime = A.parseOnly (getUTCTime <* A.endOfInput) + +parseDay :: T.Text -> Either String Day +parseDay = A.parseOnly (getDay <* A.endOfInput) + +getDay :: A.Parser Day +getDay = do + yearStr <- A.takeWhile isDigit + when (T.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 + +decimal :: Fractional a => T.Text -> a +decimal str = toNum str / 10^(T.length str) +{-# INLINE decimal #-} + +getTimeOfDay :: A.Parser TimeOfDay +getTimeOfDay = do + hour <- digits "hours" + _ <- A.char ':' + minute <- digits "minutes" + -- Allow omission of seconds. If seconds is omitted, don't try to + -- parse the sub-second part. + (sec,subsec) + <- ((,) <$> (A.char ':' *> digits "seconds") <*> fract) <|> pure (0,0) + + let !picos' = sec + subsec + + case makeTimeOfDayValid hour minute picos' of + Nothing -> fail "invalid time of day" + Just x -> return $! x + + where + fract = + (A.char '.' *> (decimal <$> A.takeWhile1 isDigit)) <|> pure 0 + +getTimeZone :: A.Parser TimeZone +getTimeZone = do + sign <- A.satisfy (\c -> c == '+' || c == '-') + hours <- digits "timezone" + mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0 + let !absset = 60 * hours + mins + !offset = if sign == '+' then absset else -absset + return $! minutesToTimeZone offset + +getUTCTime :: A.Parser UTCTime +getUTCTime = do + day <- getDay + _ <- A.char ' ' <|> A.char 'T' + time <- getTimeOfDay + -- SQLite doesn't require a timezone postfix. So make that + -- optional and default to +0. 'Z' means UTC (zulu time). + zone <- getTimeZone <|> (A.char 'Z' *> pure utc) <|> (pure utc) + let (!dayDelta,!time') = localToUTCTimeOfDay zone time + let !day' = addDays dayDelta day + let !time'' = timeOfDayToTime time' + return (UTCTime day' time'') + +toNum :: Num n => T.Text -> n +toNum = T.foldl' (\a c -> 10*a + digit c) 0 +{-# INLINE toNum #-} + +digit :: Num n => Char -> n +digit c = fromIntegral (ord c .&. 0x0f) +{-# INLINE digit #-} + +digits :: Num n => String -> A.Parser n +digits msg = do + x <- A.anyChar + y <- A.anyChar + if isDigit x && isDigit y + then return $! (10 * digit x + digit 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 '-' + +-- | Output YYYY-MM-DD HH:MM:SS with an optional .SSS fraction part. +-- Explicit timezone attribute is not appended as per SQLite3's +-- datetime conventions. +utcTimeToBuilder :: UTCTime -> Builder +utcTimeToBuilder (UTCTime day time) = + dayToBuilder day ++ fromChar ' ' ++ timeOfDayToBuilder (timeToTimeOfDay time) + +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/Database/SQLite/Simple/ToField.hs b/Database/SQLite/Simple/ToField.hs --- a/Database/SQLite/Simple/ToField.hs +++ b/Database/SQLite/Simple/ToField.hs @@ -9,7 +9,6 @@ -- (c) 2012-2013 Janne Hellsten -- License: BSD3 -- Maintainer: Janne Hellsten --- Stability: experimental -- Portability: portable -- -- The 'ToField' typeclass, for rendering a parameter to an SQLite @@ -19,19 +18,20 @@ module Database.SQLite.Simple.ToField (ToField(..)) where +import Blaze.ByteString.Builder (toByteString) import qualified Data.ByteString as SB import qualified Data.ByteString.Lazy as LB import Data.Int (Int8, Int16, Int32, Int64) import qualified Data.Text as T import qualified Data.Text.Lazy as LT +import qualified Data.Text.Encoding as T import Data.Time (Day, UTCTime) -import Data.Time.Format (formatTime) import Data.Word (Word, Word8, Word16, Word32, Word64) import GHC.Float -import System.Locale (defaultTimeLocale) import Database.SQLite3 as Base import Database.SQLite.Simple.Types (Null) +import Database.SQLite.Simple.Time -- | A type that may be used as a single parameter to a SQL query. class ToField a where @@ -129,11 +129,11 @@ {-# INLINE toField #-} instance ToField UTCTime where - toField = SQLText . T.pack . formatTime defaultTimeLocale "%F %X%Q" + toField = SQLText . T.decodeUtf8 . toByteString . utcTimeToBuilder {-# INLINE toField #-} instance ToField Day where - toField = SQLText . T.pack . show + toField = SQLText . T.decodeUtf8 . toByteString . dayToBuilder {-# INLINE toField #-} -- TODO enable these diff --git a/Database/SQLite/Simple/ToRow.hs b/Database/SQLite/Simple/ToRow.hs --- a/Database/SQLite/Simple/ToRow.hs +++ b/Database/SQLite/Simple/ToRow.hs @@ -6,7 +6,6 @@ -- (c) 2012-2013 Janne Hellsten -- License: BSD3 -- Maintainer: Janne Hellsten --- Stability: experimental -- Portability: portable -- -- The 'ToRow' typeclass, for rendering a collection of diff --git a/Database/SQLite/Simple/Types.hs b/Database/SQLite/Simple/Types.hs --- a/Database/SQLite/Simple/Types.hs +++ b/Database/SQLite/Simple/Types.hs @@ -8,7 +8,6 @@ -- (c) 2012-2013 Janne Hellsten -- License: BSD3 -- Maintainer: Janne Hellsten --- Stability: experimental -- Portability: portable -- -- Top-level module for sqlite-simple. diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -10,10 +10,17 @@ in turn borrows from [mysql-simple](https://github.com/bos/mysql-simple). -The library has been fairly well unit tested. It's also been benchmarked using -[db-bench](https://github.com/nurpax/db-bench) which is a performance comparison suite -for measuring database access overhead when using the various Haskell database libraries. +[The sqlite-simple API +reference](https://hackage.haskell.org/package/sqlite-simple/docs/Database-SQLite-Simple.html) +contains more examples of use and information on its features. +The library is well tested and stable. The library should also be +reasonably performant. You can find its benchmark suite here: +[db-bench](https://github.com/nurpax/db-bench). You can read more +about sqlite-simple's expected performance in [my blog about +sqlite-simple performance against direct-sqlite, Python and +C](http://nurpax.github.io/posts/2013-08-17-sqlite-simple-benchmarking.html). + [![Build Status](https://secure.travis-ci.org/nurpax/sqlite-simple.png)](http://travis-ci.org/nurpax/sqlite-simple) Installation @@ -84,7 +91,7 @@ ### Contributing -If you send pull requests for new features, it'd be great if you could also develop unit +If you send pull requests for new features, it'd be great if you could also develop unit tests for any such features. diff --git a/sqlite-simple.cabal b/sqlite-simple.cabal --- a/sqlite-simple.cabal +++ b/sqlite-simple.cabal @@ -1,5 +1,5 @@ Name: sqlite-simple -Version: 0.4.4.0 +Version: 0.4.5.0 Synopsis: Mid-Level SQLite client library Description: Mid-level SQLite client library, based on postgresql-simple. @@ -15,9 +15,10 @@ Maintainer: Janne Hellsten Copyright: (c) 2011 MailRank, Inc., (c) 2011-2012 Leon P Smith, - (c) 2012-2013 Janne Hellsten + (c) 2012-2014 Janne Hellsten Homepage: http://github.com/nurpax/sqlite-simple bug-reports: http://github.com/nurpax/sqlite-simple/issues +Stability: stable Category: Database Build-type: Simple @@ -36,15 +37,19 @@ Database.SQLite.Simple.ToField Database.SQLite.Simple.ToRow Database.SQLite.Simple.Types + Database.SQLite.Simple.Time + Database.SQLite.Simple.Time.Implementation Build-depends: + attoparsec >= 0.10.3, base < 5, + blaze-builder, + blaze-textual, bytestring >= 0.9, containers, direct-sqlite >= 2.3.4 && < 2.4, text >= 0.11, time, - old-locale >= 1.0.0.0, transformers default-extensions: @@ -89,7 +94,7 @@ build-depends: base , base16-bytestring - , bytestring + , bytestring >= 0.9 , HUnit , sqlite-simple , direct-sqlite diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -24,6 +24,9 @@ , TestLabel "Simple" . testSimpleTime , TestLabel "Simple" . testSimpleTimeFract , TestLabel "Simple" . testSimpleInsertId + , TestLabel "Simple" . testSimpleUTCTime + , TestLabel "Simple" . testSimpleUTCTimeTZ + , TestLabel "Simple" . testSimpleUTCTimeParams , TestLabel "ParamConv" . testParamConvInt , TestLabel "ParamConv" . testParamConvFloat , TestLabel "ParamConv" . testParamConvDateTime diff --git a/test/Simple.hs b/test/Simple.hs --- a/test/Simple.hs +++ b/test/Simple.hs @@ -7,6 +7,9 @@ , testSimpleTime , testSimpleTimeFract , testSimpleInsertId + , testSimpleUTCTime + , testSimpleUTCTimeTZ + , testSimpleUTCTimeParams ) where import qualified Data.Text as T @@ -126,3 +129,69 @@ (Only "test string") @=? (head rows) [Only row] <- query conn "SELECT t FROM test_row_id WHERE id = ?" (Only (2 :: Int)) :: IO [Only String] "test2" @=? row + +testSimpleUTCTime :: TestEnv -> Test +testSimpleUTCTime TestEnv{..} = TestCase $ do + -- Time formats understood by sqlite: http://sqlite.org/lang_datefunc.html + let timestrs = [ "2012-08-17 13:25" + , "2012-08-17 13:25:44" + , "2012-08-17 13:25:44.123" + ] + timestrsWithT = map (T.map (\c -> if c == ' ' then 'T' else c)) timestrs + execute_ conn "CREATE TABLE utctimes (t TIMESTAMP)" + mapM_ (\t -> execute conn "INSERT INTO utctimes (t) VALUES (?)" (Only t)) timestrs + mapM_ (\t -> execute conn "INSERT INTO utctimes (t) VALUES (?)" (Only t)) timestrsWithT + dates <- query_ conn "SELECT t from utctimes" :: IO [Only UTCTime] + mapM_ matchDates (zip (timestrs ++ timestrsWithT) dates) + let zulu = "2012-08-17 13:25" + [d] <- query conn "SELECT ?" (Only (T.append zulu "Z")) + matchDates (zulu, d) + let zulu = "2012-08-17 13:25:00" + [d] <- query conn "SELECT ?" (Only (T.append zulu "Z")) + matchDates (zulu, d) + where + matchDates (str,(Only date)) = do + -- Remove 'T' when reading in to Haskell + let t = read (makeReadable str) :: UTCTime + t @=? date + + makeReadable s = + let s' = if T.length s < T.length "YYYY-MM-DD HH:MM:SS" then T.append s ":00" else s + in T.unpack . T.replace "T" " " $ s' + +testSimpleUTCTimeTZ :: TestEnv -> Test +testSimpleUTCTimeTZ TestEnv{..} = TestCase $ do + -- Time formats understood by sqlite: http://sqlite.org/lang_datefunc.html + let timestrs = [ "2013-02-03 13:00:00-02:00" + , "2013-02-03 13:00:00-01:00" + , "2013-02-03 13:00:00-03:00" + , "2013-02-03 13:00:00Z" + , "2013-02-03 13:00:00+00:00" + , "2013-02-03 13:00:00+03:00" + , "2013-02-03 13:00:00+02:00" + , "2013-02-03 13:00:00+04:00" + ] + execute_ conn "CREATE TABLE utctimestz (t TIMESTAMP)" + mapM_ (\t -> execute conn "INSERT INTO utctimestz (t) VALUES (?)" (Only t)) timestrs + dates <- query_ conn "SELECT t from utctimestz" :: IO [Only UTCTime] + mapM_ matchDates (zip (timestrs) dates) + where + matchDates (str,(Only date)) = do + -- Remove 'T' when reading in to Haskell + let t = read . T.unpack $ str :: UTCTime + t @=? date + +testSimpleUTCTimeParams :: TestEnv -> Test +testSimpleUTCTimeParams TestEnv{..} = TestCase $ do + let times = [ "2012-08-17 08:00:03" + , "2012-08-17 08:00:03.2" + , "2012-08-17 08:00:03.256" + , "2012-08-17 08:00:03.4192" + ] + -- Try inserting timestamp directly as a string + mapM_ assertResult times + where + assertResult tstr = do + let utct = read . T.unpack $ tstr :: UTCTime + [Only t] <- query conn "SELECT ?" (Only utct) :: IO [Only T.Text] + assertEqual "UTCTime" tstr t