module Database.Persist.GenericSql
( GenericSql (..)
, RowPopper
, initialize
, insert
, get
, replace
, select
, deleteWhere
, update
, updateWhere
, getBy
, delete
, deleteBy
) where
import Database.Persist.Base hiding (PersistBackend (..))
import Data.List (intercalate)
import Control.Monad (unless, liftM)
import Data.Int (Int64)
import Control.Arrow (second)
data GenericSql m = GenericSql
{ gsWithStmt :: forall a.
String -> [PersistValue] -> (RowPopper m -> m a) -> m a
, gsExecute :: String -> [PersistValue] -> m ()
, gsInsert :: String -> [String] -> [PersistValue] -> m Int64
, gsEntityDefExists :: String -> m Bool
, gsKeyType :: String
, gsShowSqlType :: SqlType -> String
}
type RowPopper m = m (Maybe [PersistValue])
initialize :: (Monad m, PersistEntity v) => GenericSql m -> v -> m ()
initialize gs v = do
doesExist <- gsEntityDefExists gs $ tableName t
unless doesExist $ do
let cols = zip (tableColumns t) $ toPersistFields
$ halfDefined `asTypeOf` v
let sql = "CREATE TABLE " ++ tableName t ++
"(id " ++ gsKeyType gs ++
concatMap go' cols ++ ")"
gsExecute gs sql []
mapM_ go $ tableUniques' t
where
t = entityDef v
go' ((colName, _, as), p) = concat
[ ","
, colName
, " "
, gsShowSqlType gs $ sqlType p
, if "null" `elem` as then " NULL" else " NOT NULL"
]
go (index, fields) = do
let sql = "CREATE UNIQUE INDEX " ++ index ++ " ON " ++
tableName t ++ "(" ++ intercalate "," fields ++ ")"
gsExecute gs sql []
insert :: (Monad m, PersistEntity val)
=> GenericSql m -> val -> m (Key val)
insert gs v = liftM toPersistKey
. gsInsert gs (tableName t) (map fst3 $ tableColumns t)
. map toPersistValue . toPersistFields
$ v
where
fst3 (x, _, _) = x
t = entityDef v
replace :: (PersistEntity v, Monad m)
=> GenericSql m -> Key v -> v -> m ()
replace gs k val = do
let t = entityDef val
let sql = "UPDATE " ++ tableName t ++ " SET " ++
intercalate "," (map (go . fst3) $ tableColumns t) ++
" WHERE id=?"
gsExecute gs sql $
map toPersistValue (toPersistFields val)
++ [PersistInt64 $ fromPersistKey k]
where
go = (++ "=?")
fst3 (x, _, _) = x
dummyFromKey :: Key v -> v
dummyFromKey _ = error "dummyFromKey"
get :: (PersistEntity v, Monad m)
=> GenericSql m -> Key v -> m (Maybe v)
get gs k = do
let t = entityDef $ dummyFromKey k
let sql = "SELECT * FROM " ++ tableName t ++ " WHERE id=?"
gsWithStmt gs sql [PersistInt64 $ fromPersistKey k] $ \pop -> do
res <- pop
case res of
Nothing -> return Nothing
Just (_:vals) ->
case fromPersistValues vals of
Left e -> error $ "get " ++ showPersistKey k ++ ": " ++ e
Right v -> return $ Just v
Just [] -> error "Database.Persist.GenericSql: Empty list in get"
select :: (PersistEntity val, Monad m)
=> GenericSql m
-> [Filter val]
-> [Order val]
-> m [(Key val, val)]
select gs filts ords = do
let wher = if null filts
then ""
else " WHERE " ++
intercalate " AND " (map filterClause filts)
ord = if null ords
then ""
else " ORDER BY " ++
intercalate "," (map orderClause ords)
let sql = "SELECT * FROM " ++ tableName t ++ wher ++ ord
gsWithStmt gs sql (map persistFilterToValue filts) $ flip go id
where
t = entityDef $ dummyFromFilts filts
orderClause o = getFieldName t (persistOrderToFieldName o)
++ case persistOrderToOrder o of
Asc -> ""
Desc -> " DESC"
fromPersistValues' (PersistInt64 x:xs) = do
case fromPersistValues xs of
Left e -> Left e
Right xs' -> Right (toPersistKey x, xs')
fromPersistValues' _ = Left "error in fromPersistValues'"
go pop front = do
res <- pop
case res of
Nothing -> return $ front []
Just vals -> do
case fromPersistValues' vals of
Left _ -> go pop front
Right row -> go pop $ front . (:) row
filterClause :: PersistEntity val => Filter val -> String
filterClause f = if persistFilterIsNull f then nullClause else mainClause
where
t = entityDef $ dummyFromFilts [f]
name = getFieldName t $ persistFilterToFieldName f
mainClause = name ++ showSqlFilter (persistFilterToFilter f) ++ "?"
nullClause =
case persistFilterToFilter f of
Eq -> '(' : mainClause ++ " OR " ++ name ++ " IS NULL)"
Ne -> '(' : mainClause ++ " OR " ++ name ++ " IS NOT NULL)"
_ -> mainClause
showSqlFilter Eq = "="
showSqlFilter Ne = "<>"
showSqlFilter Gt = ">"
showSqlFilter Lt = "<"
showSqlFilter Ge = ">="
showSqlFilter Le = "<="
delete :: (PersistEntity v, Monad m) => GenericSql m -> Key v -> m ()
delete gs k =
gsExecute gs sql [PersistInt64 $ fromPersistKey k]
where
t = entityDef $ dummyFromKey k
sql = "DELETE FROM " ++ tableName t ++ " WHERE id=?"
dummyFromFilts :: [Filter v] -> v
dummyFromFilts _ = error "dummyFromFilts"
deleteWhere :: (PersistEntity v, Monad m)
=> GenericSql m -> [Filter v] -> m ()
deleteWhere gs filts = do
let t = entityDef $ dummyFromFilts filts
let wher = if null filts
then ""
else " WHERE " ++
intercalate " AND " (map filterClause filts)
sql = "DELETE FROM " ++ tableName t ++ wher
gsExecute gs sql $ map persistFilterToValue filts
deleteBy :: (PersistEntity v, Monad m) => GenericSql m -> Unique v -> m ()
deleteBy gs uniq =
gsExecute gs sql $ persistUniqueToValues uniq
where
t = entityDef $ dummyFromUnique uniq
go = map (getFieldName t) . persistUniqueToFieldNames
sql = "DELETE FROM " ++ tableName t ++ " WHERE " ++
intercalate " AND " (map (++ "=?") $ go uniq)
update :: (PersistEntity v, Monad m)
=> GenericSql m -> Key v -> [Update v] -> m ()
update _ _ [] = return ()
update gs k upds = do
let sql = "UPDATE " ++ tableName t ++ " SET " ++
intercalate "," (map (++ "=?") $ map go upds) ++
" WHERE id=?"
gsExecute gs sql $
map persistUpdateToValue upds ++ [PersistInt64 $ fromPersistKey k]
where
t = entityDef $ dummyFromKey k
go = getFieldName t . persistUpdateToFieldName
updateWhere :: (PersistEntity v, Monad m)
=> GenericSql m -> [Filter v] -> [Update v] -> m ()
updateWhere _ _ [] = return ()
updateWhere gs filts upds = do
let wher = if null filts
then ""
else " WHERE " ++
intercalate " AND " (map filterClause filts)
let sql = "UPDATE " ++ tableName t ++ " SET " ++
intercalate "," (map (++ "=?") $ map go upds) ++ wher
let dat = map persistUpdateToValue upds
++ map persistFilterToValue filts
gsWithStmt gs sql dat $ const $ return ()
where
t = entityDef $ dummyFromFilts filts
go = getFieldName t . persistUpdateToFieldName
getBy :: (PersistEntity v, Monad m)
=> GenericSql m -> Unique v -> m (Maybe (Key v, v))
getBy gs uniq = do
let sql = "SELECT * FROM " ++ tableName t ++ " WHERE " ++ sqlClause
gsWithStmt gs sql (persistUniqueToValues uniq) $ \pop -> do
row <- pop
case row of
Nothing -> return Nothing
Just (PersistInt64 k:vals) ->
case fromPersistValues vals of
Left _ -> return Nothing
Right x -> return $ Just (toPersistKey k, x)
Just _ -> error "Database.Persist.GenericSql: Bad list in getBy"
where
sqlClause = intercalate " AND " $ map (++ "=?") $ toFieldNames' uniq
t = entityDef $ dummyFromUnique uniq
toFieldNames' = map (getFieldName t) . persistUniqueToFieldNames
dummyFromUnique :: Unique v -> v
dummyFromUnique _ = error "dummyFromUnique"
tableName :: EntityDef -> String
tableName t =
case getSqlValue $ entityAttribs t of
Nothing -> "tbl" ++ entityName t
Just x -> x
toField :: (String, String, [String]) -> String
toField (n, _, as) =
case getSqlValue as of
Just x -> x
Nothing -> "fld" ++ n
getFieldName :: EntityDef -> String -> String
getFieldName t s = toField $ tableColumn t s
getSqlValue :: [String] -> Maybe String
getSqlValue (('s':'q':'l':'=':x):_) = Just x
getSqlValue (_:x) = getSqlValue x
getSqlValue [] = Nothing
tableColumns :: EntityDef -> [(String, String, [String])]
tableColumns = map (\a@(x, y, z) -> (toField a, y, z)) . entityColumns
tableColumn :: EntityDef -> String -> (String, String, [String])
tableColumn t s = go $ entityColumns t
where
go [] = error $ "Unknown table column: " ++ s
go ((x, y, z):rest)
| x == s = (x, y, z)
| otherwise = go rest
tableUniques' :: EntityDef -> [(String, [String])]
tableUniques' t = map (second $ map $ getFieldName t) $ entityUniques t