groundhog-sqlite 0.3.0 → 0.4.0

raw patch · 4 files changed

+96/−501 lines, 4 filesdep +direct-sqlitedep +monad-loggerdep ~groundhogdep ~monad-controldep ~resource-poolPVP ok

version bump matches the API change (PVP)

Dependencies added: direct-sqlite, monad-logger

Dependency ranges changed: groundhog, monad-control, resource-pool, text, transformers

API changes (from Hackage documentation)

Files

• Database/Groundhog/Sqlite.hs +86/−86
• Database/Sqlite.hs +0/−398
• cbits/sqlite3.c too large to diff
• groundhog-sqlite.cabal +10/−17

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies, RecordWildCards, Rank2Types, MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, FlexibleContexts, OverloadedStrings, TypeFamilies, RecordWildCards, Rank2Types, MultiParamTypeClasses, TemplateHaskell #-} module Database.Groundhog.Sqlite     ( withSqlitePool     , withSqliteConn@@ -17,10 +17,12 @@ import Database.Groundhog.Generic.Sql.Functions import qualified Database.Groundhog.Generic.PersistBackendHelpers as H -import qualified Database.Sqlite as S+import qualified Database.SQLite3 as S+import qualified Database.SQLite3.Direct as SD  import Control.Arrow ((***)) import Control.Monad (liftM, forM)+import Control.Monad.Logger (MonadLogger, NoLoggingT, logDebugS) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Reader (ask)@@ -35,8 +37,6 @@ import Data.Pool import qualified Data.Text as T -import GHC.Exts (inline)- -- typical operations for connection: OPEN, BEGIN, COMMIT, ROLLBACK, CLOSE data Sqlite = Sqlite S.Database (IORef (Map.HashMap BS.ByteString S.Statement)) @@ -48,8 +48,8 @@ instance SqlDb Sqlite where   append a b = Expr $ operator 50 "||" a b -instance (MonadBaseControl IO m, MonadIO m) => PersistBackend (DbPersist Sqlite m) where-  {-# SPECIALIZE instance PersistBackend (DbPersist Sqlite IO) #-}+instance (MonadBaseControl IO m, MonadIO m, MonadLogger m) => PersistBackend (DbPersist Sqlite m) where+  {-# SPECIALIZE instance PersistBackend (DbPersist Sqlite (NoLoggingT IO)) #-}   type PhantomDb (DbPersist Sqlite m) = Sqlite   insert v = insert' v   insert_ v = insert_' v@@ -58,7 +58,7 @@   replace k v = H.replace escapeS queryRawTyped executeRawCached' insertIntoConstructorTable k v   select options = H.select escapeS queryRawTyped "LIMIT -1" renderCond' options -- select' options   selectAll = H.selectAll escapeS queryRawTyped-  get k = inline $ H.get escapeS queryRawTyped k+  get k = H.get escapeS queryRawTyped k   getBy k = H.getBy escapeS queryRawTyped k   update upds cond = H.update escapeS executeRawCached' renderCond' upds cond   delete cond = H.delete escapeS executeRawCached' renderCond' cond@@ -76,7 +76,7 @@   insertList l = insertList' l   getList k = getList' k -instance (MonadBaseControl IO m, MonadIO m) => SchemaAnalyzer (DbPersist Sqlite m) where+instance (MonadBaseControl IO m, MonadIO m, MonadLogger m) => SchemaAnalyzer (DbPersist Sqlite m) where   listTables _ = queryRaw' "SELECT name FROM sqlite_master WHERE type='table'" [] (mapAllRows $ return . fst . fromPurePersistValues proxy)   listTableTriggers _ name = queryRaw' "SELECT name FROM sqlite_master WHERE type='trigger' AND tbl_name=?" [toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy)   analyzeTable = analyzeTable'@@ -94,8 +94,6 @@                -> m a withSqlitePool s connCount f = liftIO (createPool (open' s) close' 1 20 connCount) >>= f -{-# SPECIALIZE withSqliteConn :: String -> (Sqlite -> IO a) -> IO a #-}-{-# INLINE withSqliteConn #-} withSqliteConn :: (MonadBaseControl IO m, MonadIO m)                => String                -> (Sqlite -> m a)@@ -128,7 +126,7 @@  open' :: String -> IO Sqlite open' s = do-  conn <- S.open s+  conn <- S.open $ T.pack s   S.prepare conn "PRAGMA foreign_keys = ON" >>= \stmt -> S.step stmt >> S.finalize stmt   cache <- newIORef Map.empty   return $ Sqlite conn cache@@ -138,32 +136,32 @@   readIORef smap >>= mapM_ S.finalize . Map.elems   S.close conn -migrate' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> Migration (DbPersist Sqlite m)+migrate' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m, MonadLogger m) => v -> Migration (DbPersist Sqlite m) migrate' = migrateRecursively (migrateEntity migrationPack) (migrateList migrationPack) -migrationPack :: (MonadBaseControl IO m, MonadIO m) => GM.MigrationPack (DbPersist Sqlite m)+migrationPack :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => GM.MigrationPack (DbPersist Sqlite m) migrationPack = GM.MigrationPack   compareTypes   compareRefs   compareUniqs+  compareDefaults   migTriggerOnDelete   migTriggerOnUpdate   GM.defaultMigConstr   escape-  DbInt64   "INTEGER PRIMARY KEY NOT NULL"-  "INTEGER"   mainTableId   defaultPriority   addUniquesReferences   showColumn   showAlterDb+  NoAction  addUniquesReferences :: [UniqueDef'] -> [Reference] -> ([String], [AlterTable]) addUniquesReferences uniques refs = (map sqlUnique constraints ++ map sqlReference refs, map AddUnique indexes) where   (constraints, indexes) = partition ((/= UniqueIndex) . uniqueDefType) uniques -migTriggerOnDelete :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> [(String, String)] -> DbPersist Sqlite m (Bool, [AlterDB])+migTriggerOnDelete :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Maybe String -> String -> [(String, String)] -> DbPersist Sqlite m (Bool, [AlterDB]) migTriggerOnDelete schema name deletes = do   let addTrigger = AddTriggerOnDelete Nothing name Nothing name (concatMap snd deletes)   x <- analyzeTrigger schema name@@ -179,7 +177,7 @@          -- | Schema name, table name and a list of field names and according delete statements -- assume that this function is called only for ephemeral fields-migTriggerOnUpdate :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> [(String, String)] -> DbPersist Sqlite m [(Bool, [AlterDB])]+migTriggerOnUpdate :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Maybe String -> String -> [(String, String)] -> DbPersist Sqlite m [(Bool, [AlterDB])] migTriggerOnUpdate schema name dels = forM dels $ \(fieldName, del) -> do   let trigName = name ++ delim : fieldName   let addTrigger = AddTriggerOnUpdate Nothing trigName Nothing name (Just fieldName) del@@ -190,12 +188,12 @@         then []         else [DropTrigger Nothing trigName Nothing name, addTrigger]) -analyzeTable' :: (MonadBaseControl IO m, MonadIO m) => Maybe String -> String -> DbPersist Sqlite m (Either [String] (Maybe TableInfo))+analyzeTable' :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Maybe String -> String -> DbPersist Sqlite m (Maybe TableInfo) analyzeTable' _ tName = do   let fromName = escapeS . fromString   tableInfo <- queryRaw' ("pragma table_info(" <> fromName tName <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy)   case tableInfo of-    [] -> return $ Right Nothing+    [] -> return Nothing     rawColumns -> do       let mkColumn :: (Int, (String, String, Int, Maybe String, Int)) -> Column           mkColumn (_, (name, typ, isNotNull, defaultValue, _)) = Column name (isNotNull == 0) (readSqlType typ) defaultValue@@ -224,10 +222,13 @@                 Nothing -> error $ "analyzeTable: cannot find primary key for table " ++ foreignTable ++ " which is referenced without specifying column names"               Just columnName -> return (child, columnName)             return (Nothing, Reference Nothing foreignTable refs (mkAction onDelete) (mkAction onUpdate))-      let uniques' = uniques ++ if length primaryKeyColumnNames == 1 then [UniqueDef' Nothing UniquePrimary primaryKeyColumnNames] else []-      return $ Right $ Just $ TableInfo columns uniques' foreigns+      let uniques' = uniques ++ +            if all ((/= UniquePrimary) . uniqueDefType) uniques && not (null primaryKeyColumnNames)+              then  [UniqueDef' Nothing UniquePrimary primaryKeyColumnNames]+              else []+      return $ Just $ TableInfo columns uniques' foreigns -analyzePrimaryKey :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Sqlite m (Maybe String)+analyzePrimaryKey :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => String -> DbPersist Sqlite m (Maybe String) analyzePrimaryKey tName = do   tableInfo <- queryRaw' ("pragma table_info(" <> escapeS (fromString tName) <> ")") [] $ mapAllRows (return . fst . fromPurePersistValues proxy)   let rawColumns :: [(Int, (String, String, Int, Maybe String, Int))]@@ -246,7 +247,7 @@     let sql' = fromUtf8 sql     case Map.lookup sql' smap' of       Nothing -> do-        stmt <- S.prepare conn sql'+        stmt <- S.prepareUtf8 conn $ SD.Utf8 sql'         writeIORef smap (Map.insert sql' stmt smap')         return stmt       Just stmt -> return stmt@@ -254,26 +255,24 @@ getStatement :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> DbPersist Sqlite m S.Statement getStatement sql = do   Sqlite conn _ <- DbPersist ask-  liftIO $ S.prepare conn (fromUtf8 sql)+  liftIO $ S.prepareUtf8 conn $ SD.Utf8 $ fromUtf8 sql -showSqlType :: DbType -> String-showSqlType DbString = "VARCHAR"-showSqlType DbInt32 = "INTEGER"-showSqlType DbInt64 = "INTEGER"-showSqlType DbReal = "REAL"-showSqlType DbBool = "BOOLEAN"-showSqlType DbDay = "DATE"-showSqlType DbTime = "TIME"-showSqlType DbDayTime = "TIMESTAMP"-showSqlType DbDayTimeZoned = "TIMESTAMP WITH TIME ZONE"-showSqlType DbBlob = "BLOB"-showSqlType (DbOther (OtherTypeDef f)) = f showSqlType-showSqlType (DbMaybe t) = showSqlType t-showSqlType (DbList _ _) = showSqlType DbInt64-showSqlType (DbEntity Nothing _ _ _) = showSqlType DbInt64-showSqlType t = error $ "showSqlType: DbType does not have corresponding database type: " ++ show t+showSqlType :: DbTypePrimitive -> String+showSqlType t = case t of+  DbString -> "VARCHAR"+  DbInt32 -> "INTEGER"+  DbInt64 -> "INTEGER"+  DbReal -> "REAL"+  DbBool -> "BOOLEAN"+  DbDay -> "DATE"+  DbTime -> "TIME"+  DbDayTime -> "TIMESTAMP"+  DbDayTimeZoned -> "TIMESTAMP WITH TIME ZONE"+  DbBlob -> "BLOB"+  DbAutoKey -> "INTEGER"+  DbOther (OtherTypeDef f) -> f showSqlType -readSqlType :: String -> DbType+readSqlType :: String -> DbTypePrimitive readSqlType "VARCHAR" = DbString readSqlType "INTEGER" = DbInt64 readSqlType "REAL" = DbReal@@ -287,7 +286,7 @@  data Affinity = TEXT | NUMERIC | INTEGER | REAL | NONE deriving (Eq, Show) -dbTypeAffinity :: DbType -> Affinity+dbTypeAffinity :: DbTypePrimitive -> Affinity dbTypeAffinity = readSqlTypeAffinity . showSqlType  readSqlTypeAffinity :: String -> Affinity@@ -301,10 +300,10 @@     _ -> NUMERIC  showColumn :: Column -> String-showColumn (Column name isNull typ _) = escape name ++ " " ++ showSqlType typ ++ rest where-  rest = if not isNull -           then " NOT NULL"-           else ""+showColumn (Column name nullable typ def) = escape name ++ " " ++ showSqlType typ ++ rest where+  rest = concat [+    if not nullable then " NOT NULL" else "",+    maybe "" (" DEFAULT " ++) def]  sqlReference :: Reference -> String sqlReference Reference{..} = "FOREIGN KEY(" ++ our ++ ") REFERENCES " ++ escape referencedTableName ++ "(" ++ foreign ++ ")" ++ actions where@@ -325,8 +324,7 @@       UniqueConstraint -> " UNIQUE("       UniqueIndex -> error "sqlUnique: does not handle indexes" -{-# SPECIALIZE insert' :: PersistEntity v => v -> DbPersist Sqlite IO (AutoKey v) #-}-insert' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> DbPersist Sqlite m (AutoKey v)+insert' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m, MonadLogger m) => v -> DbPersist Sqlite m (AutoKey v) insert' v = do   -- constructor number and the rest of the field values   vals <- toEntityPersistValues' v@@ -350,8 +348,7 @@       executeRawCached' cQuery (vals' [])       pureFromPersistValue [rowid] -{-# SPECIALIZE insert_' :: PersistEntity v => v -> DbPersist Sqlite IO () #-}-insert_' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> DbPersist Sqlite m ()+insert_' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m, MonadLogger m) => v -> DbPersist Sqlite m () insert_' v = do   -- constructor number and the rest of the field values   vals <- toEntityPersistValues' v@@ -381,7 +378,7 @@   fieldNames   = renderFields escapeS fields   RenderS placeholders vals' = commasJoin $ map renderPersistValue vals -insertList' :: forall m a.(MonadBaseControl IO m, MonadIO m, PersistField a) => [a] -> DbPersist Sqlite m Int64+insertList' :: forall m a.(MonadBaseControl IO m, MonadIO m, MonadLogger m, PersistField a) => [a] -> DbPersist Sqlite m Int64 insertList' l = do   let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a))   executeRawCached' ("INSERT INTO " <> escapeS mainName <> " DEFAULT VALUES") []@@ -398,7 +395,7 @@   go 0 l   return $ fromPrimitivePersistValue proxy k   -getList' :: forall m a.(MonadBaseControl IO m, MonadIO m, PersistField a) => Int64 -> DbPersist Sqlite m [a]+getList' :: forall m a.(MonadBaseControl IO m, MonadIO m, MonadLogger m, PersistField a) => Int64 -> DbPersist Sqlite m [a] getList' k = do   let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a))   let valuesName = mainName <> delim' <> "values"@@ -406,14 +403,10 @@   let query = "SELECT " <> renderFields escapeS [value] <> " FROM " <> escapeS valuesName <> " WHERE id=? ORDER BY ord"   queryRawTyped query (getDbTypes (dbType (undefined :: a)) []) [toPrimitivePersistValue proxy k] $ mapAllRows (liftM fst . fromPersistValues)     -{-# SPECIALIZE getLastInsertRowId :: DbPersist Sqlite IO PersistValue #-}-getLastInsertRowId :: (MonadBaseControl IO m, MonadIO m) => DbPersist Sqlite m PersistValue+getLastInsertRowId :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => DbPersist Sqlite m PersistValue getLastInsertRowId = do-  stmt <- getStatementCached "SELECT last_insert_rowid()"-  liftIO $ flip finally (liftIO $ S.reset stmt) $ do-    S.step stmt-    x <- S.column stmt 0-    return $ pFromSql x+  Sqlite conn _ <- DbPersist ask+  liftIO (SD.lastInsertRowId conn) >>= toSinglePersistValue  ---------- @@ -435,25 +428,27 @@       PersistCustom _ _       -> error "bind: unexpected PersistCustom"     go (i + 1) xs -executeRaw' :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> [PersistValue] -> DbPersist Sqlite m ()+executeRaw' :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Utf8 -> [PersistValue] -> DbPersist Sqlite m () executeRaw' query vals = do+  $logDebugS "SQL" $ T.pack $ show (fromUtf8 query) ++ " " ++ show vals   stmt <- getStatement query   liftIO $ flip finally (S.finalize stmt) $ do     bind stmt vals     S.Done <- S.step stmt     return () -{-# SPECIALIZE executeRawCached' :: Utf8 -> [PersistValue] -> DbPersist Sqlite IO () #-}-executeRawCached' :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> [PersistValue] -> DbPersist Sqlite m ()+executeRawCached' :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Utf8 -> [PersistValue] -> DbPersist Sqlite m () executeRawCached' query vals = do+  $logDebugS "SQL" $ T.pack $ show (fromUtf8 query) ++ " " ++ show vals   stmt <- getStatementCached query   liftIO $ flip finally (S.reset stmt) $ do     bind stmt vals     S.Done <- S.step stmt     return () -queryRaw' :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> [PersistValue] -> (RowPopper (DbPersist Sqlite m) -> DbPersist Sqlite m a) -> DbPersist Sqlite m a+queryRaw' :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Utf8 -> [PersistValue] -> (RowPopper (DbPersist Sqlite m) -> DbPersist Sqlite m a) -> DbPersist Sqlite m a queryRaw' query vals f = do+  $logDebugS "SQL" $ T.pack $ show (fromUtf8 query) ++ " " ++ show vals   stmt <- getStatement query   flip finally (liftIO $ S.finalize stmt) $ do     liftIO $ bind stmt vals@@ -461,10 +456,11 @@       x <- S.step stmt       case x of         S.Done -> return Nothing-        S.Row  -> liftM (Just . map pFromSql) $ S.columns stmt+        S.Row  -> fmap (Just . map pFromSql) $ S.columns stmt -queryRawCached' :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> [PersistValue] -> (RowPopper (DbPersist Sqlite m) -> DbPersist Sqlite m a) -> DbPersist Sqlite m a+queryRawCached' :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Utf8 -> [PersistValue] -> (RowPopper (DbPersist Sqlite m) -> DbPersist Sqlite m a) -> DbPersist Sqlite m a queryRawCached' query vals f = do+  $logDebugS "SQL" $ T.pack $ show (fromUtf8 query) ++ " " ++ show vals   stmt <- getStatementCached query   flip finally (liftIO $ S.reset stmt) $ do     liftIO $ bind stmt vals@@ -474,39 +470,40 @@         S.Done -> return Nothing         S.Row  -> fmap (Just . map pFromSql) $ S.columns stmt -queryRawTyped :: (MonadBaseControl IO m, MonadIO m) => Utf8 -> [DbType] -> [PersistValue] -> (RowPopper (DbPersist Sqlite m) -> DbPersist Sqlite m a) -> DbPersist Sqlite m a+queryRawTyped :: (MonadBaseControl IO m, MonadIO m, MonadLogger m) => Utf8 -> [DbType] -> [PersistValue] -> (RowPopper (DbPersist Sqlite m) -> DbPersist Sqlite m a) -> DbPersist Sqlite m a queryRawTyped query types vals f = do+  $logDebugS "SQL" $ T.pack $ show (fromUtf8 query) ++ " " ++ show vals   stmt <- getStatementCached query-  let types' = map typeToSqlite types+  let types' = map typeToSqlite $ foldr getDbTypes [] types   flip finally (liftIO $ S.reset stmt) $ do     liftIO $ bind stmt vals     f $ liftIO $ do       x <- S.step stmt       case x of         S.Done -> return Nothing-        S.Row  -> fmap (Just . map pFromSql) $ S.unsafeColumns stmt types'+        S.Row  -> fmap (Just . map pFromSql) $ S.typedColumns stmt types'  typeToSqlite :: DbType -> Maybe S.ColumnType-typeToSqlite DbString = Just S.TextColumn-typeToSqlite DbInt32 = Just S.IntegerColumn-typeToSqlite DbInt64 = Just S.IntegerColumn-typeToSqlite DbReal = Just S.FloatColumn-typeToSqlite DbBool = Just S.IntegerColumn-typeToSqlite DbDay = Nothing-typeToSqlite DbTime = Nothing-typeToSqlite DbDayTime = Nothing-typeToSqlite DbDayTimeZoned = Nothing-typeToSqlite DbBlob = Just S.BlobColumn-typeToSqlite (DbOther _) = Nothing-typeToSqlite (DbMaybe _) = Nothing+typeToSqlite (DbTypePrimitive t nullable _ _) = case t of+  _ | nullable -> Nothing+  DbOther _ -> Nothing+  DbString -> Just S.TextColumn+  DbInt32 -> Just S.IntegerColumn+  DbInt64 -> Just S.IntegerColumn+  DbReal -> Just S.FloatColumn+  DbBool -> Just S.IntegerColumn+  DbDay -> Just S.TextColumn+  DbTime -> Just S.TextColumn+  DbDayTime -> Just S.TextColumn+  DbDayTimeZoned -> Just S.TextColumn+  DbBlob -> Just S.BlobColumn+  DbAutoKey -> Just S.IntegerColumn typeToSqlite (DbList _ _) = Just S.IntegerColumn-typeToSqlite (DbEntity Nothing _ _ _) = Just S.IntegerColumn-typeToSqlite t = error $ "typeToSqlite: DbType does not have corresponding database type: " ++ show t+typeToSqlite t@(DbEmbedded _ _) = error $ "typeToSqlite: DbType does not have corresponding database type: " ++ show t  getDbTypes :: DbType -> [DbType] -> [DbType] getDbTypes typ acc = case typ of-  DbEmbedded (EmbeddedDef _ ts) -> foldr (getDbTypes . snd) acc ts-  DbEntity (Just (EmbeddedDef _ ts, _)) _ _ _ -> foldr (getDbTypes . snd) acc ts+  DbEmbedded (EmbeddedDef _ ts) _ -> foldr (getDbTypes . snd) acc ts   t               -> t:acc  pFromSql :: S.SQLData -> PersistValue@@ -538,7 +535,7 @@ delim' :: Utf8 delim' = fromChar delim -toEntityPersistValues' :: (MonadBaseControl IO m, MonadIO m, PersistEntity v) => v -> DbPersist Sqlite m [PersistValue]+toEntityPersistValues' :: (MonadBaseControl IO m, MonadIO m, MonadLogger m, PersistEntity v) => v -> DbPersist Sqlite m [PersistValue] toEntityPersistValues' = liftM ($ []) . toEntityPersistValues  compareUniqs :: UniqueDef' -> UniqueDef' -> Bool@@ -555,9 +552,12 @@   && fromMaybe NoAction onUpd1 == fromMaybe NoAction onUpd2 where   unescape name = if head name == '"' && last name == '"' then tail $ init name else name -compareTypes :: DbType -> DbType -> Bool+compareTypes :: DbTypePrimitive -> DbTypePrimitive -> Bool compareTypes type1 type2 = dbTypeAffinity type1 == dbTypeAffinity type2 --compareTypes type1 type2 = showSqlType type1 == showSqlType type2++compareDefaults :: String -> String -> Bool+compareDefaults = (==)  mainTableId :: String mainTableId = "id"

