persistent 0.4.2 → 0.5.0
raw patch · 12 files changed
+556/−835 lines, 12 filesdep +monad-controldep −hamletdep −monad-peeldep −neitherdep ~bytestringdep ~enumeratordep ~pool
Dependencies added: monad-control
Dependencies removed: hamlet, monad-peel, neither, stm, utf8-string
Dependency ranges changed: bytestring, enumerator, pool, template-haskell, text, web-routes-quasi
Files
- Database/Persist.hs +1/−4
- Database/Persist/Base.hs +60/−53
- Database/Persist/GenericSql.hs +53/−180
- Database/Persist/GenericSql/Internal.hs +135/−15
- Database/Persist/GenericSql/Raw.hs +7/−6
- Database/Persist/Join.hs +55/−0
- Database/Persist/Join/Sql.hs +98/−0
- Database/Persist/Quasi.hs +10/−26
- Database/Persist/TH.hs +0/−529
- Database/Persist/Util.hs +17/−0
- persistent.cabal +17/−20
- runtests.hs +103/−2
Database/Persist.hs view
@@ -2,13 +2,10 @@ ( PersistField (..) , PersistEntity (..) , PersistBackend (..)- , mkPersist- , persist , selectList , insertBy+ , getByValue , checkUnique ) where import Database.Persist.Base-import Database.Persist.TH-import Database.Persist.Quasi
Database/Persist/Base.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-} -- | This defines the API for performing database actions. There are two levels -- to this API: dealing with fields, and dealing with entities. In SQL, a field@@ -25,13 +25,13 @@ , SomePersistField (..) , selectList , insertBy+ , getByValue , checkUnique , DeleteCascade (..) , deleteCascadeWhere , PersistException (..) ) where -import Language.Haskell.TH.Syntax import Data.Time (Day, TimeOfDay, UTCTime) import Data.ByteString.Char8 (ByteString, unpack) import Control.Applicative@@ -43,7 +43,8 @@ import qualified Data.Text as T import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L-import Data.Enumerator+import Data.Enumerator hiding (consume)+import Data.Enumerator.List (consume) import qualified Control.Exception as E import Data.Bits (bitSize) import Control.Monad (liftM)@@ -53,7 +54,7 @@ -- | A raw value which can be stored in any backend and can be marshalled to -- and from a 'PersistField'.-data PersistValue = PersistString String+data PersistValue = PersistText T.Text | PersistByteString ByteString | PersistInt64 Int64 | PersistDouble Double@@ -62,14 +63,17 @@ | PersistTimeOfDay TimeOfDay | PersistUTCTime UTCTime | PersistNull- deriving (Show, Read, Eq, Typeable)+ | PersistList [PersistValue]+ | PersistMap [(T.Text, PersistValue)]+ | PersistForeignKey ByteString -- ^ intended especially for MongoDB backend+ deriving (Show, Read, Eq, Typeable, Ord) -- | A SQL data type. Naming attempts to reflect the underlying Haskell -- datatypes, eg SqlString instead of SqlVarchar. Different SQL databases may -- have different translations for these types. data SqlType = SqlString | SqlInt32- | SqlInteger -- ^ 8-byte integer; should be renamed SqlInt64+ | SqlInteger -- ^ FIXME 8-byte integer; should be renamed SqlInt64 | SqlReal | SqlBool | SqlDay@@ -87,8 +91,8 @@ isNullable _ = False instance PersistField String where- toPersistValue = PersistString- fromPersistValue (PersistString s) = Right s+ toPersistValue = PersistText . T.pack+ fromPersistValue (PersistText s) = Right $ T.unpack s fromPersistValue (PersistByteString bs) = Right $ T.unpack $ T.decodeUtf8With T.lenientDecode bs fromPersistValue (PersistInt64 i) = Right $ show i@@ -98,19 +102,32 @@ fromPersistValue (PersistUTCTime d) = Right $ show d fromPersistValue PersistNull = Left "Unexpected null" fromPersistValue (PersistBool b) = Right $ show b+ fromPersistValue (PersistList _) = Left "Cannot convert PersistList to String"+ fromPersistValue (PersistMap _) = Left "Cannot convert PersistMap to String"+ fromPersistValue (PersistForeignKey _) = Left "Cannot convert PersistForeignKey to String" sqlType _ = SqlString instance PersistField ByteString where toPersistValue = PersistByteString fromPersistValue (PersistByteString bs) = Right bs- fromPersistValue x = T.encodeUtf8 . T.pack <$> fromPersistValue x+ fromPersistValue x = T.encodeUtf8 <$> fromPersistValue x sqlType _ = SqlBlob instance PersistField T.Text where- toPersistValue = PersistString . T.unpack+ toPersistValue = PersistText+ fromPersistValue (PersistText s) = Right s fromPersistValue (PersistByteString bs) = Right $ T.decodeUtf8With T.lenientDecode bs- fromPersistValue v = fmap T.pack $ fromPersistValue v+ fromPersistValue (PersistInt64 i) = Right $ T.pack $ show i+ fromPersistValue (PersistDouble d) = Right $ T.pack $ show d+ fromPersistValue (PersistDay d) = Right $ T.pack $ show d+ fromPersistValue (PersistTimeOfDay d) = Right $ T.pack $ show d+ fromPersistValue (PersistUTCTime d) = Right $ T.pack $ show d+ fromPersistValue PersistNull = Left "Unexpected null"+ fromPersistValue (PersistBool b) = Right $ T.pack $ show b+ fromPersistValue (PersistList _) = Left "Cannot convert PersistList to Text"+ fromPersistValue (PersistMap _) = Left "Cannot convert PersistMap to Text"+ fromPersistValue (PersistForeignKey _) = Left "Cannot convert PersistForeignKey to Text" sqlType _ = SqlString instance PersistField Html where@@ -190,8 +207,8 @@ instance PersistField Day where toPersistValue = PersistDay fromPersistValue (PersistDay d) = Right d- fromPersistValue x@(PersistString s) =- case reads s of+ fromPersistValue x@(PersistText t) =+ case reads $ T.unpack t of (d, _):_ -> Right d _ -> Left $ "Expected Day, received " ++ show x fromPersistValue x@(PersistByteString s) =@@ -204,8 +221,8 @@ instance PersistField TimeOfDay where toPersistValue = PersistTimeOfDay fromPersistValue (PersistTimeOfDay d) = Right d- fromPersistValue x@(PersistString s) =- case reads s of+ fromPersistValue x@(PersistText t) =+ case reads $ T.unpack t of (d, _):_ -> Right d _ -> Left $ "Expected TimeOfDay, received " ++ show x fromPersistValue x@(PersistByteString s) =@@ -218,8 +235,8 @@ instance PersistField UTCTime where toPersistValue = PersistUTCTime fromPersistValue (PersistUTCTime d) = Right d- fromPersistValue x@(PersistString s) =- case reads s of+ fromPersistValue x@(PersistText t) =+ case reads $ T.unpack t of (d, _):_ -> Right d _ -> Left $ "Expected UTCTime, received " ++ show x fromPersistValue x@(PersistByteString s) =@@ -239,7 +256,7 @@ -- | A single database entity. For example, if writing a blog application, a -- blog entry would be an entry, containing fields such as title and content.-class PersistEntity val where+class Show (Key val) => PersistEntity val where -- | The unique identifier associated with this entity. In general, backends also define a type synonym for this, such that \"type MyEntityId = Key MyEntity\". data Key val -- | Fields which can be updated using the 'update' and 'updateWhere'@@ -259,9 +276,8 @@ toPersistFields :: val -> [SomePersistField] fromPersistValues :: [PersistValue] -> Either String val halfDefined :: val- toPersistKey :: Int64 -> Key val- fromPersistKey :: Key val -> Int64- showPersistKey :: Key val -> String+ toPersistKey :: PersistValue -> Key val+ fromPersistKey :: Key val -> PersistValue persistFilterToFieldName :: Filter val -> String persistFilterToFilter :: Filter val -> PersistFilter@@ -318,7 +334,8 @@ -- | Get all records matching the given criterion in the specified order. -- Returns also the identifiers.- select :: PersistEntity val+ selectEnum+ :: PersistEntity val => [Filter val] -> [Order val] -> Int -- ^ limit@@ -348,6 +365,22 @@ Nothing -> go xs Just z -> return $ Left z +-- | A modification of 'getBy', which takes the 'PersistEntity' itself instead+-- of a 'Unique' value. Returns a value matching /one/ of the unique keys. This+-- function makes the most sense on entities with a single 'Unique'+-- constructor.+getByValue :: (PersistEntity v, PersistBackend m)+ => v -> m (Maybe (Key v, v))+getByValue val =+ go $ persistUniqueKeys val+ where+ go [] = return Nothing+ go (x:xs) = do+ y <- getBy x+ case y of+ Nothing -> go xs+ Just z -> return $ Just z+ -- | Check whether there are any conflicts for unique keys with this entity and -- existing entities in the database. --@@ -372,7 +405,7 @@ -> Int -- ^ offset -> m [(Key val, val)] selectList a b c d = do- res <- run $ select a b c d ==<< consume+ res <- run $ selectEnum a b c d ==<< consume case res of Left e -> error $ show e Right x -> return x@@ -386,36 +419,12 @@ } deriving Show -instance Lift EntityDef where- lift (EntityDef a b c d e) = do- x <- [|EntityDef|]- a' <- lift a- b' <- lift b- c' <- lift c- d' <- lift d- e' <- lift e- return $ x `AppE` a' `AppE` b' `AppE` c' `AppE` d' `AppE` e'- data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le | In | NotIn deriving (Read, Show) -instance Lift PersistFilter where- lift Eq = [|Eq|]- lift Ne = [|Ne|]- lift Gt = [|Gt|]- lift Lt = [|Lt|]- lift Ge = [|Ge|]- lift Le = [|Le|]- lift In = [|In|]- lift NotIn = [|NotIn|]- data PersistOrder = Asc | Desc deriving (Read, Show) -instance Lift PersistOrder where- lift Asc = [|Asc|]- lift Desc = [|Desc|]- class PersistEntity a => DeleteCascade a where deleteCascade :: PersistBackend m => Key a -> m () @@ -439,9 +448,7 @@ data PersistUpdate = Update | Add | Subtract | Multiply | Divide deriving (Read, Show) -instance Lift PersistUpdate where- lift Update = [|Update|]- lift Add = [|Add|]- lift Subtract = [|Subtract|]- lift Multiply = [|Multiply|]- lift Divide = [|Divide|]+instance PersistField PersistValue where+ toPersistValue = id+ fromPersistValue = Right+ sqlType _ = SqlInteger -- since PersistValue should only be used like this for keys, which in SQL are Int64
Database/Persist/GenericSql.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PackageImports #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | This is a helper module for creating SQL backends. Regular users do not@@ -19,7 +18,6 @@ , runMigrationSilent , runMigrationUnsafe , migrate- , mkMigrate ) where import Database.Persist.Base@@ -35,24 +33,24 @@ import Database.Persist.GenericSql.Raw (SqlPersist (..)) import Control.Monad (liftM, unless) import Data.Enumerator (Stream (..), Iteratee (..), Step (..))-import Language.Haskell.TH.Syntax hiding (lift)-import Control.Monad.IO.Peel (MonadPeelIO)-import Control.Exception.Peel (onException)+import Control.Monad.IO.Control (MonadControlIO)+import Control.Exception.Control (onException) import Control.Exception (toException)+import Data.Text (Text, pack, unpack) type ConnectionPool = Pool Connection -withStmt' :: MonadPeelIO m => String -> [PersistValue]+withStmt' :: MonadControlIO m => Text -> [PersistValue] -> (RowPopper (SqlPersist m) -> SqlPersist m a) -> SqlPersist m a withStmt' = R.withStmt -execute' :: MonadIO m => String -> [PersistValue] -> SqlPersist m ()+execute' :: MonadIO m => Text -> [PersistValue] -> SqlPersist m () execute' = R.execute -runSqlPool :: MonadPeelIO m => SqlPersist m a -> Pool Connection -> m a+runSqlPool :: MonadControlIO m => SqlPersist m a -> Pool Connection -> m a runSqlPool r pconn = withPool' pconn $ runSqlConn r -runSqlConn :: MonadPeelIO m => SqlPersist m a -> Connection -> m a+runSqlConn :: MonadControlIO m => SqlPersist m a -> Connection -> m a runSqlConn (SqlPersist r) conn = do let getter = R.getStmt' conn liftIO $ begin conn getter@@ -62,19 +60,19 @@ liftIO $ commit conn getter return x -instance MonadPeelIO m => PersistBackend (SqlPersist m) where+instance MonadControlIO 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+ Just [i] <- pop return i Right (sql1, sql2) -> do execute' sql1 vals withStmt' sql2 [] $ \pop -> do- Just [PersistInt64 i] <- pop+ Just [i] <- pop return i return $ toPersistKey i where@@ -85,7 +83,7 @@ replace k val = do conn <- SqlPersist ask let t = entityDef val- let sql = concat+ let sql = pack $ concat [ "UPDATE " , escapeName conn (rawTableName t) , " SET "@@ -93,7 +91,7 @@ , " WHERE id=?" ] execute' sql $ map toPersistValue (toPersistFields val)- ++ [PersistInt64 $ fromPersistKey k]+ ++ [fromPersistKey k] where go conn x = escapeName conn x ++ "=?" fst3 (x, _, _) = x@@ -103,20 +101,20 @@ let t = entityDef $ dummyFromKey k let cols = intercalate "," $ map (\(x, _, _) -> escapeName conn x) $ tableColumns t- let sql = concat+ let sql = pack $ concat [ "SELECT " , cols , " FROM " , escapeName conn $ rawTableName t , " WHERE id=?" ]- withStmt' sql [PersistInt64 $ fromPersistKey k] $ \pop -> do+ withStmt' sql [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+ Left e -> error $ "get " ++ show k ++ ": " ++ e Right v -> return $ Just v count filts = do@@ -124,8 +122,8 @@ let wher = if null filts then "" else " WHERE " ++- intercalate " AND " (map (filterClause conn) filts)- let sql = concat+ intercalate " AND " (map (filterClause False conn) filts)+ let sql = pack $ concat [ "SELECT COUNT(*) FROM " , escapeName conn $ rawTableName t , wher@@ -136,7 +134,7 @@ where t = entityDef $ dummyFromFilts filts - select filts ords limit offset =+ selectEnum filts ords limit offset = Iteratee . start where start x = do@@ -155,12 +153,7 @@ 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+ fromPersistValues' (x:xs) = do case fromPersistValues xs of Left e -> Left e Right xs' -> Right (toPersistKey x, xs')@@ -168,11 +161,11 @@ wher conn = if null filts then "" else " WHERE " ++- intercalate " AND " (map (filterClause conn) filts)+ intercalate " AND " (map (filterClause False conn) filts) ord conn = if null ords then "" else " ORDER BY " ++- intercalate "," (map (orderClause conn) ords)+ intercalate "," (map (orderClause False conn) ords) lim conn = case (limit, offset) of (0, 0) -> "" (0, _) -> ' ' : noLimit conn@@ -182,7 +175,7 @@ else " OFFSET " ++ show offset cols conn = intercalate "," $ "id" : (map (\(x, _, _) -> escapeName conn x) $ tableColumns t)- sql conn = concat+ sql conn = pack $ concat [ "SELECT " , cols conn , " FROM "@@ -204,7 +197,7 @@ res <- pop case res of Nothing -> return $ Continue k- Just [PersistInt64 i] -> do+ Just [i] -> do step <- runIteratee $ k $ Chunks [toPersistKey i] loop step pop Just y -> return $ Error $ toException $ PersistMarshalException@@ -214,8 +207,8 @@ wher conn = if null filts then "" else " WHERE " ++- intercalate " AND " (map (filterClause conn) filts)- sql conn = concat+ intercalate " AND " (map (filterClause False conn) filts)+ sql conn = pack $ concat [ "SELECT id FROM " , escapeName conn $ rawTableName t , wher conn@@ -223,10 +216,10 @@ delete k = do conn <- SqlPersist ask- execute' (sql conn) [PersistInt64 $ fromPersistKey k]+ execute' (sql conn) [fromPersistKey k] where t = entityDef $ dummyFromKey k- sql conn = concat+ sql conn = pack $ concat [ "DELETE FROM " , escapeName conn $ rawTableName t , " WHERE id=?"@@ -238,8 +231,8 @@ let wher = if null filts then "" else " WHERE " ++- intercalate " AND " (map (filterClause conn) filts)- sql = concat+ intercalate " AND " (map (filterClause False conn) filts)+ sql = pack $ concat [ "DELETE FROM " , escapeName conn $ rawTableName t , wher@@ -253,7 +246,7 @@ t = entityDef $ dummyFromUnique uniq go = map (getFieldName t) . persistUniqueToFieldNames go' conn x = escapeName conn x ++ "=?"- sql conn = concat+ sql conn = pack $ concat [ "DELETE FROM " , escapeName conn $ rawTableName t , " WHERE "@@ -269,7 +262,7 @@ go'' n Multiply = n ++ '=' : n ++ "*?" go'' n Divide = n ++ '=' : n ++ "/?" let go' (x, pu) = go'' (escapeName conn x) pu- let sql = concat+ let sql = pack $ concat [ "UPDATE " , escapeName conn $ rawTableName t , " SET "@@ -277,7 +270,7 @@ , " WHERE id=?" ] execute' sql $- map persistUpdateToValue upds ++ [PersistInt64 $ fromPersistKey k]+ map persistUpdateToValue upds ++ [fromPersistKey k] where t = entityDef $ dummyFromKey k go x = ( getFieldName t $ persistUpdateToFieldName x@@ -290,8 +283,8 @@ let wher = if null filts then "" else " WHERE " ++- intercalate " AND " (map (filterClause conn) filts)- let sql = concat+ intercalate " AND " (map (filterClause False conn) filts)+ let sql = pack $ concat [ "UPDATE " , escapeName conn $ rawTableName t , " SET "@@ -316,7 +309,7 @@ conn <- SqlPersist ask let cols = intercalate "," $ "id" : (map (\(x, _, _) -> escapeName conn x) $ tableColumns t)- let sql = concat+ let sql = pack $ concat [ "SELECT " , cols , " FROM "@@ -328,7 +321,7 @@ row <- pop case row of Nothing -> return Nothing- Just (PersistInt64 k:vals) ->+ Just (k:vals) -> case fromPersistValues vals of Left s -> error s Right x -> return $ Just (toPersistKey k, x)@@ -343,94 +336,11 @@ 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 _ "id" = ("id", "Int64", [])-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- 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 = 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 = "<="- showSqlFilter In = " IN "- showSqlFilter NotIn = " NOT IN " -dummyFromFilts :: [Filter v] -> v-dummyFromFilts _ = error "dummyFromFilts"---type Sql = String+type Sql = Text -- Bool indicates if the Sql is safe type CautiousMigration = [(Bool, Sql)]@@ -441,9 +351,9 @@ safeSql :: CautiousMigration -> [Sql] safeSql = allSql . filter (not . fst) -type Migration m = WriterT [String] (WriterT CautiousMigration m) ()+type Migration m = WriterT [Text] (WriterT CautiousMigration m) () -parseMigration :: Monad m => Migration m -> m (Either [String] CautiousMigration)+parseMigration :: Monad m => Migration m -> m (Either [Text] CautiousMigration) parseMigration = liftM go . runWriterT . execWriterT where@@ -455,35 +365,35 @@ parseMigration' m = do x <- parseMigration m case x of- Left errs -> error $ unlines errs+ Left errs -> error $ unlines $ map unpack errs Right sql -> return sql -printMigration :: MonadPeelIO m => Migration (SqlPersist m) -> SqlPersist m ()+printMigration :: MonadControlIO m => Migration (SqlPersist m) -> SqlPersist m () printMigration m = do mig <- parseMigration' m- mapM_ (liftIO . putStrLn) (allSql mig)+ mapM_ (liftIO . putStrLn . unpack) (allSql mig) -getMigration :: MonadPeelIO m => Migration (SqlPersist m) -> SqlPersist m [Sql]+getMigration :: MonadControlIO m => Migration (SqlPersist m) -> SqlPersist m [Sql] getMigration m = do mig <- parseMigration' m return $ allSql mig -runMigration :: MonadPeelIO m+runMigration :: MonadControlIO m => Migration (SqlPersist m) -> SqlPersist m () runMigration m = runMigration' m False >> return () -- | Same as 'runMigration', but returns a list of the SQL commands executed -- instead of printing them to stderr.-runMigrationSilent :: MonadPeelIO m+runMigrationSilent :: MonadControlIO m => Migration (SqlPersist m)- -> SqlPersist m [String]+ -> SqlPersist m [Text] runMigrationSilent m = runMigration' m True -runMigration' :: MonadPeelIO m+runMigration' :: MonadControlIO m => Migration (SqlPersist m) -> Bool -- ^ is silent?- -> SqlPersist m [String]+ -> SqlPersist m [Text] runMigration' m silent = do mig <- parseMigration' m case unsafeSql mig of@@ -491,23 +401,23 @@ errs -> error $ concat [ "\n\nDatabase migration: manual intervention required.\n" , "The following actions are considered unsafe:\n\n"- , unlines $ map (\s -> " " ++ s ++ ";") $ errs+ , unlines $ map (\s -> " " ++ unpack s ++ ";") $ errs ] -runMigrationUnsafe :: MonadPeelIO m+runMigrationUnsafe :: MonadControlIO m => Migration (SqlPersist m) -> SqlPersist m () runMigrationUnsafe m = do mig <- parseMigration' m mapM_ (executeMigrate False) $ allSql mig -executeMigrate :: MonadIO m => Bool -> String -> SqlPersist m String+executeMigrate :: MonadIO m => Bool -> Text -> SqlPersist m Text executeMigrate silent s = do- unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ s+ unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ unpack s execute' s [] return s -migrate :: (MonadPeelIO m, PersistEntity val)+migrate :: (MonadControlIO m, PersistEntity val) => val -> Migration (SqlPersist m) migrate val = do@@ -515,40 +425,3 @@ let getter = R.getStmt' conn res <- liftIO $ migrateSql conn getter val either tell (lift . tell) res--getFiltsValues :: PersistEntity val => [Filter val] -> [PersistValue]-getFiltsValues =- concatMap $ go . persistFilterToValue- where- go (Left PersistNull) = []- go (Left x) = [x]- go (Right xs) = filter (/= PersistNull) xs---- | Creates a single function to perform all migrations for the entities--- defined here. One thing to be aware of is dependencies: if you have entities--- with foreign references, make sure to place those definitions after the--- entities they reference.-mkMigrate :: String -> [EntityDef] -> Q [Dec]-mkMigrate fun defs = do- body' <- body- return- [ SigD (mkName fun) typ- , FunD (mkName fun) [Clause [] (NormalB body') []]- ]- where- typ = ForallT [PlainTV $ mkName "m"]- [ ClassP ''MonadPeelIO [VarT $ mkName "m"]- ]- $ ConT ''Migration `AppT` (ConT ''SqlPersist `AppT` VarT (mkName "m"))- body :: Q Exp- body =- case defs of- [] -> [|return ()|]- _ -> DoE `fmap` mapM toStmt defs- toStmt :: EntityDef -> Q Stmt- toStmt ed = do- let n = entityName ed- u <- [|undefined|]- m <- [|migrate|]- let u' = SigE u $ ConT $ mkName n- return $ NoBindS $ m `AppE` u'
Database/Persist/GenericSql/Internal.hs view
@@ -15,6 +15,11 @@ , rawFieldName , rawTableName , RawName (..)+ , filterClause+ , getFieldName+ , dummyFromFilts+ , getFiltsValues+ , orderClause ) where import qualified Data.Map as Map@@ -24,23 +29,25 @@ import Database.Persist.Base import Data.Maybe (fromJust) import Control.Arrow-import Control.Monad.IO.Peel (MonadPeelIO)-import Control.Exception.Peel (bracket)-import Database.Persist.TH (nullable)+import Control.Monad.IO.Control (MonadControlIO)+import Control.Exception.Control (bracket)+import Database.Persist.Util (nullable)+import Data.List (intercalate)+import Data.Text (Text) 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)+ { prepare :: Text -> IO Statement+ , insertSql :: RawName -> [RawName] -> Either Text (Text, Text)+ , stmtMap :: IORef (Map.Map Text 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 ()+ => (Text -> IO Statement) -> v+ -> IO (Either [Text] [(Bool, Text)])+ , begin :: (Text -> IO Statement) -> IO ()+ , commit :: (Text -> IO Statement) -> IO ()+ , rollback :: (Text -> IO Statement) -> IO () , escapeName :: RawName -> String , noLimit :: String }@@ -48,15 +55,15 @@ { finalize :: IO () , reset :: IO () , execute :: [PersistValue] -> IO ()- , withStmt :: forall a m. MonadPeelIO m+ , withStmt :: forall a m. MonadControlIO m => [PersistValue] -> (RowPopper m -> m a) -> m a } -withSqlPool :: MonadPeelIO m+withSqlPool :: MonadControlIO m => IO Connection -> Int -> (Pool Connection -> m a) -> m a withSqlPool mkConn = createPool mkConn close' -withSqlConn :: MonadPeelIO m => IO Connection -> (Connection -> m a) -> m a+withSqlConn :: MonadControlIO m => IO Connection -> (Connection -> m a) -> m a withSqlConn open = bracket (liftIO open) (liftIO . close') close' :: Connection -> IO ()@@ -125,5 +132,118 @@ Nothing -> entityName t Just x -> x -newtype RawName = RawName { unRawName :: String }+newtype RawName = RawName { unRawName :: String } -- FIXME Text deriving (Eq, Ord)++filterClause :: PersistEntity val+ => Bool -- ^ include table name?+ -> Connection -> Filter val -> String+filterClause includeTable 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 =+ (if includeTable+ then (++) (escapeName conn (rawTableName t) ++ ".")+ else id)+ $ 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 = "<="+ showSqlFilter In = " IN "+ showSqlFilter NotIn = " NOT IN "++dummyFromFilts :: [Filter v] -> v+dummyFromFilts _ = error "dummyFromFilts"++getFieldName :: EntityDef -> String -> RawName+getFieldName t s = rawFieldName $ tableColumn t s++tableColumn :: EntityDef -> String -> (String, String, [String])+tableColumn _ "id" = ("id", "Int64", [])+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++getFiltsValues :: PersistEntity val => [Filter val] -> [PersistValue]+getFiltsValues =+ concatMap $ go . persistFilterToValue+ where+ go (Left PersistNull) = []+ go (Left x) = [x]+ go (Right xs) = filter (/= PersistNull) xs++dummyFromOrder :: Order a -> a+dummyFromOrder _ = undefined++orderClause :: PersistEntity val => Bool -> Connection -> Order val -> String+orderClause includeTable conn o =+ name ++ case persistOrderToOrder o of+ Asc -> ""+ Desc -> " DESC"+ where+ t = entityDef $ dummyFromOrder o+ name =+ (if includeTable+ then (++) (escapeName conn (rawTableName t) ++ ".")+ else id)+ $ escapeName conn $ getFieldName t $ persistOrderToFieldName o
Database/Persist/GenericSql/Raw.hs view
@@ -18,12 +18,13 @@ import qualified Data.Map as Map import Control.Applicative (Applicative) import Control.Monad.Trans.Class (MonadTrans (..))-import Control.Monad.IO.Peel (MonadPeelIO (..))+import Control.Monad.IO.Control (MonadControlIO (..))+import Data.Text (Text) newtype SqlPersist m a = SqlPersist { unSqlPersist :: ReaderT Connection m a }- deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadPeelIO)+ deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadControlIO) -withStmt :: MonadPeelIO m => String -> [PersistValue]+withStmt :: MonadControlIO m => Text -> [PersistValue] -> (RowPopper (SqlPersist m) -> SqlPersist m a) -> SqlPersist m a withStmt sql vals pop = do stmt <- getStmt sql@@ -31,18 +32,18 @@ liftIO $ reset stmt return ret -execute :: MonadIO m => String -> [PersistValue] -> SqlPersist m ()+execute :: MonadIO m => Text -> [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 :: MonadIO m => Text -> SqlPersist m Statement getStmt sql = do conn <- SqlPersist ask liftIO $ getStmt' conn sql -getStmt' :: Connection -> String -> IO Statement+getStmt' :: Connection -> Text -> IO Statement getStmt' conn sql = do smap <- liftIO $ readIORef $ stmtMap conn case Map.lookup sql smap of
+ Database/Persist/Join.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+module Database.Persist.Join+ ( -- * Typeclass+ RunJoin (..)+ -- * One-to-many relation+ , SelectOneMany (..)+ , selectOneMany+ ) where++import Database.Persist.Base+import Data.Maybe (mapMaybe)+import qualified Data.Map as Map+import Data.List (foldl')++class RunJoin a where+ type Result a+ runJoin :: PersistBackend m => a -> m (Result a)++data SelectOneMany one many = SelectOneMany+ { somFilterOne :: [Filter one]+ , somOrderOne :: [Order one]+ , somFilterMany :: [Filter many]+ , somOrderMany :: [Order many]+ , somFilterKeys :: [Key one] -> Filter many+ , somGetKey :: many -> Key one+ , somIncludeNoMatch :: Bool+ }++selectOneMany :: ([Key one] -> Filter many) -> (many -> Key one) -> SelectOneMany one many+selectOneMany filts get' = SelectOneMany [] [] [] [] filts get' False+instance (PersistEntity one, PersistEntity many, Ord (Key one))+ => RunJoin (SelectOneMany one many) where+ type Result (SelectOneMany one many) =+ [((Key one, one), [(Key many, many)])]+ runJoin (SelectOneMany oneF oneO manyF manyO eq getKey isOuter) = do+ x <- selectList oneF oneO 0 0+ -- FIXME use select instead of selectList+ y <- selectList (eq (map fst x) : manyF) manyO 0 0+ let y' = foldl' go Map.empty y+ return $ mapMaybe (go' y') x+ where+ go m many@(_, many') =+ Map.insert (getKey many')+ (case Map.lookup (getKey many') m of+ Nothing -> (:) many+ Just v -> v . (:) many+ ) m+ go' y' one@(k, _) =+ case Map.lookup k y' of+ Nothing ->+ if isOuter+ then Just (one, [])+ else Nothing+ Just many -> Just (one, many [])
+ Database/Persist/Join/Sql.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+module Database.Persist.Join.Sql+ ( RunJoin (..)+ ) where++import Database.Persist.Join hiding (RunJoin (..))+import qualified Database.Persist.Join as J+import Database.Persist.Base+import Control.Monad (liftM)+import Data.Maybe (mapMaybe)+import Data.List (intercalate, groupBy)+import Database.Persist.GenericSql (SqlPersist (SqlPersist))+import Database.Persist.GenericSql.Internal hiding (withStmt)+import Database.Persist.GenericSql.Raw (withStmt)+import Control.Monad.Trans.Reader (ask)+import Control.Monad.IO.Control (MonadControlIO)+import Data.Function (on)+import Control.Arrow ((&&&))+import Data.Text (pack)++fromPersistValuesId :: PersistEntity v => [PersistValue] -> Either String (Key v, v)+fromPersistValuesId [] = Left "fromPersistValuesId: No values provided"+fromPersistValuesId (i:rest) =+ case fromPersistValues rest of+ Left e -> Left e+ Right x -> Right (toPersistKey i, x)++class RunJoin a where+ runJoin :: MonadControlIO m => a -> SqlPersist m (J.Result a)++instance (PersistEntity one, PersistEntity many, Eq (Key one))+ => RunJoin (SelectOneMany one many) where+ runJoin = selectOneMany'++selectOneMany' :: (MonadControlIO m,+ PersistEntity d,+ PersistEntity val1,+ PersistEntity val,+ PersistEntity b,+ Eq (Key b)) =>+ SelectOneMany val val1 -> SqlPersist m [((Key b, b), [(Key d, d)])]+selectOneMany' (SelectOneMany oneF oneO manyF manyO eq _getKey isOuter) = do+ conn <- SqlPersist ask+ liftM go $ withStmt (sql conn) (getFiltsValues oneF ++ getFiltsValues manyF) $ loop id+ where+ go :: Eq a => [((a, b), Maybe (c, d))] -> [((a, b), [(c, d)])]+ go = map (fst . head &&& mapMaybe snd) . groupBy ((==) `on` (fst . fst))+ loop front popper = do+ x <- popper+ case x of+ Nothing -> return $ front []+ Just vals -> do+ let (y, z) = splitAt oneCount vals+ case (fromPersistValuesId y, fromPersistValuesId z) of+ (Right y', Right z') -> loop (front . (:) (y', Just z')) popper+ (Left e, _) -> error $ "selectOneMany: " ++ e+ (Right y', Left e) ->+ case z of+ PersistNull:_ -> loop (front . (:) (y', Nothing)) popper+ _ -> error $ "selectOneMany: " ++ e+ oneCount = 1 + length (tableColumns $ entityDef one)+ one = dummyFromFilts oneF+ many = dummyFromFilts manyF+ sql conn = pack $ concat+ [ "SELECT "+ , intercalate "," $ colsPlusId conn one ++ colsPlusId conn many+ , " FROM "+ , escapeName conn $ rawTableName $ entityDef one+ , if isOuter then " LEFT JOIN " else " INNER JOIN "+ , escapeName conn $ rawTableName $ entityDef many+ , " ON "+ , escapeName conn $ rawTableName $ entityDef one+ , ".id = "+ , escapeName conn $ rawTableName $ entityDef many+ , "."+ , escapeName conn $ RawName $ persistFilterToFieldName $ eq undefined+ , if null filts+ then ""+ else " WHERE " ++ intercalate " AND " filts+ , if null ords+ then ""+ else " ORDER BY " ++ intercalate ", " ords+ ]+ where+ filts = map (filterClause True conn) oneF ++ map (filterClause True conn) manyF+ ords = map (orderClause True conn) oneO ++ map (orderClause True conn) manyO++addTable :: PersistEntity val =>+ Connection -> val -> [Char] -> [Char]+addTable conn e s = concat [escapeName conn $ rawTableName $ entityDef e, ".", s]++colsPlusId :: PersistEntity e => Connection -> e -> [String]+colsPlusId conn e =+ map (addTable conn e) $+ "id" : (map (\(x, _, _) -> escapeName conn x) cols)+ where+ cols = tableColumns $ entityDef e
Database/Persist/Quasi.hs view
@@ -1,35 +1,19 @@ module Database.Persist.Quasi- ( persist- , persistFile+ ( parse ) where -import Language.Haskell.TH.Quote-import Language.Haskell.TH.Syntax import Database.Persist.Base import Data.Char import Data.Maybe (mapMaybe)-import Text.ParserCombinators.Parsec hiding (token)-import qualified System.IO as SIO---- | Converts a quasi-quoted syntax into a list of entity definitions, to be--- used as input to the template haskell generation code (mkPersist).-persist :: QuasiQuoter-persist = QuasiQuoter- { quoteExp = lift . parse_- }--persistFile :: FilePath -> Q Exp-persistFile fp = do- h <- qRunIO $ SIO.openFile fp SIO.ReadMode- qRunIO $ SIO.hSetEncoding h SIO.utf8_bom- s <- qRunIO $ SIO.hGetContents h- lift $ parse_ s+import Text.ParserCombinators.Parsec hiding (parse, token)+import qualified Text.ParserCombinators.Parsec as Parsec -parse_ :: String -> [EntityDef]-parse_ = map parse' . nest . map words'- . removeLeadingSpaces- . map killCarriage- . lines+-- | Parses a quasi-quoted syntax into a list of entity definitions.+parse :: String -> [EntityDef]+parse = map parse' . nest . map words'+ . removeLeadingSpaces+ . map killCarriage+ . lines removeLeadingSpaces :: [String] -> [String] removeLeadingSpaces x =@@ -45,7 +29,7 @@ | otherwise = s words' :: String -> (Bool, [String])-words' s = case parse words'' s s of+words' s = case Parsec.parse words'' s s of Left e -> error $ show e Right x -> x
− Database/Persist/TH.hs
@@ -1,529 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ExistentialQuantification #-}--- | This module provides utilities for creating backends. Regular users do not--- need to use this module.-module Database.Persist.TH- ( mkPersist- , share- , share2- , mkSave- , mkDeleteCascade- , derivePersistField- , nullable- ) where--import Database.Persist.Base-import Language.Haskell.TH.Syntax-import Data.Char (toLower, toUpper)-import Data.Maybe (mapMaybe, catMaybes)-import Web.Routes.Quasi (SinglePiece)-import Data.Int (Int64)-import Control.Monad (forM)-import System.IO.Unsafe (unsafePerformIO)---- | Create data types and appropriate 'PersistEntity' instances for the given--- 'EntityDef's. Works well with the persist quasi-quoter.-mkPersist :: [EntityDef] -> Q [Dec]-mkPersist = fmap concat . mapM mkEntity--recName :: String -> String -> String-recName dt f = lowerFirst dt ++ upperFirst f--lowerFirst :: String -> String-lowerFirst (x:xs) = toLower x : xs-lowerFirst [] = []--upperFirst :: String -> String-upperFirst (x:xs) = toUpper x : xs-upperFirst [] = []--dataTypeDec :: EntityDef -> Dec-dataTypeDec t =- let name = mkName $ entityName t- cols = map (mkCol $ entityName t) $ entityColumns t- in DataD [] name [] [RecC name cols] $ map mkName $ entityDerives t- where- mkCol x (n, ty, as) =- (mkName $ recName x n, NotStrict, pairToType (ty, nullable as))--keyTypeDec :: String -> Name -> EntityDef -> Dec-keyTypeDec constr typ t =- NewtypeInstD [] ''Key [ConT $ mkName $ entityName t]- (NormalC (mkName constr) [(NotStrict, ConT typ)])- [''Show, ''Read, ''Num, ''Integral, ''Enum, ''Eq, ''Ord,- ''Real, ''PersistField, ''SinglePiece]--filterTypeDec :: EntityDef -> Dec-filterTypeDec t =- DataInstD [] ''Filter [ConT $ mkName $ entityName t]- (NormalC (mkName $ entityName t ++ "IdIn") [(NotStrict, listOfIds)]- : map (mkFilter $ entityName t) filts)- (if null filts then [] else [''Show, ''Read, ''Eq])- where- listOfIds = ListT `AppT` (ConT ''Key `AppT` ConT (mkName $ entityName t))- filts = entityFilters t--entityFilters :: EntityDef -> [(String, String, Bool, PersistFilter)]-entityFilters = mapMaybe go' . concatMap go . entityColumns- where- go (x, y, as) = map (\a -> (x, y, nullable as, a)) as- go' (x, y, z, a) =- case readMay a of- Nothing -> Nothing- Just a' -> Just (x, y, z, a')--readMay :: Read a => String -> Maybe a-readMay s =- case reads s of- (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, 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 =- DataInstD [] ''Update [ConT $ mkName $ entityName t]- (map (mkUpdate $ entityName t) tu)- (if null tu then [] else [''Show, ''Read, ''Eq])- where- tu = entityUpdates t--entityUpdates :: EntityDef -> [(String, String, Bool, PersistUpdate)]-entityUpdates = mapMaybe go' . concatMap go . entityColumns- where- go (x, y, as) = map (\a -> (x, y, nullable as, a)) as- go' (x, y, z, "update") =- deprecate "'update' is deprecated; please use 'Update'"- $ Just (x, y, z, Update)- go' (x, y, z, a) =- case readMay a of- Nothing -> Nothing- Just a' -> Just (x, y, z, a')--mkUpdate :: String -> (String, String, Bool, PersistUpdate) -> Con-mkUpdate x (s, ty, isBool, pu) =- NormalC (mkName $ updateConName x s pu) [(NotStrict, pairToType (ty, isBool))]--orderTypeDec :: EntityDef -> Q Dec-orderTypeDec t = do- ords <- entityOrders t- return $ DataInstD [] ''Order [ConT $ mkName $ entityName t]- (map (mkOrder $ entityName t) ords)- (if null ords then [] else [''Show, ''Read, ''Eq])--entityOrders :: EntityDef -> Q [(String, String, Exp)]-entityOrders = fmap concat . mapM go . entityColumns- where- go (x, _, ys) = fmap catMaybes $ mapM (go' x) ys- go' x s =- case reads s of- (y, _):_ -> do- z <- lift (y :: PersistOrder)- return $ Just (x, s, z)- _ -> return Nothing--mkOrder :: String -> (String, String, Exp) -> Con-mkOrder x (s, ad, _) = NormalC (mkName $ x ++ upperFirst s ++ ad) []--uniqueTypeDec :: EntityDef -> Dec-uniqueTypeDec t =- DataInstD [] ''Unique [ConT $ mkName $ entityName t]- (map (mkUnique t) $ entityUniques t)- (if null (entityUniques t) then [] else [''Show, ''Read, ''Eq])--mkUnique :: EntityDef -> (String, [String]) -> Con-mkUnique t (constr, fields) =- NormalC (mkName constr) types- where- types = map (go . flip lookup3 (entityColumns t)) fields- go (_, True) = error "Error: cannot have nullables in unique"- go x = (NotStrict, pairToType x)- lookup3 s [] =- error $ "Column not found: " ++ s ++ " in unique " ++ constr- lookup3 x ((x', y, z):rest)- | x == x' = (y, nullable z)- | otherwise = lookup3 x rest--pairToType :: (String, Bool) -> Type-pairToType (s, False) = ConT $ mkName s-pairToType (s, True) = ConT (mkName "Maybe") `AppT` ConT (mkName s)--degen :: [Clause] -> [Clause]-degen [] =- let err = VarE (mkName "error") `AppE` LitE (StringL- "Degenerate case, should never happen")- in [Clause [WildP] (NormalB err) []]-degen x = x--mkToPersistFields :: [(String, Int)] -> Q Dec-mkToPersistFields pairs = do- clauses <- mapM go pairs- return $ FunD (mkName "toPersistFields") $ degen clauses- where- go :: (String, Int) -> Q Clause- go (constr, fields) = do- xs <- sequence $ replicate fields $ newName "x"- let pat = ConP (mkName constr) $ map VarP xs- sp <- [|SomePersistField|]- let bod = ListE $ map (AppE sp . VarE) xs- return $ Clause [pat] (NormalB bod) []--mkToFieldNames :: [(String, [String])] -> Dec-mkToFieldNames pairs =- FunD (mkName "persistUniqueToFieldNames") $ degen $ map go pairs- where- go (constr, names) =- Clause [RecP (mkName constr) []]- (NormalB $ ListE $ map (LitE . StringL) names)- []--mkToUpdate :: String -> [(String, PersistUpdate)] -> Q Dec-mkToUpdate name pairs = do- pairs' <- mapM go pairs- return $ FunD (mkName name) $ degen pairs'- where- go (constr, pu) = do- pu' <- lift pu- return $ Clause [RecP (mkName constr) []] (NormalB pu') []--mkUniqueToValues :: [(String, [String])] -> Q Dec-mkUniqueToValues pairs = do- pairs' <- mapM go pairs- return $ FunD (mkName "persistUniqueToValues") $ degen pairs'- where- go :: (String, [String]) -> Q Clause- go (constr, names) = do- xs <- mapM (const $ newName "x") names- let pat = ConP (mkName constr) $ map VarP xs- tpv <- [|toPersistValue|]- let bod = ListE $ map (AppE tpv . VarE) xs- return $ Clause [pat] (NormalB bod) []--mkToFieldName :: String -> [(String, String)] -> Dec-mkToFieldName func pairs =- FunD (mkName func) $ degen $ map go pairs- where- go (constr, name) =- Clause [RecP (mkName constr) []] (NormalB $ LitE $ StringL name) []--mkToOrder :: [(String, Exp)] -> Dec-mkToOrder pairs =- FunD (mkName "persistOrderToOrder") $ degen $ map go pairs- where- go (constr, val) =- Clause [RecP (mkName constr) []] (NormalB val) []--mkToFilter :: EntityDef -> [(String, PersistFilter, Bool)] -> Q [Dec]-mkToFilter e pairs = do- c1 <- mapM go pairs- idIn' <- idIn- let _FIXMEc2 = concatMap go' pairs- return- [ FunD (mkName "persistFilterToFilter") $ idIn' : c1- ]- where- idIn = do- in_ <- [|In|]- return $ Clause- [RecP (mkName $ entityName e ++ "IdIn") []]- (NormalB in_)- []- go (constr, pf, _) = do- pf' <- lift pf- return $ Clause [RecP (mkName constr) []] (NormalB pf') []- go' (constr, _, False) =- [Clause [RecP (mkName constr) []]- (NormalB $ ConE $ mkName "False") []]- go' (constr, _, True) =- [ Clause [ConP (mkName constr) [ConP (mkName "Nothing") []]]- (NormalB $ ConE $ mkName "True") []- , Clause [ConP (mkName constr) [WildP]]- (NormalB $ ConE $ mkName "False") []- ]--mkToValue :: String -> [String] -> Dec-mkToValue func = FunD (mkName func) . degen . map go- where- go constr =- let x = mkName "x"- in Clause [ConP (mkName constr) [VarP x]]- (NormalB $ VarE (mkName "toPersistValue") `AppE` VarE x)- []--mkToFiltValue :: EntityDef -> String -> [(String, Bool)] -> Q Dec-mkToFiltValue e func pairs = do- left <- [|Left . toPersistValue|]- right <- [|Right . map toPersistValue|]- clauses <- mapM (go left right) pairs- inId' <- inId right- return $ FunD (mkName func) $ (inId' : clauses)- where- inId right = do- x <- newName "x"- return $ Clause- [ConP (mkName $ entityName e ++ "IdIn") [VarP x]]- (NormalB $ right `AppE` VarE x)- []- 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' =- FunD (mkName "halfDefined")- [Clause [] (NormalB- $ foldl AppE (ConE $ mkName constr)- (replicate count' $ VarE $ mkName "undefined")) []]--apE :: Either x (y -> z) -> Either x y -> Either x z-apE (Left x) _ = Left x-apE _ (Left x) = Left x-apE (Right f) (Right y) = Right $ f y--mkFromPersistValues :: EntityDef -> Q [Clause]-mkFromPersistValues t = do- nothing <- [|Left "Invalid fromPersistValues input"|]- let cons = ConE $ mkName $ entityName t- xs <- mapM (const $ newName "x") $ entityColumns t- fs <- [|fromPersistValue|]- let xs' = map (AppE fs . VarE) xs- let pat = ListP $ map VarP xs- ap' <- [|apE|]- just <- [|Right|]- let cons' = just `AppE` cons- return- [ Clause [pat] (NormalB $ foldl (go ap') cons' xs') []- , Clause [WildP] (NormalB nothing) []- ]- where- go ap' x y = InfixE (Just x) ap' (Just y)--mkEntity :: EntityDef -> Q [Dec]-mkEntity t = do- t' <- lift t- let name = entityName t- let clazz = ConT ''PersistEntity `AppT` ConT (mkName $ entityName t)- tpf <- mkToPersistFields [(name, length $ entityColumns t)]- fpv <- mkFromPersistValues t- fromIntegral' <- [|fromIntegral|]- utv <- mkUniqueToValues $ entityUniques t- show' <- [|show|]- entityOrders' <- entityOrders t- otd <- orderTypeDec t- puk <- mkUniqueKeys t- tf <- mkToFilter t- (map (\(x, _, z, y) ->- (name ++ upperFirst x ++ show y, y, z))- $ entityFilters t)- ftv <- mkToFiltValue t "persistFilterToValue"- $ map (\(x, _, _, y) ->- (name ++ upperFirst x ++ show y, isFilterList y))- $ entityFilters t- putu <- mkToUpdate "persistUpdateToUpdate"- $ map (\(s, _, _, pu) -> (updateConName name s pu, pu))- $ entityUpdates t- return- [ dataTypeDec t- , TySynD (mkName $ entityName t ++ "Id") [] $- ConT ''Key `AppT` ConT (mkName $ entityName t)- , InstanceD [] clazz $- [ keyTypeDec (entityName t ++ "Id") ''Int64 t- , filterTypeDec t- , updateTypeDec t- , otd- , uniqueTypeDec t- , FunD (mkName "entityDef") [Clause [WildP] (NormalB t') []]- , tpf- , FunD (mkName "fromPersistValues") fpv- , mkHalfDefined name $ length $ entityColumns t- , FunD (mkName "toPersistKey") [Clause [] (NormalB fromIntegral') []]- , FunD (mkName "fromPersistKey") [Clause [] (NormalB fromIntegral') []]- , FunD (mkName "showPersistKey") [Clause [] (NormalB show') []]- , mkToFieldName "persistOrderToFieldName"- $ map (\(x, y, _) -> (name ++ upperFirst x ++ y, x))- entityOrders'- , mkToOrder- $ map (\(x, y, z) -> (name ++ upperFirst x ++ y, z))- entityOrders'- , mkToFieldName "persistUpdateToFieldName"- $ map (\(s, _, _, pu) -> (updateConName name s pu, s))- $ entityUpdates t- , mkToValue "persistUpdateToValue"- $ map (\(s, _, _, pu) -> updateConName name s pu)- $ entityUpdates t- , putu- , mkToFieldName "persistFilterToFieldName"- $ (:) (entityName t ++ "IdIn", "id")- $ map (\(x, _, _, y) -> (name ++ upperFirst x ++ show y, x))- $ entityFilters t- , ftv- , mkToFieldNames $ entityUniques t- , utv- , puk- ] ++ tf- ]--updateConName :: String -> String -> PersistUpdate -> String-updateConName name s pu = concat- [ name- , upperFirst s- , case pu of- Update -> ""- _ -> show pu- ]--share :: [[EntityDef] -> Q [Dec]] -> [EntityDef] -> Q [Dec]-share fs x = fmap concat $ mapM ($ x) fs--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 = nullable 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'---- | Automatically creates a valid 'PersistField' instance for any datatype--- that has valid 'Show' and 'Read' instances. Can be very convenient for--- 'Enum' types.-derivePersistField :: String -> Q [Dec]-derivePersistField s = do- ss <- [|SqlString|]- tpv <- [|PersistString . show|]- fpv <- [|\dt v ->- case fromPersistValue v of- Left e -> Left e- Right s' ->- case reads s' of- (x, _):_ -> Right x- [] -> Left $ "Invalid " ++ dt ++ ": " ++ s'|]- return- [ InstanceD [] (ConT ''PersistField `AppT` ConT (mkName s))- [ FunD (mkName "sqlType")- [ Clause [WildP] (NormalB ss) []- ]- , FunD (mkName "toPersistValue")- [ Clause [] (NormalB tpv) []- ]- , FunD (mkName "fromPersistValue")- [ Clause [] (NormalB $ fpv `AppE` LitE (StringL s)) []- ]- ]- ]--nullable :: [String] -> Bool-nullable s- | "Maybe" `elem` s = True- | "null" `elem` s = deprecate "Please replace null with Maybe" True- | otherwise = False--deprecate :: String -> a -> a-deprecate s x = unsafePerformIO $ do- putStrLn $ "DEPRECATED: " ++ s- return x
+ Database/Persist/Util.hs view
@@ -0,0 +1,17 @@+module Database.Persist.Util+ ( nullable+ , deprecate+ ) where++import System.IO.Unsafe (unsafePerformIO)++nullable :: [String] -> Bool+nullable s+ | "Maybe" `elem` s = True+ | "null" `elem` s = deprecate "Please replace null with Maybe" True+ | otherwise = False++deprecate :: String -> a -> a+deprecate s x = unsafePerformIO $ do+ putStrLn $ "DEPRECATED: " ++ s+ return x
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 0.4.2+version: 0.5.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -13,32 +13,38 @@ homepage: http://docs.yesodweb.com/book/persistent library+ if flag(test)+ Buildable: False build-depends: base >= 4 && < 5- , template-haskell , bytestring >= 0.9 && < 0.10 , transformers >= 0.2.1 && < 0.3 , time >= 1.1.4 && < 1.3 , text >= 0.8 && < 0.12- , web-routes-quasi >= 0.6 && < 0.7 , containers >= 0.2 && < 0.5 , parsec >= 2.1 && < 4- , enumerator >= 0.4 && < 0.5- , monad-peel >= 0.1 && < 0.2- , pool >= 0.0 && < 0.1+ , enumerator >= 0.4.9 && < 0.5+ , monad-control >= 0.2 && < 0.3+ , pool >= 0.1 && < 0.2 , blaze-html >= 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.Util+ Database.Persist.Join+ Database.Persist.Join.Sql ghc-options: -Wall Flag test Description: Build the runtests executables. Default: False +Flag test-postgresql+ Description: Build the runtests executable with Postgresql support.+ Default: True+ executable runtests if flag(test) Buildable: True@@ -48,23 +54,14 @@ test-framework-hunit, base >= 4 && < 5, template-haskell >= 2.4 && < 2.6,- bytestring >= 0.9.1 && < 0.10,- transformers >= 0.2.1 && < 0.3,- time >= 1.1.4 && < 1.3,- text >= 0.7.1 && < 0.12,- hamlet >= 0.5 && < 0.7,- web-routes-quasi >= 0.6.0 && < 0.7,- containers >= 0.2 && < 0.5,- parsec >= 2.1 && < 4,- enumerator >= 0.4 && < 0.5,- stm >= 2.1 && < 2.3,- neither >= 0.1 && < 0.2, HDBC-postgresql, HDBC,- utf8-string+ web-routes-quasi >= 0.7 && < 0.8+ if flag(test-postgresql)+ cpp-options: -DWITH_POSTGRESQL else Buildable: False- hs-source-dirs: ., backends/sqlite, backends/postgresql+ hs-source-dirs: ., packages/template, backends/sqlite, backends/postgresql main-is: runtests.hs ghc-options: -Wall extra-libraries: sqlite3
runtests.hs view
@@ -3,6 +3,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} import Test.Framework (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit @@ -10,17 +12,23 @@ import Test.HUnit hiding (Test) import Database.Persist.Sqlite +#if WITH_POSTGRESQL import Database.Persist.Postgresql +#endif import Database.Persist.TH import Control.Monad.IO.Class +import Database.Persist.Join hiding (RunJoin) +import qualified Database.Persist.Join +import qualified Database.Persist.Join.Sql + import Control.Monad.Trans.Reader import Monad (unless) import Data.Int import Data.Word import Control.Exception (SomeException) -import qualified Control.Exception.Peel as Peel +import qualified Control.Exception.Control as Control infix 1 /=@, @/= @@ -64,13 +72,21 @@ word32 Word32 int64 Int64 word64 Word64 + + Author + name String Eq Asc + Entry + author AuthorId In + title String Desc |] -- connstr = "user=test password=test host=localhost port=5432 dbname=yesod_test" runConn f = do (withSqlitePool "testdb" 1) $ runSqlPool f +#if WITH_POSTGRESQL (withPostgresqlPool "user=test password=test host=localhost port=5432 dbname=test" 1) $ runSqlPool f +#endif -- TODO: run tests in transaction sqliteTest :: SqlPersist IO () -> Assertion @@ -83,6 +99,8 @@ deleteWhere ([] :: [Filter Pet]) deleteWhere ([] :: [Filter Person]) deleteWhere ([] :: [Filter Number]) + deleteWhere ([] :: [Filter Entry]) + deleteWhere ([] :: [Filter Author]) setup :: SqlPersist IO () setup = do @@ -110,6 +128,8 @@ , testCase "derivePersistField" case_derivePersistField , testCase "afterException" case_afterException , testCase "idIn" case_idIn + , testCase "join (non-SQL)" case_joinNonSql + , testCase "join (SQL)" case_joinSql ] @@ -130,6 +150,8 @@ case_derivePersistField = sqliteTest _derivePersistField case_afterException = (withSqlitePool "testdb" 1) $ runSqlPool _afterException case_idIn = sqliteTest _idIn +case_joinNonSql = sqliteTest _joinNonSql +case_joinSql = sqliteTest _joinSql _deleteWhere = do key2 <- insert $ Person "Michael2" 90 Nothing @@ -198,6 +220,10 @@ p @== p2 k @== key2 Nothing <- getBy $ PersonNameKey "Michael3" + + Just (k', p') <- getByValue p2 + k' @== k + p' @== p return () _update = do @@ -338,7 +364,7 @@ _afterException = do _ <- insert $ Person "A" 0 Nothing - _ <- (insert (Person "A" 1 Nothing) >> return ()) `Peel.catch` catcher + _ <- (insert (Person "A" 1 Nothing) >> return ()) `Control.catch` catcher _ <- insert $ Person "B" 0 Nothing return () where @@ -354,3 +380,78 @@ pid3 <- insert p3 x <- selectList [PersonIdIn [pid1, pid3]] [] 0 0 liftIO $ x @?= [(pid1, p1), (pid3, p3)] + +_joinNonSql = _joinGen Database.Persist.Join.runJoin +_joinSql = _joinGen Database.Persist.Join.Sql.runJoin + +_joinGen run = do + a <- insert $ Author "a" + a1 <- insert $ Entry a "a1" + a2 <- insert $ Entry a "a2" + a3 <- insert $ Entry a "a3" + b <- insert $ Author "b" + b1 <- insert $ Entry b "b1" + b2 <- insert $ Entry b "b2" + c <- insert $ Author "c" + + x <- run $ selectOneMany EntryAuthorIn entryAuthor + liftIO $ + x @?= + [ ((a, Author "a"), + [ (a1, Entry a "a1") + , (a2, Entry a "a2") + , (a3, Entry a "a3") + ]) + , ((b, Author "b"), + [ (b1, Entry b "b1") + , (b2, Entry b "b2") + ]) + ] + + y <- run $ (selectOneMany EntryAuthorIn entryAuthor) + { somFilterOne = [AuthorNameEq "a"] + } + liftIO $ + y @?= + [ ((a, Author "a"), + [ (a1, Entry a "a1") + , (a2, Entry a "a2") + , (a3, Entry a "a3") + ]) + ] + + z <- run (selectOneMany EntryAuthorIn entryAuthor) + { somOrderOne = [AuthorNameAsc] + , somOrderMany = [EntryTitleDesc] + } + liftIO $ + z @?= + [ ((a, Author "a"), + [ (a3, Entry a "a3") + , (a2, Entry a "a2") + , (a1, Entry a "a1") + ]) + , ((b, Author "b"), + [ (b2, Entry b "b2") + , (b1, Entry b "b1") + ]) + ] + + w <- run (selectOneMany EntryAuthorIn entryAuthor) + { somOrderOne = [AuthorNameAsc] + , somOrderMany = [EntryTitleDesc] + , somIncludeNoMatch = True + } + liftIO $ + w @?= + [ ((a, Author "a"), + [ (a3, Entry a "a3") + , (a2, Entry a "a2") + , (a1, Entry a "a1") + ]) + , ((b, Author "b"), + [ (b2, Entry b "b2") + , (b1, Entry b "b1") + ]) + , ((c, Author "c"), []) + ]