Permalink
Browse files

Merge remote-tracking branch 'upstream/master'

I had a fix on my branch for a long time that for some reason I
forgot to send upstream.

Conflicts:
	persistent-mysql/persistent-mysql.cabal
  • Loading branch information...
2 parents 2e91760 + 0d18b59 commit c2e2ef7eeedc3da463c3f9acf29936ab8c5ab3f6 @meteficha committed Aug 17, 2012
Showing with 96,957 additions and 78,374 deletions.
  1. +2 −0 .gitignore
  2. +0 −3 .gitmodules
  3. +0 −92 experimental/mysql/Database/Mysql.hs
  4. +0 −97 experimental/mysql/Database/Persist/Mysql.hs
  5. +0 −20 experimental/mysql/LICENSE
  6. +0 −30 experimental/mysql/persistent-mysql.cabal
  7. +0 −107 experimental/redis/Database/Persist/Redis.hs
  8. +0 −20 experimental/redis/LICENSE
  9. +0 −27 experimental/redis/persistent-redis.cabal
  10. +0 −78 experimental/redis/test1.hs
  11. +251 −170 persistent-mongoDB/Database/Persist/MongoDB.hs
  12. +8 −6 persistent-mongoDB/persistent-mongoDB.cabal
  13. +25 −19 persistent-mysql/Database/Persist/MySQL.hs
  14. +3 −4 persistent-mysql/persistent-mysql.cabal
  15. +81 −69 persistent-postgresql/Database/Persist/Postgresql.hs
  16. +4 −4 persistent-postgresql/persistent-postgresql.cabal
  17. +19 −14 persistent-sqlite/Database/Persist/Sqlite.hs
  18. +2 −1 persistent-sqlite/Database/Sqlite.hs
  19. +95,998 −77,382 persistent-sqlite/cbits/sqlite3.c
  20. +4 −4 persistent-sqlite/persistent-sqlite.cabal
  21. +79 −15 persistent-template/Database/Persist/TH.hs
  22. +2 −2 persistent-template/persistent-template.cabal
  23. +12 −3 persistent-test/DataTypeTest.hs
  24. +22 −13 persistent-test/EmbedTest.hs
  25. +5 −5 persistent-test/HtmlTest.hs
  26. +15 −6 persistent-test/Init.hs
  27. +9 −7 persistent-test/JoinTest.hs
  28. +5 −3 persistent-test/LargeNumberTest.hs
  29. +3 −1 persistent-test/MaxLenTest.hs
  30. +70 −15 persistent-test/PersistentTest.hs
  31. +2 −2 persistent-test/RenameTest.hs
  32. +72 −0 persistent-test/SumTypeTest.hs
  33. +37 −24 persistent-test/persistent-test.cabal
  34. +10 −4 persistent-test/test/main.hs
  35. +1 −0 persistent/Database/Persist/EntityDef.hs
  36. +18 −13 persistent/Database/Persist/GenericSql.hs
  37. +10 −2 persistent/Database/Persist/GenericSql/Internal.hs
  38. +7 −6 persistent/Database/Persist/GenericSql/Migration.hs
  39. +21 −26 persistent/Database/Persist/GenericSql/Raw.hs
  40. +7 −2 persistent/Database/Persist/Quasi.hs
  41. +1 −0 persistent/Database/Persist/Query.hs
  42. +31 −17 persistent/Database/Persist/Query/GenericSql.hs
  43. +47 −16 persistent/Database/Persist/Query/Internal.hs
  44. +2 −2 persistent/Database/Persist/Query/Join.hs
  45. +2 −1 persistent/Database/Persist/Query/Join/Sql.hs
  46. +62 −36 persistent/Database/Persist/Store.hs
  47. +6 −4 persistent/persistent.cabal
  48. +1 −1 pool-conduit/pool-conduit.cabal
  49. +1 −1 scripts
