Merge pull request yesodweb#45 from meteficha/persistent-mysql-rebased

New package persistent-mysql.

persistent-mysql/LICENSE

@@ -0,0 +1,25 @@
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
+
+Copyright 2012, Felipe Lessa. All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+  this list of conditions and the following disclaimer in the documentation
+  and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

persistent-mysql/Setup.lhs

@@ -0,0 +1,7 @@
+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain

persistent-mysql/persistent-mysql.cabal

@@ -0,0 +1,44 @@
+name:            persistent-mysql
+version:         0.0
+license:         BSD3
+license-file:    LICENSE
+author:          Felipe Lessa <[email protected]>, Michael Snoyman
+maintainer:      Felipe Lessa <[email protected]>
+synopsis:        Backend for the persistent library using MySQL database server.
+category:        Database, Yesod
+stability:       Stable
+cabal-version:   >= 1.6
+build-type:      Simple
+homepage:        http://www.yesodweb.com/book/persistent
+description:
+    This package contains a backend for persistent using the
+    MySQL database server.  Internally it uses the @mysql-simple@
+    and @mysql@ packages in order to access the database.
+    .
+    This package supports only MySQL 5.1 and above.  However, it
+    has been tested only on MySQL 5.5.
+    .
+    Known problems:
+    .
+    * This package does not support statements inside other
+      statements.
+
+library
+    build-depends:   base                  >= 4        && < 5
+                   , transformers          >= 0.2.1    && < 0.3
+                   , mysql-simple          >= 0.2.2.3  && < 0.3
+                   , mysql                 >= 0.1.1.3  && < 0.2
+                   , persistent            >= 0.7      && < 0.8
+                   , containers            >= 0.2
+                   , bytestring            >= 0.9      && < 0.10
+                   , text                  >= 0.7      && < 0.12
+                   , monad-control         >= 0.2      && < 0.4
+                   , time                  >= 1.1
+                   , aeson                 >= 0.5
+                   , conduit               >= 0.2
+    exposed-modules: Database.Persist.MySQL
+    ghc-options:     -Wall
+
+source-repository head
+  type:     git
+  location: git://github.com/yesodweb/persistent.git

persistent-test/DataTypeTest.hs

@@ -16,6 +16,10 @@ import Database.Persist.TH
 #if WITH_POSTGRESQL
 import Database.Persist.Postgresql
 #endif
+#if WITH_MYSQL
+import Database.Persist.MySQL
+#endif
+import Data.Char (generalCategory, GeneralCategory(..))
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.ByteString (ByteString)
@@ -33,8 +37,8 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
 DataTypeTable
     text Text
     bytes ByteString
-    int Int
-    double Double
+    intx Int
+    doublex Double
     bool Bool
     day Day
     time TimeOfDay
@@ -58,27 +62,32 @@ dataTypeSpecs = describe "data type specs" $ do
                 -- Check individual fields for better error messages
                 check "text" dataTypeTableText
                 check "bytes" dataTypeTableBytes
-                check "int" dataTypeTableInt
+                check "int" dataTypeTableIntx
                 check "bool" dataTypeTableBool
                 check "day" dataTypeTableDay
                 check "time" dataTypeTableTime
                 check "utc" dataTypeTableUtc
 
                 -- Do a special check for Double since it may
                 -- lose precision when serialized.
-                when (abs (dataTypeTableDouble x - dataTypeTableDouble y) > 1e-14) $
-                  check "double" dataTypeTableDouble
+                when (abs (dataTypeTableDoublex x - dataTypeTableDoublex y) > 1e-14) $
+                  check "double" dataTypeTableDoublex
 
 randomValue :: IO DataTypeTable
 randomValue = DataTypeTable
-    <$> (T.pack . filter (/= '\0') <$> randomIOs)
+    <$> (T.pack
+              . filter ((`notElem` forbidden) . generalCategory)
+              . filter (<= '\xFFFF') -- only BMP
+              . filter (/= '\0')     -- no nulls
+         <$> randomIOs)
     <*> (S.pack . map intToWord8 <$> randomIOs)
     <*> randomIO
     <*> randomIO
     <*> randomIO
     <*> randomDay
     <*> randomTime
     <*> randomUTC
+    where forbidden = [NotAssigned, PrivateUse]
 
 asIO :: IO a -> IO a
 asIO = id