@@ -1,398 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable #-}-module Database.Sqlite (-                         Database,-                         Statement,-                         Error,-                         StepResult(Row,-                                    Done),-                         SQLData(SQLInteger,-                                 SQLFloat,-                                 SQLText,-                                 SQLBlob,-                                 SQLNull),-                         ColumnType(IntegerColumn,-                                    FloatColumn,-                                    TextColumn,-                                    BlobColumn,-                                    NullColumn),-                         open,-                         close,-                         prepare,-                         step,-                         reset,-                         finalize,-                         bindParameterCount,-                         bindParameterName,-                         bindBlob,-                         bindDouble,-                         bindInt,-                         bindInt64,-                         bindNull,-                         bindText,-                         bind,-                         column,-                         columns,-                         unsafeColumns-                        )-    where--import qualified Data.ByteString as BS-import qualified Data.ByteString.Internal as BSI-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Typeable-import Foreign-import Foreign.C---newtype Database = Database (Ptr ())-data Statement = Statement (Ptr ()) Database--type Error = Int--errorOK :: Error-errorOK = 0-errorRow :: Error-errorRow = 100-errorDone :: Error-errorDone = 101--data StepResult = Row | Done deriving (Eq, Show)--data ColumnType = IntegerColumn-                | FloatColumn-                | TextColumn-                | BlobColumn-                | NullColumn-                  deriving (Eq, Show)--data SQLData = SQLInteger Int64-             | SQLFloat Double-             | SQLText T.Text-             | SQLBlob BS.ByteString-             | SQLNull-               deriving (Eq, Show, Typeable)--showError :: Error -> String-showError 0 = "ErrorOK"-showError 1 = "ErrorError"-showError 2 = "ErrorInternal"-showError 3 = "ErrorPermission"-showError 4 = "ErrorAbort"-showError 5 = "ErrorBusy"-showError 6 = "ErrorLocked"-showError 7 = "ErrorNoMemory"-showError 8 = "ErrorReadOnly"-showError 9 = "ErrorInterrupt"-showError 10 = "ErrorIO"-showError 11 = "ErrorNotFound"-showError 12 = "ErrorCorrupt"-showError 13 = "ErrorFull"-showError 14 = "ErrorCan'tOpen"-showError 15 = "ErrorProtocol"-showError 16 = "ErrorEmpty"-showError 17 = "ErrorSchema"-showError 18 = "ErrorTooBig"-showError 19 = "ErrorConstraint"-showError 20 = "ErrorMismatch"-showError 21 = "ErrorMisuse"-showError 22 = "ErrorNoLargeFileSupport"-showError 23 = "ErrorAuthorization"-showError 24 = "ErrorFormat"-showError 25 = "ErrorRange"-showError 26 = "ErrorNotADatabase"-showError 100 = "ErrorRow"-showError 101 = "ErrorDone"-showError x = "Unknown error: " ++ show x---decodeColumnType :: Int -> ColumnType-decodeColumnType 1 = IntegerColumn-decodeColumnType 2 = FloatColumn-decodeColumnType 3 = TextColumn-decodeColumnType 4 = BlobColumn-decodeColumnType 5 = NullColumn-decodeColumnType x = error $ "Unknown column type: " ++ show x--foreign import ccall "sqlite3_errmsg"-  errmsgC :: Ptr () -> IO CString-errmsg :: Database -> IO String-errmsg (Database database) = do-  message <- errmsgC database-  byteString <- BS.packCString message-  return $ T.unpack $ T.decodeUtf8 byteString--sqlError :: Maybe Database -> String -> Error -> IO a-sqlError maybeDatabase functionName err = do-  details <- case maybeDatabase of-               Just database -> do-                 details <- errmsg database-                 return $ ": " ++ details-               Nothing -> return "."-  fail $ "SQLite3 returned " ++ (showError err)-         ++ " while attempting to perform " ++ functionName-         ++ details--foreign import ccall "sqlite3_open"-  openC :: CString -> Ptr (Ptr ()) -> IO Int-openError :: String -> IO (Either Database Error)-openError path = do-  BS.useAsCString (T.encodeUtf8 $ T.pack path)-                  (\pathC -> do-                     alloca (\databaseC -> do-                               err <- openC pathC databaseC-                               if err == errorOK-                                 then do-                                   database <- peek databaseC-                                   return $ Left $ Database database-                                 else return $ Right err))-open :: String -> IO Database-open path = do-  databaseOrError <- openError path-  case databaseOrError of-    Left database -> return database-    Right err -> sqlError Nothing ("open " ++ show path) err--foreign import ccall "sqlite3_close"-  closeC :: Ptr () -> IO Int-closeError :: Database -> IO Error-closeError (Database database) = do-  err <- closeC database-  return err-close :: Database -> IO ()-close database = do-  err <- closeError database-  if err == errorOK-    then return ()-    else sqlError (Just database) "close" err--foreign import ccall "sqlite3_prepare_v2"-  prepareC :: Ptr () -> CString -> Int -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> IO Int-prepareError :: Database -> BS.ByteString -> IO (Either Statement Error)-prepareError db@(Database database) text = do-  BS.useAsCString text-                  (\textC -> do-                     alloca (\statementC -> do-                               err <- prepareC database textC (-1) statementC nullPtr-                               if err == errorOK-                                 then do-                                   statement <- peek statementC-                                   return $ Left $ Statement statement db-                                 else return $ Right err))-prepare :: Database -> BS.ByteString -> IO Statement-prepare database text = do-  statementOrError <- prepareError database text-  case statementOrError of-    Left statement -> return statement-    Right err -> sqlError (Just database) ("prepare " ++ (show text)) err--foreign import ccall "sqlite3_step"-  stepC :: Ptr () -> IO Int--step :: Statement -> IO StepResult-step (Statement statement database) = do-  err <- stepC statement-  if err == errorRow-    then return Row-    else if err == errorDone-      then return Done-      else sqlError (Just database) "step" err--foreign import ccall "sqlite3_reset"-  resetC :: Ptr () -> IO Int-reset :: Statement -> IO ()-reset (Statement statement database) = do-  err <- resetC statement-  if err == errorOK-    then return ()-    else sqlError (Just database) "reset" err--foreign import ccall "sqlite3_finalize"-  finalizeC :: Ptr () -> IO Int-finalize :: Statement -> IO ()-finalize (Statement statement database) = do-  err <- finalizeC statement-  if err == errorOK-    then return ()-    else sqlError (Just database) "finalize" err--foreign import ccall "sqlite3_bind_parameter_count"-  bindParameterCountC :: Ptr () -> IO Int---- | Find the number SQL parameters in a prepared statement.-bindParameterCount :: Statement -> IO Int-bindParameterCount (Statement stmt _) = do-  bindParameterCountC stmt--maybeNullCString :: CString -> IO (Maybe BS.ByteString)-maybeNullCString s =-  if s == nullPtr then return Nothing else fmap Just (BS.packCString s)--foreign import ccall "sqlite3_bind_parameter_name"-  bindParameterNameC :: Ptr () -> Int -> IO CString---- | Return the N-th SQL parameter name.------ Named parameters are returned as-is.  E.g. \":v\" is returned as--- @Just \":v\"@.  Unnamed parameters, however, are converted to--- @Nothing@.------ Note that the column index starts at 1, not 0.-bindParameterName :: Statement -> Int -> IO (Maybe String)-bindParameterName (Statement stmt _) colNdx = do-  mn <- bindParameterNameC stmt colNdx >>= maybeNullCString-  return (mn >>= return . T.unpack . T.decodeUtf8)--foreign import ccall "sqlite3_bind_blob"-  bindBlobC :: Ptr () -> Int -> Ptr () -> Int -> Ptr () -> IO Int-bindBlob :: Statement -> Int -> BS.ByteString -> IO ()-bindBlob (Statement statement database) parameterIndex byteString = do-  size <- return $ BS.length byteString-  err <- BS.useAsCString byteString-                  (\dataC -> do-                     err <- bindBlobC statement parameterIndex (castPtr dataC) size-                                        (intPtrToPtr (-1))-                     return err)-  if err == errorOK-    then return ()-    else sqlError (Just database) "bind blob" err--foreign import ccall "sqlite3_bind_double"-  bindDoubleC :: Ptr () -> Int -> Double -> IO Int-bindDouble :: Statement -> Int -> Double -> IO ()-bindDouble (Statement statement database) parameterIndex datum = do-  err <- bindDoubleC statement parameterIndex datum-  if err == errorOK-    then return ()-    else sqlError (Just database) "bind double" err--foreign import ccall "sqlite3_bind_int"-  bindIntC :: Ptr () -> Int -> Int -> IO Int-bindInt :: Statement -> Int -> Int -> IO ()-bindInt (Statement statement database) parameterIndex datum = do-  err <- bindIntC statement parameterIndex datum-  if err == errorOK-    then return ()-    else sqlError (Just database) "bind int" err--foreign import ccall "sqlite3_bind_int64"-  bindInt64C :: Ptr () -> Int -> Int64 -> IO Int-bindInt64 :: Statement -> Int -> Int64 -> IO ()-bindInt64 (Statement statement database) parameterIndex datum = do-  err <- bindInt64C statement parameterIndex datum-  if err == errorOK-    then return ()-    else sqlError (Just database) "bind int64" err--foreign import ccall "sqlite3_bind_null"-  bindNullC :: Ptr () -> Int -> IO Int-bindNull :: Statement -> Int -> IO ()-bindNull (Statement statement database) parameterIndex = do-  err <- bindNullC statement parameterIndex-  if err == errorOK-    then return ()-    else sqlError (Just database) "bind null" err--foreign import ccall "sqlite3_bind_text"-  bindTextC :: Ptr () -> Int -> CString -> Int -> Ptr () -> IO Int-bindText :: Statement -> Int -> T.Text -> IO ()-bindText (Statement statement database) parameterIndex text = do-  byteString <- return $ T.encodeUtf8 text-  size <- return $ BS.length byteString-  err <- BS.useAsCString byteString-                  (\dataC -> do-                     err <- bindTextC statement parameterIndex dataC size-                                        (intPtrToPtr (-1))-                     return err)-  if err == errorOK-    then return ()-    else sqlError (Just database) "bind text" err--bind :: Statement -> [SQLData] -> IO ()-bind statement sqlData = do-  mapM_ (\(parameterIndex, datum) -> do-          case datum of-            SQLInteger int64 -> bindInt64 statement parameterIndex int64-            SQLFloat double -> bindDouble statement parameterIndex double-            SQLText text -> bindText statement parameterIndex text-            SQLBlob blob -> bindBlob statement parameterIndex blob-            SQLNull -> bindNull statement parameterIndex)-       $ zip [1..] sqlData-  return ()--foreign import ccall "sqlite3_column_type"-  columnTypeC :: Ptr () -> Int -> IO Int-columnType :: Statement -> Int -> IO ColumnType-columnType (Statement statement _) columnIndex = do-  result <- columnTypeC statement columnIndex-  return $ decodeColumnType result--foreign import ccall "sqlite3_column_bytes"-  columnBytesC :: Ptr () -> Int -> IO Int--foreign import ccall "sqlite3_column_blob"-  columnBlobC :: Ptr () -> Int -> IO (Ptr ())-columnBlob :: Statement -> Int -> IO BS.ByteString-columnBlob (Statement statement _) columnIndex = do-  size <- columnBytesC statement columnIndex-  BSI.create size (\resultPtr -> do-                     dataPtr <- columnBlobC statement columnIndex-                     if dataPtr /= nullPtr-                        then BSI.memcpy resultPtr (castPtr dataPtr) (fromIntegral size)-                        else return ())--foreign import ccall "sqlite3_column_int64"-  columnInt64C :: Ptr () -> Int -> IO Int64-columnInt64 :: Statement -> Int -> IO Int64-columnInt64 (Statement statement _) columnIndex = do-  columnInt64C statement columnIndex--foreign import ccall "sqlite3_column_double"-  columnDoubleC :: Ptr () -> Int -> IO Double-columnDouble :: Statement -> Int -> IO Double-columnDouble (Statement statement _) columnIndex = do-  columnDoubleC statement columnIndex--foreign import ccall "sqlite3_column_text"-  columnTextC :: Ptr () -> Int -> IO CString-columnText :: Statement -> Int -> IO T.Text-columnText (Statement statement _) columnIndex = do-  text <- columnTextC statement columnIndex-  byteString <- BS.packCString text-  return $ T.decodeUtf8 byteString--foreign import ccall "sqlite3_column_count"-  columnCountC :: Ptr () -> IO Int-columnCount :: Statement -> IO Int-columnCount (Statement statement _) = do-  columnCountC statement--column :: Statement -> Int -> IO SQLData-column statement columnIndex = do-  theType <- columnType statement columnIndex-  typedColumn theType statement columnIndex--typedColumn :: ColumnType -> Statement -> Int -> IO SQLData-typedColumn theType statement columnIndex = do-  case theType of-    IntegerColumn -> fmap SQLInteger $ columnInt64 statement columnIndex-    FloatColumn -> fmap SQLFloat $ columnDouble statement columnIndex-    TextColumn -> fmap SQLText $ columnText statement columnIndex-    BlobColumn -> fmap SQLBlob $ columnBlob statement columnIndex-    NullColumn -> return SQLNull--columns :: Statement -> IO [SQLData]-columns statement = do-  count <- columnCount statement-  mapM (\i -> column statement i) [0..count-1]--unsafeColumns :: Statement -> [Maybe ColumnType] -> IO [SQLData]-unsafeColumns statement types = go 0 types where-  go :: Int -> [Maybe ColumnType] -> IO [SQLData]-  go n [] = n `seq` return []-  go n (t:ts) = do-    c <- case t of-      Nothing -> column statement n-      Just t' -> typedColumn t' statement n-    cs <- go (n + 1) ts-    return (c:cs)

