persistent-sqlite 0.4.0 → 0.5.0
raw patch · 3 files changed
+67/−63 lines, 3 filesdep +monad-controldep −monad-peeldep −template-haskelldep ~persistent
Dependencies added: monad-control
Dependencies removed: monad-peel, template-haskell
Dependency ranges changed: persistent
Files
- Database/Persist/Sqlite.hs +27/−27
- Database/Sqlite.hs +37/−32
- persistent-sqlite.cabal +3/−4
Database/Persist/Sqlite.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PackageImports #-}+{-# LANGUAGE OverloadedStrings #-} -- | A sqlite backend for persistent. module Database.Persist.Sqlite ( withSqlitePool@@ -18,19 +18,20 @@ import Data.List (intercalate) import Data.IORef import qualified Data.Map as Map-import Control.Monad.IO.Peel (MonadPeelIO)-import Control.Exception.Peel (finally)+import Control.Monad.IO.Control (MonadControlIO)+import Control.Exception.Control (finally)+import Data.Text (Text, pack, unpack) -withSqlitePool :: MonadPeelIO m- => String+withSqlitePool :: MonadControlIO m+ => Text -> Int -- ^ number of connections to open -> (ConnectionPool -> m a) -> m a withSqlitePool s = withSqlPool $ open' s -withSqliteConn :: MonadPeelIO m => String -> (Connection -> m a) -> m a+withSqliteConn :: MonadControlIO m => Text -> (Connection -> m a) -> m a withSqliteConn = withSqlConn . open' -open' :: String -> IO Connection+open' :: Text -> IO Connection open' s = do conn <- Sqlite.open s smap <- newIORef $ Map.empty@@ -52,7 +53,7 @@ execute stmt [] reset stmt -prepare' :: Sqlite.Connection -> String -> IO Statement+prepare' :: Sqlite.Connection -> Text -> IO Statement prepare' conn sql = do stmt <- Sqlite.prepare conn sql return Statement@@ -62,9 +63,9 @@ , withStmt = withStmt' stmt } -insertSql' :: RawName -> [RawName] -> Either String (String, String)+insertSql' :: RawName -> [RawName] -> Either Text (Text, Text) insertSql' t cols =- Right (ins, sel)+ Right (pack ins, sel) where sel = "SELECT last_insert_rowid()" ins = concat@@ -83,7 +84,7 @@ Sqlite.Done <- Sqlite.step stmt return () -withStmt' :: MonadPeelIO m+withStmt' :: MonadControlIO m => Sqlite.Statement -> [PersistValue] -> (RowPopper m -> m a)@@ -112,15 +113,14 @@ showSqlType SqlBool = "BOOLEAN" migrate' :: PersistEntity val- => (String -> IO Statement)+ => (Text -> IO Statement) -> val- -> IO (Either [String] [(Bool, String)])+ -> IO (Either [Text] [(Bool, Text)]) migrate' getter val = do let (cols, uniqs) = mkColumns val let newSql = mkCreateTable False table (cols, uniqs)- stmt <- getter $ "SELECT sql FROM sqlite_master WHERE " ++- "type='table' AND name=?"- oldSql' <- withStmt stmt [PersistString $ unRawName table] go+ stmt <- getter "SELECT sql FROM sqlite_master WHERE type='table' AND name=?"+ oldSql' <- withStmt stmt [PersistText $ pack $ unRawName table] go case oldSql' of Nothing -> return $ Right [(False, newSql)] Just oldSql ->@@ -136,23 +136,23 @@ x <- pop case x of Nothing -> return Nothing- Just [PersistString y] -> return $ Just y+ Just [PersistText y] -> return $ Just y Just y -> error $ "Unexpected result from sqlite_master: " ++ show y -getCopyTable :: PersistEntity val => (String -> IO Statement) -> val+getCopyTable :: PersistEntity val => (Text -> IO Statement) -> val -> IO [(Bool, Sql)] getCopyTable getter val = do- stmt <- getter $ "PRAGMA table_info(" ++ escape table ++ ")"+ stmt <- getter $ pack $ "PRAGMA table_info(" ++ escape table ++ ")" oldCols' <- withStmt stmt [] getCols- let oldCols = map RawName $ filter (/= "id") oldCols'+ let oldCols = map (RawName . unpack) $ filter (/= "id") oldCols' let newCols = map cName cols let common = filter (`elem` oldCols) newCols return [ (False, tmpSql) , (False, copyToTemp $ RawName "id" : common)- , (common /= oldCols, dropOld)+ , (common /= oldCols, pack dropOld) , (False, newSql) , (False, copyToFinal $ RawName "id" : newCols)- , (False, dropTmp)+ , (False, pack dropTmp) ] where def = entityDef val@@ -160,7 +160,7 @@ x <- pop case x of Nothing -> return []- Just (_:PersistString name:_) -> do+ Just (_:PersistText name:_) -> do names <- getCols pop return $ name : names Just y -> error $ "Invalid result from PRAGMA table_info: " ++ show y@@ -171,7 +171,7 @@ tmpSql = mkCreateTable True tableTmp (cols, uniqs) dropTmp = "DROP TABLE " ++ escape tableTmp dropOld = "DROP TABLE " ++ escape table- copyToTemp common = concat+ copyToTemp common = pack $ concat [ "INSERT INTO " , escape tableTmp , "("@@ -181,7 +181,7 @@ , " FROM " , escape table ]- copyToFinal newCols = concat+ copyToFinal newCols = pack $ concat [ "INSERT INTO " , escape table , " SELECT "@@ -191,7 +191,7 @@ ] mkCreateTable :: Bool -> RawName -> ([Column], [UniqueDef]) -> Sql-mkCreateTable isTemp table (cols, uniqs) = concat+mkCreateTable isTemp table (cols, uniqs) = pack $ concat [ "CREATE" , if isTemp then " TEMP" else "" , " TABLE "@@ -226,7 +226,7 @@ , ")" ] -type Sql = String+type Sql = Text escape :: RawName -> String escape (RawName s) =
Database/Sqlite.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-} -- | A port of the direct-sqlite package for dealing directly with -- 'PersistValue's. module Database.Sqlite (@@ -26,15 +27,17 @@ where import Prelude hiding (error)+import qualified Prelude as P import qualified Prelude import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BSI import Foreign import Foreign.C import Database.Persist.Base (PersistValue (..))-import Data.Text (pack, unpack)+import Data.Text (Text, pack, unpack) import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode)+import Data.Monoid (mappend, mconcat) newtype Connection = Connection (Ptr ()) newtype Statement = Statement (Ptr ())@@ -121,34 +124,32 @@ foreign import ccall "sqlite3_errmsg" errmsgC :: Ptr () -> IO CString-errmsg :: Connection -> IO String+errmsg :: Connection -> IO Text errmsg (Connection database) = do message <- errmsgC database byteString <- BS.packCString message- return $ toString byteString--toString :: BSI.ByteString -> String-toString = unpack . decodeUtf8With lenientDecode--fromString :: String -> BSI.ByteString-fromString = encodeUtf8 . pack+ return $ decodeUtf8With lenientDecode byteString -sqlError :: Maybe Connection -> String -> Error -> IO a+sqlError :: Maybe Connection -> Text -> Error -> IO a sqlError maybeConnection functionName error = do details <- case maybeConnection of Just database -> do details <- errmsg database- return $ ": " ++ details+ return $ ": " `mappend` details Nothing -> return "."- fail $ "SQLite3 returned " ++ (show error)- ++ " while attempting to perform " ++ functionName- ++ details+ fail $ unpack $ mconcat+ ["SQLite3 returned "+ , pack $ show error+ , " while attempting to perform "+ , functionName+ , details+ ] foreign import ccall "sqlite3_open" openC :: CString -> Ptr (Ptr ()) -> IO Int-openError :: String -> IO (Either Connection Error)+openError :: Text -> IO (Either Connection Error) openError path' = do- BS.useAsCString (fromString path')+ BS.useAsCString (encodeUtf8 path') (\path -> do alloca (\database -> do error' <- openC path database@@ -158,12 +159,12 @@ database' <- peek database return $ Left $ Connection database' _ -> return $ Right error))-open :: String -> IO Connection+open :: Text -> IO Connection open path = do databaseOrError <- openError path case databaseOrError of Left database -> return database- Right error -> sqlError Nothing ("open " ++ show path) error+ Right error -> sqlError Nothing ("open " `mappend` (pack $ show path)) error foreign import ccall "sqlite3_close" closeC :: Ptr () -> IO Int@@ -180,9 +181,9 @@ foreign import ccall "sqlite3_prepare_v2" prepareC :: Ptr () -> CString -> Int -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> IO Int-prepareError :: Connection -> String -> IO (Either Statement Error)+prepareError :: Connection -> Text -> IO (Either Statement Error) prepareError (Connection database) text' = do- BS.useAsCString (fromString text')+ BS.useAsCString (encodeUtf8 text') (\text -> do alloca (\statement -> do error' <- prepareC database text (-1) statement nullPtr@@ -192,12 +193,12 @@ statement' <- peek statement return $ Left $ Statement statement' _ -> return $ Right error))-prepare :: Connection -> String -> IO Statement+prepare :: Connection -> Text -> IO Statement prepare database text = do statementOrError <- prepareError database text case statementOrError of Left statement -> return statement- Right error -> sqlError (Just database) ("prepare " ++ (show text)) error+ Right error -> sqlError (Just database) ("prepare " `mappend` (pack $ show text)) error foreign import ccall "sqlite3_step" stepC :: Ptr () -> IO Int@@ -310,16 +311,16 @@ foreign import ccall "sqlite3_bind_text" bindTextC :: Ptr () -> Int -> CString -> Int -> Ptr () -> IO Int-bindTextError :: Statement -> Int -> String -> IO Error+bindTextError :: Statement -> Int -> Text -> IO Error bindTextError (Statement statement) parameterIndex text = do- byteString <- return $ fromString text+ let byteString = encodeUtf8 text size <- return $ BS.length byteString BS.useAsCString byteString (\dataC -> do error <- bindTextC statement parameterIndex dataC size (intPtrToPtr (-1)) return $ decodeError error)-bindText :: Statement -> Int -> String -> IO ()+bindText :: Statement -> Int -> Text -> IO () bindText statement parameterIndex text = do error <- bindTextError statement parameterIndex text case error of@@ -334,12 +335,16 @@ PersistDouble double -> bindDouble statement parameterIndex double PersistBool b -> bindInt64 statement parameterIndex $ if b then 1 else 0- PersistString text -> bindText statement parameterIndex text+ PersistText text -> bindText statement parameterIndex text PersistByteString blob -> bindBlob statement parameterIndex blob PersistNull -> bindNull statement parameterIndex- PersistDay d -> bindText statement parameterIndex $ show d- PersistTimeOfDay d -> bindText statement parameterIndex $ show d- PersistUTCTime d -> bindText statement parameterIndex $ show d)+ PersistDay d -> bindText statement parameterIndex $ pack $ show d+ PersistTimeOfDay d -> bindText statement parameterIndex $ pack $ show d+ PersistUTCTime d -> bindText statement parameterIndex $ pack $ show d+ PersistList _ -> P.error "Refusing to serialize a PersistList to a SQLite value"+ PersistMap _ -> P.error "Refusing to serialize a PersistMap to a SQLite value"+ PersistForeignKey _ -> P.error "Refusing to serialize a PersistForeignKey to a SQLite value"+ ) $ zip [1..] sqlData return () @@ -378,11 +383,11 @@ foreign import ccall "sqlite3_column_text" columnTextC :: Ptr () -> Int -> IO CString-columnText :: Statement -> Int -> IO String+columnText :: Statement -> Int -> IO Text columnText (Statement statement) columnIndex = do text <- columnTextC statement columnIndex byteString <- BS.packCString text- return $ toString byteString+ return $ decodeUtf8With lenientDecode byteString foreign import ccall "sqlite3_column_count" columnCountC :: Ptr () -> IO Int@@ -402,7 +407,7 @@ return $ PersistDouble double TextColumn -> do text <- columnText statement columnIndex- return $ PersistString text+ return $ PersistText text BlobColumn -> do byteString <- columnBlob statement columnIndex return $ PersistByteString byteString
persistent-sqlite.cabal view
@@ -1,5 +1,5 @@ name: persistent-sqlite-version: 0.4.0+version: 0.5.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -18,11 +18,10 @@ library build-depends: base >= 4 && < 5- , template-haskell , bytestring >= 0.9.1 && < 0.10 , transformers >= 0.2.1 && < 0.3- , persistent >= 0.4 && < 0.5- , monad-peel >= 0.1 && < 0.2+ , persistent >= 0.5 && < 0.6+ , monad-control >= 0.2 && < 0.3 , containers >= 0.2 && < 0.5 , text >= 0.7 && < 0.12 exposed-modules: Database.Sqlite