Permalink
Browse files

Merge branch 'master' into conduit-0.3

Conflicts:
	persistent-mysql/persistent-mysql.cabal
	persistent-template/persistent-template.cabal
	persistent-test/DataTypeTest.hs
	persistent/persistent.cabal
  • Loading branch information...
2 parents 969c4c3 + 5b3cb8a commit df1e65cc0fdfa93d5d5776315d8113384844802d @snoyberg snoyberg committed Mar 12, 2012
View
2 persistent-mongoDB/Database/Persist/MongoDB.hs
@@ -468,7 +468,7 @@ instance DB.Val PersistValue where
val (PersistNull) = DB.Null
val (PersistList l) = DB.Array $ map DB.val l
val (PersistMap m) = DB.Doc $ map (\(k, v)-> (DB.=:) (textToCS k) v) m
- val (PersistByteString x) = DB.String $ CS.fromByteString_ x
+ val (PersistByteString x) = DB.Bin (DB.Binary x)
val x@(PersistObjectId _) = DB.ObjId $ persistObjectIdToDbOid x
val (PersistDay _) = throw $ PersistMongoDBUnsupported "only PersistUTCTime currently implemented"
val (PersistTimeOfDay _) = throw $ PersistMongoDBUnsupported "only PersistUTCTime currently implemented"
View
8 persistent-mysql/Database/Persist/MySQL.hs
@@ -704,10 +704,12 @@ refName (DBName table) (DBName column) =
-- | Escape a database name to be included on a query.
---
--- FIXME: Can we do better here?
escapeDBName :: DBName -> String
-escapeDBName (DBName s) = T.unpack s
+escapeDBName (DBName s) = '`' : go (T.unpack s)
+ where
+ go ('`':xs) = '`' : '`' : go xs
+ go ( x :xs) = x : go xs
+ go "" = "`"
-- | Information required to connect to a MySQL database
-- using @persistent@'s generic facilities. These values are the
View
1 persistent-template/persistent-template.cabal
@@ -11,6 +11,7 @@ stability: Stable
cabal-version: >= 1.8
build-type: Simple
homepage: http://www.yesodweb.com/book/persistent
+extra-source-files: test/main.hs
library
build-depends: base >= 4 && < 5
View
1 persistent-template/test/main.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies, GADTs #-}
+{-# LANGUAGE EmptyDataDecls #-}
import Test.Hspec.Monadic
import Test.Hspec.QuickCheck
import Test.Hspec.HUnit()
View
25 persistent-test/DataTypeTest.hs
@@ -16,9 +16,6 @@ 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
@@ -27,6 +24,7 @@ import qualified Data.ByteString as S
import Data.Time (Day, TimeOfDay (..), UTCTime (..), fromGregorian)
import System.Random (randomIO, randomRIO, Random)
import Control.Applicative ((<$>), (<*>))
+import Control.Monad (when)
import Data.Word (Word8)
import Init
@@ -40,11 +38,13 @@ share [mkPersist sqlSettings, mkMigrate "dataTypeMigrate"] [persistLowerCase|
DataTypeTable no-json
text Text
bytes ByteString
- intx Int
- doublex Double
+ int Int
+ double Double
bool Bool
+#ifndef WITH_MONGODB
day Day
time TimeOfDay
+#endif
utc UTCTime
|]
@@ -62,27 +62,26 @@ specs = describe "data type specs" $ do
#endif
sequence_ $ replicate 1000 $ do
x <- liftIO randomValue
- _key <- insert x
- return ()
- {-
+ key <- insert x
Just y <- get key
liftIO $ do
let check :: (Eq a, Show a) => String -> (DataTypeTable -> a) -> IO ()
check s f = (s, f x) @=? (s, f y)
-- Check individual fields for better error messages
check "text" dataTypeTableText
check "bytes" dataTypeTableBytes
- check "int" dataTypeTableIntx
+ check "int" dataTypeTableInt
check "bool" dataTypeTableBool
+#ifndef WITH_MONGODB
check "day" dataTypeTableDay
check "time" dataTypeTableTime
+#endif
check "utc" dataTypeTableUtc
-- Do a special check for Double since it may
-- lose precision when serialized.
- when (abs (dataTypeTableDoublex x - dataTypeTableDoublex y) > 1e-14) $
- check "double" dataTypeTableDoublex
- -}
+ when (abs (dataTypeTableDouble x - dataTypeTableDouble y) > 1e-14) $
+ check "double" dataTypeTableDouble
randomValue :: IO DataTypeTable
randomValue = DataTypeTable
@@ -95,8 +94,10 @@ randomValue = DataTypeTable
<*> randomIO
<*> randomIO
<*> randomIO
+#ifndef WITH_MONGODB
<*> randomDay
<*> randomTime
+#endif
<*> randomUTC
where forbidden = [NotAssigned, PrivateUse]
View
6 persistent-test/HtmlTest.hs
@@ -17,9 +17,6 @@ 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 qualified Data.Text as T
import System.Random (randomIO, randomRIO, Random)
@@ -43,10 +40,11 @@ cleanDB = do
specs :: Specs
specs = describe "html" $ do
it "works" $ asIO $ runConn $ do
+#ifndef WITH_MONGODB
_ <- runMigrationSilent htmlMigrate
-
-- Ensure reading the data from the database works...
_ <- runMigrationSilent htmlMigrate
+#endif
sequence_ $ replicate 1000 $ do
x <- liftIO randomValue
View
9 persistent-test/PersistentTest.hs
@@ -69,7 +69,9 @@ import qualified Control.Monad.IO.Control
import Data.Text (Text)
import Web.PathPieces (PathPiece (..))
import Data.Maybe (fromJust)
+import qualified Data.HashMap.Lazy as M
import Init
+import Data.Aeson
data PetType = Cat | Dog
deriving (Show, Read, Eq)
@@ -84,7 +86,7 @@ share [mkPersist sqlSettings, mkMigrate "testMigrate", mkDeleteCascade] [persis
-- Dedented comment
-- Header-level comment
-- Indented comment
- Person
+ Person json
name String
age Int "some ignored -- \" attribute"
color String Maybe -- this is a comment sql=foobarbaz
@@ -514,6 +516,11 @@ specs = describe "persistent" $ do
x <- selectList [PersonId <-. [pid1, pid3]] []
liftIO $ x @?= [(Entity pid1 p1), (Entity pid3 p3)]
+ it "serializes to JSON" $ do
+ toJSON (Person "D" 0 Nothing) @?=
+ Object (M.fromList [("color",Null),("name",String "D"),("age",Number 0)])
+
+
#ifndef WITH_MONGODB
it "rawSql/2+2" $ db $ do
View
3 persistent-test/RenameTest.hs
@@ -24,9 +24,6 @@ import qualified Data.Conduit.List as CL
#if WITH_POSTGRESQL
import Database.Persist.Postgresql
#endif
-#if WITH_MYSQL
-import Database.Persist.MySQL
-#endif
import qualified Data.Map as Map
import qualified Data.Text as T
View
2 persistent-test/test/main.hs
@@ -52,5 +52,3 @@ main = do
EmbedTest.specs >>
LargeNumberTest.specs >>
MaxLenTest.specs
-
- exitWith ExitSuccess
View
17 persistent/Database/Persist/Store.hs
@@ -398,19 +398,21 @@ class PersistEntity val where
instance PersistField a => PersistField [a] where
toPersistValue = PersistList . map toPersistValue
fromPersistValue (PersistList l) = fromPersistList l
- fromPersistValue (PersistText t)
- | Just values <- A.decode' (L.fromChunks [TE.encodeUtf8 t]) = fromPersistList values
+ fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t)
+ fromPersistValue (PersistByteString bs)
+ | Just values <- A.decode' (L.fromChunks [bs]) = fromPersistList values
fromPersistValue x = Left $ "Expected PersistList, received: " ++ show x
sqlType _ = SqlString
instance (Ord a, PersistField a) => PersistField (S.Set a) where
toPersistValue = PersistList . map toPersistValue . S.toList
fromPersistValue (PersistList list) =
either Left (Right . S.fromList) $ fromPersistList list
- fromPersistValue (PersistText t)
- | Just values <- A.decode' (L.fromChunks [TE.encodeUtf8 t]) =
+ fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t)
+ fromPersistValue (PersistByteString bs)
+ | Just values <- A.decode' (L.fromChunks [bs]) =
either Left (Right . S.fromList) $ fromPersistList values
- fromPersistValue x = Left $ "Expected PersistList, received: " ++ show x
+ fromPersistValue x = Left $ "Expected PersistSet, received: " ++ show x
sqlType _ = SqlString
fromPersistList :: PersistField a => [PersistValue] -> Either T.Text [a]
@@ -433,8 +435,9 @@ instance PersistField v => PersistField (M.Map T.Text v) where
getPersistMap :: PersistValue -> Either T.Text [(T.Text, PersistValue)]
getPersistMap (PersistMap kvs) = Right kvs
-getPersistMap (PersistText t)
- | Just pairs <- A.decode' (L.fromChunks [TE.encodeUtf8 t]) = Right pairs
+getPersistMap (PersistText t) = getPersistMap (PersistByteString $ TE.encodeUtf8 t)
+getPersistMap (PersistByteString bs)
+ | Just pairs <- A.decode' (L.fromChunks [bs]) = Right pairs
getPersistMap x = Left $ "Expected PersistMap, received: " ++ show x
fromPersistMap :: PersistField v
2 scripts
@@ -1 +1 @@
-Subproject commit d4cb555ca5fd6bc67f7da484a63d1fcdb149eac9
+Subproject commit 6c10efccbad0cf12be2339171d931aeb035ef5dd
View
13 sources.txt
@@ -1,6 +1,7 @@
-pool
-persistent
-persistent-template
-persistent-sqlite
-persistent-postgresql
-persistent-mongoDB
+./pool-conduit
+./persistent
+./persistent-template
+./persistent-sqlite
+./persistent-postgresql
+./persistent-mysql
+./persistent-mongoDB

0 comments on commit df1e65c

Please sign in to comment.