diff --git a/Database/SQLite/Simple.hs b/Database/SQLite/Simple.hs --- a/Database/SQLite/Simple.hs +++ b/Database/SQLite/Simple.hs @@ -1,820 +1,820 @@ -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables, GADTs #-} - ------------------------------------------------------------------------------- --- | --- Module: Database.SQLite.Simple --- Copyright: (c) 2011 MailRank, Inc. --- (c) 2011-2012 Leon P Smith --- (c) 2012-2013 Janne Hellsten --- License: BSD3 --- Maintainer: Janne Hellsten --- Portability: portable --- ------------------------------------------------------------------------------- - -module Database.SQLite.Simple ( - -- ** Examples of use - -- $use - - -- ** The Query type - -- $querytype - - -- ** Parameter substitution - -- $subst - - -- *** Positional parameters - -- $substpos - - -- *** Named parameters - -- $substnamed - - -- *** Type inference - -- $inference - - -- ** Substituting a single parameter - -- $only_param - - -- * Extracting results - -- $result - - -- ** Handling null values - -- $null - - -- ** Type conversions - -- $types - - -- *** Conversion to/from UTCTime - -- $utctime - - Query(..) - , Connection(..) - , ToRow(..) - , FromRow(..) - , Only(..) - , (:.)(..) - , Base.SQLData(..) - , Statement - , ColumnIndex(..) - , NamedParam(..) - -- * Connections - , open - , close - , withConnection - , setTrace - -- * Queries that return results - , query - , query_ - , queryWith - , queryWith_ - , queryNamed - , lastInsertRowId - , changes - , totalChanges - -- * Queries that stream results - , fold - , fold_ - , foldNamed - -- * Statements that do not return results - , execute - , execute_ - , executeMany - , executeNamed - , field - -- * Transactions - , withTransaction - -- * Low-level statement API for stream access and prepared statements - , openStatement - , closeStatement - , withStatement - , bind - , bindNamed - , reset - , columnName - , withBind - , nextRow - -- ** Exceptions - , FormatError(..) - , ResultError(..) - , Base.SQLError(..) - , Base.Error(..) - ) where - -import Control.Applicative -import Control.Exception -import Control.Monad (void, when, forM_) -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State.Strict -import Data.Int (Int64) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Data.Typeable (Typeable) -import Database.SQLite.Simple.Types -import qualified Database.SQLite3 as Base -import qualified Database.SQLite3.Direct as BaseD - - -import Database.SQLite.Simple.FromField (ResultError(..)) -import Database.SQLite.Simple.FromRow -import Database.SQLite.Simple.Internal -import Database.SQLite.Simple.Ok -import Database.SQLite.Simple.ToField (ToField(..)) -import Database.SQLite.Simple.ToRow (ToRow(..)) - --- | An SQLite prepared statement. -newtype Statement = Statement Base.Statement - --- | Index of a column in a result set. Column indices start from 0. -newtype ColumnIndex = ColumnIndex BaseD.ColumnIndex - deriving (Eq, Ord, Enum, Num, Real, Integral) - -data NamedParam where - (:=) :: (ToField v) => T.Text -> v -> NamedParam - -infixr 3 := - -instance Show NamedParam where - show (k := v) = show (k, toField v) - --- | 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 :: [String] - } 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 (T.pack fname) - --- | Close a database connection. -close :: Connection -> IO () -close (Connection c) = Base.close c - --- | Opens a database connection, executes an action using this connection, and --- closes the connection, even in the presence of exceptions. -withConnection :: String -> (Connection -> IO a) -> IO a -withConnection connString = bracket (open connString) close - -unUtf8 :: BaseD.Utf8 -> T.Text -unUtf8 (BaseD.Utf8 bs) = TE.decodeUtf8 bs - --- | --- --- Enable/disable tracing of SQL execution. Tracing can be disabled --- by setting 'Nothing' as the logger callback. --- --- Warning: If the logger callback throws an exception, your whole --- program may crash. Enable only for debugging! -setTrace :: Connection -> Maybe (T.Text -> IO ()) -> IO () -setTrace (Connection db) logger = - BaseD.setTrace db (fmap (\lf -> lf . unUtf8) logger) - --- | Binds parameters to a prepared statement. Once 'nextRow' returns 'Nothing', --- the statement must be reset with the 'reset' function before it can be --- executed again by calling 'nextRow'. -bind :: (ToRow params) => Statement -> params -> IO () -bind (Statement stmt) params = do - let qp = toRow params - stmtParamCount <- Base.bindParameterCount stmt - when (length qp /= fromIntegral stmtParamCount) (throwColumnMismatch qp stmtParamCount) - mapM_ (errorCheckParamName qp) [1..stmtParamCount] - Base.bind stmt qp - where - throwColumnMismatch qp nParams = do - templ <- getQuery stmt - fmtError ("SQL query contains " ++ show nParams ++ " params, but " ++ - show (length qp) ++ " arguments given") templ qp - errorCheckParamName qp paramNdx = do - templ <- getQuery stmt - name <- Base.bindParameterName stmt paramNdx - case name of - Just n -> - fmtError ("Only unnamed '?' query parameters are accepted, '"++T.unpack n++"' given") - templ qp - Nothing -> return $! () - --- | Binds named parameters to a prepared statement. -bindNamed :: Statement -> [NamedParam] -> IO () -bindNamed (Statement stmt) params = do - stmtParamCount <- Base.bindParameterCount stmt - when (length params /= fromIntegral stmtParamCount) $ throwColumnMismatch stmtParamCount - bind stmt params - where - bind stmt params = - mapM_ (\(n := v) -> do - idx <- BaseD.bindParameterIndex stmt (BaseD.Utf8 . TE.encodeUtf8 $ n) - case idx of - Just i -> - Base.bindSQLData stmt i (toField v) - Nothing -> do - templ <- getQuery stmt - fmtError ("Unknown named parameter '" ++ T.unpack n ++ "'") - templ params) - params - - throwColumnMismatch nParams = do - templ <- getQuery stmt - fmtError ("SQL query contains " ++ show nParams ++ " params, but " ++ - show (length params) ++ " arguments given") templ params - --- | Resets a statement. This does not reset bound parameters, if any, but --- allows the statement to be reexecuted again by invoking 'nextRow'. -reset :: Statement -> IO () -reset (Statement stmt) = Base.reset stmt - --- | Return the name of a a particular column in the result set of a --- 'Statement'. Throws an 'ArrayException' if the colum index is out --- of bounds. --- --- -columnName :: Statement -> ColumnIndex -> IO T.Text -columnName (Statement stmt) (ColumnIndex n) = BaseD.columnName stmt n >>= takeUtf8 - where - takeUtf8 (Just s) = return $ unUtf8 s - takeUtf8 Nothing = - throwIO (IndexOutOfBounds ("Column index " ++ show n ++ " out of bounds")) - --- | Binds parameters to a prepared statement, and 'reset's the statement when --- the callback completes, even in the presence of exceptions. --- --- Use 'withBind' to reuse prepared statements. Because it 'reset's the --- statement /after/ each usage, it avoids a pitfall involving implicit --- transactions. SQLite creates an implicit transaction if you don't say --- @BEGIN@ explicitly, and does not commit it until all active statements are --- finished with either 'reset' or 'closeStatement'. -withBind :: (ToRow params) => Statement -> params -> IO a -> IO a -withBind stmt params io = do - bind stmt params - io `finally` reset stmt - --- | Opens a prepared statement. A prepared statement must always be closed with --- a corresponding call to 'closeStatement' before closing the connection. Use --- 'nextRow' to iterate on the values returned. Once 'nextRow' returns --- 'Nothing', you need to invoke 'reset' before reexecuting the statement again --- with 'nextRow'. -openStatement :: Connection -> Query -> IO Statement -openStatement (Connection c) (Query t) = do - stmt <- Base.prepare c t - return $ Statement stmt - --- | Closes a prepared statement. -closeStatement :: Statement -> IO () -closeStatement (Statement stmt) = Base.finalize stmt - --- | Opens a prepared statement, executes an action using this statement, and --- closes the statement, even in the presence of exceptions. -withStatement :: Connection -> Query -> (Statement -> IO a) -> IO a -withStatement conn query = bracket (openStatement conn query) closeStatement - --- A version of 'withStatement' which binds parameters. -withStatementParams :: (ToRow params) - => Connection - -> Query - -> params - -> (Statement -> IO a) - -> IO a -withStatementParams conn template params action = - withStatement conn template $ \stmt -> - -- Don't use withBind here, there is no need to reset the parameters since - -- we're destroying the statement - bind stmt (toRow params) >> action stmt - --- A version of 'withStatement' which binds named parameters. -withStatementNamedParams :: Connection - -> Query - -> [NamedParam] - -> (Statement -> IO a) - -> IO a -withStatementNamedParams conn template namedParams action = - withStatement conn template $ \stmt -> bindNamed stmt namedParams >> action stmt - --- | 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 conn template qs = - withStatementParams conn template qs $ \(Statement stmt) -> - void . Base.step $ stmt - --- | Execute a multi-row @INSERT@, @UPDATE@, or other SQL query that is not --- expected to return results. --- --- Throws 'FormatError' if the query could not be formatted correctly. -executeMany :: ToRow q => Connection -> Query -> [q] -> IO () -executeMany conn template paramRows = withStatement conn template $ \stmt -> do - let Statement stmt' = stmt - forM_ paramRows $ \params -> - withBind stmt params - (void . Base.step $ stmt') - - -doFoldToList :: RowParser row -> Statement -> IO [row] -doFoldToList fromRow_ stmt = - fmap reverse $ doFold fromRow_ stmt [] (\acc e -> return (e : acc)) - --- | 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. --- --- * 'ResultError': result conversion failed. -query :: (ToRow q, FromRow r) - => Connection -> Query -> q -> IO [r] -query = queryWith fromRow - --- | A version of 'query' that does not perform query substitution. -query_ :: (FromRow r) => Connection -> Query -> IO [r] -query_ = queryWith_ fromRow - --- | A version of 'query' that takes an explicit 'RowParser'. -queryWith :: (ToRow q) => RowParser r -> Connection -> Query -> q -> IO [r] -queryWith fromRow_ conn templ qs = - withStatementParams conn templ qs $ \stmt -> doFoldToList fromRow_ stmt - --- | A version of 'query' that does not perform query substitution and --- takes an explicit 'RowParser'. -queryWith_ :: RowParser r -> Connection -> Query -> IO [r] -queryWith_ fromRow_ conn query = - withStatement conn query (doFoldToList fromRow_) - --- | A version of 'query' where the query parameters (placeholders) --- are named. --- --- Example: --- --- @ --- r \<- 'queryNamed' c \"SELECT * FROM posts WHERE id=:id AND date>=:date\" [\":id\" ':=' postId, \":date\" ':=' afterDate] --- @ -queryNamed :: (FromRow r) => Connection -> Query -> [NamedParam] -> IO [r] -queryNamed conn templ params = - withStatementNamedParams conn templ params $ \stmt -> doFoldToList fromRow stmt - --- | A version of 'execute' that does not perform query substitution. -execute_ :: Connection -> Query -> IO () -execute_ conn template = - withStatement conn template $ \(Statement stmt) -> - void $ Base.step stmt - --- | A version of 'execute' where the query parameters (placeholders) --- are named. -executeNamed :: Connection -> Query -> [NamedParam] -> IO () -executeNamed conn template params = - withStatementNamedParams conn template params $ \(Statement stmt) -> - void $ Base.step stmt - --- | Perform a @SELECT@ or other SQL query that is expected to return results. --- Results are converted and fed into the 'action' callback as they are being --- retrieved from the database. --- --- This allows gives the possibility of processing results in constant space --- (for instance writing them to disk). --- --- Exceptions that may be thrown: --- --- * 'FormatError': the query string mismatched with given arguments. --- --- * 'ResultError': result conversion failed. -fold :: ( FromRow row, ToRow params ) - => Connection - -> Query - -> params - -> a - -> (a -> row -> IO a) - -> IO a -fold conn query params initalState action = - withStatementParams conn query params $ \stmt -> - doFold fromRow stmt initalState action - --- | A version of 'fold' which does not perform parameter substitution. -fold_ :: ( FromRow row ) - => Connection - -> Query - -> a - -> (a -> row -> IO a) - -> IO a -fold_ conn query initalState action = - withStatement conn query $ \stmt -> - doFold fromRow stmt initalState action - --- | A version of 'fold' where the query parameters (placeholders) are --- named. -foldNamed :: ( FromRow row ) - => Connection - -> Query - -> [NamedParam] - -> a - -> (a -> row -> IO a) - -> IO a -foldNamed conn query params initalState action = - withStatementNamedParams conn query params $ \stmt -> - doFold fromRow stmt initalState action - -doFold :: RowParser row -> Statement -> a -> (a -> row -> IO a) -> IO a -doFold fromRow_ stmt initState action = - loop initState - where - loop val = do - maybeNextRow <- nextRowWith fromRow_ stmt - case maybeNextRow of - Just row -> do - val' <- action val row - val' `seq` loop val' - Nothing -> return val - --- | Extracts the next row from the prepared statement. -nextRow :: (FromRow r) => Statement -> IO (Maybe r) -nextRow = nextRowWith fromRow - -nextRowWith :: RowParser r -> Statement -> IO (Maybe r) -nextRowWith fromRow_ (Statement stmt) = do - statRes <- Base.step stmt - case statRes of - Base.Row -> do - rowRes <- Base.columns stmt - let nCols = length rowRes - row <- convertRow fromRow_ rowRes nCols - return $ Just row - Base.Done -> return Nothing - -convertRow :: RowParser r -> [Base.SQLData] -> Int -> IO r -convertRow fromRow_ rowRes ncols = do - let rw = RowParseRO ncols - case runStateT (runReaderT (unRP fromRow_) rw) (0, rowRes) of - Ok (val,(col,_)) - | col == ncols -> return val - | otherwise -> errorColumnMismatch (ColumnOutOfBounds col) - Errors [] -> throwIO $ ConversionFailed "" "" "unknown error" - Errors [x] -> - throw x `Control.Exception.catch` (\e -> errorColumnMismatch (e :: ColumnOutOfBounds)) - Errors xs -> throwIO $ ManyErrors xs - where - errorColumnMismatch :: ColumnOutOfBounds -> IO r - errorColumnMismatch (ColumnOutOfBounds c) = do - let vals = map (\f -> (gettypename f, ellipsis f)) rowRes - throwIO (ConversionFailed - (show ncols ++ " values: " ++ show vals) - ("at least " ++ show c ++ " slots in target type") - "mismatch between number of columns to convert and number in target type") - - ellipsis :: Base.SQLData -> T.Text - ellipsis sql - | T.length bs > 20 = T.take 15 bs `T.append` "[...]" - | otherwise = bs - where - bs = T.pack $ show sql - - --- | Returns the rowid of the most recent successful INSERT on the --- given database connection. --- --- See also . -lastInsertRowId :: Connection -> IO Int64 -lastInsertRowId (Connection c) = BaseD.lastInsertRowId c - --- | --- --- Return the number of rows that were changed, inserted, or deleted --- by the most recent @INSERT@, @DELETE@, or @UPDATE@ statement. -changes :: Connection -> IO Int -changes (Connection c) = BaseD.changes c - --- | --- --- Return the total number of row changes caused by @INSERT@, @DELETE@, --- or @UPDATE@ statements since the 'Database' was opened. -totalChanges :: Connection -> IO Int -totalChanges (Connection c) = BaseD.totalChanges c - --- | Run an IO action inside a SQL transaction started with @BEGIN --- TRANSACTION@. If the action throws any kind of an exception, the --- transaction will be rolled back with @ROLLBACK TRANSACTION@. --- Otherwise the results are committed with @COMMIT TRANSACTION@. -withTransaction :: Connection -> IO a -> IO a -withTransaction conn action = - mask $ \restore -> do - begin - r <- restore action `onException` rollback - commit - return r - where - begin = execute_ conn "BEGIN TRANSACTION" - commit = execute_ conn "COMMIT TRANSACTION" - rollback = execute_ conn "ROLLBACK TRANSACTION" - -fmtError :: Show v => String -> Query -> [v] -> a -fmtError msg q xs = - throw FormatError { - fmtMessage = msg - , fmtQuery = q - , fmtParams = map show xs - } - -getQuery :: Base.Statement -> IO Query -getQuery stmt = - toQuery <$> BaseD.statementSql stmt - where - toQuery = - Query . maybe "no query string" (\(BaseD.Utf8 s) -> TE.decodeUtf8 s) - --- $use --- An example that creates a table 'test', inserts a couple of rows --- and proceeds to showcase how to update or delete rows. This --- example also demonstrates the use of 'lastInsertRowId' (how to --- refer to a previously inserted row) and 'executeNamed' (an easier --- to maintain form of query parameter naming). --- --- >{-# LANGUAGE OverloadedStrings #-} --- > --- >import Control.Applicative --- >import qualified Data.Text as T --- >import Database.SQLite.Simple --- >import Database.SQLite.Simple.FromRow --- > --- >data TestField = TestField Int T.Text deriving (Show) --- > --- >instance FromRow TestField where --- > fromRow = TestField <$> field <*> field --- > --- >instance ToRow TestField where --- > toRow (TestField id_ str) = toRow (id_, str) --- > --- >main :: IO () --- >main = do --- > conn <- open "test.db" --- > execute_ conn "CREATE TABLE IF NOT EXISTS test (id INTEGER PRIMARY KEY, str TEXT)" --- > execute conn "INSERT INTO test (str) VALUES (?)" (Only ("test string 2" :: String)) --- > execute conn "INSERT INTO test (id, str) VALUES (?,?)" (TestField 13 "test string 3") --- > rowId <- lastInsertRowId conn --- > executeNamed conn "UPDATE test SET str = :str WHERE id = :id" [":str" := ("updated str" :: T.Text), ":id" := rowId] --- > r <- query_ conn "SELECT * from test" :: IO [TestField] --- > mapM_ print r --- > execute conn "DELETE FROM test WHERE id = ?" (Only rowId) --- > close conn - --- $querytype --- --- SQL-based applications are somewhat notorious for their --- susceptibility to attacks through the injection of maliciously --- crafted data. The primary reason for widespread vulnerability to --- SQL injections is that many applications are sloppy in handling --- user data when constructing SQL queries. --- --- This library provides a 'Query' type and a parameter substitution --- facility to address both ease of use and security. A 'Query' is a --- @newtype@-wrapped 'Text'. It intentionally exposes a tiny API that --- is not compatible with the 'Text' API; this makes it difficult to --- construct queries from fragments of strings. The 'query' and --- 'execute' functions require queries to be of type 'Query'. --- --- To most easily construct a query, enable GHC's @OverloadedStrings@ --- language extension and write your query as a normal literal string. --- --- > {-# LANGUAGE OverloadedStrings #-} --- > --- > import Database.SQLite.Simple --- > --- > hello = do --- > conn <- open "test.db" --- > [[x]] <- query_ conn "select 2 + 2" --- > print x --- --- A 'Query' value does not represent the actual query that will be --- executed, but is a template for constructing the final query. - --- $subst --- --- Since applications need to be able to construct queries with --- parameters that change, this library uses SQLite's parameter --- binding query substitution capability. --- --- This library restricts parameter substitution to work only with --- named parameters and positional arguments with the \"@?@\" syntax. --- The API does not support for mixing these two types of bindings. --- Unsupported parameters will be rejected and a 'FormatError' will be --- thrown. --- --- You should always use parameter substitution instead of inlining --- your dynamic parameters into your queries with messy string --- concatenation. SQLite will automatically quote and escape your --- data into these placeholder parameters; this defeats the single --- most common injection vector for malicious data. - --- $substpos --- --- The 'Query' template accepted by 'query', 'execute' and 'fold' can --- contain any number of \"@?@\" characters. Both 'query' and --- 'execute' accept a third argument, typically a tuple. When the --- query executes, the first \"@?@\" in the template will be replaced --- with the first element of the tuple, the second \"@?@\" with the --- second element, and so on. This substitution happens inside the --- native SQLite implementation. --- --- For example, given the following 'Query' template: --- --- > select * from user where first_name = ? and age > ? --- --- And a tuple of this form: --- --- > ("Boris" :: String, 37 :: Int) --- --- The query to be executed will look like this after substitution: --- --- > select * from user where first_name = 'Boris' and age > 37 --- --- If there is a mismatch between the number of \"@?@\" characters in --- your template and the number of elements in your tuple, a --- 'FormatError' will be thrown. --- --- Note that the substitution functions do not attempt to parse or --- validate your query. It's up to you to write syntactically valid --- SQL, and to ensure that each \"@?@\" in your query template is --- matched with the right tuple element. - --- $substnamed --- --- Named parameters are accepted by 'queryNamed', 'executeNamed' and --- 'foldNamed'. These functions take a list of 'NamedParam's which --- are key-value pairs binding a value to an argument name. As is the --- case with \"@?@\" parameters, named parameters are automatically --- escaped by the SQLite library. The parameter names are prefixed --- with either @:@ or @\@@, e.g. @:foo@ or @\@foo@. --- --- Example: --- --- @ --- r \<- 'queryNamed' c \"SELECT id,text FROM posts WHERE id = :id AND date >= :date\" [\":id\" ':=' postId, \":date\" ':=' afterDate] --- @ --- --- Note that you can mix different value types in the same list. --- E.g., the following is perfectly legal: --- --- @ --- [\":id\" ':=' (3 :: Int), \":str\" ':=' (\"foo\" :: String)] --- @ --- --- The parameter name (or key) in the 'NamedParam' must match exactly --- the name written in the SQL query. E.g., if you used @:foo@ in --- your SQL statement, you need to use @\":foo\"@ as the parameter --- key, not @\"foo\"@. Some libraries like Python's sqlite3 --- automatically drop the @:@ character from the name. - --- $inference --- --- Automated type inference means that you will often be able to avoid --- supplying explicit type signatures for the elements of a tuple. --- However, sometimes the compiler will not be able to infer your --- types. Consider a case where you write a numeric literal in a --- parameter tuple: --- --- > query conn "select ? + ?" (40,2) --- --- The above query will be rejected by the compiler, because it does --- not know the specific numeric types of the literals @40@ and @2@. --- This is easily fixed: --- --- > query conn "select ? + ?" (40 :: Double, 2 :: Double) --- --- The same kind of problem can arise with string literals if you have --- the @OverloadedStrings@ language extension enabled. Again, just --- use an explicit type signature if this happens. - --- $only_param --- --- Haskell lacks a single-element tuple type, so if you have just one --- value you want substituted into a query, what should you do? --- --- To represent a single value @val@ as a parameter, write a singleton --- list @[val]@, use 'Just' @val@, or use 'Only' @val@. --- --- Here's an example using a singleton list: --- --- > execute conn "insert into users (first_name) values (?)" --- > ["Nuala"] --- --- Or you can use named parameters which do not have this restriction. - --- $result --- --- The 'query' and 'query_' functions return a list of values in the --- 'FromRow' typeclass. This class performs automatic extraction --- and type conversion of rows from a query result. --- --- Here is a simple example of how to extract results: --- --- > import qualified Data.Text as T --- > --- > xs <- query_ conn "select name,age from users" --- > forM_ xs $ \(name,age) -> --- > putStrLn $ T.unpack name ++ " is " ++ show (age :: Int) --- --- Notice two important details about this code: --- --- * The number of columns we ask for in the query template must --- exactly match the number of elements we specify in a row of the --- result tuple. If they do not match, a 'ResultError' exception --- will be thrown. --- --- * Sometimes, the compiler needs our help in specifying types. It --- can infer that @name@ must be a 'Text', due to our use of the --- @unpack@ function. However, we have to tell it the type of @age@, --- as it has no other information to determine the exact type. - --- $null --- --- The type of a result tuple will look something like this: --- --- > (Text, Int, Int) --- --- Although SQL can accommodate @NULL@ as a value for any of these --- types, Haskell cannot. If your result contains columns that may be --- @NULL@, be sure that you use 'Maybe' in those positions of of your --- tuple. --- --- > (Text, Maybe Int, Int) --- --- If 'query' encounters a @NULL@ in a row where the corresponding --- Haskell type is not 'Maybe', it will throw a 'ResultError' --- exception. - --- $only_result --- --- To specify that a query returns a single-column result, use the --- 'Only' type. --- --- > xs <- query_ conn "select id from users" --- > forM_ xs $ \(Only dbid) -> {- ... -} - --- $types --- --- Conversion of SQL values to Haskell values is somewhat --- permissive. Here are the rules. --- --- * For numeric types, any Haskell type that can accurately represent --- an SQLite INTEGER is considered \"compatible\". --- --- * If a numeric incompatibility is found, 'query' will throw a --- 'ResultError'. --- --- * SQLite's TEXT type is always encoded in UTF-8. Thus any text --- data coming from an SQLite database should always be compatible --- with Haskell 'String' and 'Text' types. --- --- * SQLite's BLOB type will only be conversible to a Haskell --- 'ByteString'. --- --- You can extend conversion support to your own types be adding your --- own 'FromField' / 'ToField' instances. - --- $utctime --- --- SQLite's datetime allows for multiple string representations of UTC --- time. The following formats are supported for reading SQLite times --- into Haskell UTCTime values: --- --- * YYYY-MM-DD HH:MM --- --- * YYYY-MM-DD HH:MM:SS --- --- * YYYY-MM-DD HH:MM:SS.SSS --- --- * YYYY-MM-DDTHH:MM --- --- * YYYY-MM-DDTHH:MM:SS --- --- * YYYY-MM-DDTHH:MM:SS.SSS --- --- The above may also be optionally followed by a timezone indicator --- of the form \"[+-]HH:MM\" or just \"Z\". --- --- When Haskell UTCTime values are converted into SQLite values (e.g., --- parameters for a 'query'), the following format is used: --- --- * YYYY-MM-DD HH:MM:SS.SSS --- --- The last \".SSS\" subsecond part is dropped if it's zero. No --- timezone indicator is used when converting from a UTCTime value --- into an SQLite string. SQLite assumes all datetimes are in UTC --- time. --- --- The parser and printers are implemented in . --- --- Read more about SQLite's time strings in +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables, GADTs #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Database.SQLite.Simple +-- Copyright: (c) 2011 MailRank, Inc. +-- (c) 2011-2012 Leon P Smith +-- (c) 2012-2013 Janne Hellsten +-- License: BSD3 +-- Maintainer: Janne Hellsten +-- Portability: portable +-- +------------------------------------------------------------------------------ + +module Database.SQLite.Simple ( + -- ** Examples of use + -- $use + + -- ** The Query type + -- $querytype + + -- ** Parameter substitution + -- $subst + + -- *** Positional parameters + -- $substpos + + -- *** Named parameters + -- $substnamed + + -- *** Type inference + -- $inference + + -- ** Substituting a single parameter + -- $only_param + + -- * Extracting results + -- $result + + -- ** Handling null values + -- $null + + -- ** Type conversions + -- $types + + -- *** Conversion to/from UTCTime + -- $utctime + + Query(..) + , Connection(..) + , ToRow(..) + , FromRow(..) + , Only(..) + , (:.)(..) + , Base.SQLData(..) + , Statement + , ColumnIndex(..) + , NamedParam(..) + -- * Connections + , open + , close + , withConnection + , setTrace + -- * Queries that return results + , query + , query_ + , queryWith + , queryWith_ + , queryNamed + , lastInsertRowId + , changes + , totalChanges + -- * Queries that stream results + , fold + , fold_ + , foldNamed + -- * Statements that do not return results + , execute + , execute_ + , executeMany + , executeNamed + , field + -- * Transactions + , withTransaction + -- * Low-level statement API for stream access and prepared statements + , openStatement + , closeStatement + , withStatement + , bind + , bindNamed + , reset + , columnName + , withBind + , nextRow + -- ** Exceptions + , FormatError(..) + , ResultError(..) + , Base.SQLError(..) + , Base.Error(..) + ) where + +import Control.Applicative +import Control.Exception +import Control.Monad (void, when, forM_) +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict +import Data.Int (Int64) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Typeable (Typeable) +import Database.SQLite.Simple.Types +import qualified Database.SQLite3 as Base +import qualified Database.SQLite3.Direct as BaseD + + +import Database.SQLite.Simple.FromField (ResultError(..)) +import Database.SQLite.Simple.FromRow +import Database.SQLite.Simple.Internal +import Database.SQLite.Simple.Ok +import Database.SQLite.Simple.ToField (ToField(..)) +import Database.SQLite.Simple.ToRow (ToRow(..)) + +-- | An SQLite prepared statement. +newtype Statement = Statement Base.Statement + +-- | Index of a column in a result set. Column indices start from 0. +newtype ColumnIndex = ColumnIndex BaseD.ColumnIndex + deriving (Eq, Ord, Enum, Num, Real, Integral) + +data NamedParam where + (:=) :: (ToField v) => T.Text -> v -> NamedParam + +infixr 3 := + +instance Show NamedParam where + show (k := v) = show (k, toField v) + +-- | 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 :: [String] + } 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 (T.pack fname) + +-- | Close a database connection. +close :: Connection -> IO () +close (Connection c) = Base.close c + +-- | Opens a database connection, executes an action using this connection, and +-- closes the connection, even in the presence of exceptions. +withConnection :: String -> (Connection -> IO a) -> IO a +withConnection connString = bracket (open connString) close + +unUtf8 :: BaseD.Utf8 -> T.Text +unUtf8 (BaseD.Utf8 bs) = TE.decodeUtf8 bs + +-- | +-- +-- Enable/disable tracing of SQL execution. Tracing can be disabled +-- by setting 'Nothing' as the logger callback. +-- +-- Warning: If the logger callback throws an exception, your whole +-- program may crash. Enable only for debugging! +setTrace :: Connection -> Maybe (T.Text -> IO ()) -> IO () +setTrace (Connection db) logger = + BaseD.setTrace db (fmap (\lf -> lf . unUtf8) logger) + +-- | Binds parameters to a prepared statement. Once 'nextRow' returns 'Nothing', +-- the statement must be reset with the 'reset' function before it can be +-- executed again by calling 'nextRow'. +bind :: (ToRow params) => Statement -> params -> IO () +bind (Statement stmt) params = do + let qp = toRow params + stmtParamCount <- Base.bindParameterCount stmt + when (length qp /= fromIntegral stmtParamCount) (throwColumnMismatch qp stmtParamCount) + mapM_ (errorCheckParamName qp) [1..stmtParamCount] + Base.bind stmt qp + where + throwColumnMismatch qp nParams = do + templ <- getQuery stmt + fmtError ("SQL query contains " ++ show nParams ++ " params, but " ++ + show (length qp) ++ " arguments given") templ qp + errorCheckParamName qp paramNdx = do + templ <- getQuery stmt + name <- Base.bindParameterName stmt paramNdx + case name of + Just n -> + fmtError ("Only unnamed '?' query parameters are accepted, '"++T.unpack n++"' given") + templ qp + Nothing -> return $! () + +-- | Binds named parameters to a prepared statement. +bindNamed :: Statement -> [NamedParam] -> IO () +bindNamed (Statement stmt) params = do + stmtParamCount <- Base.bindParameterCount stmt + when (length params /= fromIntegral stmtParamCount) $ throwColumnMismatch stmtParamCount + bind stmt params + where + bind stmt params = + mapM_ (\(n := v) -> do + idx <- BaseD.bindParameterIndex stmt (BaseD.Utf8 . TE.encodeUtf8 $ n) + case idx of + Just i -> + Base.bindSQLData stmt i (toField v) + Nothing -> do + templ <- getQuery stmt + fmtError ("Unknown named parameter '" ++ T.unpack n ++ "'") + templ params) + params + + throwColumnMismatch nParams = do + templ <- getQuery stmt + fmtError ("SQL query contains " ++ show nParams ++ " params, but " ++ + show (length params) ++ " arguments given") templ params + +-- | Resets a statement. This does not reset bound parameters, if any, but +-- allows the statement to be reexecuted again by invoking 'nextRow'. +reset :: Statement -> IO () +reset (Statement stmt) = Base.reset stmt + +-- | Return the name of a a particular column in the result set of a +-- 'Statement'. Throws an 'ArrayException' if the colum index is out +-- of bounds. +-- +-- +columnName :: Statement -> ColumnIndex -> IO T.Text +columnName (Statement stmt) (ColumnIndex n) = BaseD.columnName stmt n >>= takeUtf8 + where + takeUtf8 (Just s) = return $ unUtf8 s + takeUtf8 Nothing = + throwIO (IndexOutOfBounds ("Column index " ++ show n ++ " out of bounds")) + +-- | Binds parameters to a prepared statement, and 'reset's the statement when +-- the callback completes, even in the presence of exceptions. +-- +-- Use 'withBind' to reuse prepared statements. Because it 'reset's the +-- statement /after/ each usage, it avoids a pitfall involving implicit +-- transactions. SQLite creates an implicit transaction if you don't say +-- @BEGIN@ explicitly, and does not commit it until all active statements are +-- finished with either 'reset' or 'closeStatement'. +withBind :: (ToRow params) => Statement -> params -> IO a -> IO a +withBind stmt params io = do + bind stmt params + io `finally` reset stmt + +-- | Opens a prepared statement. A prepared statement must always be closed with +-- a corresponding call to 'closeStatement' before closing the connection. Use +-- 'nextRow' to iterate on the values returned. Once 'nextRow' returns +-- 'Nothing', you need to invoke 'reset' before reexecuting the statement again +-- with 'nextRow'. +openStatement :: Connection -> Query -> IO Statement +openStatement (Connection c) (Query t) = do + stmt <- Base.prepare c t + return $ Statement stmt + +-- | Closes a prepared statement. +closeStatement :: Statement -> IO () +closeStatement (Statement stmt) = Base.finalize stmt + +-- | Opens a prepared statement, executes an action using this statement, and +-- closes the statement, even in the presence of exceptions. +withStatement :: Connection -> Query -> (Statement -> IO a) -> IO a +withStatement conn query = bracket (openStatement conn query) closeStatement + +-- A version of 'withStatement' which binds parameters. +withStatementParams :: (ToRow params) + => Connection + -> Query + -> params + -> (Statement -> IO a) + -> IO a +withStatementParams conn template params action = + withStatement conn template $ \stmt -> + -- Don't use withBind here, there is no need to reset the parameters since + -- we're destroying the statement + bind stmt (toRow params) >> action stmt + +-- A version of 'withStatement' which binds named parameters. +withStatementNamedParams :: Connection + -> Query + -> [NamedParam] + -> (Statement -> IO a) + -> IO a +withStatementNamedParams conn template namedParams action = + withStatement conn template $ \stmt -> bindNamed stmt namedParams >> action stmt + +-- | 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 conn template qs = + withStatementParams conn template qs $ \(Statement stmt) -> + void . Base.step $ stmt + +-- | Execute a multi-row @INSERT@, @UPDATE@, or other SQL query that is not +-- expected to return results. +-- +-- Throws 'FormatError' if the query could not be formatted correctly. +executeMany :: ToRow q => Connection -> Query -> [q] -> IO () +executeMany conn template paramRows = withStatement conn template $ \stmt -> do + let Statement stmt' = stmt + forM_ paramRows $ \params -> + withBind stmt params + (void . Base.step $ stmt') + + +doFoldToList :: RowParser row -> Statement -> IO [row] +doFoldToList fromRow_ stmt = + fmap reverse $ doFold fromRow_ stmt [] (\acc e -> return (e : acc)) + +-- | 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. +-- +-- * 'ResultError': result conversion failed. +query :: (ToRow q, FromRow r) + => Connection -> Query -> q -> IO [r] +query = queryWith fromRow + +-- | A version of 'query' that does not perform query substitution. +query_ :: (FromRow r) => Connection -> Query -> IO [r] +query_ = queryWith_ fromRow + +-- | A version of 'query' that takes an explicit 'RowParser'. +queryWith :: (ToRow q) => RowParser r -> Connection -> Query -> q -> IO [r] +queryWith fromRow_ conn templ qs = + withStatementParams conn templ qs $ \stmt -> doFoldToList fromRow_ stmt + +-- | A version of 'query' that does not perform query substitution and +-- takes an explicit 'RowParser'. +queryWith_ :: RowParser r -> Connection -> Query -> IO [r] +queryWith_ fromRow_ conn query = + withStatement conn query (doFoldToList fromRow_) + +-- | A version of 'query' where the query parameters (placeholders) +-- are named. +-- +-- Example: +-- +-- @ +-- r \<- 'queryNamed' c \"SELECT * FROM posts WHERE id=:id AND date>=:date\" [\":id\" ':=' postId, \":date\" ':=' afterDate] +-- @ +queryNamed :: (FromRow r) => Connection -> Query -> [NamedParam] -> IO [r] +queryNamed conn templ params = + withStatementNamedParams conn templ params $ \stmt -> doFoldToList fromRow stmt + +-- | A version of 'execute' that does not perform query substitution. +execute_ :: Connection -> Query -> IO () +execute_ conn template = + withStatement conn template $ \(Statement stmt) -> + void $ Base.step stmt + +-- | A version of 'execute' where the query parameters (placeholders) +-- are named. +executeNamed :: Connection -> Query -> [NamedParam] -> IO () +executeNamed conn template params = + withStatementNamedParams conn template params $ \(Statement stmt) -> + void $ Base.step stmt + +-- | Perform a @SELECT@ or other SQL query that is expected to return results. +-- Results are converted and fed into the 'action' callback as they are being +-- retrieved from the database. +-- +-- This allows gives the possibility of processing results in constant space +-- (for instance writing them to disk). +-- +-- Exceptions that may be thrown: +-- +-- * 'FormatError': the query string mismatched with given arguments. +-- +-- * 'ResultError': result conversion failed. +fold :: ( FromRow row, ToRow params ) + => Connection + -> Query + -> params + -> a + -> (a -> row -> IO a) + -> IO a +fold conn query params initalState action = + withStatementParams conn query params $ \stmt -> + doFold fromRow stmt initalState action + +-- | A version of 'fold' which does not perform parameter substitution. +fold_ :: ( FromRow row ) + => Connection + -> Query + -> a + -> (a -> row -> IO a) + -> IO a +fold_ conn query initalState action = + withStatement conn query $ \stmt -> + doFold fromRow stmt initalState action + +-- | A version of 'fold' where the query parameters (placeholders) are +-- named. +foldNamed :: ( FromRow row ) + => Connection + -> Query + -> [NamedParam] + -> a + -> (a -> row -> IO a) + -> IO a +foldNamed conn query params initalState action = + withStatementNamedParams conn query params $ \stmt -> + doFold fromRow stmt initalState action + +doFold :: RowParser row -> Statement -> a -> (a -> row -> IO a) -> IO a +doFold fromRow_ stmt initState action = + loop initState + where + loop val = do + maybeNextRow <- nextRowWith fromRow_ stmt + case maybeNextRow of + Just row -> do + val' <- action val row + val' `seq` loop val' + Nothing -> return val + +-- | Extracts the next row from the prepared statement. +nextRow :: (FromRow r) => Statement -> IO (Maybe r) +nextRow = nextRowWith fromRow + +nextRowWith :: RowParser r -> Statement -> IO (Maybe r) +nextRowWith fromRow_ (Statement stmt) = do + statRes <- Base.step stmt + case statRes of + Base.Row -> do + rowRes <- Base.columns stmt + let nCols = length rowRes + row <- convertRow fromRow_ rowRes nCols + return $ Just row + Base.Done -> return Nothing + +convertRow :: RowParser r -> [Base.SQLData] -> Int -> IO r +convertRow fromRow_ rowRes ncols = do + let rw = RowParseRO ncols + case runStateT (runReaderT (unRP fromRow_) rw) (0, rowRes) of + Ok (val,(col,_)) + | col == ncols -> return val + | otherwise -> errorColumnMismatch (ColumnOutOfBounds col) + Errors [] -> throwIO $ ConversionFailed "" "" "unknown error" + Errors [x] -> + throw x `Control.Exception.catch` (\e -> errorColumnMismatch (e :: ColumnOutOfBounds)) + Errors xs -> throwIO $ ManyErrors xs + where + errorColumnMismatch :: ColumnOutOfBounds -> IO r + errorColumnMismatch (ColumnOutOfBounds c) = do + let vals = map (\f -> (gettypename f, ellipsis f)) rowRes + throwIO (ConversionFailed + (show ncols ++ " values: " ++ show vals) + ("at least " ++ show c ++ " slots in target type") + "mismatch between number of columns to convert and number in target type") + + ellipsis :: Base.SQLData -> T.Text + ellipsis sql + | T.length bs > 20 = T.take 15 bs `T.append` "[...]" + | otherwise = bs + where + bs = T.pack $ show sql + + +-- | Returns the rowid of the most recent successful INSERT on the +-- given database connection. +-- +-- See also . +lastInsertRowId :: Connection -> IO Int64 +lastInsertRowId (Connection c) = BaseD.lastInsertRowId c + +-- | +-- +-- Return the number of rows that were changed, inserted, or deleted +-- by the most recent @INSERT@, @DELETE@, or @UPDATE@ statement. +changes :: Connection -> IO Int +changes (Connection c) = BaseD.changes c + +-- | +-- +-- Return the total number of row changes caused by @INSERT@, @DELETE@, +-- or @UPDATE@ statements since the 'Database' was opened. +totalChanges :: Connection -> IO Int +totalChanges (Connection c) = BaseD.totalChanges c + +-- | Run an IO action inside a SQL transaction started with @BEGIN +-- TRANSACTION@. If the action throws any kind of an exception, the +-- transaction will be rolled back with @ROLLBACK TRANSACTION@. +-- Otherwise the results are committed with @COMMIT TRANSACTION@. +withTransaction :: Connection -> IO a -> IO a +withTransaction conn action = + mask $ \restore -> do + begin + r <- restore action `onException` rollback + commit + return r + where + begin = execute_ conn "BEGIN TRANSACTION" + commit = execute_ conn "COMMIT TRANSACTION" + rollback = execute_ conn "ROLLBACK TRANSACTION" + +fmtError :: Show v => String -> Query -> [v] -> a +fmtError msg q xs = + throw FormatError { + fmtMessage = msg + , fmtQuery = q + , fmtParams = map show xs + } + +getQuery :: Base.Statement -> IO Query +getQuery stmt = + toQuery <$> BaseD.statementSql stmt + where + toQuery = + Query . maybe "no query string" (\(BaseD.Utf8 s) -> TE.decodeUtf8 s) + +-- $use +-- An example that creates a table 'test', inserts a couple of rows +-- and proceeds to showcase how to update or delete rows. This +-- example also demonstrates the use of 'lastInsertRowId' (how to +-- refer to a previously inserted row) and 'executeNamed' (an easier +-- to maintain form of query parameter naming). +-- +-- >{-# LANGUAGE OverloadedStrings #-} +-- > +-- >import Control.Applicative +-- >import qualified Data.Text as T +-- >import Database.SQLite.Simple +-- >import Database.SQLite.Simple.FromRow +-- > +-- >data TestField = TestField Int T.Text deriving (Show) +-- > +-- >instance FromRow TestField where +-- > fromRow = TestField <$> field <*> field +-- > +-- >instance ToRow TestField where +-- > toRow (TestField id_ str) = toRow (id_, str) +-- > +-- >main :: IO () +-- >main = do +-- > conn <- open "test.db" +-- > execute_ conn "CREATE TABLE IF NOT EXISTS test (id INTEGER PRIMARY KEY, str TEXT)" +-- > execute conn "INSERT INTO test (str) VALUES (?)" (Only ("test string 2" :: String)) +-- > execute conn "INSERT INTO test (id, str) VALUES (?,?)" (TestField 13 "test string 3") +-- > rowId <- lastInsertRowId conn +-- > executeNamed conn "UPDATE test SET str = :str WHERE id = :id" [":str" := ("updated str" :: T.Text), ":id" := rowId] +-- > r <- query_ conn "SELECT * from test" :: IO [TestField] +-- > mapM_ print r +-- > execute conn "DELETE FROM test WHERE id = ?" (Only rowId) +-- > close conn + +-- $querytype +-- +-- SQL-based applications are somewhat notorious for their +-- susceptibility to attacks through the injection of maliciously +-- crafted data. The primary reason for widespread vulnerability to +-- SQL injections is that many applications are sloppy in handling +-- user data when constructing SQL queries. +-- +-- This library provides a 'Query' type and a parameter substitution +-- facility to address both ease of use and security. A 'Query' is a +-- @newtype@-wrapped 'Text'. It intentionally exposes a tiny API that +-- is not compatible with the 'Text' API; this makes it difficult to +-- construct queries from fragments of strings. The 'query' and +-- 'execute' functions require queries to be of type 'Query'. +-- +-- To most easily construct a query, enable GHC's @OverloadedStrings@ +-- language extension and write your query as a normal literal string. +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Database.SQLite.Simple +-- > +-- > hello = do +-- > conn <- open "test.db" +-- > [[x]] <- query_ conn "select 2 + 2" +-- > print x +-- +-- A 'Query' value does not represent the actual query that will be +-- executed, but is a template for constructing the final query. + +-- $subst +-- +-- Since applications need to be able to construct queries with +-- parameters that change, this library uses SQLite's parameter +-- binding query substitution capability. +-- +-- This library restricts parameter substitution to work only with +-- named parameters and positional arguments with the \"@?@\" syntax. +-- The API does not support for mixing these two types of bindings. +-- Unsupported parameters will be rejected and a 'FormatError' will be +-- thrown. +-- +-- You should always use parameter substitution instead of inlining +-- your dynamic parameters into your queries with messy string +-- concatenation. SQLite will automatically quote and escape your +-- data into these placeholder parameters; this defeats the single +-- most common injection vector for malicious data. + +-- $substpos +-- +-- The 'Query' template accepted by 'query', 'execute' and 'fold' can +-- contain any number of \"@?@\" characters. Both 'query' and +-- 'execute' accept a third argument, typically a tuple. When the +-- query executes, the first \"@?@\" in the template will be replaced +-- with the first element of the tuple, the second \"@?@\" with the +-- second element, and so on. This substitution happens inside the +-- native SQLite implementation. +-- +-- For example, given the following 'Query' template: +-- +-- > select * from user where first_name = ? and age > ? +-- +-- And a tuple of this form: +-- +-- > ("Boris" :: String, 37 :: Int) +-- +-- The query to be executed will look like this after substitution: +-- +-- > select * from user where first_name = 'Boris' and age > 37 +-- +-- If there is a mismatch between the number of \"@?@\" characters in +-- your template and the number of elements in your tuple, a +-- 'FormatError' will be thrown. +-- +-- Note that the substitution functions do not attempt to parse or +-- validate your query. It's up to you to write syntactically valid +-- SQL, and to ensure that each \"@?@\" in your query template is +-- matched with the right tuple element. + +-- $substnamed +-- +-- Named parameters are accepted by 'queryNamed', 'executeNamed' and +-- 'foldNamed'. These functions take a list of 'NamedParam's which +-- are key-value pairs binding a value to an argument name. As is the +-- case with \"@?@\" parameters, named parameters are automatically +-- escaped by the SQLite library. The parameter names are prefixed +-- with either @:@ or @\@@, e.g. @:foo@ or @\@foo@. +-- +-- Example: +-- +-- @ +-- r \<- 'queryNamed' c \"SELECT id,text FROM posts WHERE id = :id AND date >= :date\" [\":id\" ':=' postId, \":date\" ':=' afterDate] +-- @ +-- +-- Note that you can mix different value types in the same list. +-- E.g., the following is perfectly legal: +-- +-- @ +-- [\":id\" ':=' (3 :: Int), \":str\" ':=' (\"foo\" :: String)] +-- @ +-- +-- The parameter name (or key) in the 'NamedParam' must match exactly +-- the name written in the SQL query. E.g., if you used @:foo@ in +-- your SQL statement, you need to use @\":foo\"@ as the parameter +-- key, not @\"foo\"@. Some libraries like Python's sqlite3 +-- automatically drop the @:@ character from the name. + +-- $inference +-- +-- Automated type inference means that you will often be able to avoid +-- supplying explicit type signatures for the elements of a tuple. +-- However, sometimes the compiler will not be able to infer your +-- types. Consider a case where you write a numeric literal in a +-- parameter tuple: +-- +-- > query conn "select ? + ?" (40,2) +-- +-- The above query will be rejected by the compiler, because it does +-- not know the specific numeric types of the literals @40@ and @2@. +-- This is easily fixed: +-- +-- > query conn "select ? + ?" (40 :: Double, 2 :: Double) +-- +-- The same kind of problem can arise with string literals if you have +-- the @OverloadedStrings@ language extension enabled. Again, just +-- use an explicit type signature if this happens. + +-- $only_param +-- +-- Haskell lacks a single-element tuple type, so if you have just one +-- value you want substituted into a query, what should you do? +-- +-- To represent a single value @val@ as a parameter, write a singleton +-- list @[val]@, use 'Just' @val@, or use 'Only' @val@. +-- +-- Here's an example using a singleton list: +-- +-- > execute conn "insert into users (first_name) values (?)" +-- > ["Nuala"] +-- +-- Or you can use named parameters which do not have this restriction. + +-- $result +-- +-- The 'query' and 'query_' functions return a list of values in the +-- 'FromRow' typeclass. This class performs automatic extraction +-- and type conversion of rows from a query result. +-- +-- Here is a simple example of how to extract results: +-- +-- > import qualified Data.Text as T +-- > +-- > xs <- query_ conn "select name,age from users" +-- > forM_ xs $ \(name,age) -> +-- > putStrLn $ T.unpack name ++ " is " ++ show (age :: Int) +-- +-- Notice two important details about this code: +-- +-- * The number of columns we ask for in the query template must +-- exactly match the number of elements we specify in a row of the +-- result tuple. If they do not match, a 'ResultError' exception +-- will be thrown. +-- +-- * Sometimes, the compiler needs our help in specifying types. It +-- can infer that @name@ must be a 'Text', due to our use of the +-- @unpack@ function. However, we have to tell it the type of @age@, +-- as it has no other information to determine the exact type. + +-- $null +-- +-- The type of a result tuple will look something like this: +-- +-- > (Text, Int, Int) +-- +-- Although SQL can accommodate @NULL@ as a value for any of these +-- types, Haskell cannot. If your result contains columns that may be +-- @NULL@, be sure that you use 'Maybe' in those positions of of your +-- tuple. +-- +-- > (Text, Maybe Int, Int) +-- +-- If 'query' encounters a @NULL@ in a row where the corresponding +-- Haskell type is not 'Maybe', it will throw a 'ResultError' +-- exception. + +-- $only_result +-- +-- To specify that a query returns a single-column result, use the +-- 'Only' type. +-- +-- > xs <- query_ conn "select id from users" +-- > forM_ xs $ \(Only dbid) -> {- ... -} + +-- $types +-- +-- Conversion of SQL values to Haskell values is somewhat +-- permissive. Here are the rules. +-- +-- * For numeric types, any Haskell type that can accurately represent +-- an SQLite INTEGER is considered \"compatible\". +-- +-- * If a numeric incompatibility is found, 'query' will throw a +-- 'ResultError'. +-- +-- * SQLite's TEXT type is always encoded in UTF-8. Thus any text +-- data coming from an SQLite database should always be compatible +-- with Haskell 'String' and 'Text' types. +-- +-- * SQLite's BLOB type will only be conversible to a Haskell +-- 'ByteString'. +-- +-- You can extend conversion support to your own types be adding your +-- own 'FromField' / 'ToField' instances. + +-- $utctime +-- +-- SQLite's datetime allows for multiple string representations of UTC +-- time. The following formats are supported for reading SQLite times +-- into Haskell UTCTime values: +-- +-- * YYYY-MM-DD HH:MM +-- +-- * YYYY-MM-DD HH:MM:SS +-- +-- * YYYY-MM-DD HH:MM:SS.SSS +-- +-- * YYYY-MM-DDTHH:MM +-- +-- * YYYY-MM-DDTHH:MM:SS +-- +-- * YYYY-MM-DDTHH:MM:SS.SSS +-- +-- The above may also be optionally followed by a timezone indicator +-- of the form \"[+-]HH:MM\" or just \"Z\". +-- +-- When Haskell UTCTime values are converted into SQLite values (e.g., +-- parameters for a 'query'), the following format is used: +-- +-- * YYYY-MM-DD HH:MM:SS.SSS +-- +-- The last \".SSS\" subsecond part is dropped if it's zero. No +-- timezone indicator is used when converting from a UTCTime value +-- into an SQLite string. SQLite assumes all datetimes are in UTC +-- time. +-- +-- The parser and printers are implemented in . +-- +-- Read more about SQLite's time strings in diff --git a/Database/SQLite/Simple/FromField.hs b/Database/SQLite/Simple/FromField.hs --- a/Database/SQLite/Simple/FromField.hs +++ b/Database/SQLite/Simple/FromField.hs @@ -1,215 +1,215 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} - ------------------------------------------------------------------------------- --- | --- Module: Database.SQLite.Simple.FromField --- Copyright: (c) 2011 MailRank, Inc. --- (c) 2011-2012 Leon P Smith --- (c) 2012-2013 Janne Hellsten --- License: BSD3 --- Maintainer: Janne Hellsten --- 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 - , fieldData - , returnError - ) where - -import Control.Applicative (Applicative, (<$>), pure) -import Control.Exception (SomeException(..), Exception) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy as LB -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Time (UTCTime, Day) -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import Data.Typeable (Typeable, typeOf) -import Data.Word (Word, Word8, Word16, Word32, Word64) -import GHC.Float (double2Float) - -import Database.SQLite3 as Base -import Database.SQLite.Simple.Types -import Database.SQLite.Simple.Internal -import Database.SQLite.Simple.Ok -import Database.SQLite.Simple.Time - --- | Exception thrown if conversion from a SQL value to a Haskell --- value fails. -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 Int8 where - fromField = takeInt - -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 Word8 where - fromField = takeInt - -instance FromField Word16 where - fromField = takeInt - -instance FromField Word32 where - fromField = takeInt - -instance FromField Word64 where - fromField = takeInt - -instance FromField Word where - fromField = takeInt - -instance FromField Double where - fromField (Field (SQLFloat flt) _) = Ok flt - fromField f = returnError ConversionFailed f "expecting an SQLFloat column type" - -instance FromField Float where - fromField (Field (SQLFloat flt) _) = Ok . double2Float $ flt - fromField f = returnError ConversionFailed f "expecting an SQLFloat column type" - -instance FromField Bool where - fromField f@(Field (SQLInteger b) _) - | (b == 0) || (b == 1) = Ok (b /= 0) - | otherwise = returnError ConversionFailed f ("bool must be 0 or 1, got " ++ show b) - - fromField f = returnError ConversionFailed f "expecting an SQLInteger column type" - -instance FromField T.Text where - fromField (Field (SQLText txt) _) = Ok txt - fromField f = returnError ConversionFailed f "need a text" - -instance FromField LT.Text where - fromField (Field (SQLText txt) _) = Ok . LT.fromStrict $ 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" - -instance FromField ByteString where - fromField (Field (SQLBlob blb) _) = Ok blb - fromField f = returnError ConversionFailed f "expecting SQLBlob column type" - -instance FromField LB.ByteString where - fromField (Field (SQLBlob blb) _) = Ok . LB.fromChunks $ [blb] - fromField f = returnError ConversionFailed f "expecting SQLBlob column type" - -instance FromField UTCTime where - fromField f@(Field (SQLText t) _) = - case parseUTCTime t of - Right t -> Ok t - Left e -> returnError ConversionFailed f ("couldn't parse UTCTime field: " ++ e) - - fromField f = returnError ConversionFailed f "expecting SQLText column type" - - -instance FromField Day where - fromField f@(Field (SQLText t) _) = - case parseDay t of - Right t -> Ok t - Left e -> returnError ConversionFailed f ("couldn't parse Day field: " ++ e) - - fromField f = returnError ConversionFailed f "expecting SQLText column type" - -fieldTypename :: Field -> String -fieldTypename = B.unpack . gettypename . result - --- | Return the actual SQL data for a database field. This allows --- user-defined 'FromField' instances to access the SQL data --- associated with a field being parsed. -fieldData :: Field -> SQLData -fieldData = 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))) +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Database.SQLite.Simple.FromField +-- Copyright: (c) 2011 MailRank, Inc. +-- (c) 2011-2012 Leon P Smith +-- (c) 2012-2013 Janne Hellsten +-- License: BSD3 +-- Maintainer: Janne Hellsten +-- 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 + , fieldData + , returnError + ) where + +import Control.Applicative (Applicative, (<$>), pure) +import Control.Exception (SomeException(..), Exception) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as LB +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Time (UTCTime, Day) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Data.Typeable (Typeable, typeOf) +import Data.Word (Word, Word8, Word16, Word32, Word64) +import GHC.Float (double2Float) + +import Database.SQLite3 as Base +import Database.SQLite.Simple.Types +import Database.SQLite.Simple.Internal +import Database.SQLite.Simple.Ok +import Database.SQLite.Simple.Time + +-- | Exception thrown if conversion from a SQL value to a Haskell +-- value fails. +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 Int8 where + fromField = takeInt + +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 Word8 where + fromField = takeInt + +instance FromField Word16 where + fromField = takeInt + +instance FromField Word32 where + fromField = takeInt + +instance FromField Word64 where + fromField = takeInt + +instance FromField Word where + fromField = takeInt + +instance FromField Double where + fromField (Field (SQLFloat flt) _) = Ok flt + fromField f = returnError ConversionFailed f "expecting an SQLFloat column type" + +instance FromField Float where + fromField (Field (SQLFloat flt) _) = Ok . double2Float $ flt + fromField f = returnError ConversionFailed f "expecting an SQLFloat column type" + +instance FromField Bool where + fromField f@(Field (SQLInteger b) _) + | (b == 0) || (b == 1) = Ok (b /= 0) + | otherwise = returnError ConversionFailed f ("bool must be 0 or 1, got " ++ show b) + + fromField f = returnError ConversionFailed f "expecting an SQLInteger column type" + +instance FromField T.Text where + fromField (Field (SQLText txt) _) = Ok txt + fromField f = returnError ConversionFailed f "need a text" + +instance FromField LT.Text where + fromField (Field (SQLText txt) _) = Ok . LT.fromStrict $ 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" + +instance FromField ByteString where + fromField (Field (SQLBlob blb) _) = Ok blb + fromField f = returnError ConversionFailed f "expecting SQLBlob column type" + +instance FromField LB.ByteString where + fromField (Field (SQLBlob blb) _) = Ok . LB.fromChunks $ [blb] + fromField f = returnError ConversionFailed f "expecting SQLBlob column type" + +instance FromField UTCTime where + fromField f@(Field (SQLText t) _) = + case parseUTCTime t of + Right t -> Ok t + Left e -> returnError ConversionFailed f ("couldn't parse UTCTime field: " ++ e) + + fromField f = returnError ConversionFailed f "expecting SQLText column type" + + +instance FromField Day where + fromField f@(Field (SQLText t) _) = + case parseDay t of + Right t -> Ok t + Left e -> returnError ConversionFailed f ("couldn't parse Day field: " ++ e) + + fromField f = returnError ConversionFailed f "expecting SQLText column type" + +fieldTypename :: Field -> String +fieldTypename = B.unpack . gettypename . result + +-- | Return the actual SQL data for a database field. This allows +-- user-defined 'FromField' instances to access the SQL data +-- associated with a field being parsed. +fieldData :: Field -> SQLData +fieldData = 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 --- a/Database/SQLite/Simple/FromRow.hs +++ b/Database/SQLite/Simple/FromRow.hs @@ -1,136 +1,136 @@ -{-# LANGUAGE RecordWildCards #-} - ------------------------------------------------------------------------------- --- | --- Module: Database.SQLite.Simple.FromRow --- Copyright: (c) 2011-2012 Leon P Smith --- (c) 2012-2013 Janne Hellsten --- License: BSD3 --- Maintainer: Janne Hellsten --- 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 Database.SQLite.Simple.FromField -import Database.SQLite.Simple.Internal -import Database.SQLite.Simple.Ok -import Database.SQLite.Simple.Types - --- | 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 - ncols <- asks nColumns - (column, remaining) <- lift get - lift (put (column + 1, tail remaining)) - if column >= ncols - then - lift (lift (Errors [SomeException (ColumnOutOfBounds (column+1))])) - else do - let r = head remaining - field = Field r column - lift (lift (fieldP field)) - -field :: FromField a => RowParser a -field = fieldWith fromField - -numFieldsRemaining :: RowParser Int -numFieldsRemaining = RP $ do - ncols <- asks nColumns - (columnIdx,_) <- lift get - return $! ncols - columnIdx - -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 +{-# LANGUAGE RecordWildCards #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Database.SQLite.Simple.FromRow +-- Copyright: (c) 2011-2012 Leon P Smith +-- (c) 2012-2013 Janne Hellsten +-- License: BSD3 +-- Maintainer: Janne Hellsten +-- 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 Database.SQLite.Simple.FromField +import Database.SQLite.Simple.Internal +import Database.SQLite.Simple.Ok +import Database.SQLite.Simple.Types + +-- | 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 + ncols <- asks nColumns + (column, remaining) <- lift get + lift (put (column + 1, tail remaining)) + if column >= ncols + then + lift (lift (Errors [SomeException (ColumnOutOfBounds (column+1))])) + else do + let r = head remaining + field = Field r column + lift (lift (fieldP field)) + +field :: FromField a => RowParser a +field = fieldWith fromField + +numFieldsRemaining :: RowParser Int +numFieldsRemaining = RP $ do + ncols <- asks nColumns + (columnIdx,_) <- lift get + return $! ncols - columnIdx + +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 --- a/Database/SQLite/Simple/Internal.hs +++ b/Database/SQLite/Simple/Internal.hs @@ -1,70 +1,70 @@ -{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------- --- | --- Module: Database.SQLite.Simple.Internal --- Copyright: (c) 2011-2012 Leon P Smith --- (c) 2012-2013 Janne Hellsten --- License: BSD3 --- Maintainer: Janne Hellsten --- 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.Exception (Exception) -import Control.Monad -import Control.Applicative -import Data.ByteString (ByteString) -import Data.ByteString.Char8() -import Data.Typeable (Typeable) -import Control.Monad.Trans.State.Strict -import Control.Monad.Trans.Reader - -import Database.SQLite.Simple.Ok -import qualified Database.SQLite3 as Base - --- | Connection to an open database. --- --- You can use 'connectionHandle' to gain access to the underlying --- connection. --- This may be useful if you need to access some direct-sqlite --- functionality that's not exposed in the sqlite-simple API. This --- should be a safe thing to do although mixing both APIs is --- discouraged. -newtype Connection = Connection { connectionHandle :: Base.Database } - -data ColumnOutOfBounds = ColumnOutOfBounds { errorColumnIndex :: !Int } - deriving (Eq, Show, Typeable) - -instance Exception ColumnOutOfBounds - --- | A Field represents metadata about a particular field -data Field = Field { - result :: Base.SQLData - , column :: {-# UNPACK #-} !Int - } - --- Named type for holding RowParser read-only state. Just for making --- it easier to make sense out of types in FromRow. -newtype RowParseRO = RowParseRO { nColumns :: Int } - -newtype RowParser a = RP { unRP :: ReaderT RowParseRO (StateT (Int, [Base.SQLData]) Ok) a } - deriving ( Functor, Applicative, Alternative, Monad, MonadPlus ) - -gettypename :: Base.SQLData -> ByteString -gettypename (Base.SQLInteger _) = "INTEGER" -gettypename (Base.SQLFloat _) = "FLOAT" -gettypename (Base.SQLText _) = "TEXT" -gettypename (Base.SQLBlob _) = "BLOB" -gettypename Base.SQLNull = "NULL" - +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +------------------------------------------------------------------------------ +-- | +-- Module: Database.SQLite.Simple.Internal +-- Copyright: (c) 2011-2012 Leon P Smith +-- (c) 2012-2013 Janne Hellsten +-- License: BSD3 +-- Maintainer: Janne Hellsten +-- 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.Exception (Exception) +import Control.Monad +import Control.Applicative +import Data.ByteString (ByteString) +import Data.ByteString.Char8() +import Data.Typeable (Typeable) +import Control.Monad.Trans.State.Strict +import Control.Monad.Trans.Reader + +import Database.SQLite.Simple.Ok +import qualified Database.SQLite3 as Base + +-- | Connection to an open database. +-- +-- You can use 'connectionHandle' to gain access to the underlying +-- connection. +-- This may be useful if you need to access some direct-sqlite +-- functionality that's not exposed in the sqlite-simple API. This +-- should be a safe thing to do although mixing both APIs is +-- discouraged. +newtype Connection = Connection { connectionHandle :: Base.Database } + +data ColumnOutOfBounds = ColumnOutOfBounds { errorColumnIndex :: !Int } + deriving (Eq, Show, Typeable) + +instance Exception ColumnOutOfBounds + +-- | A Field represents metadata about a particular field +data Field = Field { + result :: Base.SQLData + , column :: {-# UNPACK #-} !Int + } + +-- Named type for holding RowParser read-only state. Just for making +-- it easier to make sense out of types in FromRow. +newtype RowParseRO = RowParseRO { nColumns :: Int } + +newtype RowParser a = RP { unRP :: ReaderT RowParseRO (StateT (Int, [Base.SQLData]) Ok) a } + deriving ( Functor, Applicative, Alternative, Monad, MonadPlus ) + +gettypename :: Base.SQLData -> ByteString +gettypename (Base.SQLInteger _) = "INTEGER" +gettypename (Base.SQLFloat _) = "FLOAT" +gettypename (Base.SQLText _) = "TEXT" +gettypename (Base.SQLBlob _) = "BLOB" +gettypename Base.SQLNull = "NULL" + diff --git a/Database/SQLite/Simple/Ok.hs b/Database/SQLite/Simple/Ok.hs --- a/Database/SQLite/Simple/Ok.hs +++ b/Database/SQLite/Simple/Ok.hs @@ -1,82 +1,82 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} - ------------------------------------------------------------------------------- --- | --- Module: Database.SQLite.Simple.Ok --- Copyright: (c) 2012 Leon P Smith --- (c) 2012-2013 Janne Hellsten --- License: BSD3 --- Maintainer: Janne Hellsten --- --- 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 +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Database.SQLite.Simple.Ok +-- Copyright: (c) 2012 Leon P Smith +-- (c) 2012-2013 Janne Hellsten +-- License: BSD3 +-- Maintainer: Janne Hellsten +-- +-- 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/Time.hs b/Database/SQLite/Simple/Time.hs --- a/Database/SQLite/Simple/Time.hs +++ b/Database/SQLite/Simple/Time.hs @@ -1,21 +1,21 @@ ------------------------------------------------------------------------------- --- | --- Module: Database.SQLite.Simple.Time --- Copyright: (c) 2012 Leon P Smith --- (c) 2012-2014 Janne Hellsten --- License: BSD3 --- Maintainer: Janne Hellsten --- --- Conversions to/from Haskell 'UTCTime' and 'Day' types for SQLite3. --- Offers better performance than direct use of time package's --- 'read'/'show' functionality. --- --- The parsers are heavily adapted for the specific variant of ISO 8601 that --- SQLite uses, and the printers attempt to duplicate this syntax. ------------------------------------------------------------------------------- - -module Database.SQLite.Simple.Time ( - module Database.SQLite.Simple.Time.Implementation - ) where - -import Database.SQLite.Simple.Time.Implementation +------------------------------------------------------------------------------ +-- | +-- Module: Database.SQLite.Simple.Time +-- Copyright: (c) 2012 Leon P Smith +-- (c) 2012-2014 Janne Hellsten +-- License: BSD3 +-- Maintainer: Janne Hellsten +-- +-- Conversions to/from Haskell 'UTCTime' and 'Day' types for SQLite3. +-- Offers better performance than direct use of time package's +-- 'read'/'show' functionality. +-- +-- The parsers are heavily adapted for the specific variant of ISO 8601 that +-- SQLite uses, and the printers attempt to duplicate this syntax. +------------------------------------------------------------------------------ + +module Database.SQLite.Simple.Time ( + module Database.SQLite.Simple.Time.Implementation + ) where + +import Database.SQLite.Simple.Time.Implementation diff --git a/Database/SQLite/Simple/Time/Implementation.hs b/Database/SQLite/Simple/Time/Implementation.hs --- a/Database/SQLite/Simple/Time/Implementation.hs +++ b/Database/SQLite/Simple/Time/Implementation.hs @@ -1,200 +1,200 @@ ------------------------------------------------------------------------------- --- | --- Module: Database.SQLite.Simple.Time.Implementation --- Copyright: (c) 2012 Leon P Smith --- (c) 2012-2014 Janne Hellsten --- License: BSD3 --- Maintainer: Janne Hellsten --- --- Adapted from Leon P Smith's code for SQLite. --- --- See for date formats used in SQLite. ------------------------------------------------------------------------------- - -module Database.SQLite.Simple.Time.Implementation ( - parseUTCTime - , parseDay - , utcTimeToBuilder - , dayToBuilder - , timeOfDayToBuilder - , timeZoneToBuilder - ) where -import Blaze.ByteString.Builder (Builder) -import Blaze.ByteString.Builder.Char8 (fromChar) -import Blaze.Text.Int (integral) -import Control.Applicative -import Control.Monad (when) -import qualified Data.Attoparsec.Text as A -import Data.Bits ((.&.)) -import Data.ByteString.Internal (w2c) -import Data.Char (isDigit, ord) -import Data.Fixed (Pico) -import Data.Monoid (Monoid(..)) -import qualified Data.Text as T -import Data.Time hiding (getTimeZone, getZonedTime) -import Prelude hiding (take, (++)) -import Unsafe.Coerce - -(++) :: Monoid a => a -> a -> a -(++) = mappend -infixr 5 ++ - -parseUTCTime :: T.Text -> Either String UTCTime -parseUTCTime = A.parseOnly (getUTCTime <* A.endOfInput) - -parseDay :: T.Text -> Either String Day -parseDay = A.parseOnly (getDay <* A.endOfInput) - -getDay :: A.Parser Day -getDay = do - yearStr <- A.takeWhile isDigit - when (T.length yearStr < 4) (fail "year must consist of at least 4 digits") - - let !year = toNum yearStr - _ <- A.char '-' - month <- digits "month" - _ <- A.char '-' - day <- digits "day" - - case fromGregorianValid year month day of - Nothing -> fail "invalid date" - Just x -> return $! x - -decimal :: Fractional a => T.Text -> a -decimal str = toNum str / 10^(T.length str) -{-# INLINE decimal #-} - -getTimeOfDay :: A.Parser TimeOfDay -getTimeOfDay = do - hour <- digits "hours" - _ <- A.char ':' - minute <- digits "minutes" - -- Allow omission of seconds. If seconds is omitted, don't try to - -- parse the sub-second part. - (sec,subsec) - <- ((,) <$> (A.char ':' *> digits "seconds") <*> fract) <|> pure (0,0) - - let !picos' = sec + subsec - - case makeTimeOfDayValid hour minute picos' of - Nothing -> fail "invalid time of day" - Just x -> return $! x - - where - fract = - (A.char '.' *> (decimal <$> A.takeWhile1 isDigit)) <|> pure 0 - -getTimeZone :: A.Parser TimeZone -getTimeZone = do - sign <- A.satisfy (\c -> c == '+' || c == '-') - hours <- digits "timezone" - mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0 - let !absset = 60 * hours + mins - !offset = if sign == '+' then absset else -absset - return $! minutesToTimeZone offset - -getUTCTime :: A.Parser UTCTime -getUTCTime = do - day <- getDay - _ <- A.char ' ' <|> A.char 'T' - time <- getTimeOfDay - -- SQLite doesn't require a timezone postfix. So make that - -- optional and default to +0. 'Z' means UTC (zulu time). - zone <- getTimeZone <|> (A.char 'Z' *> pure utc) <|> (pure utc) - let (!dayDelta,!time') = localToUTCTimeOfDay zone time - let !day' = addDays dayDelta day - let !time'' = timeOfDayToTime time' - return (UTCTime day' time'') - -toNum :: Num n => T.Text -> n -toNum = T.foldl' (\a c -> 10*a + digit c) 0 -{-# INLINE toNum #-} - -digit :: Num n => Char -> n -digit c = fromIntegral (ord c .&. 0x0f) -{-# INLINE digit #-} - -digits :: Num n => String -> A.Parser n -digits msg = do - x <- A.anyChar - y <- A.anyChar - if isDigit x && isDigit y - then return $! (10 * digit x + digit y) - else fail (msg ++ " is not 2 digits") -{-# INLINE digits #-} - -dayToBuilder :: Day -> Builder -dayToBuilder (toGregorian -> (y,m,d)) = do - pad4 y ++ fromChar '-' ++ pad2 m ++ fromChar '-' ++ pad2 d - -timeOfDayToBuilder :: TimeOfDay -> Builder -timeOfDayToBuilder (TimeOfDay h m s) = do - pad2 h ++ fromChar ':' ++ pad2 m ++ fromChar ':' ++ showSeconds s - -timeZoneToBuilder :: TimeZone -> Builder -timeZoneToBuilder tz - | m == 0 = sign h ++ pad2 (abs h) - | otherwise = sign h ++ pad2 (abs h) ++ fromChar ':' ++ pad2 (abs m) - where - (h,m) = timeZoneMinutes tz `quotRem` 60 - sign h | h >= 0 = fromChar '+' - | otherwise = fromChar '-' - --- | Output YYYY-MM-DD HH:MM:SS with an optional .SSS fraction part. --- Explicit timezone attribute is not appended as per SQLite3's --- datetime conventions. -utcTimeToBuilder :: UTCTime -> Builder -utcTimeToBuilder (UTCTime day time) = - dayToBuilder day ++ fromChar ' ' ++ timeOfDayToBuilder (timeToTimeOfDay time) - -showSeconds :: Pico -> Builder -showSeconds xyz - | yz == 0 = pad2 x - | z == 0 = pad2 x ++ fromChar '.' ++ showD6 y - | otherwise = pad2 x ++ fromChar '.' ++ pad6 y ++ showD6 z - where - -- A kludge to work around the fact that Data.Fixed isn't very fast and - -- doesn't give me access to the MkFixed constructor. - (x_,yz) = (unsafeCoerce xyz :: Integer) `quotRem` 1000000000000 - x = fromIntegral x_ :: Int - (fromIntegral -> y, fromIntegral -> z) = yz `quotRem` 1000000 - -pad6 :: Int -> Builder -pad6 xy = let (x,y) = xy `quotRem` 1000 - in pad3 x ++ pad3 y - -showD6 :: Int -> Builder -showD6 xy = case xy `quotRem` 1000 of - (x,0) -> showD3 x - (x,y) -> pad3 x ++ showD3 y - -pad3 :: Int -> Builder -pad3 abc = let (ab,c) = abc `quotRem` 10 - (a,b) = ab `quotRem` 10 - in p a ++ p b ++ p c - -showD3 :: Int -> Builder -showD3 abc = case abc `quotRem` 100 of - (a, 0) -> p a - (a,bc) -> case bc `quotRem` 10 of - (b,0) -> p a ++ p b - (b,c) -> p a ++ p b ++ p c - --- | p assumes its input is in the range [0..9] -p :: Integral n => n -> Builder -p n = fromChar (w2c (fromIntegral (n + 48))) -{-# INLINE p #-} - --- | pad2 assumes its input is in the range [0..99] -pad2 :: Integral n => n -> Builder -pad2 n = let (a,b) = n `quotRem` 10 in p a ++ p b -{-# INLINE pad2 #-} - --- | pad4 assumes its input is positive -pad4 :: (Integral n, Show n) => n -> Builder -pad4 abcd | abcd >= 10000 = integral abcd - | otherwise = p a ++ p b ++ p c ++ p d - where (ab,cd) = abcd `quotRem` 100 - (a,b) = ab `quotRem` 10 - (c,d) = cd `quotRem` 10 -{-# INLINE pad4 #-} +------------------------------------------------------------------------------ +-- | +-- Module: Database.SQLite.Simple.Time.Implementation +-- Copyright: (c) 2012 Leon P Smith +-- (c) 2012-2014 Janne Hellsten +-- License: BSD3 +-- Maintainer: Janne Hellsten +-- +-- Adapted from Leon P Smith's code for SQLite. +-- +-- See for date formats used in SQLite. +------------------------------------------------------------------------------ + +module Database.SQLite.Simple.Time.Implementation ( + parseUTCTime + , parseDay + , utcTimeToBuilder + , dayToBuilder + , timeOfDayToBuilder + , timeZoneToBuilder + ) where +import Blaze.ByteString.Builder (Builder) +import Blaze.ByteString.Builder.Char8 (fromChar) +import Blaze.Text.Int (integral) +import Control.Applicative +import Control.Monad (when) +import qualified Data.Attoparsec.Text as A +import Data.Bits ((.&.)) +import Data.ByteString.Internal (w2c) +import Data.Char (isDigit, ord) +import Data.Fixed (Pico) +import Data.Monoid (Monoid(..)) +import qualified Data.Text as T +import Data.Time hiding (getTimeZone, getZonedTime) +import Prelude hiding (take, (++)) +import Unsafe.Coerce + +(++) :: Monoid a => a -> a -> a +(++) = mappend +infixr 5 ++ + +parseUTCTime :: T.Text -> Either String UTCTime +parseUTCTime = A.parseOnly (getUTCTime <* A.endOfInput) + +parseDay :: T.Text -> Either String Day +parseDay = A.parseOnly (getDay <* A.endOfInput) + +getDay :: A.Parser Day +getDay = do + yearStr <- A.takeWhile isDigit + when (T.length yearStr < 4) (fail "year must consist of at least 4 digits") + + let !year = toNum yearStr + _ <- A.char '-' + month <- digits "month" + _ <- A.char '-' + day <- digits "day" + + case fromGregorianValid year month day of + Nothing -> fail "invalid date" + Just x -> return $! x + +decimal :: Fractional a => T.Text -> a +decimal str = toNum str / 10^(T.length str) +{-# INLINE decimal #-} + +getTimeOfDay :: A.Parser TimeOfDay +getTimeOfDay = do + hour <- digits "hours" + _ <- A.char ':' + minute <- digits "minutes" + -- Allow omission of seconds. If seconds is omitted, don't try to + -- parse the sub-second part. + (sec,subsec) + <- ((,) <$> (A.char ':' *> digits "seconds") <*> fract) <|> pure (0,0) + + let !picos' = sec + subsec + + case makeTimeOfDayValid hour minute picos' of + Nothing -> fail "invalid time of day" + Just x -> return $! x + + where + fract = + (A.char '.' *> (decimal <$> A.takeWhile1 isDigit)) <|> pure 0 + +getTimeZone :: A.Parser TimeZone +getTimeZone = do + sign <- A.satisfy (\c -> c == '+' || c == '-') + hours <- digits "timezone" + mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0 + let !absset = 60 * hours + mins + !offset = if sign == '+' then absset else -absset + return $! minutesToTimeZone offset + +getUTCTime :: A.Parser UTCTime +getUTCTime = do + day <- getDay + _ <- A.char ' ' <|> A.char 'T' + time <- getTimeOfDay + -- SQLite doesn't require a timezone postfix. So make that + -- optional and default to +0. 'Z' means UTC (zulu time). + zone <- getTimeZone <|> (A.char 'Z' *> pure utc) <|> (pure utc) + let (!dayDelta,!time') = localToUTCTimeOfDay zone time + let !day' = addDays dayDelta day + let !time'' = timeOfDayToTime time' + return (UTCTime day' time'') + +toNum :: Num n => T.Text -> n +toNum = T.foldl' (\a c -> 10*a + digit c) 0 +{-# INLINE toNum #-} + +digit :: Num n => Char -> n +digit c = fromIntegral (ord c .&. 0x0f) +{-# INLINE digit #-} + +digits :: Num n => String -> A.Parser n +digits msg = do + x <- A.anyChar + y <- A.anyChar + if isDigit x && isDigit y + then return $! (10 * digit x + digit y) + else fail (msg ++ " is not 2 digits") +{-# INLINE digits #-} + +dayToBuilder :: Day -> Builder +dayToBuilder (toGregorian -> (y,m,d)) = do + pad4 y ++ fromChar '-' ++ pad2 m ++ fromChar '-' ++ pad2 d + +timeOfDayToBuilder :: TimeOfDay -> Builder +timeOfDayToBuilder (TimeOfDay h m s) = do + pad2 h ++ fromChar ':' ++ pad2 m ++ fromChar ':' ++ showSeconds s + +timeZoneToBuilder :: TimeZone -> Builder +timeZoneToBuilder tz + | m == 0 = sign h ++ pad2 (abs h) + | otherwise = sign h ++ pad2 (abs h) ++ fromChar ':' ++ pad2 (abs m) + where + (h,m) = timeZoneMinutes tz `quotRem` 60 + sign h | h >= 0 = fromChar '+' + | otherwise = fromChar '-' + +-- | Output YYYY-MM-DD HH:MM:SS with an optional .SSS fraction part. +-- Explicit timezone attribute is not appended as per SQLite3's +-- datetime conventions. +utcTimeToBuilder :: UTCTime -> Builder +utcTimeToBuilder (UTCTime day time) = + dayToBuilder day ++ fromChar ' ' ++ timeOfDayToBuilder (timeToTimeOfDay time) + +showSeconds :: Pico -> Builder +showSeconds xyz + | yz == 0 = pad2 x + | z == 0 = pad2 x ++ fromChar '.' ++ showD6 y + | otherwise = pad2 x ++ fromChar '.' ++ pad6 y ++ showD6 z + where + -- A kludge to work around the fact that Data.Fixed isn't very fast and + -- doesn't give me access to the MkFixed constructor. + (x_,yz) = (unsafeCoerce xyz :: Integer) `quotRem` 1000000000000 + x = fromIntegral x_ :: Int + (fromIntegral -> y, fromIntegral -> z) = yz `quotRem` 1000000 + +pad6 :: Int -> Builder +pad6 xy = let (x,y) = xy `quotRem` 1000 + in pad3 x ++ pad3 y + +showD6 :: Int -> Builder +showD6 xy = case xy `quotRem` 1000 of + (x,0) -> showD3 x + (x,y) -> pad3 x ++ showD3 y + +pad3 :: Int -> Builder +pad3 abc = let (ab,c) = abc `quotRem` 10 + (a,b) = ab `quotRem` 10 + in p a ++ p b ++ p c + +showD3 :: Int -> Builder +showD3 abc = case abc `quotRem` 100 of + (a, 0) -> p a + (a,bc) -> case bc `quotRem` 10 of + (b,0) -> p a ++ p b + (b,c) -> p a ++ p b ++ p c + +-- | p assumes its input is in the range [0..9] +p :: Integral n => n -> Builder +p n = fromChar (w2c (fromIntegral (n + 48))) +{-# INLINE p #-} + +-- | pad2 assumes its input is in the range [0..99] +pad2 :: Integral n => n -> Builder +pad2 n = let (a,b) = n `quotRem` 10 in p a ++ p b +{-# INLINE pad2 #-} + +-- | pad4 assumes its input is positive +pad4 :: (Integral n, Show n) => n -> Builder +pad4 abcd | abcd >= 10000 = integral abcd + | otherwise = p a ++ p b ++ p c ++ p d + where (ab,cd) = abcd `quotRem` 100 + (a,b) = ab `quotRem` 10 + (c,d) = cd `quotRem` 10 +{-# INLINE pad4 #-} diff --git a/Database/SQLite/Simple/ToField.hs b/Database/SQLite/Simple/ToField.hs --- a/Database/SQLite/Simple/ToField.hs +++ b/Database/SQLite/Simple/ToField.hs @@ -1,170 +1,170 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} - ------------------------------------------------------------------------------- --- | --- Module: Database.SQLite.Simple.ToField --- Copyright: (c) 2011 MailRank, Inc. --- (c) 2011-2012 Leon P Smith --- (c) 2012-2013 Janne Hellsten --- License: BSD3 --- Maintainer: Janne Hellsten --- 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 Blaze.ByteString.Builder (toByteString) -import qualified Data.ByteString as SB -import qualified Data.ByteString.Lazy as LB -import Data.Int (Int8, Int16, Int32, Int64) -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Encoding as T -import Data.Time (Day, UTCTime) -import Data.Word (Word, Word8, Word16, Word32, Word64) -import GHC.Float - -import Database.SQLite3 as Base -import Database.SQLite.Simple.Types (Null) -import Database.SQLite.Simple.Time - --- | A type that may be used as a single parameter to a SQL query. -class ToField a where - 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 Null where - toField _ = Base.SQLNull - {-# INLINE toField #-} - -instance ToField Bool where - toField False = SQLInteger 0 - toField True = SQLInteger 1 - {-# 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.decodeUtf8 . toByteString . utcTimeToBuilder - {-# INLINE toField #-} - -instance ToField Day where - toField = SQLText . T.decodeUtf8 . toByteString . dayToBuilder - {-# 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 #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Database.SQLite.Simple.ToField +-- Copyright: (c) 2011 MailRank, Inc. +-- (c) 2011-2012 Leon P Smith +-- (c) 2012-2013 Janne Hellsten +-- License: BSD3 +-- Maintainer: Janne Hellsten +-- 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 Blaze.ByteString.Builder (toByteString) +import qualified Data.ByteString as SB +import qualified Data.ByteString.Lazy as LB +import Data.Int (Int8, Int16, Int32, Int64) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Encoding as T +import Data.Time (Day, UTCTime) +import Data.Word (Word, Word8, Word16, Word32, Word64) +import GHC.Float + +import Database.SQLite3 as Base +import Database.SQLite.Simple.Types (Null) +import Database.SQLite.Simple.Time + +-- | A type that may be used as a single parameter to a SQL query. +class ToField a where + 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 Null where + toField _ = Base.SQLNull + {-# INLINE toField #-} + +instance ToField Bool where + toField False = SQLInteger 0 + toField True = SQLInteger 1 + {-# 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.decodeUtf8 . toByteString . utcTimeToBuilder + {-# INLINE toField #-} + +instance ToField Day where + toField = SQLText . T.decodeUtf8 . toByteString . dayToBuilder + {-# 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 --- a/Database/SQLite/Simple/ToRow.hs +++ b/Database/SQLite/Simple/ToRow.hs @@ -1,92 +1,92 @@ ------------------------------------------------------------------------------- --- | --- Module: Database.SQLite.Simple.ToRow --- Copyright: (c) 2011 MailRank, Inc. --- (c) 2011-2012 Leon P Smith --- (c) 2012-2013 Janne Hellsten --- License: BSD3 --- Maintainer: Janne Hellsten --- 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 (ToField a) => ToRow [a] where - toRow = map toField - -instance (ToRow a, ToRow b) => ToRow (a :. b) where - toRow (a :. b) = toRow a ++ toRow b +------------------------------------------------------------------------------ +-- | +-- Module: Database.SQLite.Simple.ToRow +-- Copyright: (c) 2011 MailRank, Inc. +-- (c) 2011-2012 Leon P Smith +-- (c) 2012-2013 Janne Hellsten +-- License: BSD3 +-- Maintainer: Janne Hellsten +-- 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 (ToField a) => ToRow [a] where + toRow = map toField + +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 --- a/Database/SQLite/Simple/Types.hs +++ b/Database/SQLite/Simple/Types.hs @@ -1,111 +1,111 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-} - ------------------------------------------------------------------------------- --- | --- Module: Database.SQLite.Simple.Types --- Copyright: (c) 2011 MailRank, Inc. --- (c) 2011-2012 Leon P Smith --- (c) 2012-2013 Janne Hellsten --- License: BSD3 --- Maintainer: Janne Hellsten --- Portability: portable --- --- Top-level module for sqlite-simple. --- --- ------------------------------------------------------------------------------- - -module Database.SQLite.Simple.Types - ( - Null(..) - , Only(..) - , 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.SQLite.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) - --- | 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 :. +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Database.SQLite.Simple.Types +-- Copyright: (c) 2011 MailRank, Inc. +-- (c) 2011-2012 Leon P Smith +-- (c) 2012-2013 Janne Hellsten +-- License: BSD3 +-- Maintainer: Janne Hellsten +-- Portability: portable +-- +-- Top-level module for sqlite-simple. +-- +-- +------------------------------------------------------------------------------ + +module Database.SQLite.Simple.Types + ( + Null(..) + , Only(..) + , 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.SQLite.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) + +-- | 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 --- a/LICENSE +++ b/LICENSE @@ -1,94 +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. +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/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,114 +1,114 @@ -sqlite-simple: mid-level bindings to the sqlite database -======================================================== - -This library is a mid-level Haskell binding to the SQLite database. - -Sqlite-simple provides a convenient API to sqlite that does some level -of automatic data conversion between the database and Haskell types. -The API has been modeled directly after -[postgresql-simple](http://github.com/lpsmith/postgresql-simple) which -in turn borrows from -[mysql-simple](https://github.com/bos/mysql-simple). - -[The sqlite-simple API -reference](https://hackage.haskell.org/package/sqlite-simple/docs/Database-SQLite-Simple.html) -contains more examples of use and information on its features. - -The library is well tested and stable. The library should also be -reasonably performant. You can find its benchmark suite here: -[db-bench](https://github.com/nurpax/db-bench). You can read more -about sqlite-simple's expected performance in [my blog about -sqlite-simple performance against direct-sqlite, Python and -C](http://nurpax.github.io/posts/2013-08-17-sqlite-simple-benchmarking.html). - -[![Build Status](https://secure.travis-ci.org/nurpax/sqlite-simple.png)](http://travis-ci.org/nurpax/sqlite-simple) - -Installation ------------- - -You can install [sqlite-simple from Hackage](http://hackage.haskell.org/package/sqlite-simple) -with: - -``` -cabal install sqlite-simple -``` - -A Windows user? It works but please see [this note](https://gist.github.com/3907344) on direct-sqlite Windows installation. - -Examples of 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 in Haskell: - -```haskell -{-# LANGUAGE OverloadedStrings #-} -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 -``` - -More simple usage examples can be found from [sqlite-simple unit -tests](https://github.com/nurpax/sqlite-simple/blob/master/test/Simple.hs). - - -Development ------------ - -The development roadmap for sqlite-simple is mostly captured in the -github issue database. - -I'm happy to receive bug reports, fixes, documentation enhancements, -and other improvements. - -Please report bugs via the -[github issue tracker](http://github.com/nurpax/sqlite-simple/issues). - -For general database issues with a Haskell focus, I recommend sending -e-mail to the [database-devel mailing -list](http://www.haskell.org/mailman/listinfo/database-devel). - -### Contributing - -If you send pull requests for new features, it'd be great if you could also develop unit -tests for any such features. - - -Credits -------- - -A lot of the code is directly borrowed from -[mysql-simple](http://github.com/bos/mysql-simple) by Bryan O'Sullivan -and from -[postgresql-simple](http://github.com/lpsmith/postgresql-simple) by -Leon P. Smith. Like Leon in postgresql-simple, I borrow code and -documentation directly from both of these ancestor libraries. - -This package builds on top of the -[direct-sqlite](http://hackage.haskell.org/package/direct-sqlite) -package by Irene Knapp. - -SQLite is rather weakly-typed and thus the SQL to Haskell type -strictness of the parent projects does not necessarily apply to this -package. +sqlite-simple: mid-level bindings to the sqlite database +======================================================== + +This library is a mid-level Haskell binding to the SQLite database. + +Sqlite-simple provides a convenient API to sqlite that does some level +of automatic data conversion between the database and Haskell types. +The API has been modeled directly after +[postgresql-simple](http://github.com/lpsmith/postgresql-simple) which +in turn borrows from +[mysql-simple](https://github.com/bos/mysql-simple). + +[The sqlite-simple API +reference](https://hackage.haskell.org/package/sqlite-simple/docs/Database-SQLite-Simple.html) +contains more examples of use and information on its features. + +The library is well tested and stable. The library should also be +reasonably performant. You can find its benchmark suite here: +[db-bench](https://github.com/nurpax/db-bench). You can read more +about sqlite-simple's expected performance in [my blog about +sqlite-simple performance against direct-sqlite, Python and +C](http://nurpax.github.io/posts/2013-08-17-sqlite-simple-benchmarking.html). + +[![Build Status](https://secure.travis-ci.org/nurpax/sqlite-simple.png)](http://travis-ci.org/nurpax/sqlite-simple) + +Installation +------------ + +You can install [sqlite-simple from Hackage](http://hackage.haskell.org/package/sqlite-simple) +with: + +``` +cabal install sqlite-simple +``` + +A Windows user? It works but please see [this note](https://gist.github.com/3907344) on direct-sqlite Windows installation. + +Examples of 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 in Haskell: + +```haskell +{-# LANGUAGE OverloadedStrings #-} +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 +``` + +More simple usage examples can be found from [sqlite-simple unit +tests](https://github.com/nurpax/sqlite-simple/blob/master/test/Simple.hs). + + +Development +----------- + +The development roadmap for sqlite-simple is mostly captured in the +github issue database. + +I'm happy to receive bug reports, fixes, documentation enhancements, +and other improvements. + +Please report bugs via the +[github issue tracker](http://github.com/nurpax/sqlite-simple/issues). + +For general database issues with a Haskell focus, I recommend sending +e-mail to the [database-devel mailing +list](http://www.haskell.org/mailman/listinfo/database-devel). + +### Contributing + +If you send pull requests for new features, it'd be great if you could also develop unit +tests for any such features. + + +Credits +------- + +A lot of the code is directly borrowed from +[mysql-simple](http://github.com/bos/mysql-simple) by Bryan O'Sullivan +and from +[postgresql-simple](http://github.com/lpsmith/postgresql-simple) by +Leon P. Smith. Like Leon in postgresql-simple, I borrow code and +documentation directly from both of these ancestor libraries. + +This package builds on top of the +[direct-sqlite](http://hackage.haskell.org/package/direct-sqlite) +package by Irene Knapp. + +SQLite is rather weakly-typed and thus the SQL to Haskell type +strictness of the parent projects does not necessarily apply to this +package. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell + +import Distribution.Simple + +main = defaultMain diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,92 +1,95 @@ -0.4.12.0 - * Add queryWith - -0.4.11.0 - * Add executeMany - -0.4.10.0 - * Expose sqlite3_changes/total_changes - -0.4.9.0 - * Provide queryWith_ to allow more fine-grained access to - constructing queries. - * Expose error data constructors (pull request #42) - * Improve haddocks - -0.4.8.0 - * Export `bindNamed' - -0.4.7.0 - * Add `withTransaction' for running IO actions inside SQL - transactions with automated rollback if any exceptions are thrown. - -0.4.6.1 - * Fix unit test build break with older bytestring versions - -0.4.6.0 - * Add "named parameters" variants of query & al. Named params - allow queries like: - res <- queryNamed conn "SELECT * FROM posts WHERE id = :id" [":id" := postId] - * Add FromField instances for Int8, Word, Word8, Word16, Word32 - and Word64. - * Fix typos in some type conversion error messages. - * Improved test coverage. - -0.4.5.2 - * Build fix for GHC 7.4 - -0.4.5.1 - * Docs changes - uploaded new version to Hackage to update the - Hackage page. - -0.4.5.0 - - * Various improvements to documentation. Especially UTCTime - parsing and printing, and how it relates to SQLite datetimes is - better documented now. - - * Improved date/time parsing performance by adapting Leon - P. Smith's parsers from postgresql-simple for SQLite. UTCTime - handling is also better defined now. - - * Improved query performance - (https://github.com/nurpax/sqlite-simple/issues/23) - - * Improved tests for all areas touched by the above change. - -v0.4.4.0 - - * Add FromField instance for Float - - * Improve error handling for day parsing - - * + with tests - -v0.4.1.0 - v0.4.3.0 (missed tagging v0.4.2.0) - - * Improvements to withBind functionality and documentation - (see https://github.com/nurpax/sqlite-simple/pull/26) - - * Add columnName accessor for statements - - * Expose MonadPlus on RowParser - - * Allow access to the underlying direct-sqilte connection from an - sqlite-simple connection - - * Add Data.Text.Lazy and lazy ByteString From/ToField instances - -v0.4.0.0 - - * Add lastInsertRowId - - * Expose SQLite statements based streaming API - (see https://github.com/nurpax/sqlite-simple/pull/22) - -v0.3.0.0 - - * Add fold, fold_, withConnection - -v0.2.0.0 - v0.2.1.0 - - * Optimizations to improve query rows/sec performance +0.4.12.1 + * Add Setup.hs (https://github.com/fpco/stackage/issues/2145) + +0.4.12.0 + * Add queryWith + +0.4.11.0 + * Add executeMany + +0.4.10.0 + * Expose sqlite3_changes/total_changes + +0.4.9.0 + * Provide queryWith_ to allow more fine-grained access to + constructing queries. + * Expose error data constructors (pull request #42) + * Improve haddocks + +0.4.8.0 + * Export `bindNamed' + +0.4.7.0 + * Add `withTransaction' for running IO actions inside SQL + transactions with automated rollback if any exceptions are thrown. + +0.4.6.1 + * Fix unit test build break with older bytestring versions + +0.4.6.0 + * Add "named parameters" variants of query & al. Named params + allow queries like: + res <- queryNamed conn "SELECT * FROM posts WHERE id = :id" [":id" := postId] + * Add FromField instances for Int8, Word, Word8, Word16, Word32 + and Word64. + * Fix typos in some type conversion error messages. + * Improved test coverage. + +0.4.5.2 + * Build fix for GHC 7.4 + +0.4.5.1 + * Docs changes - uploaded new version to Hackage to update the + Hackage page. + +0.4.5.0 + + * Various improvements to documentation. Especially UTCTime + parsing and printing, and how it relates to SQLite datetimes is + better documented now. + + * Improved date/time parsing performance by adapting Leon + P. Smith's parsers from postgresql-simple for SQLite. UTCTime + handling is also better defined now. + + * Improved query performance + (https://github.com/nurpax/sqlite-simple/issues/23) + + * Improved tests for all areas touched by the above change. + +v0.4.4.0 + + * Add FromField instance for Float + + * Improve error handling for day parsing + + * + with tests + +v0.4.1.0 - v0.4.3.0 (missed tagging v0.4.2.0) + + * Improvements to withBind functionality and documentation + (see https://github.com/nurpax/sqlite-simple/pull/26) + + * Add columnName accessor for statements + + * Expose MonadPlus on RowParser + + * Allow access to the underlying direct-sqilte connection from an + sqlite-simple connection + + * Add Data.Text.Lazy and lazy ByteString From/ToField instances + +v0.4.0.0 + + * Add lastInsertRowId + + * Expose SQLite statements based streaming API + (see https://github.com/nurpax/sqlite-simple/pull/22) + +v0.3.0.0 + + * Add fold, fold_, withConnection + +v0.2.0.0 - v0.2.1.0 + + * Optimizations to improve query rows/sec performance diff --git a/sqlite-simple.cabal b/sqlite-simple.cabal --- a/sqlite-simple.cabal +++ b/sqlite-simple.cabal @@ -1,104 +1,104 @@ -Name: sqlite-simple -Version: 0.4.12.0 -Synopsis: Mid-Level SQLite client library -Description: - Mid-level SQLite client library, based on postgresql-simple. - . - Main documentation (with examples): - . - You can view the project page at - for 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-2014 Janne Hellsten -Homepage: http://github.com/nurpax/sqlite-simple -bug-reports: http://github.com/nurpax/sqlite-simple/issues -Stability: stable -Category: Database -Build-type: Simple - -Cabal-version: >= 1.10 - -extra-source-files: README.markdown - changelog - -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 - Database.SQLite.Simple.Time - Database.SQLite.Simple.Time.Implementation - - Build-depends: - attoparsec >= 0.10.3, - base < 5, - blaze-builder, - blaze-textual, - bytestring >= 0.9, - containers, - direct-sqlite >= 2.3.13 && < 2.4, - text >= 0.11, - 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 - , Debug - , DirectSqlite - , Errors - , Fold - , ParamConv - , Simple - , Statement - , TestImports - , UserInstances - , 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 >= 0.9 - , HUnit - , sqlite-simple - , direct-sqlite - , text - , time - +Name: sqlite-simple +Version: 0.4.12.1 +Synopsis: Mid-Level SQLite client library +Description: + Mid-level SQLite client library, based on postgresql-simple. + . + Main documentation (with examples): + . + You can view the project page at + for 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-2014 Janne Hellsten +Homepage: http://github.com/nurpax/sqlite-simple +bug-reports: http://github.com/nurpax/sqlite-simple/issues +Stability: stable +Category: Database +Build-type: Simple + +Cabal-version: >= 1.10 + +extra-source-files: README.markdown + changelog + +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 + Database.SQLite.Simple.Time + Database.SQLite.Simple.Time.Implementation + + Build-depends: + attoparsec >= 0.10.3, + base < 5, + blaze-builder, + blaze-textual, + bytestring >= 0.9, + containers, + direct-sqlite >= 2.3.13 && < 2.4, + text >= 0.11, + 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 + , Debug + , DirectSqlite + , Errors + , Fold + , ParamConv + , Simple + , Statement + , TestImports + , UserInstances + , 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 >= 0.9 + , HUnit + , sqlite-simple + , direct-sqlite + , text + , time + diff --git a/test/Common.hs b/test/Common.hs --- a/test/Common.hs +++ b/test/Common.hs @@ -1,18 +1,18 @@ - -module Common ( - -- Note: Do not add more exports for SQLite.Simple here. This is - -- so that we trap we by default export enough out of - -- Database.SQLite.Simple to make it useful as a single import. - 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 - } + +module Common ( + -- Note: Do not add more exports for SQLite.Simple here. This is + -- so that we trap we by default export enough out of + -- Database.SQLite.Simple to make it useful as a single import. + 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 + } diff --git a/test/Debug.hs b/test/Debug.hs --- a/test/Debug.hs +++ b/test/Debug.hs @@ -1,29 +1,29 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Debug ( - testDebugTracing) where - -import Control.Concurrent -import Common - --- Simplest SELECT -testDebugTracing :: TestEnv -> Test -testDebugTracing TestEnv{..} = TestCase $ do - chan <- newChan - let logger m = writeChan chan m - setTrace conn (Just logger) - execute_ conn "SELECT null" - msg <- readChan chan - "SELECT null" @=? msg - execute conn "SELECT 1+?" (Only (2 :: Int)) - execute conn "SELECT 1+?" (Only (3 :: Int)) - msg <- readChan chan - "SELECT 1+2" @=? msg - msg <- readChan chan - "SELECT 1+3" @=? msg - -- Check that disabling works too - setTrace conn Nothing - execute_ conn "SELECT null" - writeChan chan "empty" - msg <- readChan chan - "empty" @=? msg +{-# LANGUAGE OverloadedStrings #-} + +module Debug ( + testDebugTracing) where + +import Control.Concurrent +import Common + +-- Simplest SELECT +testDebugTracing :: TestEnv -> Test +testDebugTracing TestEnv{..} = TestCase $ do + chan <- newChan + let logger m = writeChan chan m + setTrace conn (Just logger) + execute_ conn "SELECT null" + msg <- readChan chan + "SELECT null" @=? msg + execute conn "SELECT 1+?" (Only (2 :: Int)) + execute conn "SELECT 1+?" (Only (3 :: Int)) + msg <- readChan chan + "SELECT 1+2" @=? msg + msg <- readChan chan + "SELECT 1+3" @=? msg + -- Check that disabling works too + setTrace conn Nothing + execute_ conn "SELECT null" + writeChan chan "empty" + msg <- readChan chan + "empty" @=? msg diff --git a/test/DirectSqlite.hs b/test/DirectSqlite.hs --- a/test/DirectSqlite.hs +++ b/test/DirectSqlite.hs @@ -1,23 +1,23 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} - -module DirectSqlite ( - testDirectSqlite - ) where - -import Common - -import Control.Exception (bracket) -import qualified Database.SQLite3 as DS - -testDirectSqlite :: TestEnv -> Test -testDirectSqlite TestEnv{..} = TestCase $ do - let dsConn = connectionHandle conn - bracket (DS.prepare dsConn "SELECT 1+1") DS.finalize testDirect - [Only (res :: Int)] <- query_ (Connection dsConn) "SELECT 1+2" - assertEqual "1+2" 3 res - where - testDirect stmt = do - DS.Row <- DS.step stmt - res <- DS.column stmt 0 - assertEqual "1+1" (SQLInteger 2) res +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +module DirectSqlite ( + testDirectSqlite + ) where + +import Common + +import Control.Exception (bracket) +import qualified Database.SQLite3 as DS + +testDirectSqlite :: TestEnv -> Test +testDirectSqlite TestEnv{..} = TestCase $ do + let dsConn = connectionHandle conn + bracket (DS.prepare dsConn "SELECT 1+1") DS.finalize testDirect + [Only (res :: Int)] <- query_ (Connection dsConn) "SELECT 1+2" + assertEqual "1+2" 3 res + where + testDirect stmt = do + DS.Row <- DS.step stmt + res <- DS.column stmt 0 + assertEqual "1+1" (SQLInteger 2) res diff --git a/test/Errors.hs b/test/Errors.hs --- a/test/Errors.hs +++ b/test/Errors.hs @@ -1,179 +1,179 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} - -module Errors ( - testErrorsColumns - , testErrorsInvalidParams - , testErrorsInvalidNamedParams - , testErrorsWithStatement - , testErrorsColumnName - , testErrorsTransaction - ) where - -import Prelude hiding (catch) -import Control.Exception -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as LB -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import Data.Word -import Data.Time (Day, UTCTime) - -import Common -import Database.SQLite.Simple.Types (Null) -import Database.SQLite3 (SQLError) - --- The "length (show e) `seq` .." trickery below is to force evaluate --- the contents of error messages. Another option would be to log --- them (would be useful), but I don't know if HUnit has any logging --- mechanisms. Just printing them as is will look like the tests are --- hitting errors and would be confusing. -assertResultErrorCaught :: IO a -> Assertion -assertResultErrorCaught action = do - catch (action >> return False) (\(e :: ResultError) -> length (show e) `seq` return True) >>= - assertBool "assertResultError exc" - -assertFormatErrorCaught :: IO a -> Assertion -assertFormatErrorCaught action = do - catch (action >> return False) (\(e :: FormatError) -> length (show e) `seq` return True) >>= - assertBool "assertFormatError exc" - -assertSQLErrorCaught :: IO a -> Assertion -assertSQLErrorCaught action = do - catch (action >> return False) (\(e :: SQLError) -> length (show e) `seq` return True) >>= - assertBool "assertSQLError exc" - -assertOOBCaught :: IO a -> Assertion -assertOOBCaught action = do - catch (action >> return False) (\(e :: ArrayException) -> length (show e) `seq` return True) >>= - assertBool "assertOOBCaught 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)]) - -- Mismatching types (source string doesn't match dst integer - assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only Integer]) - -- Mismatching types (sources don't match destination float/double type) - assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only Double]) - assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only Double]) - assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only Float]) - assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only Float]) - -- Mismatching types (sources don't match destination bool type, or is out of bounds) - assertResultErrorCaught (query_ conn "SELECT 'true'" :: IO [Only Bool]) - assertResultErrorCaught (query_ conn "SELECT 2" :: IO [Only Bool]) - -- Mismatching types (sources don't match destination string types (text, string) - assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only T.Text]) - assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only LT.Text]) - assertResultErrorCaught (query_ conn "SELECT 1.0" :: IO [Only T.Text]) - assertResultErrorCaught (query_ conn "SELECT 1.0" :: IO [Only LT.Text]) - -- Mismatching types (sources don't match destination string types (time/date) - assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only UTCTime]) - assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only Day]) - -- Mismatching types (sources don't match destination bytestring) - [Only (_ :: B.ByteString)] <- query_ conn "SELECT X'3177'" - assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only B.ByteString]) - assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only LB.ByteString]) - assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only B.ByteString]) - assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only LB.ByteString]) - -- 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 ()) - execute_ conn "CREATE TABLE cols_bools (id INTEGER PRIMARY KEY, b BOOLEAN)" - -- 3 = invalid value for bool, must be 0 or 1 - execute_ conn "INSERT INTO cols_bools (b) VALUES (3)" - assertResultErrorCaught - (do [Only _t1] <- query_ conn "SELECT b FROM cols_bools" :: IO [Only Bool] - return ()) - [Only (nullVal :: Null)] <- query_ conn "SELECT NULL" - False @=? nullVal == nullVal - False @=? nullVal /= nullVal - assertResultErrorCaught - (do [Only (_t1 :: Null)] <- query_ conn "SELECT 1" :: IO [Only Null] - 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))) - -testErrorsInvalidNamedParams :: TestEnv -> Test -testErrorsInvalidNamedParams TestEnv{..} = TestCase $ do - -- Test that only unnamed params are accepted - assertFormatErrorCaught - (queryNamed conn "SELECT :foo" [":foox" := (1 :: Int)] :: IO [Only Int]) - -- In this case, we have two bound params but only one given to - -- execute. This should cause an error. - assertFormatErrorCaught - (queryNamed conn "SELECT :foo + :bar" [":foo" := (1 :: Int)] :: IO [Only Int]) - -- Can't use named params in SQL string with the unnamed query/exec variants - assertFormatErrorCaught - (query conn "SELECT :foo" (Only (1 :: Int)) :: IO [Only Int]) - -testErrorsWithStatement :: TestEnv -> Test -testErrorsWithStatement TestEnv{..} = TestCase $ do - execute_ conn "CREATE TABLE invstat (id INTEGER PRIMARY KEY, t TEXT)" - assertSQLErrorCaught $ - withStatement conn "SELECT id, t, t1 FROM invstat" $ \_stmt -> - assertFailure "Error not detected" - -testErrorsColumnName :: TestEnv -> Test -testErrorsColumnName TestEnv{..} = TestCase $ do - execute_ conn "CREATE TABLE invcolumn (id INTEGER PRIMARY KEY, t TEXT)" - assertOOBCaught $ - withStatement conn "SELECT id FROM invcolumn" $ \stmt -> - columnName stmt (ColumnIndex (-1)) >> assertFailure "Error not detected" - -testErrorsTransaction :: TestEnv -> Test -testErrorsTransaction TestEnv{..} = TestCase $ do - execute_ conn "CREATE TABLE trans (id INTEGER PRIMARY KEY, t TEXT)" - v <- withTransaction conn $ do - executeNamed conn "INSERT INTO trans (t) VALUES (:txt)" [":txt" := ("foo" :: String)] - [Only r] <- query_ conn "SELECT t FROM trans" :: IO [Only String] - return r - v @=? "foo" - e <- rowExists - True @=? e - execute_ conn "DELETE FROM trans" - e <- rowExists - False @=? e - assertFormatErrorCaught - (withTransaction conn $ do - -- this execute should be automatically rolled back on error - executeNamed conn - "INSERT INTO trans (t) VALUES (:txt)" [":txt" := ("foo" :: String)] - -- intentional mistake here to hit an error & cause rollback of txn - executeNamed conn - "INSERT INTO trans (t) VALUES (:txt)" [":missing" := ("foo" :: String)]) - e <- rowExists - False @=? e - where - rowExists = do - rows <- query_ conn "SELECT t FROM trans" :: IO [Only String] - case rows of - [Only txt] -> do - "foo" @=? txt - return True - [] -> - return False - _ -> error "should have only one row" +{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} + +module Errors ( + testErrorsColumns + , testErrorsInvalidParams + , testErrorsInvalidNamedParams + , testErrorsWithStatement + , testErrorsColumnName + , testErrorsTransaction + ) where + +import Prelude hiding (catch) +import Control.Exception +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Data.Word +import Data.Time (Day, UTCTime) + +import Common +import Database.SQLite.Simple.Types (Null) +import Database.SQLite3 (SQLError) + +-- The "length (show e) `seq` .." trickery below is to force evaluate +-- the contents of error messages. Another option would be to log +-- them (would be useful), but I don't know if HUnit has any logging +-- mechanisms. Just printing them as is will look like the tests are +-- hitting errors and would be confusing. +assertResultErrorCaught :: IO a -> Assertion +assertResultErrorCaught action = do + catch (action >> return False) (\(e :: ResultError) -> length (show e) `seq` return True) >>= + assertBool "assertResultError exc" + +assertFormatErrorCaught :: IO a -> Assertion +assertFormatErrorCaught action = do + catch (action >> return False) (\(e :: FormatError) -> length (show e) `seq` return True) >>= + assertBool "assertFormatError exc" + +assertSQLErrorCaught :: IO a -> Assertion +assertSQLErrorCaught action = do + catch (action >> return False) (\(e :: SQLError) -> length (show e) `seq` return True) >>= + assertBool "assertSQLError exc" + +assertOOBCaught :: IO a -> Assertion +assertOOBCaught action = do + catch (action >> return False) (\(e :: ArrayException) -> length (show e) `seq` return True) >>= + assertBool "assertOOBCaught 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)]) + -- Mismatching types (source string doesn't match dst integer + assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only Integer]) + -- Mismatching types (sources don't match destination float/double type) + assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only Double]) + assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only Double]) + assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only Float]) + assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only Float]) + -- Mismatching types (sources don't match destination bool type, or is out of bounds) + assertResultErrorCaught (query_ conn "SELECT 'true'" :: IO [Only Bool]) + assertResultErrorCaught (query_ conn "SELECT 2" :: IO [Only Bool]) + -- Mismatching types (sources don't match destination string types (text, string) + assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only T.Text]) + assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only LT.Text]) + assertResultErrorCaught (query_ conn "SELECT 1.0" :: IO [Only T.Text]) + assertResultErrorCaught (query_ conn "SELECT 1.0" :: IO [Only LT.Text]) + -- Mismatching types (sources don't match destination string types (time/date) + assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only UTCTime]) + assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only Day]) + -- Mismatching types (sources don't match destination bytestring) + [Only (_ :: B.ByteString)] <- query_ conn "SELECT X'3177'" + assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only B.ByteString]) + assertResultErrorCaught (query_ conn "SELECT 1" :: IO [Only LB.ByteString]) + assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only B.ByteString]) + assertResultErrorCaught (query_ conn "SELECT 'foo'" :: IO [Only LB.ByteString]) + -- 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 ()) + execute_ conn "CREATE TABLE cols_bools (id INTEGER PRIMARY KEY, b BOOLEAN)" + -- 3 = invalid value for bool, must be 0 or 1 + execute_ conn "INSERT INTO cols_bools (b) VALUES (3)" + assertResultErrorCaught + (do [Only _t1] <- query_ conn "SELECT b FROM cols_bools" :: IO [Only Bool] + return ()) + [Only (nullVal :: Null)] <- query_ conn "SELECT NULL" + False @=? nullVal == nullVal + False @=? nullVal /= nullVal + assertResultErrorCaught + (do [Only (_t1 :: Null)] <- query_ conn "SELECT 1" :: IO [Only Null] + 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))) + +testErrorsInvalidNamedParams :: TestEnv -> Test +testErrorsInvalidNamedParams TestEnv{..} = TestCase $ do + -- Test that only unnamed params are accepted + assertFormatErrorCaught + (queryNamed conn "SELECT :foo" [":foox" := (1 :: Int)] :: IO [Only Int]) + -- In this case, we have two bound params but only one given to + -- execute. This should cause an error. + assertFormatErrorCaught + (queryNamed conn "SELECT :foo + :bar" [":foo" := (1 :: Int)] :: IO [Only Int]) + -- Can't use named params in SQL string with the unnamed query/exec variants + assertFormatErrorCaught + (query conn "SELECT :foo" (Only (1 :: Int)) :: IO [Only Int]) + +testErrorsWithStatement :: TestEnv -> Test +testErrorsWithStatement TestEnv{..} = TestCase $ do + execute_ conn "CREATE TABLE invstat (id INTEGER PRIMARY KEY, t TEXT)" + assertSQLErrorCaught $ + withStatement conn "SELECT id, t, t1 FROM invstat" $ \_stmt -> + assertFailure "Error not detected" + +testErrorsColumnName :: TestEnv -> Test +testErrorsColumnName TestEnv{..} = TestCase $ do + execute_ conn "CREATE TABLE invcolumn (id INTEGER PRIMARY KEY, t TEXT)" + assertOOBCaught $ + withStatement conn "SELECT id FROM invcolumn" $ \stmt -> + columnName stmt (ColumnIndex (-1)) >> assertFailure "Error not detected" + +testErrorsTransaction :: TestEnv -> Test +testErrorsTransaction TestEnv{..} = TestCase $ do + execute_ conn "CREATE TABLE trans (id INTEGER PRIMARY KEY, t TEXT)" + v <- withTransaction conn $ do + executeNamed conn "INSERT INTO trans (t) VALUES (:txt)" [":txt" := ("foo" :: String)] + [Only r] <- query_ conn "SELECT t FROM trans" :: IO [Only String] + return r + v @=? "foo" + e <- rowExists + True @=? e + execute_ conn "DELETE FROM trans" + e <- rowExists + False @=? e + assertFormatErrorCaught + (withTransaction conn $ do + -- this execute should be automatically rolled back on error + executeNamed conn + "INSERT INTO trans (t) VALUES (:txt)" [":txt" := ("foo" :: String)] + -- intentional mistake here to hit an error & cause rollback of txn + executeNamed conn + "INSERT INTO trans (t) VALUES (:txt)" [":missing" := ("foo" :: String)]) + e <- rowExists + False @=? e + where + rowExists = do + rows <- query_ conn "SELECT t FROM trans" :: IO [Only String] + case rows of + [Only txt] -> do + "foo" @=? txt + return True + [] -> + return False + _ -> error "should have only one row" diff --git a/test/Fold.hs b/test/Fold.hs --- a/test/Fold.hs +++ b/test/Fold.hs @@ -1,21 +1,21 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} - -module Fold ( - testFolds) where - -import Common - -testFolds :: TestEnv -> Test -testFolds TestEnv{..} = TestCase $ do - execute_ conn "CREATE TABLE testf (id INTEGER PRIMARY KEY, t INT)" - execute_ conn "INSERT INTO testf (t) VALUES (4)" - execute_ conn "INSERT INTO testf (t) VALUES (5)" - execute_ conn "INSERT INTO testf (t) VALUES (6)" - val <- fold_ conn "SELECT id,t FROM testf" ([],[]) sumValues - assertEqual "fold_" ([3,2,1], [6,5,4]) val - val <- fold conn "SELECT id,t FROM testf WHERE id > ?" (Only (1 :: Int)) ([],[]) sumValues - assertEqual "fold" ([3,2], [6,5]) val - val <- foldNamed conn "SELECT id,t FROM testf WHERE id > :id" [":id" := (1 :: Int)] ([],[]) sumValues - assertEqual "fold" ([3,2], [6,5]) val - where - sumValues (accId, accT) (id_ :: Int, t :: Int) = return $ (id_ : accId, t : accT) +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} + +module Fold ( + testFolds) where + +import Common + +testFolds :: TestEnv -> Test +testFolds TestEnv{..} = TestCase $ do + execute_ conn "CREATE TABLE testf (id INTEGER PRIMARY KEY, t INT)" + execute_ conn "INSERT INTO testf (t) VALUES (4)" + execute_ conn "INSERT INTO testf (t) VALUES (5)" + execute_ conn "INSERT INTO testf (t) VALUES (6)" + val <- fold_ conn "SELECT id,t FROM testf" ([],[]) sumValues + assertEqual "fold_" ([3,2,1], [6,5,4]) val + val <- fold conn "SELECT id,t FROM testf WHERE id > ?" (Only (1 :: Int)) ([],[]) sumValues + assertEqual "fold" ([3,2], [6,5]) val + val <- foldNamed conn "SELECT id,t FROM testf WHERE id > :id" [":id" := (1 :: Int)] ([],[]) sumValues + assertEqual "fold" ([3,2], [6,5]) val + where + sumValues (accId, accT) (id_ :: Int, t :: Int) = return $ (id_ : accId, t : accT) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,82 +1,82 @@ - -import Common -import Control.Exception (bracket) -import Control.Monad (when) -import System.Exit (exitFailure) -import System.IO - -import Debug -import DirectSqlite -import Errors -import Fold -import ParamConv -import Simple -import Statement -import TestImports() -import TestImports -import UserInstances -import Utf8Strings - -tests :: [TestEnv -> Test] -tests = - [ TestLabel "Simple" . testSimpleSelect - , TestLabel "Simple" . testSimpleOnePlusOne - , TestLabel "Simple" . testSimpleParams - , TestLabel "Simple" . testSimpleTime - , TestLabel "Simple" . testSimpleTimeFract - , TestLabel "Simple" . testSimpleInsertId - , TestLabel "Simple" . testSimpleMultiInsert - , TestLabel "Simple" . testSimpleUTCTime - , TestLabel "Simple" . testSimpleUTCTimeTZ - , TestLabel "Simple" . testSimpleUTCTimeParams - , TestLabel "Simple" . testSimpleQueryCov - , TestLabel "Simple" . testSimpleStrings - , TestLabel "Simple" . testSimpleChanges - , TestLabel "ParamConv" . testParamConvNull - , TestLabel "ParamConv" . testParamConvInt - , TestLabel "ParamConv" . testParamConvIntWidths - , TestLabel "ParamConv" . testParamConvIntWidthsFromField - , TestLabel "ParamConv" . testParamConvFloat - , TestLabel "ParamConv" . testParamConvDateTime - , TestLabel "ParamConv" . testParamConvBools - , TestLabel "ParamConv" . testParamConvToRow - , TestLabel "ParamConv" . testParamConvFromRow - , TestLabel "ParamConv" . testParamConvComposite - , TestLabel "ParamConv" . testParamNamed - , TestLabel "Errors" . testErrorsColumns - , TestLabel "Errors" . testErrorsInvalidParams - , TestLabel "Errors" . testErrorsInvalidNamedParams - , TestLabel "Errors" . testErrorsWithStatement - , TestLabel "Errors" . testErrorsColumnName - , TestLabel "Errors" . testErrorsTransaction - , TestLabel "Utf8" . testUtf8Simplest - , TestLabel "Utf8" . testBlobs - , TestLabel "Instances" . testUserFromField - , TestLabel "Fold" . testFolds - , TestLabel "Statement" . testBind - , TestLabel "Statement" . testDoubleBind - , TestLabel "Statement" . testPreparedStatements - , TestLabel "Debug" . testDebugTracing - , TestLabel "Direct" . testDirectSqlite - , TestLabel "Imports" . testImports - ] - --- | 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 } - 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 + +import Common +import Control.Exception (bracket) +import Control.Monad (when) +import System.Exit (exitFailure) +import System.IO + +import Debug +import DirectSqlite +import Errors +import Fold +import ParamConv +import Simple +import Statement +import TestImports() +import TestImports +import UserInstances +import Utf8Strings + +tests :: [TestEnv -> Test] +tests = + [ TestLabel "Simple" . testSimpleSelect + , TestLabel "Simple" . testSimpleOnePlusOne + , TestLabel "Simple" . testSimpleParams + , TestLabel "Simple" . testSimpleTime + , TestLabel "Simple" . testSimpleTimeFract + , TestLabel "Simple" . testSimpleInsertId + , TestLabel "Simple" . testSimpleMultiInsert + , TestLabel "Simple" . testSimpleUTCTime + , TestLabel "Simple" . testSimpleUTCTimeTZ + , TestLabel "Simple" . testSimpleUTCTimeParams + , TestLabel "Simple" . testSimpleQueryCov + , TestLabel "Simple" . testSimpleStrings + , TestLabel "Simple" . testSimpleChanges + , TestLabel "ParamConv" . testParamConvNull + , TestLabel "ParamConv" . testParamConvInt + , TestLabel "ParamConv" . testParamConvIntWidths + , TestLabel "ParamConv" . testParamConvIntWidthsFromField + , TestLabel "ParamConv" . testParamConvFloat + , TestLabel "ParamConv" . testParamConvDateTime + , TestLabel "ParamConv" . testParamConvBools + , TestLabel "ParamConv" . testParamConvToRow + , TestLabel "ParamConv" . testParamConvFromRow + , TestLabel "ParamConv" . testParamConvComposite + , TestLabel "ParamConv" . testParamNamed + , TestLabel "Errors" . testErrorsColumns + , TestLabel "Errors" . testErrorsInvalidParams + , TestLabel "Errors" . testErrorsInvalidNamedParams + , TestLabel "Errors" . testErrorsWithStatement + , TestLabel "Errors" . testErrorsColumnName + , TestLabel "Errors" . testErrorsTransaction + , TestLabel "Utf8" . testUtf8Simplest + , TestLabel "Utf8" . testBlobs + , TestLabel "Instances" . testUserFromField + , TestLabel "Fold" . testFolds + , TestLabel "Statement" . testBind + , TestLabel "Statement" . testDoubleBind + , TestLabel "Statement" . testPreparedStatements + , TestLabel "Debug" . testDebugTracing + , TestLabel "Direct" . testDirectSqlite + , TestLabel "Imports" . testImports + ] + +-- | 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 } + 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 --- a/test/ParamConv.hs +++ b/test/ParamConv.hs @@ -1,244 +1,244 @@ -{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} - -module ParamConv ( - testParamConvNull - , testParamConvInt - , testParamConvIntWidths - , testParamConvIntWidthsFromField - , testParamConvFloat - , testParamConvBools - , testParamConvDateTime - , testParamConvFromRow - , testParamConvToRow - , testParamConvComposite - , testParamNamed) where - -import Control.Applicative -import Data.Int -import Data.Word -import Data.Time -import qualified Data.Text as T -import Database.SQLite.Simple.Types (Null(..)) - -import Common - -one, two, three :: Int -one = 1 -two = 2 -three = 3 - -testParamConvNull :: TestEnv -> Test -testParamConvNull TestEnv{..} = TestCase $ do - execute_ conn "CREATE TABLE nulltype (id INTEGER PRIMARY KEY, t1 TEXT)" - [Only r] <- (query_ conn "SELECT NULL") :: IO [Only Null] - execute conn "INSERT INTO nulltype (id, t1) VALUES (?,?)" (one, r) - [Only mr1] <- query_ conn "SELECT t1 FROM nulltype WHERE id = 1" :: IO [Only (Maybe String)] - assertEqual "nulls" Nothing mr1 - execute conn "INSERT INTO nulltype (id, t1) VALUES (?,?)" (two, "foo" :: String) - [mr2] <- query_ conn "SELECT t1 FROM nulltype WHERE id = 2" :: IO [Only (Maybe String)] - assertEqual "nulls" (Just "foo") (fromOnly mr2) - -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 ?" (Only one)) :: IO [Only Integer] - 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 - [Only r] <- (query conn "SELECT ?+?" (two, 14 :: Integer)) :: 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 - -testParamConvIntWidths :: TestEnv -> Test -testParamConvIntWidths TestEnv{..} = TestCase $ do - [Only r] <- (query conn "SELECT ?" (Only (1 :: Int8))) :: IO [Only Int] - assertEqual "value" 1 r - [Only r] <- (query conn "SELECT ?" (Only (257 :: Int8))) :: IO [Only Int] -- wrap around - assertEqual "value" 1 r - [Only r] <- (query conn "SELECT ?" (Only (257 :: Int16))) :: IO [Only Int] - assertEqual "value" 257 r - [Only r] <- (query conn "SELECT ?" (Only (258 :: Int32))) :: IO [Only Int] - assertEqual "value" 258 r - [Only r] <- (query conn "SELECT ?" (Only (1 :: Word8))) :: IO [Only Int] - assertEqual "value" 1 r - [Only r] <- (query conn "SELECT ?" (Only (257 :: Word8))) :: IO [Only Int] -- wrap around - assertEqual "value" 1 r - [Only r] <- (query conn "SELECT ?" (Only (257 :: Word16))) :: IO [Only Int] - assertEqual "value" 257 r - [Only r] <- (query conn "SELECT ?" (Only (257 :: Word32))) :: IO [Only Int] - assertEqual "value" 257 r - [Only r] <- (query conn "SELECT ?" (Only (0x100000000 :: Word64))) :: IO [Only Int] - assertEqual "value" 0x100000000 r - [Only r] <- (query conn "SELECT ?" (Only (1 :: Integer))) :: IO [Only Int] - assertEqual "value" 1 r - [Only r] <- (query conn "SELECT ?" (Only (1 :: Word))) :: IO [Only Int] - assertEqual "value" 1 r - -testParamConvIntWidthsFromField :: TestEnv -> Test -testParamConvIntWidthsFromField TestEnv{..} = TestCase $ do - [Only r] <- (query conn "SELECT ?" (Only (1 :: Int))) :: IO [Only Int8] - assertEqual "value" 1 r - [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Int8] -- wrap around - assertEqual "value" 1 r - [Only r] <- (query conn "SELECT ?" (Only (65536 :: Int))) :: IO [Only Int16] -- wrap around - assertEqual "value" 0 r - [Only r] <- (query conn "SELECT ?" (Only (65536 :: Int))) :: IO [Only Int32] -- wrap around - assertEqual "value" 65536 r - [Only r] <- (query conn "SELECT ?" (Only (258 :: Int))) :: IO [Only Int32] - assertEqual "value" 258 r - [Only r] <- (query conn "SELECT ?" (Only (1 :: Int))) :: IO [Only Word8] - assertEqual "value" 1 r - [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Word8] -- wrap around - assertEqual "value" 1 r - [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Word16] - assertEqual "value" 257 r - [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Word32] - assertEqual "value" 257 r - [Only r] <- (query conn "SELECT ?" (Only (0x100000000 :: Int64))) :: IO [Only Word64] - assertEqual "value" 0x100000000 r - [Only r] <- (query conn "SELECT ?" (Only (1 :: Int))) :: IO [Only Word] - assertEqual "value" 1 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 - - -testParamConvBools :: TestEnv -> Test -testParamConvBools TestEnv{..} = TestCase $ do - execute_ conn "CREATE TABLE bt (id INTEGER PRIMARY KEY, b BOOLEAN)" - -- Booleans are ints with values 0 or 1 on SQLite - execute_ conn "INSERT INTO bt (b) VALUES (0)" - execute_ conn "INSERT INTO bt (b) VALUES (1)" - [Only r1, Only r2] <- query_ conn "SELECT b from bt" :: IO [Only Bool] - assertEqual "bool" False r1 - assertEqual "bool" True r2 - execute conn "INSERT INTO bt (b) VALUES (?)" (Only True) - execute conn "INSERT INTO bt (b) VALUES (?)" (Only False) - execute conn "INSERT INTO bt (b) VALUES (?)" (Only False) - [Only r3, Only r4, Only r5] <- - query_ conn "SELECT b from bt where id in (3, 4, 5) ORDER BY id" :: IO [Only Bool] - assertEqual "bool" True r3 - assertEqual "bool" False r4 - assertEqual "bool" False r5 - -testParamConvFromRow :: TestEnv -> Test -testParamConvFromRow TestEnv{..} = TestCase $ do - [(1,2)] <- query_ conn "SELECT 1,2" :: IO [(Int,Int)] - [(1,2,3)] <- query_ conn "SELECT 1,2,3" :: IO [(Int,Int,Int)] - [(1,2,3,4)] <- query_ conn "SELECT 1,2,3,4" :: IO [(Int,Int,Int,Int)] - [(1,2,3,4,5)] <- query_ conn "SELECT 1,2,3,4,5" :: IO [(Int,Int,Int,Int,Int)] - [(1,2,3,4,5,6)] <- query_ conn "SELECT 1,2,3,4,5,6" :: IO [(Int,Int,Int,Int,Int,Int)] - [(1,2,3,4,5,6,7)] <- query_ conn "SELECT 1,2,3,4,5,6,7" :: IO [(Int,Int,Int,Int,Int,Int,Int)] - [(1,2,3,4,5,6,7,8)] <- query_ conn "SELECT 1,2,3,4,5,6,7,8" :: IO [(Int,Int,Int,Int,Int,Int,Int,Int)] - [(1,2,3,4,5,6,7,8,9)] <- query_ conn "SELECT 1,2,3,4,5,6,7,8,9" :: IO [(Int,Int,Int,Int,Int,Int,Int,Int,Int)] - [(1,2,3,4,5,6,7,8,9,10)] <- query_ conn "SELECT 1,2,3,4,5,6,7,8,9,10" :: IO [(Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)] - [[1,2,3]] <- query_ conn "SELECT 1,2,3" :: IO [[Int]] - return () - -testParamConvToRow :: TestEnv -> Test -testParamConvToRow TestEnv{..} = TestCase $ do - [Only (s :: Int)] <- query conn "SELECT 13" () - 13 @=? s - [Only (s :: Int)] <- query conn "SELECT ?" (Only one) - 1 @=? s - [Only (s :: Int)] <- query conn "SELECT ?+?" (one, two) - (1+2) @=? s - [Only (s :: Int)] <- query conn "SELECT ?+?+?" (one, two, three) - (1+2+3) @=? s - [Only (s :: Int)] <- query conn "SELECT ?+?+?+?" (one, two, three, 4 :: Int) - (1+2+3+4) @=? s - [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?" (one, two, three, 4 :: Int, 5 :: Int) - (1+2+3+4+5) @=? s - [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?" (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int) - (1+2+3+4+5+6) @=? s - [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?+?" - (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int) - (1+2+3+4+5+6+7) @=? s - [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?+?+?" - (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int, 8 :: Int) - (1+2+3+4+5+6+7+8) @=? s - [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?+?+?+?" - (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int, 8 :: Int, 9 :: Int) - (1+2+3+4+5+6+7+8+9) @=? s - [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?+?+?+?+?" - (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int, 8 :: Int, 9 :: Int, 10 :: Int) - (1+2+3+4+5+6+7+8+9+10) @=? s - -data TestTuple = TestTuple Int64 Int64 deriving (Eq, Show) -data TestTuple2 = TestTuple2 T.Text T.Text deriving (Eq, Show) - -instance FromRow TestTuple where - fromRow = TestTuple <$> field <*> field - -instance FromRow TestTuple2 where - fromRow = TestTuple2 <$> field <*> field - -instance ToRow TestTuple where - toRow (TestTuple a b) = [SQLInteger a, SQLInteger b] - -instance ToRow TestTuple2 where - toRow (TestTuple2 a b) = [SQLText a, SQLText b] - -testParamConvComposite :: TestEnv -> Test -testParamConvComposite TestEnv{..} = TestCase $ do - [t1] <- query_ conn "SELECT 1,2" - TestTuple 1 2 @=? t1 - [t2] <- query_ conn "SELECT 'foo','bar'" - TestTuple2 "foo" "bar" @=? t2 - [a :. b] <- query_ conn "SELECT 4,5,'baz','xyzz'" - TestTuple 4 5 :. TestTuple2 "baz" "xyzz" @=? a :. b - [TestTuple x y :. TestTuple2 z w] <- query conn "SELECT ?,?,?,?" (a :. b) - x @=? 4 - y @=? 5 - z @=? "baz" - w @=? "xyzz" - -testParamNamed :: TestEnv -> Test -testParamNamed TestEnv{..} = TestCase $ do - [Only t1] <- queryNamed conn "SELECT :foo / :bar" [":foo" := two, ":bar" := one] - t1 @=? (2 :: Int) - [(t1,t2)] <- queryNamed conn "SELECT :foo,:bar" [":foo" := ("foo" :: T.Text), ":bar" := one] - t1 @=? ("foo" :: T.Text) - t2 @=? one - execute_ conn "CREATE TABLE np (id INTEGER PRIMARY KEY, b BOOLEAN)" - executeNamed conn "INSERT INTO np (b) VALUES (:b)" [":b" := True] - [Only t1] <- query_ conn "SELECT b FROM np" - True @=? t1 - - +{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} + +module ParamConv ( + testParamConvNull + , testParamConvInt + , testParamConvIntWidths + , testParamConvIntWidthsFromField + , testParamConvFloat + , testParamConvBools + , testParamConvDateTime + , testParamConvFromRow + , testParamConvToRow + , testParamConvComposite + , testParamNamed) where + +import Control.Applicative +import Data.Int +import Data.Word +import Data.Time +import qualified Data.Text as T +import Database.SQLite.Simple.Types (Null(..)) + +import Common + +one, two, three :: Int +one = 1 +two = 2 +three = 3 + +testParamConvNull :: TestEnv -> Test +testParamConvNull TestEnv{..} = TestCase $ do + execute_ conn "CREATE TABLE nulltype (id INTEGER PRIMARY KEY, t1 TEXT)" + [Only r] <- (query_ conn "SELECT NULL") :: IO [Only Null] + execute conn "INSERT INTO nulltype (id, t1) VALUES (?,?)" (one, r) + [Only mr1] <- query_ conn "SELECT t1 FROM nulltype WHERE id = 1" :: IO [Only (Maybe String)] + assertEqual "nulls" Nothing mr1 + execute conn "INSERT INTO nulltype (id, t1) VALUES (?,?)" (two, "foo" :: String) + [mr2] <- query_ conn "SELECT t1 FROM nulltype WHERE id = 2" :: IO [Only (Maybe String)] + assertEqual "nulls" (Just "foo") (fromOnly mr2) + +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 ?" (Only one)) :: IO [Only Integer] + 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 + [Only r] <- (query conn "SELECT ?+?" (two, 14 :: Integer)) :: 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 + +testParamConvIntWidths :: TestEnv -> Test +testParamConvIntWidths TestEnv{..} = TestCase $ do + [Only r] <- (query conn "SELECT ?" (Only (1 :: Int8))) :: IO [Only Int] + assertEqual "value" 1 r + [Only r] <- (query conn "SELECT ?" (Only (257 :: Int8))) :: IO [Only Int] -- wrap around + assertEqual "value" 1 r + [Only r] <- (query conn "SELECT ?" (Only (257 :: Int16))) :: IO [Only Int] + assertEqual "value" 257 r + [Only r] <- (query conn "SELECT ?" (Only (258 :: Int32))) :: IO [Only Int] + assertEqual "value" 258 r + [Only r] <- (query conn "SELECT ?" (Only (1 :: Word8))) :: IO [Only Int] + assertEqual "value" 1 r + [Only r] <- (query conn "SELECT ?" (Only (257 :: Word8))) :: IO [Only Int] -- wrap around + assertEqual "value" 1 r + [Only r] <- (query conn "SELECT ?" (Only (257 :: Word16))) :: IO [Only Int] + assertEqual "value" 257 r + [Only r] <- (query conn "SELECT ?" (Only (257 :: Word32))) :: IO [Only Int] + assertEqual "value" 257 r + [Only r] <- (query conn "SELECT ?" (Only (0x100000000 :: Word64))) :: IO [Only Int] + assertEqual "value" 0x100000000 r + [Only r] <- (query conn "SELECT ?" (Only (1 :: Integer))) :: IO [Only Int] + assertEqual "value" 1 r + [Only r] <- (query conn "SELECT ?" (Only (1 :: Word))) :: IO [Only Int] + assertEqual "value" 1 r + +testParamConvIntWidthsFromField :: TestEnv -> Test +testParamConvIntWidthsFromField TestEnv{..} = TestCase $ do + [Only r] <- (query conn "SELECT ?" (Only (1 :: Int))) :: IO [Only Int8] + assertEqual "value" 1 r + [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Int8] -- wrap around + assertEqual "value" 1 r + [Only r] <- (query conn "SELECT ?" (Only (65536 :: Int))) :: IO [Only Int16] -- wrap around + assertEqual "value" 0 r + [Only r] <- (query conn "SELECT ?" (Only (65536 :: Int))) :: IO [Only Int32] -- wrap around + assertEqual "value" 65536 r + [Only r] <- (query conn "SELECT ?" (Only (258 :: Int))) :: IO [Only Int32] + assertEqual "value" 258 r + [Only r] <- (query conn "SELECT ?" (Only (1 :: Int))) :: IO [Only Word8] + assertEqual "value" 1 r + [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Word8] -- wrap around + assertEqual "value" 1 r + [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Word16] + assertEqual "value" 257 r + [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Word32] + assertEqual "value" 257 r + [Only r] <- (query conn "SELECT ?" (Only (0x100000000 :: Int64))) :: IO [Only Word64] + assertEqual "value" 0x100000000 r + [Only r] <- (query conn "SELECT ?" (Only (1 :: Int))) :: IO [Only Word] + assertEqual "value" 1 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 + + +testParamConvBools :: TestEnv -> Test +testParamConvBools TestEnv{..} = TestCase $ do + execute_ conn "CREATE TABLE bt (id INTEGER PRIMARY KEY, b BOOLEAN)" + -- Booleans are ints with values 0 or 1 on SQLite + execute_ conn "INSERT INTO bt (b) VALUES (0)" + execute_ conn "INSERT INTO bt (b) VALUES (1)" + [Only r1, Only r2] <- query_ conn "SELECT b from bt" :: IO [Only Bool] + assertEqual "bool" False r1 + assertEqual "bool" True r2 + execute conn "INSERT INTO bt (b) VALUES (?)" (Only True) + execute conn "INSERT INTO bt (b) VALUES (?)" (Only False) + execute conn "INSERT INTO bt (b) VALUES (?)" (Only False) + [Only r3, Only r4, Only r5] <- + query_ conn "SELECT b from bt where id in (3, 4, 5) ORDER BY id" :: IO [Only Bool] + assertEqual "bool" True r3 + assertEqual "bool" False r4 + assertEqual "bool" False r5 + +testParamConvFromRow :: TestEnv -> Test +testParamConvFromRow TestEnv{..} = TestCase $ do + [(1,2)] <- query_ conn "SELECT 1,2" :: IO [(Int,Int)] + [(1,2,3)] <- query_ conn "SELECT 1,2,3" :: IO [(Int,Int,Int)] + [(1,2,3,4)] <- query_ conn "SELECT 1,2,3,4" :: IO [(Int,Int,Int,Int)] + [(1,2,3,4,5)] <- query_ conn "SELECT 1,2,3,4,5" :: IO [(Int,Int,Int,Int,Int)] + [(1,2,3,4,5,6)] <- query_ conn "SELECT 1,2,3,4,5,6" :: IO [(Int,Int,Int,Int,Int,Int)] + [(1,2,3,4,5,6,7)] <- query_ conn "SELECT 1,2,3,4,5,6,7" :: IO [(Int,Int,Int,Int,Int,Int,Int)] + [(1,2,3,4,5,6,7,8)] <- query_ conn "SELECT 1,2,3,4,5,6,7,8" :: IO [(Int,Int,Int,Int,Int,Int,Int,Int)] + [(1,2,3,4,5,6,7,8,9)] <- query_ conn "SELECT 1,2,3,4,5,6,7,8,9" :: IO [(Int,Int,Int,Int,Int,Int,Int,Int,Int)] + [(1,2,3,4,5,6,7,8,9,10)] <- query_ conn "SELECT 1,2,3,4,5,6,7,8,9,10" :: IO [(Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)] + [[1,2,3]] <- query_ conn "SELECT 1,2,3" :: IO [[Int]] + return () + +testParamConvToRow :: TestEnv -> Test +testParamConvToRow TestEnv{..} = TestCase $ do + [Only (s :: Int)] <- query conn "SELECT 13" () + 13 @=? s + [Only (s :: Int)] <- query conn "SELECT ?" (Only one) + 1 @=? s + [Only (s :: Int)] <- query conn "SELECT ?+?" (one, two) + (1+2) @=? s + [Only (s :: Int)] <- query conn "SELECT ?+?+?" (one, two, three) + (1+2+3) @=? s + [Only (s :: Int)] <- query conn "SELECT ?+?+?+?" (one, two, three, 4 :: Int) + (1+2+3+4) @=? s + [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?" (one, two, three, 4 :: Int, 5 :: Int) + (1+2+3+4+5) @=? s + [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?" (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int) + (1+2+3+4+5+6) @=? s + [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?+?" + (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int) + (1+2+3+4+5+6+7) @=? s + [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?+?+?" + (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int, 8 :: Int) + (1+2+3+4+5+6+7+8) @=? s + [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?+?+?+?" + (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int, 8 :: Int, 9 :: Int) + (1+2+3+4+5+6+7+8+9) @=? s + [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?+?+?+?+?" + (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int, 8 :: Int, 9 :: Int, 10 :: Int) + (1+2+3+4+5+6+7+8+9+10) @=? s + +data TestTuple = TestTuple Int64 Int64 deriving (Eq, Show) +data TestTuple2 = TestTuple2 T.Text T.Text deriving (Eq, Show) + +instance FromRow TestTuple where + fromRow = TestTuple <$> field <*> field + +instance FromRow TestTuple2 where + fromRow = TestTuple2 <$> field <*> field + +instance ToRow TestTuple where + toRow (TestTuple a b) = [SQLInteger a, SQLInteger b] + +instance ToRow TestTuple2 where + toRow (TestTuple2 a b) = [SQLText a, SQLText b] + +testParamConvComposite :: TestEnv -> Test +testParamConvComposite TestEnv{..} = TestCase $ do + [t1] <- query_ conn "SELECT 1,2" + TestTuple 1 2 @=? t1 + [t2] <- query_ conn "SELECT 'foo','bar'" + TestTuple2 "foo" "bar" @=? t2 + [a :. b] <- query_ conn "SELECT 4,5,'baz','xyzz'" + TestTuple 4 5 :. TestTuple2 "baz" "xyzz" @=? a :. b + [TestTuple x y :. TestTuple2 z w] <- query conn "SELECT ?,?,?,?" (a :. b) + x @=? 4 + y @=? 5 + z @=? "baz" + w @=? "xyzz" + +testParamNamed :: TestEnv -> Test +testParamNamed TestEnv{..} = TestCase $ do + [Only t1] <- queryNamed conn "SELECT :foo / :bar" [":foo" := two, ":bar" := one] + t1 @=? (2 :: Int) + [(t1,t2)] <- queryNamed conn "SELECT :foo,:bar" [":foo" := ("foo" :: T.Text), ":bar" := one] + t1 @=? ("foo" :: T.Text) + t2 @=? one + execute_ conn "CREATE TABLE np (id INTEGER PRIMARY KEY, b BOOLEAN)" + executeNamed conn "INSERT INTO np (b) VALUES (:b)" [":b" := True] + [Only t1] <- query_ conn "SELECT b FROM np" + True @=? t1 + + diff --git a/test/Simple.hs b/test/Simple.hs --- a/test/Simple.hs +++ b/test/Simple.hs @@ -1,268 +1,268 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Simple ( - testSimpleOnePlusOne - , testSimpleSelect - , testSimpleParams - , testSimpleTime - , testSimpleTimeFract - , testSimpleInsertId - , testSimpleMultiInsert - , testSimpleUTCTime - , testSimpleUTCTimeTZ - , testSimpleUTCTimeParams - , testSimpleQueryCov - , testSimpleStrings - , testSimpleChanges - ) where - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS --- orphan IsString instance in older byteString -import Data.ByteString.Lazy.Char8 () -import Data.Monoid ((<>), mappend, mempty) -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import Data.Time (UTCTime, Day) - -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 - [Only r] <- query_ conn "SELECT 1.0" :: IO [Only Double] - assertEqual "doubles" 1.0 r - [Only r] <- query_ conn "SELECT 1.0" :: IO [Only Float] - assertEqual "floats" 1.0 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 - [Only r1, Only r2] <- query conn "SELECT t FROM testparams WHERE (id = ? OR id = ?)" (1 :: Int, 2 :: Int) :: IO [Only String] - assertEqual "select params" "test string" r1 - assertEqual "select params" "test2" r2 - [Only i] <- query conn "SELECT ?+?" [42 :: Int, 1 :: Int] :: IO [Only Int] - assertEqual "select int param" 43 i - [Only d] <- query conn "SELECT ?" [2.0 :: Double] :: IO [Only Double] - assertEqual "select double param" 2.0 d - [Only f] <- query conn "SELECT ?" [4.0 :: Float] :: IO [Only Float] - assertEqual "select double param" 4.0 f - -testSimpleTime :: TestEnv -> Test -testSimpleTime TestEnv{..} = TestCase $ do - let timestr = "2012-08-20 20:19:58" - time = read timestr :: UTCTime - execute_ conn "CREATE TABLE time (t TIMESTAMP)" - execute conn "INSERT INTO time (t) VALUES (?)" (Only time) - [Only t] <- query_ conn "SELECT * FROM time" :: IO [Only UTCTime] - assertEqual "UTCTime conv" time t - [Only t] <- query conn "SELECT * FROM time WHERE t = ?" (Only time) :: IO [Only UTCTime] - assertEqual "UTCTime conv2" time t - -- Try inserting timestamp directly as a string - execute_ conn "CREATE TABLE time2 (t TIMESTAMP)" - execute_ conn (Query (T.concat ["INSERT INTO time2 (t) VALUES ('", T.pack timestr, "')"])) - [Only t] <- query_ conn "SELECT * FROM time2" :: IO [Only UTCTime] - assertEqual "UTCTime" time t - rows <- query conn "SELECT * FROM time2 WHERE t = ?" (Only time) :: IO [Only UTCTime] - assertEqual "should see one row result" 1 (length rows) - assertEqual "UTCTime" time t - -- Days - let daystr = "2013-08-21" - day = read daystr :: Day - [Only day'] <- query_ conn (Query (T.concat ["SELECT '", T.pack daystr, "'"])) - day @?= day' - [Only day''] <- query conn "SELECT ?" (Only day) - day @?= day'' - -- database timestamp -> day conversion is treated as an error, but - -- try converting a timestamp to a date and see we get it back ok - [Only dayx] <- query_ conn "SELECT date('2013-08-21 08:00:03.256887')" - day @?= dayx - -testSimpleTimeFract :: TestEnv -> Test -testSimpleTimeFract TestEnv{..} = TestCase $ do - let timestr = "2012-08-17 08:00:03.256887" - time = read timestr :: UTCTime - -- Try inserting timestamp directly as a string - execute_ conn "CREATE TABLE timefract (t TIMESTAMP)" - execute_ conn (Query (T.concat ["INSERT INTO timefract (t) VALUES ('", T.pack timestr, "')"])) - [Only t] <- query_ conn "SELECT * FROM timefract" :: IO [Only UTCTime] - assertEqual "UTCTime" time t - rows <- query conn "SELECT * FROM timefract WHERE t = ?" (Only time) :: IO [Only UTCTime] - assertEqual "should see one row result" 1 (length rows) - assertEqual "UTCTime" time t - -testSimpleInsertId :: TestEnv -> Test -testSimpleInsertId TestEnv{..} = TestCase $ do - execute_ conn "CREATE TABLE test_row_id (id INTEGER PRIMARY KEY, t TEXT)" - execute conn "INSERT INTO test_row_id (t) VALUES (?)" (Only ("test string" :: String)) - id1 <- lastInsertRowId conn - execute_ conn "INSERT INTO test_row_id (t) VALUES ('test2')" - id2 <- lastInsertRowId conn - 1 @=? id1 - 2 @=? id2 - rows <- query conn "SELECT t FROM test_row_id WHERE id = ?" (Only (1 :: Int)) :: IO [Only String] - 1 @=? (length rows) - (Only "test string") @=? (head rows) - [Only row] <- query conn "SELECT t FROM test_row_id WHERE id = ?" (Only (2 :: Int)) :: IO [Only String] - "test2" @=? row - -testSimpleMultiInsert :: TestEnv -> Test -testSimpleMultiInsert TestEnv{..} = TestCase $ do - execute_ conn "CREATE TABLE test_multi_insert (id INTEGER PRIMARY KEY, t1 TEXT, t2 TEXT)" - executeMany conn "INSERT INTO test_multi_insert (t1, t2) VALUES (?, ?)" ([("foo", "bar"), ("baz", "bat")] :: [(String, String)]) - id2 <- lastInsertRowId conn - 2 @=? id2 - - rows <- query_ conn "SELECT id,t1,t2 FROM test_multi_insert" :: IO [(Int, String, String)] - [(1, "foo", "bar"), (2, "baz", "bat")] @=? rows - -testSimpleUTCTime :: TestEnv -> Test -testSimpleUTCTime TestEnv{..} = TestCase $ do - -- Time formats understood by sqlite: http://sqlite.org/lang_datefunc.html - let timestrs = [ "2012-08-17 13:25" - , "2012-08-17 13:25:44" - , "2012-08-17 13:25:44.123" - ] - timestrsWithT = map (T.map (\c -> if c == ' ' then 'T' else c)) timestrs - execute_ conn "CREATE TABLE utctimes (t TIMESTAMP)" - mapM_ (\t -> execute conn "INSERT INTO utctimes (t) VALUES (?)" (Only t)) timestrs - mapM_ (\t -> execute conn "INSERT INTO utctimes (t) VALUES (?)" (Only t)) timestrsWithT - dates <- query_ conn "SELECT t from utctimes" :: IO [Only UTCTime] - mapM_ matchDates (zip (timestrs ++ timestrsWithT) dates) - let zulu = "2012-08-17 13:25" - [d] <- query conn "SELECT ?" (Only (T.append zulu "Z")) - matchDates (zulu, d) - let zulu = "2012-08-17 13:25:00" - [d] <- query conn "SELECT ?" (Only (T.append zulu "Z")) - matchDates (zulu, d) - where - matchDates (str,(Only date)) = do - -- Remove 'T' when reading in to Haskell - let t = read (makeReadable str) :: UTCTime - t @=? date - - makeReadable s = - let s' = if T.length s < T.length "YYYY-MM-DD HH:MM:SS" then T.append s ":00" else s - in T.unpack . T.replace "T" " " $ s' - -testSimpleUTCTimeTZ :: TestEnv -> Test -testSimpleUTCTimeTZ TestEnv{..} = TestCase $ do - -- Time formats understood by sqlite: http://sqlite.org/lang_datefunc.html - let timestrs = [ "2013-02-03 13:00:00-02:00" - , "2013-02-03 13:00:00-01:00" - , "2013-02-03 13:00:00-03:00" - , "2013-02-03 13:00:00Z" - , "2013-02-03 13:00:00+00:00" - , "2013-02-03 13:00:00+03:00" - , "2013-02-03 13:00:00+02:00" - , "2013-02-03 13:00:00+04:00" - ] - execute_ conn "CREATE TABLE utctimestz (t TIMESTAMP)" - mapM_ (\t -> execute conn "INSERT INTO utctimestz (t) VALUES (?)" (Only t)) timestrs - dates <- query_ conn "SELECT t from utctimestz" :: IO [Only UTCTime] - mapM_ matchDates (zip (timestrs) dates) - where - matchDates (str,(Only date)) = do - -- Remove 'T' when reading in to Haskell - let t = read . T.unpack $ str :: UTCTime - t @=? date - -testSimpleUTCTimeParams :: TestEnv -> Test -testSimpleUTCTimeParams TestEnv{..} = TestCase $ do - let times = [ "2012-08-17 08:00:03" - , "2012-08-17 08:00:03.2" - , "2012-08-17 08:00:03.256" - , "2012-08-17 08:00:03.4192" - ] - -- Try inserting timestamp directly as a string - mapM_ assertResult times - where - assertResult tstr = do - let utct = read . T.unpack $ tstr :: UTCTime - [Only t] <- query conn "SELECT ?" (Only utct) :: IO [Only T.Text] - assertEqual "UTCTime" tstr t - -testSimpleQueryCov :: TestEnv -> Test -testSimpleQueryCov TestEnv{..} = TestCase $ do - let str = "SELECT 1+1" :: T.Text - q = "SELECT 1+1" :: Query - fromQuery q @=? str - show str @=? show q - q @=? ((read . show $ q) :: Query) - q @=? q - q @=? (Query "SELECT 1" <> Query "+1") - q @=? foldr mappend mempty ["SELECT ", "1", "+", "1"] - True @=? q <= q - -testSimpleStrings :: TestEnv -> Test -testSimpleStrings TestEnv{..} = TestCase $ do - [Only s] <- query_ conn "SELECT 'str1'" :: IO [Only T.Text] - s @=? "str1" - [Only s] <- query_ conn "SELECT 'strLazy'" :: IO [Only LT.Text] - s @=? "strLazy" - [Only s] <- query conn "SELECT ?" (Only ("strP" :: T.Text)) :: IO [Only T.Text] - s @=? "strP" - [Only s] <- query conn "SELECT ?" (Only ("strPLazy" :: LT.Text)) :: IO [Only T.Text] - s @=? "strPLazy" - -- ByteStrings are blobs in sqlite storage, so use ByteString for - -- both input and output - [Only s] <- query conn "SELECT ?" (Only ("strBsP" :: BS.ByteString)) :: IO [Only BS.ByteString] - s @=? "strBsP" - [Only s] <- query conn "SELECT ?" (Only ("strBsPLazy" :: LBS.ByteString)) :: IO [Only BS.ByteString] - s @=? "strBsPLazy" - [Only s] <- query conn "SELECT ?" (Only ("strBsPLazy2" :: BS.ByteString)) :: IO [Only LBS.ByteString] - s @=? "strBsPLazy2" - -testSimpleChanges :: TestEnv -> Test -testSimpleChanges TestEnv{..} = TestCase $ do - execute_ conn "CREATE TABLE testchanges (id INTEGER PRIMARY KEY, t TEXT)" - execute conn "INSERT INTO testchanges(t) VALUES (?)" (Only ("test string" :: String)) - numChanges <- changes conn - assertEqual "changed/inserted rows" 1 numChanges - execute conn "INSERT INTO testchanges(t) VALUES (?)" (Only ("test string 2" :: String)) - numChanges <- changes conn - assertEqual "changed/inserted rows" 1 numChanges - execute_ conn "UPDATE testchanges SET t = 'foo' WHERE id = 1" - numChanges <- changes conn - assertEqual "changed/inserted rows" 1 numChanges - execute_ conn "UPDATE testchanges SET t = 'foo' WHERE id = 100" - numChanges <- changes conn - assertEqual "changed/inserted rows" 0 numChanges - execute_ conn "UPDATE testchanges SET t = 'foo'" - numChanges <- changes conn - assertEqual "changed/inserted rows" 2 numChanges +{-# LANGUAGE OverloadedStrings #-} + +module Simple ( + testSimpleOnePlusOne + , testSimpleSelect + , testSimpleParams + , testSimpleTime + , testSimpleTimeFract + , testSimpleInsertId + , testSimpleMultiInsert + , testSimpleUTCTime + , testSimpleUTCTimeTZ + , testSimpleUTCTimeParams + , testSimpleQueryCov + , testSimpleStrings + , testSimpleChanges + ) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +-- orphan IsString instance in older byteString +import Data.ByteString.Lazy.Char8 () +import Data.Monoid ((<>), mappend, mempty) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Data.Time (UTCTime, Day) + +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 + [Only r] <- query_ conn "SELECT 1.0" :: IO [Only Double] + assertEqual "doubles" 1.0 r + [Only r] <- query_ conn "SELECT 1.0" :: IO [Only Float] + assertEqual "floats" 1.0 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 + [Only r1, Only r2] <- query conn "SELECT t FROM testparams WHERE (id = ? OR id = ?)" (1 :: Int, 2 :: Int) :: IO [Only String] + assertEqual "select params" "test string" r1 + assertEqual "select params" "test2" r2 + [Only i] <- query conn "SELECT ?+?" [42 :: Int, 1 :: Int] :: IO [Only Int] + assertEqual "select int param" 43 i + [Only d] <- query conn "SELECT ?" [2.0 :: Double] :: IO [Only Double] + assertEqual "select double param" 2.0 d + [Only f] <- query conn "SELECT ?" [4.0 :: Float] :: IO [Only Float] + assertEqual "select double param" 4.0 f + +testSimpleTime :: TestEnv -> Test +testSimpleTime TestEnv{..} = TestCase $ do + let timestr = "2012-08-20 20:19:58" + time = read timestr :: UTCTime + execute_ conn "CREATE TABLE time (t TIMESTAMP)" + execute conn "INSERT INTO time (t) VALUES (?)" (Only time) + [Only t] <- query_ conn "SELECT * FROM time" :: IO [Only UTCTime] + assertEqual "UTCTime conv" time t + [Only t] <- query conn "SELECT * FROM time WHERE t = ?" (Only time) :: IO [Only UTCTime] + assertEqual "UTCTime conv2" time t + -- Try inserting timestamp directly as a string + execute_ conn "CREATE TABLE time2 (t TIMESTAMP)" + execute_ conn (Query (T.concat ["INSERT INTO time2 (t) VALUES ('", T.pack timestr, "')"])) + [Only t] <- query_ conn "SELECT * FROM time2" :: IO [Only UTCTime] + assertEqual "UTCTime" time t + rows <- query conn "SELECT * FROM time2 WHERE t = ?" (Only time) :: IO [Only UTCTime] + assertEqual "should see one row result" 1 (length rows) + assertEqual "UTCTime" time t + -- Days + let daystr = "2013-08-21" + day = read daystr :: Day + [Only day'] <- query_ conn (Query (T.concat ["SELECT '", T.pack daystr, "'"])) + day @?= day' + [Only day''] <- query conn "SELECT ?" (Only day) + day @?= day'' + -- database timestamp -> day conversion is treated as an error, but + -- try converting a timestamp to a date and see we get it back ok + [Only dayx] <- query_ conn "SELECT date('2013-08-21 08:00:03.256887')" + day @?= dayx + +testSimpleTimeFract :: TestEnv -> Test +testSimpleTimeFract TestEnv{..} = TestCase $ do + let timestr = "2012-08-17 08:00:03.256887" + time = read timestr :: UTCTime + -- Try inserting timestamp directly as a string + execute_ conn "CREATE TABLE timefract (t TIMESTAMP)" + execute_ conn (Query (T.concat ["INSERT INTO timefract (t) VALUES ('", T.pack timestr, "')"])) + [Only t] <- query_ conn "SELECT * FROM timefract" :: IO [Only UTCTime] + assertEqual "UTCTime" time t + rows <- query conn "SELECT * FROM timefract WHERE t = ?" (Only time) :: IO [Only UTCTime] + assertEqual "should see one row result" 1 (length rows) + assertEqual "UTCTime" time t + +testSimpleInsertId :: TestEnv -> Test +testSimpleInsertId TestEnv{..} = TestCase $ do + execute_ conn "CREATE TABLE test_row_id (id INTEGER PRIMARY KEY, t TEXT)" + execute conn "INSERT INTO test_row_id (t) VALUES (?)" (Only ("test string" :: String)) + id1 <- lastInsertRowId conn + execute_ conn "INSERT INTO test_row_id (t) VALUES ('test2')" + id2 <- lastInsertRowId conn + 1 @=? id1 + 2 @=? id2 + rows <- query conn "SELECT t FROM test_row_id WHERE id = ?" (Only (1 :: Int)) :: IO [Only String] + 1 @=? (length rows) + (Only "test string") @=? (head rows) + [Only row] <- query conn "SELECT t FROM test_row_id WHERE id = ?" (Only (2 :: Int)) :: IO [Only String] + "test2" @=? row + +testSimpleMultiInsert :: TestEnv -> Test +testSimpleMultiInsert TestEnv{..} = TestCase $ do + execute_ conn "CREATE TABLE test_multi_insert (id INTEGER PRIMARY KEY, t1 TEXT, t2 TEXT)" + executeMany conn "INSERT INTO test_multi_insert (t1, t2) VALUES (?, ?)" ([("foo", "bar"), ("baz", "bat")] :: [(String, String)]) + id2 <- lastInsertRowId conn + 2 @=? id2 + + rows <- query_ conn "SELECT id,t1,t2 FROM test_multi_insert" :: IO [(Int, String, String)] + [(1, "foo", "bar"), (2, "baz", "bat")] @=? rows + +testSimpleUTCTime :: TestEnv -> Test +testSimpleUTCTime TestEnv{..} = TestCase $ do + -- Time formats understood by sqlite: http://sqlite.org/lang_datefunc.html + let timestrs = [ "2012-08-17 13:25" + , "2012-08-17 13:25:44" + , "2012-08-17 13:25:44.123" + ] + timestrsWithT = map (T.map (\c -> if c == ' ' then 'T' else c)) timestrs + execute_ conn "CREATE TABLE utctimes (t TIMESTAMP)" + mapM_ (\t -> execute conn "INSERT INTO utctimes (t) VALUES (?)" (Only t)) timestrs + mapM_ (\t -> execute conn "INSERT INTO utctimes (t) VALUES (?)" (Only t)) timestrsWithT + dates <- query_ conn "SELECT t from utctimes" :: IO [Only UTCTime] + mapM_ matchDates (zip (timestrs ++ timestrsWithT) dates) + let zulu = "2012-08-17 13:25" + [d] <- query conn "SELECT ?" (Only (T.append zulu "Z")) + matchDates (zulu, d) + let zulu = "2012-08-17 13:25:00" + [d] <- query conn "SELECT ?" (Only (T.append zulu "Z")) + matchDates (zulu, d) + where + matchDates (str,(Only date)) = do + -- Remove 'T' when reading in to Haskell + let t = read (makeReadable str) :: UTCTime + t @=? date + + makeReadable s = + let s' = if T.length s < T.length "YYYY-MM-DD HH:MM:SS" then T.append s ":00" else s + in T.unpack . T.replace "T" " " $ s' + +testSimpleUTCTimeTZ :: TestEnv -> Test +testSimpleUTCTimeTZ TestEnv{..} = TestCase $ do + -- Time formats understood by sqlite: http://sqlite.org/lang_datefunc.html + let timestrs = [ "2013-02-03 13:00:00-02:00" + , "2013-02-03 13:00:00-01:00" + , "2013-02-03 13:00:00-03:00" + , "2013-02-03 13:00:00Z" + , "2013-02-03 13:00:00+00:00" + , "2013-02-03 13:00:00+03:00" + , "2013-02-03 13:00:00+02:00" + , "2013-02-03 13:00:00+04:00" + ] + execute_ conn "CREATE TABLE utctimestz (t TIMESTAMP)" + mapM_ (\t -> execute conn "INSERT INTO utctimestz (t) VALUES (?)" (Only t)) timestrs + dates <- query_ conn "SELECT t from utctimestz" :: IO [Only UTCTime] + mapM_ matchDates (zip (timestrs) dates) + where + matchDates (str,(Only date)) = do + -- Remove 'T' when reading in to Haskell + let t = read . T.unpack $ str :: UTCTime + t @=? date + +testSimpleUTCTimeParams :: TestEnv -> Test +testSimpleUTCTimeParams TestEnv{..} = TestCase $ do + let times = [ "2012-08-17 08:00:03" + , "2012-08-17 08:00:03.2" + , "2012-08-17 08:00:03.256" + , "2012-08-17 08:00:03.4192" + ] + -- Try inserting timestamp directly as a string + mapM_ assertResult times + where + assertResult tstr = do + let utct = read . T.unpack $ tstr :: UTCTime + [Only t] <- query conn "SELECT ?" (Only utct) :: IO [Only T.Text] + assertEqual "UTCTime" tstr t + +testSimpleQueryCov :: TestEnv -> Test +testSimpleQueryCov TestEnv{..} = TestCase $ do + let str = "SELECT 1+1" :: T.Text + q = "SELECT 1+1" :: Query + fromQuery q @=? str + show str @=? show q + q @=? ((read . show $ q) :: Query) + q @=? q + q @=? (Query "SELECT 1" <> Query "+1") + q @=? foldr mappend mempty ["SELECT ", "1", "+", "1"] + True @=? q <= q + +testSimpleStrings :: TestEnv -> Test +testSimpleStrings TestEnv{..} = TestCase $ do + [Only s] <- query_ conn "SELECT 'str1'" :: IO [Only T.Text] + s @=? "str1" + [Only s] <- query_ conn "SELECT 'strLazy'" :: IO [Only LT.Text] + s @=? "strLazy" + [Only s] <- query conn "SELECT ?" (Only ("strP" :: T.Text)) :: IO [Only T.Text] + s @=? "strP" + [Only s] <- query conn "SELECT ?" (Only ("strPLazy" :: LT.Text)) :: IO [Only T.Text] + s @=? "strPLazy" + -- ByteStrings are blobs in sqlite storage, so use ByteString for + -- both input and output + [Only s] <- query conn "SELECT ?" (Only ("strBsP" :: BS.ByteString)) :: IO [Only BS.ByteString] + s @=? "strBsP" + [Only s] <- query conn "SELECT ?" (Only ("strBsPLazy" :: LBS.ByteString)) :: IO [Only BS.ByteString] + s @=? "strBsPLazy" + [Only s] <- query conn "SELECT ?" (Only ("strBsPLazy2" :: BS.ByteString)) :: IO [Only LBS.ByteString] + s @=? "strBsPLazy2" + +testSimpleChanges :: TestEnv -> Test +testSimpleChanges TestEnv{..} = TestCase $ do + execute_ conn "CREATE TABLE testchanges (id INTEGER PRIMARY KEY, t TEXT)" + execute conn "INSERT INTO testchanges(t) VALUES (?)" (Only ("test string" :: String)) + numChanges <- changes conn + assertEqual "changed/inserted rows" 1 numChanges + execute conn "INSERT INTO testchanges(t) VALUES (?)" (Only ("test string 2" :: String)) + numChanges <- changes conn + assertEqual "changed/inserted rows" 1 numChanges + execute_ conn "UPDATE testchanges SET t = 'foo' WHERE id = 1" + numChanges <- changes conn + assertEqual "changed/inserted rows" 1 numChanges + execute_ conn "UPDATE testchanges SET t = 'foo' WHERE id = 100" + numChanges <- changes conn + assertEqual "changed/inserted rows" 0 numChanges + execute_ conn "UPDATE testchanges SET t = 'foo'" + numChanges <- changes conn + assertEqual "changed/inserted rows" 2 numChanges diff --git a/test/Statement.hs b/test/Statement.hs --- a/test/Statement.hs +++ b/test/Statement.hs @@ -1,50 +1,50 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Statement ( - testBind - , testDoubleBind - , testPreparedStatements - ) where - -import Common -import Data.Maybe(fromJust) - -testBind :: TestEnv -> Test -testBind TestEnv{..} = TestCase $ do - execute_ conn "CREATE TABLE test_bind (id INTEGER PRIMARY KEY, t TEXT)" - execute_ conn "INSERT INTO test_bind VALUES(1, 'result')" - withStatement conn "SELECT t FROM test_bind WHERE id=?" $ \stmt -> - withBind stmt [1::Int] $ do - row <- nextRow stmt :: IO (Maybe (Only String)) - assertEqual "result" (Only "result") (fromJust row) - -testDoubleBind :: TestEnv -> Test -testDoubleBind TestEnv{..} = TestCase $ do - execute_ conn "CREATE TABLE test_double_bind (id INTEGER PRIMARY KEY, t TEXT)" - execute_ conn "INSERT INTO test_double_bind VALUES(1, 'first result')" - execute_ conn "INSERT INTO test_double_bind VALUES(2, 'second result')" - withStatement conn "SELECT t FROM test_double_bind WHERE id=?" $ \stmt -> do - withBind stmt [1::Int] $ do - row <- nextRow stmt :: IO (Maybe (Only String)) - assertEqual "first result" (Only "first result") (fromJust row) - - withBind stmt [2::Int] $ do - row <- nextRow stmt :: IO (Maybe (Only String)) - assertEqual "second result" (Only "second result") (fromJust row) - -testPreparedStatements :: TestEnv -> Test -testPreparedStatements TestEnv{..} = TestCase $ do - execute_ conn "CREATE TABLE ps (id INTEGER PRIMARY KEY, t TEXT)" - execute_ conn "INSERT INTO ps VALUES(1, 'first result')" - execute_ conn "INSERT INTO ps VALUES(2, 'second result')" - withStatement conn "SELECT t FROM ps WHERE id=?" $ \stmt -> do - colName <- columnName stmt 0 - colName @?= "t" - elems <- mapM (queryOne stmt) [1 :: Int, 2] - ["first result" :: String, "second result"] @=? elems - where - queryOne stmt rowId = - withBind stmt (Only rowId) $ do - Just (Only r) <- nextRow stmt - Nothing <- nextRow stmt :: IO (Maybe (Only String)) - return r +{-# LANGUAGE OverloadedStrings #-} + +module Statement ( + testBind + , testDoubleBind + , testPreparedStatements + ) where + +import Common +import Data.Maybe(fromJust) + +testBind :: TestEnv -> Test +testBind TestEnv{..} = TestCase $ do + execute_ conn "CREATE TABLE test_bind (id INTEGER PRIMARY KEY, t TEXT)" + execute_ conn "INSERT INTO test_bind VALUES(1, 'result')" + withStatement conn "SELECT t FROM test_bind WHERE id=?" $ \stmt -> + withBind stmt [1::Int] $ do + row <- nextRow stmt :: IO (Maybe (Only String)) + assertEqual "result" (Only "result") (fromJust row) + +testDoubleBind :: TestEnv -> Test +testDoubleBind TestEnv{..} = TestCase $ do + execute_ conn "CREATE TABLE test_double_bind (id INTEGER PRIMARY KEY, t TEXT)" + execute_ conn "INSERT INTO test_double_bind VALUES(1, 'first result')" + execute_ conn "INSERT INTO test_double_bind VALUES(2, 'second result')" + withStatement conn "SELECT t FROM test_double_bind WHERE id=?" $ \stmt -> do + withBind stmt [1::Int] $ do + row <- nextRow stmt :: IO (Maybe (Only String)) + assertEqual "first result" (Only "first result") (fromJust row) + + withBind stmt [2::Int] $ do + row <- nextRow stmt :: IO (Maybe (Only String)) + assertEqual "second result" (Only "second result") (fromJust row) + +testPreparedStatements :: TestEnv -> Test +testPreparedStatements TestEnv{..} = TestCase $ do + execute_ conn "CREATE TABLE ps (id INTEGER PRIMARY KEY, t TEXT)" + execute_ conn "INSERT INTO ps VALUES(1, 'first result')" + execute_ conn "INSERT INTO ps VALUES(2, 'second result')" + withStatement conn "SELECT t FROM ps WHERE id=?" $ \stmt -> do + colName <- columnName stmt 0 + colName @?= "t" + elems <- mapM (queryOne stmt) [1 :: Int, 2] + ["first result" :: String, "second result"] @=? elems + where + queryOne stmt rowId = + withBind stmt (Only rowId) $ do + Just (Only r) <- nextRow stmt + Nothing <- nextRow stmt :: IO (Maybe (Only String)) + return r diff --git a/test/TestImports.hs b/test/TestImports.hs --- a/test/TestImports.hs +++ b/test/TestImports.hs @@ -1,45 +1,45 @@ - -module TestImports ( - testImports - ) where - --- Test file to test that we can do most things with a single import -import Control.Applicative -import qualified Data.Text as T - -import Common - -data TestType = TestType Int Int Int - --- Hook up sqlite-simple to know how to read Test rows -instance FromRow TestType where - fromRow = TestType <$> field <*> field <*> field - -test1 :: IO () -test1 = do - conn <- open ":memory:" - execute_ conn "CREATE TABLE testimp (id INTEGER PRIMARY KEY, id2 INTEGER, id3 INTEGER)" - execute_ conn "INSERT INTO testimp (id, id2, id3) VALUES (1, 2, 3)" - [_v] <- query_ conn "SELECT * FROM testimp" :: IO [TestType] - [_v] <- query conn "SELECT ?+?" (3::Int,4::Int) :: IO [(Only Int)] - close conn - -test2 :: Connection -> IO () -test2 conn = do - execute_ conn "CREATE TABLE testimp (id INTEGER PRIMARY KEY)" - execute_ conn "INSERT INTO testimp (id) VALUES (1)" - [Only _v] <- query_ conn (Query q) :: IO [Only Int] - return () - where - q = T.concat ["SELECT * FROM ", "testimp"] - -test3 :: Connection -> IO () -test3 conn = do - [_v] <- query conn "SELECT ?+?" (3::Int,4::Int) :: IO [(Only Int)] - return () - -testImports :: TestEnv -> Test -testImports env = TestCase $ do - test1 - withConnection ":memory:" test2 - test3 (conn env) + +module TestImports ( + testImports + ) where + +-- Test file to test that we can do most things with a single import +import Control.Applicative +import qualified Data.Text as T + +import Common + +data TestType = TestType Int Int Int + +-- Hook up sqlite-simple to know how to read Test rows +instance FromRow TestType where + fromRow = TestType <$> field <*> field <*> field + +test1 :: IO () +test1 = do + conn <- open ":memory:" + execute_ conn "CREATE TABLE testimp (id INTEGER PRIMARY KEY, id2 INTEGER, id3 INTEGER)" + execute_ conn "INSERT INTO testimp (id, id2, id3) VALUES (1, 2, 3)" + [_v] <- query_ conn "SELECT * FROM testimp" :: IO [TestType] + [_v] <- query conn "SELECT ?+?" (3::Int,4::Int) :: IO [(Only Int)] + close conn + +test2 :: Connection -> IO () +test2 conn = do + execute_ conn "CREATE TABLE testimp (id INTEGER PRIMARY KEY)" + execute_ conn "INSERT INTO testimp (id) VALUES (1)" + [Only _v] <- query_ conn (Query q) :: IO [Only Int] + return () + where + q = T.concat ["SELECT * FROM ", "testimp"] + +test3 :: Connection -> IO () +test3 conn = do + [_v] <- query conn "SELECT ?+?" (3::Int,4::Int) :: IO [(Only Int)] + return () + +testImports :: TestEnv -> Test +testImports env = TestCase $ do + test1 + withConnection ":memory:" test2 + test3 (conn env) diff --git a/test/UserInstances.hs b/test/UserInstances.hs --- a/test/UserInstances.hs +++ b/test/UserInstances.hs @@ -1,33 +1,33 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module UserInstances (testUserFromField) where - -import Common -import Data.Typeable (Typeable) -import qualified Data.Text as T -import Database.SQLite.Simple.FromField -import Database.SQLite.Simple.Ok -import Database.SQLite.Simple.ToField - -newtype MyType = MyType String deriving (Eq, Show, Typeable) - -instance FromField MyType where - fromField f = cvt f . fieldData $ f where - -- Prefix with "fromField " to really ensure we got here - cvt _ (SQLText s) = Ok $ MyType ("fromField "++(T.unpack s)) - cvt f _ = returnError ConversionFailed f "expecting SQLText type" - -instance ToField MyType where - -- Prefix with "toField " to really ensure we got here - toField (MyType s) = SQLText . T.pack $ ("toField " ++ s) - -testUserFromField :: TestEnv -> Test -testUserFromField TestEnv{..} = TestCase $ do - execute_ conn "CREATE TABLE fromfield (t TEXT)" - execute conn "INSERT INTO fromfield (t) VALUES (?)" (Only ("test string" :: String)) - [Only r] <- query_ conn "SELECT t FROM fromfield" :: IO [(Only MyType)] - (MyType "fromField test string") @=? r - execute_ conn "DELETE FROM fromfield" - execute conn "INSERT INTO fromfield (t) VALUES (?)" (Only (MyType "test2")) - [Only r] <- query_ conn "SELECT t FROM fromfield" :: IO [(Only String)] - "toField test2" @=? r +{-# LANGUAGE DeriveDataTypeable #-} + +module UserInstances (testUserFromField) where + +import Common +import Data.Typeable (Typeable) +import qualified Data.Text as T +import Database.SQLite.Simple.FromField +import Database.SQLite.Simple.Ok +import Database.SQLite.Simple.ToField + +newtype MyType = MyType String deriving (Eq, Show, Typeable) + +instance FromField MyType where + fromField f = cvt f . fieldData $ f where + -- Prefix with "fromField " to really ensure we got here + cvt _ (SQLText s) = Ok $ MyType ("fromField "++(T.unpack s)) + cvt f _ = returnError ConversionFailed f "expecting SQLText type" + +instance ToField MyType where + -- Prefix with "toField " to really ensure we got here + toField (MyType s) = SQLText . T.pack $ ("toField " ++ s) + +testUserFromField :: TestEnv -> Test +testUserFromField TestEnv{..} = TestCase $ do + execute_ conn "CREATE TABLE fromfield (t TEXT)" + execute conn "INSERT INTO fromfield (t) VALUES (?)" (Only ("test string" :: String)) + [Only r] <- query_ conn "SELECT t FROM fromfield" :: IO [(Only MyType)] + (MyType "fromField test string") @=? r + execute_ conn "DELETE FROM fromfield" + execute conn "INSERT INTO fromfield (t) VALUES (?)" (Only (MyType "test2")) + [Only r] <- query_ conn "SELECT t FROM fromfield" :: IO [(Only String)] + "toField test2" @=? r diff --git a/test/Utf8Strings.hs b/test/Utf8Strings.hs --- a/test/Utf8Strings.hs +++ b/test/Utf8Strings.hs @@ -1,28 +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) +-- -*- 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)