Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

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...
commit df1e65cc0fdfa93d5d5776315d8113384844802d 2 parents 969c4c3 + 5b3cb8a
Michael Snoyman snoyberg authored
2  persistent-mongoDB/Database/Persist/MongoDB.hs
@@ -468,7 +468,7 @@ instance DB.Val PersistValue where
468 468 val (PersistNull) = DB.Null
469 469 val (PersistList l) = DB.Array $ map DB.val l
470 470 val (PersistMap m) = DB.Doc $ map (\(k, v)-> (DB.=:) (textToCS k) v) m
471   - val (PersistByteString x) = DB.String $ CS.fromByteString_ x
  471 + val (PersistByteString x) = DB.Bin (DB.Binary x)
472 472 val x@(PersistObjectId _) = DB.ObjId $ persistObjectIdToDbOid x
473 473 val (PersistDay _) = throw $ PersistMongoDBUnsupported "only PersistUTCTime currently implemented"
474 474 val (PersistTimeOfDay _) = throw $ PersistMongoDBUnsupported "only PersistUTCTime currently implemented"
8 persistent-mysql/Database/Persist/MySQL.hs
@@ -704,10 +704,12 @@ refName (DBName table) (DBName column) =
704 704
705 705
706 706 -- | Escape a database name to be included on a query.
707   ---
708   --- FIXME: Can we do better here?
709 707 escapeDBName :: DBName -> String
710   -escapeDBName (DBName s) = T.unpack s
  708 +escapeDBName (DBName s) = '`' : go (T.unpack s)
  709 + where
  710 + go ('`':xs) = '`' : '`' : go xs
  711 + go ( x :xs) = x : go xs
  712 + go "" = "`"
711 713
712 714 -- | Information required to connect to a MySQL database
713 715 -- using @persistent@'s generic facilities. These values are the
1  persistent-template/persistent-template.cabal
@@ -11,6 +11,7 @@ stability: Stable
11 11 cabal-version: >= 1.8
12 12 build-type: Simple
13 13 homepage: http://www.yesodweb.com/book/persistent
  14 +extra-source-files: test/main.hs
