diff --git a/Database/Groundhog/Sqlite.hs b/Database/Groundhog/Sqlite.hs --- a/Database/Groundhog/Sqlite.hs +++ b/Database/Groundhog/Sqlite.hs @@ -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" diff --git a/Database/Sqlite.hs b/Database/Sqlite.hs deleted file mode 100644 --- a/Database/Sqlite.hs +++ /dev/null @@ -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) diff --git a/cbits/sqlite3.c b/cbits/sqlite3.c deleted file mode 100644 # file too large to diff: cbits/sqlite3.c diff --git a/groundhog-sqlite.cabal b/groundhog-sqlite.cabal --- a/groundhog-sqlite.cabal +++ b/groundhog-sqlite.cabal @@ -1,37 +1,30 @@ name: groundhog-sqlite -version: 0.3.0 +version: 0.4.0 license: BSD3 license-file: LICENSE author: Boris Lykah maintainer: Boris Lykah 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