persistent 0.1.0 → 0.2.0
raw patch · 8 files changed
+873/−262 lines, 8 filesdep +containersdep +enumeratordep +hamletdep −blaze-htmldep ~web-routes-quasi
Dependencies added: containers, enumerator, hamlet
Dependencies removed: blaze-html
Dependency ranges changed: web-routes-quasi
Files
- Database/Persist.hs +3/−0
- Database/Persist/Base.hs +93/−12
- Database/Persist/GenericSql.hs +448/−236
- Database/Persist/GenericSql/Internal.hs +127/−0
- Database/Persist/GenericSql/Raw.hs +52/−0
- Database/Persist/Quasi.hs +1/−0
- Database/Persist/TH.hs +141/−10
- persistent.cabal +8/−4
Database/Persist.hs view
@@ -4,6 +4,9 @@ , PersistBackend (..) , mkPersist , persist+ , selectList+ , insertBy+ , checkUnique ) where import Database.Persist.Base
Database/Persist/Base.hs view
@@ -22,6 +22,12 @@ , PersistFilter (..) , PersistOrder (..) , SomePersistField (..)+ , selectList+ , insertBy+ , checkUnique+ , DeleteCascade (..)+ , deleteCascadeWhere+ , PersistException (..) ) where import Language.Haskell.TH.Syntax@@ -31,10 +37,12 @@ import Control.Applicative import Data.Typeable (Typeable) import Data.Int (Int64)-import Text.Blaze+import Text.Hamlet import qualified Data.Text as T import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L+import Data.Enumerator+import qualified Control.Exception as E -- | A raw value which can be stored in any backend and can be marshalled to -- and from a 'PersistField'.@@ -94,7 +102,7 @@ fromPersistValue = fmap T.pack . fromPersistValue sqlType _ = SqlString -instance PersistField (Html ()) where+instance PersistField Html where toPersistValue = PersistByteString . S.concat . L.toChunks . renderHtml fromPersistValue = fmap unsafeByteString . fromPersistValue sqlType _ = SqlString@@ -202,8 +210,7 @@ persistFilterToFieldName :: Filter val -> String persistFilterToFilter :: Filter val -> PersistFilter- persistFilterIsNull :: Filter val -> Bool- persistFilterToValue :: Filter val -> PersistValue+ persistFilterToValue :: Filter val -> Either PersistValue [PersistValue] persistOrderToFieldName :: Order val -> String persistOrderToOrder :: Order val -> PersistOrder@@ -213,6 +220,7 @@ persistUniqueToFieldNames :: Unique val -> [String] persistUniqueToValues :: Unique val -> [PersistValue]+ persistUniqueKeys :: val -> [Unique val] data SomePersistField = forall a. PersistField a => SomePersistField a instance PersistField SomePersistField where@@ -220,12 +228,7 @@ fromPersistValue x = fmap SomePersistField (fromPersistValue x :: Either String String) sqlType (SomePersistField a) = sqlType a -class PersistBackend m where- -- | Prepare database for this entity, if necessary. In SQL, this creates- -- values and indices if they don't exist. The first argument is not used,- -- so you can used 'undefined'.- initialize :: PersistEntity val => val -> m ()-+class Monad m => PersistBackend m where -- | Create a new record in the database, returning the newly created -- identifier. insert :: PersistEntity val => val -> m (Key val)@@ -259,8 +262,64 @@ -- | Get all records matching the given criterion in the specified order. -- Returns also the identifiers.- select :: PersistEntity val => [Filter val] -> [Order val]+ select :: PersistEntity val+ => [Filter val]+ -> [Order val]+ -> Int -- ^ limit+ -> Int -- ^ offset+ -> Enumerator (Key val, val) m a++ -- | Get the 'Key's of all records matching the given criterion.+ selectKeys :: PersistEntity val+ => [Filter val]+ -> Enumerator (Key val) m a++ -- | The total number of records fulfilling the given criterion.+ count :: PersistEntity val => [Filter val] -> m Int++-- | Try to insert the given entity; if another entity exists with the same+-- unique key, return that entity; otherwise, return the newly created entity.+insertBy :: (PersistEntity val, PersistBackend m) => val -> m (Key val, val)+insertBy val =+ go $ persistUniqueKeys val+ where+ go [] = do+ key <- insert val+ return (key, val)+ go (x:xs) = do+ y <- getBy x+ case y of+ Nothing -> go xs+ Just z -> return z++-- | Check whether there are any conflicts for unique keys with this entity and+-- existing entities in the database.+--+-- Returns 'True' if the entity would be unique, and could thus safely be+-- 'insert'ed; returns 'False' on a conflict.+checkUnique :: (PersistEntity val, PersistBackend m) => val -> m Bool+checkUnique val =+ go $ persistUniqueKeys val+ where+ go [] = return True+ go (x:xs) = do+ y <- getBy x+ case y of+ Nothing -> go xs+ Just _ -> return False++-- | Call 'select' but return the result as a list.+selectList :: (PersistEntity val, PersistBackend m, Monad m)+ => [Filter val]+ -> [Order val]+ -> Int -- ^ limit+ -> Int -- ^ offset -> m [(Key val, val)]+selectList a b c d = do+ res <- run $ select a b c d ==<< consume+ case res of+ Left e -> error $ show e+ Right x -> return x data EntityDef = EntityDef { entityName :: String@@ -281,7 +340,7 @@ e' <- lift e return $ x `AppE` a' `AppE` b' `AppE` c' `AppE` d' `AppE` e' -data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le+data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le | In | NotIn deriving (Read, Show) instance Lift PersistFilter where@@ -291,6 +350,8 @@ lift Lt = [|Lt|] lift Ge = [|Ge|] lift Le = [|Le|]+ lift In = [|In|]+ lift NotIn = [|NotIn|] data PersistOrder = Asc | Desc deriving (Read, Show)@@ -298,3 +359,23 @@ instance Lift PersistOrder where lift Asc = [|Asc|] lift Desc = [|Desc|]++class PersistEntity a => DeleteCascade a where+ deleteCascade :: PersistBackend m => Key a -> m ()++deleteCascadeWhere :: (DeleteCascade a, PersistBackend m)+ => [Filter a] -> m ()+deleteCascadeWhere filts = do+ res <- run $ selectKeys filts $ Continue iter+ case res of+ Left e -> error $ show e+ Right () -> return ()+ where+ iter EOF = Iteratee $ return $ Yield () EOF+ iter (Chunks keys) = Iteratee $ do+ mapM_ deleteCascade keys+ return $ Continue iter++data PersistException = PersistMarshalException String+ deriving (Show, Typeable)+instance E.Exception PersistException
Database/Persist/GenericSql.hs view
@@ -1,278 +1,490 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PackageImports #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- | This is a helper module for creating SQL backends. Regular users do not -- need to use this module. module Database.Persist.GenericSql- ( GenericSql (..)- , RowPopper- , initialize- , insert- , get- , replace- , select- , deleteWhere- , update- , updateWhere- , getBy- , delete- , deleteBy+ ( SqlPersist (..)+ , Connection+ , ConnectionPool+ , Statement+ , runSqlConn+ , runSqlPool+ , Migration+ , parseMigration+ , parseMigration'+ , printMigration+ , getMigration+ , runMigration+ , runMigrationUnsafe+ , migrate ) where -import Database.Persist.Base hiding (PersistBackend (..))+import Database.Persist.Base import Data.List (intercalate)-import Control.Monad (unless, liftM)-import Data.Int (Int64)-import Control.Arrow (second)+import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class (MonadTrans (..))+import Database.Persist.Pool+import Control.Monad.Trans.Writer+import System.IO+import Database.Persist.GenericSql.Internal+import qualified Database.Persist.GenericSql.Raw as R+import Database.Persist.GenericSql.Raw (SqlPersist (..))+import "MonadCatchIO-transformers" Control.Monad.CatchIO+import Control.Monad (liftM)+import Data.Enumerator hiding (map, length) -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 ConnectionPool = Pool Connection -type RowPopper m = m (Maybe [PersistValue])+withStmt' :: MonadCatchIO m => String -> [PersistValue]+ -> (RowPopper (SqlPersist m) -> SqlPersist m a) -> SqlPersist m a+withStmt' = R.withStmt -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 []+execute' :: MonadIO m => String -> [PersistValue] -> SqlPersist m ()+execute' = R.execute -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+runSqlPool :: MonadCatchIO m => SqlPersist m a -> Pool Connection -> m a+runSqlPool r pconn = withPool' pconn $ runSqlConn r -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+runSqlConn :: MonadCatchIO m => SqlPersist m a -> Connection -> m a+runSqlConn (SqlPersist r) conn = do+ let getter = R.getStmt' conn+ liftIO $ begin conn getter+ x <- onException+ (runReaderT r conn)+ (liftIO $ rollback conn getter)+ liftIO $ commit conn getter+ return x -dummyFromKey :: Key v -> v-dummyFromKey _ = error "dummyFromKey"+instance MonadCatchIO m => PersistBackend (SqlPersist m) where+ insert val = do+ conn <- SqlPersist ask+ let esql = insertSql conn (rawTableName t) (map fst3 $ tableColumns t)+ i <-+ case esql of+ Left sql -> withStmt' sql vals $ \pop -> do+ Just [PersistInt64 i] <- pop+ return i+ Right (sql1, sql2) -> do+ execute' sql1 vals+ withStmt' sql2 [] $ \pop -> do+ Just [PersistInt64 i] <- pop+ return i+ return $ toPersistKey i+ where+ fst3 (x, _, _) = x+ t = entityDef val+ vals = map toPersistValue $ toPersistFields val -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"+ replace k val = do+ conn <- SqlPersist ask+ let t = entityDef val+ let sql = concat+ [ "UPDATE "+ , escapeName conn (rawTableName t)+ , " SET "+ , intercalate "," (map (go conn . fst3) $ tableColumns t)+ , " WHERE id=?"+ ]+ execute' sql $ map toPersistValue (toPersistFields val)+ ++ [PersistInt64 $ fromPersistKey k]+ where+ go conn x = escapeName conn x ++ "=?"+ fst3 (x, _, _) = x -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+ get k = do+ conn <- SqlPersist ask+ let t = entityDef $ dummyFromKey k+ let cols = intercalate ","+ $ map (\(x, _, _) -> escapeName conn x) $ tableColumns t+ let sql = concat+ [ "SELECT "+ , cols+ , " FROM "+ , escapeName conn $ rawTableName t+ , " WHERE id=?"+ ]+ withStmt' 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++ count filts = do+ conn <- SqlPersist ask+ let wher = if null filts+ then ""+ else " WHERE " +++ intercalate " AND " (map (filterClause conn) filts)+ let sql = concat+ [ "SELECT COUNT(*) FROM "+ , escapeName conn $ rawTableName t+ , wher+ ]+ withStmt' sql (getFiltsValues filts) $ \pop -> do+ Just [PersistInt64 i] <- pop+ return $ fromIntegral i+ where+ t = entityDef $ dummyFromFilts filts++ select filts ords limit offset =+ Iteratee . start+ where+ start x = do+ conn <- SqlPersist ask+ withStmt' (sql conn) (getFiltsValues filts) $ loop x+ loop (Continue k) pop = do+ res <- pop+ case res of+ Nothing -> return $ Continue k+ Just vals -> do+ case fromPersistValues' vals of+ Left s -> return $ Error $ toException+ $ PersistMarshalException s+ Right row -> do+ step <- runIteratee $ k $ Chunks [row]+ loop step pop+ loop step _ = return step+ t = entityDef $ dummyFromFilts filts+ orderClause conn o =+ escapeName conn (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'"+ wher conn = if null filts+ then ""+ else " WHERE " +++ intercalate " AND " (map (filterClause conn) filts)+ ord conn = if null ords+ then ""+ else " ORDER BY " +++ intercalate "," (map (orderClause conn) ords)+ lim conn = case (limit, offset) of+ (0, 0) -> ""+ (0, _) -> ' ' : noLimit conn+ (l, _) -> " LIMIT " ++ show limit+ off = if offset == 0+ then ""+ else " OFFSET " ++ show offset+ cols conn = intercalate "," $ "id"+ : (map (\(x, _, _) -> escapeName conn x) $ tableColumns t)+ sql conn = concat+ [ "SELECT "+ , cols conn+ , " FROM "+ , escapeName conn $ rawTableName t+ , wher conn+ , ord conn+ , lim conn+ , off+ ]+++ selectKeys filts =+ Iteratee . start+ where+ start x = do+ conn <- SqlPersist ask+ withStmt' (sql conn) (getFiltsValues filts) $ loop x+ loop (Continue k) pop = do+ res <- pop+ case res of+ Nothing -> return $ Continue k+ Just [PersistInt64 i] -> do+ step <- runIteratee $ k $ Chunks [toPersistKey i]+ loop step pop+ Just y -> return $ Error $ toException $ PersistMarshalException+ $ "Unexpected in selectKeys: " ++ show y+ loop step _ = return step+ t = entityDef $ dummyFromFilts filts+ wher conn = if null filts+ then ""+ else " WHERE " +++ intercalate " AND " (map (filterClause conn) filts)+ sql conn = concat+ [ "SELECT id FROM "+ , escapeName conn $ rawTableName t+ , wher conn+ ]++ delete k = do+ conn <- SqlPersist ask+ execute' (sql conn) [PersistInt64 $ fromPersistKey k]+ where+ t = entityDef $ dummyFromKey k+ sql conn = concat+ [ "DELETE FROM "+ , escapeName conn $ rawTableName t+ , " WHERE id=?"+ ]++ deleteWhere filts = do+ conn <- SqlPersist ask+ let t = entityDef $ dummyFromFilts filts+ let wher = if null filts+ then ""+ else " WHERE " +++ intercalate " AND " (map (filterClause conn) filts)+ sql = concat+ [ "DELETE FROM "+ , escapeName conn $ rawTableName t+ , wher+ ]+ execute' sql $ getFiltsValues filts++ deleteBy uniq = do+ conn <- SqlPersist ask+ execute' (sql conn) $ persistUniqueToValues uniq+ where+ t = entityDef $ dummyFromUnique uniq+ go = map (getFieldName t) . persistUniqueToFieldNames+ go' conn x = escapeName conn x ++ "=?"+ sql conn = concat+ [ "DELETE FROM "+ , escapeName conn $ rawTableName t+ , " WHERE "+ , intercalate " AND " $ map (go' conn) $ go uniq+ ]++ update _ [] = return ()+ update k upds = do+ conn <- SqlPersist ask+ let go' x = escapeName conn x ++ "=?"+ let sql = concat+ [ "UPDATE "+ , escapeName conn $ rawTableName t+ , " SET "+ , intercalate "," $ map (go' . go) upds+ , " WHERE id=?"+ ]+ execute' sql $+ map persistUpdateToValue upds ++ [PersistInt64 $ fromPersistKey k]+ where+ t = entityDef $ dummyFromKey k+ go = getFieldName t . persistUpdateToFieldName++ updateWhere _ [] = return ()+ updateWhere filts upds = do+ conn <- SqlPersist ask+ let wher = if null filts+ then ""+ else " WHERE " +++ intercalate " AND " (map (filterClause conn) filts)+ let sql = concat+ [ "UPDATE "+ , escapeName conn $ rawTableName t+ , " SET "+ , intercalate "," $ map (go' conn . go) upds+ , wher+ ]+ let dat = map persistUpdateToValue upds ++ getFiltsValues filts+ execute' sql dat+ where+ t = entityDef $ dummyFromFilts filts+ go = getFieldName t . persistUpdateToFieldName+ go' conn x = escapeName conn x ++ "=?"++ getBy uniq = do+ conn <- SqlPersist ask+ let cols = intercalate "," $ "id"+ : (map (\(x, _, _) -> escapeName conn x) $ tableColumns t)+ let sql = concat+ [ "SELECT "+ , cols+ , " FROM "+ , escapeName conn $ rawTableName t+ , " WHERE "+ , sqlClause conn+ ]+ withStmt' sql (persistUniqueToValues uniq) $ \pop -> do+ row <- pop+ case row of+ Nothing -> return Nothing+ Just (PersistInt64 k:vals) ->+ case fromPersistValues vals of+ Left s -> error s+ Right x -> return $ Just (toPersistKey k, x)+ Just _ -> error "Database.Persist.GenericSql: Bad list in getBy"+ where+ sqlClause conn =+ intercalate " AND " $ map (go conn) $ toFieldNames' uniq+ go conn x = escapeName conn x ++ "=?"+ t = entityDef $ dummyFromUnique uniq+ toFieldNames' = map (getFieldName t) . persistUniqueToFieldNames++dummyFromUnique :: Unique v -> v+dummyFromUnique _ = error "dummyFromUnique"++getFieldName :: EntityDef -> String -> RawName+getFieldName t s = rawFieldName $ tableColumn t s++tableColumn :: EntityDef -> String -> (String, String, [String])+tableColumn t s = go $ entityColumns t 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 -- FIXME error?- Right row -> go pop $ front . (:) row+ go [] = error $ "Unknown table column: " ++ s+ go ((x, y, z):rest)+ | x == s = (x, y, z)+ | otherwise = go rest -filterClause :: PersistEntity val => Filter val -> String-filterClause f = if persistFilterIsNull f then nullClause else mainClause+dummyFromKey :: Key v -> v+dummyFromKey _ = error "dummyFromKey"++filterClause :: PersistEntity val => Connection -> Filter val -> String+filterClause conn f =+ case (isNull, persistFilterToFilter f, varCount) of+ (True, Eq, _) -> name ++ " IS NULL"+ (True, Ne, _) -> name ++ " IS NOT NULL"+ (False, Ne, _) -> concat+ [ "("+ , name+ , " IS NULL OR "+ , name+ , "<>?)"+ ]+ -- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since+ -- not all databases support those words directly.+ (_, In, 0) -> "1=2"+ (False, In, _) -> name ++ " IN " ++ qmarks+ (True, In, _) -> concat+ [ "("+ , name+ , " IS NULL OR "+ , name+ , " IN "+ , qmarks+ , ")"+ ]+ (_, NotIn, 0) -> "1=1"+ (False, NotIn, _) -> concat+ [ "("+ , name+ , " IS NULL OR "+ , name+ , " NOT IN "+ , qmarks+ , ")"+ ]+ (True, NotIn, _) -> concat+ [ "("+ , name+ , " IS NOT NULL AND "+ , name+ , " NOT IN "+ , qmarks+ , ")"+ ]+ _ -> name ++ showSqlFilter (persistFilterToFilter f) ++ "?" where+ isNull = any (== PersistNull)+ $ either return id+ $ persistFilterToValue f 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+ name = escapeName conn $ getFieldName t $ persistFilterToFieldName f+ qmarks = case persistFilterToValue f of+ Left _ -> "?"+ Right x ->+ let x' = filter (/= PersistNull) x+ in '(' : intercalate "," (map (const "?") x') ++ ")"+ varCount = case persistFilterToValue f of+ Left _ -> 1+ Right x -> length x 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=?"+ showSqlFilter In = " IN "+ showSqlFilter NotIn = " NOT IN " 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)+type Sql = String -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+-- Bool indicates if the Sql is safe+type CautiousMigration = [(Bool, Sql)]+allSql :: CautiousMigration -> [Sql]+allSql = map snd+unsafeSql :: CautiousMigration -> [Sql]+unsafeSql = allSql . filter fst+safeSql :: CautiousMigration -> [Sql]+safeSql = allSql . filter (not . fst) -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+type Migration m = WriterT [String] (WriterT CautiousMigration m) () -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"+parseMigration :: Monad m => Migration m -> m (Either [String] CautiousMigration)+parseMigration =+ liftM go . runWriterT . execWriterT where- sqlClause = intercalate " AND " $ map (++ "=?") $ toFieldNames' uniq- t = entityDef $ dummyFromUnique uniq- toFieldNames' = map (getFieldName t) . persistUniqueToFieldNames+ go ([], sql) = Right sql+ go (errs, _) = Left errs -dummyFromUnique :: Unique v -> v-dummyFromUnique _ = error "dummyFromUnique"+-- like parseMigration, but call error or return the CautiousMigration+parseMigration' :: Monad m => Migration m -> m (CautiousMigration)+parseMigration' m = do+ x <- parseMigration m+ case x of+ Left errs -> error $ unlines errs+ Right sql -> return sql -tableName :: EntityDef -> String-tableName t =- case getSqlValue $ entityAttribs t of- Nothing -> "tbl" ++ entityName t- Just x -> x+printMigration :: MonadCatchIO m => Migration (SqlPersist m) -> SqlPersist m ()+printMigration m = do+ mig <- parseMigration' m+ mapM_ (liftIO . putStrLn) (allSql mig) -toField :: (String, String, [String]) -> String-toField (n, _, as) =- case getSqlValue as of- Just x -> x- Nothing -> "fld" ++ n+getMigration :: MonadCatchIO m => Migration (SqlPersist m) -> SqlPersist m [Sql]+getMigration m = do+ mig <- parseMigration' m+ return $ allSql mig -getFieldName :: EntityDef -> String -> String-getFieldName t s = toField $ tableColumn t s+runMigration :: MonadCatchIO m+ => Migration (SqlPersist m)+ -> SqlPersist m ()+runMigration m = do+ mig <- parseMigration' m+ case unsafeSql mig of+ [] -> mapM_ executeMigrate $ safeSql mig+ errs -> error $ concat+ [ "\n\nDatabase migration: manual intervention required.\n"+ , "The following actions are considered unsafe:\n\n"+ , unlines $ map (" " ++) $ errs+ ] -getSqlValue :: [String] -> Maybe String-getSqlValue (('s':'q':'l':'=':x):_) = Just x-getSqlValue (_:x) = getSqlValue x-getSqlValue [] = Nothing+runMigrationUnsafe :: MonadCatchIO m+ => Migration (SqlPersist m)+ -> SqlPersist m ()+runMigrationUnsafe m = do+ mig <- parseMigration' m+ mapM_ executeMigrate $ allSql mig -tableColumns :: EntityDef -> [(String, String, [String])]-tableColumns = map (\a@(x, y, z) -> (toField a, y, z)) . entityColumns+executeMigrate :: MonadIO m => String -> SqlPersist m ()+executeMigrate s = do+ liftIO $ hPutStrLn stderr $ "Migrating: " ++ s+ execute' s [] -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+migrate :: (MonadCatchIO m, PersistEntity val)+ => val+ -> Migration (SqlPersist m)+migrate val = do+ conn <- lift $ lift $ SqlPersist ask+ let getter = R.getStmt' conn+ res <- liftIO $ migrateSql conn getter val+ either tell (lift . tell) res -tableUniques' :: EntityDef -> [(String, [String])]-tableUniques' t = map (second $ map $ getFieldName t) $ entityUniques t+getFiltsValues :: PersistEntity val => [Filter val] -> [PersistValue]+getFiltsValues =+ concatMap $ go . persistFilterToValue+ where+ go (Left PersistNull) = []+ go (Left x) = [x]+ go (Right xs) = filter (/= PersistNull) xs
+ Database/Persist/GenericSql/Internal.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PackageImports #-}+-- | Code that is only needed for writing GenericSql backends.+module Database.Persist.GenericSql.Internal+ ( Connection (..)+ , Statement (..)+ , withSqlConn+ , withSqlPool+ , RowPopper+ , mkColumns+ , Column (..)+ , UniqueDef+ , refName+ , tableColumns+ , rawFieldName+ , rawTableName+ , RawName (..)+ ) where++import "MonadCatchIO-transformers" Control.Monad.CatchIO+import qualified Data.Map as Map+import Data.IORef+import Control.Monad.IO.Class+import Database.Persist.Pool+import Database.Persist.Base+import Data.Maybe (fromJust)+import Control.Arrow++type RowPopper m = m (Maybe [PersistValue])++data Connection = Connection+ { prepare :: String -> IO Statement+ , insertSql :: RawName -> [RawName] -> Either String (String, String)+ , stmtMap :: IORef (Map.Map String Statement)+ , close :: IO ()+ , migrateSql :: forall v. PersistEntity v+ => (String -> IO Statement) -> v+ -> IO (Either [String] [(Bool, String)])+ , begin :: (String -> IO Statement) -> IO ()+ , commit :: (String -> IO Statement) -> IO ()+ , rollback :: (String -> IO Statement) -> IO ()+ , escapeName :: RawName -> String+ , noLimit :: String+ }+data Statement = Statement+ { finalize :: IO ()+ , reset :: IO ()+ , execute :: [PersistValue] -> IO ()+ , withStmt :: forall a m. MonadCatchIO m+ => [PersistValue] -> (RowPopper m -> m a) -> m a+ }++withSqlPool :: MonadCatchIO m+ => IO Connection -> Int -> (Pool Connection -> m a) -> m a+withSqlPool mkConn = createPool mkConn close'++withSqlConn :: MonadCatchIO m => IO Connection -> (Connection -> m a) -> m a+withSqlConn open = bracket (liftIO open) (liftIO . close')++close' :: Connection -> IO ()+close' conn = do+ readIORef (stmtMap conn) >>= mapM_ finalize . Map.elems+ close conn++-- | Create the list of columns for the given entity.+mkColumns :: PersistEntity val => val -> ([Column], [UniqueDef])+mkColumns val =+ (cols, uniqs)+ where+ colNameMap = map ((\(x, _, _) -> x) &&& rawFieldName) $ entityColumns t+ uniqs = map (RawName *** map (fromJust . flip lookup colNameMap))+ $ entityUniques t -- FIXME don't use fromJust+ cols = zipWith go (tableColumns t) $ toPersistFields $ halfDefined `asTypeOf` val+ t = entityDef val+ tn = rawTableName t+ go (name, t', as) p =+ Column name ("null" `elem` as) (sqlType p) (def as) (ref name t' as)+ def [] = Nothing+ def (('d':'e':'f':'a':'u':'l':'t':'=':d):_) = Just d+ def (_:rest) = def rest+ ref c t' [] =+ let l = length t'+ (f, b) = splitAt (l - 2) t'+ in if b == "Id"+ then Just (RawName f, refName tn c)+ else Nothing+ ref _ _ ("noreference":_) = Nothing+ ref c _ (('r':'e':'f':'e':'r':'e':'n':'c':'e':'=':x):_) =+ Just (RawName x, refName tn c)+ ref c x (_:y) = ref c x y++refName :: RawName -> RawName -> RawName+refName (RawName table) (RawName column) =+ RawName $ table ++ '_' : column ++ "_fkey"++data Column = Column+ { cName :: RawName+ , cNull :: Bool+ , cType :: SqlType+ , cDefault :: Maybe String+ , cReference :: (Maybe (RawName, RawName)) -- table name, constraint name+ }++getSqlValue :: [String] -> Maybe String+getSqlValue (('s':'q':'l':'=':x):_) = Just x+getSqlValue (_:x) = getSqlValue x+getSqlValue [] = Nothing++tableColumns :: EntityDef -> [(RawName, String, [String])]+tableColumns = map (\a@(_, y, z) -> (rawFieldName a, y, z)) . entityColumns++type UniqueDef = (RawName, [RawName])++rawFieldName :: (String, String, [String]) -> RawName+rawFieldName (n, _, as) = RawName $+ case getSqlValue as of+ Just x -> x+ Nothing -> n++rawTableName :: EntityDef -> RawName+rawTableName t = RawName $+ case getSqlValue $ entityAttribs t of+ Nothing -> entityName t+ Just x -> x++newtype RawName = RawName { unRawName :: String }+ deriving (Eq, Ord)
+ Database/Persist/GenericSql/Raw.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Database.Persist.GenericSql.Raw+ ( withStmt+ , execute+ , SqlPersist (..)+ , getStmt'+ , getStmt+ ) where++import qualified Database.Persist.GenericSql.Internal as I+import Database.Persist.GenericSql.Internal hiding (execute, withStmt)+import Database.Persist.Base (PersistValue)+import Data.IORef+import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import qualified Data.Map as Map+import Control.Applicative (Applicative)+import Control.Monad.Trans.Class (MonadTrans (..))+import "MonadCatchIO-transformers" Control.Monad.CatchIO++newtype SqlPersist m a = SqlPersist (ReaderT Connection m a)+ deriving (Monad, MonadIO, MonadCatchIO, MonadTrans, Functor, Applicative)++withStmt :: MonadCatchIO m => String -> [PersistValue]+ -> (RowPopper (SqlPersist m) -> SqlPersist m a) -> SqlPersist m a+withStmt sql vals pop = do+ stmt <- getStmt sql+ ret <- I.withStmt stmt vals pop+ liftIO $ reset stmt+ return ret++execute :: MonadIO m => String -> [PersistValue] -> SqlPersist m ()+execute sql vals = do+ stmt <- getStmt sql+ liftIO $ I.execute stmt vals+ liftIO $ reset stmt++getStmt :: MonadIO m => String -> SqlPersist m Statement+getStmt sql = do+ conn <- SqlPersist ask+ liftIO $ getStmt' conn sql++getStmt' :: Connection -> String -> IO Statement+getStmt' conn sql = do+ smap <- liftIO $ readIORef $ stmtMap conn+ case Map.lookup sql smap of+ Just stmt -> return stmt+ Nothing -> do+ stmt <- liftIO $ prepare conn sql+ liftIO $ writeIORef (stmtMap conn) $ Map.insert sql stmt smap+ return stmt
Database/Persist/Quasi.hs view
@@ -51,6 +51,7 @@ nest ((False, name:entattribs):rest) = let (x, y) = break (not . fst) rest in (name, entattribs, map snd x) : nest y+nest ((False, []):_) = error "Indented line must contain at least name" nest ((True, _):_) = error "Blocks must begin with non-indented lines" nest [] = []
Database/Persist/TH.hs view
@@ -2,7 +2,12 @@ {-# LANGUAGE ExistentialQuantification #-} -- | This module provides utilities for creating backends. Regular users do not -- need to use this module.-module Database.Persist.TH (mkPersist) where+module Database.Persist.TH+ ( mkPersist+ , share2+ , mkSave+ , mkDeleteCascade+ ) where import Database.Persist.Base import Language.Haskell.TH.Syntax@@ -10,6 +15,7 @@ import Data.Maybe (mapMaybe, catMaybes) import Web.Routes.Quasi (SinglePiece) import Data.Int (Int64)+import Control.Monad (forM) -- | Create data types and appropriate 'PersistEntity' instances for the given -- 'EntityDef's. Works well with the persist quasi-quoter.@@ -64,10 +70,25 @@ (x, _):_ -> Just x [] -> Nothing +isFilterList :: PersistFilter -> Bool+isFilterList In = True+isFilterList NotIn = True+isFilterList _ = False+ mkFilter :: String -> (String, String, Bool, PersistFilter) -> Con mkFilter x (s, ty, isNull', filt) =- NormalC (mkName $ x ++ upperFirst s ++ show filt)- [(NotStrict, pairToType (ty, isNull'))]+ NormalC (mkName $ x ++ upperFirst s ++ show filt) [(NotStrict, ty'')]+ where+ ty' = pairToType (ty, isNull' && isNullableFilter filt)+ ty'' = if isFilterList filt then ListT `AppT` ty' else ty'+ isNullableFilter Eq = True+ isNullableFilter Ne = True+ isNullableFilter In = True+ isNullableFilter NotIn = True+ isNullableFilter Lt = False+ isNullableFilter Le = False+ isNullableFilter Gt = False+ isNullableFilter Ge = False updateTypeDec :: EntityDef -> Dec updateTypeDec t =@@ -191,10 +212,9 @@ mkToFilter :: [(String, PersistFilter, Bool)] -> Q [Dec] mkToFilter pairs = do c1 <- mapM go pairs- let c2 = concatMap go' pairs+ let _FIXMEc2 = concatMap go' pairs return [ FunD (mkName "persistFilterToFilter") $ degen c1- , FunD (mkName "persistFilterIsNull") $ degen c2 ] where go (constr, pf, _) = do@@ -219,12 +239,26 @@ (NormalB $ VarE (mkName "toPersistValue") `AppE` VarE x) [] +mkToFiltValue :: String -> [(String, Bool)] -> Q Dec+mkToFiltValue func pairs = do+ left <- [|Left . toPersistValue|]+ right <- [|Right . map toPersistValue|]+ clauses <- mapM (go left right) pairs+ return . FunD (mkName func) . degen $ clauses+ where+ go left right (constr, isList) = do+ x <- newName "x"+ return+ $ Clause [ConP (mkName constr) [VarP x]]+ (NormalB $ (if isList then right else left) `AppE` VarE x)+ []+ mkHalfDefined :: String -> Int -> Dec-mkHalfDefined constr count =+mkHalfDefined constr count' = FunD (mkName "halfDefined") [Clause [] (NormalB $ foldl AppE (ConE $ mkName constr)- (replicate count $ VarE $ mkName "undefined")) []]+ (replicate count' $ VarE $ mkName "undefined")) []] apE :: Either x (y -> z) -> Either x y -> Either x z apE (Left x) _ = Left x@@ -261,10 +295,15 @@ show' <- [|show|] entityOrders' <- entityOrders t otd <- orderTypeDec t+ puk <- mkUniqueKeys t tf <- mkToFilter (map (\(x, _, z, y) -> (name ++ upperFirst x ++ show y, y, z)) $ entityFilters t)+ ftv <- mkToFiltValue "persistFilterToValue"+ $ map (\(x, _, _, y) ->+ (name ++ upperFirst x ++ show y, isFilterList y))+ $ entityFilters t return [ dataTypeDec t , TySynD (mkName $ entityName t ++ "Id") [] $@@ -297,10 +336,102 @@ , mkToFieldName "persistFilterToFieldName" $ map (\(x, _, _, y) -> (name ++ upperFirst x ++ show y, x)) $ entityFilters t- , mkToValue "persistFilterToValue"- $ map (\(x, _, _, y) -> name ++ upperFirst x ++ show y)- $ entityFilters t+ , ftv , mkToFieldNames $ entityUniques t , utv+ , puk ] ++ tf ]++share2 :: ([EntityDef] -> Q [Dec])+ -> ([EntityDef] -> Q [Dec])+ -> [EntityDef]+ -> Q [Dec]+share2 f g x = do+ y <- f x+ z <- g x+ return $ y ++ z++mkSave :: String -> [EntityDef] -> Q [Dec]+mkSave name' defs' = do+ let name = mkName name'+ defs <- lift defs'+ return [ SigD name $ ListT `AppT` ConT ''EntityDef+ , FunD name [Clause [] (NormalB defs) []]+ ]++data Dep = Dep+ { depTarget :: String+ , depSourceTable :: String+ , depSourceField :: String+ , depSourceNull :: Bool+ }++mkDeleteCascade :: [EntityDef] -> Q [Dec]+mkDeleteCascade defs = do+ let deps = concatMap getDeps defs+ mapM (go deps) defs+ where+ getDeps :: EntityDef -> [Dep]+ getDeps def =+ concatMap getDeps' $ entityColumns def+ where+ getDeps' (name, typ, attribs) =+ let isNull = "null" `elem` attribs+ l = length typ+ (f, b) = splitAt (l - 2) typ+ in if b == "Id"+ then return Dep+ { depTarget = f+ , depSourceTable = entityName def+ , depSourceField = name+ , depSourceNull = isNull+ }+ else []+ go :: [Dep] -> EntityDef -> Q Dec+ go allDeps EntityDef{entityName = name} = do+ let deps = filter (\x -> depTarget x == name) allDeps+ key <- newName "key"+ del <- [|delete|]+ dcw <- [|deleteCascadeWhere|]+ just <- [|Just|]+ let mkStmt dep = NoBindS+ $ dcw `AppE`+ ListE+ [ ConE (mkName filtName) `AppE` val (depSourceNull dep)+ ]+ where+ filtName =+ depSourceTable dep ++ upperFirst (depSourceField dep)+ ++ "Eq"+ val False = VarE key+ val True = just `AppE` VarE key++++ let stmts = map mkStmt deps ++ [NoBindS $ del `AppE` VarE key]+ return $+ InstanceD+ []+ (ConT ''DeleteCascade `AppT` ConT (mkName name))+ [ FunD (mkName "deleteCascade")+ [Clause [VarP key] (NormalB $ DoE stmts) []]+ ]++mkUniqueKeys :: EntityDef -> Q Dec+mkUniqueKeys def = do+ c <- clause+ return $ FunD (mkName "persistUniqueKeys") [c]+ where+ clause = do+ xs <- forM (entityColumns def) $ \(x, _, _) -> do+ x' <- newName $ '_' : x+ return (x, x')+ let pcs = map (go xs) $ entityUniques def+ let pat = ConP (mkName $ entityName def) $ map (VarP . snd) xs+ return $ Clause [pat] (NormalB $ ListE pcs) []+ go xs (name, cols) =+ foldl (go' xs) (ConE (mkName name)) cols+ go' xs front col =+ let Just col' = lookup col xs+ in front `AppE` VarE col'
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 0.1.0+version: 0.2.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -21,14 +21,18 @@ time >= 1.1.4 && < 1.3, utf8-string >= 0.3.4 && < 0.4, text >= 0.7.1 && < 0.8,- blaze-html >= 0.1 && < 0.2,- web-routes-quasi >= 0.5.0 && < 0.6,- parsec >= 2.1 && < 4+ hamlet >= 0.5 && < 0.6,+ web-routes-quasi >= 0.6.0 && < 0.7,+ containers >= 0.2 && < 0.4,+ parsec >= 2.1 && < 4,+ enumerator >= 0.4 && < 0.5 exposed-modules: Database.Persist Database.Persist.Base Database.Persist.TH Database.Persist.Quasi Database.Persist.GenericSql+ Database.Persist.GenericSql.Internal+ Database.Persist.GenericSql.Raw Database.Persist.Pool ghc-options: -Wall