14 15
15 16 library
16 17 build-depends: base >= 4 && < 5
1  persistent-template/test/main.hs
... ... @@ -1,4 +1,5 @@
1 1 {-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies, GADTs #-}
  2 +{-# LANGUAGE EmptyDataDecls #-}
2 3 import Test.Hspec.Monadic
3 4 import Test.Hspec.QuickCheck
4 5 import Test.Hspec.HUnit()
25 persistent-test/DataTypeTest.hs
@@ -16,9 +16,6 @@ import Database.Persist.TH
16 16 #if WITH_POSTGRESQL
17 17 import Database.Persist.Postgresql
18 18 #endif
19   -#if WITH_MYSQL
20   -import Database.Persist.MySQL
21   -#endif
22 19 import Data.Char (generalCategory, GeneralCategory(..))
23 20 import Data.Text (Text)
24 21 import qualified Data.Text as T
@@ -27,6 +24,7 @@ import qualified Data.ByteString as S
27 24 import Data.Time (Day, TimeOfDay (..), UTCTime (..), fromGregorian)
28 25 import System.Random (randomIO, randomRIO, Random)
29 26 import Control.Applicative ((<$>), (<*>))
  27 +import Control.Monad (when)
30 28 import Data.Word (Word8)
31 29
32 30 import Init
@@ -40,11 +38,13 @@ share [mkPersist sqlSettings, mkMigrate "dataTypeMigrate"] [persistLowerCase|
40 38 DataTypeTable no-json
41 39 text Text
42 40 bytes ByteString
43   - intx Int
44   - doublex Double
  41 + int Int
  42 + double Double
45 43 bool Bool
  44 +#ifndef WITH_MONGODB
46 45 day Day
47 46 time TimeOfDay
  47 +#endif
48 48 utc UTCTime
49 49 |]
50 50
@@ -62,9 +62,7 @@ specs = describe "data type specs" $ do
62 62 #endif
63 63 sequence_ $ replicate 1000 $ do
64 64 x <- liftIO randomValue
65   - _key <- insert x
66   - return ()
67   - {-
  65 + key <- insert x
68 66 Just y <- get key
69 67 liftIO $ do
70 68 let check :: (Eq a, Show a) => String -> (DataTypeTable -> a) -> IO ()
@@ -72,17 +70,18 @@ specs = describe "data type specs" $ do
72 70 -- Check individual fields for better error messages
73 71 check "text" dataTypeTableText
74 72 check "bytes" dataTypeTableBytes
75   - check "int" dataTypeTableIntx
  73 + check "int" dataTypeTableInt
76 74 check "bool" dataTypeTableBool
  75 +#ifndef WITH_MONGODB
77 76 check "day" dataTypeTableDay
78 77 check "time" dataTypeTableTime
  78 +#endif
79 79 check "utc" dataTypeTableUtc
80 80
81 81 -- Do a special check for Double since it may
82 82 -- lose precision when serialized.
83   - when (abs (dataTypeTableDoublex x - dataTypeTableDoublex y) > 1e-14) $
84   - check "double" dataTypeTableDoublex
85   - -}
  83 + when (abs (dataTypeTableDouble x - dataTypeTableDouble y) > 1e-14) $
  84 + check "double" dataTypeTableDouble
86 85
87 86 randomValue :: IO DataTypeTable
88 87 randomValue = DataTypeTable
@@ -95,8 +94,10 @@ randomValue = DataTypeTable
95 94 <*> randomIO
96 95 <*> randomIO
97 96 <*> randomIO
  97 +#ifndef WITH_MONGODB
98 98 <*> randomDay
99 99 <*> randomTime
  100 +#endif
100 101 <*> randomUTC
101 102 where forbidden = [NotAssigned, PrivateUse]
102 103
6 persistent-test/HtmlTest.hs
@@ -17,9 +17,6 @@ import Database.Persist.TH
17 17 #if WITH_POSTGRESQL
18 18 import Database.Persist.Postgresql
19 19 #endif
20   -#if WITH_MYSQL
21   -import Database.Persist.MySQL
22   -#endif
23 20 import Data.Char (generalCategory, GeneralCategory(..))
24 21 import qualified Data.Text as T
25 22 import System.Random (randomIO, randomRIO, Random)
@@ -43,10 +40,11 @@ cleanDB = do
43 40 specs :: Specs
44 41 specs = describe "html" $ do
45 42 it "works" $ asIO $ runConn $ do
  43 +#ifndef WITH_MONGODB
46 44 _ <- runMigrationSilent htmlMigrate
47   -
48 45 -- Ensure reading the data from the database works...
49 46 _ <- runMigrationSilent htmlMigrate
  47 +#endif
50 48
51 49 sequence_ $ replicate 1000 $ do
52 50 x <- liftIO randomValue
9 persistent-test/PersistentTest.hs
@@ -69,7 +69,9 @@ import qualified Control.Monad.IO.Control
69 69 import Data.Text (Text)
70 70 import Web.PathPieces (PathPiece (..))
71 71 import Data.Maybe (fromJust)
  72 +import qualified Data.HashMap.Lazy as M
72 73 import Init
  74 +import Data.Aeson
73 75
74 76 data PetType = Cat | Dog
75 77 deriving (Show, Read, Eq)
@@ -84,7 +86,7 @@ share [mkPersist sqlSettings, mkMigrate "testMigrate", mkDeleteCascade] [persis
84 86 -- Dedented comment
85 87 -- Header-level comment
86 88 -- Indented comment
87   - Person
  89 + Person json
88 90 name String
89 91 age Int "some ignored -- \" attribute"
90 92 color String Maybe -- this is a comment sql=foobarbaz
@@ -514,6 +516,11 @@ specs = describe "persistent" $ do
514 516 x <- selectList [PersonId <-. [pid1, pid3]] []
515 517 liftIO $ x @?= [(Entity pid1 p1), (Entity pid3 p3)]
516 518
  519 + it "serializes to JSON" $ do
  520 + toJSON (Person "D" 0 Nothing) @?=
  521 + Object (M.fromList [("color",Null),("name",String "D"),("age",Number 0)])
  522 +
  523 +
517 524
518 525 #ifndef WITH_MONGODB
519 526 it "rawSql/2+2" $ db $ do
3  persistent-test/RenameTest.hs
@@ -24,9 +24,6 @@ import qualified Data.Conduit.List as CL
24 24 #if WITH_POSTGRESQL
25 25 import Database.Persist.Postgresql
26 26 #endif
27   -#if WITH_MYSQL
28   -import Database.Persist.MySQL
29   -#endif
30 27 import qualified Data.Map as Map
31 28 import qualified Data.Text as T
32 29
2  persistent-test/test/main.hs
@@ -52,5 +52,3 @@ main = do
52 52 EmbedTest.specs >>
53 53 LargeNumberTest.specs >>
54 54 MaxLenTest.specs
55   -
56   - exitWith ExitSuccess
17 persistent/Database/Persist/Store.hs
@@ -398,8 +398,9 @@ class PersistEntity val where
398 398 instance PersistField a => PersistField [a] where
399 399 toPersistValue = PersistList . map toPersistValue
400 400 fromPersistValue (PersistList l) = fromPersistList l
401   - fromPersistValue (PersistText t)
402   - | Just values <- A.decode' (L.fromChunks [TE.encodeUtf8 t]) = fromPersistList values
  401 + fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t)
  402 + fromPersistValue (PersistByteString bs)
  403 + | Just values <- A.decode' (L.fromChunks [bs]) = fromPersistList values
403 404 fromPersistValue x = Left $ "Expected PersistList, received: " ++ show x
404 405 sqlType _ = SqlString
405 406
@@ -407,10 +408,11 @@ instance (Ord a, PersistField a) => PersistField (S.Set a) where
407 408 toPersistValue = PersistList . map toPersistValue . S.toList
408 409 fromPersistValue (PersistList list) =
409 410 either Left (Right . S.fromList) $ fromPersistList list
410   - fromPersistValue (PersistText t)
411   - | Just values <- A.decode' (L.fromChunks [TE.encodeUtf8 t]) =
  411 + fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t)
  412 + fromPersistValue (PersistByteString bs)
  413 + | Just values <- A.decode' (L.fromChunks [bs]) =
412 414 either Left (Right . S.fromList) $ fromPersistList values
413   - fromPersistValue x = Left $ "Expected PersistList, received: " ++ show x
  415 + fromPersistValue x = Left $ "Expected PersistSet, received: " ++ show x
414 416 sqlType _ = SqlString
415 417
416 418 fromPersistList :: PersistField a => [PersistValue] -> Either T.Text [a]
@@ -433,8 +435,9 @@ instance PersistField v => PersistField (M.Map T.Text v) where
433 435
434 436 getPersistMap :: PersistValue -> Either T.Text [(T.Text, PersistValue)]
435 437 getPersistMap (PersistMap kvs) = Right kvs
436   -getPersistMap (PersistText t)
437   - | Just pairs <- A.decode' (L.fromChunks [TE.encodeUtf8 t]) = Right pairs
  438 +getPersistMap (PersistText t) = getPersistMap (PersistByteString $ TE.encodeUtf8 t)
  439 +getPersistMap (PersistByteString bs)
  440 + | Just pairs <- A.decode' (L.fromChunks [bs]) = Right pairs
438 441 getPersistMap x = Left $ "Expected PersistMap, received: " ++ show x
439 442
440 443 fromPersistMap :: PersistField v
2  scripts
... ... @@ -1 +1 @@
1   -Subproject commit d4cb555ca5fd6bc67f7da484a63d1fcdb149eac9
  1 +Subproject commit 6c10efccbad0cf12be2339171d931aeb035ef5dd
13 sources.txt
... ... @@ -1,6 +1,7 @@
1   -pool
2   -persistent
3   -persistent-template
4   -persistent-sqlite
5   -persistent-postgresql
6   -persistent-mongoDB
  1 +./pool-conduit
  2 +./persistent
  3 +./persistent-template
  4 +./persistent-sqlite
  5 +./persistent-postgresql
  6 +./persistent-mysql
  7 +./persistent-mongoDB

0 comments on commit df1e65c

Please sign in to comment.
Something went wrong with that request. Please try again.