persistent 2.0.2 → 2.0.3
raw patch · 10 files changed
+275/−156 lines, 10 files
Files
- Database/Persist.hs +8/−8
- Database/Persist/Quasi.hs +140/−65
- Database/Persist/Sql/Class.hs +11/−1
- Database/Persist/Sql/Internal.hs +9/−8
- Database/Persist/Sql/Orphan/PersistQuery.hs +43/−32
- Database/Persist/Sql/Orphan/PersistStore.hs +35/−23
- Database/Persist/Sql/Orphan/PersistUnique.hs +2/−4
- Database/Persist/Types/Base.hs +20/−8
- persistent.cabal +1/−1
- test/main.hs +6/−6
Database/Persist.hs view
@@ -15,6 +15,7 @@ -- * JSON Utilities , listToJSON , mapToJSON+ , toJsonText , getPersistMap -- * Other utililities@@ -27,7 +28,7 @@ import qualified Data.Text as T import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder (toLazyText)-import Data.Aeson (toJSON)+import Data.Aeson (toJSON, ToJSON) #if MIN_VERSION_aeson(0, 7, 0) import Data.Aeson.Encode (encodeToTextBuilder) #else@@ -70,17 +71,16 @@ a ||. b = [FilterOr [FilterAnd a, FilterAnd b]] listToJSON :: [PersistValue] -> T.Text-#if MIN_VERSION_aeson(0, 7, 0)-listToJSON = toStrict . toLazyText . encodeToTextBuilder . toJSON-#else-listToJSON = toStrict . toLazyText . fromValue . toJSON-#endif+listToJSON = toJsonText mapToJSON :: [(T.Text, PersistValue)] -> T.Text+mapToJSON = toJsonText++toJsonText :: ToJSON j => j -> T.Text #if MIN_VERSION_aeson(0, 7, 0)-mapToJSON = toStrict . toLazyText . encodeToTextBuilder . toJSON+toJsonText = toStrict . toLazyText . encodeToTextBuilder . toJSON #else-mapToJSON = toStrict . toLazyText . fromValue . toJSON+toJSonText = toStrict . toLazyText . fromValue . toJSON #endif limitOffsetOrder :: PersistEntity val => [SelectOpt val] -> (Int, Int, [SelectOpt val])
Database/Persist/Quasi.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TemplateHaskell #-} module Database.Persist.Quasi ( parse , PersistSettings (..)@@ -25,54 +26,56 @@ import qualified Data.Map as M import Data.List (foldl') import Data.Monoid (mappend)+import Control.Monad (msum, mplus) -data ParseState a = PSDone | PSFail | PSSuccess a Text+data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show -parseFieldType :: Text -> Maybe FieldType+parseFieldType :: Text -> Either String FieldType parseFieldType t0 =- case go t0 of+ case parseApplyFT t0 of PSSuccess ft t'- | T.all isSpace t' -> Just ft- _ -> Nothing+ | T.all isSpace t' -> Right ft+ PSFail err -> Left $ "PSFail " ++ err+ other -> Left $ show other where- go t =+ parseApplyFT t = case goMany id t of PSSuccess (ft:fts) t' -> PSSuccess (foldl' FTApp ft fts) t'- PSSuccess [] _ -> PSFail- PSFail -> PSFail+ PSSuccess [] _ -> PSFail "empty"+ PSFail err -> PSFail err PSDone -> PSDone- go1 t =++ parseEnclosed :: Char -> (FieldType -> FieldType) -> Text -> ParseState FieldType+ parseEnclosed end ftMod t =+ let (a, b) = T.break (== end) t+ in case parseApplyFT a of+ PSSuccess ft t' -> case (T.dropWhile isSpace t', T.uncons b) of+ ("", Just (c, t'')) | c == end -> PSSuccess (ftMod ft) (t'' `mappend` t')+ (x, y) -> PSFail $ show (b, x, y)+ x -> PSFail $ show x++ parse1 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+ | isSpace c -> parse1 $ T.dropWhile isSpace t'+ | c == '(' -> parseEnclosed ')' id t'+ | c == '[' -> parseEnclosed ']' FTList t' | isUpper c -> let (a, b) = T.break (\x -> isSpace x || x `elem` "()[]") t in PSSuccess (getCon a) b- | otherwise -> PSFail+ | otherwise -> PSFail $ show (c, t') 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+ case parse1 t of PSSuccess x t' -> goMany (front . (x:)) t'- _ -> PSSuccess (front []) t+ PSFail err -> PSFail err+ PSDone -> PSSuccess (front []) t+ -- _ -> data PersistSettings = PersistSettings { psToDBName :: !(Text -> Text)@@ -217,11 +220,11 @@ case M.lookup (foreignRefTableHaskell fdef) entLookup of Just pent -> case entityPrimary pent of Just pdef ->- if length foreignFieldTexts /= length (primaryFields pdef)+ if length foreignFieldTexts /= length (compositeFields pdef) then lengthError pdef else let fds_ffs = zipWith (toForeignFields pent) foreignFieldTexts- (primaryFields pdef)+ (compositeFields pdef) in fdef { foreignFields = map snd fds_ffs , foreignNullable = setNull $ map fst fds_ffs }@@ -265,7 +268,7 @@ | fieldHaskell f == t = f | otherwise = getFd fs t - lengthError pdef = error $ "found " ++ show (length foreignFieldTexts) ++ " fkeys and " ++ show (length (primaryFields pdef)) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef+ lengthError pdef = error $ "found " ++ show (length foreignFieldTexts) ++ " fkeys and " ++ show (length (compositeFields pdef)) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef data UnboundEntityDef = UnboundEntityDef@@ -273,44 +276,88 @@ , unboundEntityDef :: EntityDef } ++lookupKeyVal :: Text -> [Text] -> Maybe Text+lookupKeyVal key = lookupPrefix $ key `mappend` "="+lookupPrefix :: Text -> [Text] -> Maybe Text+lookupPrefix prefix = msum . map (T.stripPrefix prefix)+ -- | Construct an entity definition. mkEntityDef :: PersistSettings -> Text -- ^ name -> [Attr] -- ^ entity attributes -> [Line] -- ^ indented lines -> UnboundEntityDef-mkEntityDef ps name entattribs lines = UnboundEntityDef foreigns $+mkEntityDef ps name entattribs lines =+ UnboundEntityDef foreigns $ EntityDef- (HaskellName name')+ entName (DBName $ getDbName ps name' entattribs)- (DBName $ idName entattribs)- entattribs cols primary uniqs [] derives+ -- idField is the user-specified Id+ -- otherwise useAutoIdField+ -- but, adjust it if the user specified a Primary+ (setComposite primaryComposite $ fromMaybe autoIdField idField)+ entattribs+ cols+ uniqs+ []+ derives extras isSum where+ entName = HaskellName name' (isSum, name') = case T.uncons name of Just ('+', x) -> (True, x) _ -> (False, name) (attribs, extras) = splitExtras lines- idName [] = "id"- idName (t:ts) = fromMaybe (idName ts) $ T.stripPrefix "id=" t++ attribPrefix = flip lookupKeyVal entattribs+ idName | Just _ <- attribPrefix "id" = error "id= is deprecated, ad a field named 'Id' and use sql="+ | otherwise = Nothing - (primarys, uniqs, foreigns) = foldl' (\(a,b,c) attr -> - let (a',b',c') = takeConstraint ps name' cols attr - squish xs m = xs `mappend` maybeToList m- in (squish a a', squish b b', squish c c')) ([],[],[]) attribs+ (idField, primaryComposite, uniqs, foreigns) = foldl' (\(mid, mp, us, fs) attr -> + let (i, p, u, f) = takeConstraint ps name' cols attr + squish xs m = xs `mappend` maybeToList m+ in (just1 mid i, just1 mp p, squish us u, squish fs f)) (Nothing, Nothing, [],[]) attribs - primary = case primarys of - [] -> Nothing - [p] -> Just p- _ -> error $ "found more than one primary key in table[" ++ show name' ++ "]"- derives = concat $ mapMaybe takeDerives attribs cols :: [FieldDef]- cols = mapMaybe (takeCols ps) attribs+ cols = mapMaybe (takeColsEx ps) attribs + autoIdField = mkAutoIdField entName (DBName `fmap` idName) idSqlType+ idSqlType = maybe SqlInt64 (const $ SqlOther "Primary Key") primaryComposite++ setComposite Nothing fd = fd+ setComposite (Just c) fd = fd { fieldReference = CompositeRef c }+++just1 :: (Show x) => Maybe x -> Maybe x -> Maybe x+just1 (Just x) (Just y) = error $ "expected only one of: "+ `mappend` show x `mappend` " " `mappend` show y+just1 x y = x `mplus` y+ ++mkAutoIdField :: HaskellName -> Maybe DBName -> SqlType -> FieldDef+mkAutoIdField entName idName idSqlType = FieldDef+ { fieldHaskell = HaskellName "Id"+ -- this should be modeled as a Maybe+ -- but that sucks for non-ID field+ -- TODO: use a sumtype FieldDef | IdFieldDef+ , fieldDB = fromMaybe (DBName "") idName+ , fieldType = FTTypeCon Nothing $ keyConName $ unHaskellName entName+ , fieldSqlType = idSqlType+ -- the primary field is actually a reference to the entity+ , fieldReference = ForeignRef entName (FTTypeCon Nothing "Int64")+ , fieldAttrs = []+ , fieldStrict = True+ }++keyConName :: Text -> Text+keyConName entName = entName `mappend` "Id"++ splitExtras :: [Line] -> ([[Text]], M.Map Text [[Text]]) splitExtras [] = ([], M.empty) splitExtras (Line indent [name]:rest)@@ -322,13 +369,16 @@ let (x, y) = splitExtras rest in (ts:x, y) -takeCols :: PersistSettings -> [Text] -> Maybe FieldDef-takeCols _ ("deriving":_) = Nothing-takeCols ps (n':typ:rest)+takeColsEx :: PersistSettings -> [Text] -> Maybe FieldDef+takeColsEx = takeCols (\ft perr -> error $ "Invalid field type " ++ show ft ++ " " ++ perr)++takeCols :: (Text -> String -> Maybe FieldDef) -> PersistSettings -> [Text] -> Maybe FieldDef+takeCols _ _ ("deriving":_) = Nothing+takeCols onErr 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+ Left err -> onErr typ err+ Right ft -> Just FieldDef { fieldHaskell = HaskellName n , fieldDB = DBName $ getDbName ps n rest , fieldType = ft@@ -342,7 +392,7 @@ | Just x <- T.stripPrefix "!" n' = (Just True, x) | Just x <- T.stripPrefix "~" n' = (Just False, x) | otherwise = (Nothing, n')-takeCols _ _ = Nothing+takeCols _ _ _ = Nothing getDbName :: PersistSettings -> Text -> [Text] -> Text getDbName ps n [] = psToDBName ps n@@ -352,21 +402,46 @@ -> Text -> [FieldDef] -> [Text]- -> (Maybe PrimaryDef, Maybe UniqueDef, Maybe UnboundForeignDef)+ -> (Maybe FieldDef, Maybe CompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef) takeConstraint ps tableName defs (n:rest) | not (T.null n) && isUpper (T.head n) = takeConstraint' - where takeConstraint' - | n == "Primary" = (Just $ takePrimary defs rest, Nothing, Nothing)- | n == "Unique" = (Nothing, Just $ takeUniq ps tableName defs rest, Nothing)- | n == "Foreign" = (Nothing, Nothing, Just $ takeForeign ps tableName defs rest)- | otherwise = (Nothing, Just $ takeUniq ps "" defs (n:rest), Nothing) -- retain compatibility with original unique constraint-takeConstraint _ _ _ _ = (Nothing, Nothing, Nothing)+ where+ takeConstraint' + | n == "Unique" = (Nothing, Nothing, Just $ takeUniq ps tableName defs rest, Nothing)+ | n == "Foreign" = (Nothing, Nothing, Nothing, Just $ takeForeign ps tableName defs rest)+ | n == "Primary" = (Nothing, Just $ takeComposite defs rest, Nothing, Nothing)+ | n == "Id" = (Just $ takeId ps tableName (n:rest), Nothing, Nothing, Nothing)+ | otherwise = (Nothing, Nothing, Just $ takeUniq ps "" defs (n:rest), Nothing) -- retain compatibility with original unique constraint+takeConstraint _ _ _ _ = (Nothing, Nothing, Nothing, Nothing)++-- TODO: this is hacky (the double takeCols, the setFieldDef stuff, and setIdName.+-- need to re-work takeCols function+takeId :: PersistSettings -> Text -> [Text] -> FieldDef+takeId ps tableName (n:rest) = fromMaybe (error "takeId: impossible!") $ setFieldDef $+ takeCols (\_ _ -> addDefaultIdType) ps (field:rest `mappend` setIdName)+ where+ field = case T.uncons n of+ Nothing -> error "takeId: empty field"+ Just (f, ield) -> toLower f `T.cons` ield+ addDefaultIdType = takeColsEx ps (field : keyCon : rest `mappend` setIdName)+ setFieldDef = fmap (\fd ->+ let refFieldType = if fieldType fd == FTTypeCon Nothing keyCon+ then FTTypeCon Nothing "Int64"+ else fieldType fd+ in fd { fieldReference = ForeignRef (HaskellName tableName) $ refFieldType+ })+ keyCon = keyConName tableName+ -- this will be ignored if there is already an existing sql=+ -- TODO: I think there is a ! ignore syntax that would screw this up+ setIdName = ["sql="]+takeId _ tableName _ = error $ "empty Id field for " `mappend` show tableName+ -takePrimary :: [FieldDef]- -> [Text]- -> PrimaryDef-takePrimary defs pkcols- = PrimaryDef- (map (getDef defs) pkcols)+takeComposite :: [FieldDef]+ -> [Text]+ -> CompositeDef+takeComposite fields pkcols+ = CompositeDef+ (map (getDef fields) pkcols) attrs where (_, attrs) = break ("!" `T.isPrefixOf`) pkcols
Database/Persist/Sql/Class.hs view
@@ -10,6 +10,7 @@ module Database.Persist.Sql.Class ( RawSql (..) , PersistFieldSql (..)+ , defaultIdName, sqlIdName , IsSqlKey (..) ) where @@ -38,6 +39,15 @@ import Data.Bits (bitSize) import qualified Data.Vector as V +defaultIdName :: Text+defaultIdName = "id"++sqlIdName :: EntityDef -> DBName+sqlIdName ent =+ if primaryName /= (DBName "") then primaryName else DBName defaultIdName+ where+ primaryName = fieldDB (entityId ent)+ -- | Class for data types that may be retrived from a 'rawSql' -- query. class RawSql a where@@ -64,7 +74,7 @@ process ed = (:[]) $ intercalate ", " $ map ((name ed <>) . escape) $- (entityID ed:) $+ (sqlIdName ed :) $ map fieldDB $ entityFields ed name ed = escape (entityDB ed) <> "."
Database/Persist/Sql/Internal.hs view
@@ -3,6 +3,7 @@ -- | Intended for creating new backends. module Database.Persist.Sql.Internal ( mkColumns+ , defaultAttribute ) where import Database.Persist.Types@@ -13,6 +14,12 @@ import Data.Monoid (mappend, mconcat) import Database.Persist.Sql.Types +defaultAttribute :: [Attr] -> Maybe Text+defaultAttribute [] = Nothing+defaultAttribute (a:as)+ | Just d <- T.stripPrefix "default=" a = Just d+ | otherwise = defaultAttribute as+ -- | Create the list of columns for the given entity. mkColumns :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) mkColumns allDefs t =@@ -30,17 +37,11 @@ (fieldDB fd) (nullable (fieldAttrs fd) /= NotNullable || entitySum t) (fieldSqlType fd)- (def $ fieldAttrs fd)+ (defaultAttribute $ fieldAttrs fd) Nothing (maxLen $ fieldAttrs fd) (ref (fieldDB fd) (fieldReference fd) (fieldAttrs fd)) - def :: [Attr] -> Maybe Text- def [] = Nothing- def (a:as)- | Just d <- T.stripPrefix "default=" a = Just d- | otherwise = def as- maxLen :: [Attr] -> Maybe Integer maxLen [] = Nothing maxLen (a:as)@@ -56,7 +57,7 @@ -> [Attr] -> Maybe (DBName, DBName) -- table name, constraint name ref c fe []- | ForeignRef f <- fe =+ | ForeignRef f _ <- fe = Just (resolveTableName allDefs f, refName tn c) | otherwise = Nothing ref _ _ ("noreference":_) = Nothing
Database/Persist/Sql/Orphan/PersistQuery.hs view
@@ -8,10 +8,10 @@ , decorateSQLWithLimitOffset ) where -import Database.Persist+import Database.Persist hiding (updateField) import Database.Persist.Sql.Types import Database.Persist.Sql.Raw-import Database.Persist.Sql.Orphan.PersistStore (withRawQuery)+import Database.Persist.Sql.Orphan.PersistStore (defaultIdName, sqlIdName, withRawQuery) import qualified Data.Text as T import Data.Text (Text) import Data.Monoid (Monoid (..), (<>))@@ -61,7 +61,7 @@ parse vals = case entityPrimary t of Just pdef -> - let pks = map fieldHaskell $ primaryFields pdef+ let pks = map fieldHaskell $ compositeFields pdef keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) vals in case fromPersistValuesComposite' keyvals vals of Left s -> liftIO $ throwIO $ PersistMarshalError s@@ -100,8 +100,8 @@ [] -> "" ords -> " ORDER BY " <> T.intercalate "," ords cols conn = T.intercalate ","- $ ((if composite then [] else [connEscapeName conn $ entityID t]) - <> map (connEscapeName conn . fieldDB) (entityFields t))+ $ (if composite then [] else [connEscapeName conn $ sqlIdName t])+ <> map (connEscapeName conn . fieldDB) (entityFields t) sql conn = connLimitOffset conn (limit,offset) (not (null orders)) $ mconcat [ "SELECT " , cols conn@@ -118,8 +118,8 @@ where t = entityDef $ dummyFromFilts filts cols conn = case entityPrimary t of - Just pdef -> T.intercalate "," $ map (connEscapeName conn . fieldDB) $ primaryFields pdef- Nothing -> connEscapeName conn $ entityID t+ Just pdef -> T.intercalate "," $ map (connEscapeName conn . fieldDB) $ compositeFields pdef+ Nothing -> connEscapeName conn $ sqlIdName t wher conn = if null filts then ""@@ -148,7 +148,7 @@ [PersistDouble x] -> return [PersistInt64 (truncate x)] -- oracle returns Double _ -> liftIO $ throwIO $ PersistMarshalError $ "Unexpected in selectKeys False: " <> T.pack (show xs) Just pdef -> - let pks = map fieldHaskell $ primaryFields pdef+ let pks = map fieldHaskell $ compositeFields pdef keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) xs in return keyvals case keyFromValues keyvals of@@ -168,7 +168,7 @@ -- | Same as 'deleteWhere', but returns the number of rows affected. -- -- Since 1.1.5-deleteWhereCount :: (PersistEntity val, MonadIO m)+deleteWhereCount :: (PersistEntity val, MonadIO m, PersistEntityBackend val ~ Connection) => [Filter val] -> ReaderT Connection m Int64 deleteWhereCount filts = do@@ -187,7 +187,7 @@ -- | Same as 'updateWhere', but returns the number of rows affected. -- -- Since 1.1.5-updateWhereCount :: (PersistEntity val, MonadIO m, SqlBackend ~ PersistEntityBackend val)+updateWhereCount :: (PersistEntity val, MonadIO m, Connection ~ PersistEntityBackend val) => [Filter val] -> [Update val] -> ReaderT Connection m Int64@@ -215,21 +215,31 @@ go'' n Multiply = mconcat [n, "=", n, "*?"] go'' n Divide = mconcat [n, "=", n, "/?"] go' conn (x, pu) = go'' (connEscapeName conn x) pu- go x = (fieldDB $ updateFieldDef x, updateUpdate x)+ go x = (updateField x, updateUpdate x) -updateFieldDef :: PersistEntity v => Update v -> FieldDef-updateFieldDef (Update f _ _) = persistFieldDef f-updateFieldDef _ = error "BackendUpdate not implemented"+ updateField (Update f _ _) = fieldName f+ updateField _ = error "BackendUpdate not implemented" +fieldName :: forall record typ. (PersistEntity record, PersistEntityBackend record ~ Connection) => EntityField record typ -> DBName+fieldName f | isIdField f && dbName == DBName "" = DBName defaultIdName+ | otherwise = dbName+ where+ dbName = fieldDB fd+ fd = persistFieldDef f++isIdField :: forall record typ. (PersistEntity record) => EntityField record typ -> Bool+isIdField f = fieldHaskell (persistFieldDef f) == HaskellName "Id"+ dummyFromFilts :: [Filter v] -> Maybe v dummyFromFilts _ = Nothing -getFiltsValues :: forall val. PersistEntity val => Connection -> [Filter val] -> [PersistValue]+getFiltsValues :: forall val. (PersistEntity val, PersistEntityBackend val ~ Connection)+ => Connection -> [Filter val] -> [PersistValue] getFiltsValues conn = snd . filterClauseHelper False False conn OrNullNo data OrNull = OrNullYes | OrNullNo -filterClauseHelper :: PersistEntity val+filterClauseHelper :: (PersistEntity val, PersistEntityBackend val ~ Connection) => Bool -- ^ include table name? -> Bool -- ^ include WHERE? -> Connection@@ -257,29 +267,28 @@ go (FilterOr fs) = combine " OR " fs go (Filter field value pfilter) = let t = entityDef $ dummyFromFilts [Filter field value pfilter]- in case (fieldDB (persistFieldDef field) == DBName "id", entityPrimary t, allVals) of- -- need to check the id field in a safer way: entityId? - (True, Just pdef, (PersistList ys:_)) -> - if length (primaryFields pdef) /= length ys - then error $ "wrong number of entries in primaryFields vs PersistList allVals=" ++ show allVals+ in case (isIdField field, entityPrimary t, allVals) of+ (True, Just pdef, PersistList ys:_) ->+ if length (compositeFields pdef) /= length ys+ then error $ "wrong number of entries in compositeFields vs PersistList allVals=" ++ show allVals else case (allVals, pfilter, isCompFilter pfilter) of ([PersistList xs], Eq, _) -> - let sqlcl=T.intercalate " and " (map (\a -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") (primaryFields pdef))+ let sqlcl=T.intercalate " and " (map (\a -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") (compositeFields pdef)) in (wrapSql sqlcl,xs) ([PersistList xs], Ne, _) -> - let sqlcl=T.intercalate " or " (map (\a -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") (primaryFields pdef))+ let sqlcl=T.intercalate " or " (map (\a -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") (compositeFields pdef)) in (wrapSql sqlcl,xs) (_, In, _) -> let xxs = transpose (map fromPersistList allVals)- sqls=map (\(a,xs) -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (primaryFields pdef) xxs)+ sqls=map (\(a,xs) -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs) in (wrapSql (T.intercalate " and " (map wrapSql sqls)), concat xxs) (_, NotIn, _) -> let xxs = transpose (map fromPersistList allVals)- sqls=map (\(a,xs) -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (primaryFields pdef) xxs)+ sqls=map (\(a,xs) -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs) in (wrapSql (T.intercalate " or " (map wrapSql sqls)), concat xxs) ([PersistList xs], _, True) -> - let zs = tail (inits (primaryFields pdef))+ let zs = tail (inits (compositeFields pdef)) sql1 = map (\b -> wrapSql (T.intercalate " and " (map (\(i,a) -> sql2 (i==length b) a) (zip [1..] b)))) zs sql2 islast a = connEscapeName conn (fieldDB a) <> (if islast then showSqlFilter pfilter else showSqlFilter Eq) <> "? " sqlcl = T.intercalate " or " sql1@@ -362,7 +371,7 @@ (if includeTable then ((tn <> ".") <>) else id)- $ connEscapeName conn $ fieldDB $ persistFieldDef field+ $ connEscapeName conn $ fieldName field qmarks = case value of Left _ -> "?" Right x ->@@ -385,22 +394,22 @@ updatePersistValue (Update _ v _) = toPersistValue v updatePersistValue _ = error "BackendUpdate not implemented" -filterClause :: PersistEntity val+filterClause :: (PersistEntity val, PersistEntityBackend val ~ Connection) => Bool -- ^ include table name? -> Connection -> [Filter val] -> Text filterClause b c = fst . filterClauseHelper b True c OrNullNo -orderClause :: PersistEntity val+orderClause :: (PersistEntity val, PersistEntityBackend val ~ Connection) => Bool -- ^ include the table name -> Connection -> SelectOpt val -> Text orderClause includeTable conn o = case o of- Asc x -> name $ persistFieldDef x- Desc x -> name (persistFieldDef x) <> " DESC"+ Asc x -> name x+ Desc x -> name x <> " DESC" _ -> error "orderClause: expected Asc or Desc, not limit or offset" where dummyFromOrder :: SelectOpt a -> Maybe a@@ -408,11 +417,13 @@ tn = connEscapeName conn $ entityDB $ entityDef $ dummyFromOrder o + name :: (PersistEntityBackend record ~ Connection, PersistEntity record)+ => EntityField record typ -> Text name x = (if includeTable then ((tn <> ".") <>) else id)- $ connEscapeName conn $ fieldDB x+ $ connEscapeName conn $ fieldName x -- | Generates sql for limit and offset for postgres, sqlite and mysql. decorateSQLWithLimitOffset::Text -> (Int,Int) -> Bool -> Text -> Text
Database/Persist/Sql/Orphan/PersistStore.hs view
@@ -3,7 +3,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-module Database.Persist.Sql.Orphan.PersistStore (withRawQuery, BackendKey(..)) where+module Database.Persist.Sql.Orphan.PersistStore (defaultIdName, sqlIdName, withRawQuery, BackendKey(..)) where import Database.Persist import Database.Persist.Sql.Types@@ -12,7 +12,7 @@ import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import qualified Data.Text as T-import Data.Text (Text, unpack, pack)+import Data.Text (Text, unpack) import Data.Monoid (mappend, (<>)) import Control.Monad.IO.Class import Data.ByteString.Char8 (readInteger)@@ -22,8 +22,9 @@ import Data.Acquire (with) import Data.Int (Int64) import Web.PathPieces (PathPiece)-import Database.Persist.Sql.Class (PersistFieldSql)+import Database.Persist.Sql.Class (PersistFieldSql, defaultIdName, sqlIdName) import qualified Data.Aeson as A+import Control.Exception.Lifted (throwIO) withRawQuery :: MonadIO m => Text@@ -39,7 +40,7 @@ fromSqlKey = unSqlBackendKey instance PersistStore Connection where- newtype BackendKey SqlBackend = SqlBackendKey { unSqlBackendKey :: Int64 }+ newtype BackendKey Connection = SqlBackendKey { unSqlBackendKey :: Int64 } deriving (Show, Read, Eq, Ord, Num, Integral, PersistField, PersistFieldSql, PathPiece, Real, Enum, Bounded, A.ToJSON, A.FromJSON) update _ [] = return ()@@ -52,8 +53,8 @@ go'' n Divide = T.concat [n, "=", n, "/?"] let go' (x, pu) = go'' (connEscapeName conn x) pu let wher = case entityPrimary t of- Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (fieldDB fld) <> "=? ") $ primaryFields pdef- Nothing -> connEscapeName conn (entityID t) <> "=?"+ Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (fieldDB fld) <> "=? ") $ compositeFields pdef+ Nothing -> connEscapeName conn (sqlIdName t) <> "=?" let sql = T.concat [ "UPDATE " , connEscapeName conn $ entityDB t@@ -88,23 +89,31 @@ rawExecute sql1 vals withRawQuery sql2 [] $ do mm <- CL.head- i <- case mm of- Just [PersistInt64 i] -> return $ i- Just [PersistDouble i] ->return $ truncate i -- oracle need this!- Just [PersistByteString i] -> case readInteger i of -- mssql- Just (ret,"") -> return $ fromIntegral ret- xs -> error $ "invalid number i["++show i++"] xs[" ++ show xs ++ "]"- Just xs -> error $ "invalid sql2 return xs["++show xs++"] sql2["++show sql2++"] sql1["++show sql1++"]"- Nothing -> error $ "invalid sql2 returned nothing sql2["++show sql2++"] sql1["++show sql1++"]"- case keyFromValues [PersistInt64 i] of+ let m = maybe+ (Left $ "No results from ISRInsertGet: " `mappend` tshow (sql1, sql2))+ Right mm++ -- TODO: figure out something better for MySQL+ let convert x =+ case x of+ [PersistByteString i] -> case readInteger i of -- mssql+ Just (ret,"") -> [PersistInt64 $ fromIntegral ret]+ _ -> x+ _ -> x+ -- Yes, it's just <|>. Older bases don't have the+ -- instance for Either.+ onLeft Left{} x = x+ onLeft x _ = x++ case m >>= (\x -> keyFromValues x `onLeft` keyFromValues (convert x)) of Right k -> return k- Left err -> error $ "ISRInsertGet: keyFromValues failed: " `mappend` unpack err+ Left err -> throw $ "ISRInsertGet: keyFromValues failed: " `mappend` err ISRManyKeys sql fs -> do rawExecute sql vals case entityPrimary t of Nothing -> error $ "ISRManyKeys is used when Primary is defined " ++ show sql Just pdef -> - let pks = map fieldHaskell $ primaryFields pdef+ let pks = map fieldHaskell $ compositeFields pdef keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) fs in case keyFromValues keyvals of Right k -> return k@@ -112,6 +121,9 @@ return key where+ tshow :: Show a => a -> Text+ tshow = T.pack . show+ throw = liftIO . throwIO . userError . T.unpack t = entityDef $ Just val vals = map toPersistValue $ toPersistFields val @@ -145,7 +157,7 @@ , " SET " , T.intercalate "," (map (go conn . fieldDB) $ entityFields t) , " WHERE "- , connEscapeName conn $ entityID t+ , connEscapeName conn $ sqlIdName t , "=?" ] vals = map toPersistValue (toPersistFields val) `mappend` keyToValues k@@ -169,8 +181,8 @@ noColumns :: Bool noColumns = null $ entityFields t let wher = case entityPrimary t of- Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (fieldDB fld) <> "=? ") $ primaryFields pdef- Nothing -> connEscapeName conn (entityID t) <> "=?"+ Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (fieldDB fld) <> "=? ") $ compositeFields pdef+ Nothing -> connEscapeName conn (sqlIdName t) <> "=?" let sql = T.concat [ "SELECT " , if noColumns then "*" else cols@@ -195,8 +207,8 @@ t = entityDef $ dummyFromKey k wher conn = case entityPrimary t of- Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (fieldDB fld) <> "=? ") $ primaryFields pdef- Nothing -> connEscapeName conn (entityID t) <> "=?"+ Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (fieldDB fld) <> "=? ") $ compositeFields pdef+ Nothing -> connEscapeName conn (sqlIdName t) <> "=?" sql conn = T.concat [ "DELETE FROM " , connEscapeName conn $ entityDB t@@ -224,7 +236,7 @@ , "(" , T.intercalate "," $ map (connEscapeName conn)- $ entityID t : map fieldDB (entityFields t)+ $ sqlIdName t : map fieldDB (entityFields t) , ") VALUES(" , T.intercalate "," ("?" : map (const "?") (entityFields t)) , ")"
Database/Persist/Sql/Orphan/PersistUnique.hs view
@@ -5,12 +5,10 @@ import Database.Persist import Database.Persist.Sql.Types import Database.Persist.Sql.Raw-import Database.Persist.Sql.Orphan.PersistStore (withRawQuery)+import Database.Persist.Sql.Orphan.PersistStore (withRawQuery, sqlIdName) import qualified Data.Text as T import Data.Monoid (mappend)-import Control.Monad.Logger import qualified Data.Conduit.List as CL-import Data.Conduit import Control.Monad.Trans.Reader (ask) instance PersistUnique Connection where@@ -35,7 +33,7 @@ let flds = map (connEscapeName conn . fieldDB) (entityFields t) let cols = case entityPrimary t of Just _ -> T.intercalate "," flds- Nothing -> T.intercalate "," $ (connEscapeName conn $ entityID t) : flds+ Nothing -> T.intercalate "," $ connEscapeName conn (sqlIdName t) : flds let sql = T.concat [ "SELECT " , cols
Database/Persist/Types/Base.hs view
@@ -108,10 +108,9 @@ data EntityDef = EntityDef { entityHaskell :: !HaskellName , entityDB :: !DBName- , entityID :: !DBName+ , entityId :: !FieldDef , entityAttrs :: ![Attr] , entityFields :: ![FieldDef]- , entityPrimary :: Maybe PrimaryDef , entityUniques :: ![UniqueDef] , entityForeigns:: ![ForeignDef] , entityDerives :: ![Text]@@ -120,6 +119,11 @@ } deriving (Show, Eq, Read, Ord) +entityPrimary :: EntityDef -> Maybe CompositeDef+entityPrimary t = case fieldReference (entityId t) of+ CompositeRef c -> Just c+ _ -> Nothing+ type ExtraLine = [Text] newtype HaskellName = HaskellName { unHaskellName :: Text }@@ -141,15 +145,23 @@ , fieldDB :: !DBName , fieldType :: !FieldType , fieldSqlType :: !SqlType- , fieldAttrs :: ![Attr] -- ^ user annotations for a field+ , fieldAttrs :: ![Attr] -- ^ user annotations for a field , fieldStrict :: !Bool -- ^ a strict field in the data type. Default: true , fieldReference :: !ReferenceDef } deriving (Show, Eq, Read, Ord) -data ReferenceDef = ForeignRef !HaskellName++-- | There are 3 kinds of references+-- 1) composite (to fields that exist in the record)+-- 2) single field+-- 3) embedded+--+-- embedding isn't really a reference+data ReferenceDef = NoReference+ | ForeignRef !HaskellName !FieldType -- ^ A ForeignRef has a late binding to the EntityDef it references via HaskellName and has the Haskell type of the foreign key in the form of FieldType | EmbedRef EmbedEntityDef- | NoReference+ | CompositeRef CompositeDef deriving (Show, Eq, Read, Ord) -- | An EmbedEntityDef is the same as an EntityDef@@ -191,9 +203,9 @@ } deriving (Show, Eq, Read, Ord) -data PrimaryDef = PrimaryDef- { primaryFields :: ![FieldDef]- , primaryAttrs :: ![Attr]+data CompositeDef = CompositeDef+ { compositeFields :: ![FieldDef]+ , compositeAttrs :: ![Attr] } deriving (Show, Eq, Read, Ord)
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.0.2+version: 2.0.3 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>
test/main.hs view
@@ -77,14 +77,14 @@ ] describe "parseFieldType" $ do it "simple types" $- parseFieldType "FooBar" `shouldBe` Just (FTTypeCon Nothing "FooBar")+ parseFieldType "FooBar" `shouldBe` Right (FTTypeCon Nothing "FooBar") it "module types" $- parseFieldType "Data.Map.FooBar" `shouldBe` Just (FTTypeCon (Just "Data.Map") "FooBar")+ parseFieldType "Data.Map.FooBar" `shouldBe` Right (FTTypeCon (Just "Data.Map") "FooBar") it "application" $- parseFieldType "Foo Bar" `shouldBe` Just (+ parseFieldType "Foo Bar" `shouldBe` Right ( FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar") it "application multiple" $- parseFieldType "Foo Bar Baz" `shouldBe` Just (+ parseFieldType "Foo Bar Baz" `shouldBe` Right ( (FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar") `FTApp` FTTypeCon Nothing "Baz" )@@ -92,12 +92,12 @@ let foo = FTTypeCon Nothing "Foo" bar = FTTypeCon Nothing "Bar" baz = FTTypeCon Nothing "Baz"- parseFieldType "Foo (Bar Baz)" `shouldBe` Just (+ parseFieldType "Foo (Bar Baz)" `shouldBe` Right ( foo `FTApp` (bar `FTApp` baz)) it "lists" $ do let foo = FTTypeCon Nothing "Foo" bar = FTTypeCon Nothing "Bar" bars = FTList bar baz = FTTypeCon Nothing "Baz"- parseFieldType "Foo [Bar] Baz" `shouldBe` Just (+ parseFieldType "Foo [Bar] Baz" `shouldBe` Right ( foo `FTApp` bars `FTApp` baz)