persistent-sqlite 0.6.2.1 → 0.7.0
raw patch · 3 files changed
+98/−94 lines, 3 filesdep +aesondep +conduitdep −data-objectdep −neitherdep ~persistentdep ~text
Dependencies added: aeson, conduit
Dependencies removed: data-object, neither
Dependency ranges changed: persistent, text
Files
- Database/Persist/Sqlite.hs +92/−88
- Database/Sqlite.hs +1/−1
- persistent-sqlite.cabal +5/−5
Database/Persist/Sqlite.hs view
@@ -6,13 +6,15 @@ module Database.Persist.Sqlite ( withSqlitePool , withSqliteConn+ , createSqlitePool , module Database.Persist , module Database.Persist.GenericSql , SqliteConf (..) ) where -import Database.Persist-import Database.Persist.Base+import Database.Persist hiding (Entity (..))+import Database.Persist.Store+import Database.Persist.EntityDef import Database.Persist.GenericSql hiding (Key(..)) import Database.Persist.GenericSql.Internal @@ -31,17 +33,24 @@ import Control.Exception.Control (finally) #define MBCIO MonadControlIO #endif-import Data.Text (Text, pack, unpack)-import Data.Neither (MEither (..), meither)-import Data.Object+import Data.Text (Text, pack)+import Control.Monad (mzero)+import Data.Aeson+import qualified Data.Text as T+import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+import Control.Applicative -withSqlitePool :: (MonadIO m, MBCIO m)+createSqlitePool :: MonadIO m => Text -> Int -> m ConnectionPool+createSqlitePool s = createSqlPool $ open' s++withSqlitePool :: C.ResourceIO m => Text -> Int -- ^ number of connections to open -> (ConnectionPool -> m a) -> m a withSqlitePool s = withSqlPool $ open' s -withSqliteConn :: (MonadIO m, MBCIO m) => Text -> (Connection -> m a) -> m a+withSqliteConn :: C.ResourceIO m => Text -> (Connection -> m a) -> m a withSqliteConn = withSqlConn . open' open' :: Text -> IO Connection@@ -76,16 +85,16 @@ , withStmt = withStmt' stmt } -insertSql' :: RawName -> [RawName] -> Either Text (Text, Text)+insertSql' :: DBName -> [DBName] -> Either Text (Text, Text) insertSql' t cols = Right (pack ins, sel) where sel = "SELECT last_insert_rowid()" ins = concat [ "INSERT INTO "- , escape t+ , escape' t , "("- , intercalate "," $ map escape cols+ , intercalate "," $ map escape' cols , ") VALUES(" , intercalate "," (map (const "?") cols) , ")"@@ -98,23 +107,22 @@ return () withStmt'- :: (MBCIO m, MonadIO m)+ :: C.ResourceIO m => Sqlite.Statement -> [PersistValue]- -> (RowPopper m -> m a)- -> m a-withStmt' stmt vals f = flip finally (liftIO $ Sqlite.reset stmt) $ do- liftIO $ Sqlite.bind stmt vals- x <- f go- return x+ -> C.Source m [PersistValue]+withStmt' stmt vals = C.sourceIO+ (Sqlite.bind stmt vals >> return stmt)+ Sqlite.reset+ pull where- go = liftIO $ do+ pull _ = liftIO $ do x <- Sqlite.step stmt case x of- Sqlite.Done -> return Nothing+ Sqlite.Done -> return C.Closed Sqlite.Row -> do cols <- liftIO $ Sqlite.columns stmt- return $ Just cols+ return $ C.Open cols showSqlType :: SqlType -> String showSqlType SqlString = "VARCHAR" showSqlType SqlInt32 = "INTEGER"@@ -127,41 +135,46 @@ showSqlType SqlBool = "BOOLEAN" migrate' :: PersistEntity val- => (Text -> IO Statement)+ => [EntityDef]+ -> (Text -> IO Statement) -> val -> IO (Either [Text] [(Bool, Text)])-migrate' getter val = do- let (cols, uniqs) = mkColumns val- let newSql = mkCreateTable False table (cols, uniqs)+migrate' allDefs getter val = do+ let (cols, uniqs) = mkColumns allDefs val+ let newSql = mkCreateTable False def (cols, uniqs) stmt <- getter "SELECT sql FROM sqlite_master WHERE type='table' AND name=?"- oldSql' <- withStmt stmt [PersistText $ pack $ unRawName table] go+ oldSql' <- C.runResourceT+ $ withStmt stmt [PersistText $ unDBName table] C.$$ go case oldSql' of Nothing -> return $ Right [(False, newSql)] Just oldSql -> if oldSql == newSql then return $ Right [] else do- sql <- getCopyTable getter val+ sql <- getCopyTable allDefs getter val return $ Right sql where def = entityDef val- table = rawTableName def- go pop = do- x <- pop+ table = entityDB def+ go = do+ x <- CL.head case x of Nothing -> return Nothing Just [PersistText y] -> return $ Just y Just y -> error $ "Unexpected result from sqlite_master: " ++ show y -getCopyTable :: PersistEntity val => (Text -> IO Statement) -> val+getCopyTable :: PersistEntity val+ => [EntityDef]+ -> (Text -> IO Statement)+ -> val -> IO [(Bool, Sql)]-getCopyTable getter val = do- stmt <- getter $ pack $ "PRAGMA table_info(" ++ escape table ++ ")"- oldCols' <- withStmt stmt [] getCols- let oldCols = map (RawName . unpack) $ filter (/= "id") oldCols' -- need to update for table id attribute ?+getCopyTable allDefs getter val = do+ stmt <- getter $ pack $ "PRAGMA table_info(" ++ escape' table ++ ")"+ oldCols' <- C.runResourceT $ withStmt stmt [] C.$$ getCols+ let oldCols = map DBName $ filter (/= "id") oldCols' -- need to update for table id attribute ? let newCols = map cName cols let common = filter (`elem` oldCols) newCols- let id_ = rawTableIdName $ entityDef val+ let id_ = entityID $ entityDef val return [ (False, tmpSql) , (False, copyToTemp $ id_ : common) , (common /= oldCols, pack dropOld)@@ -171,47 +184,52 @@ ] where def = entityDef val- getCols pop = do- x <- pop+ getCols = do+ x <- CL.head case x of Nothing -> return [] Just (_:PersistText name:_) -> do- names <- getCols pop+ names <- getCols return $ name : names Just y -> error $ "Invalid result from PRAGMA table_info: " ++ show y- table = rawTableName def- tableTmp = RawName $ unRawName table ++ "_backup"- (cols, uniqs) = mkColumns val- newSql = mkCreateTable False table (cols, uniqs)- tmpSql = mkCreateTable True tableTmp (cols, uniqs)- dropTmp = "DROP TABLE " ++ escape tableTmp- dropOld = "DROP TABLE " ++ escape table+ table = entityDB def+ tableTmp = DBName $ unDBName table `T.append` "_backup"+ (cols, uniqs) = mkColumns allDefs val+ newSql = mkCreateTable False def (cols, uniqs)+ tmpSql = mkCreateTable True def { entityDB = tableTmp } (cols, uniqs)+ dropTmp = "DROP TABLE " ++ escape' tableTmp+ dropOld = "DROP TABLE " ++ escape' table copyToTemp common = pack $ concat [ "INSERT INTO "- , escape tableTmp+ , escape' tableTmp , "("- , intercalate "," $ map escape common+ , intercalate "," $ map escape' common , ") SELECT "- , intercalate "," $ map escape common+ , intercalate "," $ map escape' common , " FROM "- , escape table+ , escape' table ] copyToFinal newCols = pack $ concat [ "INSERT INTO "- , escape table+ , T.unpack $ escape table , " SELECT "- , intercalate "," $ map escape newCols+ , intercalate "," $ map escape' newCols , " FROM "- , escape tableTmp+ , escape' tableTmp ] -mkCreateTable :: Bool -> RawName -> ([Column], [UniqueDef']) -> Sql-mkCreateTable isTemp table (cols, uniqs) = pack $ concat+escape' :: DBName -> String+escape' = T.unpack . escape++mkCreateTable :: Bool -> EntityDef -> ([Column], [UniqueDef]) -> Sql+mkCreateTable isTemp entity (cols, uniqs) = pack $ concat [ "CREATE" , if isTemp then " TEMP" else "" , " TABLE "- , escape table- , "(id INTEGER PRIMARY KEY"+ , T.unpack $ escape $ entityDB entity+ , "("+ , T.unpack $ escape $ entityID entity+ , " INTEGER PRIMARY KEY" , concatMap sqlColumn cols , concatMap sqlUnique uniqs , ")"@@ -220,36 +238,36 @@ sqlColumn :: Column -> String sqlColumn (Column name isNull typ def ref) = concat [ ","- , escape name+ , T.unpack $ escape name , " " , showSqlType typ , if isNull then " NULL" else " NOT NULL" , case def of Nothing -> ""- Just d -> " DEFAULT " ++ d+ Just d -> " DEFAULT " ++ T.unpack d , case ref of Nothing -> ""- Just (table, _) -> " REFERENCES " ++ escape table+ Just (table, _) -> " REFERENCES " ++ T.unpack (escape table) ] -sqlUnique :: UniqueDef' -> String-sqlUnique (cname, cols) = concat+sqlUnique :: UniqueDef -> String+sqlUnique (UniqueDef _ cname cols) = concat [ ",CONSTRAINT "- , escape cname+ , T.unpack $ escape cname , " UNIQUE ("- , intercalate "," $ map escape cols+ , intercalate "," $ map (T.unpack . escape . snd) cols , ")" ] type Sql = Text -escape :: RawName -> String-escape (RawName s) =- '"' : go s ++ "\""+escape :: DBName -> Text+escape (DBName s) =+ T.concat [q, T.concatMap go s, q] where- go "" = ""- go ('"':xs) = "\"\"" ++ go xs- go (x:xs) = x : go xs+ q = T.singleton '"'+ go '"' = "\"\""+ go c = T.singleton c -- | Information required to connect to a sqlite database data SqliteConf = SqliteConf@@ -260,26 +278,12 @@ instance PersistConfig SqliteConf where type PersistConfigBackend SqliteConf = SqlPersist type PersistConfigPool SqliteConf = ConnectionPool- withPool (SqliteConf cs size) = withSqlitePool cs size+ createPoolConfig (SqliteConf cs size) = createSqlitePool cs size runPool _ = runSqlPool- loadConfig e' = meither Left Right $ do- e <- go $ fromMapping e'- db <- go $ lookupScalar "database" e- pool' <- go $ lookupScalar "poolsize" e- pool <- safeRead "poolsize" pool'-- return $ SqliteConf db pool- where- go :: MEither ObjectExtractError a -> MEither String a- go (MLeft e) = MLeft $ show e- go (MRight a) = MRight a--safeRead :: String -> Text -> MEither String Int-safeRead name t = case reads s of- (i, _):_ -> MRight i- [] -> MLeft $ concat ["Invalid value for ", name, ": ", s]- where- s = unpack t+ loadConfig (Object o) =+ SqliteConf <$> o .: "database"+ <*> o .: "poolsize"+ loadConfig _ = mzero #if MIN_VERSION_monad_control(0, 3, 0) finally :: MonadBaseControl IO m
Database/Sqlite.hs view
@@ -33,7 +33,7 @@ import qualified Data.ByteString.Internal as BSI import Foreign import Foreign.C-import Database.Persist.Base (PersistValue (..))+import Database.Persist.Store (PersistValue (..)) import Data.Text (Text, pack, unpack) import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode)
persistent-sqlite.cabal view
@@ -1,5 +1,5 @@ name: persistent-sqlite-version: 0.6.2.1+version: 0.7.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -20,12 +20,12 @@ build-depends: base >= 4 && < 5 , bytestring >= 0.9.1 && < 0.10 , transformers >= 0.2.1 && < 0.3- , persistent >= 0.6.3 && < 0.7+ , persistent >= 0.7 && < 0.8 , monad-control >= 0.2 && < 0.4 , containers >= 0.2 && < 0.5- , text >= 0.7 && < 0.12- , data-object >= 0.3 && < 0.4- , neither >= 0.3 && < 0.4+ , text >= 0.7 && < 1+ , aeson >= 0.5+ , conduit exposed-modules: Database.Sqlite Database.Persist.Sqlite ghc-options: -Wall