View
@@ -7,3 +7,5 @@ persistent-test/test/testdb.sqlite3
*.o
TAGS
.virthualenv
+# hsenv does this
+dist_y
View
@@ -4,6 +4,3 @@
[submodule "pool"]
path = pool
url = https://github.com/bos/pool.git
-[submodule "mongoDB-haskell"]
- path = mongoDB-haskell
- url = https://github.com/TonyGen/mongoDB-haskell.git
@@ -1,92 +0,0 @@
-{-# LANGUAGE ForeignFunctionInterface #-}
-module Database.Mysql
- ( MysqlSettings (..)
- , open
- , close
- , Connection
- , Statement
- , prepare
- , finalize
- , bindParams
- , execute
- , reset
- ) where
-
-import Foreign.C
-import Foreign.Ptr
-import Database.Persist.Base
-
-data MysqlSettings = MysqlSettings
- { mysqlHost :: String
- , mysqlUser :: String
- , mysqlPass :: String
- , mysqlDb :: String
- , mysqlPort :: Int
- }
-
-newtype Connection = Connection (Ptr ())
-newtype Statement = Statement (Ptr ())
-newtype Bind = Bind (Ptr ())
-
-foreign import ccall "mysql_init"
- c'init :: Ptr () -> IO Connection
-foreign import ccall "mysql_real_connect"
- c'open :: Connection -> Ptr CChar -> Ptr CChar -> Ptr CChar
- -> Ptr CChar -> CInt -> Ptr CChar -> CLong -> IO (Ptr ())
-
-getError :: Connection -> String -> IO String
-getError _ _ = error "An error occurred"
-
-tellError :: Connection -> String -> IO a
-tellError conn str = do
- err <- getError conn str
- error err
-
-open :: MysqlSettings -> IO Connection
-open (MysqlSettings host' user' pass' db' port') =
- withCString host' $ \host ->
- withCString user' $ \user ->
- withCString pass' $ \pass ->
- withCString db' $ \db -> do
- let port = fromIntegral port'
- conn <- c'init nullPtr
- conn' <- c'open conn host user pass db port nullPtr 0
- if conn' == nullPtr
- then do
- err <- getError conn "open"
- close conn
- error err
- else return conn
-
-foreign import ccall "mysql_close"
- close :: Connection -> IO ()
-
-foreign import ccall "mysql_stmt_init"
- c'stmtInit :: Connection -> IO Statement
-foreign import ccall "mysql_stmt_prepare"
- c'stmtPrepare :: Statement -> Ptr CChar -> CLong -> IO CInt
-foreign import ccall "mysql_stmt_close"
- c'stmtClose :: Statement -> IO CInt
-prepare :: Connection -> String -> IO Statement
-prepare conn sql' = withCStringLen sql' $ \(sql, len') -> do
- let len = fromIntegral len'
- stmt <- c'stmtInit conn
- res <- c'stmtPrepare stmt sql len
- if res == 0
- then return stmt
- else do
- _ <- c'stmtClose stmt
- tellError conn $ "prepare " ++ sql'
-finalize :: Statement -> IO ()
-finalize stmt = c'stmtClose stmt >> return ()
-
-foreign import ccall "mysql_stmt_execute"
- execute :: Statement -> IO ()
-
-foreign import ccall "mysql_stmt_bind_param"
- c'bindParam :: Statement -> Bind -> IO CInt
-bindParams :: Statement -> [PersistValue] -> IO ()
-bindParams _ _ = error "bindParams"
-
-foreign import ccall "mysql_stmt_reset"
- reset :: Statement -> IO ()
@@ -1,97 +0,0 @@
-{-# LANGUAGE PackageImports #-}
-module Database.Persist.Mysql
- ( withMysqlPool
- , withMysqlConn
- , MysqlSettings (..)
- , module Database.Persist
- , module Database.Persist.GenericSql
- ) where
-
-import Database.Persist
-import Database.Persist.Base
-import Database.Persist.GenericSql
-import Database.Persist.GenericSql.Internal
-import Database.Mysql (MysqlSettings (..))
-import qualified Database.Mysql as M
-
-import Control.Monad.IO.Class (MonadIO (..))
-import "MonadCatchIO-transformers" Control.Monad.CatchIO
-import Data.IORef
-import qualified Data.Map as Map
-import Data.List (intercalate)
-
-withMysqlPool :: MonadCatchIO m
- => MysqlSettings
- -> Int -- ^ number of connections to open
- -> (ConnectionPool -> m a) -> m a
-withMysqlPool s = withSqlPool $ open' s
-
-withMysqlConn :: MonadCatchIO m
- => MysqlSettings -> (Connection -> m a) -> m a
-withMysqlConn = withSqlConn . open'
-
-open' :: MysqlSettings -> IO Connection
-open' s = do
- conn <- M.open s
- smap <- newIORef $ Map.empty
- return Connection
- { prepare = prepare' conn
- , stmtMap = smap
- , insertSql = insertSql'
- , close = M.close conn
- , migrateSql = migrate'
- , begin = helper "BEGIN"
- , commit = helper "COMMIT"
- , rollback = helper "ROLLBACK"
- }
- where
- helper t getter = do
- stmt <- getter t
- execute stmt []
-
-insertSql' :: String -> [String] -> Either String (String, String)
-insertSql' t cols =
- Right (ins, sel)
- where
- sel = "SELECT LAST_INSERT_ID()"
- ins = concat
- [ "INSERT INTO "
- , t
- , "("
- , intercalate "," cols
- , ") VALUES("
- , intercalate "," (map (const "?") cols)
- , ")"
- ]
-
-prepare' :: M.Connection -> String -> IO Statement
-prepare' conn sql = do
- stmt <- M.prepare conn sql
- return Statement
- { finalize = M.finalize stmt
- , reset = M.reset stmt
- , execute = execute' stmt
- , withStmt = withStmt' stmt
- }
-
-execute' :: M.Statement -> [PersistValue] -> IO ()
-execute' stmt vals = do
- M.bindParams stmt vals
- M.execute stmt
-
-withStmt' :: MonadCatchIO m => M.Statement -> [PersistValue]
- -> (RowPopper m -> m a) -> m a
-withStmt' stmt vals f = do
- liftIO $ M.bindParams stmt vals
- liftIO $ M.execute stmt
- res <- f go
- liftIO $ M.reset stmt
- return res
- where
- go = return Nothing -- FIXME
-
-migrate' :: PersistEntity val
- => (String -> IO Statement)
- -> val
- -> IO (Either [String] [(Bool, String)])
-migrate' = undefined
View
@@ -1,20 +0,0 @@
-Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
-
-Permission is hereby granted, free of charge, to any person obtaining
-a copy of this software and associated documentation files (the
-"Software"), to deal in the Software without restriction, including
-without limitation the rights to use, copy, modify, merge, publish,
-distribute, sublicense, and/or sell copies of the Software, and to
-permit persons to whom the Software is furnished to do so, subject to
-the following conditions:
-
-The above copyright notice and this permission notice shall be
-included in all copies or substantial portions of the Software.
-
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
@@ -1,30 +0,0 @@
-name: persistent-mysql
-version: 0.2.0
-license: MIT
-license-file: LICENSE
-author: Michael Snoyman <michael@snoyman.com>
-maintainer: Michael Snoyman <michael@snoyman.com>
-synopsis: Backend for the persistent library using MySQL.
-category: Database
-stability: Stable
-cabal-version: >= 1.6
-build-type: Simple
-homepage: http://docs.yesodweb.com/persistent/
-
-library
- build-depends: base >= 4 && < 5,
- template-haskell >= 2.4 && < 2.5,
- bytestring >= 0.9.1
- transformers >= 0.2.1 && < 0.4,
- MonadCatchIO-transformers >= 0.2.2 && < 0.3,
- utf8-string >= 0.3.4 && < 0.4,
- persistent >= 0.2.0 && < 0.3,
- containers >= 0.2 && < 0.4
- exposed-modules: Database.Mysql
- Database.Persist.Mysql
- ghc-options: -Wall
- extra-libraries: mysqlclient
-
-source-repository head
- type: git
- location: git://github.com/snoyberg/persistent.git
@@ -1,107 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE PackageImports #-}
--- | A redis backend for persistent.
-module Database.Persist.Redis
- ( RedisReader
- , runRedis
- , withRedis
- , Connection
- , Pool
- , module Database.Persist
- ) where
-
-import Database.Persist
-import Database.Persist.Base
-import Database.Persist.Pool
-import Control.Monad.Trans.Reader
-import Control.Monad.IO.Class (MonadIO (..))
-import Control.Monad.Trans.Class (MonadTrans (..))
-import "MonadCatchIO-transformers" Control.Monad.CatchIO
-import qualified Database.Redis.Redis as R
-import Control.Applicative (Applicative)
-import Control.Monad (forM_, forM)
-import Database.Redis.ByteStringClass
-import qualified Data.ByteString.UTF8 as SU
-import Data.Maybe (fromMaybe, mapMaybe)
-
--- FIXME make more intelligent
-instance BS PersistValue where
- toBS = SU.fromString . show
- fromBS = read . SU.toString
-
-type Connection = R.Redis
-
--- | A ReaderT monad transformer holding a sqlite database connection.
-newtype RedisReader m a = RedisReader (ReaderT Connection m a)
- deriving (Monad, MonadIO, MonadTrans, MonadCatchIO, Functor,
- Applicative)
-
--- | Handles opening and closing of the database connection pool automatically.
-withRedis :: MonadCatchIO m
- => String -- ^ hostname
- -> String -- ^ port
- -> Int -- ^ number of connections to open
- -> (Pool Connection -> m a) -> m a
-withRedis host port i f = createPool (R.connect host port) R.disconnect i f
-
--- | Run a series of database actions. Remember, redis does not support
--- transactions, so nothing will be rolled back on exceptions.
-runRedis :: MonadCatchIO m => RedisReader m a -> Pool Connection -> m a
-runRedis (RedisReader r) pconn = withPool' pconn $ runReaderT r
-
-dummyFromKey :: Key v -> v
-dummyFromKey _ = error "dummyFromKey"
-
-dummyFromFilts :: [Filter v] -> v
-dummyFromFilts _ = error "dummyFromFilts"
-
-instance MonadIO m => PersistBackend (RedisReader m) where
- initialize _ = return ()
- insert val = do
- r <- RedisReader ask
- let t = entityDef val
- let name = entityName t
- R.RInt i <- liftIO $ R.incr r $ "global:" ++ name ++ ":nextId"
- let i' = toPersistKey $ fromIntegral i
- replace i' val
- return i'
- replace i' val = do
- let i = show $ fromPersistKey i'
- r <- RedisReader ask
- let t = entityDef val
- let name = entityName t
- let vals = map toPersistValue $ toPersistFields val
- let cols = map (\(x, _, _) -> x) $ entityColumns $ entityDef val
- liftIO $ forM_ (zip cols vals) $ \(col, val) ->
- R.set r (name ++ ":by-id:" ++ i ++ ":" ++ col) val
- liftIO $ R.sadd r (name ++ ":ids") i
- return ()
- get eid' = do
- r <- RedisReader ask
- let def = entityDef $ dummyFromKey eid'
- let name = entityName def
- let eid = show $ fromPersistKey eid'
- let cols = map (\(x, _, _) -> x) $ entityColumns def
- R.RInt exists <- liftIO $ R.sismember r (name ++ ":ids") eid
- if exists == 0
- then return Nothing
- else do
- let go s = do
- R.RBulk x <- R.get r $ name ++ ":by-id:" ++ eid ++ ":" ++ s
- return $ fromMaybe PersistNull x
- vals <- liftIO $ mapM go cols
- case fromPersistValues vals of
- Left s -> error s
- Right x -> return $ Just x
- select filts ords = do
- r <- RedisReader ask
- let def = entityDef $ dummyFromFilts filts
- let name = entityName def
- R.RMulti x <- liftIO $ R.smembers r $ name ++ ":ids"
- let go (R.RBulk (Just s)) = Just $ toPersistKey $ read s
- go _ = Nothing
- let ids = maybe [] (mapMaybe go) x
- forM ids $ \i -> do
- Just val <- get i
- return (i, val)
- -- FIXME apply filters and orders
View
@@ -1,20 +0,0 @@
-Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
-
-Permission is hereby granted, free of charge, to any person obtaining
-a copy of this software and associated documentation files (the
-"Software"), to deal in the Software without restriction, including
-without limitation the rights to use, copy, modify, merge, publish,
-distribute, sublicense, and/or sell copies of the Software, and to
-permit persons to whom the Software is furnished to do so, subject to
-the following conditions:
-
-The above copyright notice and this permission notice shall be
-included in all copies or substantial portions of the Software.
-
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
-OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
Oops, something went wrong.

0 comments on commit c2e2ef7

Please sign in to comment.