├── .ghci ├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── Database └── SQLite │ ├── Simple.hs │ └── Simple │ ├── FromField.hs │ ├── FromRow.hs │ ├── Function.hs │ ├── Internal.hs │ ├── Ok.hs │ ├── QQ.hs │ ├── Time.hs │ ├── Time │ └── Implementation.hs │ ├── ToField.hs │ ├── ToRow.hs │ └── Types.hs ├── LICENSE ├── README.md ├── Setup.hs ├── changelog ├── devenv.sh ├── sqlite-simple.cabal ├── stack-9.0.yaml ├── stack-9.2.yaml ├── stack-9.4.yaml ├── stack-9.6.yaml ├── stack.yaml └── test ├── Common.hs ├── Debug.hs ├── DirectSqlite.hs ├── Errors.hs ├── Fold.hs ├── Function.hs ├── Main.hs ├── ParamConv.hs ├── QQ.hs ├── Simple.hs ├── Statement.hs ├── TestImports.hs ├── UserInstances.hs └── Utf8Strings.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -XNamedFieldPuns 2 | :set -XOverloadedStrings 3 | :set -XRank2Types 4 | :set -XRecordWildCards 5 | :set -XDoAndIfThenElse 6 | :set -XOverloadedStrings 7 | :set -XBangPatterns 8 | :set -XViewPatterns 9 | :set -XTypeOperators 10 | :set -Wall 11 | :set -fno-warn-name-shadowing 12 | :set -i. 13 | :set -itest 14 | -------------------------------------------------------------------------------- /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci '--distribution' 'jammy' 'github' 'sqlite-simple.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.18.1 12 | # 13 | # REGENDATA ("0.18.1",["--distribution","jammy","github","sqlite-simple.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-20.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.8.2 32 | compilerKind: ghc 33 | compilerVersion: 9.8.2 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-9.6.4 37 | compilerKind: ghc 38 | compilerVersion: 9.6.4 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.4.8 42 | compilerKind: ghc 43 | compilerVersion: 9.4.8 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.2.8 47 | compilerKind: ghc 48 | compilerVersion: 9.2.8 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-9.0.2 52 | compilerKind: ghc 53 | compilerVersion: 9.0.2 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-8.10.7 57 | compilerKind: ghc 58 | compilerVersion: 8.10.7 59 | setup-method: ghcup 60 | allow-failure: false 61 | - compiler: ghc-8.8.4 62 | compilerKind: ghc 63 | compilerVersion: 8.8.4 64 | setup-method: ghcup 65 | allow-failure: false 66 | fail-fast: false 67 | steps: 68 | - name: apt 69 | run: | 70 | apt-get update 71 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 72 | mkdir -p "$HOME/.ghcup/bin" 73 | curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup" 74 | chmod a+x "$HOME/.ghcup/bin/ghcup" 75 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 76 | "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 77 | env: 78 | HCKIND: ${{ matrix.compilerKind }} 79 | HCNAME: ${{ matrix.compiler }} 80 | HCVER: ${{ matrix.compilerVersion }} 81 | - name: Set PATH and environment variables 82 | run: | 83 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 84 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 85 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 86 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 87 | HCDIR=/opt/$HCKIND/$HCVER 88 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 89 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 90 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 91 | echo "HC=$HC" >> "$GITHUB_ENV" 92 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 93 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 94 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" 95 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 96 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 97 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 98 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 99 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 100 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 101 | echo "GHCJSARITH=0" >> "$GITHUB_ENV" 102 | env: 103 | HCKIND: ${{ matrix.compilerKind }} 104 | HCNAME: ${{ matrix.compiler }} 105 | HCVER: ${{ matrix.compilerVersion }} 106 | - name: env 107 | run: | 108 | env 109 | - name: write cabal config 110 | run: | 111 | mkdir -p $CABAL_DIR 112 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 145 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 146 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 147 | rm -f cabal-plan.xz 148 | chmod a+x $HOME/.cabal/bin/cabal-plan 149 | cabal-plan --version 150 | - name: checkout 151 | uses: actions/checkout@v3 152 | with: 153 | path: source 154 | - name: initial cabal.project for sdist 155 | run: | 156 | touch cabal.project 157 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 158 | cat cabal.project 159 | - name: sdist 160 | run: | 161 | mkdir -p sdist 162 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 163 | - name: unpack 164 | run: | 165 | mkdir -p unpacked 166 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 167 | - name: generate cabal.project 168 | run: | 169 | PKGDIR_sqlite_simple="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/sqlite-simple-[0-9.]*')" 170 | echo "PKGDIR_sqlite_simple=${PKGDIR_sqlite_simple}" >> "$GITHUB_ENV" 171 | rm -f cabal.project cabal.project.local 172 | touch cabal.project 173 | touch cabal.project.local 174 | echo "packages: ${PKGDIR_sqlite_simple}" >> cabal.project 175 | echo "package sqlite-simple" >> cabal.project 176 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 177 | cat >> cabal.project <> cabal.project.local 180 | cat cabal.project 181 | cat cabal.project.local 182 | - name: dump install plan 183 | run: | 184 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 185 | cabal-plan 186 | - name: restore cache 187 | uses: actions/cache/restore@v3 188 | with: 189 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 190 | path: ~/.cabal/store 191 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 192 | - name: install dependencies 193 | run: | 194 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 195 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 196 | - name: build w/o tests 197 | run: | 198 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 199 | - name: build 200 | run: | 201 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 202 | - name: tests 203 | run: | 204 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 205 | - name: cabal check 206 | run: | 207 | cd ${PKGDIR_sqlite_simple} || false 208 | ${CABAL} -vnormal check 209 | - name: haddock 210 | run: | 211 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 212 | - name: unconstrained build 213 | run: | 214 | rm -f cabal.project.local 215 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 216 | - name: save cache 217 | uses: actions/cache/save@v3 218 | if: always() 219 | with: 220 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 221 | path: ~/.cabal/store 222 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /dist-newstyle/ 2 | /.stack-work/ 3 | /stack.yaml.lock 4 | /stack-*.yaml.lock 5 | -------------------------------------------------------------------------------- /Database/SQLite/Simple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables, GADTs #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- | 5 | -- Module: Database.SQLite.Simple 6 | -- Copyright: (c) 2011 MailRank, Inc. 7 | -- (c) 2011-2012 Leon P Smith 8 | -- (c) 2012-2013 Janne Hellsten 9 | -- License: BSD3 10 | -- Maintainer: Janne Hellsten 11 | -- Portability: portable 12 | -- 13 | ------------------------------------------------------------------------------ 14 | 15 | module Database.SQLite.Simple ( 16 | -- ** Examples of use 17 | -- $use 18 | 19 | -- ** The Query type 20 | -- $querytype 21 | 22 | -- ** Parameter substitution 23 | -- $subst 24 | 25 | -- *** Positional parameters 26 | -- $substpos 27 | 28 | -- *** Named parameters 29 | -- $substnamed 30 | 31 | -- *** Type inference 32 | -- $inference 33 | 34 | -- ** Substituting a single parameter 35 | -- $only_param 36 | 37 | -- * Extracting results 38 | -- $result 39 | 40 | -- ** Handling null values 41 | -- $null 42 | 43 | -- ** Type conversions 44 | -- $types 45 | 46 | -- *** Conversion to/from UTCTime 47 | -- $utctime 48 | 49 | Query(..) 50 | , Connection(..) 51 | , ToRow(..) 52 | , FromRow(..) 53 | , Only(..) 54 | , (:.)(..) 55 | , Base.SQLData(..) 56 | , Statement(..) 57 | , ColumnIndex(..) 58 | , NamedParam(..) 59 | -- * Connections 60 | , open 61 | , close 62 | , withConnection 63 | , setTrace 64 | -- * Queries that return results 65 | , query 66 | , query_ 67 | , queryWith 68 | , queryWith_ 69 | , queryNamed 70 | , lastInsertRowId 71 | , changes 72 | , totalChanges 73 | -- * Queries that stream results 74 | , fold 75 | , fold_ 76 | , foldNamed 77 | -- * Statements that do not return results 78 | , execute 79 | , execute_ 80 | , executeMany 81 | , executeNamed 82 | , field 83 | -- * Transactions 84 | , withTransaction 85 | , withImmediateTransaction 86 | , withExclusiveTransaction 87 | , withSavepoint 88 | -- * Low-level statement API for stream access and prepared statements 89 | , openStatement 90 | , closeStatement 91 | , withStatement 92 | , bind 93 | , bindNamed 94 | , reset 95 | , columnName 96 | , columnCount 97 | , withBind 98 | , nextRow 99 | -- ** Exceptions 100 | , FormatError(..) 101 | , ResultError(..) 102 | , Base.SQLError(..) 103 | , Base.Error(..) 104 | ) where 105 | 106 | import Control.Exception 107 | import Control.Monad (void, when, forM_) 108 | import Control.Monad.Trans.Reader 109 | import Control.Monad.Trans.State.Strict 110 | import Data.Int (Int64) 111 | import Data.IORef 112 | import qualified Data.Text as T 113 | import qualified Data.Text.Encoding as TE 114 | import Data.Typeable (Typeable) 115 | import Database.SQLite.Simple.Types 116 | import qualified Database.SQLite3 as Base 117 | import qualified Database.SQLite3.Direct as BaseD 118 | 119 | 120 | import Database.SQLite.Simple.FromField (ResultError(..)) 121 | import Database.SQLite.Simple.FromRow 122 | import Database.SQLite.Simple.Internal 123 | import Database.SQLite.Simple.Ok 124 | import Database.SQLite.Simple.ToField (ToField(..)) 125 | import Database.SQLite.Simple.ToRow (ToRow(..)) 126 | 127 | -- | An SQLite prepared statement. 128 | newtype Statement = Statement { unStatement :: Base.Statement } 129 | 130 | -- | Index of a column in a result set. Column indices start from 0. 131 | newtype ColumnIndex = ColumnIndex BaseD.ColumnIndex 132 | deriving (Eq, Ord, Enum, Num, Real, Integral) 133 | 134 | data NamedParam where 135 | (:=) :: (ToField v) => T.Text -> v -> NamedParam 136 | 137 | data TransactionType 138 | = Deferred 139 | | Immediate 140 | | Exclusive 141 | | Savepoint T.Text 142 | 143 | infixr 3 := 144 | 145 | instance Show NamedParam where 146 | show (k := v) = show (k, toField v) 147 | 148 | -- | Exception thrown if a 'Query' was malformed. 149 | -- This may occur if the number of \'@?@\' characters in the query 150 | -- string does not match the number of parameters provided. 151 | data FormatError = FormatError { 152 | fmtMessage :: String 153 | , fmtQuery :: Query 154 | , fmtParams :: [String] 155 | } deriving (Eq, Show, Typeable) 156 | 157 | instance Exception FormatError 158 | 159 | -- | Open a database connection to a given file. Will throw an 160 | -- exception if it cannot connect. 161 | -- 162 | -- Every 'open' must be closed with a call to 'close'. 163 | -- 164 | -- If you specify \":memory:\" or an empty string as the input filename, 165 | -- then a private, temporary in-memory database is created for the 166 | -- connection. This database will vanish when you close the 167 | -- connection. 168 | open :: String -> IO Connection 169 | open fname = Connection <$> Base.open (T.pack fname) <*> newIORef 0 170 | 171 | -- | Close a database connection. 172 | close :: Connection -> IO () 173 | close = Base.close . connectionHandle 174 | 175 | -- | Opens a database connection, executes an action using this connection, and 176 | -- closes the connection, even in the presence of exceptions. 177 | withConnection :: String -> (Connection -> IO a) -> IO a 178 | withConnection connString = bracket (open connString) close 179 | 180 | unUtf8 :: BaseD.Utf8 -> T.Text 181 | unUtf8 (BaseD.Utf8 bs) = TE.decodeUtf8 bs 182 | 183 | -- | 184 | -- 185 | -- Enable/disable tracing of SQL execution. Tracing can be disabled 186 | -- by setting 'Nothing' as the logger callback. 187 | -- 188 | -- Warning: If the logger callback throws an exception, your whole 189 | -- program may crash. Enable only for debugging! 190 | setTrace :: Connection -> Maybe (T.Text -> IO ()) -> IO () 191 | setTrace conn logger = 192 | BaseD.setTrace (connectionHandle conn) (fmap (\lf -> lf . unUtf8) logger) 193 | 194 | -- | Binds parameters to a prepared statement. Once 'nextRow' returns 'Nothing', 195 | -- the statement must be reset with the 'reset' function before it can be 196 | -- executed again by calling 'nextRow'. 197 | bind :: (ToRow params) => Statement -> params -> IO () 198 | bind (Statement stmt) params = do 199 | let qp = toRow params 200 | stmtParamCount <- Base.bindParameterCount stmt 201 | when (length qp /= fromIntegral stmtParamCount) (throwColumnMismatch qp stmtParamCount) 202 | mapM_ (errorCheckParamName qp) [1..stmtParamCount] 203 | Base.bind stmt qp 204 | where 205 | throwColumnMismatch qp nParams = do 206 | templ <- getQuery stmt 207 | fmtError ("SQL query contains " ++ show nParams ++ " params, but " ++ 208 | show (length qp) ++ " arguments given") templ qp 209 | errorCheckParamName qp paramNdx = do 210 | templ <- getQuery stmt 211 | name <- Base.bindParameterName stmt paramNdx 212 | case name of 213 | Just n -> 214 | fmtError ("Only unnamed '?' query parameters are accepted, '"++T.unpack n++"' given") 215 | templ qp 216 | Nothing -> return $! () 217 | 218 | -- | Binds named parameters to a prepared statement. 219 | bindNamed :: Statement -> [NamedParam] -> IO () 220 | bindNamed (Statement stmt) params = do 221 | stmtParamCount <- Base.bindParameterCount stmt 222 | when (length params /= fromIntegral stmtParamCount) $ throwColumnMismatch stmtParamCount 223 | bind stmt params 224 | where 225 | bind stmt params = 226 | mapM_ (\(n := v) -> do 227 | idx <- BaseD.bindParameterIndex stmt (BaseD.Utf8 . TE.encodeUtf8 $ n) 228 | case idx of 229 | Just i -> 230 | Base.bindSQLData stmt i (toField v) 231 | Nothing -> do 232 | templ <- getQuery stmt 233 | fmtError ("Unknown named parameter '" ++ T.unpack n ++ "'") 234 | templ params) 235 | params 236 | 237 | throwColumnMismatch nParams = do 238 | templ <- getQuery stmt 239 | fmtError ("SQL query contains " ++ show nParams ++ " params, but " ++ 240 | show (length params) ++ " arguments given") templ params 241 | 242 | -- | Resets a statement. This does not reset bound parameters, if any, but 243 | -- allows the statement to be reexecuted again by invoking 'nextRow'. 244 | reset :: Statement -> IO () 245 | reset (Statement stmt) = Base.reset stmt 246 | 247 | -- | Return the name of a particular column in the result set of a 248 | -- 'Statement'. Throws an 'ArrayException' if the colum index is out 249 | -- of bounds. 250 | -- 251 | -- 252 | columnName :: Statement -> ColumnIndex -> IO T.Text 253 | columnName (Statement stmt) (ColumnIndex n) = BaseD.columnName stmt n >>= takeUtf8 254 | where 255 | takeUtf8 (Just s) = return $ unUtf8 s 256 | takeUtf8 Nothing = 257 | throwIO (IndexOutOfBounds ("Column index " ++ show n ++ " out of bounds")) 258 | 259 | -- | Return number of columns in the query 260 | columnCount :: Statement -> IO ColumnIndex 261 | columnCount (Statement stmt) = ColumnIndex <$> BaseD.columnCount stmt 262 | 263 | -- | Binds parameters to a prepared statement, and 'reset's the statement when 264 | -- the callback completes, even in the presence of exceptions. 265 | -- 266 | -- Use 'withBind' to reuse prepared statements. Because it 'reset's the 267 | -- statement /after/ each usage, it avoids a pitfall involving implicit 268 | -- transactions. SQLite creates an implicit transaction if you don't say 269 | -- @BEGIN@ explicitly, and does not commit it until all active statements are 270 | -- finished with either 'reset' or 'closeStatement'. 271 | withBind :: (ToRow params) => Statement -> params -> IO a -> IO a 272 | withBind stmt params io = do 273 | bind stmt params 274 | io `finally` reset stmt 275 | 276 | -- | Opens a prepared statement. A prepared statement must always be closed with 277 | -- a corresponding call to 'closeStatement' before closing the connection. Use 278 | -- 'nextRow' to iterate on the values returned. Once 'nextRow' returns 279 | -- 'Nothing', you need to invoke 'reset' before reexecuting the statement again 280 | -- with 'nextRow'. 281 | openStatement :: Connection -> Query -> IO Statement 282 | openStatement conn (Query t) = do 283 | stmt <- Base.prepare (connectionHandle conn) t 284 | return $ Statement stmt 285 | 286 | -- | Closes a prepared statement. 287 | closeStatement :: Statement -> IO () 288 | closeStatement (Statement stmt) = Base.finalize stmt 289 | 290 | -- | Opens a prepared statement, executes an action using this statement, and 291 | -- closes the statement, even in the presence of exceptions. 292 | withStatement :: Connection -> Query -> (Statement -> IO a) -> IO a 293 | withStatement conn query = bracket (openStatement conn query) closeStatement 294 | 295 | -- A version of 'withStatement' which binds parameters. 296 | withStatementParams :: (ToRow params) 297 | => Connection 298 | -> Query 299 | -> params 300 | -> (Statement -> IO a) 301 | -> IO a 302 | withStatementParams conn template params action = 303 | withStatement conn template $ \stmt -> 304 | -- Don't use withBind here, there is no need to reset the parameters since 305 | -- we're destroying the statement 306 | bind stmt (toRow params) >> action stmt 307 | 308 | -- A version of 'withStatement' which binds named parameters. 309 | withStatementNamedParams :: Connection 310 | -> Query 311 | -> [NamedParam] 312 | -> (Statement -> IO a) 313 | -> IO a 314 | withStatementNamedParams conn template namedParams action = 315 | withStatement conn template $ \stmt -> bindNamed stmt namedParams >> action stmt 316 | 317 | -- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not 318 | -- expected to return results. 319 | -- 320 | -- Throws 'FormatError' if the query could not be formatted correctly. 321 | execute :: (ToRow q) => Connection -> Query -> q -> IO () 322 | execute conn template qs = 323 | withStatementParams conn template qs $ \(Statement stmt) -> 324 | void . Base.step $ stmt 325 | 326 | -- | Execute a multi-row @INSERT@, @UPDATE@, or other SQL query that is not 327 | -- expected to return results. 328 | -- 329 | -- Throws 'FormatError' if the query could not be formatted correctly. 330 | executeMany :: ToRow q => Connection -> Query -> [q] -> IO () 331 | executeMany conn template paramRows = withStatement conn template $ \stmt -> do 332 | let Statement stmt' = stmt 333 | forM_ paramRows $ \params -> 334 | withBind stmt params 335 | (void . Base.step $ stmt') 336 | 337 | 338 | doFoldToList :: RowParser row -> Statement -> IO [row] 339 | doFoldToList fromRow_ stmt = 340 | fmap reverse $ doFold fromRow_ stmt [] (\acc e -> return (e : acc)) 341 | 342 | -- | Perform a @SELECT@ or other SQL query that is expected to return 343 | -- results. All results are retrieved and converted before this 344 | -- function returns. 345 | -- 346 | -- When processing large results, this function will consume a lot of 347 | -- client-side memory. Consider using 'fold' instead. 348 | -- 349 | -- Exceptions that may be thrown: 350 | -- 351 | -- * 'FormatError': the query string mismatched with given arguments. 352 | -- 353 | -- * 'ResultError': result conversion failed. 354 | query :: (ToRow q, FromRow r) 355 | => Connection -> Query -> q -> IO [r] 356 | query = queryWith fromRow 357 | 358 | -- | A version of 'query' that does not perform query substitution. 359 | query_ :: (FromRow r) => Connection -> Query -> IO [r] 360 | query_ = queryWith_ fromRow 361 | 362 | -- | A version of 'query' that takes an explicit 'RowParser'. 363 | queryWith :: (ToRow q) => RowParser r -> Connection -> Query -> q -> IO [r] 364 | queryWith fromRow_ conn templ qs = 365 | withStatementParams conn templ qs $ \stmt -> doFoldToList fromRow_ stmt 366 | 367 | -- | A version of 'query' that does not perform query substitution and 368 | -- takes an explicit 'RowParser'. 369 | queryWith_ :: RowParser r -> Connection -> Query -> IO [r] 370 | queryWith_ fromRow_ conn query = 371 | withStatement conn query (doFoldToList fromRow_) 372 | 373 | -- | A version of 'query' where the query parameters (placeholders) 374 | -- are named. 375 | -- 376 | -- Example: 377 | -- 378 | -- @ 379 | -- r \<- 'queryNamed' c \"SELECT * FROM posts WHERE id=:id AND date>=:date\" [\":id\" ':=' postId, \":date\" ':=' afterDate] 380 | -- @ 381 | queryNamed :: (FromRow r) => Connection -> Query -> [NamedParam] -> IO [r] 382 | queryNamed conn templ params = 383 | withStatementNamedParams conn templ params $ \stmt -> doFoldToList fromRow stmt 384 | 385 | -- | A version of 'execute' that does not perform query substitution. 386 | execute_ :: Connection -> Query -> IO () 387 | execute_ conn template = 388 | withStatement conn template $ \(Statement stmt) -> 389 | void $ Base.step stmt 390 | 391 | -- | A version of 'execute' where the query parameters (placeholders) 392 | -- are named. 393 | executeNamed :: Connection -> Query -> [NamedParam] -> IO () 394 | executeNamed conn template params = 395 | withStatementNamedParams conn template params $ \(Statement stmt) -> 396 | void $ Base.step stmt 397 | 398 | -- | Perform a @SELECT@ or other SQL query that is expected to return results. 399 | -- Results are converted and fed into the 'action' callback as they are being 400 | -- retrieved from the database. 401 | -- 402 | -- This allows gives the possibility of processing results in constant space 403 | -- (for instance writing them to disk). 404 | -- 405 | -- Exceptions that may be thrown: 406 | -- 407 | -- * 'FormatError': the query string mismatched with given arguments. 408 | -- 409 | -- * 'ResultError': result conversion failed. 410 | fold :: ( FromRow row, ToRow params ) 411 | => Connection 412 | -> Query 413 | -> params 414 | -> a 415 | -> (a -> row -> IO a) 416 | -> IO a 417 | fold conn query params initalState action = 418 | withStatementParams conn query params $ \stmt -> 419 | doFold fromRow stmt initalState action 420 | 421 | -- | A version of 'fold' which does not perform parameter substitution. 422 | fold_ :: ( FromRow row ) 423 | => Connection 424 | -> Query 425 | -> a 426 | -> (a -> row -> IO a) 427 | -> IO a 428 | fold_ conn query initalState action = 429 | withStatement conn query $ \stmt -> 430 | doFold fromRow stmt initalState action 431 | 432 | -- | A version of 'fold' where the query parameters (placeholders) are 433 | -- named. 434 | foldNamed :: ( FromRow row ) 435 | => Connection 436 | -> Query 437 | -> [NamedParam] 438 | -> a 439 | -> (a -> row -> IO a) 440 | -> IO a 441 | foldNamed conn query params initalState action = 442 | withStatementNamedParams conn query params $ \stmt -> 443 | doFold fromRow stmt initalState action 444 | 445 | doFold :: RowParser row -> Statement -> a -> (a -> row -> IO a) -> IO a 446 | doFold fromRow_ stmt initState action = 447 | loop initState 448 | where 449 | loop val = do 450 | maybeNextRow <- nextRowWith fromRow_ stmt 451 | case maybeNextRow of 452 | Just row -> do 453 | val' <- action val row 454 | val' `seq` loop val' 455 | Nothing -> return val 456 | 457 | -- | Extracts the next row from the prepared statement. 458 | nextRow :: (FromRow r) => Statement -> IO (Maybe r) 459 | nextRow = nextRowWith fromRow 460 | 461 | nextRowWith :: RowParser r -> Statement -> IO (Maybe r) 462 | nextRowWith fromRow_ (Statement stmt) = do 463 | statRes <- Base.step stmt 464 | case statRes of 465 | Base.Row -> do 466 | rowRes <- Base.columns stmt 467 | let nCols = length rowRes 468 | row <- convertRow fromRow_ rowRes nCols 469 | return $ Just row 470 | Base.Done -> return Nothing 471 | 472 | convertRow :: RowParser r -> [Base.SQLData] -> Int -> IO r 473 | convertRow fromRow_ rowRes ncols = do 474 | let rw = RowParseRO ncols 475 | case runStateT (runReaderT (unRP fromRow_) rw) (0, rowRes) of 476 | Ok (val,(col,_)) 477 | | col == ncols -> return val 478 | | otherwise -> errorColumnMismatch (ColumnOutOfBounds col) 479 | Errors [] -> throwIO $ ConversionFailed "" "" "unknown error" 480 | Errors [x] -> 481 | throw x `Control.Exception.catch` (\e -> errorColumnMismatch (e :: ColumnOutOfBounds)) 482 | Errors xs -> throwIO $ ManyErrors xs 483 | where 484 | errorColumnMismatch :: ColumnOutOfBounds -> IO r 485 | errorColumnMismatch (ColumnOutOfBounds c) = do 486 | let vals = map (\f -> (gettypename f, ellipsis f)) rowRes 487 | throwIO (ConversionFailed 488 | (show ncols ++ " values: " ++ show vals) 489 | ("at least " ++ show c ++ " slots in target type") 490 | "mismatch between number of columns to convert and number in target type") 491 | 492 | ellipsis :: Base.SQLData -> T.Text 493 | ellipsis sql 494 | | T.length bs > 20 = T.take 15 bs `T.append` "[...]" 495 | | otherwise = bs 496 | where 497 | bs = T.pack $ show sql 498 | 499 | withTransactionPrivate :: Connection -> IO a -> TransactionType -> IO a 500 | withTransactionPrivate conn action ttype = 501 | mask $ \restore -> do 502 | begin 503 | r <- restore action `onException` rollback 504 | commit 505 | return r 506 | where 507 | begin = execute_ conn $ case ttype of 508 | Deferred -> "BEGIN TRANSACTION" 509 | Immediate -> "BEGIN IMMEDIATE TRANSACTION" 510 | Exclusive -> "BEGIN EXCLUSIVE TRANSACTION" 511 | Savepoint name -> Query $ "SAVEPOINT '" <> name <> "'" 512 | commit = execute_ conn $ case ttype of 513 | Savepoint name -> Query $ "RELEASE '" <> name <> "'" 514 | _ -> "COMMIT TRANSACTION" 515 | rollback = execute_ conn $ case ttype of 516 | Savepoint name -> Query $ "ROLLBACK TO '" <> name <> "'" 517 | _ -> "ROLLBACK TRANSACTION" 518 | 519 | 520 | -- | Run an IO action inside a SQL transaction started with @BEGIN IMMEDIATE 521 | -- TRANSACTION@, which immediately blocks all other database connections from 522 | -- writing. The default SQLite3 @BEGIN TRANSACTION@ does not acquire the write 523 | -- lock on @BEGIN@ nor on @SELECT@ but waits until you try to change data. If 524 | -- the action throws any kind of an exception, the transaction will be rolled 525 | -- back with @ROLLBACK TRANSACTION@. Otherwise the results are committed with 526 | -- @COMMIT TRANSACTION@. 527 | withImmediateTransaction :: Connection -> IO a -> IO a 528 | withImmediateTransaction conn action = 529 | withTransactionPrivate conn action Immediate 530 | 531 | -- | Run an IO action inside a SQL transaction started with @BEGIN EXCLUSIVE 532 | -- TRANSACTION@, which immediately blocks all other database connections from 533 | -- writing, and other connections from reading (exception: read_uncommitted 534 | -- connections are allowed to read.) If the action throws any kind of an 535 | -- exception, the transaction will be rolled back with @ROLLBACK TRANSACTION@. 536 | -- Otherwise the results are committed with @COMMIT TRANSACTION@. 537 | withExclusiveTransaction :: Connection -> IO a -> IO a 538 | withExclusiveTransaction conn action = 539 | withTransactionPrivate conn action Exclusive 540 | 541 | -- | Returns the rowid of the most recent successful INSERT on the 542 | -- given database connection. 543 | -- 544 | -- See also . 545 | lastInsertRowId :: Connection -> IO Int64 546 | lastInsertRowId = BaseD.lastInsertRowId . connectionHandle 547 | 548 | -- | 549 | -- 550 | -- Return the number of rows that were changed, inserted, or deleted 551 | -- by the most recent @INSERT@, @DELETE@, or @UPDATE@ statement. 552 | changes :: Connection -> IO Int 553 | changes = BaseD.changes . connectionHandle 554 | 555 | -- | 556 | -- 557 | -- Return the total number of row changes caused by @INSERT@, @DELETE@, 558 | -- or @UPDATE@ statements since the 'Database' was opened. 559 | totalChanges :: Connection -> IO Int 560 | totalChanges = BaseD.totalChanges . connectionHandle 561 | 562 | -- | Run an IO action inside a SQL transaction started with @BEGIN 563 | -- TRANSACTION@. If the action throws any kind of an exception, the 564 | -- transaction will be rolled back with @ROLLBACK TRANSACTION@. 565 | -- Otherwise the results are committed with @COMMIT TRANSACTION@. 566 | withTransaction :: Connection -> IO a -> IO a 567 | withTransaction conn action = 568 | withTransactionPrivate conn action Deferred 569 | 570 | -- | Run an IO action inside an SQLite @SAVEPOINT@. If the action throws any 571 | -- kind of an exception, the transaction will be rolled back to the savepoint 572 | -- with @ROLLBACK TO@. Otherwise the results are released to the outer 573 | -- transaction if any with @RELEASE@. 574 | -- 575 | -- See for a full description of 576 | -- savepoint semantics. 577 | withSavepoint :: Connection -> IO a -> IO a 578 | withSavepoint conn action = do 579 | n <- atomicModifyIORef' (connectionTempNameCounter conn) $ \n -> (n + 1, n) 580 | withTransactionPrivate conn action $ 581 | Savepoint $ "sqlite_simple_savepoint_" <> T.pack (show n) 582 | 583 | fmtError :: Show v => String -> Query -> [v] -> a 584 | fmtError msg q xs = 585 | throw FormatError { 586 | fmtMessage = msg 587 | , fmtQuery = q 588 | , fmtParams = map show xs 589 | } 590 | 591 | getQuery :: Base.Statement -> IO Query 592 | getQuery stmt = 593 | toQuery <$> BaseD.statementSql stmt 594 | where 595 | toQuery = 596 | Query . maybe "no query string" (\(BaseD.Utf8 s) -> TE.decodeUtf8 s) 597 | 598 | -- $use 599 | -- An example that creates a table 'test', inserts a couple of rows 600 | -- and proceeds to showcase how to update or delete rows. This 601 | -- example also demonstrates the use of 'lastInsertRowId' (how to 602 | -- refer to a previously inserted row) and 'executeNamed' (an easier 603 | -- to maintain form of query parameter naming). 604 | -- 605 | -- >{-# LANGUAGE OverloadedStrings #-} 606 | -- > 607 | -- >import Control.Applicative 608 | -- >import qualified Data.Text as T 609 | -- >import Database.SQLite.Simple 610 | -- >import Database.SQLite.Simple.FromRow 611 | -- > 612 | -- >data TestField = TestField Int T.Text deriving (Show) 613 | -- > 614 | -- >instance FromRow TestField where 615 | -- > fromRow = TestField <$> field <*> field 616 | -- > 617 | -- >instance ToRow TestField where 618 | -- > toRow (TestField id_ str) = toRow (id_, str) 619 | -- > 620 | -- >main :: IO () 621 | -- >main = do 622 | -- > conn <- open "test.db" 623 | -- > execute_ conn "CREATE TABLE IF NOT EXISTS test (id INTEGER PRIMARY KEY, str TEXT)" 624 | -- > execute conn "INSERT INTO test (str) VALUES (?)" (Only ("test string 2" :: String)) 625 | -- > execute conn "INSERT INTO test (id, str) VALUES (?,?)" (TestField 13 "test string 3") 626 | -- > rowId <- lastInsertRowId conn 627 | -- > executeNamed conn "UPDATE test SET str = :str WHERE id = :id" [":str" := ("updated str" :: T.Text), ":id" := rowId] 628 | -- > r <- query_ conn "SELECT * from test" :: IO [TestField] 629 | -- > mapM_ print r 630 | -- > execute conn "DELETE FROM test WHERE id = ?" (Only rowId) 631 | -- > close conn 632 | 633 | -- $querytype 634 | -- 635 | -- SQL-based applications are somewhat notorious for their 636 | -- susceptibility to attacks through the injection of maliciously 637 | -- crafted data. The primary reason for widespread vulnerability to 638 | -- SQL injections is that many applications are sloppy in handling 639 | -- user data when constructing SQL queries. 640 | -- 641 | -- This library provides a 'Query' type and a parameter substitution 642 | -- facility to address both ease of use and security. A 'Query' is a 643 | -- @newtype@-wrapped 'Text'. It intentionally exposes a tiny API that 644 | -- is not compatible with the 'Text' API; this makes it difficult to 645 | -- construct queries from fragments of strings. The 'query' and 646 | -- 'execute' functions require queries to be of type 'Query'. 647 | -- 648 | -- To most easily construct a query, enable GHC's @OverloadedStrings@ 649 | -- language extension and write your query as a normal literal string. 650 | -- 651 | -- > {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} 652 | -- > 653 | -- > import Database.SQLite.Simple 654 | -- > 655 | -- > hello = do 656 | -- > conn <- open "test.db" 657 | -- > [[x :: Int]] <- query_ conn "select 2 + 2" 658 | -- > print x 659 | -- 660 | -- A 'Query' value does not represent the actual query that will be 661 | -- executed, but is a template for constructing the final query. 662 | 663 | -- $subst 664 | -- 665 | -- Since applications need to be able to construct queries with 666 | -- parameters that change, this library uses SQLite's parameter 667 | -- binding query substitution capability. 668 | -- 669 | -- This library restricts parameter substitution to work only with 670 | -- named parameters and positional arguments with the \"@?@\" syntax. 671 | -- The API does not support for mixing these two types of bindings. 672 | -- Unsupported parameters will be rejected and a 'FormatError' will be 673 | -- thrown. 674 | -- 675 | -- You should always use parameter substitution instead of inlining 676 | -- your dynamic parameters into your queries with messy string 677 | -- concatenation. SQLite will automatically quote and escape your 678 | -- data into these placeholder parameters; this defeats the single 679 | -- most common injection vector for malicious data. 680 | 681 | -- $substpos 682 | -- 683 | -- The 'Query' template accepted by 'query', 'execute' and 'fold' can 684 | -- contain any number of \"@?@\" characters. Both 'query' and 685 | -- 'execute' accept a third argument, typically a tuple. When the 686 | -- query executes, the first \"@?@\" in the template will be replaced 687 | -- with the first element of the tuple, the second \"@?@\" with the 688 | -- second element, and so on. This substitution happens inside the 689 | -- native SQLite implementation. 690 | -- 691 | -- For example, given the following 'Query' template: 692 | -- 693 | -- > select * from user where first_name = ? and age > ? 694 | -- 695 | -- And a tuple of this form: 696 | -- 697 | -- > ("Boris" :: String, 37 :: Int) 698 | -- 699 | -- The query to be executed will look like this after substitution: 700 | -- 701 | -- > select * from user where first_name = 'Boris' and age > 37 702 | -- 703 | -- If there is a mismatch between the number of \"@?@\" characters in 704 | -- your template and the number of elements in your tuple, a 705 | -- 'FormatError' will be thrown. 706 | -- 707 | -- Note that the substitution functions do not attempt to parse or 708 | -- validate your query. It's up to you to write syntactically valid 709 | -- SQL, and to ensure that each \"@?@\" in your query template is 710 | -- matched with the right tuple element. 711 | 712 | -- $substnamed 713 | -- 714 | -- Named parameters are accepted by 'queryNamed', 'executeNamed' and 715 | -- 'foldNamed'. These functions take a list of 'NamedParam's which 716 | -- are key-value pairs binding a value to an argument name. As is the 717 | -- case with \"@?@\" parameters, named parameters are automatically 718 | -- escaped by the SQLite library. The parameter names are prefixed 719 | -- with either @:@ or @\@@, e.g. @:foo@ or @\@foo@. 720 | -- 721 | -- Example: 722 | -- 723 | -- @ 724 | -- r \<- 'queryNamed' c \"SELECT id,text FROM posts WHERE id = :id AND date >= :date\" [\":id\" ':=' postId, \":date\" ':=' afterDate] 725 | -- @ 726 | -- 727 | -- Note that you can mix different value types in the same list. 728 | -- E.g., the following is perfectly legal: 729 | -- 730 | -- @ 731 | -- [\":id\" ':=' (3 :: Int), \":str\" ':=' (\"foo\" :: String)] 732 | -- @ 733 | -- 734 | -- The parameter name (or key) in the 'NamedParam' must match exactly 735 | -- the name written in the SQL query. E.g., if you used @:foo@ in 736 | -- your SQL statement, you need to use @\":foo\"@ as the parameter 737 | -- key, not @\"foo\"@. Some libraries like Python's sqlite3 738 | -- automatically drop the @:@ character from the name. 739 | 740 | -- $inference 741 | -- 742 | -- Automated type inference means that you will often be able to avoid 743 | -- supplying explicit type signatures for the elements of a tuple. 744 | -- However, sometimes the compiler will not be able to infer your 745 | -- types. Consider a case where you write a numeric literal in a 746 | -- parameter tuple: 747 | -- 748 | -- > query conn "select ? + ?" (40,2) 749 | -- 750 | -- The above query will be rejected by the compiler, because it does 751 | -- not know the specific numeric types of the literals @40@ and @2@. 752 | -- This is easily fixed: 753 | -- 754 | -- > query conn "select ? + ?" (40 :: Double, 2 :: Double) 755 | -- 756 | -- The same kind of problem can arise with string literals if you have 757 | -- the @OverloadedStrings@ language extension enabled. Again, just 758 | -- use an explicit type signature if this happens. 759 | 760 | -- $only_param 761 | -- 762 | -- Haskell lacks a single-element tuple type, so if you have just one 763 | -- value you want substituted into a query, what should you do? 764 | -- 765 | -- To represent a single value @val@ as a parameter, write a singleton 766 | -- list @[val]@, use 'Just' @val@, or use 'Only' @val@. 767 | -- 768 | -- Here's an example using a singleton list: 769 | -- 770 | -- > execute conn "insert into users (first_name) values (?)" 771 | -- > ["Nuala"] 772 | -- 773 | -- Or you can use named parameters which do not have this restriction. 774 | 775 | -- $result 776 | -- 777 | -- The 'query' and 'query_' functions return a list of values in the 778 | -- 'FromRow' typeclass. This class performs automatic extraction 779 | -- and type conversion of rows from a query result. 780 | -- 781 | -- Here is a simple example of how to extract results: 782 | -- 783 | -- > import qualified Data.Text as T 784 | -- > 785 | -- > xs <- query_ conn "select name,age from users" 786 | -- > forM_ xs $ \(name,age) -> 787 | -- > putStrLn $ T.unpack name ++ " is " ++ show (age :: Int) 788 | -- 789 | -- Notice two important details about this code: 790 | -- 791 | -- * The number of columns we ask for in the query template must 792 | -- exactly match the number of elements we specify in a row of the 793 | -- result tuple. If they do not match, a 'ResultError' exception 794 | -- will be thrown. 795 | -- 796 | -- * Sometimes, the compiler needs our help in specifying types. It 797 | -- can infer that @name@ must be a 'Text', due to our use of the 798 | -- @unpack@ function. However, we have to tell it the type of @age@, 799 | -- as it has no other information to determine the exact type. 800 | 801 | -- $null 802 | -- 803 | -- The type of a result tuple will look something like this: 804 | -- 805 | -- > (Text, Int, Int) 806 | -- 807 | -- Although SQL can accommodate @NULL@ as a value for any of these 808 | -- types, Haskell cannot. If your result contains columns that may be 809 | -- @NULL@, be sure that you use 'Maybe' in those positions of your 810 | -- tuple. 811 | -- 812 | -- > (Text, Maybe Int, Int) 813 | -- 814 | -- If 'query' encounters a @NULL@ in a row where the corresponding 815 | -- Haskell type is not 'Maybe', it will throw a 'ResultError' 816 | -- exception. 817 | 818 | -- $only_result 819 | -- 820 | -- To specify that a query returns a single-column result, use the 821 | -- 'Only' type. 822 | -- 823 | -- > xs <- query_ conn "select id from users" 824 | -- > forM_ xs $ \(Only dbid) -> {- ... -} 825 | 826 | -- $types 827 | -- 828 | -- Conversion of SQL values to Haskell values is somewhat 829 | -- permissive. Here are the rules. 830 | -- 831 | -- * For numeric types, any Haskell type that can accurately represent 832 | -- an SQLite INTEGER is considered \"compatible\". 833 | -- 834 | -- * If a numeric incompatibility is found, 'query' will throw a 835 | -- 'ResultError'. 836 | -- 837 | -- * SQLite's TEXT type is always encoded in UTF-8. Thus any text 838 | -- data coming from an SQLite database should always be compatible 839 | -- with Haskell 'String' and 'Text' types. 840 | -- 841 | -- * SQLite's BLOB type will only be conversible to a Haskell 842 | -- 'ByteString'. 843 | -- 844 | -- You can extend conversion support to your own types be adding your 845 | -- own 'FromField' / 'ToField' instances. 846 | 847 | -- $utctime 848 | -- 849 | -- SQLite's datetime allows for multiple string representations of UTC 850 | -- time. The following formats are supported for reading SQLite times 851 | -- into Haskell UTCTime values: 852 | -- 853 | -- * YYYY-MM-DD HH:MM 854 | -- 855 | -- * YYYY-MM-DD HH:MM:SS 856 | -- 857 | -- * YYYY-MM-DD HH:MM:SS.SSS 858 | -- 859 | -- * YYYY-MM-DDTHH:MM 860 | -- 861 | -- * YYYY-MM-DDTHH:MM:SS 862 | -- 863 | -- * YYYY-MM-DDTHH:MM:SS.SSS 864 | -- 865 | -- The above may also be optionally followed by a timezone indicator 866 | -- of the form \"[+-]HH:MM\" or just \"Z\". 867 | -- 868 | -- When Haskell UTCTime values are converted into SQLite values (e.g., 869 | -- parameters for a 'query'), the following format is used: 870 | -- 871 | -- * YYYY-MM-DD HH:MM:SS.SSS 872 | -- 873 | -- The last \".SSS\" subsecond part is dropped if it's zero. No 874 | -- timezone indicator is used when converting from a UTCTime value 875 | -- into an SQLite string. SQLite assumes all datetimes are in UTC 876 | -- time. 877 | -- 878 | -- The parser and printers are implemented in . 879 | -- 880 | -- Read more about SQLite's time strings in 881 | -------------------------------------------------------------------------------- /Database/SQLite/Simple/FromField.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | ------------------------------------------------------------------------------ 7 | -- | 8 | -- Module: Database.SQLite.Simple.FromField 9 | -- Copyright: (c) 2011 MailRank, Inc. 10 | -- (c) 2011-2012 Leon P Smith 11 | -- (c) 2012-2013 Janne Hellsten 12 | -- License: BSD3 13 | -- Maintainer: Janne Hellsten 14 | -- Portability: portable 15 | -- 16 | -- The 'FromField' typeclass, for converting a single value in a row 17 | -- returned by a SQL query into a more useful Haskell representation. 18 | -- 19 | -- A Haskell numeric type is considered to be compatible with all 20 | -- SQLite numeric types that are less accurate than it. For instance, 21 | -- the Haskell 'Double' type is compatible with the SQLite's 32-bit 22 | -- @Int@ type because it can represent a @Int@ exactly. On the other hand, 23 | -- since a 'Double' might lose precision if representing a 64-bit @BigInt@, 24 | -- the two are /not/ considered compatible. 25 | -- 26 | ------------------------------------------------------------------------------ 27 | 28 | module Database.SQLite.Simple.FromField 29 | ( 30 | FromField(..) 31 | , FieldParser 32 | , ResultError(..) 33 | , Field 34 | , fieldData 35 | , returnError 36 | ) where 37 | 38 | import Control.Exception (SomeException(..), Exception) 39 | import Data.ByteString (ByteString) 40 | import qualified Data.ByteString.Char8 as B 41 | import qualified Data.ByteString.Lazy as LB 42 | import Data.Int (Int8, Int16, Int32, Int64) 43 | import Data.Time (UTCTime, Day) 44 | import qualified Data.Text as T 45 | import qualified Data.Text.Lazy as LT 46 | import Data.Typeable (Typeable, typeOf) 47 | import Data.Word (Word8, Word16, Word32, Word64) 48 | import GHC.Float (double2Float) 49 | 50 | import Database.SQLite3 as Base 51 | import Database.SQLite.Simple.Types 52 | import Database.SQLite.Simple.Internal 53 | import Database.SQLite.Simple.Ok 54 | import Database.SQLite.Simple.Time 55 | 56 | -- | Exception thrown if conversion from a SQL value to a Haskell 57 | -- value fails. 58 | data ResultError = Incompatible { errSQLType :: String 59 | , errHaskellType :: String 60 | , errMessage :: String } 61 | -- ^ The SQL and Haskell types are not compatible. 62 | | UnexpectedNull { errSQLType :: String 63 | , errHaskellType :: String 64 | , errMessage :: String } 65 | -- ^ A SQL @NULL@ was encountered when the Haskell 66 | -- type did not permit it. 67 | | ConversionFailed { errSQLType :: String 68 | , errHaskellType :: String 69 | , errMessage :: String } 70 | -- ^ The SQL value could not be parsed, or could not 71 | -- be represented as a valid Haskell value, or an 72 | -- unexpected low-level error occurred (e.g. mismatch 73 | -- between metadata and actual data in a row). 74 | deriving (Eq, Show, Typeable) 75 | 76 | instance Exception ResultError 77 | 78 | left :: Exception a => a -> Ok b 79 | left = Errors . (:[]) . SomeException 80 | 81 | type FieldParser a = Field -> Ok a 82 | 83 | -- | A type that may be converted from a SQL type. 84 | class FromField a where 85 | fromField :: FieldParser a 86 | -- ^ Convert a SQL value to a Haskell value. 87 | -- 88 | -- Returns a list of exceptions if the conversion fails. In the case of 89 | -- library instances, this will usually be a single 'ResultError', but 90 | -- may be a 'UnicodeException'. 91 | -- 92 | -- Implementations of 'fromField' should not retain any references to 93 | -- the 'Field' nor the 'ByteString' arguments after the result has 94 | -- been evaluated to WHNF. Such a reference causes the entire 95 | -- @LibPQ.'PQ.Result'@ to be retained. 96 | -- 97 | -- For example, the instance for 'ByteString' uses 'B.copy' to avoid 98 | -- such a reference, and that using bytestring functions such as 'B.drop' 99 | -- and 'B.takeWhile' alone will also trigger this memory leak. 100 | 101 | instance (FromField a) => FromField (Maybe a) where 102 | fromField (Field SQLNull _) = pure Nothing 103 | fromField f = Just <$> fromField f 104 | 105 | instance FromField Null where 106 | fromField (Field SQLNull _) = pure Null 107 | fromField f = returnError ConversionFailed f "data is not null" 108 | 109 | takeInt :: (Num a, Typeable a) => Field -> Ok a 110 | takeInt (Field (SQLInteger i) _) = Ok . fromIntegral $ i 111 | takeInt f = returnError ConversionFailed f "need an int" 112 | 113 | instance FromField Int8 where 114 | fromField = takeInt 115 | 116 | instance FromField Int16 where 117 | fromField = takeInt 118 | 119 | instance FromField Int32 where 120 | fromField = takeInt 121 | 122 | instance FromField Int where 123 | fromField = takeInt 124 | 125 | instance FromField Int64 where 126 | fromField = takeInt 127 | 128 | instance FromField Integer where 129 | fromField = takeInt 130 | 131 | instance FromField Word8 where 132 | fromField = takeInt 133 | 134 | instance FromField Word16 where 135 | fromField = takeInt 136 | 137 | instance FromField Word32 where 138 | fromField = takeInt 139 | 140 | instance FromField Word64 where 141 | fromField = takeInt 142 | 143 | instance FromField Word where 144 | fromField = takeInt 145 | 146 | instance FromField Double where 147 | fromField (Field (SQLFloat flt) _) = Ok flt 148 | fromField f = returnError ConversionFailed f "expecting an SQLFloat column type" 149 | 150 | instance FromField Float where 151 | fromField (Field (SQLFloat flt) _) = Ok . double2Float $ flt 152 | fromField f = returnError ConversionFailed f "expecting an SQLFloat column type" 153 | 154 | instance FromField Bool where 155 | fromField f@(Field (SQLInteger b) _) 156 | | (b == 0) || (b == 1) = Ok (b /= 0) 157 | | otherwise = returnError ConversionFailed f ("bool must be 0 or 1, got " ++ show b) 158 | 159 | fromField f = returnError ConversionFailed f "expecting an SQLInteger column type" 160 | 161 | instance FromField T.Text where 162 | fromField (Field (SQLText txt) _) = Ok txt 163 | fromField f = returnError ConversionFailed f "need a text" 164 | 165 | instance FromField LT.Text where 166 | fromField (Field (SQLText txt) _) = Ok . LT.fromStrict $ txt 167 | fromField f = returnError ConversionFailed f "need a text" 168 | 169 | instance FromField [Char] where 170 | fromField (Field (SQLText t) _) = Ok $ T.unpack t 171 | fromField f = returnError ConversionFailed f "expecting SQLText column type" 172 | 173 | instance FromField ByteString where 174 | fromField (Field (SQLBlob blb) _) = Ok blb 175 | fromField f = returnError ConversionFailed f "expecting SQLBlob column type" 176 | 177 | instance FromField LB.ByteString where 178 | fromField (Field (SQLBlob blb) _) = Ok . LB.fromChunks $ [blb] 179 | fromField f = returnError ConversionFailed f "expecting SQLBlob column type" 180 | 181 | instance FromField UTCTime where 182 | fromField f@(Field (SQLText t) _) = 183 | case parseUTCTime t of 184 | Right t -> Ok t 185 | Left e -> returnError ConversionFailed f ("couldn't parse UTCTime field: " ++ e) 186 | 187 | fromField f = returnError ConversionFailed f "expecting SQLText column type" 188 | 189 | 190 | instance FromField Day where 191 | fromField f@(Field (SQLText t) _) = 192 | case parseDay t of 193 | Right t -> Ok t 194 | Left e -> returnError ConversionFailed f ("couldn't parse Day field: " ++ e) 195 | 196 | fromField f = returnError ConversionFailed f "expecting SQLText column type" 197 | 198 | instance FromField SQLData where 199 | fromField f = Ok (fieldData f) 200 | 201 | fieldTypename :: Field -> String 202 | fieldTypename = B.unpack . gettypename . result 203 | 204 | -- | Return the actual SQL data for a database field. This allows 205 | -- user-defined 'FromField' instances to access the SQL data 206 | -- associated with a field being parsed. 207 | fieldData :: Field -> SQLData 208 | fieldData = result 209 | 210 | -- | Given one of the constructors from 'ResultError', the field, 211 | -- and an 'errMessage', this fills in the other fields in the 212 | -- exception value and returns it in a 'Left . SomeException' 213 | -- constructor. 214 | returnError :: forall a err . (Typeable a, Exception err) 215 | => (String -> String -> String -> err) 216 | -> Field -> String -> Ok a 217 | returnError mkErr f = left . mkErr (fieldTypename f) 218 | (show (typeOf (undefined :: a))) 219 | -------------------------------------------------------------------------------- /Database/SQLite/Simple/FromRow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures, FlexibleContexts #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- | 5 | -- Module: Database.SQLite.Simple.FromRow 6 | -- Copyright: (c) 2011-2012 Leon P Smith 7 | -- (c) 2012-2013 Janne Hellsten 8 | -- License: BSD3 9 | -- Maintainer: Janne Hellsten 10 | -- Portability: portable 11 | -- 12 | -- The 'FromRow' typeclass, for converting a row of results 13 | -- returned by a SQL query into a more useful Haskell representation. 14 | -- 15 | -- Predefined instances are provided for tuples containing up to ten 16 | -- elements. 17 | ------------------------------------------------------------------------------ 18 | 19 | module Database.SQLite.Simple.FromRow 20 | ( GFromRow(..) 21 | , FromRow(..) 22 | , RowParser 23 | , field 24 | , fieldWith 25 | , numFieldsRemaining 26 | ) where 27 | 28 | import Control.Exception (SomeException(..)) 29 | import Control.Monad (replicateM) 30 | import Control.Monad.Trans.State.Strict 31 | import Control.Monad.Trans.Reader 32 | import Control.Monad.Trans.Class 33 | import GHC.Generics 34 | 35 | import Database.SQLite.Simple.FromField 36 | import Database.SQLite.Simple.Internal 37 | import Database.SQLite.Simple.Ok 38 | import Database.SQLite.Simple.Types 39 | 40 | 41 | -- | Generic derivation of 'FromRow'. 42 | -- 43 | -- Instantiating 'FromRow' can in some cases be quite tedious. Luckily 44 | -- we can derive it generically in some cases where the type at hand 45 | -- has a 'Generic' instance. The current implementation only works 46 | -- for a (n-ary) product types. So we would not be able to 47 | -- e.g. derive a 'FromRow' instance for 48 | -- 49 | -- @ 50 | -- data Bool = True | False 51 | -- @ 52 | -- 53 | -- We /can/, however, derive a generic instance for the @User@ type 54 | -- (see the example in 'FromRow'). 55 | -- 56 | -- @since 0.4.18.1 57 | class GFromRow f where 58 | gfromRow :: RowParser (f a) 59 | 60 | instance GFromRow U1 where 61 | gfromRow = pure U1 62 | 63 | instance FromField a => GFromRow (K1 i a) where 64 | gfromRow = K1 <$> field 65 | 66 | instance GFromRow a => GFromRow (M1 i c a) where 67 | gfromRow = M1 <$> gfromRow 68 | 69 | instance (GFromRow a, GFromRow b) => GFromRow (a :*: b) where 70 | gfromRow = (:*:) <$> gfromRow <*> gfromRow 71 | 72 | -- | A collection type that can be converted from a sequence of fields. 73 | -- Instances are provided for tuples up to 10 elements and lists of any length. 74 | -- 75 | -- Note that instances can defined outside of sqlite-simple, which is 76 | -- often useful. For example, here's an instance for a user-defined pair: 77 | -- 78 | -- @ 79 | -- data User = User { name :: String, fileQuota :: Int } 80 | -- 81 | -- instance 'FromRow' User where 82 | -- fromRow = User \<$\> 'field' \<*\> 'field' 83 | -- @ 84 | -- 85 | -- The number of calls to 'field' must match the number of fields returned 86 | -- in a single row of the query result. Otherwise, a 'ConversionFailed' 87 | -- exception will be thrown. 88 | -- 89 | -- Note the caveats associated with user-defined implementations of 90 | -- 'fromRow'. 91 | -- 92 | -- === Generic implementation 93 | -- 94 | -- Since version 0.4.18.1 it is possible in some cases to derive a 95 | -- generic implementation for 'FromRow'. With a 'Generic' instance 96 | -- for @User@, the example above could be written: 97 | -- 98 | -- @ 99 | -- instance 'FromRow' User where 100 | -- @ 101 | -- 102 | -- With @-XDeriveAnyClass -XDerivingStrategies@ the same can be written: 103 | -- 104 | -- @ 105 | -- deriving anyclass instance 'FromRow' User 106 | -- @ 107 | -- 108 | -- For more details refer to 'GFromRow'. 109 | class FromRow a where 110 | fromRow :: RowParser a 111 | 112 | default fromRow :: Generic a => GFromRow (Rep a) => RowParser a 113 | fromRow = to <$> gfromRow 114 | 115 | fieldWith :: FieldParser a -> RowParser a 116 | fieldWith fieldP = RP $ do 117 | ncols <- asks nColumns 118 | (column, remaining) <- lift get 119 | lift (put (column + 1, tail remaining)) 120 | if column >= ncols 121 | then 122 | lift (lift (Errors [SomeException (ColumnOutOfBounds (column+1))])) 123 | else do 124 | let r = head remaining 125 | field = Field r column 126 | lift (lift (fieldP field)) 127 | 128 | field :: FromField a => RowParser a 129 | field = fieldWith fromField 130 | 131 | numFieldsRemaining :: RowParser Int 132 | numFieldsRemaining = RP $ do 133 | ncols <- asks nColumns 134 | (columnIdx,_) <- lift get 135 | return $! ncols - columnIdx 136 | 137 | instance (FromField a) => FromRow (Only a) where 138 | fromRow = Only <$> field 139 | 140 | instance (FromField a, FromField b) => FromRow (a,b) where 141 | fromRow = (,) <$> field <*> field 142 | 143 | instance (FromField a, FromField b, FromField c) => FromRow (a,b,c) where 144 | fromRow = (,,) <$> field <*> field <*> field 145 | 146 | instance (FromField a, FromField b, FromField c, FromField d) => 147 | FromRow (a,b,c,d) where 148 | fromRow = (,,,) <$> field <*> field <*> field <*> field 149 | 150 | instance (FromField a, FromField b, FromField c, FromField d, FromField e) => 151 | FromRow (a,b,c,d,e) where 152 | fromRow = (,,,,) <$> field <*> field <*> field <*> field <*> field 153 | 154 | instance (FromField a, FromField b, FromField c, FromField d, FromField e, 155 | FromField f) => 156 | FromRow (a,b,c,d,e,f) where 157 | fromRow = (,,,,,) <$> field <*> field <*> field <*> field <*> field 158 | <*> field 159 | 160 | instance (FromField a, FromField b, FromField c, FromField d, FromField e, 161 | FromField f, FromField g) => 162 | FromRow (a,b,c,d,e,f,g) where 163 | fromRow = (,,,,,,) <$> field <*> field <*> field <*> field <*> field 164 | <*> field <*> field 165 | 166 | instance (FromField a, FromField b, FromField c, FromField d, FromField e, 167 | FromField f, FromField g, FromField h) => 168 | FromRow (a,b,c,d,e,f,g,h) where 169 | fromRow = (,,,,,,,) <$> field <*> field <*> field <*> field <*> field 170 | <*> field <*> field <*> field 171 | 172 | instance (FromField a, FromField b, FromField c, FromField d, FromField e, 173 | FromField f, FromField g, FromField h, FromField i) => 174 | FromRow (a,b,c,d,e,f,g,h,i) where 175 | fromRow = (,,,,,,,,) <$> field <*> field <*> field <*> field <*> field 176 | <*> field <*> field <*> field <*> field 177 | 178 | instance (FromField a, FromField b, FromField c, FromField d, FromField e, 179 | FromField f, FromField g, FromField h, FromField i, FromField j) => 180 | FromRow (a,b,c,d,e,f,g,h,i,j) where 181 | fromRow = (,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field 182 | <*> field <*> field <*> field <*> field <*> field 183 | 184 | instance FromField a => FromRow [a] where 185 | fromRow = do 186 | n <- numFieldsRemaining 187 | replicateM n field 188 | 189 | instance (FromRow a, FromRow b) => FromRow (a :. b) where 190 | fromRow = (:.) <$> fromRow <*> fromRow 191 | -------------------------------------------------------------------------------- /Database/SQLite/Simple/Function.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | module Database.SQLite.Simple.Function 4 | ( 5 | Function 6 | , createFunction 7 | , deleteFunction 8 | ) where 9 | 10 | import Control.Exception 11 | import Data.Proxy 12 | import Database.SQLite3 as Base hiding (createFunction,deleteFunction,funcArgText,funcResultText) 13 | import qualified Database.SQLite3.Direct as Base 14 | import Database.SQLite.Simple 15 | import Database.SQLite.Simple.Internal (Field(..)) 16 | import Database.SQLite.Simple.ToField 17 | import Database.SQLite.Simple.FromField 18 | import Database.SQLite.Simple.Ok 19 | import qualified Data.Text as T 20 | import qualified Data.Text.Encoding as TE 21 | 22 | class Function a where 23 | argCount :: Proxy a -> Int 24 | deterministicFn :: Proxy a -> Bool 25 | evalFunction :: Base.FuncContext -> Base.FuncArgs -> Int -> a -> IO () 26 | 27 | instance {-# OVERLAPPING #-} (ToField a) => Function a where 28 | argCount = const 0 29 | deterministicFn = const True 30 | evalFunction ctx _ _ a = case toField a of 31 | SQLInteger r -> Base.funcResultInt64 ctx r 32 | SQLFloat r -> Base.funcResultDouble ctx r 33 | SQLText r -> Base.funcResultText ctx $ Base.Utf8 $ TE.encodeUtf8 r 34 | SQLBlob r -> Base.funcResultBlob ctx r 35 | SQLNull -> Base.funcResultNull ctx 36 | 37 | instance {-# Overlapping #-} (Function a) => Function (IO a) where 38 | argCount = const 0 39 | deterministicFn = const False 40 | evalFunction ctx args ca a = a >>= evalFunction ctx args ca 41 | 42 | instance {-# Overlapping #-} forall f r . (Function r, FromField f) => Function (f -> r) where 43 | argCount = const $ argCount (Proxy :: Proxy r) + 1 44 | deterministicFn = const $ deterministicFn (Proxy :: Proxy r) 45 | evalFunction ctx args ca fn = let ca' = Base.ArgCount ca in do 46 | sqlv <- Base.funcArgType args ca' >>= \ct -> case ct of 47 | Base.IntegerColumn -> SQLInteger <$> Base.funcArgInt64 args ca' 48 | Base.FloatColumn -> SQLFloat <$> Base.funcArgDouble args ca' 49 | Base.TextColumn -> (\(Base.Utf8 b) -> SQLText $ TE.decodeUtf8 b) <$> 50 | Base.funcArgText args ca' 51 | Base.BlobColumn -> SQLBlob <$> Base.funcArgBlob args ca' 52 | Base.NullColumn -> pure SQLNull 53 | case fromField $ Field sqlv ca of 54 | Ok arg -> evalFunction ctx args (ca + 1) (fn arg) 55 | Errors ex -> throw $ ManyErrors ex 56 | 57 | createFunction :: forall f . Function f => Connection -> T.Text -> f -> IO (Either Base.Error ()) 58 | createFunction conn fn f = Base.createFunction 59 | (connectionHandle conn) 60 | (Base.Utf8 $ TE.encodeUtf8 fn) 61 | (Just $ Base.ArgCount $ argCount (Proxy :: Proxy f)) 62 | (deterministicFn (Proxy :: Proxy f)) 63 | (\ctx args -> catch 64 | (evalFunction ctx args 0 f) 65 | ((const :: IO () -> SomeException -> IO ()) $ Base.funcResultNull ctx)) 66 | 67 | deleteFunction :: Connection -> T.Text -> IO (Either Base.Error ()) 68 | deleteFunction conn fn = Base.deleteFunction 69 | (connectionHandle conn) 70 | (Base.Utf8 $ TE.encodeUtf8 fn) 71 | Nothing 72 | -------------------------------------------------------------------------------- /Database/SQLite/Simple/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} 2 | ------------------------------------------------------------------------------ 3 | -- | 4 | -- Module: Database.SQLite.Simple.Internal 5 | -- Copyright: (c) 2011-2012 Leon P Smith 6 | -- (c) 2012-2013 Janne Hellsten 7 | -- License: BSD3 8 | -- Maintainer: Janne Hellsten 9 | -- Portability: portable 10 | -- 11 | -- Internal bits. This interface is less stable and can change at any time. 12 | -- In particular this means that while the rest of the sqlite-simple 13 | -- package endeavors to follow the package versioning policy, this module 14 | -- does not. Also, at the moment there are things in here that aren't 15 | -- particularly internal and are exported elsewhere; these will eventually 16 | -- disappear from this module. 17 | -- 18 | ------------------------------------------------------------------------------ 19 | 20 | module Database.SQLite.Simple.Internal where 21 | 22 | import Control.Exception (Exception) 23 | import Control.Monad 24 | import Control.Applicative 25 | import Data.ByteString (ByteString) 26 | import Data.ByteString.Char8() 27 | import Data.IORef 28 | import Data.Typeable (Typeable) 29 | import Data.Word 30 | import Control.Monad.Trans.State.Strict 31 | import Control.Monad.Trans.Reader 32 | 33 | import Database.SQLite.Simple.Ok 34 | import qualified Database.SQLite3 as Base 35 | 36 | -- | Connection to an open database. 37 | -- 38 | -- You can use 'connectionHandle' to gain access to the underlying 39 | -- connection. 40 | -- This may be useful if you need to access some direct-sqlite 41 | -- functionality that's not exposed in the sqlite-simple API. This 42 | -- should be a safe thing to do although mixing both APIs is 43 | -- discouraged. 44 | data Connection = Connection 45 | { connectionHandle :: {-# UNPACK #-} !Base.Database 46 | , connectionTempNameCounter :: {-# UNPACK #-} !(IORef Word64) 47 | } 48 | 49 | data ColumnOutOfBounds = ColumnOutOfBounds { errorColumnIndex :: !Int } 50 | deriving (Eq, Show, Typeable) 51 | 52 | instance Exception ColumnOutOfBounds 53 | 54 | -- | A Field represents metadata about a particular field 55 | data Field = Field { 56 | result :: Base.SQLData 57 | , column :: {-# UNPACK #-} !Int 58 | } 59 | 60 | -- Named type for holding RowParser read-only state. Just for making 61 | -- it easier to make sense out of types in FromRow. 62 | newtype RowParseRO = RowParseRO { nColumns :: Int } 63 | 64 | newtype RowParser a = RP { unRP :: ReaderT RowParseRO (StateT (Int, [Base.SQLData]) Ok) a } 65 | deriving ( Functor, Applicative, Alternative, Monad, MonadPlus ) 66 | 67 | gettypename :: Base.SQLData -> ByteString 68 | gettypename (Base.SQLInteger _) = "INTEGER" 69 | gettypename (Base.SQLFloat _) = "FLOAT" 70 | gettypename (Base.SQLText _) = "TEXT" 71 | gettypename (Base.SQLBlob _) = "BLOB" 72 | gettypename Base.SQLNull = "NULL" 73 | 74 | -------------------------------------------------------------------------------- /Database/SQLite/Simple/Ok.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | 5 | ------------------------------------------------------------------------------ 6 | -- | 7 | -- Module: Database.SQLite.Simple.Ok 8 | -- Copyright: (c) 2012 Leon P Smith 9 | -- (c) 2012-2013 Janne Hellsten 10 | -- License: BSD3 11 | -- Maintainer: Janne Hellsten 12 | -- 13 | -- The 'Ok' type is a simple error handler, basically equivalent to 14 | -- @Either [SomeException]@. 15 | -- 16 | -- One of the primary reasons why this type was introduced is that 17 | -- @Either SomeException@ had not been provided an instance for 'Alternative', 18 | -- and it would have been a bad idea to provide an orphaned instance for a 19 | -- commonly-used type and typeclass included in @base@. 20 | -- 21 | -- Extending the failure case to a list of 'SomeException's enables a 22 | -- more sensible 'Alternative' instance definitions: '<|>' concatenates 23 | -- the list of exceptions when both cases fail, and 'empty' is defined as 24 | -- 'Errors []'. Though '<|>' one could pick one of two exceptions, and 25 | -- throw away the other, and have 'empty' provide a generic exception, 26 | -- this avoids cases where 'empty' overrides a more informative exception 27 | -- and allows you to see all the different ways your computation has failed. 28 | -- 29 | ------------------------------------------------------------------------------ 30 | 31 | module Database.SQLite.Simple.Ok where 32 | 33 | import Control.Applicative 34 | import Control.Exception 35 | import Control.Monad (MonadPlus(..)) 36 | import Control.Monad.Catch (MonadThrow, throwM) 37 | import Data.Typeable 38 | 39 | #if !MIN_VERSION_base(4,13,0) && MIN_VERSION_base(4,9,0) 40 | import Control.Monad.Fail 41 | #endif 42 | 43 | -- FIXME: [SomeException] should probably be something else, maybe 44 | -- a difference list (or a tree?) 45 | 46 | data Ok a = Errors [SomeException] | Ok !a 47 | deriving(Show, Typeable, Functor) 48 | 49 | -- | Two 'Errors' cases are considered equal, regardless of what the 50 | -- list of exceptions looks like. 51 | 52 | instance Eq a => Eq (Ok a) where 53 | Errors _ == Errors _ = True 54 | Ok a == Ok b = a == b 55 | _ == _ = False 56 | 57 | instance Applicative Ok where 58 | pure = Ok 59 | 60 | Errors es <*> _ = Errors es 61 | _ <*> Errors es = Errors es 62 | Ok f <*> Ok a = Ok (f a) 63 | 64 | instance Alternative Ok where 65 | empty = Errors [] 66 | 67 | a@(Ok _) <|> _ = a 68 | Errors _ <|> b@(Ok _) = b 69 | Errors as <|> Errors bs = Errors (as ++ bs) 70 | 71 | instance MonadPlus Ok where 72 | mzero = empty 73 | mplus = (<|>) 74 | 75 | instance Monad Ok where 76 | Errors es >>= _ = Errors es 77 | Ok a >>= f = f a 78 | 79 | #if MIN_VERSION_base(4,9,0) 80 | instance MonadFail Ok where 81 | fail str = Errors [SomeException (ErrorCall str)] 82 | #endif 83 | 84 | instance MonadThrow Ok where 85 | throwM = Errors . pure . toException 86 | 87 | 88 | -- | a way to reify a list of exceptions into a single exception 89 | 90 | newtype ManyErrors = ManyErrors [SomeException] 91 | deriving (Show, Typeable) 92 | 93 | instance Exception ManyErrors 94 | -------------------------------------------------------------------------------- /Database/SQLite/Simple/QQ.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskellQuotes #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- | 5 | -- Module: Database.SQLite.Simple.QQ 6 | -- Copyright: (c) 2011-2012 Leon P Smith 7 | -- (c) 2018 Janne Hellsten 8 | -- License: BSD3 9 | -- Maintainer: Janne Hellsten 10 | -- Portability: portable 11 | -- 12 | -- The 'sql' quasiquoter, for writing large @SQL@ statements. 13 | -- 14 | ------------------------------------------------------------------------------ 15 | 16 | module Database.SQLite.Simple.QQ 17 | ( sql 18 | ) where 19 | 20 | import Data.String (fromString) 21 | import Database.SQLite.Simple.Types (Query) 22 | import Language.Haskell.TH (Exp, Q, appE, stringE) 23 | import Language.Haskell.TH.Quote (QuasiQuoter (..)) 24 | 25 | {- | A quasiquoter for writing big @SQL@ queries. 26 | 27 | One should consider turning on the @-XQuasiQuotes@ pragma in that module: 28 | 29 | @ 30 | {-# LANGUAGE QuasiQuotes #-} 31 | 32 | myQuery = query conn [sql| 33 | SELECT 34 | * 35 | FROM 36 | users 37 | WHERE jobTitle = ? 38 | |] jobTitle 39 | @ 40 | 41 | -} 42 | sql :: QuasiQuoter 43 | sql = QuasiQuoter 44 | { quotePat = error "Database.SQLite.Simple.QQ.sql: quasiquoter used in pattern context" 45 | , quoteType = error "Database.SQLite.Simple.QQ.sql: quasiquoter used in type context" 46 | , quoteDec = error "Database.SQLite.Simple.QQ.sql: quasiquoter used in declaration context" 47 | , quoteExp = sqlExp 48 | } 49 | 50 | sqlExp :: String -> Q Exp 51 | sqlExp = appE [| fromString :: String -> Query |] . stringE 52 | -------------------------------------------------------------------------------- /Database/SQLite/Simple/Time.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- | 3 | -- Module: Database.SQLite.Simple.Time 4 | -- Copyright: (c) 2012 Leon P Smith 5 | -- (c) 2012-2014 Janne Hellsten 6 | -- License: BSD3 7 | -- Maintainer: Janne Hellsten 8 | -- 9 | -- Conversions to/from Haskell 'UTCTime' and 'Day' types for SQLite3. 10 | -- Offers better performance than direct use of time package's 11 | -- 'read'/'show' functionality. 12 | -- 13 | -- The parsers are heavily adapted for the specific variant of ISO 8601 that 14 | -- SQLite uses, and the printers attempt to duplicate this syntax. 15 | ------------------------------------------------------------------------------ 16 | 17 | module Database.SQLite.Simple.Time ( 18 | module Database.SQLite.Simple.Time.Implementation 19 | ) where 20 | 21 | import Database.SQLite.Simple.Time.Implementation 22 | -------------------------------------------------------------------------------- /Database/SQLite/Simple/Time/Implementation.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- | 3 | -- Module: Database.SQLite.Simple.Time.Implementation 4 | -- Copyright: (c) 2012 Leon P Smith 5 | -- (c) 2012-2014 Janne Hellsten 6 | -- License: BSD3 7 | -- Maintainer: Janne Hellsten 8 | -- 9 | -- Adapted from Leon P Smith's code for SQLite. 10 | -- 11 | -- See for date formats used in SQLite. 12 | ------------------------------------------------------------------------------ 13 | 14 | module Database.SQLite.Simple.Time.Implementation ( 15 | parseUTCTime 16 | , parseDay 17 | , utcTimeToBuilder 18 | , dayToBuilder 19 | , timeOfDayToBuilder 20 | , timeZoneToBuilder 21 | ) where 22 | import Blaze.ByteString.Builder (Builder) 23 | import Blaze.ByteString.Builder.Char8 (fromChar) 24 | import Blaze.Text.Int (integral) 25 | import Control.Applicative 26 | import Control.Monad (when) 27 | import qualified Data.Attoparsec.Text as A 28 | import Data.Bits ((.&.)) 29 | import Data.ByteString.Internal (w2c) 30 | import Data.Char (isDigit, ord) 31 | import Data.Fixed (Pico) 32 | import qualified Data.Text as T 33 | import Data.Time hiding (getTimeZone, getZonedTime) 34 | import Prelude hiding (take, (++)) 35 | import Unsafe.Coerce 36 | 37 | (++) :: Monoid a => a -> a -> a 38 | (++) = mappend 39 | infixr 5 ++ 40 | 41 | parseUTCTime :: T.Text -> Either String UTCTime 42 | parseUTCTime = A.parseOnly (getUTCTime <* A.endOfInput) 43 | 44 | parseDay :: T.Text -> Either String Day 45 | parseDay = A.parseOnly (getDay <* A.endOfInput) 46 | 47 | getDay :: A.Parser Day 48 | getDay = do 49 | yearStr <- A.takeWhile isDigit 50 | when (T.length yearStr < 4) (fail "year must consist of at least 4 digits") 51 | 52 | let !year = toNum yearStr 53 | _ <- A.char '-' 54 | month <- digits "month" 55 | _ <- A.char '-' 56 | day <- digits "day" 57 | 58 | case fromGregorianValid year month day of 59 | Nothing -> fail "invalid date" 60 | Just x -> return $! x 61 | 62 | decimal :: Fractional a => T.Text -> a 63 | decimal str = toNum str / 10^(T.length str) 64 | {-# INLINE decimal #-} 65 | 66 | getTimeOfDay :: A.Parser TimeOfDay 67 | getTimeOfDay = do 68 | hour <- digits "hours" 69 | _ <- A.char ':' 70 | minute <- digits "minutes" 71 | -- Allow omission of seconds. If seconds is omitted, don't try to 72 | -- parse the sub-second part. 73 | (sec,subsec) 74 | <- ((,) <$> (A.char ':' *> digits "seconds") <*> fract) <|> pure (0,0) 75 | 76 | let !picos' = sec + subsec 77 | 78 | case makeTimeOfDayValid hour minute picos' of 79 | Nothing -> fail "invalid time of day" 80 | Just x -> return $! x 81 | 82 | where 83 | fract = 84 | (A.char '.' *> (decimal <$> A.takeWhile1 isDigit)) <|> pure 0 85 | 86 | getTimeZone :: A.Parser TimeZone 87 | getTimeZone = do 88 | sign <- A.satisfy (\c -> c == '+' || c == '-') 89 | hours <- digits "timezone" 90 | mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0 91 | let !absset = 60 * hours + mins 92 | !offset = if sign == '+' then absset else -absset 93 | return $! minutesToTimeZone offset 94 | 95 | getUTCTime :: A.Parser UTCTime 96 | getUTCTime = do 97 | day <- getDay 98 | _ <- A.char ' ' <|> A.char 'T' 99 | time <- getTimeOfDay 100 | -- SQLite doesn't require a timezone postfix. So make that 101 | -- optional and default to +0. 'Z' means UTC (zulu time). 102 | zone <- getTimeZone <|> (A.char 'Z' *> pure utc) <|> (pure utc) 103 | let (!dayDelta,!time') = localToUTCTimeOfDay zone time 104 | let !day' = addDays dayDelta day 105 | let !time'' = timeOfDayToTime time' 106 | return (UTCTime day' time'') 107 | 108 | toNum :: Num n => T.Text -> n 109 | toNum = T.foldl' (\a c -> 10*a + digit c) 0 110 | {-# INLINE toNum #-} 111 | 112 | digit :: Num n => Char -> n 113 | digit c = fromIntegral (ord c .&. 0x0f) 114 | {-# INLINE digit #-} 115 | 116 | digits :: Num n => String -> A.Parser n 117 | digits msg = do 118 | x <- A.anyChar 119 | y <- A.anyChar 120 | if isDigit x && isDigit y 121 | then return $! (10 * digit x + digit y) 122 | else fail (msg ++ " is not 2 digits") 123 | {-# INLINE digits #-} 124 | 125 | dayToBuilder :: Day -> Builder 126 | dayToBuilder (toGregorian -> (y,m,d)) = do 127 | pad4 y ++ fromChar '-' ++ pad2 m ++ fromChar '-' ++ pad2 d 128 | 129 | timeOfDayToBuilder :: TimeOfDay -> Builder 130 | timeOfDayToBuilder (TimeOfDay h m s) = do 131 | pad2 h ++ fromChar ':' ++ pad2 m ++ fromChar ':' ++ showSeconds s 132 | 133 | timeZoneToBuilder :: TimeZone -> Builder 134 | timeZoneToBuilder tz 135 | | m == 0 = sign h ++ pad2 (abs h) 136 | | otherwise = sign h ++ pad2 (abs h) ++ fromChar ':' ++ pad2 (abs m) 137 | where 138 | (h,m) = timeZoneMinutes tz `quotRem` 60 139 | sign h | h >= 0 = fromChar '+' 140 | | otherwise = fromChar '-' 141 | 142 | -- | Output YYYY-MM-DD HH:MM:SS with an optional .SSS fraction part. 143 | -- Explicit timezone attribute is not appended as per SQLite3's 144 | -- datetime conventions. 145 | utcTimeToBuilder :: UTCTime -> Builder 146 | utcTimeToBuilder (UTCTime day time) = 147 | dayToBuilder day ++ fromChar ' ' ++ timeOfDayToBuilder (timeToTimeOfDay time) 148 | 149 | showSeconds :: Pico -> Builder 150 | showSeconds xyz 151 | | yz == 0 = pad2 x 152 | | z == 0 = pad2 x ++ fromChar '.' ++ showD6 y 153 | | otherwise = pad2 x ++ fromChar '.' ++ pad6 y ++ showD6 z 154 | where 155 | -- A kludge to work around the fact that Data.Fixed isn't very fast and 156 | -- doesn't give me access to the MkFixed constructor. 157 | (x_,yz) = (unsafeCoerce xyz :: Integer) `quotRem` 1000000000000 158 | x = fromIntegral x_ :: Int 159 | (fromIntegral -> y, fromIntegral -> z) = yz `quotRem` 1000000 160 | 161 | pad6 :: Int -> Builder 162 | pad6 xy = let (x,y) = xy `quotRem` 1000 163 | in pad3 x ++ pad3 y 164 | 165 | showD6 :: Int -> Builder 166 | showD6 xy = case xy `quotRem` 1000 of 167 | (x,0) -> showD3 x 168 | (x,y) -> pad3 x ++ showD3 y 169 | 170 | pad3 :: Int -> Builder 171 | pad3 abc = let (ab,c) = abc `quotRem` 10 172 | (a,b) = ab `quotRem` 10 173 | in p a ++ p b ++ p c 174 | 175 | showD3 :: Int -> Builder 176 | showD3 abc = case abc `quotRem` 100 of 177 | (a, 0) -> p a 178 | (a,bc) -> case bc `quotRem` 10 of 179 | (b,0) -> p a ++ p b 180 | (b,c) -> p a ++ p b ++ p c 181 | 182 | -- | p assumes its input is in the range [0..9] 183 | p :: Integral n => n -> Builder 184 | p n = fromChar (w2c (fromIntegral (n + 48))) 185 | {-# INLINE p #-} 186 | 187 | -- | pad2 assumes its input is in the range [0..99] 188 | pad2 :: Integral n => n -> Builder 189 | pad2 n = let (a,b) = n `quotRem` 10 in p a ++ p b 190 | {-# INLINE pad2 #-} 191 | 192 | -- | pad4 assumes its input is positive 193 | pad4 :: (Integral n, Show n) => n -> Builder 194 | pad4 abcd | abcd >= 10000 = integral abcd 195 | | otherwise = p a ++ p b ++ p c ++ p d 196 | where (ab,cd) = abcd `quotRem` 100 197 | (a,b) = ab `quotRem` 10 198 | (c,d) = cd `quotRem` 10 199 | {-# INLINE pad4 #-} 200 | -------------------------------------------------------------------------------- /Database/SQLite/Simple/ToField.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- | 5 | -- Module: Database.SQLite.Simple.ToField 6 | -- Copyright: (c) 2011 MailRank, Inc. 7 | -- (c) 2011-2012 Leon P Smith 8 | -- (c) 2012-2013 Janne Hellsten 9 | -- License: BSD3 10 | -- Maintainer: Janne Hellsten 11 | -- Portability: portable 12 | -- 13 | -- The 'ToField' typeclass, for rendering a parameter to an SQLite 14 | -- value to be bound as a SQL query parameter. 15 | -- 16 | ------------------------------------------------------------------------------ 17 | 18 | module Database.SQLite.Simple.ToField (ToField(..)) where 19 | 20 | import Blaze.ByteString.Builder (toByteString) 21 | import qualified Data.ByteString as SB 22 | import qualified Data.ByteString.Lazy as LB 23 | import Data.Int (Int8, Int16, Int32, Int64) 24 | import qualified Data.Text as T 25 | import qualified Data.Text.Lazy as LT 26 | import qualified Data.Text.Encoding as T 27 | import Data.Time (Day, UTCTime) 28 | import Data.Word (Word8, Word16, Word32, Word64) 29 | import GHC.Float 30 | 31 | import Database.SQLite3 as Base 32 | import Database.SQLite.Simple.Types (Null) 33 | import Database.SQLite.Simple.Time 34 | 35 | -- | A type that may be used as a single parameter to a SQL query. 36 | class ToField a where 37 | toField :: a -> SQLData 38 | -- ^ Prepare a value for substitution into a query string. 39 | 40 | instance ToField SQLData where 41 | toField a = a 42 | {-# INLINE toField #-} 43 | 44 | instance (ToField a) => ToField (Maybe a) where 45 | toField Nothing = Base.SQLNull 46 | toField (Just a) = toField a 47 | {-# INLINE toField #-} 48 | 49 | instance ToField Null where 50 | toField _ = Base.SQLNull 51 | {-# INLINE toField #-} 52 | 53 | instance ToField Bool where 54 | toField False = SQLInteger 0 55 | toField True = SQLInteger 1 56 | {-# INLINE toField #-} 57 | 58 | instance ToField Int8 where 59 | toField = SQLInteger . fromIntegral 60 | {-# INLINE toField #-} 61 | 62 | instance ToField Int16 where 63 | toField = SQLInteger . fromIntegral 64 | {-# INLINE toField #-} 65 | 66 | instance ToField Int32 where 67 | toField = SQLInteger . fromIntegral 68 | {-# INLINE toField #-} 69 | 70 | instance ToField Int where 71 | toField = SQLInteger . fromIntegral 72 | {-# INLINE toField #-} 73 | 74 | instance ToField Int64 where 75 | toField = SQLInteger . fromIntegral 76 | {-# INLINE toField #-} 77 | 78 | instance ToField Integer where 79 | toField = SQLInteger . fromIntegral 80 | {-# INLINE toField #-} 81 | 82 | instance ToField Word8 where 83 | toField = SQLInteger . fromIntegral 84 | {-# INLINE toField #-} 85 | 86 | instance ToField Word16 where 87 | toField = SQLInteger . fromIntegral 88 | {-# INLINE toField #-} 89 | 90 | instance ToField Word32 where 91 | toField = SQLInteger . fromIntegral 92 | {-# INLINE toField #-} 93 | 94 | instance ToField Word where 95 | toField = SQLInteger . fromIntegral 96 | {-# INLINE toField #-} 97 | 98 | instance ToField Word64 where 99 | toField = SQLInteger . fromIntegral 100 | {-# INLINE toField #-} 101 | 102 | instance ToField Float where 103 | toField = SQLFloat . float2Double 104 | {-# INLINE toField #-} 105 | 106 | instance ToField Double where 107 | toField = SQLFloat 108 | {-# INLINE toField #-} 109 | 110 | instance ToField SB.ByteString where 111 | toField = SQLBlob 112 | {-# INLINE toField #-} 113 | 114 | instance ToField LB.ByteString where 115 | toField = toField . SB.concat . LB.toChunks 116 | {-# INLINE toField #-} 117 | 118 | instance ToField T.Text where 119 | toField = SQLText 120 | {-# INLINE toField #-} 121 | 122 | instance ToField [Char] where 123 | toField = SQLText . T.pack 124 | {-# INLINE toField #-} 125 | 126 | instance ToField LT.Text where 127 | toField = toField . LT.toStrict 128 | {-# INLINE toField #-} 129 | 130 | instance ToField UTCTime where 131 | toField = SQLText . T.decodeUtf8 . toByteString . utcTimeToBuilder 132 | {-# INLINE toField #-} 133 | 134 | instance ToField Day where 135 | toField = SQLText . T.decodeUtf8 . toByteString . dayToBuilder 136 | {-# INLINE toField #-} 137 | 138 | -- TODO enable these 139 | --instance ToField ZonedTime where 140 | -- toField = SQLText . zonedTimeToBuilder 141 | -- {-# INLINE toField #-} 142 | -- 143 | --instance ToField LocalTime where 144 | -- toField = SQLText . localTimeToBuilder 145 | -- {-# INLINE toField #-} 146 | -- 147 | --instance ToField Day where 148 | -- toField = SQLText . dayToBuilder 149 | -- {-# INLINE toField #-} 150 | -- 151 | --instance ToField TimeOfDay where 152 | -- toField = SQLText . timeOfDayToBuilder 153 | -- {-# INLINE toField #-} 154 | -- 155 | --instance ToField UTCTimestamp where 156 | -- toField = SQLText . utcTimestampToBuilder 157 | -- {-# INLINE toField #-} 158 | -- 159 | --instance ToField ZonedTimestamp where 160 | -- toField = SQLText . zonedTimestampToBuilder 161 | -- {-# INLINE toField #-} 162 | -- 163 | --instance ToField LocalTimestamp where 164 | -- toField = SQLText . localTimestampToBuilder 165 | -- {-# INLINE toField #-} 166 | -- 167 | --instance ToField Date where 168 | -- toField = SQLText . dateToBuilder 169 | -- {-# INLINE toField #-} 170 | -------------------------------------------------------------------------------- /Database/SQLite/Simple/ToRow.hs: -------------------------------------------------------------------------------- 1 | {-# Language DefaultSignatures, FlexibleContexts, DeriveAnyClass, 2 | StandaloneDeriving #-} 3 | ------------------------------------------------------------------------------ 4 | -- | 5 | -- Module: Database.SQLite.Simple.ToRow 6 | -- Copyright: (c) 2011 MailRank, Inc. 7 | -- (c) 2011-2012 Leon P Smith 8 | -- (c) 2012-2013 Janne Hellsten 9 | -- License: BSD3 10 | -- Maintainer: Janne Hellsten 11 | -- Portability: portable 12 | -- 13 | -- The 'ToRow' typeclass, for rendering a collection of 14 | -- parameters to a SQL query. 15 | -- 16 | -- Predefined instances are provided for tuples containing up to ten 17 | -- elements. 18 | -- 19 | ------------------------------------------------------------------------------ 20 | 21 | module Database.SQLite.Simple.ToRow 22 | ( GToRow(..) 23 | , ToRow(..) 24 | ) where 25 | 26 | import GHC.Generics 27 | 28 | import Database.SQLite.Simple.ToField (ToField(..)) 29 | import Database.SQLite.Simple.Types (Only(..), (:.)(..)) 30 | 31 | import Database.SQLite3 (SQLData(..)) 32 | 33 | -- | Generic derivation of 'ToRow'. For details about what can be 34 | -- derived refer to 'Database.Sqlite.Simple.FromRow.GFromRow'. 35 | -- 36 | -- @since 0.4.18.1 37 | class GToRow f where 38 | gtoRow :: (f a) -> [SQLData] 39 | 40 | instance GToRow U1 where 41 | gtoRow U1 = mempty 42 | 43 | instance ToField a => GToRow (K1 i a) where 44 | gtoRow (K1 a) = pure $ toField a 45 | 46 | instance (GToRow a, GToRow b) => GToRow (a :*: b) where 47 | gtoRow (a :*: b) = gtoRow a `mappend` gtoRow b 48 | 49 | instance GToRow a => GToRow (M1 i c a) where 50 | gtoRow (M1 a) = gtoRow a 51 | 52 | -- | A collection type that can be turned into a list of 'SQLData' 53 | -- elements. 54 | -- 55 | -- Since version 0.4.18.1 it is possible in some cases to derive a 56 | -- generic implementation for 'ToRow'. Refer to the documentation for 57 | -- 'Database.Sqlite.Simple.FromRow.FromRow' to see how this can be 58 | -- done. 59 | class ToRow a where 60 | toRow :: a -> [SQLData] 61 | -- ^ 'ToField' a collection of values. 62 | 63 | default toRow :: Generic a => GToRow (Rep a) => a -> [SQLData] 64 | toRow a = gtoRow $ from a 65 | 66 | deriving instance ToRow () 67 | deriving instance (ToField a) => ToRow (Only a) 68 | deriving instance (ToField a, ToField b) => ToRow (a,b) 69 | deriving instance (ToField a, ToField b, ToField c) => ToRow (a,b,c) 70 | deriving instance (ToField a, ToField b, ToField c, ToField d) => ToRow (a,b,c,d) 71 | deriving instance (ToField a, ToField b, ToField c, ToField d, ToField e) => ToRow (a,b,c,d,e) 72 | deriving instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f) => ToRow (a,b,c,d,e,f) 73 | deriving instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g) => ToRow (a,b,c,d,e,f,g) 74 | 75 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, 76 | ToField g, ToField h) 77 | => ToRow (a,b,c,d,e,f,g,h) where 78 | toRow (a,b,c,d,e,f,g,h) = 79 | [toField a, toField b, toField c, toField d, toField e, toField f, 80 | toField g, toField h] 81 | 82 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, 83 | ToField g, ToField h, ToField i) 84 | => ToRow (a,b,c,d,e,f,g,h,i) where 85 | toRow (a,b,c,d,e,f,g,h,i) = 86 | [toField a, toField b, toField c, toField d, toField e, toField f, 87 | toField g, toField h, toField i] 88 | 89 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, 90 | ToField g, ToField h, ToField i, ToField j) 91 | => ToRow (a,b,c,d,e,f,g,h,i,j) where 92 | toRow (a,b,c,d,e,f,g,h,i,j) = 93 | [toField a, toField b, toField c, toField d, toField e, toField f, 94 | toField g, toField h, toField i, toField j] 95 | 96 | instance (ToField a) => ToRow [a] where 97 | toRow = map toField 98 | 99 | instance (ToRow a, ToRow b) => ToRow (a :. b) where 100 | toRow (a :. b) = toRow a ++ toRow b 101 | -------------------------------------------------------------------------------- /Database/SQLite/Simple/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, CPP #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- | 5 | -- Module: Database.SQLite.Simple.Types 6 | -- Copyright: (c) 2011 MailRank, Inc. 7 | -- (c) 2011-2012 Leon P Smith 8 | -- (c) 2012-2013 Janne Hellsten 9 | -- License: BSD3 10 | -- Maintainer: Janne Hellsten 11 | -- Portability: portable 12 | -- 13 | -- Top-level module for sqlite-simple. 14 | -- 15 | -- 16 | ------------------------------------------------------------------------------ 17 | 18 | module Database.SQLite.Simple.Types 19 | ( 20 | Null(..) 21 | , Only(..) 22 | , Query(..) 23 | , (:.)(..) 24 | ) where 25 | 26 | import Control.Arrow (first) 27 | import Data.String (IsString(..)) 28 | import Data.Tuple.Only (Only(..)) 29 | import Data.Typeable (Typeable) 30 | import qualified Data.Text as T 31 | 32 | #if !MIN_VERSION_base(4,11,0) 33 | import Data.Semigroup 34 | #endif 35 | 36 | -- | A placeholder for the SQL @NULL@ value. 37 | data Null = Null 38 | deriving (Read, Show, Typeable) 39 | 40 | instance Eq Null where 41 | _ == _ = False 42 | _ /= _ = False 43 | 44 | -- | A query string. This type is intended to make it difficult to 45 | -- construct a SQL query by concatenating string fragments, as that is 46 | -- an extremely common way to accidentally introduce SQL injection 47 | -- vulnerabilities into an application. 48 | -- 49 | -- This type is an instance of 'IsString', so the easiest way to 50 | -- construct a query is to enable the @OverloadedStrings@ language 51 | -- extension and then simply write the query in double quotes. 52 | -- 53 | -- > {-# LANGUAGE OverloadedStrings #-} 54 | -- > 55 | -- > import Database.SQLite.Simple 56 | -- > 57 | -- > q :: Query 58 | -- > q = "select ?" 59 | -- 60 | -- The underlying type is a 'Text', and literal Haskell strings that 61 | -- contain Unicode characters will be correctly transformed to UTF-8. 62 | newtype Query = Query { 63 | fromQuery :: T.Text 64 | } deriving (Eq, Ord, Typeable) 65 | 66 | instance Show Query where 67 | show = show . fromQuery 68 | 69 | instance Read Query where 70 | readsPrec i = fmap (first Query) . readsPrec i 71 | 72 | instance IsString Query where 73 | fromString = Query . T.pack 74 | 75 | instance Semigroup Query where 76 | Query a <> Query b = Query (T.append a b) 77 | {-# INLINE (<>) #-} 78 | 79 | instance Monoid Query where 80 | mempty = Query T.empty 81 | mappend = (<>) 82 | {-# INLINE mappend #-} 83 | 84 | -- | A composite type to parse your custom data structures without 85 | -- having to define dummy newtype wrappers every time. 86 | -- 87 | -- 88 | -- > instance FromRow MyData where ... 89 | -- 90 | -- > instance FromRow MyData2 where ... 91 | -- 92 | -- 93 | -- then I can do the following for free: 94 | -- 95 | -- @ 96 | -- res <- query' c "..." 97 | -- forM res $ \\(MyData{..} :. MyData2{..}) -> do 98 | -- .... 99 | -- @ 100 | data h :. t = h :. t deriving (Eq,Ord,Show,Read,Typeable) 101 | 102 | infixr 3 :. 103 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, Janne Hellsten 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Leon P Smith nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | 33 | Copyright (c) 2011, Leon P Smith 34 | 35 | All rights reserved. 36 | 37 | Redistribution and use in source and binary forms, with or without 38 | modification, are permitted provided that the following conditions are met: 39 | 40 | * Redistributions of source code must retain the above copyright 41 | notice, this list of conditions and the following disclaimer. 42 | 43 | * Redistributions in binary form must reproduce the above 44 | copyright notice, this list of conditions and the following 45 | disclaimer in the documentation and/or other materials provided 46 | with the distribution. 47 | 48 | * Neither the name of Leon P Smith nor the names of other 49 | contributors may be used to endorse or promote products derived 50 | from this software without specific prior written permission. 51 | 52 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 53 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 54 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 55 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 56 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 57 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 58 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 59 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 60 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 61 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 62 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 63 | 64 | 65 | Copyright (c) 2011, MailRank, Inc. 66 | 67 | All rights reserved. 68 | 69 | Redistribution and use in source and binary forms, with or without 70 | modification, are permitted provided that the following conditions 71 | are met: 72 | 73 | 1. Redistributions of source code must retain the above copyright 74 | notice, this list of conditions and the following disclaimer. 75 | 76 | 2. Redistributions in binary form must reproduce the above copyright 77 | notice, this list of conditions and the following disclaimer in the 78 | documentation and/or other materials provided with the distribution. 79 | 80 | 3. Neither the name of the author nor the names of his contributors 81 | may be used to endorse or promote products derived from this software 82 | without specific prior written permission. 83 | 84 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 85 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 86 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 87 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 88 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 89 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 90 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 91 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 92 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 93 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 94 | POSSIBILITY OF SUCH DAMAGE. 95 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | sqlite-simple: mid-level bindings to the sqlite database 2 | ======================================================== 3 | 4 | [![Build Status](https://github.com/nurpax/sqlite-simple/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/nurpax/sqlite-simple/actions/workflows/haskell-ci.yml) [![Hackage](https://img.shields.io/hackage/v/sqlite-simple.svg)](https://hackage.haskell.org/package/sqlite-simple) 5 | 6 | This library is a mid-level Haskell binding to the SQLite database. 7 | 8 | Sqlite-simple provides a convenient API to sqlite that does some level 9 | of automatic data conversion between the database and Haskell types. 10 | The API has been modeled directly after 11 | [postgresql-simple](http://github.com/lpsmith/postgresql-simple) which 12 | in turn borrows from 13 | [mysql-simple](https://github.com/bos/mysql-simple). 14 | 15 | [The sqlite-simple API 16 | reference](https://hackage.haskell.org/package/sqlite-simple/docs/Database-SQLite-Simple.html) 17 | contains more examples of use and information on its features. 18 | 19 | The library is well tested and stable. The library should also be 20 | reasonably performant. You can find its benchmark suite here: 21 | [db-bench](https://github.com/nurpax/db-bench). You can read more 22 | about sqlite-simple's expected performance in [my blog about 23 | sqlite-simple performance against direct-sqlite, Python and 24 | C](http://nurpax.github.io/posts/2013-08-17-sqlite-simple-benchmarking.html). 25 | 26 | 27 | ## Installation 28 | 29 | You can install [sqlite-simple from Hackage](http://hackage.haskell.org/package/sqlite-simple) 30 | with: 31 | 32 | ``` 33 | cabal install sqlite-simple 34 | ``` 35 | 36 | A Windows user? It works but please see [this note](https://gist.github.com/3907344) on direct-sqlite Windows installation. 37 | 38 | ## Examples of use 39 | 40 | Create a test database by copy&pasting the below snippet to your 41 | shell: 42 | 43 | ``` 44 | sqlite3 test.db "CREATE TABLE test (id INTEGER PRIMARY KEY, str text);\ 45 | INSERT INTO test (str) VALUES ('test string');" 46 | ``` 47 | 48 | ..and access it in Haskell: 49 | 50 | ```haskell 51 | {-# LANGUAGE OverloadedStrings #-} 52 | import Control.Applicative 53 | import Database.SQLite.Simple 54 | import Database.SQLite.Simple.FromRow 55 | 56 | data TestField = TestField Int String deriving (Show) 57 | 58 | instance FromRow TestField where 59 | fromRow = TestField <$> field <*> field 60 | 61 | main :: IO () 62 | main = do 63 | conn <- open "test.db" 64 | execute conn "INSERT INTO test (str) VALUES (?)" 65 | (Only ("test string 2" :: String)) 66 | r <- query_ conn "SELECT * from test" :: IO [TestField] 67 | mapM_ print r 68 | close conn 69 | ``` 70 | 71 | More simple usage examples can be found from [sqlite-simple unit 72 | tests](https://github.com/nurpax/sqlite-simple/blob/master/test/Simple.hs). 73 | 74 | 75 | ## Development 76 | 77 | The development roadmap for sqlite-simple is mostly captured in the 78 | github issue database. 79 | 80 | I'm happy to receive bug reports, fixes, documentation enhancements, 81 | and other improvements. 82 | 83 | Please report bugs via the 84 | [github issue tracker](http://github.com/nurpax/sqlite-simple/issues). 85 | 86 | For general database issues with a Haskell focus, I recommend sending 87 | e-mail to the [database-devel mailing 88 | list](http://www.haskell.org/mailman/listinfo/database-devel). 89 | 90 | ## Contributing 91 | 92 | If you send pull requests for new features, it'd be great if you could also develop unit 93 | tests for any such features. 94 | 95 | ## Credits 96 | 97 | - [Janne Hellsten](https://github.com/nurpax) author, long-term maintainer 98 | - [Sergey Bushnyak](https://github.com/sigrlami) long-term maintainer 99 | - [Joshua Chia](https://github.com/jchia) current maintainer 100 | 101 | A lot of the code is directly borrowed from 102 | [mysql-simple](http://github.com/bos/mysql-simple) by Bryan O'Sullivan 103 | and from 104 | [postgresql-simple](http://github.com/lpsmith/postgresql-simple) by 105 | Leon P. Smith. Like Leon in postgresql-simple, I borrow code and 106 | documentation directly from both of these ancestor libraries. 107 | 108 | This package builds on top of the 109 | [direct-sqlite](http://hackage.haskell.org/package/direct-sqlite) 110 | package by Irene Knapp. 111 | 112 | SQLite is rather weakly-typed and thus the SQL to Haskell type 113 | strictness of the parent projects does not necessarily apply to this 114 | package. 115 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | import Distribution.Simple 4 | 5 | main = defaultMain 6 | -------------------------------------------------------------------------------- /changelog: -------------------------------------------------------------------------------- 1 | 0.4.19.0 2 | * Generic derivation of `FromRow` and `ToRow` 3 | * Add `withSavePoint` 4 | * Add `MonadFail` instance of `Ok` 5 | 6 | 0.4.18.0 7 | * Allow semigroups-0.19 8 | * Support GHC 8.8.1 9 | 10 | 0.4.17.0 11 | * Add `createFunction` and `deleteFunction` 12 | 13 | 0.4.16.0 14 | * Add FromField instance for SQLData (thanks @LindaOrtega, @Shimuuar) 15 | * Add QuasiQuoter sql (thanks @vrom911) 16 | 17 | 0.4.15.0 18 | * Support GHC 8.4.1 (Add instance Semigroup Query) (thanks @gwils!) 19 | 20 | 0.4.14.0 21 | * Use @hvr's Only package for the Only single element typle type. 22 | 23 | 0.4.13.0 24 | * Add columnCount (thanks @Shimuuar!) 25 | * Add withImmediateTransaction, withExclusiveTransaction (thanks @mbucc!) 26 | * Expose the Database.SQLite3 Statement type through Database.SQLite.Simple Statement 27 | 28 | 0.4.12.1 29 | * Add Setup.hs (https://github.com/fpco/stackage/issues/2145) 30 | 31 | 0.4.12.0 32 | * Add queryWith 33 | 34 | 0.4.11.0 35 | * Add executeMany 36 | 37 | 0.4.10.0 38 | * Expose sqlite3_changes/total_changes 39 | 40 | 0.4.9.0 41 | * Provide queryWith_ to allow more fine-grained access to 42 | constructing queries. 43 | * Expose error data constructors (pull request #42) 44 | * Improve haddocks 45 | 46 | 0.4.8.0 47 | * Export `bindNamed' 48 | 49 | 0.4.7.0 50 | * Add `withTransaction' for running IO actions inside SQL 51 | transactions with automated rollback if any exceptions are thrown. 52 | 53 | 0.4.6.1 54 | * Fix unit test build break with older bytestring versions 55 | 56 | 0.4.6.0 57 | * Add "named parameters" variants of query & al. Named params 58 | allow queries like: 59 | res <- queryNamed conn "SELECT * FROM posts WHERE id = :id" [":id" := postId] 60 | * Add FromField instances for Int8, Word, Word8, Word16, Word32 61 | and Word64. 62 | * Fix typos in some type conversion error messages. 63 | * Improved test coverage. 64 | 65 | 0.4.5.2 66 | * Build fix for GHC 7.4 67 | 68 | 0.4.5.1 69 | * Docs changes - uploaded new version to Hackage to update the 70 | Hackage page. 71 | 72 | 0.4.5.0 73 | 74 | * Various improvements to documentation. Especially UTCTime 75 | parsing and printing, and how it relates to SQLite datetimes is 76 | better documented now. 77 | 78 | * Improved date/time parsing performance by adapting Leon 79 | P. Smith's parsers from postgresql-simple for SQLite. UTCTime 80 | handling is also better defined now. 81 | 82 | * Improved query performance 83 | (https://github.com/nurpax/sqlite-simple/issues/23) 84 | 85 | * Improved tests for all areas touched by the above change. 86 | 87 | v0.4.4.0 88 | 89 | * Add FromField instance for Float 90 | 91 | * Improve error handling for day parsing 92 | 93 | * + with tests 94 | 95 | v0.4.1.0 - v0.4.3.0 (missed tagging v0.4.2.0) 96 | 97 | * Improvements to withBind functionality and documentation 98 | (see https://github.com/nurpax/sqlite-simple/pull/26) 99 | 100 | * Add columnName accessor for statements 101 | 102 | * Expose MonadPlus on RowParser 103 | 104 | * Allow access to the underlying direct-sqilte connection from an 105 | sqlite-simple connection 106 | 107 | * Add Data.Text.Lazy and lazy ByteString From/ToField instances 108 | 109 | v0.4.0.0 110 | 111 | * Add lastInsertRowId 112 | 113 | * Expose SQLite statements based streaming API 114 | (see https://github.com/nurpax/sqlite-simple/pull/22) 115 | 116 | v0.3.0.0 117 | 118 | * Add fold, fold_, withConnection 119 | 120 | v0.2.0.0 - v0.2.1.0 121 | 122 | * Optimizations to improve query rows/sec performance 123 | -------------------------------------------------------------------------------- /devenv.sh: -------------------------------------------------------------------------------- 1 | 2 | # source this file for some helper commands 3 | 4 | # Run tests 5 | function rt () 6 | { 7 | cabal-dev build && ./dist/build/test/test 8 | } 9 | -------------------------------------------------------------------------------- /sqlite-simple.cabal: -------------------------------------------------------------------------------- 1 | Name: sqlite-simple 2 | Version: 0.4.19.0 3 | Synopsis: Mid-Level SQLite client library 4 | Description: 5 | Mid-level SQLite client library, based on postgresql-simple. 6 | . 7 | Main documentation (with examples): 8 | . 9 | You can view the project page at 10 | for more information. 11 | 12 | License: BSD3 13 | License-file: LICENSE 14 | Author: Bryan O'Sullivan, Leon P Smith, Janne Hellsten 15 | Maintainer: Janne Hellsten 16 | Copyright: (c) 2011 MailRank, Inc., 17 | (c) 2011-2012 Leon P Smith, 18 | (c) 2012-2014 Janne Hellsten 19 | (c) 2022-2024 Joshua Chia 20 | Homepage: http://github.com/nurpax/sqlite-simple 21 | bug-reports: http://github.com/nurpax/sqlite-simple/issues 22 | Stability: stable 23 | Category: Database 24 | Build-type: Simple 25 | 26 | Cabal-version: >= 1.10 27 | tested-with: GHC == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.8 || == 9.4.8 || == 9.6.4 || == 9.8.2 28 | extra-source-files: README.md 29 | changelog 30 | 31 | Library 32 | Default-language: Haskell2010 33 | Exposed-modules: 34 | Database.SQLite.Simple 35 | Database.SQLite.Simple.Ok 36 | Database.SQLite.Simple.FromField 37 | Database.SQLite.Simple.FromRow 38 | Database.SQLite.Simple.Internal 39 | Database.SQLite.Simple.QQ 40 | Database.SQLite.Simple.ToField 41 | Database.SQLite.Simple.ToRow 42 | Database.SQLite.Simple.Types 43 | Database.SQLite.Simple.Function 44 | Database.SQLite.Simple.Time 45 | Database.SQLite.Simple.Time.Implementation 46 | 47 | Build-depends: 48 | attoparsec >= 0.10.3, 49 | base < 5, 50 | blaze-builder, 51 | blaze-textual, 52 | bytestring >= 0.9, 53 | containers, 54 | direct-sqlite >= 2.3.13 && < 2.4, 55 | exceptions >= 0.4, 56 | template-haskell, 57 | text >= 0.11, 58 | time, 59 | transformers, 60 | Only >= 0.1 && < 0.1.1 61 | 62 | if impl(ghc < 8.0) 63 | Build-depends: semigroups >= 0.18 && < 0.20 64 | 65 | default-extensions: 66 | DoAndIfThenElse 67 | , OverloadedStrings 68 | , BangPatterns 69 | , ViewPatterns 70 | , TypeOperators 71 | 72 | ghc-options: -Wall -fno-warn-name-shadowing 73 | 74 | source-repository head 75 | type: git 76 | location: http://github.com/nurpax/sqlite-simple 77 | 78 | 79 | test-suite test 80 | default-language: Haskell2010 81 | type: exitcode-stdio-1.0 82 | 83 | hs-source-dirs: test 84 | main-is: Main.hs 85 | other-modules: Common 86 | , Debug 87 | , DirectSqlite 88 | , Errors 89 | , Fold 90 | , Function 91 | , ParamConv 92 | , QQ 93 | , Simple 94 | , Statement 95 | , TestImports 96 | , UserInstances 97 | , Utf8Strings 98 | 99 | ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind 100 | 101 | default-extensions: 102 | NamedFieldPuns 103 | , OverloadedStrings 104 | , Rank2Types 105 | , RecordWildCards 106 | 107 | build-depends: base 108 | , base16-bytestring 109 | , bytestring >= 0.9 110 | , HUnit 111 | , sqlite-simple 112 | , direct-sqlite 113 | , text 114 | , time 115 | -------------------------------------------------------------------------------- /stack-9.0.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-19.33 2 | -------------------------------------------------------------------------------- /stack-9.2.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.26 2 | -------------------------------------------------------------------------------- /stack-9.4.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.25 2 | -------------------------------------------------------------------------------- /stack-9.6.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-22.7 2 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | stack-9.6.yaml -------------------------------------------------------------------------------- /test/Common.hs: -------------------------------------------------------------------------------- 1 | 2 | module Common ( 3 | -- Note: Do not add more exports for SQLite.Simple here. This is 4 | -- so that we trap we by default export enough out of 5 | -- Database.SQLite.Simple to make it useful as a single import. 6 | module Database.SQLite.Simple 7 | , module Test.HUnit 8 | , TestEnv(..) 9 | ) where 10 | 11 | import Test.HUnit 12 | import Database.SQLite.Simple 13 | 14 | data TestEnv 15 | = TestEnv 16 | { conn :: Connection 17 | -- ^ Connection shared by all the tests 18 | } 19 | -------------------------------------------------------------------------------- /test/Debug.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Debug ( 4 | testDebugTracing) where 5 | 6 | import Control.Concurrent 7 | import Common 8 | 9 | -- Simplest SELECT 10 | testDebugTracing :: TestEnv -> Test 11 | testDebugTracing TestEnv{..} = TestCase $ do 12 | chan <- newChan 13 | let logger m = writeChan chan m 14 | setTrace conn (Just logger) 15 | execute_ conn "SELECT null" 16 | msg <- readChan chan 17 | "SELECT null" @=? msg 18 | execute conn "SELECT 1+?" (Only (2 :: Int)) 19 | execute conn "SELECT 1+?" (Only (3 :: Int)) 20 | msg <- readChan chan 21 | "SELECT 1+2" @=? msg 22 | msg <- readChan chan 23 | "SELECT 1+3" @=? msg 24 | -- Check that disabling works too 25 | setTrace conn Nothing 26 | execute_ conn "SELECT null" 27 | writeChan chan "empty" 28 | msg <- readChan chan 29 | "empty" @=? msg 30 | -------------------------------------------------------------------------------- /test/DirectSqlite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module DirectSqlite ( 5 | testDirectSqlite 6 | ) where 7 | 8 | import Common 9 | 10 | import Control.Exception (bracket) 11 | import qualified Database.SQLite3 as DS 12 | 13 | testDirectSqlite :: TestEnv -> Test 14 | testDirectSqlite TestEnv{..} = TestCase $ do 15 | let dsConn = connectionHandle conn 16 | bracket (DS.prepare dsConn "SELECT 1+1") DS.finalize testDirect 17 | [Only (res :: Int)] <- query_ conn "SELECT 1+2" 18 | assertEqual "1+2" 3 res 19 | where 20 | testDirect stmt = do 21 | DS.Row <- DS.step stmt 22 | res <- DS.column stmt 0 23 | assertEqual "1+1" (SQLInteger 2) res 24 | -------------------------------------------------------------------------------- /test/Errors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Errors ( 4 | testErrorsColumns 5 | , testErrorsInvalidParams 6 | , testErrorsInvalidNamedParams 7 | , testErrorsWithStatement 8 | , testErrorsColumnName 9 | , testErrorsTransaction 10 | , testErrorsImmediateTransaction 11 | , testErrorsExclusiveTransaction 12 | , testErrorsSavepoint 13 | ) where 14 | 15 | import Control.Exception 16 | import qualified Data.ByteString as B 17 | import qualified Data.ByteString.Lazy as LB 18 | import qualified Data.Text as T 19 | import qualified Data.Text.Lazy as LT 20 | import Data.Word 21 | import Data.Time (Day, UTCTime) 22 | 23 | import Common 24 | import Database.SQLite.Simple.Types (Null) 25 | 26 | assertResultErrorThrown :: IO a -> ResultError -> Assertion 27 | assertResultErrorThrown action expectedError = 28 | catch 29 | (action >> assertFailure ("Expected error: " ++ show expectedError ++ ", but nothing was thrown")) 30 | (\(e :: ResultError) -> assertEqual "assertResultErrorThrown" expectedError e) 31 | 32 | assertFormatErrorCaught :: IO a -> Assertion 33 | assertFormatErrorCaught action = do 34 | catch (action >> return False) (\(e :: FormatError) -> length (show e) `seq` return True) >>= 35 | assertBool "assertFormatError exc" 36 | 37 | assertSQLErrorCaught :: IO a -> Assertion 38 | assertSQLErrorCaught action = do 39 | catch (action >> return False) (\(e :: SQLError) -> length (show e) `seq` return True) >>= 40 | assertBool "assertSQLError exc" 41 | 42 | assertOOBCaught :: IO a -> Assertion 43 | assertOOBCaught action = do 44 | catch (action >> return False) (\(e :: ArrayException) -> length (show e) `seq` return True) >>= 45 | assertBool "assertOOBCaught exc" 46 | 47 | testErrorsColumns :: TestEnv -> Test 48 | testErrorsColumns TestEnv{..} = TestCase $ do 49 | execute_ conn "CREATE TABLE cols (id INTEGER PRIMARY KEY, t TEXT)" 50 | execute_ conn "INSERT INTO cols (t) VALUES ('test string')" 51 | rows <- query_ conn "SELECT t FROM cols" :: IO [Only String] 52 | assertEqual "row count" 1 (length rows) 53 | assertEqual "string" (Only "test string") (head rows) 54 | -- Mismatched number of output columns (selects two, dest type has 1 field) 55 | assertResultErrorThrown (query_ conn "SELECT id,t FROM cols" :: IO [Only Int]) 56 | ConversionFailed 57 | { errSQLType = "2 values: [(\"INTEGER\",\"SQLInteger 1\"),(\"TEXT\",\"SQLText \\\"test s[...]\")]" 58 | , errHaskellType = "at least 1 slots in target type" 59 | , errMessage = "mismatch between number of columns to convert and number in target type" 60 | } 61 | -- Same as above but the other way round (select 1, dst has two) 62 | assertResultErrorThrown (query_ conn "SELECT id FROM cols" :: IO [(Int, String)]) 63 | ConversionFailed 64 | { errSQLType = "1 values: [(\"INTEGER\",\"SQLInteger 1\")]" 65 | , errHaskellType = "at least 2 slots in target type" 66 | , errMessage = "mismatch between number of columns to convert and number in target type" 67 | } 68 | -- Mismatching types (source int,text doesn't match dst string,int) 69 | assertResultErrorThrown (query_ conn "SELECT id, t FROM cols" :: IO [(String, Int)]) 70 | ConversionFailed {errSQLType = "INTEGER", errHaskellType = "[Char]", errMessage = "expecting SQLText column type"} 71 | -- Mismatching types (source string doesn't match dst integer) 72 | assertResultErrorThrown (query_ conn "SELECT 'foo'" :: IO [Only Integer]) 73 | ConversionFailed {errSQLType = "TEXT", errHaskellType = "Integer", errMessage = "need an int"} 74 | -- Mismatching types (sources don't match destination float/double type) 75 | assertResultErrorThrown (query_ conn "SELECT 1" :: IO [Only Double]) 76 | ConversionFailed {errSQLType = "INTEGER", errHaskellType = "Double", errMessage = "expecting an SQLFloat column type"} 77 | assertResultErrorThrown (query_ conn "SELECT 'foo'" :: IO [Only Double]) 78 | ConversionFailed {errSQLType = "TEXT", errHaskellType = "Double", errMessage = "expecting an SQLFloat column type"} 79 | assertResultErrorThrown (query_ conn "SELECT 1" :: IO [Only Float]) 80 | ConversionFailed {errSQLType = "INTEGER", errHaskellType = "Float", errMessage = "expecting an SQLFloat column type"} 81 | assertResultErrorThrown (query_ conn "SELECT 'foo'" :: IO [Only Float]) 82 | ConversionFailed {errSQLType = "TEXT", errHaskellType = "Float", errMessage = "expecting an SQLFloat column type"} 83 | -- Mismatching types (sources don't match destination bool type, or is out of bounds) 84 | assertResultErrorThrown (query_ conn "SELECT 'true'" :: IO [Only Bool]) 85 | ConversionFailed {errSQLType = "TEXT", errHaskellType = "Bool", errMessage = "expecting an SQLInteger column type"} 86 | assertResultErrorThrown (query_ conn "SELECT 2" :: IO [Only Bool]) 87 | ConversionFailed {errSQLType = "INTEGER", errHaskellType = "Bool", errMessage = "bool must be 0 or 1, got 2"} 88 | -- Mismatching types (sources don't match destination string types (text, string) 89 | assertResultErrorThrown (query_ conn "SELECT 1" :: IO [Only T.Text]) 90 | ConversionFailed {errSQLType = "INTEGER", errHaskellType = "Text", errMessage = "need a text"} 91 | assertResultErrorThrown (query_ conn "SELECT 1" :: IO [Only LT.Text]) 92 | ConversionFailed {errSQLType = "INTEGER", errHaskellType = "Text", errMessage = "need a text"} 93 | assertResultErrorThrown (query_ conn "SELECT 1.0" :: IO [Only T.Text]) 94 | ConversionFailed {errSQLType = "FLOAT", errHaskellType = "Text", errMessage = "need a text"} 95 | assertResultErrorThrown (query_ conn "SELECT 1.0" :: IO [Only LT.Text]) 96 | ConversionFailed {errSQLType = "FLOAT", errHaskellType = "Text", errMessage = "need a text"} 97 | -- Mismatching types (sources don't match destination string types (time/date) 98 | assertResultErrorThrown (query_ conn "SELECT 1" :: IO [Only UTCTime]) 99 | ConversionFailed {errSQLType = "INTEGER", errHaskellType = "UTCTime", errMessage = "expecting SQLText column type"} 100 | assertResultErrorThrown (query_ conn "SELECT 1" :: IO [Only Day]) 101 | ConversionFailed {errSQLType = "INTEGER", errHaskellType = "Day", errMessage = "expecting SQLText column type"} 102 | -- Mismatching types (sources don't match destination bytestring) 103 | [Only (_ :: B.ByteString)] <- query_ conn "SELECT X'3177'" 104 | assertResultErrorThrown (query_ conn "SELECT 1" :: IO [Only B.ByteString]) 105 | ConversionFailed {errSQLType = "INTEGER", errHaskellType = "ByteString", errMessage = "expecting SQLBlob column type"} 106 | assertResultErrorThrown (query_ conn "SELECT 1" :: IO [Only LB.ByteString]) 107 | ConversionFailed {errSQLType = "INTEGER", errHaskellType = "ByteString", errMessage = "expecting SQLBlob column type"} 108 | assertResultErrorThrown (query_ conn "SELECT 'foo'" :: IO [Only B.ByteString]) 109 | ConversionFailed {errSQLType = "TEXT", errHaskellType = "ByteString", errMessage = "expecting SQLBlob column type"} 110 | assertResultErrorThrown (query_ conn "SELECT 'foo'" :: IO [Only LB.ByteString]) 111 | ConversionFailed {errSQLType = "TEXT", errHaskellType = "ByteString", errMessage = "expecting SQLBlob column type"} 112 | -- Trying to get a blob into a string 113 | let d = B.pack ([0..127] :: [Word8]) 114 | execute_ conn "CREATE TABLE cols_blobs (id INTEGER, b BLOB)" 115 | execute conn "INSERT INTO cols_blobs (id, b) VALUES (?,?)" (1 :: Int, d) 116 | assertResultErrorThrown 117 | (do [Only _t1] <- query conn "SELECT b FROM cols_blobs WHERE id = ?" (Only (1 :: Int)) :: IO [Only String] 118 | return ()) 119 | ConversionFailed {errSQLType = "BLOB", errHaskellType = "[Char]", errMessage = "expecting SQLText column type"} 120 | execute_ conn "CREATE TABLE cols_bools (id INTEGER PRIMARY KEY, b BOOLEAN)" 121 | -- 3 = invalid value for bool, must be 0 or 1 122 | execute_ conn "INSERT INTO cols_bools (b) VALUES (3)" 123 | assertResultErrorThrown 124 | (do [Only _t1] <- query_ conn "SELECT b FROM cols_bools" :: IO [Only Bool] 125 | return ()) 126 | ConversionFailed {errSQLType = "INTEGER", errHaskellType = "Bool", errMessage = "bool must be 0 or 1, got 3"} 127 | [Only (nullVal :: Null)] <- query_ conn "SELECT NULL" 128 | False @=? nullVal == nullVal 129 | False @=? nullVal /= nullVal 130 | assertResultErrorThrown 131 | (do [Only (_t1 :: Null)] <- query_ conn "SELECT 1" :: IO [Only Null] 132 | return ()) 133 | ConversionFailed {errSQLType = "INTEGER", errHaskellType = "Null", errMessage = "data is not null"} 134 | 135 | testErrorsInvalidParams :: TestEnv -> Test 136 | testErrorsInvalidParams TestEnv{..} = TestCase $ do 137 | execute_ conn "CREATE TABLE invparams (id INTEGER PRIMARY KEY, t TEXT)" 138 | -- Test that only unnamed params are accepted 139 | assertFormatErrorCaught 140 | (execute conn "INSERT INTO invparams (t) VALUES (:v)" (Only ("foo" :: String))) 141 | assertFormatErrorCaught 142 | (execute conn "INSERT INTO invparams (id, t) VALUES (:v,$1)" (3::Int, "foo" :: String)) 143 | -- In this case, we have two bound params but only one given to 144 | -- execute. This should cause an error. 145 | assertFormatErrorCaught 146 | (execute conn "INSERT INTO invparams (id, t) VALUES (?, ?)" (Only (3::Int))) 147 | 148 | testErrorsInvalidNamedParams :: TestEnv -> Test 149 | testErrorsInvalidNamedParams TestEnv{..} = TestCase $ do 150 | -- Test that only unnamed params are accepted 151 | assertFormatErrorCaught 152 | (queryNamed conn "SELECT :foo" [":foox" := (1 :: Int)] :: IO [Only Int]) 153 | -- In this case, we have two bound params but only one given to 154 | -- execute. This should cause an error. 155 | assertFormatErrorCaught 156 | (queryNamed conn "SELECT :foo + :bar" [":foo" := (1 :: Int)] :: IO [Only Int]) 157 | -- Can't use named params in SQL string with the unnamed query/exec variants 158 | assertFormatErrorCaught 159 | (query conn "SELECT :foo" (Only (1 :: Int)) :: IO [Only Int]) 160 | 161 | testErrorsWithStatement :: TestEnv -> Test 162 | testErrorsWithStatement TestEnv{..} = TestCase $ do 163 | execute_ conn "CREATE TABLE invstat (id INTEGER PRIMARY KEY, t TEXT)" 164 | assertSQLErrorCaught $ 165 | withStatement conn "SELECT id, t, t1 FROM invstat" $ \_stmt -> 166 | assertFailure "Error not detected" 167 | 168 | testErrorsColumnName :: TestEnv -> Test 169 | testErrorsColumnName TestEnv{..} = TestCase $ do 170 | execute_ conn "CREATE TABLE invcolumn (id INTEGER PRIMARY KEY, t TEXT)" 171 | assertOOBCaught $ 172 | withStatement conn "SELECT id FROM invcolumn" $ \stmt -> 173 | columnName stmt (ColumnIndex (-1)) >> assertFailure "Error not detected" 174 | 175 | testErrorsTransaction :: TestEnv -> Test 176 | testErrorsTransaction TestEnv{..} = TestCase $ do 177 | execute_ conn "CREATE TABLE trans (id INTEGER PRIMARY KEY, t TEXT)" 178 | v <- withTransaction conn $ do 179 | executeNamed conn "INSERT INTO trans (t) VALUES (:txt)" [":txt" := ("foo" :: String)] 180 | [Only r] <- query_ conn "SELECT t FROM trans" :: IO [Only String] 181 | return r 182 | v @=? "foo" 183 | e <- rowExists 184 | True @=? e 185 | execute_ conn "DELETE FROM trans" 186 | e <- rowExists 187 | False @=? e 188 | assertFormatErrorCaught 189 | (withTransaction conn $ do 190 | -- this execute should be automatically rolled back on error 191 | executeNamed conn 192 | "INSERT INTO trans (t) VALUES (:txt)" [":txt" := ("foo" :: String)] 193 | -- intentional mistake here to hit an error & cause rollback of txn 194 | executeNamed conn 195 | "INSERT INTO trans (t) VALUES (:txt)" [":missing" := ("foo" :: String)]) 196 | e <- rowExists 197 | False @=? e 198 | where 199 | rowExists = do 200 | rows <- query_ conn "SELECT t FROM trans" :: IO [Only String] 201 | case rows of 202 | [Only txt] -> do 203 | "foo" @=? txt 204 | return True 205 | [] -> 206 | return False 207 | _ -> error "should have only one row" 208 | 209 | testErrorsImmediateTransaction :: TestEnv -> Test 210 | testErrorsImmediateTransaction TestEnv{..} = TestCase $ do 211 | execute_ conn "CREATE TABLE itrans (id INTEGER PRIMARY KEY, t TEXT)" 212 | v <- withImmediateTransaction conn $ do 213 | executeNamed conn "INSERT INTO itrans (t) VALUES (:txt)" [":txt" := ("foo" :: String)] 214 | [Only r] <- query_ conn "SELECT t FROM itrans" :: IO [Only String] 215 | return r 216 | v @=? "foo" 217 | e <- rowExists 218 | True @=? e 219 | execute_ conn "DELETE FROM itrans" 220 | e <- rowExists 221 | False @=? e 222 | assertFormatErrorCaught 223 | (withImmediateTransaction conn $ do 224 | -- this execute should be automatically rolled back on error 225 | executeNamed conn 226 | "INSERT INTO itrans (t) VALUES (:txt)" [":txt" := ("foo" :: String)] 227 | -- intentional mistake here to hit an error & cause rollback of txn 228 | executeNamed conn 229 | "INSERT INTO itrans (t) VALUES (:txt)" [":missing" := ("foo" :: String)]) 230 | e <- rowExists 231 | False @=? e 232 | where 233 | rowExists = do 234 | rows <- query_ conn "SELECT t FROM itrans" :: IO [Only String] 235 | case rows of 236 | [Only txt] -> do 237 | "foo" @=? txt 238 | return True 239 | [] -> 240 | return False 241 | _ -> error "should have only one row" 242 | 243 | testErrorsExclusiveTransaction :: TestEnv -> Test 244 | testErrorsExclusiveTransaction TestEnv{..} = TestCase $ do 245 | execute_ conn "CREATE TABLE etrans (id INTEGER PRIMARY KEY, t TEXT)" 246 | v <- withExclusiveTransaction conn $ do 247 | executeNamed conn "INSERT INTO etrans (t) VALUES (:txt)" [":txt" := ("foo" :: String)] 248 | [Only r] <- query_ conn "SELECT t FROM etrans" :: IO [Only String] 249 | return r 250 | v @=? "foo" 251 | e <- rowExists 252 | True @=? e 253 | execute_ conn "DELETE FROM etrans" 254 | e <- rowExists 255 | False @=? e 256 | assertFormatErrorCaught 257 | (withExclusiveTransaction conn $ do 258 | -- this execute should be automatically rolled back on error 259 | executeNamed conn 260 | "INSERT INTO etrans (t) VALUES (:txt)" [":txt" := ("foo" :: String)] 261 | -- intentional mistake here to hit an error & cause rollback of txn 262 | executeNamed conn 263 | "INSERT INTO etrans (t) VALUES (:txt)" [":missing" := ("foo" :: String)]) 264 | e <- rowExists 265 | False @=? e 266 | where 267 | rowExists = do 268 | rows <- query_ conn "SELECT t FROM etrans" :: IO [Only String] 269 | case rows of 270 | [Only txt] -> do 271 | "foo" @=? txt 272 | return True 273 | [] -> 274 | return False 275 | _ -> error "should have only one row" 276 | 277 | testErrorsSavepoint :: TestEnv -> Test 278 | testErrorsSavepoint TestEnv{..} = TestCase $ do 279 | execute_ conn "CREATE TABLE strans (id INTEGER PRIMARY KEY, t TEXT)" 280 | v <- withSavepoint conn $ do 281 | executeNamed conn "INSERT INTO strans (t) VALUES (:txt)" [":txt" := ("foo" :: String)] 282 | [Only r] <- query_ conn "SELECT t FROM strans" :: IO [Only String] 283 | return r 284 | v @=? "foo" 285 | e <- rowExists 286 | True @=? e 287 | execute_ conn "DELETE FROM strans" 288 | e <- rowExists 289 | False @=? e 290 | assertFormatErrorCaught 291 | (withSavepoint conn $ do 292 | -- this execute should be automatically rolled back on error 293 | executeNamed conn 294 | "INSERT INTO strans (t) VALUES (:txt)" [":txt" := ("foo" :: String)] 295 | -- intentional mistake here to hit an error & cause rollback of txn 296 | executeNamed conn 297 | "INSERT INTO strans (t) VALUES (:txt)" [":missing" := ("foo" :: String)]) 298 | e <- rowExists 299 | False @=? e 300 | where 301 | rowExists = do 302 | rows <- query_ conn "SELECT t FROM strans" :: IO [Only String] 303 | case rows of 304 | [Only txt] -> do 305 | "foo" @=? txt 306 | return True 307 | [] -> 308 | return False 309 | _ -> error "should have only one row" 310 | -------------------------------------------------------------------------------- /test/Fold.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} 2 | 3 | module Fold ( 4 | testFolds) where 5 | 6 | import Common 7 | 8 | testFolds :: TestEnv -> Test 9 | testFolds TestEnv{..} = TestCase $ do 10 | execute_ conn "CREATE TABLE testf (id INTEGER PRIMARY KEY, t INT)" 11 | execute_ conn "INSERT INTO testf (t) VALUES (4)" 12 | execute_ conn "INSERT INTO testf (t) VALUES (5)" 13 | execute_ conn "INSERT INTO testf (t) VALUES (6)" 14 | val <- fold_ conn "SELECT id,t FROM testf" ([],[]) sumValues 15 | assertEqual "fold_" ([3,2,1], [6,5,4]) val 16 | val <- fold conn "SELECT id,t FROM testf WHERE id > ?" (Only (1 :: Int)) ([],[]) sumValues 17 | assertEqual "fold" ([3,2], [6,5]) val 18 | val <- foldNamed conn "SELECT id,t FROM testf WHERE id > :id" [":id" := (1 :: Int)] ([],[]) sumValues 19 | assertEqual "fold" ([3,2], [6,5]) val 20 | where 21 | sumValues (accId, accT) (id_ :: Int, t :: Int) = return $ (id_ : accId, t : accT) 22 | -------------------------------------------------------------------------------- /test/Function.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Function ( 3 | testExternalAddition 4 | ) where 5 | 6 | import Control.Monad 7 | import Common 8 | import Database.SQLite.Simple.Function 9 | 10 | testExternalAddition :: TestEnv -> Test 11 | testExternalAddition TestEnv{..} = TestCase $ do 12 | createFunction conn "my_add" ((+) :: Int -> Int -> Int) 13 | forM_ ([1 .. 10] :: [Int]) $ \x -> 14 | forM_ ([1 .. 10] :: [Int]) $ \y -> do 15 | [Only r] <- query conn "SELECT my_add(?,?)" (x,y) 16 | assertEqual (show x ++ " + " ++ show y ++ " = " ++ show r) (x + y) r 17 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | import Common 2 | import Control.Exception (bracket) 3 | import Control.Monad (when) 4 | import System.Exit (exitFailure) 5 | import System.IO 6 | 7 | import Debug 8 | import DirectSqlite 9 | import Errors 10 | import Fold 11 | import ParamConv 12 | import QQ 13 | import Simple 14 | import Function 15 | import Statement 16 | import TestImports() 17 | import TestImports 18 | import UserInstances 19 | import Utf8Strings 20 | 21 | tests :: [TestEnv -> Test] 22 | tests = 23 | [ TestLabel "Simple" . testSimpleSelect 24 | , TestLabel "Simple" . testSimpleOnePlusOne 25 | , TestLabel "Simple" . testSimpleParams 26 | , TestLabel "Simple" . testSimpleTime 27 | , TestLabel "Simple" . testSimpleTimeFract 28 | , TestLabel "Simple" . testSimpleInsertId 29 | , TestLabel "Simple" . testSimpleMultiInsert 30 | , TestLabel "Simple" . testSimpleUTCTime 31 | , TestLabel "Simple" . testSimpleUTCTimeTZ 32 | , TestLabel "Simple" . testSimpleUTCTimeParams 33 | , TestLabel "Simple" . testSimpleQueryCov 34 | , TestLabel "Simple" . testSimpleStrings 35 | , TestLabel "Simple" . testSimpleChanges 36 | , TestLabel "ParamConv" . testParamConvNull 37 | , TestLabel "ParamConv" . testParamConvInt 38 | , TestLabel "ParamConv" . testParamConvIntWidths 39 | , TestLabel "ParamConv" . testParamConvIntWidthsFromField 40 | , TestLabel "ParamConv" . testParamConvFloat 41 | , TestLabel "ParamConv" . testParamConvDateTime 42 | , TestLabel "ParamConv" . testParamConvBools 43 | , TestLabel "ParamConv" . testParamConvToRow 44 | , TestLabel "ParamConv" . testParamConvFromRow 45 | , TestLabel "ParamConv" . testParamConvComposite 46 | , TestLabel "ParamConv" . testParamNamed 47 | , TestLabel "Errors" . testErrorsColumns 48 | , TestLabel "Errors" . testErrorsInvalidParams 49 | , TestLabel "Errors" . testErrorsInvalidNamedParams 50 | , TestLabel "Errors" . testErrorsWithStatement 51 | , TestLabel "Errors" . testErrorsColumnName 52 | , TestLabel "Errors" . testErrorsTransaction 53 | , TestLabel "Errors" . testErrorsImmediateTransaction 54 | , TestLabel "Errors" . testErrorsExclusiveTransaction 55 | , TestLabel "Errors" . testErrorsSavepoint 56 | , TestLabel "Utf8" . testUtf8Simplest 57 | , TestLabel "Utf8" . testBlobs 58 | , TestLabel "Instances" . testUserFromField 59 | , TestLabel "Instances" . testSQLDataFromField 60 | , TestLabel "Fold" . testFolds 61 | , TestLabel "Statement" . testBind 62 | , TestLabel "Statement" . testDoubleBind 63 | , TestLabel "Statement" . testPreparedStatements 64 | , TestLabel "Statement" . testPreparedStatementsColumnCount 65 | , TestLabel "Debug" . testDebugTracing 66 | , TestLabel "Functions" . testExternalAddition 67 | , TestLabel "Direct" . testDirectSqlite 68 | , TestLabel "Imports" . testImports 69 | , TestLabel "QQ" . testSimpleQQ 70 | , TestLabel "QQ" . testMultiLinedQQ 71 | ] 72 | 73 | -- | Action for connecting to the database that will be used for testing. 74 | -- 75 | -- Note that some tests, such as Notify, use multiple connections, and assume 76 | -- that 'testConnect' connects to the same database every time it is called. 77 | testConnect :: IO Connection 78 | testConnect = open ":memory:" 79 | 80 | withTestEnv :: (TestEnv -> IO a) -> IO a 81 | withTestEnv cb = 82 | withConn $ \conn -> cb TestEnv { conn = conn } 83 | where 84 | withConn = bracket testConnect close 85 | 86 | main :: IO () 87 | main = do 88 | mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr] 89 | Counts{cases, tried, errors, failures} <- 90 | withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests 91 | when (cases /= tried || errors /= 0 || failures /= 0) $ exitFailure 92 | -------------------------------------------------------------------------------- /test/ParamConv.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, OverloadedStrings, CPP #-} 2 | 3 | #if MIN_VERSION_base(4,9,0) 4 | {-# OPTIONS_GHC -Wno-overflowed-literals #-} 5 | #endif 6 | 7 | module ParamConv ( 8 | testParamConvNull 9 | , testParamConvInt 10 | , testParamConvIntWidths 11 | , testParamConvIntWidthsFromField 12 | , testParamConvFloat 13 | , testParamConvBools 14 | , testParamConvDateTime 15 | , testParamConvFromRow 16 | , testParamConvToRow 17 | , testParamConvComposite 18 | , testParamNamed) where 19 | 20 | import Data.Int 21 | import Data.Word 22 | import Data.Time 23 | import qualified Data.Text as T 24 | import Database.SQLite.Simple.Types (Null(..)) 25 | 26 | import Common 27 | 28 | one, two, three :: Int 29 | one = 1 30 | two = 2 31 | three = 3 32 | 33 | testParamConvNull :: TestEnv -> Test 34 | testParamConvNull TestEnv{..} = TestCase $ do 35 | execute_ conn "CREATE TABLE nulltype (id INTEGER PRIMARY KEY, t1 TEXT)" 36 | [Only r] <- (query_ conn "SELECT NULL") :: IO [Only Null] 37 | execute conn "INSERT INTO nulltype (id, t1) VALUES (?,?)" (one, r) 38 | [Only mr1] <- query_ conn "SELECT t1 FROM nulltype WHERE id = 1" :: IO [Only (Maybe String)] 39 | assertEqual "nulls" Nothing mr1 40 | execute conn "INSERT INTO nulltype (id, t1) VALUES (?,?)" (two, "foo" :: String) 41 | [mr2] <- query_ conn "SELECT t1 FROM nulltype WHERE id = 2" :: IO [Only (Maybe String)] 42 | assertEqual "nulls" (Just "foo") (fromOnly mr2) 43 | 44 | testParamConvInt :: TestEnv -> Test 45 | testParamConvInt TestEnv{..} = TestCase $ do 46 | [Only r] <- (query conn "SELECT ?" (Only one)) :: IO [Only Int] 47 | assertEqual "value" 1 r 48 | [Only r] <- (query conn "SELECT ?" (Only one)) :: IO [Only Integer] 49 | assertEqual "value" 1 r 50 | [Only r] <- (query conn "SELECT ?+?" (one, two)) :: IO [Only Int] 51 | assertEqual "value" 3 r 52 | [Only r] <- (query conn "SELECT ?+?" (one, 15 :: Int64)) :: IO [Only Int] 53 | assertEqual "value" 16 r 54 | [Only r] <- (query conn "SELECT ?+?" (two, 14 :: Int32)) :: IO [Only Int] 55 | assertEqual "value" 16 r 56 | [Only r] <- (query conn "SELECT ?+?" (two, 14 :: Integer)) :: IO [Only Int] 57 | assertEqual "value" 16 r 58 | -- This overflows 32-bit ints, verify that we get more than 32-bits out 59 | [Only r] <- (query conn "SELECT 255*?" (Only (0x7FFFFFFF :: Int32))) :: IO [Only Int64] 60 | assertEqual "> 32-bit result" 61 | (255*0x7FFFFFFF :: Int64) (fromIntegral r) 62 | [Only r] <- (query conn "SELECT 2*?" (Only (0x7FFFFFFFFF :: Int64))) :: IO [Only Int64] 63 | assertEqual "> 32-bit result & param" 64 | (2*0x7FFFFFFFFF :: Int64) (fromIntegral r) 65 | [Only r] <- (query_ conn "SELECT NULL") :: IO [Only (Maybe Int)] 66 | assertEqual "should see nothing" Nothing r 67 | [Only r] <- (query_ conn "SELECT 3") :: IO [Only (Maybe Int)] 68 | assertEqual "should see Just 3" (Just 3) r 69 | [Only r] <- (query conn "SELECT ?") (Only (Nothing :: Maybe Int)) :: IO [Only (Maybe Int)] 70 | assertEqual "should see nothing" Nothing r 71 | [Only r] <- (query conn "SELECT ?") (Only (Just three :: Maybe Int)) :: IO [Only (Maybe Int)] 72 | assertEqual "should see 4" (Just 3) r 73 | 74 | testParamConvIntWidths :: TestEnv -> Test 75 | testParamConvIntWidths TestEnv{..} = TestCase $ do 76 | [Only r] <- (query conn "SELECT ?" (Only (1 :: Int8))) :: IO [Only Int] 77 | assertEqual "value" 1 r 78 | [Only r] <- (query conn "SELECT ?" (Only (257 :: Int8))) :: IO [Only Int] -- wrap around 79 | assertEqual "value" 1 r 80 | [Only r] <- (query conn "SELECT ?" (Only (257 :: Int16))) :: IO [Only Int] 81 | assertEqual "value" 257 r 82 | [Only r] <- (query conn "SELECT ?" (Only (258 :: Int32))) :: IO [Only Int] 83 | assertEqual "value" 258 r 84 | [Only r] <- (query conn "SELECT ?" (Only (1 :: Word8))) :: IO [Only Int] 85 | assertEqual "value" 1 r 86 | [Only r] <- (query conn "SELECT ?" (Only (257 :: Word8))) :: IO [Only Int] -- wrap around 87 | assertEqual "value" 1 r 88 | [Only r] <- (query conn "SELECT ?" (Only (257 :: Word16))) :: IO [Only Int] 89 | assertEqual "value" 257 r 90 | [Only r] <- (query conn "SELECT ?" (Only (257 :: Word32))) :: IO [Only Int] 91 | assertEqual "value" 257 r 92 | [Only r] <- (query conn "SELECT ?" (Only (0x100000000 :: Word64))) :: IO [Only Int] 93 | assertEqual "value" 0x100000000 r 94 | [Only r] <- (query conn "SELECT ?" (Only (1 :: Integer))) :: IO [Only Int] 95 | assertEqual "value" 1 r 96 | [Only r] <- (query conn "SELECT ?" (Only (1 :: Word))) :: IO [Only Int] 97 | assertEqual "value" 1 r 98 | 99 | testParamConvIntWidthsFromField :: TestEnv -> Test 100 | testParamConvIntWidthsFromField TestEnv{..} = TestCase $ do 101 | [Only r] <- (query conn "SELECT ?" (Only (1 :: Int))) :: IO [Only Int8] 102 | assertEqual "value" 1 r 103 | [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Int8] -- wrap around 104 | assertEqual "value" 1 r 105 | [Only r] <- (query conn "SELECT ?" (Only (65536 :: Int))) :: IO [Only Int16] -- wrap around 106 | assertEqual "value" 0 r 107 | [Only r] <- (query conn "SELECT ?" (Only (65536 :: Int))) :: IO [Only Int32] -- wrap around 108 | assertEqual "value" 65536 r 109 | [Only r] <- (query conn "SELECT ?" (Only (258 :: Int))) :: IO [Only Int32] 110 | assertEqual "value" 258 r 111 | [Only r] <- (query conn "SELECT ?" (Only (1 :: Int))) :: IO [Only Word8] 112 | assertEqual "value" 1 r 113 | [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Word8] -- wrap around 114 | assertEqual "value" 1 r 115 | [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Word16] 116 | assertEqual "value" 257 r 117 | [Only r] <- (query conn "SELECT ?" (Only (257 :: Int))) :: IO [Only Word32] 118 | assertEqual "value" 257 r 119 | [Only r] <- (query conn "SELECT ?" (Only (0x100000000 :: Int64))) :: IO [Only Word64] 120 | assertEqual "value" 0x100000000 r 121 | [Only r] <- (query conn "SELECT ?" (Only (1 :: Int))) :: IO [Only Word] 122 | assertEqual "value" 1 r 123 | 124 | testParamConvFloat :: TestEnv -> Test 125 | testParamConvFloat TestEnv{..} = TestCase $ do 126 | [Only r] <- query conn "SELECT ?" (Only (1.0 :: Double)) :: IO [Only Double] 127 | assertEqual "value" 1.0 r 128 | [Only r] <- query conn "SELECT ?*0.25" (Only (8.0 :: Double)) :: IO [Only Double] 129 | assertEqual "value" 2.0 r 130 | 131 | testParamConvDateTime :: TestEnv -> Test 132 | testParamConvDateTime TestEnv{..} = TestCase $ do 133 | execute_ conn "CREATE TABLE dt (id INTEGER PRIMARY KEY, t1 DATE, t2 TIMESTAMP)" 134 | execute_ conn "INSERT INTO dt (t1, t2) VALUES (date('now'), datetime('now'))" 135 | _rows <- query_ conn "SELECT t1,t2 from dt" :: IO [(Day, UTCTime)] 136 | -- TODO should _rows be forced to make sure parsers kick on the 137 | -- returned data? 138 | execute conn "INSERT INTO dt (t1,t2) VALUES (?,?)" 139 | (read "2012-08-12" :: Day, read "2012-08-12 01:01:01 UTC" :: UTCTime) 140 | [_,(t1,t2)] <- query_ conn "SELECT t1,t2 from dt" :: IO [(Day, UTCTime)] 141 | assertEqual "day" (read "2012-08-12" :: Day) t1 142 | assertEqual "day" (read "2012-08-12 01:01:01 UTC" :: UTCTime) t2 143 | 144 | 145 | testParamConvBools :: TestEnv -> Test 146 | testParamConvBools TestEnv{..} = TestCase $ do 147 | execute_ conn "CREATE TABLE bt (id INTEGER PRIMARY KEY, b BOOLEAN)" 148 | -- Booleans are ints with values 0 or 1 on SQLite 149 | execute_ conn "INSERT INTO bt (b) VALUES (0)" 150 | execute_ conn "INSERT INTO bt (b) VALUES (1)" 151 | [Only r1, Only r2] <- query_ conn "SELECT b from bt" :: IO [Only Bool] 152 | assertEqual "bool" False r1 153 | assertEqual "bool" True r2 154 | execute conn "INSERT INTO bt (b) VALUES (?)" (Only True) 155 | execute conn "INSERT INTO bt (b) VALUES (?)" (Only False) 156 | execute conn "INSERT INTO bt (b) VALUES (?)" (Only False) 157 | [Only r3, Only r4, Only r5] <- 158 | query_ conn "SELECT b from bt where id in (3, 4, 5) ORDER BY id" :: IO [Only Bool] 159 | assertEqual "bool" True r3 160 | assertEqual "bool" False r4 161 | assertEqual "bool" False r5 162 | 163 | testParamConvFromRow :: TestEnv -> Test 164 | testParamConvFromRow TestEnv{..} = TestCase $ do 165 | [(1,2)] <- query_ conn "SELECT 1,2" :: IO [(Int,Int)] 166 | [(1,2,3)] <- query_ conn "SELECT 1,2,3" :: IO [(Int,Int,Int)] 167 | [(1,2,3,4)] <- query_ conn "SELECT 1,2,3,4" :: IO [(Int,Int,Int,Int)] 168 | [(1,2,3,4,5)] <- query_ conn "SELECT 1,2,3,4,5" :: IO [(Int,Int,Int,Int,Int)] 169 | [(1,2,3,4,5,6)] <- query_ conn "SELECT 1,2,3,4,5,6" :: IO [(Int,Int,Int,Int,Int,Int)] 170 | [(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)] 171 | [(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)] 172 | [(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)] 173 | [(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)] 174 | [[1,2,3]] <- query_ conn "SELECT 1,2,3" :: IO [[Int]] 175 | return () 176 | 177 | testParamConvToRow :: TestEnv -> Test 178 | testParamConvToRow TestEnv{..} = TestCase $ do 179 | [Only (s :: Int)] <- query conn "SELECT 13" () 180 | 13 @=? s 181 | [Only (s :: Int)] <- query conn "SELECT ?" (Only one) 182 | 1 @=? s 183 | [Only (s :: Int)] <- query conn "SELECT ?+?" (one, two) 184 | (1+2) @=? s 185 | [Only (s :: Int)] <- query conn "SELECT ?+?+?" (one, two, three) 186 | (1+2+3) @=? s 187 | [Only (s :: Int)] <- query conn "SELECT ?+?+?+?" (one, two, three, 4 :: Int) 188 | (1+2+3+4) @=? s 189 | [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?" (one, two, three, 4 :: Int, 5 :: Int) 190 | (1+2+3+4+5) @=? s 191 | [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?" (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int) 192 | (1+2+3+4+5+6) @=? s 193 | [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?+?" 194 | (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int) 195 | (1+2+3+4+5+6+7) @=? s 196 | [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?+?+?" 197 | (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int, 8 :: Int) 198 | (1+2+3+4+5+6+7+8) @=? s 199 | [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?+?+?+?" 200 | (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int, 8 :: Int, 9 :: Int) 201 | (1+2+3+4+5+6+7+8+9) @=? s 202 | [Only (s :: Int)] <- query conn "SELECT ?+?+?+?+?+?+?+?+?+?" 203 | (one, two, three, 4 :: Int, 5 :: Int, 6 :: Int, 7 :: Int, 8 :: Int, 9 :: Int, 10 :: Int) 204 | (1+2+3+4+5+6+7+8+9+10) @=? s 205 | 206 | data TestTuple = TestTuple Int64 Int64 deriving (Eq, Show) 207 | data TestTuple2 = TestTuple2 T.Text T.Text deriving (Eq, Show) 208 | 209 | instance FromRow TestTuple where 210 | fromRow = TestTuple <$> field <*> field 211 | 212 | instance FromRow TestTuple2 where 213 | fromRow = TestTuple2 <$> field <*> field 214 | 215 | instance ToRow TestTuple where 216 | toRow (TestTuple a b) = [SQLInteger a, SQLInteger b] 217 | 218 | instance ToRow TestTuple2 where 219 | toRow (TestTuple2 a b) = [SQLText a, SQLText b] 220 | 221 | testParamConvComposite :: TestEnv -> Test 222 | testParamConvComposite TestEnv{..} = TestCase $ do 223 | [t1] <- query_ conn "SELECT 1,2" 224 | TestTuple 1 2 @=? t1 225 | [t2] <- query_ conn "SELECT 'foo','bar'" 226 | TestTuple2 "foo" "bar" @=? t2 227 | [a :. b] <- query_ conn "SELECT 4,5,'baz','xyzz'" 228 | TestTuple 4 5 :. TestTuple2 "baz" "xyzz" @=? a :. b 229 | [TestTuple x y :. TestTuple2 z w] <- query conn "SELECT ?,?,?,?" (a :. b) 230 | x @=? 4 231 | y @=? 5 232 | z @=? "baz" 233 | w @=? "xyzz" 234 | 235 | testParamNamed :: TestEnv -> Test 236 | testParamNamed TestEnv{..} = TestCase $ do 237 | [Only t1] <- queryNamed conn "SELECT :foo / :bar" [":foo" := two, ":bar" := one] 238 | t1 @=? (2 :: Int) 239 | [(t1,t2)] <- queryNamed conn "SELECT :foo,:bar" [":foo" := ("foo" :: T.Text), ":bar" := one] 240 | t1 @=? ("foo" :: T.Text) 241 | t2 @=? one 242 | execute_ conn "CREATE TABLE np (id INTEGER PRIMARY KEY, b BOOLEAN)" 243 | executeNamed conn "INSERT INTO np (b) VALUES (:b)" [":b" := True] 244 | [Only t1] <- query_ conn "SELECT b FROM np" 245 | True @=? t1 246 | -------------------------------------------------------------------------------- /test/QQ.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | module QQ ( 4 | testSimpleQQ 5 | , testMultiLinedQQ 6 | ) where 7 | 8 | import Common 9 | import Database.SQLite.Simple.QQ (sql) 10 | 11 | testSimpleQQ :: TestEnv -> Test 12 | testSimpleQQ TestEnv{..} = TestCase $ do 13 | q <- query_ conn "SELECT 1+1" :: IO [Only Int] 14 | qq <- query_ conn [sql| 15 | SELECT 1 + 1 16 | |] :: IO [Only Int] 17 | assertEqual "result" q qq 18 | 19 | 20 | testMultiLinedQQ :: TestEnv -> Test 21 | testMultiLinedQQ TestEnv{..} = TestCase $ do 22 | execute_ conn "CREATE TABLE testQQ (id INTEGER PRIMARY KEY, t TEXT)" 23 | execute_ conn "INSERT INTO testQQ (t) VALUES ('test string')" 24 | q <- query_ conn "SELECT t FROM testQQ" :: IO [Only String] 25 | qq <- query_ conn [sql| 26 | SELECT 27 | t 28 | FROM 29 | testQQ 30 | 31 | |] :: IO [Only String] 32 | assertEqual "result" q qq 33 | -------------------------------------------------------------------------------- /test/Simple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Simple ( 5 | testSimpleOnePlusOne 6 | , testSimpleSelect 7 | , testSimpleParams 8 | , testSimpleTime 9 | , testSimpleTimeFract 10 | , testSimpleInsertId 11 | , testSimpleMultiInsert 12 | , testSimpleUTCTime 13 | , testSimpleUTCTimeTZ 14 | , testSimpleUTCTimeParams 15 | , testSimpleQueryCov 16 | , testSimpleStrings 17 | , testSimpleChanges 18 | ) where 19 | 20 | import qualified Data.ByteString as BS 21 | import qualified Data.ByteString.Lazy as LBS 22 | -- orphan IsString instance in older byteString 23 | import Data.ByteString.Lazy.Char8 () 24 | import qualified Data.Text as T 25 | import qualified Data.Text.Lazy as LT 26 | import Data.Time (UTCTime, Day) 27 | 28 | import Common 29 | 30 | #if !MIN_VERSION_base(4,11,0) 31 | import Data.Monoid ((<>)) 32 | #endif 33 | 34 | -- Simplest SELECT 35 | testSimpleOnePlusOne :: TestEnv -> Test 36 | testSimpleOnePlusOne TestEnv{..} = TestCase $ do 37 | rows <- query_ conn "SELECT 1+1" :: IO [Only Int] 38 | assertEqual "row count" 1 (length rows) 39 | assertEqual "value" (Only 2) (head rows) 40 | 41 | testSimpleSelect :: TestEnv -> Test 42 | testSimpleSelect TestEnv{..} = TestCase $ do 43 | execute_ conn "CREATE TABLE test1 (id INTEGER PRIMARY KEY, t TEXT)" 44 | execute_ conn "INSERT INTO test1 (t) VALUES ('test string')" 45 | rows <- query_ conn "SELECT t FROM test1" :: IO [Only String] 46 | assertEqual "row count" 1 (length rows) 47 | assertEqual "string" (Only "test string") (head rows) 48 | rows <- query_ conn "SELECT id,t FROM test1" :: IO [(Int, String)] 49 | assertEqual "int,string" (1, "test string") (head rows) 50 | -- Add another row 51 | execute_ conn "INSERT INTO test1 (t) VALUES ('test string 2')" 52 | rows <- query_ conn "SELECT id,t FROM test1" :: IO [(Int, String)] 53 | assertEqual "row count" 2 (length rows) 54 | assertEqual "int,string" (1, "test string") (rows !! 0) 55 | assertEqual "int,string" (2, "test string 2") (rows !! 1) 56 | [Only r] <- query_ conn "SELECT NULL" :: IO [Only (Maybe Int)] 57 | assertEqual "nulls" Nothing r 58 | [Only r] <- query_ conn "SELECT 1" :: IO [Only (Maybe Int)] 59 | assertEqual "nulls" (Just 1) r 60 | [Only r] <- query_ conn "SELECT 1.0" :: IO [Only Double] 61 | assertEqual "doubles" 1.0 r 62 | [Only r] <- query_ conn "SELECT 1.0" :: IO [Only Float] 63 | assertEqual "floats" 1.0 r 64 | 65 | testSimpleParams :: TestEnv -> Test 66 | testSimpleParams TestEnv{..} = TestCase $ do 67 | execute_ conn "CREATE TABLE testparams (id INTEGER PRIMARY KEY, t TEXT)" 68 | execute_ conn "CREATE TABLE testparams2 (id INTEGER, t TEXT, t2 TEXT)" 69 | [Only i] <- query conn "SELECT ?" (Only (42 :: Int)) :: IO [Only Int] 70 | assertEqual "select int param" 42 i 71 | execute conn "INSERT INTO testparams (t) VALUES (?)" (Only ("test string" :: String)) 72 | rows <- query conn "SELECT t FROM testparams WHERE id = ?" (Only (1 :: Int)) :: IO [Only String] 73 | assertEqual "row count" 1 (length rows) 74 | assertEqual "string" (Only "test string") (head rows) 75 | execute_ conn "INSERT INTO testparams (t) VALUES ('test2')" 76 | [Only row] <- query conn "SELECT t FROM testparams WHERE id = ?" (Only (1 :: Int)) :: IO [Only String] 77 | assertEqual "select params" "test string" row 78 | [Only row] <- query conn "SELECT t FROM testparams WHERE id = ?" (Only (2 :: Int)) :: IO [Only String] 79 | assertEqual "select params" "test2" row 80 | [Only r1, Only r2] <- query conn "SELECT t FROM testparams WHERE (id = ? OR id = ?)" (1 :: Int, 2 :: Int) :: IO [Only String] 81 | assertEqual "select params" "test string" r1 82 | assertEqual "select params" "test2" r2 83 | [Only i] <- query conn "SELECT ?+?" [42 :: Int, 1 :: Int] :: IO [Only Int] 84 | assertEqual "select int param" 43 i 85 | [Only d] <- query conn "SELECT ?" [2.0 :: Double] :: IO [Only Double] 86 | assertEqual "select double param" 2.0 d 87 | [Only f] <- query conn "SELECT ?" [4.0 :: Float] :: IO [Only Float] 88 | assertEqual "select double param" 4.0 f 89 | 90 | testSimpleTime :: TestEnv -> Test 91 | testSimpleTime TestEnv{..} = TestCase $ do 92 | let timestr = "2012-08-20 20:19:58" 93 | time = read (timestr ++ " UTC") :: UTCTime 94 | execute_ conn "CREATE TABLE time (t TIMESTAMP)" 95 | execute conn "INSERT INTO time (t) VALUES (?)" (Only time) 96 | [Only t] <- query_ conn "SELECT * FROM time" :: IO [Only UTCTime] 97 | assertEqual "UTCTime conv" time t 98 | [Only t] <- query conn "SELECT * FROM time WHERE t = ?" (Only time) :: IO [Only UTCTime] 99 | assertEqual "UTCTime conv2" time t 100 | -- Try inserting timestamp directly as a string 101 | execute_ conn "CREATE TABLE time2 (t TIMESTAMP)" 102 | execute_ conn (Query (T.concat ["INSERT INTO time2 (t) VALUES ('", T.pack timestr, "')"])) 103 | [Only t] <- query_ conn "SELECT * FROM time2" :: IO [Only UTCTime] 104 | assertEqual "UTCTime" time t 105 | rows <- query conn "SELECT * FROM time2 WHERE t = ?" (Only time) :: IO [Only UTCTime] 106 | assertEqual "should see one row result" 1 (length rows) 107 | assertEqual "UTCTime" time t 108 | -- Days 109 | let daystr = "2013-08-21" 110 | day = read daystr :: Day 111 | [Only day'] <- query_ conn (Query (T.concat ["SELECT '", T.pack daystr, "'"])) 112 | day @?= day' 113 | [Only day''] <- query conn "SELECT ?" (Only day) 114 | day @?= day'' 115 | -- database timestamp -> day conversion is treated as an error, but 116 | -- try converting a timestamp to a date and see we get it back ok 117 | [Only dayx] <- query_ conn "SELECT date('2013-08-21 08:00:03.256887')" 118 | day @?= dayx 119 | 120 | testSimpleTimeFract :: TestEnv -> Test 121 | testSimpleTimeFract TestEnv{..} = TestCase $ do 122 | let timestr = "2012-08-17 08:00:03.256887" 123 | time = read (timestr ++ " UTC") :: UTCTime 124 | -- Try inserting timestamp directly as a string 125 | execute_ conn "CREATE TABLE timefract (t TIMESTAMP)" 126 | execute_ conn (Query (T.concat ["INSERT INTO timefract (t) VALUES ('", T.pack timestr, "')"])) 127 | [Only t] <- query_ conn "SELECT * FROM timefract" :: IO [Only UTCTime] 128 | assertEqual "UTCTime" time t 129 | rows <- query conn "SELECT * FROM timefract WHERE t = ?" (Only time) :: IO [Only UTCTime] 130 | assertEqual "should see one row result" 1 (length rows) 131 | 132 | testSimpleInsertId :: TestEnv -> Test 133 | testSimpleInsertId TestEnv{..} = TestCase $ do 134 | execute_ conn "CREATE TABLE test_row_id (id INTEGER PRIMARY KEY, t TEXT)" 135 | execute conn "INSERT INTO test_row_id (t) VALUES (?)" (Only ("test string" :: String)) 136 | id1 <- lastInsertRowId conn 137 | execute_ conn "INSERT INTO test_row_id (t) VALUES ('test2')" 138 | id2 <- lastInsertRowId conn 139 | 1 @=? id1 140 | 2 @=? id2 141 | rows <- query conn "SELECT t FROM test_row_id WHERE id = ?" (Only (1 :: Int)) :: IO [Only String] 142 | 1 @=? (length rows) 143 | (Only "test string") @=? (head rows) 144 | [Only row] <- query conn "SELECT t FROM test_row_id WHERE id = ?" (Only (2 :: Int)) :: IO [Only String] 145 | "test2" @=? row 146 | 147 | testSimpleMultiInsert :: TestEnv -> Test 148 | testSimpleMultiInsert TestEnv{..} = TestCase $ do 149 | execute_ conn "CREATE TABLE test_multi_insert (id INTEGER PRIMARY KEY, t1 TEXT, t2 TEXT)" 150 | executeMany conn "INSERT INTO test_multi_insert (t1, t2) VALUES (?, ?)" ([("foo", "bar"), ("baz", "bat")] :: [(String, String)]) 151 | id2 <- lastInsertRowId conn 152 | 2 @=? id2 153 | 154 | rows <- query_ conn "SELECT id,t1,t2 FROM test_multi_insert" :: IO [(Int, String, String)] 155 | [(1, "foo", "bar"), (2, "baz", "bat")] @=? rows 156 | 157 | testSimpleUTCTime :: TestEnv -> Test 158 | testSimpleUTCTime TestEnv{..} = TestCase $ do 159 | -- Time formats understood by sqlite: http://sqlite.org/lang_datefunc.html 160 | let timestrs = [ "2012-08-17 13:25" 161 | , "2012-08-17 13:25:44" 162 | , "2012-08-17 13:25:44.123" 163 | ] 164 | timestrsWithT = map (T.map (\c -> if c == ' ' then 'T' else c)) timestrs 165 | execute_ conn "CREATE TABLE utctimes (t TIMESTAMP)" 166 | mapM_ (\t -> execute conn "INSERT INTO utctimes (t) VALUES (?)" (Only t)) timestrs 167 | mapM_ (\t -> execute conn "INSERT INTO utctimes (t) VALUES (?)" (Only t)) timestrsWithT 168 | dates <- query_ conn "SELECT t from utctimes" :: IO [Only UTCTime] 169 | mapM_ matchDates (zip (timestrs ++ timestrsWithT) dates) 170 | let zulu = "2012-08-17 13:25" 171 | [d] <- query conn "SELECT ?" (Only (T.append zulu "Z")) 172 | matchDates (zulu, d) 173 | let zulu = "2012-08-17 13:25:00" 174 | [d] <- query conn "SELECT ?" (Only (T.append zulu "Z")) 175 | matchDates (zulu, d) 176 | where 177 | matchDates (str, Only date) = do 178 | -- Remove 'T' when reading in to Haskell 179 | let t = read (makeReadable str) :: UTCTime 180 | t @=? date 181 | 182 | makeReadable s = 183 | let s' = if T.length s < T.length "YYYY-MM-DD HH:MM:SS" then T.append s ":00" else s 184 | in (T.unpack . T.replace "T" " " $ s') ++ " UTC" 185 | 186 | testSimpleUTCTimeTZ :: TestEnv -> Test 187 | testSimpleUTCTimeTZ TestEnv{..} = TestCase $ do 188 | -- Time formats understood by sqlite: http://sqlite.org/lang_datefunc.html 189 | let timestrs = [ "2013-02-03 13:00:00-02:00" 190 | , "2013-02-03 13:00:00-01:00" 191 | , "2013-02-03 13:00:00-03:00" 192 | , "2013-02-03 13:00:00Z" 193 | , "2013-02-03 13:00:00+00:00" 194 | , "2013-02-03 13:00:00+03:00" 195 | , "2013-02-03 13:00:00+02:00" 196 | , "2013-02-03 13:00:00+04:00" 197 | ] 198 | execute_ conn "CREATE TABLE utctimestz (t TIMESTAMP)" 199 | mapM_ (\t -> execute conn "INSERT INTO utctimestz (t) VALUES (?)" (Only t)) timestrs 200 | dates <- query_ conn "SELECT t from utctimestz" :: IO [Only UTCTime] 201 | mapM_ matchDates (zip timestrs dates) 202 | where 203 | matchDates (str, Only date) = do 204 | -- Remove 'T' when reading in to Haskell 205 | let t = read . T.unpack $ str :: UTCTime 206 | t @=? date 207 | 208 | testSimpleUTCTimeParams :: TestEnv -> Test 209 | testSimpleUTCTimeParams TestEnv{..} = TestCase $ do 210 | let times = [ "2012-08-17 08:00:03" 211 | , "2012-08-17 08:00:03.2" 212 | , "2012-08-17 08:00:03.256" 213 | , "2012-08-17 08:00:03.4192" 214 | ] 215 | -- Try inserting timestamp directly as a string 216 | mapM_ assertResult times 217 | where 218 | assertResult tstr = do 219 | let utct = read . (++ " UTC") . T.unpack $ tstr :: UTCTime 220 | [Only t] <- query conn "SELECT ?" (Only utct) :: IO [Only T.Text] 221 | assertEqual "UTCTime" tstr t 222 | 223 | testSimpleQueryCov :: TestEnv -> Test 224 | testSimpleQueryCov _ = TestCase $ do 225 | let str = "SELECT 1+1" :: T.Text 226 | q = "SELECT 1+1" :: Query 227 | fromQuery q @=? str 228 | show str @=? show q 229 | q @=? ((read . show $ q) :: Query) 230 | q @=? q 231 | q @=? (Query "SELECT 1" <> Query "+1") 232 | q @=? foldr mappend mempty ["SELECT ", "1", "+", "1"] 233 | True @=? q <= q 234 | 235 | testSimpleStrings :: TestEnv -> Test 236 | testSimpleStrings TestEnv{..} = TestCase $ do 237 | [Only s] <- query_ conn "SELECT 'str1'" :: IO [Only T.Text] 238 | s @=? "str1" 239 | [Only s] <- query_ conn "SELECT 'strLazy'" :: IO [Only LT.Text] 240 | s @=? "strLazy" 241 | [Only s] <- query conn "SELECT ?" (Only ("strP" :: T.Text)) :: IO [Only T.Text] 242 | s @=? "strP" 243 | [Only s] <- query conn "SELECT ?" (Only ("strPLazy" :: LT.Text)) :: IO [Only T.Text] 244 | s @=? "strPLazy" 245 | -- ByteStrings are blobs in sqlite storage, so use ByteString for 246 | -- both input and output 247 | [Only s] <- query conn "SELECT ?" (Only ("strBsP" :: BS.ByteString)) :: IO [Only BS.ByteString] 248 | s @=? "strBsP" 249 | [Only s] <- query conn "SELECT ?" (Only ("strBsPLazy" :: LBS.ByteString)) :: IO [Only BS.ByteString] 250 | s @=? "strBsPLazy" 251 | [Only s] <- query conn "SELECT ?" (Only ("strBsPLazy2" :: BS.ByteString)) :: IO [Only LBS.ByteString] 252 | s @=? "strBsPLazy2" 253 | 254 | testSimpleChanges :: TestEnv -> Test 255 | testSimpleChanges TestEnv{..} = TestCase $ do 256 | execute_ conn "CREATE TABLE testchanges (id INTEGER PRIMARY KEY, t TEXT)" 257 | execute conn "INSERT INTO testchanges(t) VALUES (?)" (Only ("test string" :: String)) 258 | numChanges <- changes conn 259 | assertEqual "changed/inserted rows" 1 numChanges 260 | execute conn "INSERT INTO testchanges(t) VALUES (?)" (Only ("test string 2" :: String)) 261 | numChanges <- changes conn 262 | assertEqual "changed/inserted rows" 1 numChanges 263 | execute_ conn "UPDATE testchanges SET t = 'foo' WHERE id = 1" 264 | numChanges <- changes conn 265 | assertEqual "changed/inserted rows" 1 numChanges 266 | execute_ conn "UPDATE testchanges SET t = 'foo' WHERE id = 100" 267 | numChanges <- changes conn 268 | assertEqual "changed/inserted rows" 0 numChanges 269 | execute_ conn "UPDATE testchanges SET t = 'foo'" 270 | numChanges <- changes conn 271 | assertEqual "changed/inserted rows" 2 numChanges 272 | -------------------------------------------------------------------------------- /test/Statement.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Statement ( 4 | testBind 5 | , testDoubleBind 6 | , testPreparedStatements 7 | , testPreparedStatementsColumnCount 8 | ) where 9 | 10 | import Common 11 | import Data.Maybe(fromJust) 12 | 13 | import qualified Database.SQLite3 as Base 14 | 15 | testBind :: TestEnv -> Test 16 | testBind TestEnv{..} = TestCase $ do 17 | execute_ conn "CREATE TABLE test_bind (id INTEGER PRIMARY KEY, t TEXT)" 18 | execute_ conn "INSERT INTO test_bind VALUES(1, 'result')" 19 | withStatement conn "SELECT t FROM test_bind WHERE id=?" $ \stmt -> 20 | withBind stmt [1::Int] $ do 21 | row <- nextRow stmt :: IO (Maybe (Only String)) 22 | assertEqual "result" (Only "result") (fromJust row) 23 | 24 | testDoubleBind :: TestEnv -> Test 25 | testDoubleBind TestEnv{..} = TestCase $ do 26 | execute_ conn "CREATE TABLE test_double_bind (id INTEGER PRIMARY KEY, t TEXT)" 27 | execute_ conn "INSERT INTO test_double_bind VALUES(1, 'first result')" 28 | execute_ conn "INSERT INTO test_double_bind VALUES(2, 'second result')" 29 | withStatement conn "SELECT t FROM test_double_bind WHERE id=?" $ \stmt -> do 30 | withBind stmt [1::Int] $ do 31 | row <- nextRow stmt :: IO (Maybe (Only String)) 32 | assertEqual "first result" (Only "first result") (fromJust row) 33 | 34 | withBind stmt [2::Int] $ do 35 | row <- nextRow stmt :: IO (Maybe (Only String)) 36 | assertEqual "second result" (Only "second result") (fromJust row) 37 | 38 | testPreparedStatements :: TestEnv -> Test 39 | testPreparedStatements TestEnv{..} = TestCase $ do 40 | execute_ conn "CREATE TABLE ps (id INTEGER PRIMARY KEY, t TEXT)" 41 | execute_ conn "INSERT INTO ps VALUES(1, 'first result')" 42 | execute_ conn "INSERT INTO ps VALUES(2, 'second result')" 43 | withStatement conn "SELECT t FROM ps WHERE id=?" $ \stmt -> do 44 | colName <- columnName stmt 0 45 | colName @?= "t" 46 | elems <- mapM (queryOne stmt) [1 :: Int, 2] 47 | ["first result" :: String, "second result"] @=? elems 48 | where 49 | queryOne stmt rowId = 50 | withBind stmt (Only rowId) $ do 51 | Just (Only r) <- nextRow stmt 52 | Nothing <- nextRow stmt :: IO (Maybe (Only String)) 53 | return r 54 | 55 | testPreparedStatementsColumnCount :: TestEnv -> Test 56 | testPreparedStatementsColumnCount TestEnv{..} = TestCase $ do 57 | execute_ conn "CREATE TABLE ps2 (id INTEGER PRIMARY KEY, t TEXT)" 58 | execute_ conn "INSERT INTO ps2 VALUES(1, 'first result')" 59 | withStatement conn "SELECT t FROM ps2 WHERE id=?" $ \stmt -> do 60 | colName <- columnName stmt 0 61 | colName @?= "t" 62 | ColumnIndex colCount <- columnCount stmt 63 | colCount @?= 1 64 | let baseStatment = unStatement stmt 65 | colCountBase <- Base.columnCount baseStatment 66 | colCountBase @?= 1 67 | -------------------------------------------------------------------------------- /test/TestImports.hs: -------------------------------------------------------------------------------- 1 | 2 | module TestImports ( 3 | testImports 4 | ) where 5 | 6 | -- Test file to test that we can do most things with a single import 7 | import qualified Data.Text as T 8 | 9 | import Common 10 | 11 | data TestType = TestType Int Int Int 12 | 13 | -- Hook up sqlite-simple to know how to read Test rows 14 | instance FromRow TestType where 15 | fromRow = TestType <$> field <*> field <*> field 16 | 17 | test1 :: IO () 18 | test1 = do 19 | conn <- open ":memory:" 20 | execute_ conn "CREATE TABLE testimp (id INTEGER PRIMARY KEY, id2 INTEGER, id3 INTEGER)" 21 | execute_ conn "INSERT INTO testimp (id, id2, id3) VALUES (1, 2, 3)" 22 | [_v] <- query_ conn "SELECT * FROM testimp" :: IO [TestType] 23 | [_v] <- query conn "SELECT ?+?" (3::Int,4::Int) :: IO [(Only Int)] 24 | close conn 25 | 26 | test2 :: Connection -> IO () 27 | test2 conn = do 28 | execute_ conn "CREATE TABLE testimp (id INTEGER PRIMARY KEY)" 29 | execute_ conn "INSERT INTO testimp (id) VALUES (1)" 30 | [Only _v] <- query_ conn (Query q) :: IO [Only Int] 31 | return () 32 | where 33 | q = T.concat ["SELECT * FROM ", "testimp"] 34 | 35 | test3 :: Connection -> IO () 36 | test3 conn = do 37 | [_v] <- query conn "SELECT ?+?" (3::Int,4::Int) :: IO [(Only Int)] 38 | return () 39 | 40 | testImports :: TestEnv -> Test 41 | testImports env = TestCase $ do 42 | test1 43 | withConnection ":memory:" test2 44 | test3 (conn env) 45 | -------------------------------------------------------------------------------- /test/UserInstances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | module UserInstances ( 4 | testUserFromField 5 | ,testSQLDataFromField 6 | ) where 7 | 8 | import Common 9 | import Data.Int (Int64) 10 | import Data.Typeable (Typeable) 11 | import qualified Data.Text as T 12 | import Database.SQLite.Simple.FromField 13 | import Database.SQLite.Simple.Ok 14 | import Database.SQLite.Simple.ToField 15 | 16 | newtype MyType = MyType String deriving (Eq, Show, Typeable) 17 | 18 | instance FromField MyType where 19 | fromField f = cvt f . fieldData $ f where 20 | -- Prefix with "fromField " to really ensure we got here 21 | cvt _ (SQLText s) = Ok $ MyType ("fromField "++(T.unpack s)) 22 | cvt f _ = returnError ConversionFailed f "expecting SQLText type" 23 | 24 | instance ToField MyType where 25 | -- Prefix with "toField " to really ensure we got here 26 | toField (MyType s) = SQLText . T.pack $ ("toField " ++ s) 27 | 28 | testUserFromField :: TestEnv -> Test 29 | testUserFromField TestEnv{..} = TestCase $ do 30 | execute_ conn "CREATE TABLE fromfield (t TEXT)" 31 | execute conn "INSERT INTO fromfield (t) VALUES (?)" (Only ("test string" :: String)) 32 | [Only r] <- query_ conn "SELECT t FROM fromfield" :: IO [(Only MyType)] 33 | (MyType "fromField test string") @=? r 34 | execute_ conn "DELETE FROM fromfield" 35 | execute conn "INSERT INTO fromfield (t) VALUES (?)" (Only (MyType "test2")) 36 | [Only r] <- query_ conn "SELECT t FROM fromfield" :: IO [(Only String)] 37 | "toField test2" @=? r 38 | 39 | testSQLDataFromField :: TestEnv -> Test 40 | testSQLDataFromField TestEnv{..} = TestCase $ do 41 | execute_ conn "CREATE TABLE sqldatafromfield (t TEXT, i INT, b BOOLEAN, f FLOAT)" 42 | execute conn "INSERT INTO sqldatafromfield (t,i,b,f) VALUES (?,?,?,?)" (("test string" :: T.Text, 43 | 1 :: Int64, 44 | True :: Bool, 45 | 1.11 :: Double)) 46 | execute conn "INSERT INTO sqldatafromfield (t,i,b) VALUES (?,?,?)" (("test string2" :: T.Text, 47 | 2 :: Int64, 48 | False :: Bool)) 49 | r <- query_ conn "SELECT * FROM sqldatafromfield" :: IO [[SQLData]] 50 | let testData = [[SQLText "test string", 51 | SQLInteger 1, 52 | SQLInteger 1, 53 | SQLFloat 1.11], 54 | [SQLText "test string2", 55 | SQLInteger 2, 56 | SQLInteger 0, 57 | SQLNull]] 58 | testData @=? r 59 | -------------------------------------------------------------------------------- /test/Utf8Strings.hs: -------------------------------------------------------------------------------- 1 | -- -*- coding: utf-8 -*- 2 | 3 | module Utf8Strings (testUtf8Simplest 4 | , testBlobs) where 5 | 6 | import Common 7 | import qualified Data.ByteString as B 8 | import Data.Word 9 | 10 | testUtf8Simplest :: TestEnv -> Test 11 | testUtf8Simplest TestEnv{..} = TestCase $ do 12 | execute_ conn "CREATE TABLE utf (id INTEGER, t TEXT)" 13 | execute_ conn "INSERT INTO utf (id, t) VALUES (1, 'ääöö')" 14 | execute conn "INSERT INTO utf (id, t) VALUES (?,?)" (2 :: Int, "ääööåå" :: String) 15 | [Only t1] <- query conn "SELECT t FROM utf WHERE id = ?" (Only (1 :: Int)) 16 | assertEqual "utf8" ("ääöö" :: String) t1 17 | [Only t2] <- query conn "SELECT t FROM utf WHERE id = ?" (Only (2 :: Int)) 18 | assertEqual "utf8" ("ääööåå" :: String) t2 19 | 20 | testBlobs :: TestEnv -> Test 21 | testBlobs TestEnv{..} = TestCase $ do 22 | let d = B.pack ([0..127] :: [Word8]) 23 | execute_ conn "CREATE TABLE blobs (id INTEGER, b BLOB)" 24 | execute conn "INSERT INTO blobs (id, b) VALUES (?,?)" (1 :: Int, d) 25 | [Only t1] <- query conn "SELECT b FROM blobs WHERE id = ?" (Only (1 :: Int)) 26 | assertEqual "blob" d t1 27 | assertEqual "blob nul char" 0 (B.index d 0) 28 | assertEqual "blob first char" 1 (B.index d 1) 29 | --------------------------------------------------------------------------------