persistent 0.7.0.1 → 0.8.0
raw patch · 11 files changed
+322/−98 lines, 11 filesdep +HUnitdep +attoparsecdep +base64-bytestringdep ~conduitdep ~containersdep ~text
Dependencies added: HUnit, attoparsec, base64-bytestring, hspec, unordered-containers, vector
Dependency ranges changed: conduit, containers, text
Files
- Database/Persist/EntityDef.hs +14/−4
- Database/Persist/GenericSql.hs +12/−6
- Database/Persist/GenericSql/Internal.hs +16/−2
- Database/Persist/GenericSql/Raw.hs +20/−14
- Database/Persist/Quasi.hs +101/−22
- Database/Persist/Query/GenericSql.hs +20/−11
- Database/Persist/Query/Internal.hs +7/−6
- Database/Persist/Query/Join.hs +2/−2
- Database/Persist/Query/Join/Sql.hs +3/−3
- Database/Persist/Store.hs +109/−26
- persistent.cabal +18/−2
Database/Persist/EntityDef.hs view
@@ -2,16 +2,18 @@ ( -- * Helper types HaskellName (..) , DBName (..)- , FieldType (..) , Attr -- * Defs , EntityDef (..) , FieldDef (..)+ , FieldType (..) , UniqueDef (..) , ExtraLine+ -- * Utils+ , stripId ) where -import Data.Text (Text)+import Data.Text (Text, stripSuffix, pack) import Data.Map (Map) data EntityDef = EntityDef@@ -32,11 +34,15 @@ deriving (Show, Eq, Read, Ord) newtype DBName = DBName { unDBName :: Text } deriving (Show, Eq, Read, Ord)-newtype FieldType = FieldType { unFieldType :: Text }- deriving (Show, Eq, Read, Ord) type Attr = Text +data FieldType+ = FTTypeCon (Maybe Text) Text -- ^ optional module, name+ | FTApp FieldType FieldType+ | FTList FieldType+ deriving (Show, Eq, Read, Ord)+ data FieldDef = FieldDef { fieldHaskell :: HaskellName , fieldDB :: DBName@@ -51,3 +57,7 @@ , uniqueFields :: [(HaskellName, DBName)] } deriving (Show, Eq, Read, Ord)++stripId :: FieldType -> Maybe Text+stripId (FTTypeCon Nothing t) = stripSuffix (pack "Id") t+stripId _ = Nothing
Database/Persist/GenericSql.hs view
@@ -106,8 +106,11 @@ i <- case esql of Left sql -> C.runResourceT $ R.withStmt sql vals C.$$ do- Just [PersistInt64 i] <- CL.head- return i+ x <- CL.head+ case x of+ Just [PersistInt64 i] -> return i+ Nothing -> error $ "SQL insert did not return a result giving the generated ID"+ Just vals' -> error $ "Invalid result from a SQL insert, got: " P.++ P.show vals' Right (sql1, sql2) -> do execute' sql1 vals C.runResourceT $ R.withStmt sql2 [] C.$$ do@@ -135,7 +138,10 @@ insertKey = insrepHelper "INSERT" - repsert = insrepHelper "REPLACE"+ repsert key value = do+ -- FIXME use this for sqlite insrepHelper "REPLACE"+ delete key+ insertKey key value get k = do conn <- SqlPersist ask@@ -385,8 +391,8 @@ -- you and automatically parses the rows of the result. It may -- return: ----- * An 'Entity', which is analogous to the tuples that--- 'selectList' returns. All of your entity's fields are+-- * An 'Entity', that which 'selectList' returns.+-- All of your entity's fields are -- automatically parsed. -- -- * A @'Single' a@, which is a single, raw column of type @a@.@@ -531,7 +537,7 @@ rawSqlProcessRow [pv] = Single <$> fromPersistValue pv rawSqlProcessRow _ = Left "RawSql (Single a): wrong number of columns." -instance PersistEntity a => RawSql (Entity backend a) where+instance PersistEntity a => RawSql (Entity a) where rawSqlCols escape = ((+1).length.entityFields &&& process) . entityDef . entityVal where process ed = (:[]) $
Database/Persist/GenericSql/Internal.hs view
@@ -16,6 +16,7 @@ ) where import qualified Data.Map as Map+import Data.Char (isSpace) import Data.IORef import Control.Monad.IO.Class import Data.Conduit.Pool@@ -107,6 +108,7 @@ (nullable $ fieldAttrs fd) (sqlType p) (def $ fieldAttrs fd)+ (maxLen $ fieldAttrs fd) (ref (fieldDB fd) (fieldType fd) (fieldAttrs fd)) def :: [Attr] -> Maybe Text@@ -115,12 +117,22 @@ | Just d <- T.stripPrefix "default=" a = Just d | otherwise = def as + maxLen :: [Attr] -> Maybe Integer+ maxLen [] = Nothing+ maxLen (a:as)+ | Just d <- T.stripPrefix "maxlen=" a =+ case reads (T.unpack d) of+ [(i, s)] | all isSpace s -> Just i+ _ -> error $ "Could not parse maxlen field with value " +++ show d ++ " on " ++ show tn+ | otherwise = maxLen as+ ref :: DBName -> FieldType -> [Attr] -> Maybe (DBName, DBName) -- table name, constraint name- ref c (FieldType t') []- | Just f <- T.stripSuffix "Id" t' =+ ref c ft []+ | Just f <- stripId ft = Just (resolveTableName allDefs $ HaskellName f, refName tn c) | otherwise = Nothing ref _ _ ("noreference":_) = Nothing@@ -138,8 +150,10 @@ , cNull :: Bool , cType :: SqlType , cDefault :: Maybe Text+ , cMaxLen :: Maybe Integer , cReference :: (Maybe (DBName, DBName)) -- table name, constraint name }+ deriving (Eq, Ord, Show) {- FIXME getSqlValue :: [String] -> Maybe String
Database/Persist/GenericSql/Raw.hs view
@@ -65,20 +65,26 @@ => Text -> [PersistValue] -> C.Source (SqlPersist m) [PersistValue]-withStmt sql vals = C.Source $ do- stmt <- lift $ getStmt sql- src <- C.prepareSource $ I.withStmt stmt vals- return C.PreparedSource- { C.sourcePull = do- res <- C.sourcePull src- case res of- C.Closed -> liftIO $ I.reset stmt- _ -> return ()- return res- , C.sourceClose = do- liftIO $ I.reset stmt- C.sourceClose src- }+withStmt sql vals = C.Source+ { C.sourcePull = do+ stmt <- lift $ getStmt sql+ let src = I.withStmt stmt vals+ pull stmt src+ , C.sourceClose = return ()+ }+ where+ pull stmt src = do+ res <- C.sourcePull src+ case res of+ C.Closed -> do+ liftIO $ I.reset stmt+ return C.Closed+ C.Open src' val -> return $ C.Open+ (C.Source (pull stmt src') (close' stmt src'))+ val+ close' stmt src = do+ liftIO $ I.reset stmt+ C.sourceClose src execute :: MonadIO m => Text -> [PersistValue] -> SqlPersist m () execute sql vals = do
Database/Persist/Quasi.hs view
@@ -1,9 +1,15 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-} module Database.Persist.Quasi ( parse , PersistSettings (..) , upperCaseSettings , lowerCaseSettings+#if TEST+ , Token (..)+ , tokenize+ , parseFieldType+#endif ) where import Prelude hiding (lines)@@ -13,8 +19,57 @@ import Data.Text (Text) import qualified Data.Text as T import Control.Arrow ((&&&))-import qualified Data.Map as Map+import qualified Data.Map as M+import Data.List (foldl') +data ParseState a = PSDone | PSFail | PSSuccess a Text++parseFieldType :: Text -> Maybe FieldType+parseFieldType t0 =+ case go t0 of+ PSSuccess ft t'+ | T.all isSpace t' -> Just ft+ _ -> Nothing+ where+ go t =+ case goMany id t of+ PSSuccess (ft:fts) t' -> PSSuccess (foldl' FTApp ft fts) t'+ PSSuccess [] _ -> PSFail+ PSFail -> PSFail+ PSDone -> PSDone+ go1 t =+ case T.uncons t of+ Nothing -> PSDone+ Just (c, t')+ | isSpace c -> go1 $ T.dropWhile isSpace t'+ | c == '(' ->+ case go t' of+ PSSuccess ft t'' ->+ case T.uncons $ T.dropWhile isSpace t'' of+ Just (')', t''') -> PSSuccess ft t'''+ _ -> PSFail+ _ -> PSFail+ | c == '[' ->+ case go t' of+ PSSuccess ft t'' ->+ case T.uncons $ T.dropWhile isSpace t'' of+ Just (']', t''') -> PSSuccess (FTList ft) t'''+ _ -> PSFail+ _ -> PSFail+ | isUpper c ->+ let (a, b) = T.break (\x -> isSpace x || x `elem` "()[]") t+ in PSSuccess (getCon a) b+ | otherwise -> PSFail+ getCon t =+ case T.breakOnEnd "." t of+ (_, "") -> FTTypeCon Nothing t+ ("", _) -> FTTypeCon Nothing t+ (a, b) -> FTTypeCon (Just $ T.init a) b+ goMany front t =+ case go1 t of+ PSSuccess x t' -> goMany (front . (x:)) t'+ _ -> PSSuccess (front []) t+ data PersistSettings = PersistSettings { psToDBName :: Text -> Text }@@ -35,7 +90,7 @@ -- | Parses a quasi-quoted syntax into a list of entity definitions. parse :: PersistSettings -> Text -> [EntityDef]-parse ps = parse' ps+parse ps = parseLines ps . removeSpaces . filter (not . empty) . map tokenize@@ -44,6 +99,7 @@ -- | A token used by the parser. data Token = Spaces !Int -- ^ @Spaces n@ are @n@ consecutive spaces. | Token Text -- ^ @Token tok@ is token @tok@ already unquoted.+ deriving (Show, Eq) -- | Tokenize a string. tokenize :: Text -> [Token]@@ -51,6 +107,7 @@ | T.null t = [] | "--" `T.isPrefixOf` t = [] -- Comment until the end of the line. | T.head t == '"' = quotes (T.tail t) id+ | T.head t == '(' = parens 1 (T.tail t) id | isSpace (T.head t) = let (spaces, rest) = T.span isSpace t in Spaces (T.length spaces) : tokenize rest@@ -63,10 +120,24 @@ "Unterminated quoted string starting with " : front [] | T.head t' == '"' = Token (T.concat $ front []) : tokenize (T.tail t') | T.head t' == '\\' && T.length t' > 1 =- quotes (T.drop 2 t') (front . (T.take 2 t':))+ quotes (T.drop 2 t') (front . (T.take 1 (T.drop 1 t'):)) | otherwise = let (x, y) = T.break (`elem` "\\\"") t' in quotes y (front . (x:))+ parens count t' front+ | T.null t' = error $ T.unpack $ T.concat $+ "Unterminated parens string starting with " : front []+ | T.head t' == ')' =+ if count == (1 :: Int)+ then Token (T.concat $ front []) : tokenize (T.tail t')+ else parens (count - 1) (T.tail t') (front . (")":))+ | T.head t' == '(' =+ parens (count + 1) (T.tail t') (front . ("(":))+ | T.head t' == '\\' && T.length t' > 1 =+ parens count (T.drop 2 t') (front . (T.take 1 (T.drop 1 t'):))+ | otherwise =+ let (x, y) = T.break (`elem` "\\()") t'+ in parens count y (front . (x:)) -- | A string of tokens is empty when it has only spaces. There -- can't be two consecutive 'Spaces', so this takes /O(1)/ time.@@ -90,18 +161,21 @@ toLine (Spaces i:rest) = toLine' i rest toLine xs = toLine' 0 xs - toLine' i = Line i . mapMaybe toToken+ toLine' i = Line i . mapMaybe fromToken - toToken (Token t) = Just t- toToken Spaces{} = Nothing+ fromToken (Token t) = Just t+ fromToken Spaces{} = Nothing -- | Divide lines into blocks and make entity definitions.-parse' :: PersistSettings -> [Line] -> [EntityDef]-parse' ps (Line indent (name:entattribs) : rest) =- let (x, y) = span ((> indent) . lineIndent) rest- in mkEntityDef ps name entattribs x : parse' ps y-parse' ps (Line _ []:rest) = parse' ps rest-parse' _ [] = []+parseLines :: PersistSettings -> [Line] -> [EntityDef]+parseLines ps lines =+ toEnts lines+ where+ toEnts (Line indent (name:entattribs) : rest) =+ let (x, y) = span ((> indent) . lineIndent) rest+ in mkEntityDef ps name entattribs x : toEnts y+ toEnts (Line _ []:rest) = toEnts rest+ toEnts [] = [] -- | Construct an entity definition. mkEntityDef :: PersistSettings@@ -123,31 +197,36 @@ case T.stripPrefix "id=" t of Nothing -> idName ts Just s -> s- cols = mapMaybe (takeCols ps) attribs uniqs = mapMaybe (takeUniqs ps cols) attribs derives = case mapMaybe takeDerives attribs of [] -> ["Show", "Read", "Eq"] x -> concat x -splitExtras :: [Line] -> ([[Text]], Map.Map Text [[Text]])-splitExtras [] = ([], Map.empty)+ cols :: [FieldDef]+ cols = mapMaybe (takeCols ps) attribs++splitExtras :: [Line] -> ([[Text]], M.Map Text [[Text]])+splitExtras [] = ([], M.empty) splitExtras (Line indent [name]:rest) | not (T.null name) && isUpper (T.head name) = let (children, rest') = span ((> indent) . lineIndent) rest (x, y) = splitExtras rest'- in (x, Map.insert name (map tokens children) y)+ in (x, M.insert name (map tokens children) y) splitExtras (Line _ ts:rest) = let (x, y) = splitExtras rest in (ts:x, y) takeCols :: PersistSettings -> [Text] -> Maybe FieldDef takeCols _ ("deriving":_) = Nothing-takeCols ps (n:ty:rest)- | not (T.null n) && isLower (T.head n) = Just $ FieldDef- (HaskellName n)- (DBName $ db rest)- (FieldType ty)- rest+takeCols ps (n:typ:rest)+ | not (T.null n) && isLower (T.head n) =+ case parseFieldType typ of+ Nothing -> error $ "Invalid field type: " ++ show typ+ Just ft -> Just $ FieldDef+ (HaskellName n)+ (DBName $ db rest)+ ft+ rest where db [] = psToDBName ps n db (a:as) =
Database/Persist/Query/GenericSql.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-}@@ -79,9 +80,13 @@ where t = entityDef $ dummyFromFilts filts - selectSource filts opts = C.Source $ do- conn <- lift $ SqlPersist ask- C.prepareSource $ R.withStmt (sql conn) (getFiltsValues conn filts) C.$= CL.mapM parse+ selectSource filts opts = C.Source+ { C.sourcePull = do+ conn <- lift $ SqlPersist ask+ let src = R.withStmt (sql conn) (getFiltsValues conn filts) C.$= CL.mapM parse+ C.sourcePull src+ , C.sourceClose = return ()+ } where (limit, offset, orders) = limitOffsetOrder opts @@ -124,9 +129,13 @@ , off ] - selectKeys filts = C.Source $ do- conn <- lift $ SqlPersist ask- C.prepareSource $ R.withStmt (sql conn) (getFiltsValues conn filts) C.$= CL.mapM parse+ selectKeys filts = C.Source+ { C.sourcePull = do+ conn <- lift $ SqlPersist ask+ let src = R.withStmt (sql conn) (getFiltsValues conn filts) C.$= CL.mapM parse+ C.sourcePull src+ , C.sourceClose = return ()+ } where parse [PersistInt64 i] = return $ Key $ PersistInt64 i parse y = liftIO $ throwIO $ PersistMarshalError $ "Unexpected in selectKeys: " ++ show y@@ -320,11 +329,11 @@ -- the environment inside a 'SqlPersist' monad, provide an explicit -- 'Connection'. This can allow you to use the returned 'Source' in an -- arbitrary monad.-selectSourceConn :: (C.ResourceIO m, PersistEntity val)+selectSourceConn :: (C.ResourceIO m, PersistEntity val, SqlPersist ~ PersistEntityBackend val) => Connection -> [Filter val] -> [SelectOpt val]- -> C.Source m (Entity SqlPersist val)+ -> C.Source m (Entity val) selectSourceConn conn fs opts = C.transSource (flip runSqlConn conn) (selectSource fs opts) @@ -338,8 +347,8 @@ -> Text orderClause includeTable conn o = case o of- Asc x -> name x- Desc x -> name x ++ " DESC"+ Asc x -> name $ persistFieldDef x+ Desc x -> name (persistFieldDef x) ++ " DESC" _ -> error $ "orderClause: expected Asc or Desc, not limit or offset" where dummyFromOrder :: SelectOpt a -> a@@ -351,4 +360,4 @@ (if includeTable then ((tn ++ ".") ++) else id)- $ escapeName conn $ fieldDB $ persistFieldDef x+ $ escapeName conn $ fieldDB x
Database/Persist/Query/Internal.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-} module Database.Persist.Query.Internal ( -- re-exported as public PersistQuery (..)@@ -35,16 +36,16 @@ -- | Get all records matching the given criterion in the specified order. -- Returns also the identifiers. selectSource- :: PersistEntity val+ :: (PersistEntity val, PersistEntityBackend val ~ b) => [Filter val] -> [SelectOpt val]- -> C.Source (b m) (Entity b val)+ -> C.Source (b m) (Entity val) -- | get just the first record for the criterion- selectFirst :: PersistEntity val+ selectFirst :: (PersistEntity val, PersistEntityBackend val ~ b) => [Filter val] -> [SelectOpt val]- -> b m (Maybe (Entity b val))+ -> b m (Maybe (Entity val)) selectFirst filts opts = C.runResourceT $ selectSource filts ((LimitTo 1):opts) C.$$ CL.head @@ -76,10 +77,10 @@ | LimitTo Int -- | Call 'select' but return the result as a list.-selectList :: (PersistEntity val, PersistQuery b m)+selectList :: (PersistEntity val, PersistQuery b m, PersistEntityBackend val ~ b) => [Filter val] -> [SelectOpt val]- -> b m [Entity b val]+ -> b m [Entity val] selectList a b = C.runResourceT $ selectSource a b C.$$ CL.consume data PersistUpdate = Assign | Add | Subtract | Multiply | Divide -- FIXME need something else here
Database/Persist/Query/Join.hs view
@@ -32,10 +32,10 @@ selectOneMany :: ([Key backend one] -> Filter many) -> (many -> Key backend one) -> SelectOneMany backend one many selectOneMany filts get' = SelectOneMany [] [] [] [] filts get' False-instance (PersistEntity one, PersistEntity many, Ord (Key backend one), PersistQuery backend monad)+instance (PersistEntity one, PersistEntity many, Ord (Key backend one), PersistQuery backend monad, backend ~ PersistEntityBackend one, backend ~ PersistEntityBackend many) => RunJoin (SelectOneMany backend one many) backend monad where type Result (SelectOneMany backend one many) =- [((Entity backend one), [(Entity backend many)])]+ [((Entity one), [(Entity many)])] runJoin (SelectOneMany oneF oneO manyF manyO eq getKey isOuter) = do x <- selectList oneF oneO -- FIXME use select instead of selectList
Database/Persist/Query/Join/Sql.hs view
@@ -29,7 +29,7 @@ import qualified Data.Conduit as C import qualified Data.Conduit.List as CL -fromPersistValuesId :: PersistEntity v => [PersistValue] -> Either Text (Entity SqlPersist v)+fromPersistValuesId :: PersistEntity v => [PersistValue] -> Either Text (Entity v) fromPersistValuesId [] = Left "fromPersistValuesId: No values provided" fromPersistValuesId (PersistInt64 i:rest) = case fromPersistValues rest of@@ -46,8 +46,8 @@ conn <- SqlPersist ask C.runResourceT $ liftM go $ withStmt (sql conn) (getFiltsValues conn oneF ++ getFiltsValues conn manyF) C.$$ loop id where- go :: [(Entity a b, Maybe (Entity c d))]- -> [(Entity a b, [Entity c d])]+ go :: [(Entity b, Maybe (Entity d))]+ -> [(Entity b, [Entity d])] go = map (fst . head &&& mapMaybe snd) . groupBy ((==) `on` (entityKey . fst))
Database/Persist/Store.hs view
@@ -11,6 +11,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-} -- This is to test our assumption that OverlappingInstances is just for String #ifndef NO_OVERLAP {-# LANGUAGE OverlappingInstances #-}@@ -41,6 +42,11 @@ , Key (..) , Entity (..) + -- * Helpers+ , getPersistMap+ , listToJSON+ , mapToJSON+ -- * Config , PersistConfig (..) ) where@@ -66,7 +72,8 @@ import Database.Persist.EntityDef import Data.Bits (bitSize)-import Control.Monad (liftM)+import Control.Monad (liftM, (<=<))+import Control.Arrow (second) import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T@@ -76,7 +83,22 @@ import Data.Aeson (Value) import Data.Aeson.Types (Parser)+import qualified Data.Aeson as A+import qualified Data.Attoparsec.Number as AN+import qualified Data.Vector as V +import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.HashMap.Strict as HM++import qualified Data.Text.Encoding as TE+import qualified Data.ByteString.Base64 as B64++import Data.Aeson (toJSON)+import Data.Aeson.Encode (fromValue)+import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Builder (toLazyText)+ data PersistException = PersistError T.Text -- ^ Generic Exception | PersistMarshalError T.Text@@ -117,6 +139,49 @@ Left e -> error $ T.unpack e Right y -> y +instance A.ToJSON PersistValue where+ toJSON (PersistText t) = A.String $ T.cons 's' t+ toJSON (PersistByteString b) = A.String $ T.cons 'b' $ TE.decodeUtf8 $ B64.encode b+ toJSON (PersistInt64 i) = A.Number $ fromIntegral i+ toJSON (PersistDouble d) = A.Number $ AN.D d+ toJSON (PersistBool b) = A.Bool b+ toJSON (PersistTimeOfDay t) = A.String $ T.cons 't' $ show t+ toJSON (PersistUTCTime u) = A.String $ T.cons 'u' $ show u+ toJSON (PersistDay d) = A.String $ T.cons 'd' $ show d+ toJSON PersistNull = A.Null+ toJSON (PersistList l) = A.Array $ V.fromList $ map A.toJSON l+ toJSON (PersistMap m) = A.object $ map (second A.toJSON) m+ toJSON (PersistObjectId o) = A.String $ T.cons 'o' $ TE.decodeUtf8 $ B64.encode o++instance A.FromJSON PersistValue where+ parseJSON (A.String t0) =+ case T.uncons t0 of+ Nothing -> fail "Null string"+ Just ('s', t) -> return $ PersistText t+ Just ('b', t) -> either (fail "Invalid base64") (return . PersistByteString)+ $ B64.decode $ TE.encodeUtf8 t+ Just ('t', t) -> fmap PersistTimeOfDay $ readMay t+ Just ('u', t) -> fmap PersistUTCTime $ readMay t+ Just ('d', t) -> fmap PersistDay $ readMay t+ Just ('o', t) -> either (fail "Invalid base64") (return . PersistObjectId)+ $ B64.decode $ TE.encodeUtf8 t+ Just (c, _) -> fail $ "Unknown prefix: " `mappend` [c]+ where+ readMay :: (Read a, Monad m) => T.Text -> m a+ readMay t =+ case reads $ T.unpack t of+ (x, _):_ -> return x+ [] -> fail "Could not read"+ parseJSON (A.Number (AN.I i)) = return $ PersistInt64 $ fromInteger i+ parseJSON (A.Number (AN.D d)) = return $ PersistDouble d+ parseJSON (A.Bool b) = return $ PersistBool b+ parseJSON A.Null = return $ PersistNull+ parseJSON (A.Array a) = fmap PersistList (mapM A.parseJSON $ V.toList a)+ parseJSON (A.Object o) =+ fmap PersistMap $ mapM go $ HM.toList o+ where+ go (k, v) = fmap ((,) k) $ A.parseJSON v+ -- | 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.@@ -129,7 +194,7 @@ | 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@@ -328,10 +393,11 @@ persistIdField :: EntityField val (Key (PersistEntityBackend val) val) -#ifdef WITH_MONGODB 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 x = Left $ "Expected PersistList, received: " ++ show x sqlType _ = SqlString @@ -339,17 +405,14 @@ 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]) =+ either Left (Right . S.fromList) $ fromPersistList values fromPersistValue x = Left $ "Expected PersistList, received: " ++ show x sqlType _ = SqlString -fromPersistList :: PersistField a => [PersistValue] -> Either String [a]-fromPersistList list =- foldl (\eithList v ->- case (eithList, fromPersistValue v) of- (Left e, _) -> Left e- (_, Left e) -> Left e- (Right xs, Right x) -> Right (x:xs)- ) (Right []) list+fromPersistList :: PersistField a => [PersistValue] -> Either T.Text [a]+fromPersistList = mapM fromPersistValue instance (PersistField a, PersistField b) => PersistField (a,b) where toPersistValue (x,y) = PersistList [toPersistValue x, toPersistValue y]@@ -363,7 +426,20 @@ instance PersistField v => PersistField (M.Map T.Text v) where toPersistValue = PersistMap . map (\(k,v) -> (k, toPersistValue v)) . M.toList- fromPersistValue (PersistMap kvs) = case (+ fromPersistValue = fromPersistMap <=< getPersistMap+ sqlType _ = SqlString++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 x = Left $ "Expected PersistMap, received: " ++ show x++fromPersistMap :: PersistField v+ => [(T.Text, PersistValue)]+ -> Either T.Text (M.Map T.Text v)+fromPersistMap kvs =+ case ( foldl (\eithAssocs (k,v) -> case (eithAssocs, fromPersistValue v) of (Left e, _) -> Left e@@ -374,11 +450,6 @@ Right vs -> Right $ M.fromList vs Left e -> Left e - fromPersistValue x = Left $ "Expected PersistMap, received: " ++ show x- sqlType _ = SqlString-#endif-- data SomePersistField = forall a. PersistField a => SomePersistField a instance PersistField SomePersistField where toPersistValue (SomePersistField a) = toPersistValue a@@ -388,6 +459,12 @@ newtype Key (backend :: (* -> *) -> * -> *) entity = Key { unKey :: PersistValue } deriving (Show, Read, Eq, Ord, PersistField) +instance A.ToJSON (Key backend entity) where+ toJSON (Key val) = A.toJSON val++instance A.FromJSON (Key backend entity) where+ parseJSON = fmap Key . A.parseJSON+ -- | Datatype that represents an entity, with both its key and -- its Haskell representation. --@@ -418,8 +495,8 @@ -- your query returns two entities (i.e. @(Entity backend a, -- Entity backend b)@), then you must you use @SELECT ??, ?? -- WHERE ...@, and so on.-data Entity backend entity =- Entity { entityKey :: Key backend entity+data Entity entity =+ Entity { entityKey :: Key (PersistEntityBackend entity) entity , entityVal :: entity } deriving (Eq, Ord, Show, Read) @@ -452,7 +529,7 @@ class PersistStore b m => PersistUnique b m where -- | Get a record by unique key, if available. Returns also the identifier.- getBy :: PersistEntity val => Unique val b -> b m (Maybe (Entity b val))+ getBy :: (PersistEntityBackend val ~ b, PersistEntity val) => Unique val b -> b m (Maybe (Entity val)) -- | Delete a specific record by unique key. Does nothing if no record -- matches.@@ -460,7 +537,7 @@ -- | Like 'insert', but returns 'Nothing' when the record -- couldn't be inserted because of a uniqueness constraint.- insertUnique :: PersistEntity val => val -> b m (Maybe (Key b val))+ insertUnique :: (b ~ PersistEntityBackend val, PersistEntity val) => val -> b m (Maybe (Key b val)) insertUnique datum = do isUnique <- checkUnique datum if isUnique then Just <$> insert datum else return Nothing@@ -470,8 +547,8 @@ -- | Insert a value, checking for conflicts with any unique constraints. If a -- duplicate exists in the database, it is returned as 'Left'. Otherwise, the -- new 'Key' is returned as 'Right'.-insertBy :: (PersistEntity v, PersistStore b m, PersistUnique b m)- => v -> b m (Either (Entity b v) (Key b v))+insertBy :: (PersistEntity v, PersistStore b m, PersistUnique b m, b ~ PersistEntityBackend v)+ => v -> b m (Either (Entity v) (Key b v)) insertBy val = go $ persistUniqueKeys val where@@ -486,8 +563,8 @@ -- 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, PersistUnique b m)- => v -> b m (Maybe (Entity b v))+getByValue :: (PersistEntity v, PersistUnique b m, PersistEntityBackend v ~ b)+ => v -> b m (Maybe (Entity v)) getByValue val = go $ persistUniqueKeys val where@@ -528,7 +605,7 @@ -- -- Returns 'True' if the entity would be unique, and could thus safely be -- 'insert'ed; returns 'False' on a conflict.-checkUnique :: (PersistEntity val, PersistUnique b m) => val -> b m Bool+checkUnique :: (PersistEntityBackend val ~ b, PersistEntity val, PersistUnique b m) => val -> b m Bool checkUnique val = go $ persistUniqueKeys val where@@ -580,3 +657,9 @@ show :: Show a => a -> T.Text show = T.pack . Prelude.show++listToJSON :: [PersistValue] -> T.Text+listToJSON = toStrict . toLazyText . fromValue . toJSON++mapToJSON :: [(T.Text, PersistValue)] -> T.Text+mapToJSON = toStrict . toLazyText . fromValue . toJSON
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 0.7.0.1+version: 0.8.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -26,7 +26,7 @@ , time >= 1.1.4 , text >= 0.8 && < 1 , containers >= 0.2 && < 0.5- , conduit >= 0.0 && < 0.2+ , conduit >= 0.2 && < 0.3 , monad-control >= 0.3 && < 0.4 , lifted-base >= 0.1 && < 0.2 , pool-conduit >= 0.0 && < 0.1@@ -35,6 +35,10 @@ , mtl >= 2.0 && < 2.1 , aeson >= 0.5 && < 0.7 , transformers-base+ , base64-bytestring+ , unordered-containers+ , vector+ , attoparsec exposed-modules: Database.Persist Database.Persist.EntityDef@@ -53,6 +57,18 @@ Database.Persist.GenericSql.Internal ghc-options: -Wall++test-suite test+ type: exitcode-stdio-1.0+ main-is: test/main.hs++ build-depends: base >= 4 && < 5+ , hspec+ , containers+ , text+ , HUnit++ cpp-options: -DTEST source-repository head type: git