file too large to diff

@@ -1,37 +1,30 @@ name:            groundhog-sqlite-version:         0.3.0+version:         0.4.0 license:         BSD3 license-file:    LICENSE author:          Boris Lykah <lykahb@gmail.com> maintainer:      Boris Lykah <lykahb@gmail.com> synopsis:        Sqlite3 backend for the groundhog library-description:     This package includes a thin sqlite3 wrapper based on the direct-sqlite package, as well as the entire C library, so there are no system dependencies.+description:     It depends on direct-sqlite library which includes Sqlite C sources, so there are no system dependencies. category:        Database stability:       Non-stable cabal-version:   >= 1.6 build-type:      Simple -flag systemlib-  description: Use the system-wide sqlite library-  default: False- library     build-depends:   base                    >= 4         && < 5                    , bytestring              >= 0.9-                   , transformers            >= 0.2.1     && < 0.4-                   , groundhog               >= 0.3.0     && < 0.4.0-                   , monad-control           >= 0.3       && < 0.4+                   , transformers            >= 0.2.1+                   , groundhog               >= 0.4.0     && < 0.5.0+                   , monad-control           >= 0.3+                   , monad-logger            >= 0.3                    , containers              >= 0.2-                   , text                    >= 0.8       && < 0.12-                   , resource-pool           >= 0.2.1     && < 0.3+                   , text                    >= 0.8+                   , direct-sqlite           >= 2.3.5+                   , resource-pool           >= 0.2.1                    , unordered-containers-    exposed-modules: Database.Sqlite-                     Database.Groundhog.Sqlite+    exposed-modules: Database.Groundhog.Sqlite     ghc-options:     -Wall -fno-warn-unused-do-bind-    if flag(systemlib)-        extra-libraries: sqlite3-    else-        c-sources:   cbits/sqlite3.c  source-repository head   type:     git