persistent-test/PersistentTest.hs

@@ -42,12 +42,15 @@ import Control.Monad (replicateM)
 import qualified Data.ByteString as BS
 
 #else
-import Database.Persist.EntityDef (EntityDef(..))
+import Database.Persist.EntityDef (EntityDef(..), DBName(..))
 import Database.Persist.Store ( DeleteCascade (..) )
 import Database.Persist.GenericSql
+import Database.Persist.GenericSql.Internal (escapeName)
 import qualified Database.Persist.Query.Join.Sql
 import Database.Persist.Sqlite
 import Control.Exception (SomeException)
+import Control.Monad.Trans.Reader (ask)
+import qualified Data.Text as T
 #if MIN_VERSION_monad_control(0, 3, 0)
 import qualified Control.Exception as E
 #define CATCH catch'
@@ -62,6 +65,9 @@ import Control.Monad.Trans.Resource (ResourceIO)
 #if WITH_POSTGRESQL
 import Database.Persist.Postgresql
 #endif
+#if WITH_MYSQL
+import Database.Persist.MySQL
+#endif
 
 #endif
 
@@ -146,7 +152,7 @@ share [mkPersist sqlSettings,  mkMigrate "testMigrate", mkDeleteCascade] [persis
   NeedsPet
     petKey PetId
   Number
-    int Int
+    intx Int
     int32 Int32
     word32 Word32
     int64 Int64
@@ -219,6 +225,14 @@ runConn f = do
     _<-withSqlitePool sqlite_database 1 $ runSqlPool f
 #if WITH_POSTGRESQL
     _<-withPostgresqlPool "host=localhost port=5432 user=test dbname=test password=test" 1 $ runSqlPool f
+#endif
+#if WITH_MYSQL
+    _ <- withMySQLPool defaultConnectInfo
+                        { connectHost     = "localhost"
+                        , connectUser     = "test"
+                        , connectPassword = "test"
+                        , connectDatabase = "test"
+                        } 1 $ runSqlPool f
 #endif
     return ()
 
@@ -608,7 +622,7 @@ specs = describe "persistent" $ do
       -- limit
       ps2 <- selectList [] [LimitTo 1]
       ps2 @== [(Entity key25 p25)]
-      -- offset -- FAILS!
+      -- offset
       ps3 <- selectList [] [OffsetBy 1]
       ps3 @== [(Entity key26 p26)]
       -- limit & offset
@@ -746,16 +760,29 @@ specs = describe "persistent" $ do
       (a2k, a2) <- insert' $ Pet p1k "Zeno"    Cat
       (a3k, a3) <- insert' $ Pet p2k "Lhama"   Dog
       (_  , _ ) <- insert' $ Pet p3k "Abacate" Cat
-      ret <- rawSql "SELECT ??, ?? FROM \"Person\", \"Pet\" WHERE \"Person\".age >= ? AND \"Pet\".\"ownerId\" = \"Person\".id ORDER BY \"Person\".name, \"Pet\".name" [PersistInt64 20]
+      escape <- ((. DBName) . escapeName) `fmap` SqlPersist ask
+      let query = T.concat [ "SELECT ??, ?? "
+                           , "FROM ", escape "Person"
+                           , ", ", escape "Pet"
+                           , " WHERE ", escape "Person", ".", escape "age", " >= ? "
+                           , "AND ", escape "Pet", ".", escape "ownerId", " = "
+                                   , escape "Person", ".", escape "id"
+                           , " ORDER BY ", escape "Person", ".", escape "name"
+                           ]
+      ret <- rawSql query [PersistInt64 20]
       liftIO $ ret @?= [ (Entity p1k p1, Entity a1k a1)
                        , (Entity p1k p1, Entity a2k a2)
                        , (Entity p2k p2, Entity a3k a3) ]
 
   it "rawSql/order-proof" $ db $ do
       let p1 = Person "Zacarias" 93 Nothing
       p1k <- insert p1
-      ret1 <- rawSql "SELECT ?? FROM \"Person\"" []
-      ret2 <- rawSql "SELECT ?? FROM \"Person\"" []
+      escape <- ((. DBName) . escapeName) `fmap` SqlPersist ask
+      let query = T.concat [ "SELECT ?? "
+                           , "FROM ", escape "Person"
+                           ]
+      ret1 <- rawSql query []
+      ret2 <- rawSql query []
       liftIO $ ret1 @?= [Entity p1k p1]
       liftIO $ ret2 @?= [Entity (Key $ unKey p1k) (RFO p1)]
 

persistent-test/RenameTest.hs

@@ -18,6 +18,9 @@ import Database.Persist.GenericSql.Raw
 #if WITH_POSTGRESQL
 import Database.Persist.Postgresql
 #endif
+#if WITH_MYSQL
+import Database.Persist.MySQL
+#endif
 import qualified Data.Conduit as C
 import qualified Data.Conduit.List as CL
 import qualified Data.Map as Map
@@ -44,6 +47,14 @@ runConn2 f = do
     _ <- withSqlitePool ":memory:" 1 $ runSqlPool f
 #if WITH_POSTGRESQL
     _ <- withPostgresqlPool "host=localhost port=5432 user=test dbname=test password=test" 1 $ runSqlPool f
+#endif
+#if WITH_MYSQL
+    _ <- withMySQLPool defaultConnectInfo
+                        { connectHost     = "localhost"
+                        , connectUser     = "test"
+                        , connectPassword = "test"
+                        , connectDatabase = "test"
+                        } 1 $ runSqlPool f
 #endif
     return ()
 

persistent-test/persistent-mysql

@@ -0,0 +1 @@
+../persistent-mysql/

persistent-test/persistent-test.cabal

@@ -24,6 +24,10 @@ Flag postgresql
    Description: test postgresql. default is to test just sqlite.
    Default: False
 
+Flag mysql
+   Description: test MySQL
+   Default: False
+
 library
     extra-libraries: sqlite3
 
@@ -50,6 +54,7 @@ library
                      Database.Persist.Sqlite
                      Database.Sqlite
                      Database.Persist.Postgresql
+                     Database.Persist.MySQL
 
                      Database.Persist.MongoDB
 
@@ -67,7 +72,7 @@ library
                    , monad-control
                    , containers
                    , bytestring
-                   , conduit
+                   , conduit >= 0.2
                    , time >= 1.2
                    , random == 1.*
                    , QuickCheck == 2.4.*
@@ -79,12 +84,16 @@ library
                    , postgresql-simple     >= 0.0      && < 1.0
                    , postgresql-libpq      >= 0.6
 
+                   -- MySQL dependencies
+                   , mysql-simple          >= 0.2.2.3  && < 0.3
+                   , mysql                 >= 0.1.1.3  && < 0.2
+
                    -- mongoDB dependencies
                    , mongoDB       == 1.2.*
                    , cereal
                    , compact-string-fix
                    , bson
-    hs-source-dirs: ., persistent, persistent-template, persistent-sqlite, persistent-postgresql, persistent-mongoDB
+    hs-source-dirs: ., persistent, persistent-template, persistent-sqlite, persistent-postgresql, persistent-mysql, persistent-mongoDB
 
     ghc-options:   -Wall
 
@@ -95,6 +104,9 @@ library
 --    else
 --        if flag(postgresql)
 --            cpp-options: -DWITH_POSTGRESQL
+--        else
+--            if flag(mysql)
+--                cpp-options: -DWITH_MYSQL
 
 test-suite test
     type:          exitcode-stdio-1.0
@@ -112,6 +124,9 @@ test-suite test
 --    else
 --        if flag(postgresql)
 --            cpp-options: -DWITH_POSTGRESQL
+--        else
+--            if flag(mysql)
+--                cpp-options: -DWITH_MYSQL
 
 
 source-repository head

persistent/Database/Persist/GenericSql/Internal.hs

@@ -140,6 +140,7 @@ data Column = Column
     , cDefault   :: Maybe Text
     , cReference :: (Maybe (DBName, DBName)) -- table name, constraint name
     }
+    deriving (Eq, Ord, Show)
 
 {- FIXME
 getSqlValue :: [String] -> Maybe String

persistent/Database/Persist/Store.hs

@@ -134,7 +134,7 @@ data SqlType = SqlString
              | SqlTime
              | SqlDayTime
              | SqlBlob
-    deriving (Show, Read, Eq, Typeable)
+    deriving (Show, Read, Eq, Typeable, Ord)
 
 -- | A value which can be marshalled to and from a 'PersistValue'.
 class PersistField a where