diff --git a/Database/SQLite/Simple.hs b/Database/SQLite/Simple.hs new file mode 100644 --- /dev/null +++ b/Database/SQLite/Simple.hs @@ -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 +-- 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 + } diff --git a/Database/SQLite/Simple/FromField.hs b/Database/SQLite/Simple/FromField.hs new file mode 100644 --- /dev/null +++ b/Database/SQLite/Simple/FromField.hs @@ -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 +-- 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))) diff --git a/Database/SQLite/Simple/FromRow.hs b/Database/SQLite/Simple/FromRow.hs new file mode 100644 --- /dev/null +++ b/Database/SQLite/Simple/FromRow.hs @@ -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 +-- 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 diff --git a/Database/SQLite/Simple/Internal.hs b/Database/SQLite/Simple/Internal.hs new file mode 100644 --- /dev/null +++ b/Database/SQLite/Simple/Internal.hs @@ -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 +-- 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 [] diff --git a/Database/SQLite/Simple/Ok.hs b/Database/SQLite/Simple/Ok.hs new file mode 100644 --- /dev/null +++ b/Database/SQLite/Simple/Ok.hs @@ -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 +-- 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 diff --git a/Database/SQLite/Simple/ToField.hs b/Database/SQLite/Simple/ToField.hs new file mode 100644 --- /dev/null +++ b/Database/SQLite/Simple/ToField.hs @@ -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 +-- 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 #-} diff --git a/Database/SQLite/Simple/ToRow.hs b/Database/SQLite/Simple/ToRow.hs new file mode 100644 --- /dev/null +++ b/Database/SQLite/Simple/ToRow.hs @@ -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 +-- 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 diff --git a/Database/SQLite/Simple/Types.hs b/Database/SQLite/Simple/Types.hs new file mode 100644 --- /dev/null +++ b/Database/SQLite/Simple/Types.hs @@ -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 +-- 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 :. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/sqlite-simple.cabal b/sqlite-simple.cabal new file mode 100644 --- /dev/null +++ b/sqlite-simple.cabal @@ -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 for usage examples & + more information. + +License: BSD3 +License-file: LICENSE +Author: Bryan O'Sullivan, Leon P Smith, Janne Hellsten +Maintainer: Janne Hellsten +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 + diff --git a/test/Common.hs b/test/Common.hs new file mode 100644 --- /dev/null +++ b/test/Common.hs @@ -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 + } diff --git a/test/Errors.hs b/test/Errors.hs new file mode 100644 --- /dev/null +++ b/test/Errors.hs @@ -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))) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/test/ParamConv.hs b/test/ParamConv.hs new file mode 100644 --- /dev/null +++ b/test/ParamConv.hs @@ -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 + diff --git a/test/Simple.hs b/test/Simple.hs new file mode 100644 --- /dev/null +++ b/test/Simple.hs @@ -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 () diff --git a/test/Utf8Strings.hs b/test/Utf8Strings.hs new file mode 100644 --- /dev/null +++ b/test/Utf8Strings.hs @@ -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)