packages feed

sqlite-simple (empty) → 0.1.0.0

raw patch · 17 files changed

+1521/−0 lines, 17 filesdep +HUnitdep +basedep +base16-bytestringsetup-changed

Dependencies added: HUnit, base, base16-bytestring, bytestring, containers, direct-sqlite, sqlite-simple, text, time, transformers

Files

+ Database/SQLite/Simple.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++------------------------------------------------------------------------------+-- |+-- Module:      Database.SQLite.Simple+-- Copyright:   (c) 2011 MailRank, Inc.+--              (c) 2011-2012 Leon P Smith+--              (c) 2012 Janne Hellsten+-- License:     BSD3+-- Maintainer:  Janne Hellsten <jjhellst@gmail.com>+-- Stability:   experimental+-- Portability: portable+--+------------------------------------------------------------------------------++module Database.SQLite.Simple (+    -- * Examples of use+    -- $use+    open+  , close+  , query+  , query_+  , execute+  , execute_+  , field+  , Query+  , Connection+  , ToRow+  , FromRow+  , In(..)+  , Only(..)+  , (:.)(..)+    -- ** Exceptions+  , FormatError(fmtMessage, fmtQuery, fmtParams)+  , ResultError(errSQLType, errHaskellType, errMessage)+  ) where++import           Control.Applicative+import           Control.Exception+  ( Exception, throw, throwIO, bracket )+import           Control.Monad (void, when)+import           Control.Monad.Trans.Reader+import           Control.Monad.Trans.State.Strict+import           Data.ByteString (ByteString)+import qualified Data.Text as T+import           Data.Typeable (Typeable)+import           Database.SQLite.Simple.Types+import qualified Database.SQLite3 as Base+import qualified Data.ByteString.Char8 as B+++import           Database.SQLite.Simple.FromField (ResultError(..))+import           Database.SQLite.Simple.Internal+import           Database.SQLite.Simple.Ok+import           Database.SQLite.Simple.ToRow (ToRow(..))+import           Database.SQLite.Simple.FromRow++{- $use+Create a test database by copy&pasting the below snippet to your+shell:++@+sqlite3 test.db \"CREATE TABLE test (id INTEGER PRIMARY KEY, str text);\\+INSERT INTO test (str) VALUES ('test string');\"+@++..and access it from Haskell:++@+import           Control.Applicative+import           Database.SQLite.Simple+import           Database.SQLite.Simple.FromRow++data TestField = TestField Int String deriving (Show)++instance FromRow TestField where+  fromRow = TestField \<$\> field \<*\> field++main :: IO ()+main = do+  conn <- open \"test.db\"+  execute conn \"INSERT INTO test (str) VALUES (?)\" (Only (\"test string 2\" :: String))+  r <- query_ conn \"SELECT * from test\" :: IO [TestField]+  mapM_ print r+  close conn+@+-}++-- | Exception thrown if a 'Query' was malformed.+-- This may occur if the number of \'@?@\' characters in the query+-- string does not match the number of parameters provided.+data FormatError = FormatError {+      fmtMessage :: String+    , fmtQuery :: Query+    , fmtParams :: [ByteString]+    } deriving (Eq, Show, Typeable)++instance Exception FormatError++-- | Open a database connection to a given file.  Will throw an+-- exception if it cannot connect.+--+-- Every 'open' must be closed with a call to 'close'.+--+-- If you specify \":memory:\" or an empty string as the input filename,+-- then a private, temporary in-memory database is created for the+-- connection.  This database will vanish when you close the+-- connection.+open :: String -> IO Connection+open fname = Connection <$> Base.open fname++-- | Close a database connection.+close :: Connection -> IO ()+close (Connection c) = Base.close c++withBind :: Query -> Base.Statement -> [Base.SQLData] -> IO r -> IO r+withBind templ stmt qp action = do+  stmtParamCount <- Base.bindParameterCount stmt+  when (length qp /= stmtParamCount) (throwColumnMismatch qp stmtParamCount)+  mapM_ errorCheckParamName [1..stmtParamCount]+  Base.bind stmt qp+  action+  where+    throwColumnMismatch qp nParams =+      fmtError ("SQL query contains " ++ show nParams ++ " params, but " +++                show (length qp) ++ " arguments given") templ qp+    errorCheckParamName paramNdx = do+      name <- Base.bindParameterName stmt paramNdx+      case name of+        Just n ->+          fmtError ("Only unnamed '?' query parameters are accepted, '"++n++"' given")+                    templ qp+        Nothing -> return ()++-- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not+-- expected to return results.+--+-- Throws 'FormatError' if the query could not be formatted correctly.+execute :: (ToRow q) => Connection -> Query -> q -> IO ()+execute (Connection c) template@(Query t) qs = do+  bracket (Base.prepare c (T.unpack t)) Base.finalize go+  where+    go stmt = withBind template stmt (toRow qs) (void $ Base.step stmt)++-- | Perform a @SELECT@ or other SQL query that is expected to return+-- results. All results are retrieved and converted before this+-- function returns.+--+-- When processing large results, this function will consume a lot of+-- client-side memory.  Consider using 'fold' instead.+--+-- Exceptions that may be thrown:+--+-- * 'FormatError': the query string mismatched with given arguments.+--+-- * 'QueryError': the result contains no columns (i.e. you should be+--   using 'execute' instead of 'query').+--+-- * 'ResultError': result conversion failed.+query :: (ToRow q, FromRow r)+         => Connection -> Query -> q -> IO [r]+query (Connection conn) templ@(Query t) qs = do+  bracket (Base.prepare conn (T.unpack t)) Base.finalize go+  where+    go stmt = withBind templ stmt (toRow qs) (stepStmt stmt >>= finishQuery)++-- | A version of 'query' that does not perform query substitution.+query_ :: (FromRow r) => Connection -> Query -> IO [r]+query_ conn (Query que) = do+  result <- exec conn que+  finishQuery result++-- | A version of 'execute' that does not perform query substitution.+execute_ :: Connection -> Query -> IO ()+execute_ (Connection conn) (Query que) =+  bracket (Base.prepare conn (T.unpack que)) Base.finalize go+    where+      go stmt = void $ Base.step stmt+++finishQuery :: (FromRow r) => Result -> IO [r]+finishQuery rows =+  mapM doRow $ zip rows [0..]+    where+      doRow (rowRes, rowNdx) = do+        let rw = Row rowNdx 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+                           throw (ConversionFailed+                             (show ncols ++ " values: " ++ show vals)+                             (show col ++ " slots in target type")+                             "mismatch between number of columns to \+                             \convert and number in target type")+          Errors []  -> throwIO $ ConversionFailed "" "" "unknown error"+          Errors [x] -> throwIO x+          Errors xs  -> throwIO $ ManyErrors xs++      ncols = length . head $ rows++fmtError :: String -> Query -> [Base.SQLData] -> a+fmtError msg q xs = throw FormatError {+                      fmtMessage = msg+                    , fmtQuery = q+                    , fmtParams = map (B.pack . show) xs+                    }
+ Database/SQLite/Simple/FromField.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor  #-}+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE PatternGuards, ScopedTypeVariables      #-}++------------------------------------------------------------------------------+-- |+-- Module:      Database.SQLite.Simple.FromField+-- Copyright:   (c) 2011 MailRank, Inc.+--              (c) 2011-2012 Leon P Smith+--              (c) 2012 Janne Hellsten+-- License:     BSD3+-- Maintainer:  Janne Hellsten <jjhellst@gmail.com>+-- Stability:   experimental+-- Portability: portable+--+-- The 'FromField' typeclass, for converting a single value in a row+-- returned by a SQL query into a more useful Haskell representation.+--+-- A Haskell numeric type is considered to be compatible with all+-- SQLite numeric types that are less accurate than it. For instance,+-- the Haskell 'Double' type is compatible with the SQLite's 32-bit+-- @Int@ type because it can represent a @Int@ exactly. On the other hand,+-- since a 'Double' might lose precision if representing a 64-bit @BigInt@,+-- the two are /not/ considered compatible.+--+------------------------------------------------------------------------------++module Database.SQLite.Simple.FromField+    (+      FromField(..)+    , FieldParser+    , ResultError(..)+    , Field+    ) where++import           Control.Applicative (Applicative, (<$>), pure)+import           Control.Exception (SomeException(..), Exception)+import           Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import           Data.Int (Int16, Int32, Int64)+import           Data.Time (UTCTime, Day)+import qualified Data.Text as T+import           Data.Typeable (Typeable, typeOf)++import           Database.SQLite3 as Base+import           Database.SQLite.Simple.Types+import           Database.SQLite.Simple.Internal+import           Database.SQLite.Simple.Ok++-- | Exception thrown if conversion from a SQL value to a Haskell+-- value fails.+data ResultError = Incompatible { errSQLType :: String+                                , errHaskellType :: String+                                , errMessage :: String }+                 -- ^ The SQL and Haskell types are not compatible.+                 | UnexpectedNull { errSQLType :: String+                                  , errHaskellType :: String+                                  , errMessage :: String }+                 -- ^ A SQL @NULL@ was encountered when the Haskell+                 -- type did not permit it.+                 | ConversionFailed { errSQLType :: String+                                    , errHaskellType :: String+                                    , errMessage :: String }+                 -- ^ The SQL value could not be parsed, or could not+                 -- be represented as a valid Haskell value, or an+                 -- unexpected low-level error occurred (e.g. mismatch+                 -- between metadata and actual data in a row).+                   deriving (Eq, Show, Typeable)++instance Exception ResultError++left :: Exception a => a -> Ok b+left = Errors . (:[]) . SomeException++type FieldParser a = Field -> Ok a++-- | A type that may be converted from a SQL type.+class FromField a where+    fromField :: FieldParser a+    -- ^ Convert a SQL value to a Haskell value.+    --+    -- Returns a list of exceptions if the conversion fails.  In the case of+    -- library instances,  this will usually be a single 'ResultError',  but+    -- may be a 'UnicodeException'.+    --+    -- Implementations of 'fromField' should not retain any references to+    -- the 'Field' nor the 'ByteString' arguments after the result has+    -- been evaluated to WHNF.  Such a reference causes the entire+    -- @LibPQ.'PQ.Result'@ to be retained.+    --+    -- For example,  the instance for 'ByteString' uses 'B.copy' to avoid+    -- such a reference,  and that using bytestring functions such as 'B.drop'+    -- and 'B.takeWhile' alone will also trigger this memory leak.++instance (FromField a) => FromField (Maybe a) where+    fromField (Field SQLNull _) = pure Nothing+    fromField f                 = Just <$> fromField f++instance FromField Null where+    fromField (Field SQLNull _) = pure Null+    fromField f                 = returnError ConversionFailed f "data is not null"++takeInt :: (Num a, Typeable a) => Field -> Ok a+takeInt (Field (SQLInteger i) _) = Ok . fromIntegral $ i+takeInt f                        = returnError ConversionFailed f "need an int"++instance FromField Int16 where+    fromField = takeInt++instance FromField Int32 where+    fromField = takeInt++instance FromField Int where+    fromField = takeInt++instance FromField Int64 where+    fromField = takeInt++instance FromField Integer where+    fromField = takeInt++instance FromField Double where+    fromField (Field (SQLFloat flt) _) = Ok flt+    fromField f                        = returnError ConversionFailed f "need a float"++instance FromField T.Text where+    fromField (Field (SQLText txt) _) = Ok txt+    fromField f                       = returnError ConversionFailed f "need a text"++instance FromField [Char] where+  fromField (Field (SQLText t) _) = Ok $ T.unpack t+  fromField f                     = returnError ConversionFailed f "expecting SQLText column type"++-- TODO ToRow has both T and LB variants of ByteString, check what's+-- really needed here+instance FromField ByteString where+  fromField (Field (SQLBlob blb) _) = Ok blb+  fromField f                       = returnError ConversionFailed f "expecting SQLBlob column type"++instance FromField UTCTime where+  fromField (Field (SQLText t) _) = Ok . read . T.unpack $ t+  fromField f                     = returnError ConversionFailed f "expecting SQLText column type"++instance FromField Day where+  fromField (Field (SQLText t) _) = Ok . read . T.unpack $ t+  fromField f                     = returnError ConversionFailed f "expecting SQLText column type"++fieldTypename :: Field -> String+fieldTypename = B.unpack . gettypename . result++-- | Given one of the constructors from 'ResultError',  the field,+--   and an 'errMessage',  this fills in the other fields in the+--   exception value and returns it in a 'Left . SomeException'+--   constructor.+returnError :: forall a err . (Typeable a, Exception err)+            => (String -> String -> String -> err)+            -> Field -> String -> Ok a+returnError mkErr f = left . mkErr (fieldTypename f)+                                   (show (typeOf (undefined :: a)))
+ Database/SQLite/Simple/FromRow.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE RecordWildCards #-}++------------------------------------------------------------------------------+-- |+-- Module:      Database.SQLite.Simple.FromRow+-- Copyright:   (c) 2011-2012 Leon P Smith+--              (c) 2012 Janne Hellsten+-- License:     BSD3+-- Maintainer:  Janne Hellsten <jjhellst@gmail.com>+-- Stability:   experimental+-- Portability: portable+--+-- The 'FromRow' typeclass, for converting a row of results+-- returned by a SQL query into a more useful Haskell representation.+--+-- Predefined instances are provided for tuples containing up to ten+-- elements.+------------------------------------------------------------------------------++module Database.SQLite.Simple.FromRow+     ( FromRow(..)+     , RowParser+     , field+     , fieldWith+     , numFieldsRemaining+     ) where++import           Control.Applicative (Applicative(..), (<$>))+import           Control.Exception (SomeException(..))+import           Control.Monad (replicateM)+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.+--+-- Note that instances can defined outside of sqlite-simple,  which is+-- often useful.   For example, here's an instance for a user-defined pair:+--+-- @data User = User { name :: String, fileQuota :: Int }+--+-- instance 'FromRow' User where+--     fromRow = User \<$\> 'field' \<*\> 'field'+-- @+--+-- The number of calls to 'field' must match the number of fields returned+-- in a single row of the query result.  Otherwise,  a 'ConversionFailed'+-- exception will be thrown.+--+-- Note the caveats associated with user-defined implementations of+-- 'fromRow'.++class FromRow a where+    fromRow :: RowParser a++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]))+    else do+      let r = rowresult !! column+          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++instance (FromField a) => FromRow (Only a) where+    fromRow = Only <$> field++instance (FromField a, FromField b) => FromRow (a,b) where+    fromRow = (,) <$> field <*> field++instance (FromField a, FromField b, FromField c) => FromRow (a,b,c) where+    fromRow = (,,) <$> field <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d) =>+    FromRow (a,b,c,d) where+    fromRow = (,,,) <$> field <*> field <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e) =>+    FromRow (a,b,c,d,e) where+    fromRow = (,,,,) <$> field <*> field <*> field <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+          FromField f) =>+    FromRow (a,b,c,d,e,f) where+    fromRow = (,,,,,) <$> field <*> field <*> field <*> field <*> field+                      <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+          FromField f, FromField g) =>+    FromRow (a,b,c,d,e,f,g) where+    fromRow = (,,,,,,) <$> field <*> field <*> field <*> field <*> field+                       <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+          FromField f, FromField g, FromField h) =>+    FromRow (a,b,c,d,e,f,g,h) where+    fromRow = (,,,,,,,) <$> field <*> field <*> field <*> field <*> field+                        <*> field <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+          FromField f, FromField g, FromField h, FromField i) =>+    FromRow (a,b,c,d,e,f,g,h,i) where+    fromRow = (,,,,,,,,) <$> field <*> field <*> field <*> field <*> field+                         <*> field <*> field <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+          FromField f, FromField g, FromField h, FromField i, FromField j) =>+    FromRow (a,b,c,d,e,f,g,h,i,j) where+    fromRow = (,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field+                          <*> field <*> field <*> field <*> field <*> field++instance FromField a => FromRow [a] where+    fromRow = do+      n <- numFieldsRemaining+      replicateM n field++instance (FromRow a, FromRow b) => FromRow (a :. b) where+    fromRow = (:.) <$> fromRow <*> fromRow
+ Database/SQLite/Simple/Internal.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE RecordWildCards, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+------------------------------------------------------------------------------+-- |+-- Module:      Database.SQLite.Simple.Internal+-- Copyright:   (c) 2011-2012 Leon P Smith+--              (c) 2012 Janne Hellsten+-- License:     BSD3+-- Maintainer:  Janne Hellsten <jjhellst@gmail.com>+-- Stability:   experimental+-- Portability: portable+--+-- Internal bits.  This interface is less stable and can change at any time.+-- In particular this means that while the rest of the sqlite-simple+-- package endeavors to follow the package versioning policy,  this module+-- does not.  Also, at the moment there are things in here that aren't+-- particularly internal and are exported elsewhere;  these will eventually+-- disappear from this module.+--+------------------------------------------------------------------------------++module Database.SQLite.Simple.Internal where++import           Prelude hiding (catch)++import           Control.Applicative+import           Control.Exception+import           Data.ByteString (ByteString)+import           Data.ByteString.Char8()+import           Control.Monad.Trans.State.Strict+import           Control.Monad.Trans.Reader++import qualified Data.Text          as T++import           Database.SQLite.Simple.Ok+import qualified Database.SQLite3 as Base++-- | Connection to an open database.+data Connection = Connection Base.Database++-- | A Field represents metadata about a particular field++data Field = Field {+     result   :: Base.SQLData+   , column   :: {-# UNPACK #-} !Int+   }++data Row = Row {+     row        :: {-# UNPACK #-} !Int+   , rowresult  :: [Base.SQLData]+   }++newtype RowParser a = RP { unRP :: ReaderT Row (StateT Int Ok) a }+   deriving ( Functor, Applicative, Alternative, Monad )++type Result = [[Base.SQLData]]++gettypename :: Base.SQLData -> ByteString+gettypename (Base.SQLInteger _) = "INTEGER"+gettypename (Base.SQLFloat _) = "FLOAT"+gettypename (Base.SQLText _) = "TEXT"+gettypename (Base.SQLBlob _) = "BLOB"+gettypename Base.SQLNull = "NULL"++exec :: Connection -> T.Text -> IO Result+exec (Connection conn) q =+  bracket (Base.prepare conn (T.unpack q)) Base.finalize stepStmt++-- Run a query a prepared statement+stepStmt :: Base.Statement -> IO Result+stepStmt = go+  where+    go stmt = do+      res <- Base.step stmt+      case res of+        Base.Row -> do+          cols <- Base.columns stmt+          next <- go stmt+          return $ cols : next+        Base.Done ->+          return []
+ Database/SQLite/Simple/Ok.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor      #-}++------------------------------------------------------------------------------+-- |+-- Module:     Database.SQLite.Simple.Ok+-- Copyright:  (c) 2012 Leon P Smith+--             (c) 2012 Janne Hellsten+-- License:    BSD3+-- Maintainer: Janne Hellsten <jjhellst@gmail.com>+-- Stability:  experimental+--+-- The 'Ok' type is a simple error handler,  basically equivalent to+-- @Either [SomeException]@.+--+-- One of the primary reasons why this type  was introduced is that+-- @Either SomeException@ had not been provided an instance for 'Alternative',+-- and it would have been a bad idea to provide an orphaned instance for a+-- commonly-used type and typeclass included in @base@.+--+-- Extending the failure case to a list of 'SomeException's enables a+-- more sensible 'Alternative' instance definitions:   '<|>' concatinates+-- the list of exceptions when both cases fail,  and 'empty' is defined as+-- 'Errors []'.   Though '<|>' one could pick one of two exceptions, and+-- throw away the other,  and have 'empty' provide a generic exception,+-- this avoids cases where 'empty' overrides a more informative exception+-- and allows you to see all the different ways your computation has failed.+--+------------------------------------------------------------------------------++module Database.SQLite.Simple.Ok where++import Control.Applicative+import Control.Exception+import Control.Monad(MonadPlus(..))+import Data.Typeable++-- FIXME:   [SomeException] should probably be something else,  maybe+--          a difference list (or a tree?)++data Ok a = Errors [SomeException] | Ok !a+    deriving(Show, Typeable, Functor)++-- | Two 'Errors' cases are considered equal, regardless of what the+--   list of exceptions looks like.++instance Eq a => Eq (Ok a) where+    Errors _ == Errors _  = True+    Ok  a    == Ok  b     = a == b+    _        == _         = False++instance Applicative Ok where+    pure = Ok++    Errors es <*> _ = Errors es+    _ <*> Errors es = Errors es+    Ok f <*> Ok a   = Ok (f a)++instance Alternative Ok where+    empty = Errors []++    a@(Ok _)  <|> _         = a+    Errors _  <|> b@(Ok _)  = b+    Errors as <|> Errors bs = Errors (as ++ bs)++instance MonadPlus Ok where+    mzero = empty+    mplus = (<|>)++instance Monad Ok where+    return = Ok++    Errors es >>= _ = Errors es+    Ok a      >>= f = f a++    fail str = Errors [SomeException (ErrorCall str)]++-- | a way to reify a list of exceptions into a single exception++newtype ManyErrors = ManyErrors [SomeException]+   deriving (Show, Typeable)++instance Exception ManyErrors
+ Database/SQLite/Simple/ToField.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor       #-}+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}++------------------------------------------------------------------------------+-- |+-- Module:      Database.SQLite.Simple.ToField+-- Copyright:   (c) 2011 MailRank, Inc.+--              (c) 2011-2012 Leon P Smith+--              (c) 2012 Janne Hellsten+-- License:     BSD3+-- Maintainer:  Janne Hellsten <jjhellst@gmail.com>+-- Stability:   experimental+-- Portability: portable+--+-- The 'ToField' typeclass, for rendering a parameter to an SQLite+-- value to be bound as a SQL query parameter.+--+------------------------------------------------------------------------------++module Database.SQLite.Simple.ToField (ToField(..)) where++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           Data.Time (Day, UTCTime)+import           Data.Word (Word, Word8, Word16, Word32, Word64)+import           GHC.Float++import           Database.SQLite3 as Base+import           Database.SQLite.Simple.Types (In(..), Null)++-- | A type that may be used as a single parameter to a SQL query.+class ToField a where+    toField :: a -> SQLData+    -- ^ Prepare a value for substitution into a query string.++instance ToField SQLData where+    toField a = a+    {-# INLINE toField #-}++instance (ToField a) => ToField (Maybe a) where+    toField Nothing  = Base.SQLNull+    toField (Just a) = toField a+    {-# INLINE toField #-}++instance (ToField a) => ToField (In [a]) where+    toField (In _) =+      error "NOT IMPLEMENTED see https://github.com/nurpax/sqlite-simple/issues/6"++instance ToField Null where+    toField _ = Base.SQLNull+    {-# INLINE toField #-}++instance ToField Bool where+    toField True  = SQLText "true"+    toField False = SQLText "false"+    {-# INLINE toField #-}++instance ToField Int8 where+    toField = SQLInteger . fromIntegral+    {-# INLINE toField #-}++instance ToField Int16 where+    toField = SQLInteger . fromIntegral+    {-# INLINE toField #-}++instance ToField Int32 where+    toField = SQLInteger . fromIntegral+    {-# INLINE toField #-}++instance ToField Int where+    toField = SQLInteger . fromIntegral+    {-# INLINE toField #-}++instance ToField Int64 where+    toField = SQLInteger . fromIntegral+    {-# INLINE toField #-}++instance ToField Integer where+    toField = SQLInteger . fromIntegral+    {-# INLINE toField #-}++instance ToField Word8 where+    toField = SQLInteger . fromIntegral+    {-# INLINE toField #-}++instance ToField Word16 where+    toField = SQLInteger . fromIntegral+    {-# INLINE toField #-}++instance ToField Word32 where+    toField = SQLInteger . fromIntegral+    {-# INLINE toField #-}++instance ToField Word where+    toField = SQLInteger . fromIntegral+    {-# INLINE toField #-}++instance ToField Word64 where+    toField = SQLInteger . fromIntegral+    {-# INLINE toField #-}++instance ToField Float where+    toField = SQLFloat . float2Double+    {-# INLINE toField #-}++instance ToField Double where+    toField = SQLFloat+    {-# INLINE toField #-}++instance ToField SB.ByteString where+    toField = SQLBlob+    {-# INLINE toField #-}++instance ToField LB.ByteString where+    toField = toField . SB.concat . LB.toChunks+    {-# INLINE toField #-}++instance ToField T.Text where+    toField = SQLText+    {-# INLINE toField #-}++instance ToField [Char] where+    toField = SQLText . T.pack+    {-# INLINE toField #-}++instance ToField LT.Text where+    toField = toField . LT.toStrict+    {-# INLINE toField #-}++instance ToField UTCTime where+    toField = SQLText . T.pack . show+    {-# INLINE toField #-}++instance ToField Day where+    toField = SQLText . T.pack . show+    {-# INLINE toField #-}++-- TODO enable these+--instance ToField ZonedTime where+--    toField = SQLText . zonedTimeToBuilder+--    {-# INLINE toField #-}+--+--instance ToField LocalTime where+--    toField = SQLText . localTimeToBuilder+--    {-# INLINE toField #-}+--+--instance ToField Day where+--    toField = SQLText . dayToBuilder+--    {-# INLINE toField #-}+--+--instance ToField TimeOfDay where+--    toField = SQLText . timeOfDayToBuilder+--    {-# INLINE toField #-}+--+--instance ToField UTCTimestamp where+--    toField = SQLText . utcTimestampToBuilder+--    {-# INLINE toField #-}+--+--instance ToField ZonedTimestamp where+--    toField = SQLText . zonedTimestampToBuilder+--    {-# INLINE toField #-}+--+--instance ToField LocalTimestamp where+--    toField = SQLText . localTimestampToBuilder+--    {-# INLINE toField #-}+--+--instance ToField Date where+--    toField = SQLText . dateToBuilder+--    {-# INLINE toField #-}
+ Database/SQLite/Simple/ToRow.hs view
@@ -0,0 +1,90 @@+------------------------------------------------------------------------------+-- |+-- Module:      Database.SQLite.Simple.ToRow+-- Copyright:   (c) 2011 MailRank, Inc.+--              (c) 2011-2012 Leon P Smith+--              (c) 2012 Janne Hellsten+-- License:     BSD3+-- Maintainer:  Janne Hellsten <jjhellst@gmail.com>+-- Stability:   experimental+-- Portability: portable+--+-- The 'ToRow' typeclass, for rendering a collection of+-- parameters to a SQL query.+--+-- Predefined instances are provided for tuples containing up to ten+-- elements.+--+------------------------------------------------------------------------------++module Database.SQLite.Simple.ToRow+    (+      ToRow(..)+    ) where++import Database.SQLite.Simple.ToField (ToField(..))+import Database.SQLite.Simple.Types (Only(..), (:.)(..))++import Database.SQLite3 (SQLData(..))++-- | A collection type that can be turned into a list of SQLData+-- elements.+class ToRow a where+    toRow :: a -> [SQLData]+    -- ^ ToField a collection of values.++instance ToRow () where+    toRow _ = []++instance (ToField a) => ToRow (Only a) where+    toRow (Only v) = [toField v]++instance (ToField a, ToField b) => ToRow (a,b) where+    toRow (a,b) = [toField a, toField b]++instance (ToField a, ToField b, ToField c) => ToRow (a,b,c) where+    toRow (a,b,c) = [toField a, toField b, toField c]++instance (ToField a, ToField b, ToField c, ToField d) => ToRow (a,b,c,d) where+    toRow (a,b,c,d) = [toField a, toField b, toField c, toField d]++instance (ToField a, ToField b, ToField c, ToField d, ToField e)+    => ToRow (a,b,c,d,e) where+    toRow (a,b,c,d,e) =+        [toField a, toField b, toField c, toField d, toField e]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f)+    => ToRow (a,b,c,d,e,f) where+    toRow (a,b,c,d,e,f) =+        [toField a, toField b, toField c, toField d, toField e, toField f]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,+          ToField g)+    => ToRow (a,b,c,d,e,f,g) where+    toRow (a,b,c,d,e,f,g) =+        [toField a, toField b, toField c, toField d, toField e, toField f,+         toField g]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,+          ToField g, ToField h)+    => ToRow (a,b,c,d,e,f,g,h) where+    toRow (a,b,c,d,e,f,g,h) =+        [toField a, toField b, toField c, toField d, toField e, toField f,+         toField g, toField h]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,+          ToField g, ToField h, ToField i)+    => ToRow (a,b,c,d,e,f,g,h,i) where+    toRow (a,b,c,d,e,f,g,h,i) =+        [toField a, toField b, toField c, toField d, toField e, toField f,+         toField g, toField h, toField i]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,+          ToField g, ToField h, ToField i, ToField j)+    => ToRow (a,b,c,d,e,f,g,h,i,j) where+    toRow (a,b,c,d,e,f,g,h,i,j) =+        [toField a, toField b, toField c, toField d, toField e, toField f,+         toField g, toField h, toField i, toField j]++instance (ToRow a, ToRow b) => ToRow (a :. b) where+    toRow (a :. b) = toRow a ++ toRow b
+ Database/SQLite/Simple/Types.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}++------------------------------------------------------------------------------+-- |+-- Module:      Database.SQLite.Simple.Types+-- Copyright:   (c) 2011 MailRank, Inc.+--              (c) 2011-2012 Leon P Smith+--              (c) 2012 Janne Hellsten+-- License:     BSD3+-- Maintainer:  Janne Hellsten <jjhellst@gmail.com>+-- Stability:   experimental+-- Portability: portable+--+-- Top-level module for sqlite-simple.+--+--+------------------------------------------------------------------------------++module Database.SQLite.Simple.Types+    (+      Null(..)+    , Only(..)+    , In(..)+    , Query(..)+    , (:.)(..)+    ) where++import           Control.Arrow (first)+import           Data.Monoid (Monoid(..))+import           Data.String (IsString(..))+import           Data.Typeable (Typeable)+import qualified Data.Text as T++-- | A placeholder for the SQL @NULL@ value.+data Null = Null+          deriving (Read, Show, Typeable)++instance Eq Null where+    _ == _ = False+    _ /= _ = False++-- | A query string. This type is intended to make it difficult to+-- construct a SQL query by concatenating string fragments, as that is+-- an extremely common way to accidentally introduce SQL injection+-- vulnerabilities into an application.+--+-- This type is an instance of 'IsString', so the easiest way to+-- construct a query is to enable the @OverloadedStrings@ language+-- extension and then simply write the query in double quotes.+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- >+-- > import Database.PostgreSQL.Simple+-- >+-- > q :: Query+-- > q = "select ?"+--+-- The underlying type is a 'Text', and literal Haskell strings that+-- contain Unicode characters will be correctly transformed to UTF-8.+newtype Query = Query {+      fromQuery :: T.Text+    } deriving (Eq, Ord, Typeable)++instance Show Query where+    show = show . fromQuery++instance Read Query where+    readsPrec i = fmap (first Query) . readsPrec i++instance IsString Query where+    fromString = Query . T.pack++instance Monoid Query where+    mempty = Query T.empty+    mappend (Query a) (Query b) = Query (T.append a b)+    {-# INLINE mappend #-}++-- | A single-value \"collection\".+--+-- This is useful if you need to supply a single parameter to a SQL+-- query, or extract a single column from a SQL result.+--+-- Parameter example:+--+-- @query c \"select x from scores where x > ?\" ('Only' (42::Int))@+--+-- Result example:+--+-- @xs <- query_ c \"select id from users\"+--forM_ xs $ \\('Only' id) -> {- ... -}@+newtype Only a = Only {+      fromOnly :: a+    } deriving (Eq, Ord, Read, Show, Typeable, Functor)++-- | Wrap a list of values for use in an @IN@ clause.  Replaces a+-- single \"@?@\" character with a parenthesized list of rendered+-- values.+--+-- Example:+--+-- > query c "select * from whatever where id in ?" (In [3,4,5])+newtype In a = In a+    deriving (Eq, Ord, Read, Show, Typeable, Functor)++-- | A composite type to parse your custom data structures without+-- having to define dummy newtype wrappers every time.+--+--+-- > instance FromRow MyData where ...+--+-- > instance FromRow MyData2 where ...+--+--+-- then I can do the following for free:+--+-- @+-- res <- query' c "..."+-- forM res $ \\(MyData{..} :. MyData2{..}) -> do+--   ....+-- @+data h :. t = h :. t deriving (Eq,Ord,Show,Read,Typeable)++infixr 3 :.
+ LICENSE view
@@ -0,0 +1,94 @@+Copyright (c) 2012, Janne Hellsten++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Leon P Smith nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+++Copyright (c) 2011, Leon P Smith++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Leon P Smith nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+++Copyright (c) 2011, MailRank, Inc.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ sqlite-simple.cabal view
@@ -0,0 +1,87 @@+Name:                sqlite-simple+Version:             0.1.0.0+Synopsis:            Mid-Level SQLite client library+Description:+    Mid-level SQLite client library, based on postgresql-simple.+    .+    See <http://github.com/nurpax/sqlite-simple> for usage examples &+    more information.++License:             BSD3+License-file:        LICENSE+Author:              Bryan O'Sullivan, Leon P Smith, Janne Hellsten+Maintainer:          Janne Hellsten <jjhellst@gmail.com>+Copyright:           (c) 2011 MailRank, Inc.,+                     (c) 2011-2012 Leon P Smith,+                     (c) 2012 Janne Hellsten+Homepage:            http://github.com/nurpax/sqlite-simple+bug-reports:         http://github.com/nurpax/sqlite-simple/issues+Category:            Database+Build-type:          Simple++Cabal-version:       >= 1.10++Library+  Default-language:  Haskell2010+  Exposed-modules:+     Database.SQLite.Simple+     Database.SQLite.Simple.Ok+     Database.SQLite.Simple.FromField+     Database.SQLite.Simple.FromRow+     Database.SQLite.Simple.Internal+     Database.SQLite.Simple.ToField+     Database.SQLite.Simple.ToRow+     Database.SQLite.Simple.Types++  Build-depends:+    base < 5,+    bytestring >= 0.9,+    containers,+    direct-sqlite >= 2.0,+    text >= 0.11.1,+    time,+    transformers++  default-extensions:+      DoAndIfThenElse+    , OverloadedStrings+    , BangPatterns+    , ViewPatterns+    , TypeOperators++  ghc-options: -Wall -fno-warn-name-shadowing++source-repository head+  type:     git+  location: http://github.com/nurpax/sqlite-simple+++test-suite test+  default-language: Haskell2010+  type:             exitcode-stdio-1.0++  hs-source-dirs: test+  main-is:        Main.hs+  other-modules:+    Common+    Simple+    Errors+    ParamConv+    Utf8Strings++  ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind++  default-extensions:+      NamedFieldPuns+    , OverloadedStrings+    , Rank2Types+    , RecordWildCards++  build-depends: base+               , base16-bytestring+               , bytestring+               , HUnit+               , sqlite-simple+               , text+               , time+
+ test/Common.hs view
@@ -0,0 +1,18 @@++module Common (+    module Database.SQLite.Simple+  , module Test.HUnit+  , TestEnv(..)+) where++import Test.HUnit++import Database.SQLite.Simple++data TestEnv+    = TestEnv+        { conn     :: Connection+            -- ^ Connection shared by all the tests+        , withConn :: forall a. (Connection -> IO a) -> IO a+            -- ^ Bracket for spawning additional connections+        }
+ test/Errors.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Errors (+    testErrorsColumns+  , testErrorsInvalidParams+  ) where++import Prelude hiding (catch)+import Control.Exception+import qualified Data.ByteString as B+import Data.Word++import Common++assertResultErrorCaught :: IO a -> Assertion+assertResultErrorCaught action = do+  catch (action >> return False) (\(_ :: ResultError) -> return True) >>=+    assertBool "assertResultError exc"++assertFormatErrorCaught :: IO a -> Assertion+assertFormatErrorCaught action = do+  catch (action >> return False) (\(_ :: FormatError) -> return True) >>=+    assertBool "assertFormatError exc"++testErrorsColumns :: TestEnv -> Test+testErrorsColumns TestEnv{..} = TestCase $ do+  execute_ conn "CREATE TABLE cols (id INTEGER PRIMARY KEY, t TEXT)"+  execute_ conn "INSERT INTO cols (t) VALUES ('test string')"+  rows <- query_ conn "SELECT t FROM cols" :: IO [Only String]+  assertEqual "row count" 1 (length rows)+  assertEqual "string" (Only "test string") (head rows)+  -- Mismatched number of output columns (selects two, dest type has 1 field)+  assertResultErrorCaught (query_ conn "SELECT id,t FROM cols" :: IO [Only Int])+  -- Same as above but the other way round (select 1, dst has two)+  assertResultErrorCaught (query_ conn "SELECT id FROM cols" :: IO [(Int, String)])+  -- Mismatching types (source int,text doesn't match dst string,int+  assertResultErrorCaught (query_ conn "SELECT id, t FROM cols" :: IO [(String, Int)])+  -- Trying to get a blob into a string+  let d = B.pack ([0..127] :: [Word8])+  execute_ conn "CREATE TABLE cols_blobs (id INTEGER, b BLOB)"+  execute conn "INSERT INTO cols_blobs (id, b) VALUES (?,?)" (1 :: Int, d)+  assertResultErrorCaught+    (do [Only _t1] <- query conn "SELECT b FROM cols_blobs WHERE id = ?" (Only (1 :: Int)) :: IO [Only String]+        return ())++testErrorsInvalidParams :: TestEnv -> Test+testErrorsInvalidParams TestEnv{..} = TestCase $ do+  execute_ conn "CREATE TABLE invparams (id INTEGER PRIMARY KEY, t TEXT)"+  -- Test that only unnamed params are accepted+  assertFormatErrorCaught+    (execute conn "INSERT INTO invparams (t) VALUES (:v)" (Only ("foo" :: String)))+  assertFormatErrorCaught+    (execute conn "INSERT INTO invparams (id, t) VALUES (:v,$1)" (3::Int, "foo" :: String))+  -- In this case, we have two bound params but only one given to+  -- execute.  This should cause an error.+  assertFormatErrorCaught+    (execute conn "INSERT INTO invparams (id, t) VALUES (?, ?)" (Only (3::Int)))
+ test/Main.hs view
@@ -0,0 +1,49 @@++import Common+import Control.Exception (bracket)+import Control.Monad     (when)+import System.Exit       (exitFailure)+import System.IO++import Simple+import ParamConv+import Errors+import Utf8Strings++tests :: [TestEnv -> Test]+tests =+    [ TestLabel "Simple"    . testSimpleSelect+    , TestLabel "Simple"    . testSimpleOnePlusOne+    , TestLabel "Simple"    . testSimpleParams+    , TestLabel "ParamConv" . testParamConvInt+    , TestLabel "ParamConv" . testParamConvFloat+    , TestLabel "ParamConv" . testParamConvDateTime+    , TestLabel "Errors"    . testErrorsColumns+    , TestLabel "Errors"    . testErrorsInvalidParams+    , TestLabel "Utf8"      . testUtf8Simplest+    , TestLabel "Utf8"      . testBlobs+    ]++-- | 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 = open ":memory:"++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/ParamConv.hs view
@@ -0,0 +1,62 @@++module ParamConv (+    testParamConvInt+  , testParamConvFloat+  , testParamConvDateTime) where++import Data.Int+import Data.Time++import Common++one, two, three :: Int+one   = 1+two   = 2+three = 3++testParamConvInt :: TestEnv -> Test+testParamConvInt TestEnv{..} = TestCase $ do+  [Only r] <- (query conn "SELECT ?" (Only one)) :: IO [Only Int]+  assertEqual "value" 1 r+  [Only r] <- (query conn "SELECT ?+?" (one, two)) :: IO [Only Int]+  assertEqual "value" 3 r+  [Only r] <- (query conn "SELECT ?+?" (one, 15 :: Int64)) :: IO [Only Int]+  assertEqual "value" 16 r+  [Only r] <- (query conn "SELECT ?+?" (two, 14 :: Int32)) :: IO [Only Int]+  assertEqual "value" 16 r+  -- This overflows 32-bit ints, verify that we get more than 32-bits out+  [Only r] <- (query conn "SELECT 255*?" (Only (0x7FFFFFFF :: Int32))) :: IO [Only Int64]+  assertEqual "> 32-bit result"+    (255*0x7FFFFFFF :: Int64) (fromIntegral r)+  [Only r] <- (query conn "SELECT 2*?" (Only (0x7FFFFFFFFF :: Int64))) :: IO [Only Int64]+  assertEqual "> 32-bit result & param"+    (2*0x7FFFFFFFFF :: Int64) (fromIntegral r)+  [Only r] <- (query_ conn "SELECT NULL") :: IO [Only (Maybe Int)]+  assertEqual "should see nothing" Nothing r+  [Only r] <- (query_ conn "SELECT 3") :: IO [Only (Maybe Int)]+  assertEqual "should see Just 3" (Just 3) r+  [Only r] <- (query conn "SELECT ?") (Only (Nothing :: Maybe Int)) :: IO [Only (Maybe Int)]+  assertEqual "should see nothing" Nothing r+  [Only r] <- (query conn "SELECT ?") (Only (Just three :: Maybe Int)) :: IO [Only (Maybe Int)]+  assertEqual "should see 4" (Just 3) r++testParamConvFloat :: TestEnv -> Test+testParamConvFloat TestEnv{..} = TestCase $ do+  [Only r] <- query conn "SELECT ?" (Only (1.0 :: Double)) :: IO [Only Double]+  assertEqual "value" 1.0 r+  [Only r] <- query conn "SELECT ?*0.25" (Only (8.0 :: Double)) :: IO [Only Double]+  assertEqual "value" 2.0 r++testParamConvDateTime :: TestEnv -> Test+testParamConvDateTime TestEnv{..} = TestCase $ do+  execute_ conn "CREATE TABLE dt (id INTEGER PRIMARY KEY, t1 DATE, t2 TIMESTAMP)"+  execute_ conn "INSERT INTO dt (t1, t2) VALUES (date('now'), datetime('now'))"+  _rows <- query_ conn "SELECT t1,t2 from dt" :: IO [(Day, UTCTime)]+  -- TODO should _rows be forced to make sure parsers kick on the+  -- returned data?+  execute conn "INSERT INTO dt (t1,t2) VALUES (?,?)"+    (read "2012-08-12" :: Day, read "2012-08-12 01:01:01" :: UTCTime)+  [_,(t1,t2)] <- query_ conn "SELECT t1,t2 from dt" :: IO [(Day, UTCTime)]+  assertEqual "day" (read "2012-08-12" :: Day) t1+  assertEqual "day" (read "2012-08-12 01:01:01" :: UTCTime) t2+
+ test/Simple.hs view
@@ -0,0 +1,51 @@++module Simple (+    testSimpleOnePlusOne+  , testSimpleSelect+  , testSimpleParams) where++import Common++-- Simplest SELECT+testSimpleOnePlusOne :: TestEnv -> Test+testSimpleOnePlusOne TestEnv{..} = TestCase $ do+  rows <- query_ conn "SELECT 1+1" :: IO [Only Int]+  assertEqual "row count" 1 (length rows)+  assertEqual "value" (Only 2) (head rows)++testSimpleSelect :: TestEnv -> Test+testSimpleSelect TestEnv{..} = TestCase $ do+  execute_ conn "CREATE TABLE test1 (id INTEGER PRIMARY KEY, t TEXT)"+  execute_ conn "INSERT INTO test1 (t) VALUES ('test string')"+  rows <- query_ conn "SELECT t FROM test1" :: IO [Only String]+  assertEqual "row count" 1 (length rows)+  assertEqual "string" (Only "test string") (head rows)+  rows <- query_ conn "SELECT id,t FROM test1" :: IO [(Int, String)]+  assertEqual "int,string" (1, "test string") (head rows)+  -- Add another row+  execute_ conn "INSERT INTO test1 (t) VALUES ('test string 2')"+  rows <- query_ conn "SELECT id,t FROM test1" :: IO [(Int, String)]+  assertEqual "row count" 2 (length rows)+  assertEqual "int,string" (1, "test string") (rows !! 0)+  assertEqual "int,string" (2, "test string 2") (rows !! 1)+  [Only r] <- query_ conn "SELECT NULL" :: IO [Only (Maybe Int)]+  assertEqual "nulls" Nothing r+  [Only r] <- query_ conn "SELECT 1" :: IO [Only (Maybe Int)]+  assertEqual "nulls" (Just 1) r++testSimpleParams :: TestEnv -> Test+testSimpleParams TestEnv{..} = TestCase $ do+  execute_ conn "CREATE TABLE testparams (id INTEGER PRIMARY KEY, t TEXT)"+  execute_ conn "CREATE TABLE testparams2 (id INTEGER, t TEXT, t2 TEXT)"+  [Only i] <- query conn "SELECT ?" (Only (42 :: Int))  :: IO [Only Int]+  assertEqual "select int param" 42 i+  execute conn "INSERT INTO testparams (t) VALUES (?)" (Only ("test string" :: String))+  rows <- query conn "SELECT t FROM testparams WHERE id = ?" (Only (1 :: Int)) :: IO [Only String]+  assertEqual "row count" 1 (length rows)+  assertEqual "string" (Only "test string") (head rows)+  execute_ conn "INSERT INTO testparams (t) VALUES ('test2')"+  [Only row] <- query conn "SELECT t FROM testparams WHERE id = ?" (Only (1 :: Int)) :: IO [Only String]+  assertEqual "select params" "test string" row+  [Only row] <- query conn "SELECT t FROM testparams WHERE id = ?" (Only (2 :: Int)) :: IO [Only String]+  assertEqual "select params" "test2" row+  return ()
+ test/Utf8Strings.hs view
@@ -0,0 +1,28 @@+-- -*- coding: utf-8 -*-++module Utf8Strings (testUtf8Simplest+                  , testBlobs) where++import Common+import qualified Data.ByteString as B+import Data.Word++testUtf8Simplest :: TestEnv -> Test+testUtf8Simplest TestEnv{..} = TestCase $ do+  execute_ conn "CREATE TABLE utf (id INTEGER, t TEXT)"+  execute_ conn "INSERT INTO utf (id, t) VALUES (1, 'ääöö')"+  execute conn "INSERT INTO utf (id, t) VALUES (?,?)" (2 :: Int, "ääööåå" :: String)+  [Only t1] <- query conn "SELECT t FROM utf WHERE id = ?" (Only (1 :: Int))+  assertEqual "utf8" ("ääöö" :: String) t1+  [Only t2] <- query conn "SELECT t FROM utf WHERE id = ?" (Only (2 :: Int))+  assertEqual "utf8" ("ääööåå" :: String) t2++testBlobs :: TestEnv -> Test+testBlobs TestEnv{..} = TestCase $ do+  let d = B.pack ([0..127] :: [Word8])+  execute_ conn "CREATE TABLE blobs (id INTEGER, b BLOB)"+  execute conn "INSERT INTO blobs (id, b) VALUES (?,?)" (1 :: Int, d)+  [Only t1] <- query conn "SELECT b FROM blobs WHERE id = ?" (Only (1 :: Int))+  assertEqual "blob" d t1+  assertEqual "blob nul char" 0 (B.index d 0)+  assertEqual "blob first char" 1 (B.index d 1)