module Database.Groundhog.Sqlite
( withSqlitePool
, withSqliteConn
, runSqlitePool
, runSqliteConn
, Sqlite
, module Database.Groundhog
) where
import Database.Groundhog
import Database.Groundhog.Core
import Database.Groundhog.Generic
import Database.Groundhog.Generic.Sql
import qualified Database.Sqlite as S
import Control.Exception.Control (bracket, onException, finally)
import Control.Monad(liftM, forM, (>=>))
import Control.Monad.IO.Control (MonadControlIO)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class(MonadTrans(..))
import Control.Monad.Trans.Reader(ask)
import Data.Enumerator(Enumerator, Iteratee(..), Stream(..), checkContinue0, (>>==), joinE, runIteratee, continue, concatEnums)
import qualified Data.Enumerator.List as EL
import Data.Int (Int64)
import Data.List (intercalate)
import Data.IORef
import qualified Data.Map as Map
import Data.Pool
data Sqlite = Sqlite S.Database (IORef (Map.Map String S.Statement))
instance MonadControlIO m => PersistBackend (DbPersist Sqlite m) where
insert v = insert' v
insertBy v = insertBy' v
replace k v = replace' k v
selectEnum cond ords limit offset = selectEnum' cond ords limit offset
selectAllEnum = selectAllEnum'
select cond ords limit offset = select' cond ords limit offset
selectAll = selectAll'
get k = get' k
update upds cond = update' upds cond
delete cond = delete' cond
deleteByKey k = deleteByKey' k
count cond = count' cond
countAll fakeV = countAll' fakeV
migrate fakeV = migrate' fakeV
executeRaw False query ps = executeRaw' query ps
executeRaw True query ps = executeRawCached' query ps
queryRaw False query ps f = queryRaw' query ps f
queryRaw True query ps f = queryRawCached' query ps f
insertList l = insertList' l
getList k = getList' k
insertTuple t ts = insertTuple' t ts
getTuple t k = getTuple' t k
withSqlitePool :: MonadControlIO m
=> String
-> Int
-> (Pool Sqlite -> m a)
-> m a
withSqlitePool s = createPool (open' s) close'
withSqliteConn :: MonadControlIO m
=> String
-> (Sqlite -> m a)
-> m a
withSqliteConn s = bracket (liftIO $ open' s) (liftIO.close')
runSqlitePool :: MonadControlIO m => DbPersist Sqlite m a -> Pool Sqlite -> m a
runSqlitePool = flip withPool' . runSqliteConn
runSqliteConn :: MonadControlIO m => DbPersist Sqlite m a -> Sqlite -> m a
runSqliteConn f conn@(Sqlite c _) = do
let runStmt query = S.prepare c query >>= \stmt -> S.step stmt >> S.finalize stmt
liftIO $ runStmt "BEGIN"
x <- onException (runDbPersist f conn) (liftIO $ runStmt "ROLLBACK")
liftIO $ runStmt "COMMIT"
return x
open' :: String -> IO Sqlite
open' s = do
conn <- S.open s
cache <- newIORef Map.empty
return $ Sqlite conn cache
close' :: Sqlite -> IO ()
close' (Sqlite conn smap) = do
readIORef smap >>= mapM_ S.finalize . Map.elems
S.close conn
migrate' :: (PersistEntity v, MonadControlIO m) => v -> Migration (DbPersist Sqlite m)
migrate' = migrateRecursively migE migT migL where
migE e = do
let name = getEntityName e
let constrs = constructors e
let mainTableQuery = "CREATE TABLE " ++ escape name ++ " (id INTEGER PRIMARY KEY, discr INTEGER NOT NULL)"
if isSimple constrs
then do
x <- checkTable name
case x of
Just sql | sql == mainTableQuery -> do
return $ Left ["Datatype with multiple constructors was truncated to one constructor. Manual migration required. Datatype: " ++ name]
_ -> liftM snd $ migConstrAndTrigger True name $ head constrs
else do
mainsql <- checkTable name
let constrTable c = name ++ [defDelim] ++ constrName c
res <- mapM (\c -> migConstrAndTrigger False name c) constrs
case mainsql of
Nothing -> do
let orphans = filter fst res
return $ if null orphans
then mergeMigrations $ Right [(False, mainTableQuery)]:map snd res
else Left $ foldl (\l (_, c) -> ("Orphan constructor table found: " ++ constrTable c):l) [] $ filter (fst.fst) $ zip res constrs
Just sql -> do
if sql == mainTableQuery
then do
return $ if any (not.fst) res
then Left ["Migration with constructors addition will be implemented soon. Datatype: " ++ name]
else mergeMigrations $ map snd res
else do
return $ Left ["Migration from one constructor to many will be implemented soon. Datatype: " ++ name]
migT n ts = do
let name = intercalate "$" $ ("Tuple" ++ show n ++ "$") : map getName ts
let fields = zipWith (\i t -> ("val" ++ show i, t)) [0::Int ..] ts
(_, trigger) <- migTriggerOnDelete name $ mkDeletesOnDelete fields
x <- checkTable name
let fields' = concatMap (\(s, t) -> sqlColumn s (getType t)) fields
let query = "CREATE TABLE " ++ name ++ " (id INTEGER PRIMARY KEY" ++ fields' ++ ")"
return $ case x of
Nothing -> mergeMigrations [Right [(False, query)], trigger]
Just sql -> if sql == query
then Right []
else Left ["Tuple table " ++ name ++ " has unexpected structure"]
--TODO:finish
migL t = do
let mainName = "List$" ++ "$" ++ getName t
let valuesName = mainName ++ "$" ++ "values"
let mainQuery = "CREATE TABLE " ++ mainName ++ " (id INTEGER PRIMARY KEY)"
let valuesQuery = "CREATE TABLE " ++ valuesName ++ " (id INTEGER, ord$ INTEGER NOT NULL" ++ sqlColumn "value" (getType t) ++ ")"
x <- checkTable mainName
y <- checkTable valuesName
(_, triggerMain) <- migTriggerOnDelete mainName ["DELETE FROM " ++ valuesName ++ " WHERE id=old.id;"]
(_, triggerValues) <- migTriggerOnDelete valuesName $ mkDeletesOnDelete [("value", t)]
let f name a b = if a /= b then ["List table " ++ name ++ " error. Expected: " ++ a ++ ". Found: " ++ b] else []
return $ case (x, y) of
(Nothing, Nothing) -> mergeMigrations [Right [(False, mainQuery), (False, valuesQuery)], triggerMain, triggerValues]
(Just sql1, Just sql2) -> let errors = f mainName mainQuery sql1 ++ f valuesName valuesQuery sql2
in if null errors then Right [] else Left errors
(_, Nothing) -> Left ["Found orphan main list table " ++ mainName]
(Nothing, _) -> Left ["Found orphan list values table " ++ valuesName]
migConstrAndTrigger :: MonadControlIO m => Bool -> String -> ConstructorDef -> DbPersist Sqlite m (Bool, SingleMigration)
migConstrAndTrigger simple name constr = do
let cName = if simple then name else name ++ [defDelim] ++ constrName constr
(constrExisted, mig) <- migConstr cName constr
let dels = mkDeletesOnDelete $ constrParams constr
let allDels = if simple then dels else ("DELETE FROM " ++ escape name ++ " WHERE id=old." ++ constrId ++ ";"):dels
(triggerExisted, delTrigger) <- migTriggerOnDelete cName allDels
let updDels = mkDeletesOnUpdate $ constrParams constr
updTriggers <- mapM (liftM snd . uncurry (migTriggerOnUpdate cName)) updDels
return $ if constrExisted == triggerExisted || (constrExisted && null allDels)
then (constrExisted, mergeMigrations ([mig, delTrigger] ++ updTriggers))
else (constrExisted, Left ["Trigger and constructor table must exist together: " ++ cName])
migConstr :: MonadControlIO m => String -> ConstructorDef -> DbPersist Sqlite m (Bool, SingleMigration)
migConstr name constr = do
let fields = constrParams constr
let uniques = constrConstrs constr
let query = "CREATE TABLE " ++ escape name ++ " (" ++ constrId ++ " INTEGER PRIMARY KEY" ++ concatMap (\(n, t) -> sqlColumn n (getType t)) fields ++ concatMap sqlUnique uniques ++ ")"
x <- checkTable name
return $ case x of
Nothing -> (False, Right [(False, query)])
Just sql -> (True, if sql == query
then Right []
else Left ["Constructor table must be altered: " ++ name])
migTriggerOnDelete :: MonadControlIO m => String -> [String] -> DbPersist Sqlite m (Bool, SingleMigration)
migTriggerOnDelete name deletes = do
let query = "CREATE TRIGGER " ++ escape name ++ " DELETE ON " ++ escape name ++ " BEGIN " ++ concat deletes ++ "END"
x <- checkTrigger name
return $ case x of
Nothing | null deletes -> (False, Right [])
Nothing -> (False, Right [(False, query)])
Just sql -> (True, if null deletes
then Right [(False, "DROP TRIGGER " ++ escape name)]
else if sql == query
then Right []
else Left ["The trigger " ++ name ++ " is different from expected. Manual migration required.\n" ++ sql ++ "\n" ++ query])
migTriggerOnUpdate :: MonadControlIO m => String -> String -> String -> DbPersist Sqlite m (Bool, SingleMigration)
migTriggerOnUpdate name fieldName del = do
let tname = name ++ "$" ++ fieldName
let query = "CREATE TRIGGER " ++ escape tname ++ " UPDATE OF " ++ escape fieldName ++ " ON " ++ escape name ++ " BEGIN " ++ del ++ "END"
x <- checkTrigger tname
return $ case x of
Nothing -> (False, Right [(False, query)])
Just sql -> (True, if sql == query
then Right []
else Left ["The trigger " ++ tname ++ " is different from expected. Manual migration required.\n" ++ sql ++ "\n" ++ query])
mkDeletesOnDelete :: [(String, NamedType)] -> [String]
mkDeletesOnDelete types = map (uncurry delField) ephemerals where
delField field t = "DELETE FROM " ++ tname ++ " WHERE id=old." ++ escape field ++ ";" where
tname = getName t
ephemerals = filter (isEphemeral.snd) types
mkDeletesOnUpdate :: [(String, NamedType)] -> [(String, String)]
mkDeletesOnUpdate types = map (uncurry delField) ephemerals where
delField field t = (field, "DELETE FROM " ++ tname ++ " WHERE id=old." ++ escape field ++ ";") where
tname = getName t
ephemerals = filter (isEphemeral.snd) types
isEphemeral :: NamedType -> Bool
isEphemeral a = case getType a of
DbList _ -> True
DbTuple _ _ -> True
_ -> False
checkTrigger :: MonadControlIO m => String -> DbPersist Sqlite m (Maybe String)
checkTrigger = checkSqliteMaster "trigger"
checkTable :: MonadControlIO m => String -> DbPersist Sqlite m (Maybe String)
checkTable = checkSqliteMaster "table"
checkSqliteMaster :: MonadControlIO m => String -> String -> DbPersist Sqlite m (Maybe String)
checkSqliteMaster vtype name = do
let query = "SELECT sql FROM sqlite_master WHERE type = ? AND name = ?"
x <- queryRawTyped query [DbString] [toPrim vtype, toPrim name] firstRow
let throwErr = error . ("Unexpected result from sqlite_master: " ++)
case x of
Nothing -> return Nothing
Just [hsql] -> case hsql of
PersistString sql -> return $ Just sql
err -> throwErr $ "column sql is not string: " ++ show err
Just xs -> throwErr $ "requested 1 column, returned " ++ show xs
getStatementCached :: MonadIO m => String -> DbPersist Sqlite m S.Statement
getStatementCached sql = do
Sqlite conn smap <- DbPersist ask
liftIO $ do
smap' <- readIORef smap
case Map.lookup sql smap' of
Nothing -> do
stmt <- S.prepare conn sql
writeIORef smap (Map.insert sql stmt smap')
return stmt
Just stmt -> return stmt
getStatement :: MonadIO m => String -> DbPersist Sqlite m S.Statement
getStatement sql = do
Sqlite conn _ <- DbPersist ask
liftIO $ S.prepare conn 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 DbBlob = "BLOB"
showSqlType (DbMaybe t) = showSqlType (getType t)
showSqlType (DbList _) = "INTEGER"
showSqlType (DbTuple _ _) = "INTEGER"
showSqlType (DbEntity _) = "INTEGER"
sqlColumn :: String -> DbType -> String
sqlColumn name typ = ", " ++ escape name ++ " " ++ showSqlType typ ++ f typ where
f (DbMaybe t) = g (getType t)
f t = " NOT NULL" ++ g t
g (DbEntity t) = " REFERENCES " ++ escape (getEntityName t)
g (DbTuple n ts) = " REFERENCES " ++ (intercalate "$" $ ("Tuple" ++ show n ++ "$") : map getName ts)
g (DbList t) = " REFERENCES " ++ "List$$" ++ getName t
g _ = ""
sqlUnique :: Constraint -> String
sqlUnique (cname, cols) = concat
[ ", CONSTRAINT "
, escape cname
, " UNIQUE ("
, intercalate "," $ map escape cols
, ")"
]
insert' :: (PersistEntity v, MonadControlIO m) => v -> DbPersist Sqlite m (Key v)
insert' v = do
vals <- toPersistValues v
let e = entityDef v
let name = getEntityName e
let constructorNum = fromPrim (head vals)
if isSimple (constructors e)
then do
let constr = head $ constructors e
let query = insertIntoConstructorTable False name constr
executeRaw True query (tail vals)
rowid <- getLastInsertRowId
return $ Key rowid
else do
let constr = constructors e !! constructorNum
let cName = name ++ [defDelim] ++ constrName constr
let query = "INSERT INTO " ++ escape name ++ "(discr)VALUES(?)"
executeRaw True query $ take 1 vals
rowid <- getLastInsertRowId
let cQuery = insertIntoConstructorTable True cName constr
executeRaw True cQuery $ PersistInt64 rowid:(tail vals)
return $ Key rowid
insertIntoConstructorTable :: Bool -> String -> ConstructorDef -> String
insertIntoConstructorTable withId tName c = "INSERT INTO " ++ escape tName ++ "(" ++ fieldNames ++ ")VALUES(" ++ placeholders ++ ")" where
fieldNames = intercalate "," $ (if withId then (constrId:) else id) $ map (escape.fst) (constrParams c)
placeholders = intercalate "," $ (if withId then ("?":) else id) $ map (const "?") (constrParams c)
insertBy' :: (MonadControlIO m, PersistEntity v) => v -> DbPersist Sqlite m (Either (Key v) (Key v))
insertBy' v = do
let e = entityDef v
let name = getEntityName e
let constraints = getConstraints v
let constructorNum = fst constraints
let constraintFields = map snd $ snd constraints
let constrCond = intercalate " OR " $ map (intercalate " AND " . map (\(fname, _) -> escape fname ++ "=?")) constraintFields
let ifAbsent tname ins = if null constraintFields
then liftM (Right . Key) ins
else do
let query = "SELECT " ++ constrId ++ " FROM " ++ escape tname ++ " WHERE " ++ constrCond
x <- queryRawTyped query [DbInt64] (concatMap (map snd) constraintFields) firstRow
case x of
Nothing -> liftM (Right . Key) ins
Just [k] -> return $ Left $ fromPrim k
Just xs -> fail $ "unexpected query result: " ++ show xs
if isSimple (constructors e)
then do
let constr = head $ constructors e
ifAbsent name $ do
let query = insertIntoConstructorTable False name constr
vals <- toPersistValues v
executeRaw True query (tail vals)
getLastInsertRowId
else do
let constr = constructors e !! constructorNum
let cName = name ++ [defDelim] ++ constrName constr
ifAbsent cName $ do
let query = "INSERT INTO " ++ escape name ++ "(discr)VALUES(?)"
vals <- toPersistValues v
executeRaw True query $ take 1 vals
rowid <- getLastInsertRowId
let cQuery = insertIntoConstructorTable True cName constr
executeRaw True cQuery $ PersistInt64 rowid :(tail vals)
return rowid
replace' :: (MonadControlIO m, PersistEntity v) => Key v -> v -> DbPersist Sqlite m ()
replace' k v = do
vals <- toPersistValues v
let e = entityDef v
let name = getEntityName e
let constructorNum = fromPrim (head vals)
let constr = constructors e !! constructorNum
let upds = intercalate "," $ map (\f -> escape (fst f) ++ "=?") $ constrParams constr
let mkQuery tname = "UPDATE " ++ escape tname ++ " SET " ++ upds ++ " WHERE " ++ constrId ++ "=?"
if isSimple (constructors e)
then executeRaw True (mkQuery name) (tail vals ++ [toPrim k])
else do
let query = "SELECT discr FROM " ++ escape name ++ " WHERE id=?"
x <- queryRawTyped query [DbInt32] [toPrim k] (firstRow >=> return.fmap (fromPrim . head))
case x of
Just discr -> do
let cName = name ++ [defDelim] ++ constrName constr
if discr == constructorNum
then executeRaw True (mkQuery cName) (tail vals ++ [toPrim k])
else do
let insQuery = insertIntoConstructorTable True cName constr
executeRaw True insQuery (toPrim k:tail vals)
let oldCName = name ++ [defDelim] ++ constrName (constructors e !! discr)
let delQuery = "DELETE FROM " ++ escape oldCName ++ " WHERE " ++ constrId ++ "=?"
executeRaw True delQuery [toPrim k]
let reInsQuery = "INSERT INTO " ++ escape name ++ "(id,discr)VALUES(?,?)"
executeRaw True reInsQuery [toPrim k, head vals]
Nothing -> return ()
mkEntity :: (PersistEntity v, PersistBackend m) => Int -> [PersistValue] -> m (Key v, v)
mkEntity i (k:xs) = fromPersistValues (toPrim i:xs) >>= \v -> return (fromPrim k, v)
mkEntity _ [] = error "Unable to create entity. No values supplied"
selectEnum' :: (MonadControlIO m, PersistEntity v, Constructor c) => Cond v c -> [Order v c] -> Int -> Int -> Enumerator (Key v, v) (DbPersist Sqlite m) a
selectEnum' (cond :: Cond v c) ords limit offset = start where
start = if isSimple (constructors e)
then joinE (queryEnum (mkQuery name) types binds) (EL.mapM (mkEntity 0))
else let
query = mkQuery $ name ++ [defDelim] ++ constrName constr
in joinE (queryEnum query types binds) (EL.mapM (mkEntity $ constrNum constr))
e = entityDef (undefined :: v)
orders = renderOrders escape ords
name = getEntityName e
(lim, limps) = case (limit, offset) of
(0, 0) -> ("", [])
(0, o) -> (" LIMIT -1 OFFSET ?", [toPrim o])
(l, 0) -> (" LIMIT ?", [toPrim l])
(l, o) -> (" LIMIT ? OFFSET ?", [toPrim l, toPrim o])
(conds, condps) = renderCond' cond
mkQuery tname = "SELECT * FROM " ++ escape tname ++ " WHERE " ++ (conds . orders $ lim)
binds = condps limps
constr = (constructors e) !! phantomConstrNum (undefined :: c)
types = DbInt64:getConstructorTypes constr
selectAllEnum' :: forall m v a.(MonadControlIO m, PersistEntity v) => Enumerator (Key v, v) (DbPersist Sqlite m) a
selectAllEnum' = start where
start = if isSimple (constructors e)
then let
query = "SELECT * FROM " ++ escape name
types = DbInt64:(getConstructorTypes $ head $ constructors e)
in joinE (queryEnum query types []) (EL.mapM (mkEntity 0))
else concatEnums $ zipWith q [0..] (constructors e) where
q cNum constr = let
cName = name ++ [defDelim] ++ constrName constr
query = "SELECT * FROM " ++ escape cName
types = DbInt64:getConstructorTypes constr
in joinE (queryEnum query types []) (EL.mapM (mkEntity cNum))
e = entityDef (undefined :: v)
name = getEntityName e
select' :: (MonadControlIO m, PersistEntity v, Constructor c) => Cond v c -> [Order v c] -> Int -> Int -> DbPersist Sqlite m [(Key v, v)]
select' (cond :: Cond v c) ords limit offset = start where
start = if isSimple (constructors e)
then doSelectQuery (mkQuery name) 0
else let
cName = name ++ [defDelim] ++ constrName constr
in doSelectQuery (mkQuery cName) $ constrNum constr
e = entityDef (undefined :: v)
orders = renderOrders escape ords
name = getEntityName e
(lim, limps) = case (limit, offset) of
(0, 0) -> ("", [])
(0, o) -> (" LIMIT -1 OFFSET ?", [toPrim o])
(l, 0) -> (" LIMIT ?", [toPrim l])
(l, o) -> (" LIMIT ? OFFSET ?", [toPrim l, toPrim o])
(conds, condps) = renderCond' cond
mkQuery tname = "SELECT * FROM " ++ escape tname ++ " WHERE " ++ (conds . orders $ lim)
doSelectQuery query cNum = queryRawTyped query types binds $ mapAllRows (mkEntity cNum)
binds = condps limps
constr = constructors e !! phantomConstrNum (undefined :: c)
types = DbInt64:getConstructorTypes constr
selectAll' :: forall m v.(MonadControlIO m, PersistEntity v) => DbPersist Sqlite m [(Key v, v)]
selectAll' = start where
start = if isSimple (constructors e)
then let
query = "SELECT * FROM " ++ escape name
types = DbInt64:(getConstructorTypes $ head $ constructors e)
in queryRawTyped query types [] $ mapAllRows (mkEntity 0)
else liftM concat $ forM (zip [0..] (constructors e)) $ \(i, constr) -> do
let cName = name ++ [defDelim] ++ constrName constr
let query = "SELECT * FROM " ++ escape cName
let types = DbInt64:getConstructorTypes constr
queryRawTyped query types [] $ mapAllRows (mkEntity i)
e = entityDef (undefined :: v)
name = getEntityName e
insertTuple' :: MonadIO m => NamedType -> [PersistValue] -> DbPersist Sqlite m Int64
insertTuple' t vals = do
let name = getName t
let (DbTuple _ ts) = getType t
let fields = map (\i -> "val" ++ show i) [0 .. length ts 1]
let query = "INSERT INTO " ++ name ++ " (" ++ intercalate ", " fields ++ ")VALUES(" ++ intercalate ", " (replicate (length ts) "?") ++ ")"
executeRawCached' query vals
getLastInsertRowId
getTuple' :: MonadControlIO m => NamedType -> Int64 -> DbPersist Sqlite m [PersistValue]
getTuple' t k = do
let name = getName t
let (DbTuple _ ts) = getType t
let query = "SELECT * FROM " ++ name ++ " WHERE id = ?"
x <- queryRawTyped query (DbInt64:map getType ts) [toPrim k] firstRow
maybe (fail $ "No tuple with id " ++ show k) (return . tail) x
get' :: (MonadControlIO m, PersistEntity v) => Key v -> DbPersist Sqlite m (Maybe v)
get' (k :: Key v) = do
let e = entityDef (undefined :: v)
let name = getEntityName e
if isSimple (constructors e)
then do
let constr = head $ constructors e
let query = "SELECT * FROM " ++ escape name ++ " WHERE " ++ constrId ++ "=?"
x <- queryRawTyped query (DbInt64:getConstructorTypes constr) [toPrim k] firstRow
case x of
Just (_:xs) -> liftM Just $ fromPersistValues $ PersistInt64 0:xs
Just x' -> fail $ "Unexpected number of columns returned: " ++ show x'
Nothing -> return Nothing
else do
let query = "SELECT discr FROM " ++ escape name ++ " WHERE id=?"
x <- queryRawTyped query [DbInt64] [toPrim k] firstRow
case x of
Just [discr] -> do
let constructorNum = fromPrim discr
let constr = constructors e !! constructorNum
let cName = name ++ [defDelim] ++ constrName constr
let cQuery = "SELECT * FROM " ++ escape cName ++ " WHERE " ++ constrId ++ "=?"
x2 <- queryRawTyped cQuery (DbInt64:getConstructorTypes constr) [toPrim k] firstRow
case x2 of
Just (_:xs) -> liftM Just $ fromPersistValues $ discr:xs
Just x2' -> fail $ "Unexpected number of columns returned: " ++ show x2'
Nothing -> fail "Missing entry in constructor table"
Just x' -> fail $ "Unexpected number of columns returned: " ++ show x'
Nothing -> return Nothing
update' :: (PersistBackend m, PersistEntity v, Constructor c) => [Update v c] -> Cond v c -> m ()
update' upds (cond :: Cond v c) = do
let e = entityDef (undefined :: v)
let name = getEntityName e
let (conds, condps) = renderCond' cond
let (upds', ps) = renderUpdates escape upds
let mkQuery tname = "UPDATE " ++ escape tname ++ " SET " ++ (upds' . (" WHERE " ++) . conds $ "")
if isSimple (constructors e)
then executeRaw True (mkQuery name) (ps $ condps [])
else do
let cName = name ++ [defDelim] ++ phantomConstrName (undefined :: c)
executeRaw True (mkQuery cName) (ps $ condps [])
delete' :: (PersistBackend m, PersistEntity v, Constructor c) => Cond v c -> m ()
delete' (cond :: Cond v c) = do
let e = entityDef (undefined :: v)
let (conds, condps) = renderCond' cond
let name = getEntityName e
if isSimple (constructors e)
then do
let query = "DELETE FROM " ++ escape name ++ " WHERE " ++ conds ""
executeRaw True query (condps [])
else do
let cName = name ++ [defDelim] ++ phantomConstrName (undefined :: c)
let query = "DELETE FROM " ++ escape cName ++ " WHERE " ++ conds ""
executeRaw True query (condps [])
deleteByKey' :: (MonadControlIO m, PersistEntity v) => Key v -> DbPersist Sqlite m ()
deleteByKey' (k :: Key v) = do
let e = entityDef (undefined :: v)
let name = getEntityName e
if isSimple (constructors e)
then do
let query = "DELETE FROM " ++ escape name ++ " WHERE id$=?"
executeRaw True query [toPrim k]
else do
let query = "SELECT discr FROM " ++ escape name
x <- queryRawTyped query [DbInt64] [] firstRow
case x of
Just [discr] -> do
let cName = name ++ [defDelim] ++ constrName (constructors e !! fromPrim discr)
let cQuery = "DELETE FROM " ++ escape cName ++ " WHERE id$=?"
executeRaw True cQuery [toPrim k]
Just xs -> fail $ "requested 1 column, returned " ++ show xs
Nothing -> return ()
count' :: (MonadControlIO m, PersistEntity v, Constructor c) => Cond v c -> DbPersist Sqlite m Int
count' (cond :: Cond v c) = do
let cName = persistName (undefined :: v) ++ [defDelim] ++ phantomConstrName (undefined :: c)
let (conds, condps) = renderCond' cond
let query = "SELECT COUNT(*) FROM " ++ cName ++ " WHERE " ++ conds ""
x <- queryRawTyped query [DbInt64] (condps []) firstRow
case x of
Just [num] -> return $ fromPrim num
Just xs -> fail $ "requested 1 column, returned " ++ show (length xs)
Nothing -> fail $ "COUNT returned no rows"
countAll' :: (MonadControlIO m, PersistEntity v) => v -> DbPersist Sqlite m Int
countAll' (_ :: v) = do
let name = persistName (undefined :: v)
let query = "SELECT COUNT(*) FROM " ++ name
x <- queryRawTyped query [DbInt64] [] firstRow
case x of
Just [num] -> return $ fromPrim num
Just xs -> fail $ "requested 1 column, returned " ++ show (length xs)
Nothing -> fail $ "COUNT returned no rows"
insertList' :: forall m a.(MonadControlIO m, PersistField a) => [a] -> DbPersist Sqlite m Int64
insertList' l = do
let mainName = "List$$" ++ persistName (undefined :: a)
executeRaw True ("INSERT INTO " ++ mainName ++ " DEFAULT VALUES") []
k <- getLastInsertRowId
let valuesName = mainName ++ "$" ++ "values"
let query = "INSERT INTO " ++ valuesName ++ "(id,ord$,value)VALUES(?,?,?)"
let go :: Int -> [a] -> DbPersist Sqlite m ()
go n (x:xs) = do
x' <- toPersistValue x
executeRaw True query [toPrim k, toPrim n, x']
go (n + 1) xs
go _ [] = return ()
go 0 l
return k
getList' :: forall m a.(MonadControlIO m, PersistField a) => Int64 -> DbPersist Sqlite m [a]
getList' k = do
let mainName = "List$$" ++ persistName (undefined :: a)
let valuesName = mainName ++ "$" ++ "values"
queryRawTyped ("SELECT value FROM " ++ valuesName ++ " WHERE id=? ORDER BY ord$") [dbType (undefined :: a)] [toPrim k] $ mapAllRows (fromPersistValue.head)
getLastInsertRowId :: MonadIO m => DbPersist Sqlite m Int64
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 $ fromPrim $ pFromSql x
constrId :: String
constrId = defId
bind :: S.Statement -> [PersistValue] -> IO ()
bind stmt = go 1 where
go _ [] = return ()
go i (x:xs) = do
case x of
PersistInt64 int64 -> S.bindInt64 stmt i int64
PersistString text -> S.bindText stmt i text
PersistDouble double -> S.bindDouble stmt i double
PersistBool b -> S.bindInt64 stmt i $ if b then 1 else 0
PersistByteString blob -> S.bindBlob stmt i blob
PersistNull -> S.bindNull stmt i
PersistDay d -> S.bindText stmt i $ show d
PersistTimeOfDay d -> S.bindText stmt i $ show d
PersistUTCTime d -> S.bindText stmt i $ show d
go (i+1) xs
executeRaw' :: MonadIO m => String -> [PersistValue] -> DbPersist Sqlite m ()
executeRaw' query vals = do
stmt <- getStatement query
liftIO $ flip finally (S.finalize stmt) $ do
bind stmt vals
S.Done <- S.step stmt
return ()
executeRawCached' :: MonadIO m => String -> [PersistValue] -> DbPersist Sqlite m ()
executeRawCached' query vals = do
stmt <- getStatementCached query
liftIO $ flip finally (S.reset stmt) $ do
bind stmt vals
S.Done <- S.step stmt
return ()
queryRaw' :: MonadControlIO m => String -> [PersistValue] -> (RowPopper (DbPersist Sqlite m) -> DbPersist Sqlite m a) -> DbPersist Sqlite m a
queryRaw' query vals f = do
stmt <- getStatement query
flip finally (liftIO $ S.finalize stmt) $ do
liftIO $ bind stmt vals
f $ liftIO $ do
x <- S.step stmt
case x of
S.Done -> return Nothing
S.Row -> liftM (Just . map pFromSql) $ S.columns stmt
queryRawCached' :: MonadControlIO m => String -> [PersistValue] -> (RowPopper (DbPersist Sqlite m) -> DbPersist Sqlite m a) -> DbPersist Sqlite m a
queryRawCached' query vals f = do
stmt <- getStatementCached query
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.columns stmt
queryRawTyped :: MonadControlIO m => String -> [DbType] -> [PersistValue] -> (RowPopper (DbPersist Sqlite m) -> DbPersist Sqlite m a) -> DbPersist Sqlite m a
queryRawTyped query types vals f = do
stmt <- getStatementCached query
let types' = map typeToSqlite 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'
queryEnum :: MonadControlIO m => String -> [DbType] -> [PersistValue] -> Enumerator [PersistValue] (DbPersist Sqlite m) b
queryEnum query types vals = \step -> do
stmt <- lift $ getStatementCached query
liftIO $ S.reset stmt >> bind stmt vals
let iter = checkContinue0 $ \loop k -> do
x <- liftIO $ do
x <- S.step stmt
case x of
S.Done -> return Nothing
S.Row -> do
fmap (Just . map pFromSql) $ S.unsafeColumns stmt (map typeToSqlite types)
maybe (continue k) (\row -> k (Chunks [row]) >>== loop) x
Iteratee (runIteratee (iter step))
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 DbBlob = Just S.BlobColumn
typeToSqlite (DbMaybe _) = Nothing
typeToSqlite (DbList _) = Just S.IntegerColumn
typeToSqlite (DbTuple _ _) = Just S.IntegerColumn
typeToSqlite (DbEntity _) = Just S.IntegerColumn
getConstructorTypes :: ConstructorDef -> [DbType]
getConstructorTypes = map (getType.snd) . constrParams
firstRow :: Monad m => RowPopper m -> m (Maybe [PersistValue])
firstRow pop = pop >>= return
mapAllRows :: Monad m => ([PersistValue] -> m a) -> RowPopper m -> m [a]
mapAllRows f pop = go where
go = pop >>= maybe (return []) (f >=> \a -> liftM (a:) go)
pFromSql :: S.SQLData -> PersistValue
pFromSql (S.SQLInteger i) = PersistInt64 i
pFromSql (S.SQLFloat i) = PersistDouble i
pFromSql (S.SQLText s) = PersistString s
pFromSql (S.SQLBlob bs) = PersistByteString bs
pFromSql (S.SQLNull) = PersistNull
escape :: String -> String
escape s = '\"' : s ++ "\""
renderCond' :: (PersistEntity v, Constructor c) => Cond v c -> RenderS
renderCond' = renderCond escape constrId renderEquals renderNotEquals where
renderEquals :: (String -> String) -> Expr v c a -> Expr v c a -> RenderS
renderEquals esc a b = renderExpr esc a <> ((" IS " ++), id) <> renderExpr esc b
renderNotEquals :: (String -> String) -> Expr v c a -> Expr v c a -> RenderS
renderNotEquals esc a b = renderExpr esc a <> ((" IS NOT " ++), id) <> renderExpr esc b
isSimple :: [ConstructorDef] -> Bool
isSimple [_] = True
isSimple _ = False