persistent-2.7.1/Database/0000755000000000000000000000000013170567656013633 5ustar0000000000000000persistent-2.7.1/Database/Persist/0000755000000000000000000000000013173255472015255 5ustar0000000000000000persistent-2.7.1/Database/Persist/Class/0000755000000000000000000000000013173255472016322 5ustar0000000000000000persistent-2.7.1/Database/Persist/Sql/0000755000000000000000000000000013170567656016023 5ustar0000000000000000persistent-2.7.1/Database/Persist/Sql/Orphan/0000755000000000000000000000000013173255472017243 5ustar0000000000000000persistent-2.7.1/Database/Persist/Sql/Types/0000755000000000000000000000000013170567656017127 5ustar0000000000000000persistent-2.7.1/Database/Persist/Types/0000755000000000000000000000000013170567656016370 5ustar0000000000000000persistent-2.7.1/test/0000755000000000000000000000000013170567656013106 5ustar0000000000000000persistent-2.7.1/Database/Persist.hs0000644000000000000000000002502513170567656015624 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} module Database.Persist ( module Database.Persist.Class , module Database.Persist.Types -- * Reference Schema & Dataset -- | -- -- All the combinators present here will be explained based on this schema: -- -- > share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -- > User -- > name String -- > age Int -- > deriving Show -- > |] -- -- and this dataset. The examples below will refer to this as dataset-1. -- -- #dataset# -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ -- > |2 |Simon|41 | -- > +-----+-----+-----+ -- * Query update combinators , (=.), (+=.), (-=.), (*=.), (/=.) -- * Query filter combinators , (==.), (!=.), (<.), (>.), (<=.), (>=.), (<-.), (/<-.), (||.) -- * JSON Utilities , listToJSON , mapToJSON , toJsonText , getPersistMap -- * Other utilities , limitOffsetOrder ) where import Database.Persist.Types import Database.Persist.Class import Database.Persist.Class.PersistField (getPersistMap) import qualified Data.Text as T import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder (toLazyText) import Data.Aeson (toJSON, ToJSON) #if MIN_VERSION_aeson(1, 0, 0) import Data.Aeson.Text (encodeToTextBuilder) #elif MIN_VERSION_aeson(0, 7, 0) import Data.Aeson.Encode (encodeToTextBuilder) #else import Data.Aeson.Encode (fromValue) #endif infixr 3 =., +=., -=., *=., /=. (=.), (+=.), (-=.), (*=.), (/=.) :: forall v typ. PersistField typ => EntityField v typ -> typ -> Update v -- | Assign a field a value. -- -- === __Example usage__ -- -- @ -- updateAge :: MonadIO m => ReaderT SqlBackend m () -- updateAge = updateWhere [UserName ==. \"SPJ\" ] [UserAge =. 45] -- @ -- -- Similar to `updateWhere` which is shown in the above example you can use other functions present in the module "Database.Persist.Class". Note that the first parameter of `updateWhere` is [`Filter` val] and second parameter is [`Update` val]. By comparing this with the type of `==.` and `=.`, you can see that they match up in the above usage. -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+--------+ -- > |id |name |age | -- > +-----+-----+--------+ -- > |1 |SPJ |40 -> 45| -- > +-----+-----+--------+ -- > |2 |Simon|41 | -- > +-----+-----+--------+ f =. a = Update f a Assign -- | Assign a field by addition (@+=@). -- -- === __Example usage__ -- -- @ -- addAge :: MonadIO m => ReaderT SqlBackend m () -- addAge = updateWhere [UserName ==. \"SPJ\" ] [UserAge +=. 1] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+---------+ -- > |id |name |age | -- > +-----+-----+---------+ -- > |1 |SPJ |40 -> 41 | -- > +-----+-----+---------+ -- > |2 |Simon|41 | -- > +-----+-----+---------+ f +=. a = Update f a Add -- | Assign a field by subtraction (@-=@). -- -- === __Example usage__ -- -- @ -- subtractAge :: MonadIO m => ReaderT SqlBackend m () -- subtractAge = updateWhere [UserName ==. \"SPJ\" ] [UserAge -=. 1] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+---------+ -- > |id |name |age | -- > +-----+-----+---------+ -- > |1 |SPJ |40 -> 39 | -- > +-----+-----+---------+ -- > |2 |Simon|41 | -- > +-----+-----+---------+ f -=. a = Update f a Subtract -- | Assign a field by multiplication (@*=@). -- -- === __Example usage__ -- -- @ -- multiplyAge :: MonadIO m => ReaderT SqlBackend m () -- multiplyAge = updateWhere [UserName ==. \"SPJ\" ] [UserAge *=. 2] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+--------+ -- > |id |name |age | -- > +-----+-----+--------+ -- > |1 |SPJ |40 -> 80| -- > +-----+-----+--------+ -- > |2 |Simon|41 | -- > +-----+-----+--------+ f *=. a = Update f a Multiply -- | Assign a field by division (@/=@). -- -- === __Example usage__ -- -- @ -- divideAge :: MonadIO m => ReaderT SqlBackend m () -- divideAge = updateWhere [UserName ==. \"SPJ\" ] [UserAge /=. 2] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+---------+ -- > |id |name |age | -- > +-----+-----+---------+ -- > |1 |SPJ |40 -> 20 | -- > +-----+-----+---------+ -- > |2 |Simon|41 | -- > +-----+-----+---------+ f /=. a = Update f a Divide infix 4 ==., <., <=., >., >=., !=. (==.), (!=.), (<.), (<=.), (>.), (>=.) :: forall v typ. PersistField typ => EntityField v typ -> typ -> Filter v -- | Check for equality. -- -- === __Example usage__ -- -- @ -- selectSPJ :: MonadIO m => ReaderT SqlBackend m [Entity User] -- selectSPJ = selectList [UserName ==. \"SPJ\" ] [] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ f ==. a = Filter f (Left a) Eq -- | Non-equality check. -- -- === __Example usage__ -- -- @ -- selectSimon :: MonadIO m => ReaderT SqlBackend m [Entity User] -- selectSimon = selectList [UserName !=. \"SPJ\" ] [] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |2 |Simon|41 | -- > +-----+-----+-----+ f !=. a = Filter f (Left a) Ne -- | Less-than check. -- -- === __Example usage__ -- -- @ -- selectLessAge :: MonadIO m => ReaderT SqlBackend m [Entity User] -- selectLessAge = selectList [UserAge <. 41 ] [] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ f <. a = Filter f (Left a) Lt -- | Less-than or equal check. -- -- === __Example usage__ -- -- @ -- selectLessEqualAge :: MonadIO m => ReaderT SqlBackend m [Entity User] -- selectLessEqualAge = selectList [UserAge <=. 40 ] [] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ f <=. a = Filter f (Left a) Le -- | Greater-than check. -- -- === __Example usage__ -- -- @ -- selectGreaterAge :: MonadIO m => ReaderT SqlBackend m [Entity User] -- selectGreaterAge = selectList [UserAge >. 40 ] [] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |2 |Simon|41 | -- > +-----+-----+-----+ f >. a = Filter f (Left a) Gt -- | Greater-than or equal check. -- -- === __Example usage__ -- -- @ -- selectGreaterEqualAge :: MonadIO m => ReaderT SqlBackend m [Entity User] -- selectGreaterEqualAge = selectList [UserAge >=. 41 ] [] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |2 |Simon|41 | -- > +-----+-----+-----+ f >=. a = Filter f (Left a) Ge infix 4 <-., /<-. (<-.), (/<-.) :: forall v typ. PersistField typ => EntityField v typ -> [typ] -> Filter v -- | Check if value is in given list. -- -- === __Example usage__ -- -- @ -- selectUsers :: MonadIO m => ReaderT SqlBackend m [Entity User] -- selectUsers = selectList [UserAge <-. [40, 41]] [] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ -- > |2 |Simon|41 | -- > +-----+-----+-----+ -- -- -- @ -- selectSPJ :: MonadIO m => ReaderT SqlBackend m [Entity User] -- selectSPJ = selectList [UserAge <-. [40]] [] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |1 |SPJ |40 | -- > +-----+-----+-----+ f <-. a = Filter f (Right a) In -- | Check if value is not in given list. -- -- === __Example usage__ -- -- @ -- selectSimon :: MonadIO m => ReaderT SqlBackend m [Entity User] -- selectSimon = selectList [UserAge /<-. [40]] [] -- @ -- -- The above query when applied on <#dataset dataset-1>, will produce this: -- -- > +-----+-----+-----+ -- > |id |name |age | -- > +-----+-----+-----+ -- > |2 |Simon|41 | -- > +-----+-----+-----+ f /<-. a = Filter f (Right a) NotIn infixl 3 ||. (||.) :: forall v. [Filter v] -> [Filter v] -> [Filter v] -- | The OR of two lists of filters. For example: -- -- > selectList -- > ([ PersonAge >. 25 -- > , PersonAge <. 30 ] ||. -- > [ PersonIncome >. 15000 -- > , PersonIncome <. 25000 ]) -- > [] -- -- will filter records where a person's age is between 25 and 30 /or/ a -- person's income is between (15000 and 25000). -- -- If you are looking for an @(&&.)@ operator to do @(A AND B AND (C OR D))@ -- you can use the @(++)@ operator instead as there is no @(&&.)@. For -- example: -- -- > selectList -- > ([ PersonAge >. 25 -- > , PersonAge <. 30 ] ++ -- > ([PersonCategory ==. 1] ||. -- > [PersonCategory ==. 5])) -- > [] -- -- will filter records where a person's age is between 25 and 30 /and/ -- (person's category is either 1 or 5). a ||. b = [FilterOr [FilterAnd a, FilterAnd b]] -- | Convert list of 'PersistValue's into textual representation of JSON -- object. This is a type-constrained synonym for 'toJsonText'. listToJSON :: [PersistValue] -> T.Text listToJSON = toJsonText -- | Convert map (list of tuples) into textual representation of JSON -- object. This is a type-constrained synonym for 'toJsonText'. mapToJSON :: [(T.Text, PersistValue)] -> T.Text mapToJSON = toJsonText -- | A more general way to convert instances of `ToJSON` type class to -- strict text 'T.Text'. toJsonText :: ToJSON j => j -> T.Text #if MIN_VERSION_aeson(0, 7, 0) toJsonText = toStrict . toLazyText . encodeToTextBuilder . toJSON #else toJsonText = toStrict . toLazyText . fromValue . toJSON #endif -- | FIXME What's this exactly? limitOffsetOrder :: PersistEntity val => [SelectOpt val] -> (Int, Int, [SelectOpt val]) limitOffsetOrder opts = foldr go (0, 0, []) opts where go (LimitTo l) (_, b, c) = (l, b ,c) go (OffsetBy o) (a, _, c) = (a, o, c) go x (a, b, c) = (a, b, x : c) persistent-2.7.1/Database/Persist/Quasi.hs0000644000000000000000000004740213170567656016711 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ViewPatterns #-} module Database.Persist.Quasi ( parse , PersistSettings (..) , upperCaseSettings , lowerCaseSettings , nullable #if TEST , Token (..) , tokenize , parseFieldType #endif ) where import Prelude hiding (lines) import Database.Persist.Types import Data.Char import Data.Maybe (mapMaybe, fromMaybe, maybeToList) import Data.Text (Text) import qualified Data.Text as T import Control.Arrow ((&&&)) import qualified Data.Map as M import Data.List (foldl') import Data.Monoid (mappend) import Control.Monad (msum, mplus) data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show parseFieldType :: Text -> Either String FieldType parseFieldType t0 = case parseApplyFT t0 of PSSuccess ft t' | T.all isSpace t' -> Right ft PSFail err -> Left $ "PSFail " ++ err other -> Left $ show other where parseApplyFT t = case goMany id t of PSSuccess (ft:fts) t' -> PSSuccess (foldl' FTApp ft fts) t' PSSuccess [] _ -> PSFail "empty" PSFail err -> PSFail err PSDone -> PSDone 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'' `Data.Monoid.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 -> 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` ("()[]"::String)) t in PSSuccess (getCon a) b | 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 parse1 t of PSSuccess x t' -> goMany (front . (x:)) t' PSFail err -> PSFail err PSDone -> PSSuccess (front []) t -- _ -> data PersistSettings = PersistSettings { psToDBName :: !(Text -> Text) , psStrictFields :: !Bool -- ^ Whether fields are by default strict. Default value: @True@. -- -- @since 1.2 , psIdName :: !Text -- ^ The name of the id column. Default value: @id@ -- The name of the id column can also be changed on a per-model basis -- -- -- @since 2.0 } defaultPersistSettings, upperCaseSettings, lowerCaseSettings :: PersistSettings defaultPersistSettings = PersistSettings { psToDBName = id , psStrictFields = True , psIdName = "id" } upperCaseSettings = defaultPersistSettings lowerCaseSettings = defaultPersistSettings { psToDBName = let go c | isUpper c = T.pack ['_', toLower c] | otherwise = T.singleton c in T.dropWhile (== '_') . T.concatMap go } -- | Parses a quasi-quoted syntax into a list of entity definitions. parse :: PersistSettings -> Text -> [EntityDef] parse ps = parseLines ps . removeSpaces . filter (not . empty) . map tokenize . T.lines -- | 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] tokenize t | T.null t = [] | "--" `T.isPrefixOf` t = [] -- Comment until the end of the line. | "#" `T.isPrefixOf` t = [] -- Also comment to the end of the line, needed for a CPP bug (#110) | 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 -- support mid-token quotes and parens | Just (beforeEquals, afterEquals) <- findMidToken t , not (T.any isSpace beforeEquals) , Token next : rest <- tokenize afterEquals = Token (T.concat [beforeEquals, "=", next]) : rest | otherwise = let (token, rest) = T.break isSpace t in Token token : tokenize rest where findMidToken t' = case T.break (== '=') t' of (x, T.drop 1 -> y) | "\"" `T.isPrefixOf` y || "(" `T.isPrefixOf` y -> Just (x, y) _ -> Nothing quotes t' front | T.null t' = error $ T.unpack $ T.concat $ "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 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. empty :: [Token] -> Bool empty [] = True empty [Spaces _] = True empty _ = False -- | A line. We don't care about spaces in the middle of the -- line. Also, we don't care about the ammount of indentation. data Line = Line { lineIndent :: Int , tokens :: [Text] } -- | Remove leading spaces and remove spaces in the middle of the -- tokens. removeSpaces :: [[Token]] -> [Line] removeSpaces = map toLine where toLine (Spaces i:rest) = toLine' i rest toLine xs = toLine' 0 xs toLine' i = Line i . mapMaybe fromToken fromToken (Token t) = Just t fromToken Spaces{} = Nothing -- | Divide lines into blocks and make entity definitions. parseLines :: PersistSettings -> [Line] -> [EntityDef] parseLines ps lines = fixForeignKeysAll $ 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 [] = [] fixForeignKeysAll :: [UnboundEntityDef] -> [EntityDef] fixForeignKeysAll unEnts = map fixForeignKeys unEnts where ents = map unboundEntityDef unEnts entLookup = M.fromList $ map (\e -> (entityHaskell e, e)) ents fixForeignKeys :: UnboundEntityDef -> EntityDef fixForeignKeys (UnboundEntityDef foreigns ent) = ent { entityForeigns = map (fixForeignKey ent) foreigns } -- check the count and the sqltypes match and update the foreignFields with the names of the primary columns fixForeignKey :: EntityDef -> UnboundForeignDef -> ForeignDef fixForeignKey ent (UnboundForeignDef foreignFieldTexts fdef) = case M.lookup (foreignRefTableHaskell fdef) entLookup of Just pent -> case entityPrimary pent of Just pdef -> if length foreignFieldTexts /= length (compositeFields pdef) then lengthError pdef else let fds_ffs = zipWith (toForeignFields pent) foreignFieldTexts (compositeFields pdef) in fdef { foreignFields = map snd fds_ffs , foreignNullable = setNull $ map fst fds_ffs } Nothing -> error $ "no explicit primary key fdef="++show fdef++ " ent="++show ent Nothing -> error $ "could not find table " ++ show (foreignRefTableHaskell fdef) ++ " fdef=" ++ show fdef ++ " allnames=" ++ show (map (unHaskellName . entityHaskell . unboundEntityDef) unEnts) ++ "\n\nents=" ++ show ents where setNull :: [FieldDef] -> Bool setNull [] = error "setNull: impossible!" setNull (fd:fds) = let nullSetting = isNull fd in if all ((nullSetting ==) . isNull) fds then nullSetting else error $ "foreign key columns must all be nullable or non-nullable" ++ show (map (unHaskellName . fieldHaskell) (fd:fds)) isNull = (NotNullable /=) . nullable . fieldAttrs toForeignFields pent fieldText pfd = case chktypes fd haskellField (entityFields pent) pfh of Just err -> error err Nothing -> (fd, ((haskellField, fieldDB fd), (pfh, pfdb))) where fd = getFd (entityFields ent) haskellField haskellField = HaskellName fieldText (pfh, pfdb) = (fieldHaskell pfd, fieldDB pfd) chktypes :: FieldDef -> HaskellName -> [FieldDef] -> HaskellName -> Maybe String chktypes ffld _fkey pflds pkey = if fieldType ffld == fieldType pfld then Nothing else Just $ "fieldType mismatch: " ++ show (fieldType ffld) ++ ", " ++ show (fieldType pfld) where pfld = getFd pflds pkey entName = entityHaskell ent getFd [] t = error $ "foreign key constraint for: " ++ show (unHaskellName entName) ++ " unknown column: " ++ show t getFd (f:fs) t | fieldHaskell f == t = f | otherwise = getFd fs t lengthError pdef = error $ "found " ++ show (length foreignFieldTexts) ++ " fkeys and " ++ show (length (compositeFields pdef)) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef data UnboundEntityDef = UnboundEntityDef { _unboundForeignDefs :: [UnboundForeignDef] , 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 $ EntityDef entName (DBName $ getDbName ps name' entattribs) -- 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 attribPrefix = flip lookupKeyVal entattribs idName | Just _ <- attribPrefix "id" = error "id= is deprecated, ad a field named 'Id' and use sql=" | otherwise = Nothing (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 derives = concat $ mapMaybe takeDerives attribs cols :: [FieldDef] cols = mapMaybe (takeColsEx ps) attribs autoIdField = mkAutoIdField ps 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 :: PersistSettings -> HaskellName -> Maybe DBName -> SqlType -> FieldDef mkAutoIdField ps 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 $ psIdName ps) idName , fieldType = FTTypeCon Nothing $ keyConName $ unHaskellName entName , fieldSqlType = idSqlType -- the primary field is actually a reference to the entity , fieldReference = ForeignRef entName defaultReferenceTypeCon , fieldAttrs = [] , fieldStrict = True } defaultReferenceTypeCon :: FieldType defaultReferenceTypeCon = FTTypeCon (Just "Data.Int") "Int64" keyConName :: Text -> Text keyConName entName = entName `mappend` "Id" 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, M.insert name (map tokens children) y) splitExtras (Line _ ts:rest) = let (x, y) = splitExtras rest in (ts:x, y) 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 Left err -> onErr typ err Right ft -> Just FieldDef { fieldHaskell = HaskellName n , fieldDB = DBName $ getDbName ps n rest , fieldType = ft , fieldSqlType = SqlOther $ "SqlType unset for " `mappend` n , fieldAttrs = rest , fieldStrict = fromMaybe (psStrictFields ps) mstrict , fieldReference = NoReference } where (mstrict, n) | Just x <- T.stripPrefix "!" n' = (Just True, x) | Just x <- T.stripPrefix "~" n' = (Just False, x) | otherwise = (Nothing, n') takeCols _ _ _ = Nothing getDbName :: PersistSettings -> Text -> [Text] -> Text getDbName ps n [] = psToDBName ps n getDbName ps n (a:as) = fromMaybe (getDbName ps n as) $ T.stripPrefix "sql=" a takeConstraint :: PersistSettings -> Text -> [FieldDef] -> [Text] -> (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 == "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 defaultReferenceTypeCon 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=" `mappend` psIdName ps] takeId _ tableName _ = error $ "empty Id field for " `mappend` show tableName takeComposite :: [FieldDef] -> [Text] -> CompositeDef takeComposite fields pkcols = CompositeDef (map (getDef fields) pkcols) attrs where (_, attrs) = break ("!" `T.isPrefixOf`) pkcols getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t getDef (d:ds) t | fieldHaskell d == HaskellName t = if nullable (fieldAttrs d) /= NotNullable then error $ "primary key column cannot be nullable: " ++ show t else d | otherwise = getDef ds t -- Unique UppercaseConstraintName list of lowercasefields takeUniq :: PersistSettings -> Text -> [FieldDef] -> [Text] -> UniqueDef takeUniq ps tableName defs (n:rest) | not (T.null n) && isUpper (T.head n) = UniqueDef (HaskellName n) (DBName $ psToDBName ps (tableName `T.append` n)) (map (HaskellName &&& getDBName defs) fields) attrs where (fields,attrs) = break ("!" `T.isPrefixOf`) rest getDBName [] t = error $ "Unknown column in unique constraint: " ++ show t getDBName (d:ds) t | fieldHaskell d == HaskellName t = fieldDB d | otherwise = getDBName ds t takeUniq _ tableName _ xs = error $ "invalid unique constraint on table[" ++ show tableName ++ "] expecting an uppercase constraint name xs=" ++ show xs data UnboundForeignDef = UnboundForeignDef { _unboundFields :: [Text] -- ^ fields in other entity , _unboundForeignDef :: ForeignDef } takeForeign :: PersistSettings -> Text -> [FieldDef] -> [Text] -> UnboundForeignDef takeForeign ps tableName _defs (refTableName:n:rest) | not (T.null n) && isLower (T.head n) = UnboundForeignDef fields $ ForeignDef (HaskellName refTableName) (DBName $ psToDBName ps refTableName) (HaskellName n) (DBName $ psToDBName ps (tableName `T.append` n)) [] attrs False where (fields,attrs) = break ("!" `T.isPrefixOf`) rest takeForeign _ tableName _ xs = error $ "invalid foreign key constraint on table[" ++ show tableName ++ "] expecting a lower case constraint name xs=" ++ show xs takeDerives :: [Text] -> Maybe [Text] takeDerives ("deriving":rest) = Just rest takeDerives _ = Nothing nullable :: [Text] -> IsNullable nullable s | "Maybe" `elem` s = Nullable ByMaybeAttr | "nullable" `elem` s = Nullable ByNullableAttr | otherwise = NotNullable persistent-2.7.1/Database/Persist/Types.hs0000644000000000000000000000070013170567656016721 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TypeFamilies #-} module Database.Persist.Types ( module Database.Persist.Types.Base , SomePersistField (..) , Update (..) , BackendSpecificUpdate , SelectOpt (..) , Filter (..) , BackendSpecificFilter , Key , Entity (..) ) where import Database.Persist.Types.Base import Database.Persist.Class.PersistField import Database.Persist.Class.PersistEntity persistent-2.7.1/Database/Persist/Class.hs0000644000000000000000000000441213173255472016657 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} module Database.Persist.Class ( ToBackendKey (..) -- * PersistStore , PersistCore (..) , PersistStore , PersistStoreRead (..) , PersistStoreWrite (..) , PersistRecordBackend , getJust , getJustEntity , getEntity , belongsTo , belongsToJust , insertEntity , insertRecord -- * PersistUnique , PersistUnique , PersistUniqueRead (..) , PersistUniqueWrite (..) , getByValue , insertBy , insertUniqueEntity , replaceUnique , checkUnique , onlyUnique -- * PersistQuery , PersistQuery , PersistQueryRead (..) , PersistQueryWrite (..) , selectSource , selectKeys , selectList , selectKeysList -- * DeleteCascade , DeleteCascade (..) , deleteCascadeWhere -- * PersistEntity , PersistEntity (..) -- * PersistField , PersistField (..) -- * PersistConfig , PersistConfig (..) , entityValues -- * Lifting , HasPersistBackend (..) , IsPersistBackend () , liftPersist , BackendCompatible (..) -- * JSON utilities , keyValueEntityToJSON, keyValueEntityFromJSON , entityIdToJSON, entityIdFromJSON , toPersistValueJSON, fromPersistValueJSON ) where import Database.Persist.Class.DeleteCascade import Database.Persist.Class.PersistEntity import Database.Persist.Class.PersistQuery import Database.Persist.Class.PersistUnique import Database.Persist.Class.PersistConfig import Database.Persist.Class.PersistField import Database.Persist.Class.PersistStore -- | A backwards-compatible alias for those that don't care about distinguishing between read and write queries. -- It signifies the assumption that, by default, a backend can write as well as read. type PersistUnique a = PersistUniqueWrite a -- | A backwards-compatible alias for those that don't care about distinguishing between read and write queries. -- It signifies the assumption that, by default, a backend can write as well as read. type PersistQuery a = PersistQueryWrite a -- | A backwards-compatible alias for those that don't care about distinguishing between read and write queries. -- It signifies the assumption that, by default, a backend can write as well as read. type PersistStore a = PersistStoreWrite a persistent-2.7.1/Database/Persist/Sql.hs0000644000000000000000000000307713170567656016366 0ustar0000000000000000module Database.Persist.Sql ( module Database.Persist.Sql.Types , module Database.Persist.Sql.Class , module Database.Persist.Sql.Run , module Database.Persist.Sql.Migration , module Database.Persist , module Database.Persist.Sql.Orphan.PersistStore , rawQuery , rawQueryRes , rawExecute , rawExecuteCount , rawSql , deleteWhereCount , updateWhereCount , transactionSave , transactionUndo , getStmtConn -- * Internal , module Database.Persist.Sql.Internal , decorateSQLWithLimitOffset ) where import Database.Persist import Database.Persist.Sql.Types import Database.Persist.Sql.Class import Database.Persist.Sql.Run hiding (withResourceTimeout) import Database.Persist.Sql.Raw import Database.Persist.Sql.Migration import Database.Persist.Sql.Internal import Database.Persist.Sql.Orphan.PersistQuery import Database.Persist.Sql.Orphan.PersistStore import Database.Persist.Sql.Orphan.PersistUnique () import Control.Monad.IO.Class import Control.Monad.Trans.Reader (ReaderT, ask) -- | Commit the current transaction and begin a new one. -- -- @since 1.2.0 transactionSave :: MonadIO m => ReaderT SqlBackend m () transactionSave = do conn <- ask let getter = getStmtConn conn liftIO $ connCommit conn getter >> connBegin conn getter -- | Roll back the current transaction and begin a new one. -- -- @since 1.2.0 transactionUndo :: MonadIO m => ReaderT SqlBackend m () transactionUndo = do conn <- ask let getter = getStmtConn conn liftIO $ connRollback conn getter >> connBegin conn getter persistent-2.7.1/Database/Persist/Sql/Util.hs0000644000000000000000000000616413170567656017303 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Database.Persist.Sql.Util ( parseEntityValues , entityColumnNames , keyAndEntityColumnNames , entityColumnCount , isIdField , hasCompositeKey , dbIdColumns , dbIdColumnsEsc , dbColumns ) where import Data.Maybe (isJust) import Data.Monoid ((<>)) import Data.Text (Text, pack) import Database.Persist ( Entity(Entity), EntityDef, EntityField, HaskellName(HaskellName) , PersistEntity, PersistValue , keyFromValues, fromPersistValues, fieldDB, entityId, entityPrimary , entityFields, entityKeyFields, fieldHaskell, compositeFields, persistFieldDef , keyAndEntityFields , DBName) import Database.Persist.Sql.Types (Sql, SqlBackend, connEscapeName) entityColumnNames :: EntityDef -> SqlBackend -> [Sql] entityColumnNames ent conn = (if hasCompositeKey ent then [] else [connEscapeName conn $ fieldDB (entityId ent)]) <> map (connEscapeName conn . fieldDB) (entityFields ent) keyAndEntityColumnNames :: EntityDef -> SqlBackend -> [Sql] keyAndEntityColumnNames ent conn = map (connEscapeName conn . fieldDB) (keyAndEntityFields ent) entityColumnCount :: EntityDef -> Int entityColumnCount e = length (entityFields e) + if hasCompositeKey e then 0 else 1 hasCompositeKey :: EntityDef -> Bool hasCompositeKey = isJust . entityPrimary dbIdColumns :: SqlBackend -> EntityDef -> [Text] dbIdColumns conn = dbIdColumnsEsc (connEscapeName conn) dbIdColumnsEsc :: (DBName -> Text) -> EntityDef -> [Text] dbIdColumnsEsc esc t = map (esc . fieldDB) $ entityKeyFields t dbColumns :: SqlBackend -> EntityDef -> [Text] dbColumns conn t = case entityPrimary t of Just _ -> flds Nothing -> escapeDB (entityId t) : flds where escapeDB = connEscapeName conn . fieldDB flds = map escapeDB (entityFields t) parseEntityValues :: PersistEntity record => EntityDef -> [PersistValue] -> Either Text (Entity record) parseEntityValues t vals = case entityPrimary t of Just pdef -> let pks = map fieldHaskell $ compositeFields pdef keyvals = map snd . filter ((`elem` pks) . fst) $ zip (map fieldHaskell $ entityFields t) vals in fromPersistValuesComposite' keyvals vals Nothing -> fromPersistValues' vals where fromPersistValues' (kpv:xs) = -- oracle returns Double case fromPersistValues xs of Left e -> Left e Right xs' -> case keyFromValues [kpv] of Left _ -> error $ "fromPersistValues': keyFromValues failed on " ++ show kpv Right k -> Right (Entity k xs') fromPersistValues' xs = Left $ pack ("error in fromPersistValues' xs=" ++ show xs) fromPersistValuesComposite' keyvals xs = case fromPersistValues xs of Left e -> Left e Right xs' -> case keyFromValues keyvals of Left _ -> error "fromPersistValuesComposite': keyFromValues failed" Right key -> Right (Entity key xs') isIdField :: PersistEntity record => EntityField record typ -> Bool isIdField f = fieldHaskell (persistFieldDef f) == HaskellName "Id" persistent-2.7.1/Database/Persist/Sql/Types/Internal.hs0000644000000000000000000001333113170567656021240 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveDataTypeable #-} module Database.Persist.Sql.Types.Internal ( HasPersistBackend (..) , IsPersistBackend (..) , SqlReadBackend (unSqlReadBackend) , SqlWriteBackend (unSqlWriteBackend) , readToUnknown , readToWrite , writeToUnknown , LogFunc , InsertSqlResult (..) , Statement (..) , SqlBackend (..) , SqlBackendCanRead , SqlBackendCanWrite , SqlReadT , SqlWriteT , IsSqlBackend ) where import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Logger (LogSource, LogLevel) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask) import Data.Acquire (Acquire) import Data.Conduit (Source) import Data.Int (Int64) import Data.IORef (IORef) import Data.Map (Map) import Data.Text (Text) import Data.Typeable (Typeable) import Database.Persist.Class ( HasPersistBackend (..) , PersistQueryRead, PersistQueryWrite , PersistStoreRead, PersistStoreWrite , PersistUniqueRead, PersistUniqueWrite ) import Database.Persist.Class.PersistStore (IsPersistBackend (..)) import Database.Persist.Types import Language.Haskell.TH.Syntax (Loc) import System.Log.FastLogger (LogStr) type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () data InsertSqlResult = ISRSingle Text | ISRInsertGet Text Text | ISRManyKeys Text [PersistValue] data Statement = Statement { stmtFinalize :: IO () , stmtReset :: IO () , stmtExecute :: [PersistValue] -> IO Int64 , stmtQuery :: forall m. MonadIO m => [PersistValue] -> Acquire (Source m [PersistValue]) } data SqlBackend = SqlBackend { connPrepare :: Text -> IO Statement -- | table name, column names, id name, either 1 or 2 statements to run , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult , connInsertManySql :: Maybe (EntityDef -> [[PersistValue]] -> InsertSqlResult) -- ^ SQL for inserting many rows and returning their primary keys, for backends that support this functioanlity. If 'Nothing', rows will be inserted one-at-a-time using 'connInsertSql'. , connUpsertSql :: Maybe (EntityDef -> Text -> Text) , connStmtMap :: IORef (Map Text Statement) , connClose :: IO () , connMigrateSql :: [EntityDef] -> (Text -> IO Statement) -> EntityDef -> IO (Either [Text] [(Bool, Text)]) , connBegin :: (Text -> IO Statement) -> IO () , connCommit :: (Text -> IO Statement) -> IO () , connRollback :: (Text -> IO Statement) -> IO () , connEscapeName :: DBName -> Text , connNoLimit :: Text , connRDBMS :: Text , connLimitOffset :: (Int,Int) -> Bool -> Text -> Text , connLogFunc :: LogFunc , connMaxParams :: Maybe Int -- ^ Some databases (probably only Sqlite) have a limit on how -- many question-mark parameters may be used in a statement -- -- @since 2.6.1 } deriving Typeable instance HasPersistBackend SqlBackend where type BaseBackend SqlBackend = SqlBackend persistBackend = id instance IsPersistBackend SqlBackend where mkPersistBackend = id -- | An SQL backend which can only handle read queries newtype SqlReadBackend = SqlReadBackend { unSqlReadBackend :: SqlBackend } deriving Typeable instance HasPersistBackend SqlReadBackend where type BaseBackend SqlReadBackend = SqlBackend persistBackend = unSqlReadBackend instance IsPersistBackend SqlReadBackend where mkPersistBackend = SqlReadBackend -- | An SQL backend which can handle read or write queries newtype SqlWriteBackend = SqlWriteBackend { unSqlWriteBackend :: SqlBackend } deriving Typeable instance HasPersistBackend SqlWriteBackend where type BaseBackend SqlWriteBackend = SqlBackend persistBackend = unSqlWriteBackend instance IsPersistBackend SqlWriteBackend where mkPersistBackend = SqlWriteBackend -- | Useful for running a write query against an untagged backend with unknown capabilities. writeToUnknown :: Monad m => ReaderT SqlWriteBackend m a -> ReaderT SqlBackend m a writeToUnknown ma = do unknown <- ask lift . runReaderT ma $ SqlWriteBackend unknown -- | Useful for running a read query against a backend with read and write capabilities. readToWrite :: Monad m => ReaderT SqlReadBackend m a -> ReaderT SqlWriteBackend m a readToWrite ma = do write <- ask lift . runReaderT ma . SqlReadBackend $ unSqlWriteBackend write -- | Useful for running a read query against a backend with unknown capabilities. readToUnknown :: Monad m => ReaderT SqlReadBackend m a -> ReaderT SqlBackend m a readToUnknown ma = do unknown <- ask lift . runReaderT ma $ SqlReadBackend unknown -- | A constraint synonym which witnesses that a backend is SQL and can run read queries. type SqlBackendCanRead backend = ( IsSqlBackend backend , PersistQueryRead backend, PersistStoreRead backend, PersistUniqueRead backend ) -- | A constraint synonym which witnesses that a backend is SQL and can run read and write queries. type SqlBackendCanWrite backend = ( SqlBackendCanRead backend , PersistQueryWrite backend, PersistStoreWrite backend, PersistUniqueWrite backend ) -- | Like @SqlPersistT@ but compatible with any SQL backend which can handle read queries. type SqlReadT m a = forall backend. (SqlBackendCanRead backend) => ReaderT backend m a -- | Like @SqlPersistT@ but compatible with any SQL backend which can handle read and write queries. type SqlWriteT m a = forall backend. (SqlBackendCanWrite backend) => ReaderT backend m a -- | A backend which is a wrapper around @SqlBackend@. type IsSqlBackend backend = (IsPersistBackend backend, BaseBackend backend ~ SqlBackend) persistent-2.7.1/Database/Persist/Types/Base.hs0000644000000000000000000004371113170567656017604 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} -- usage of Error typeclass module Database.Persist.Types.Base where import qualified Data.Aeson as A import Control.Exception (Exception) import Web.PathPieces (PathPiece(..)) import Web.HttpApiData (ToHttpApiData (..), FromHttpApiData (..), parseUrlPieceMaybe, showTextData, readTextData, parseBoundedTextData) import Control.Monad.Trans.Error (Error (..)) import Data.Typeable (Typeable) import Data.Text (Text, pack) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Data.Text.Encoding.Error (lenientDecode) import qualified Data.ByteString.Base64 as B64 import qualified Data.Vector as V import Control.Arrow (second) import Control.Applicative as A ((<$>)) import Data.Time (Day, TimeOfDay, UTCTime) import Data.Int (Int64) import Data.ByteString (ByteString, foldl') import Data.Bits (shiftL, shiftR) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Data.Map (Map) import qualified Data.HashMap.Strict as HM import Data.Word (Word32) import Numeric (showHex, readHex) #if MIN_VERSION_aeson(0, 7, 0) import qualified Data.Scientific #else import qualified Data.Attoparsec.Number as AN #endif -- | A 'Checkmark' should be used as a field type whenever a -- uniqueness constraint should guarantee that a certain kind of -- record may appear at most once, but other kinds of records may -- appear any number of times. -- -- /NOTE:/ You need to mark any @Checkmark@ fields as @nullable@ -- (see the following example). -- -- For example, suppose there's a @Location@ entity that -- represents where a user has lived: -- -- @ -- Location -- user UserId -- name Text -- current Checkmark nullable -- -- UniqueLocation user current -- @ -- -- The @UniqueLocation@ constraint allows any number of -- 'Inactive' @Location@s to be @current@. However, there may be -- at most one @current@ @Location@ per user (i.e., either zero -- or one per user). -- -- This data type works because of the way that SQL treats -- @NULL@able fields within uniqueness constraints. The SQL -- standard says that @NULL@ values should be considered -- different, so we represent 'Inactive' as SQL @NULL@, thus -- allowing any number of 'Inactive' records. On the other hand, -- we represent 'Active' as @TRUE@, so the uniqueness constraint -- will disallow more than one 'Active' record. -- -- /Note:/ There may be DBMSs that do not respect the SQL -- standard's treatment of @NULL@ values on uniqueness -- constraints, please check if this data type works before -- relying on it. -- -- The SQL @BOOLEAN@ type is used because it's the smallest data -- type available. Note that we never use @FALSE@, just @TRUE@ -- and @NULL@. Provides the same behavior @Maybe ()@ would if -- @()@ was a valid 'PersistField'. data Checkmark = Active -- ^ When used on a uniqueness constraint, there -- may be at most one 'Active' record. | Inactive -- ^ When used on a uniqueness constraint, there -- may be any number of 'Inactive' records. deriving (Eq, Ord, Read, Show, Enum, Bounded) instance ToHttpApiData Checkmark where toUrlPiece = showTextData instance FromHttpApiData Checkmark where parseUrlPiece = parseBoundedTextData instance PathPiece Checkmark where toPathPiece Active = "active" toPathPiece Inactive = "inactive" fromPathPiece "active" = Just Active fromPathPiece "inactive" = Just Inactive fromPathPiece _ = Nothing data IsNullable = Nullable !WhyNullable | NotNullable deriving (Eq, Show) -- | The reason why a field is 'nullable' is very important. A -- field that is nullable because of a @Maybe@ tag will have its -- type changed from @A@ to @Maybe A@. OTOH, a field that is -- nullable because of a @nullable@ tag will remain with the same -- type. data WhyNullable = ByMaybeAttr | ByNullableAttr deriving (Eq, Show) data EntityDef = EntityDef { entityHaskell :: !HaskellName , entityDB :: !DBName , entityId :: !FieldDef , entityAttrs :: ![Attr] , entityFields :: ![FieldDef] , entityUniques :: ![UniqueDef] , entityForeigns:: ![ForeignDef] , entityDerives :: ![Text] , entityExtra :: !(Map Text [ExtraLine]) , entitySum :: !Bool } deriving (Show, Eq, Read, Ord) entityPrimary :: EntityDef -> Maybe CompositeDef entityPrimary t = case fieldReference (entityId t) of CompositeRef c -> Just c _ -> Nothing entityKeyFields :: EntityDef -> [FieldDef] entityKeyFields ent = case entityPrimary ent of Nothing -> [entityId ent] Just pdef -> compositeFields pdef keyAndEntityFields :: EntityDef -> [FieldDef] keyAndEntityFields ent = case entityPrimary ent of Nothing -> entityId ent : entityFields ent Just _ -> entityFields ent type ExtraLine = [Text] newtype HaskellName = HaskellName { unHaskellName :: Text } deriving (Show, Eq, Read, Ord) newtype DBName = DBName { unDBName :: Text } deriving (Show, Eq, Read, Ord) type Attr = Text data FieldType = FTTypeCon (Maybe Text) Text -- ^ Optional module and name. | FTApp FieldType FieldType | FTList FieldType deriving (Show, Eq, Read, Ord) data FieldDef = FieldDef { fieldHaskell :: !HaskellName -- ^ name of the field , fieldDB :: !DBName , fieldType :: !FieldType , fieldSqlType :: !SqlType , 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) -- | There are 3 kinds of references -- 1) composite (to fields that exist in the record) -- 2) single field -- 3) embedded 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 | CompositeRef CompositeDef | SelfReference -- ^ A SelfReference stops an immediate cycle which causes non-termination at compile-time (issue #311). deriving (Show, Eq, Read, Ord) -- | An EmbedEntityDef is the same as an EntityDef -- But it is only used for fieldReference -- so it only has data needed for embedding data EmbedEntityDef = EmbedEntityDef { embeddedHaskell :: !HaskellName , embeddedFields :: ![EmbedFieldDef] } deriving (Show, Eq, Read, Ord) -- | An EmbedFieldDef is the same as a FieldDef -- But it is only used for embeddedFields -- so it only has data needed for embedding data EmbedFieldDef = EmbedFieldDef { emFieldDB :: !DBName , emFieldEmbed :: Maybe EmbedEntityDef , emFieldCycle :: Maybe HaskellName -- ^ 'emFieldEmbed' can create a cycle (issue #311) -- when a cycle is detected, 'emFieldEmbed' will be Nothing -- and 'emFieldCycle' will be Just } deriving (Show, Eq, Read, Ord) toEmbedEntityDef :: EntityDef -> EmbedEntityDef toEmbedEntityDef ent = embDef where embDef = EmbedEntityDef { embeddedHaskell = entityHaskell ent , embeddedFields = map toEmbedFieldDef $ entityFields ent } toEmbedFieldDef :: FieldDef -> EmbedFieldDef toEmbedFieldDef field = EmbedFieldDef { emFieldDB = fieldDB field , emFieldEmbed = case fieldReference field of EmbedRef em -> Just em SelfReference -> Just embDef _ -> Nothing , emFieldCycle = case fieldReference field of SelfReference -> Just $ entityHaskell ent _ -> Nothing } -- Type for storing the Uniqueness constraint in the Schema. -- Assume you have the following schema with a uniqueness -- constraint: -- Person -- name String -- age Int -- UniqueAge age -- -- This will be represented as: -- UniqueDef (HaskellName (packPTH "UniqueAge")) -- (DBName (packPTH "unique_age")) [(HaskellName (packPTH "age"), DBName (packPTH "age"))] [] -- data UniqueDef = UniqueDef { uniqueHaskell :: !HaskellName , uniqueDBName :: !DBName , uniqueFields :: ![(HaskellName, DBName)] , uniqueAttrs :: ![Attr] } deriving (Show, Eq, Read, Ord) data CompositeDef = CompositeDef { compositeFields :: ![FieldDef] , compositeAttrs :: ![Attr] } deriving (Show, Eq, Read, Ord) -- | Used instead of FieldDef -- to generate a smaller amount of code type ForeignFieldDef = (HaskellName, DBName) data ForeignDef = ForeignDef { foreignRefTableHaskell :: !HaskellName , foreignRefTableDBName :: !DBName , foreignConstraintNameHaskell :: !HaskellName , foreignConstraintNameDBName :: !DBName , foreignFields :: ![(ForeignFieldDef, ForeignFieldDef)] -- this entity plus the primary entity , foreignAttrs :: ![Attr] , foreignNullable :: Bool } deriving (Show, Eq, Read, Ord) data PersistException = PersistError Text -- ^ Generic Exception | PersistMarshalError Text | PersistInvalidField Text | PersistForeignConstraintUnmet Text | PersistMongoDBError Text | PersistMongoDBUnsupported Text deriving (Show, Typeable) instance Exception PersistException instance Error PersistException where strMsg = PersistError . pack -- | A raw value which can be stored in any backend and can be marshalled to -- and from a 'PersistField'. data PersistValue = PersistText Text | PersistByteString ByteString | PersistInt64 Int64 | PersistDouble Double | PersistRational Rational | PersistBool Bool | PersistDay Day | PersistTimeOfDay TimeOfDay | PersistUTCTime UTCTime | PersistNull | PersistList [PersistValue] | PersistMap [(Text, PersistValue)] | PersistObjectId ByteString -- ^ Intended especially for MongoDB backend | PersistDbSpecific ByteString -- ^ Using 'PersistDbSpecific' allows you to use types specific to a particular backend -- For example, below is a simple example of the PostGIS geography type: -- -- @ -- data Geo = Geo ByteString -- -- instance PersistField Geo where -- toPersistValue (Geo t) = PersistDbSpecific t -- -- fromPersistValue (PersistDbSpecific t) = Right $ Geo $ Data.ByteString.concat ["'", t, "'"] -- fromPersistValue _ = Left "Geo values must be converted from PersistDbSpecific" -- -- instance PersistFieldSql Geo where -- sqlType _ = SqlOther "GEOGRAPHY(POINT,4326)" -- -- toPoint :: Double -> Double -> Geo -- toPoint lat lon = Geo $ Data.ByteString.concat ["'POINT(", ps $ lon, " ", ps $ lat, ")'"] -- where ps = Data.Text.pack . show -- @ -- -- If Foo has a geography field, we can then perform insertions like the following: -- -- @ -- insert $ Foo (toPoint 44 44) -- @ -- deriving (Show, Read, Eq, Typeable, Ord) instance ToHttpApiData PersistValue where toUrlPiece val = case fromPersistValueText val of Left e -> error $ T.unpack e Right y -> y instance FromHttpApiData PersistValue where parseUrlPiece input = PersistInt64 A.<$> parseUrlPiece input PersistList A.<$> readTextData input PersistText A.<$> return input where infixl 3 Left _ y = y x _ = x instance PathPiece PersistValue where toPathPiece = toUrlPiece fromPathPiece = parseUrlPieceMaybe fromPersistValueText :: PersistValue -> Either Text Text fromPersistValueText (PersistText s) = Right s fromPersistValueText (PersistByteString bs) = Right $ TE.decodeUtf8With lenientDecode bs fromPersistValueText (PersistInt64 i) = Right $ T.pack $ show i fromPersistValueText (PersistDouble d) = Right $ T.pack $ show d fromPersistValueText (PersistRational r) = Right $ T.pack $ show r fromPersistValueText (PersistDay d) = Right $ T.pack $ show d fromPersistValueText (PersistTimeOfDay d) = Right $ T.pack $ show d fromPersistValueText (PersistUTCTime d) = Right $ T.pack $ show d fromPersistValueText PersistNull = Left "Unexpected null" fromPersistValueText (PersistBool b) = Right $ T.pack $ show b fromPersistValueText (PersistList _) = Left "Cannot convert PersistList to Text" fromPersistValueText (PersistMap _) = Left "Cannot convert PersistMap to Text" fromPersistValueText (PersistObjectId _) = Left "Cannot convert PersistObjectId to Text" fromPersistValueText (PersistDbSpecific _) = Left "Cannot convert PersistDbSpecific to Text" 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 $ #if MIN_VERSION_aeson(0, 7, 0) Data.Scientific.fromFloatDigits #else AN.D #endif d toJSON (PersistRational r) = A.String $ T.pack $ 'r' : show r toJSON (PersistBool b) = A.Bool b toJSON (PersistTimeOfDay t) = A.String $ T.pack $ 't' : show t toJSON (PersistUTCTime u) = A.String $ T.pack $ 'u' : show u toJSON (PersistDay d) = A.String $ T.pack $ '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 (PersistDbSpecific b) = A.String $ T.cons 'p' $ TE.decodeUtf8 $ B64.encode b toJSON (PersistObjectId o) = A.toJSON $ showChar 'o' $ showHexLen 8 (bs2i four) $ showHexLen 16 (bs2i eight) "" where (four, eight) = BS8.splitAt 4 o -- taken from crypto-api bs2i :: ByteString -> Integer bs2i bs = foldl' (\i b -> (i `shiftL` 8) + fromIntegral b) 0 bs {-# INLINE bs2i #-} -- showHex of n padded with leading zeros if necessary to fill d digits -- taken from Data.BSON showHexLen :: (Show n, Integral n) => Int -> n -> ShowS showHexLen d n = showString (replicate (d - sigDigits n) '0') . showHex n where sigDigits 0 = 1 sigDigits n' = truncate (logBase (16 :: Double) $ fromIntegral n') + 1 instance A.FromJSON PersistValue where parseJSON (A.String t0) = case T.uncons t0 of Nothing -> fail "Null string" Just ('p', t) -> either (fail "Invalid base64") (return . PersistDbSpecific) $ B64.decode $ TE.encodeUtf8 t 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 ('r', t) -> fmap PersistRational $ readMay t Just ('o', t) -> maybe (fail "Invalid base64") (return . PersistObjectId) $ fmap (i2bs (8 * 12) . fst) $ headMay $ readHex $ T.unpack t Just (c, _) -> fail $ "Unknown prefix: " ++ [c] where headMay [] = Nothing headMay (x:_) = Just x readMay :: (Read a, Monad m) => T.Text -> m a readMay t = case reads $ T.unpack t of (x, _):_ -> return x [] -> fail "Could not read" -- taken from crypto-api -- |@i2bs bitLen i@ converts @i@ to a 'ByteString' of @bitLen@ bits (must be a multiple of 8). i2bs :: Int -> Integer -> BS.ByteString i2bs l i = BS.unfoldr (\l' -> if l' < 0 then Nothing else Just (fromIntegral (i `shiftR` l'), l' - 8)) (l-8) {-# INLINE i2bs #-} #if MIN_VERSION_aeson(0, 7, 0) parseJSON (A.Number n) = return $ if fromInteger (floor n) == n then PersistInt64 $ floor n else PersistDouble $ fromRational $ toRational n #else parseJSON (A.Number (AN.I i)) = return $ PersistInt64 $ fromInteger i parseJSON (A.Number (AN.D d)) = return $ PersistDouble d #endif 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. data SqlType = SqlString | SqlInt32 | SqlInt64 | SqlReal | SqlNumeric Word32 Word32 | SqlBool | SqlDay | SqlTime | SqlDayTime -- ^ Always uses UTC timezone | SqlBlob | SqlOther T.Text -- ^ a backend-specific name deriving (Show, Read, Eq, Typeable, Ord) data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le | In | NotIn | BackendSpecificFilter T.Text deriving (Read, Show) data UpdateException = KeyNotFound String | UpsertError String deriving Typeable instance Show UpdateException where show (KeyNotFound key) = "Key not found during updateGet: " ++ key show (UpsertError msg) = "Error during upsert: " ++ msg instance Exception UpdateException data OnlyUniqueException = OnlyUniqueException String deriving Typeable instance Show OnlyUniqueException where show (OnlyUniqueException uniqueMsg) = "Expected only one unique key, got " ++ uniqueMsg instance Exception OnlyUniqueException data PersistUpdate = Assign | Add | Subtract | Multiply | Divide | BackendSpecificUpdate T.Text deriving (Read, Show) persistent-2.7.1/Database/Persist/Class/DeleteCascade.hs0000644000000000000000000000253013170567656021333 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} module Database.Persist.Class.DeleteCascade ( DeleteCascade (..) , deleteCascadeWhere ) where import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistQuery import Database.Persist.Class.PersistEntity import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (ReaderT, ask, runReaderT) import Data.Acquire (with) -- | For combinations of backends and entities that support -- cascade-deletion. “Cascade-deletion” means that entries that depend on -- other entries to be deleted will be deleted as well. class (PersistStoreWrite backend, PersistEntity record, BaseBackend backend ~ PersistEntityBackend record) => DeleteCascade record backend where -- | Perform cascade-deletion of single database -- entry. deleteCascade :: MonadIO m => Key record -> ReaderT backend m () -- | Cascade-deletion of entries satisfying given filters. deleteCascadeWhere :: (MonadIO m, DeleteCascade record backend, PersistQueryWrite backend) => [Filter record] -> ReaderT backend m () deleteCascadeWhere filts = do srcRes <- selectKeysRes filts [] conn <- ask liftIO $ with srcRes (C.$$ CL.mapM_ (flip runReaderT conn . deleteCascade)) persistent-2.7.1/Database/Persist/Class/PersistEntity.hs0000644000000000000000000003467113170567656021526 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts, StandaloneDeriving, UndecidableInstances #-} module Database.Persist.Class.PersistEntity ( PersistEntity (..) , Update (..) , BackendSpecificUpdate , SelectOpt (..) , Filter (..) , BackendSpecificFilter , Entity (..) , entityValues , keyValueEntityToJSON, keyValueEntityFromJSON , entityIdToJSON, entityIdFromJSON -- * PersistField based on other typeclasses , toPersistValueJSON, fromPersistValueJSON , toPersistValueEnum, fromPersistValueEnum ) where import Database.Persist.Types.Base import Database.Persist.Class.PersistField import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as TB import Data.Aeson (ToJSON (..), FromJSON (..), fromJSON, object, (.:), (.=), Value (Object)) import qualified Data.Aeson.Parser as AP import Data.Aeson.Types (Parser,Result(Error,Success)) #if MIN_VERSION_aeson(1,0,0) import Data.Aeson.Text (encodeToTextBuilder) #else import Data.Aeson.Encode (encodeToTextBuilder) #endif import Data.Attoparsec.ByteString (parseOnly) import Control.Applicative as A ((<$>), (<*>)) import Data.Monoid (mappend) import qualified Data.HashMap.Strict as HM import Data.Typeable (Typeable) import Data.Maybe (isJust) -- | Persistent serialized Haskell records to the database. -- A Database 'Entity' (A row in SQL, a document in MongoDB, etc) -- corresponds to a 'Key' plus a Haskell record. -- -- For every Haskell record type stored in the database there is a -- corresponding 'PersistEntity' instance. An instance of PersistEntity -- contains meta-data for the record. PersistEntity also helps abstract -- over different record types. That way the same query interface can return -- a 'PersistEntity', with each query returning different types of Haskell -- records. -- -- Some advanced type system capabilities are used to make this process -- type-safe. Persistent users usually don't need to understand the class -- associated data and functions. class ( PersistField (Key record), ToJSON (Key record), FromJSON (Key record) , Show (Key record), Read (Key record), Eq (Key record), Ord (Key record)) => PersistEntity record where -- | Persistent allows multiple different backends (databases). type PersistEntityBackend record -- | By default, a backend will automatically generate the key -- Instead you can specify a Primary key made up of unique values. data Key record -- | A lower-level key operation. keyToValues :: Key record -> [PersistValue] -- | A lower-level key operation. keyFromValues :: [PersistValue] -> Either Text (Key record) -- | A meta-operation to retrieve the 'Key' 'EntityField'. persistIdField :: EntityField record (Key record) -- | Retrieve the 'EntityDef' meta-data for the record. entityDef :: Monad m => m record -> EntityDef -- | An 'EntityField' is parameterised by the Haskell record it belongs to -- and the additional type of that field. data EntityField record :: * -> * -- | Return meta-data for a given 'EntityField'. persistFieldDef :: EntityField record typ -> FieldDef -- | A meta-operation to get the database fields of a record. toPersistFields :: record -> [SomePersistField] -- | A lower-level operation to convert from database values to a Haskell record. fromPersistValues :: [PersistValue] -> Either Text record -- | Unique keys besides the 'Key'. data Unique record -- | A meta operation to retrieve all the 'Unique' keys. persistUniqueKeys :: record -> [Unique record] -- | A lower level operation. persistUniqueToFieldNames :: Unique record -> [(HaskellName, DBName)] -- | A lower level operation. persistUniqueToValues :: Unique record -> [PersistValue] -- | Use a 'PersistField' as a lens. fieldLens :: EntityField record field -> (forall f. Functor f => (field -> f field) -> Entity record -> f (Entity record)) type family BackendSpecificUpdate backend record -- | Updating a database entity. -- -- Persistent users use combinators to create these. data Update record = forall typ. PersistField typ => Update { updateField :: EntityField record typ , updateValue :: typ -- FIXME Replace with expr down the road , updateUpdate :: PersistUpdate } | BackendUpdate (BackendSpecificUpdate (PersistEntityBackend record) record) -- | Query options. -- -- Persistent users use these directly. data SelectOpt record = forall typ. Asc (EntityField record typ) | forall typ. Desc (EntityField record typ) | OffsetBy Int | LimitTo Int type family BackendSpecificFilter backend record -- | Filters which are available for 'select', 'updateWhere' and -- 'deleteWhere'. Each filter constructor specifies the field being -- filtered on, the type of comparison applied (equals, not equals, etc) -- and the argument for the comparison. -- -- Persistent users use combinators to create these. data Filter record = forall typ. PersistField typ => Filter { filterField :: EntityField record typ , filterValue :: Either typ [typ] -- FIXME , filterFilter :: PersistFilter -- FIXME } | FilterAnd [Filter record] -- ^ convenient for internal use, not needed for the API | FilterOr [Filter record] | BackendFilter (BackendSpecificFilter (PersistEntityBackend record) record) -- | Datatype that represents an entity, with both its 'Key' and -- its Haskell record representation. -- -- When using a SQL-based backend (such as SQLite or -- PostgreSQL), an 'Entity' may take any number of columns -- depending on how many fields it has. In order to reconstruct -- your entity on the Haskell side, @persistent@ needs all of -- your entity columns and in the right order. Note that you -- don't need to worry about this when using @persistent@\'s API -- since everything is handled correctly behind the scenes. -- -- However, if you want to issue a raw SQL command that returns -- an 'Entity', then you have to be careful with the column -- order. While you could use @SELECT Entity.* WHERE ...@ and -- that would work most of the time, there are times when the -- order of the columns on your database is different from the -- order that @persistent@ expects (for example, if you add a new -- field in the middle of you entity definition and then use the -- migration code -- @persistent@ will expect the column to be in -- the middle, but your DBMS will put it as the last column). -- So, instead of using a query like the one above, you may use -- 'Database.Persist.GenericSql.rawSql' (from the -- "Database.Persist.GenericSql" module) with its /entity -- selection placeholder/ (a double question mark @??@). Using -- @rawSql@ the query above must be written as @SELECT ?? WHERE -- ..@. Then @rawSql@ will replace @??@ with the list of all -- columns that we need from your entity in the right order. If -- 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 record = PersistEntity record => Entity { entityKey :: Key record , entityVal :: record } deriving instance (PersistEntity record, Eq (Key record), Eq record) => Eq (Entity record) deriving instance (PersistEntity record, Ord (Key record), Ord record) => Ord (Entity record) deriving instance (PersistEntity record, Show (Key record), Show record) => Show (Entity record) deriving instance (PersistEntity record, Read (Key record), Read record) => Read (Entity record) #if MIN_VERSION_base(4,7,0) deriving instance Typeable Entity #endif -- | Get list of values corresponding to given entity. entityValues :: PersistEntity record => Entity record -> [PersistValue] entityValues (Entity k record) = if isJust (entityPrimary ent) then -- TODO: check against the key map toPersistValue (toPersistFields record) else keyToValues k ++ map toPersistValue (toPersistFields record) where ent = entityDef $ Just record -- | Predefined @toJSON@. The resulting JSON looks like -- @{"key": 1, "value": {"name": ...}}@. -- -- The typical usage is: -- -- @ -- instance ToJSON (Entity User) where -- toJSON = keyValueEntityToJSON -- @ keyValueEntityToJSON :: (PersistEntity record, ToJSON record, ToJSON (Key record)) => Entity record -> Value keyValueEntityToJSON (Entity key value) = object [ "key" .= key , "value" .= value ] -- | Predefined @parseJSON@. The input JSON looks like -- @{"key": 1, "value": {"name": ...}}@. -- -- The typical usage is: -- -- @ -- instance FromJSON (Entity User) where -- parseJSON = keyValueEntityFromJSON -- @ keyValueEntityFromJSON :: (PersistEntity record, FromJSON record, FromJSON (Key record)) => Value -> Parser (Entity record) keyValueEntityFromJSON (Object o) = Entity A.<$> o .: "key" A.<*> o .: "value" keyValueEntityFromJSON _ = fail "keyValueEntityFromJSON: not an object" -- | Predefined @toJSON@. The resulting JSON looks like -- @{"id": 1, "name": ...}@. -- -- The typical usage is: -- -- @ -- instance ToJSON (Entity User) where -- toJSON = entityIdToJSON -- @ entityIdToJSON :: (PersistEntity record, ToJSON record, ToJSON (Key record)) => Entity record -> Value entityIdToJSON (Entity key value) = case toJSON value of Object o -> Object $ HM.insert "id" (toJSON key) o x -> x -- | Predefined @parseJSON@. The input JSON looks like -- @{"id": 1, "name": ...}@. -- -- The typical usage is: -- -- @ -- instance FromJSON (Entity User) where -- parseJSON = entityIdFromJSON -- @ entityIdFromJSON :: (PersistEntity record, FromJSON record, FromJSON (Key record)) => Value -> Parser (Entity record) entityIdFromJSON value@(Object o) = Entity <$> o .: "id" <*> parseJSON value entityIdFromJSON _ = fail "entityIdFromJSON: not an object" instance (PersistEntity record, PersistField record, PersistField (Key record)) => PersistField (Entity record) where toPersistValue (Entity key value) = case toPersistValue value of (PersistMap alist) -> PersistMap ((idField, toPersistValue key) : alist) _ -> error $ T.unpack $ errMsg "expected PersistMap" fromPersistValue (PersistMap alist) = case after of [] -> Left $ errMsg $ "did not find " `Data.Monoid.mappend` idField `mappend` " field" ("_id", kv):afterRest -> fromPersistValue (PersistMap (before ++ afterRest)) >>= \record -> keyFromValues [kv] >>= \k -> Right (Entity k record) _ -> Left $ errMsg $ "impossible id field: " `mappend` T.pack (show alist) where (before, after) = break ((== idField) . fst) alist fromPersistValue x = Left $ errMsg "Expected PersistMap, received: " `mappend` T.pack (show x) errMsg :: Text -> Text errMsg = mappend "PersistField entity fromPersistValue: " -- | Realistically this is only going to be used for MongoDB, -- so lets use MongoDB conventions idField :: Text idField = "_id" -- | Convenience function for getting a free 'PersistField' instance -- from a type with JSON instances. -- -- -- Example usage in combination with 'fromPersistValueJSON': -- -- @ -- instance PersistField MyData where -- fromPersistValue = fromPersistValueJSON -- toPersistValue = toPersistValueJSON -- @ toPersistValueJSON :: ToJSON a => a -> PersistValue toPersistValueJSON = PersistText . LT.toStrict . TB.toLazyText . encodeToTextBuilder . toJSON -- | Convenience function for getting a free 'PersistField' instance -- from a type with JSON instances. The JSON parser used will accept JSON -- values other that object and arrays. So, if your instance serializes the -- data to a JSON string, this will still work. -- -- -- Example usage in combination with 'toPersistValueJSON': -- -- @ -- instance PersistField MyData where -- fromPersistValue = fromPersistValueJSON -- toPersistValue = toPersistValueJSON -- @ fromPersistValueJSON :: FromJSON a => PersistValue -> Either Text a fromPersistValueJSON z = case z of PersistByteString bs -> mapLeft (T.append "Could not parse the JSON (was a PersistByteString): ") $ parseGo bs PersistText t -> mapLeft (T.append "Could not parse the JSON (was PersistText): ") $ parseGo (TE.encodeUtf8 t) a -> Left $ T.append "Expected PersistByteString, received: " (T.pack (show a)) where parseGo bs = mapLeft T.pack $ case parseOnly AP.value bs of Left err -> Left err Right v -> case fromJSON v of Error err -> Left err Success a -> Right a mapLeft _ (Right a) = Right a mapLeft f (Left b) = Left (f b) -- | Convenience function for getting a free 'PersistField' instance -- from a type with an 'Enum' instance. The function 'derivePersistField' -- from the persistent-template package should generally be preferred. -- However, if you want to ensure that an @ORDER BY@ clause that uses -- your field will order rows by the data constructor order, this is -- a better choice. -- -- Example usage in combination with 'fromPersistValueEnum': -- -- @ -- data SeverityLevel = Low | Medium | Critical | High -- deriving (Enum, Bounded) -- instance PersistField SeverityLevel where -- fromPersistValue = fromPersistValueEnum -- toPersistValue = toPersistValueEnum -- @ toPersistValueEnum :: Enum a => a -> PersistValue toPersistValueEnum = toPersistValue . fromEnum -- | Convenience function for getting a free 'PersistField' instance -- from a type with an 'Enum' instance. This function also requires -- a `Bounded` instance to improve the reporting of errors. -- -- Example usage in combination with 'toPersistValueEnum': -- -- @ -- data SeverityLevel = Low | Medium | Critical | High -- deriving (Enum, Bounded) -- instance PersistField SeverityLevel where -- fromPersistValue = fromPersistValueEnum -- toPersistValue = toPersistValueEnum -- @ fromPersistValueEnum :: (Enum a, Bounded a) => PersistValue -> Either Text a fromPersistValueEnum v = fromPersistValue v >>= go where go i = let res = toEnum i in if i >= fromEnum (asTypeOf minBound res) && i <= fromEnum (asTypeOf maxBound res) then Right res else Left ("The number " `mappend` T.pack (show i) `mappend` " was out of the " `mappend` "allowed bounds for an enum type") persistent-2.7.1/Database/Persist/Class/PersistQuery.hs0000644000000000000000000001062013170567656021343 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} module Database.Persist.Class.PersistQuery ( PersistQueryRead (..) , PersistQueryWrite (..) , selectSource , selectKeys , selectList , selectKeysList ) where import Database.Persist.Types import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (ReaderT, MonadReader) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistEntity import Control.Monad.Trans.Resource (MonadResource, release) import Data.Acquire (Acquire, allocateAcquire, with) -- | Backends supporting conditional read operations. class (PersistCore backend, PersistStoreRead backend) => PersistQueryRead backend where -- | Get all records matching the given criterion in the specified order. -- Returns also the identifiers. selectSourceRes :: (PersistRecordBackend record backend, MonadIO m1, MonadIO m2) => [Filter record] -> [SelectOpt record] -> ReaderT backend m1 (Acquire (C.Source m2 (Entity record))) -- | Get just the first record for the criterion. selectFirst :: (MonadIO m, PersistRecordBackend record backend) => [Filter record] -> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record)) selectFirst filts opts = do srcRes <- selectSourceRes filts (LimitTo 1 : opts) liftIO $ with srcRes (C.$$ CL.head) -- | Get the 'Key's of all records matching the given criterion. selectKeysRes :: (MonadIO m1, MonadIO m2, PersistRecordBackend record backend) => [Filter record] -> [SelectOpt record] -> ReaderT backend m1 (Acquire (C.Source m2 (Key record))) -- | The total number of records fulfilling the given criterion. count :: (MonadIO m, PersistRecordBackend record backend) => [Filter record] -> ReaderT backend m Int -- | Backends supporting conditional write operations class (PersistQueryRead backend, PersistStoreWrite backend) => PersistQueryWrite backend where -- | Update individual fields on any record matching the given criterion. updateWhere :: (MonadIO m, PersistRecordBackend record backend) => [Filter record] -> [Update record] -> ReaderT backend m () -- | Delete all records matching the given criterion. deleteWhere :: (MonadIO m, PersistRecordBackend record backend) => [Filter record] -> ReaderT backend m () -- | Get all records matching the given criterion in the specified order. -- Returns also the identifiers. selectSource :: (PersistQueryRead (BaseBackend backend), MonadResource m, PersistEntity record, PersistEntityBackend record ~ BaseBackend (BaseBackend backend), MonadReader backend m, HasPersistBackend backend) => [Filter record] -> [SelectOpt record] -> C.Source m (Entity record) selectSource filts opts = do srcRes <- liftPersist $ selectSourceRes filts opts (releaseKey, src) <- allocateAcquire srcRes src release releaseKey -- | Get the 'Key's of all records matching the given criterion. selectKeys :: (PersistQueryRead (BaseBackend backend), MonadResource m, PersistEntity record, BaseBackend (BaseBackend backend) ~ PersistEntityBackend record, MonadReader backend m, HasPersistBackend backend) => [Filter record] -> [SelectOpt record] -> C.Source m (Key record) selectKeys filts opts = do srcRes <- liftPersist $ selectKeysRes filts opts (releaseKey, src) <- allocateAcquire srcRes src release releaseKey -- | Call 'selectSource' but return the result as a list. selectList :: (MonadIO m, PersistQueryRead backend, PersistRecordBackend record backend) => [Filter record] -> [SelectOpt record] -> ReaderT backend m [Entity record] selectList filts opts = do srcRes <- selectSourceRes filts opts liftIO $ with srcRes (C.$$ CL.consume) -- | Call 'selectKeys' but return the result as a list. selectKeysList :: (MonadIO m, PersistQueryRead backend, PersistRecordBackend record backend) => [Filter record] -> [SelectOpt record] -> ReaderT backend m [Key record] selectKeysList filts opts = do srcRes <- selectKeysRes filts opts liftIO $ with srcRes (C.$$ CL.consume) persistent-2.7.1/Database/Persist/Class/PersistUnique.hs0000644000000000000000000002315413173255472021503 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-} module Database.Persist.Class.PersistUnique (PersistUniqueRead(..) ,PersistUniqueWrite(..) ,getByValue ,insertBy ,insertUniqueEntity ,replaceUnique ,checkUnique ,onlyUnique) where import Database.Persist.Types import Control.Exception (throwIO) import Control.Monad (liftM) import Control.Monad.IO.Class (liftIO, MonadIO) import Data.List ((\\)) import Control.Monad.Trans.Reader (ReaderT) import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistEntity import Data.Monoid (mappend) import Data.Text (unpack, Text) -- | Queries against 'Unique' keys (other than the id 'Key'). -- -- Please read the general Persistent documentation to learn how to create -- 'Unique' keys. -- -- Using this with an Entity without a Unique key leads to undefined -- behavior. A few of these functions require a /single/ 'Unique', so using -- an Entity with multiple 'Unique's is also undefined. In these cases -- persistent's goal is to throw an exception as soon as possible, but -- persistent is still transitioning to that. -- -- SQL backends automatically create uniqueness constraints, but for MongoDB -- you must manually place a unique index on a field to have a uniqueness -- constraint. -- class (PersistCore backend, PersistStoreRead backend) => PersistUniqueRead backend where -- | Get a record by unique key, if available. Returns also the identifier. getBy :: (MonadIO m, PersistRecordBackend record backend) => Unique record -> ReaderT backend m (Maybe (Entity record)) -- | Some functions in this module ('insertUnique', 'insertBy', and -- 'replaceUnique') first query the unique indexes to check for -- conflicts. You could instead optimistically attempt to perform the -- operation (e.g. 'replace' instead of 'replaceUnique'). However, -- -- * there is some fragility to trying to catch the correct exception and -- determing the column of failure; -- -- * an exception will automatically abort the current SQL transaction. class (PersistUniqueRead backend, PersistStoreWrite backend) => PersistUniqueWrite backend where -- | Delete a specific record by unique key. Does nothing if no record -- matches. deleteBy :: (MonadIO m, PersistRecordBackend record backend) => Unique record -> ReaderT backend m () -- | Like 'insert', but returns 'Nothing' when the record -- couldn't be inserted because of a uniqueness constraint. insertUnique :: (MonadIO m, PersistRecordBackend record backend) => record -> ReaderT backend m (Maybe (Key record)) insertUnique datum = do conflict <- checkUnique datum case conflict of Nothing -> Just `liftM` insert datum Just _ -> return Nothing -- | Update based on a uniqueness constraint or insert: -- -- * insert the new record if it does not exist; -- * If the record exists (matched via it's uniqueness constraint), then update the existing record with the parameters which is passed on as list to the function. -- -- Throws an exception if there is more than 1 uniqueness contraint. upsert :: (MonadIO m, PersistRecordBackend record backend) => record -- ^ new record to insert -> [Update record] -- ^ updates to perform if the record already exists (leaving -- this empty is the equivalent of performing a 'repsert' on a -- unique key) -> ReaderT backend m (Entity record) -- ^ the record in the database after the operation upsert record updates = do uniqueKey <- onlyUnique record upsertBy uniqueKey record updates -- | Update based on a given uniqueness constraint or insert: -- -- * insert the new record if it does not exist; -- * update the existing record that matches the given uniqueness contraint. upsertBy :: (MonadIO m, PersistRecordBackend record backend) => Unique record -- ^ uniqueness constraint to find by -> record -- ^ new record to insert -> [Update record] -- ^ updates to perform if the record already exists (leaving -- this empty is the equivalent of performing a 'repsert' on a -- unique key) -> ReaderT backend m (Entity record) -- ^ the record in the database after the operation upsertBy uniqueKey record updates = do mrecord <- getBy uniqueKey maybe (insertEntity record) (`updateGetEntity` updates) mrecord where updateGetEntity (Entity k _) upds = (Entity k) `liftM` (updateGet k upds) -- | 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 :: (MonadIO m ,PersistUniqueWrite backend ,PersistRecordBackend record backend) => record -> ReaderT backend m (Either (Entity record) (Key record)) insertBy val = do res <- getByValue val case res of Nothing -> Right `liftM` insert val Just z -> return $ Left z -- | Insert a value, checking for conflicts with any unique constraints. If a -- duplicate exists in the database, it is left untouched. The key of the -- existing or new entry is returned _insertOrGet :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend record backend) => record -> ReaderT backend m (Key record) _insertOrGet val = do res <- getByValue val case res of Nothing -> insert val Just (Entity key _) -> return key -- | Like 'insertEntity', but returns 'Nothing' when the record -- couldn't be inserted because of a uniqueness constraint. -- -- @since 2.7.1 insertUniqueEntity :: (MonadIO m ,PersistRecordBackend record backend ,PersistUniqueWrite backend) => record -> ReaderT backend m (Maybe (Entity record)) insertUniqueEntity datum = fmap (\key -> Entity key datum) `liftM` insertUnique datum -- | Return the single unique key for a record. onlyUnique :: (MonadIO m ,PersistUniqueWrite backend ,PersistRecordBackend record backend) => record -> ReaderT backend m (Unique record) onlyUnique record = case onlyUniqueEither record of Right u -> return u Left us -> requireUniques record us >>= liftIO . throwIO . OnlyUniqueException . show . length onlyUniqueEither :: (PersistEntity record) => record -> Either [Unique record] (Unique record) onlyUniqueEither record = case persistUniqueKeys record of [u] -> Right u us -> Left us -- | A modification of 'getBy', which takes the 'PersistEntity' itself instead -- of a 'Unique' record. Returns a record matching /one/ of the unique keys. This -- function makes the most sense on entities with a single 'Unique' -- constructor. getByValue :: (MonadIO m ,PersistUniqueRead backend ,PersistRecordBackend record backend) => record -> ReaderT backend m (Maybe (Entity record)) getByValue record = checkUniques =<< requireUniques record (persistUniqueKeys record) where checkUniques [] = return Nothing checkUniques (x:xs) = do y <- getBy x case y of Nothing -> checkUniques xs Just z -> return $ Just z requireUniques :: (MonadIO m, PersistEntity record) => record -> [Unique record] -> m [Unique record] requireUniques record [] = liftIO $ throwIO $ userError errorMsg where errorMsg = "getByValue: " `Data.Monoid.mappend` unpack (recordName record) `mappend` " does not have any Unique" requireUniques _ xs = return xs -- TODO: expose this to users recordName :: (PersistEntity record) => record -> Text recordName = unHaskellName . entityHaskell . entityDef . Just -- | Attempt to replace the record of the given key with the given new record. -- First query the unique fields to make sure the replacement maintains -- uniqueness constraints. -- -- Return 'Nothing' if the replacement was made. -- If uniqueness is violated, return a 'Just' with the 'Unique' violation -- -- @since 1.2.2.0 replaceUnique :: (MonadIO m ,Eq record ,Eq (Unique record) ,PersistRecordBackend record backend ,PersistUniqueWrite backend) => Key record -> record -> ReaderT backend m (Maybe (Unique record)) replaceUnique key datumNew = getJust key >>= replaceOriginal where uniqueKeysNew = persistUniqueKeys datumNew replaceOriginal original = do conflict <- checkUniqueKeys changedKeys case conflict of Nothing -> replace key datumNew >> return Nothing (Just conflictingKey) -> return $ Just conflictingKey where changedKeys = uniqueKeysNew \\ uniqueKeysOriginal uniqueKeysOriginal = persistUniqueKeys original -- | Check whether there are any conflicts for unique keys with this entity and -- existing entities in the database. -- -- Returns 'Nothing' if the entity would be unique, and could thus safely be inserted. -- on a conflict returns the conflicting key checkUnique :: (MonadIO m ,PersistRecordBackend record backend ,PersistUniqueRead backend) => record -> ReaderT backend m (Maybe (Unique record)) checkUnique = checkUniqueKeys . persistUniqueKeys checkUniqueKeys :: (MonadIO m ,PersistEntity record ,PersistUniqueRead backend ,PersistRecordBackend record backend) => [Unique record] -> ReaderT backend m (Maybe (Unique record)) checkUniqueKeys [] = return Nothing checkUniqueKeys (x:xs) = do y <- getBy x case y of Nothing -> checkUniqueKeys xs Just _ -> return (Just x) persistent-2.7.1/Database/Persist/Class/PersistConfig.hs0000644000000000000000000000422413170567656021446 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Database.Persist.Class.PersistConfig ( PersistConfig (..) ) where import Data.Aeson (Value (Object)) import Data.Aeson.Types (Parser) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Applicative as A ((<$>)) import qualified Data.HashMap.Strict as HashMap -- | Represents a value containing all the configuration options for a specific -- backend. This abstraction makes it easier to write code that can easily swap -- backends. class PersistConfig c where type PersistConfigBackend c :: (* -> *) -> * -> * type PersistConfigPool c -- | Load the config settings from a 'Value', most likely taken from a YAML -- config file. loadConfig :: Value -> Parser c -- | Modify the config settings based on environment variables. applyEnv :: c -> IO c applyEnv = return -- | Create a new connection pool based on the given config settings. createPoolConfig :: c -> IO (PersistConfigPool c) -- | Run a database action by taking a connection from the pool. runPool :: (MonadBaseControl IO m, MonadIO m) => c -> PersistConfigBackend c m a -> PersistConfigPool c -> m a instance ( PersistConfig c1 , PersistConfig c2 , PersistConfigPool c1 ~ PersistConfigPool c2 , PersistConfigBackend c1 ~ PersistConfigBackend c2 ) => PersistConfig (Either c1 c2) where type PersistConfigBackend (Either c1 c2) = PersistConfigBackend c1 type PersistConfigPool (Either c1 c2) = PersistConfigPool c1 loadConfig (Object o) = case HashMap.lookup "left" o of Just v -> Left A.<$> loadConfig v Nothing -> case HashMap.lookup "right" o of Just v -> Right <$> loadConfig v Nothing -> fail "PersistConfig for Either: need either a left or right" loadConfig _ = fail "PersistConfig for Either: need an object" createPoolConfig = either createPoolConfig createPoolConfig runPool (Left c) = runPool c runPool (Right c) = runPool c persistent-2.7.1/Database/Persist/Class/PersistField.hs0000644000000000000000000004252513170567656021272 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} #if !MIN_VERSION_base(4,8,0) {-# LANGUAGE OverlappingInstances #-} #endif module Database.Persist.Class.PersistField ( PersistField (..) , SomePersistField (..) , getPersistMap ) where import Control.Arrow (second) import Database.Persist.Types.Base import Data.Time (Day(..), TimeOfDay, UTCTime, #if MIN_VERSION_time(1,5,0) parseTimeM) #else parseTime) #endif #ifdef HIGH_PRECISION_DATE import Data.Time.Clock.POSIX (posixSecondsToUTCTime) #endif import Data.ByteString.Char8 (ByteString, unpack, readInt) import Control.Applicative as A import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word, Word8, Word16, Word32, Word64) import Data.Text (Text) import Data.Text.Read (double) import Data.Fixed import Data.Monoid ((<>)) import Text.Blaze.Html import Text.Blaze.Html.Renderer.Text (renderHtml) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.ByteString.Lazy as L import Control.Monad ((<=<)) import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T import qualified Data.Aeson as A import qualified Data.Set as S import qualified Data.Map as M import qualified Data.IntMap as IM import qualified Data.Text.Encoding as TE import qualified Data.Vector as V #if MIN_VERSION_time(1,5,0) import Data.Time (defaultTimeLocale) #else import System.Locale (defaultTimeLocale) #endif #if MIN_VERSION_base(4,8,0) import Numeric.Natural (Natural) #endif -- | A value which can be marshalled to and from a 'PersistValue'. class PersistField a where toPersistValue :: a -> PersistValue fromPersistValue :: PersistValue -> Either T.Text a #ifndef NO_OVERLAP #if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPING #-} PersistField [Char] where #else instance PersistField [Char] where #endif toPersistValue = PersistText . T.pack fromPersistValue (PersistText s) = Right $ T.unpack s fromPersistValue (PersistByteString bs) = Right $ T.unpack $ T.decodeUtf8With T.lenientDecode bs fromPersistValue (PersistInt64 i) = Right $ Prelude.show i fromPersistValue (PersistDouble d) = Right $ Prelude.show d fromPersistValue (PersistRational r) = Right $ Prelude.show r fromPersistValue (PersistDay d) = Right $ Prelude.show d fromPersistValue (PersistTimeOfDay d) = Right $ Prelude.show d fromPersistValue (PersistUTCTime d) = Right $ Prelude.show d fromPersistValue PersistNull = Left $ T.pack "Unexpected null" fromPersistValue (PersistBool b) = Right $ Prelude.show b fromPersistValue (PersistList _) = Left $ T.pack "Cannot convert PersistList to String" fromPersistValue (PersistMap _) = Left $ T.pack "Cannot convert PersistMap to String" fromPersistValue (PersistDbSpecific _) = Left $ T.pack "Cannot convert PersistDbSpecific to String" fromPersistValue (PersistObjectId _) = Left $ T.pack "Cannot convert PersistObjectId to String" #endif instance PersistField ByteString where toPersistValue = PersistByteString fromPersistValue (PersistByteString bs) = Right bs fromPersistValue x = T.encodeUtf8 A.<$> fromPersistValue x instance PersistField T.Text where toPersistValue = PersistText fromPersistValue = fromPersistValueText instance PersistField TL.Text where toPersistValue = toPersistValue . TL.toStrict fromPersistValue = fmap TL.fromStrict . fromPersistValue instance PersistField Html where toPersistValue = PersistText . TL.toStrict . renderHtml fromPersistValue = fmap (preEscapedToMarkup :: T.Text -> Html) . fromPersistValue instance PersistField Int where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue (PersistDouble i) = Right (truncate i :: Int) -- oracle fromPersistValue x = Left $ T.pack $ "int Expected Integer, received: " ++ show x instance PersistField Int8 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue (PersistDouble i) = Right (truncate i :: Int8) -- oracle fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle Just (i,"") -> Right $ fromIntegral i xs -> error $ "PersistField Int8 failed parsing PersistByteString xs["++show xs++"] i["++show bs++"]" fromPersistValue x = Left $ T.pack $ "int8 Expected Integer, received: " ++ show x instance PersistField Int16 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue (PersistDouble i) = Right (truncate i :: Int16) -- oracle fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle Just (i,"") -> Right $ fromIntegral i xs -> error $ "PersistField Int16 failed parsing PersistByteString xs["++show xs++"] i["++show bs++"]" fromPersistValue x = Left $ T.pack $ "int16 Expected Integer, received: " ++ show x instance PersistField Int32 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue (PersistDouble i) = Right (truncate i :: Int32) -- oracle fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle Just (i,"") -> Right $ fromIntegral i xs -> error $ "PersistField Int32 failed parsing PersistByteString xs["++show xs++"] i["++show bs++"]" fromPersistValue x = Left $ T.pack $ "int32 Expected Integer, received: " ++ show x instance PersistField Int64 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue (PersistDouble i) = Right (truncate i :: Int64) -- oracle fromPersistValue (PersistByteString bs) = case readInt bs of -- oracle Just (i,"") -> Right $ fromIntegral i xs -> error $ "PersistField Int64 failed parsing PersistByteString xs["++show xs++"] i["++show bs++"]" fromPersistValue x = Left $ T.pack $ "int64 Expected Integer, received: " ++ show x instance PersistField Data.Word.Word where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ T.pack $ "Expected Word, received: " ++ show x instance PersistField Word8 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ T.pack $ "Expected Word, received: " ++ show x instance PersistField Word16 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ T.pack $ "Expected Word, received: " ++ show x instance PersistField Word32 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ T.pack $ "Expected Word, received: " ++ show x instance PersistField Word64 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ T.pack $ "Expected Word, received: " ++ show x instance PersistField Double where toPersistValue = PersistDouble fromPersistValue (PersistDouble d) = Right d fromPersistValue (PersistRational r) = Right $ fromRational r fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ T.pack $ "Expected Double, received: " ++ show x instance (HasResolution a) => PersistField (Fixed a) where toPersistValue = PersistRational . toRational fromPersistValue (PersistRational r) = Right $ fromRational r fromPersistValue (PersistText t) = case reads $ T.unpack t of -- NOTE: Sqlite can store rationals just as string [(a, "")] -> Right a _ -> Left $ "Can not read " <> t <> " as Fixed" fromPersistValue (PersistDouble d) = Right $ realToFrac d fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ "PersistField Fixed:Expected Rational, received: " <> T.pack (show x) instance PersistField Rational where toPersistValue = PersistRational fromPersistValue (PersistRational r) = Right r fromPersistValue (PersistDouble d) = Right $ toRational d fromPersistValue (PersistText t) = case reads $ T.unpack t of -- NOTE: Sqlite can store rationals just as string [(a, "")] -> Right $ toRational (a :: Pico) _ -> Left $ "Can not read " <> t <> " as Rational (Pico in fact)" fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue (PersistByteString bs) = case double $ T.cons '0' $ T.decodeUtf8With T.lenientDecode bs of Right (ret,"") -> Right $ toRational ret Right (a,b) -> Left $ "Invalid bytestring[" <> T.pack (show bs) <> "]: expected a double but returned " <> T.pack (show (a,b)) Left xs -> Left $ "Invalid bytestring[" <> T.pack (show bs) <> "]: expected a double but returned " <> T.pack (show xs) fromPersistValue x = Left $ "PersistField Rational:Expected Rational, received: " <> T.pack (show x) instance PersistField Bool where toPersistValue = PersistBool fromPersistValue (PersistBool b) = Right b fromPersistValue (PersistInt64 i) = Right $ i /= 0 fromPersistValue (PersistByteString i) = case readInt i of Just (0,"") -> Right False Just (1,"") -> Right True xs -> error $ "PersistField Bool failed parsing PersistByteString xs["++show xs++"] i["++show i++"]" fromPersistValue x = Left $ T.pack $ "Expected Bool, received: " ++ show x instance PersistField Day where toPersistValue = PersistDay fromPersistValue (PersistDay d) = Right d fromPersistValue (PersistInt64 i) = Right $ ModifiedJulianDay $ toInteger i fromPersistValue x@(PersistText t) = case reads $ T.unpack t of (d, _):_ -> Right d _ -> Left $ T.pack $ "Expected Day, received " ++ show x fromPersistValue x@(PersistByteString s) = case reads $ unpack s of (d, _):_ -> Right d _ -> Left $ T.pack $ "Expected Day, received " ++ show x fromPersistValue x = Left $ T.pack $ "Expected Day, received: " ++ show x instance PersistField TimeOfDay where toPersistValue = PersistTimeOfDay fromPersistValue (PersistTimeOfDay d) = Right d fromPersistValue x@(PersistText t) = case reads $ T.unpack t of (d, _):_ -> Right d _ -> Left $ T.pack $ "Expected TimeOfDay, received " ++ show x fromPersistValue x@(PersistByteString s) = case reads $ unpack s of (d, _):_ -> Right d _ -> Left $ T.pack $ "Expected TimeOfDay, received " ++ show x fromPersistValue x = Left $ T.pack $ "Expected TimeOfDay, received: " ++ show x instance PersistField UTCTime where toPersistValue = PersistUTCTime fromPersistValue (PersistUTCTime d) = Right d #ifdef HIGH_PRECISION_DATE fromPersistValue (PersistInt64 i) = Right $ posixSecondsToUTCTime $ (/ (1000 * 1000 * 1000)) $ fromIntegral $ i #endif fromPersistValue x@(PersistText t) = case reads $ T.unpack t of (d, _):_ -> Right d _ -> case parse8601 $ T.unpack t of Nothing -> Left $ T.pack $ "Expected UTCTime, received " ++ show x Just x' -> Right x' where #if MIN_VERSION_time(1,5,0) parse8601 = parseTimeM True defaultTimeLocale "%FT%T%Q" #else parse8601 = parseTime defaultTimeLocale "%FT%T%Q" #endif fromPersistValue x@(PersistByteString s) = case reads $ unpack s of (d, _):_ -> Right d _ -> Left $ T.pack $ "Expected UTCTime, received " ++ show x fromPersistValue x = Left $ T.pack $ "Expected UTCTime, received: " ++ show x #if MIN_VERSION_base(4,8,0) instance PersistField Natural where toPersistValue = (toPersistValue :: Int64 -> PersistValue) . fromIntegral fromPersistValue x = fromIntegral <$> (fromPersistValue x :: Either Text Int64) #endif instance PersistField a => PersistField (Maybe a) where toPersistValue Nothing = PersistNull toPersistValue (Just a) = toPersistValue a fromPersistValue PersistNull = Right Nothing fromPersistValue x = Just <$> fromPersistValue x #if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPABLE #-} PersistField a => PersistField [a] where #else instance PersistField a => PersistField [a] where #endif toPersistValue = PersistList . fmap toPersistValue fromPersistValue (PersistList l) = fromPersistList l fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t) fromPersistValue (PersistByteString bs) | Just values <- A.decode' (L.fromChunks [bs]) = fromPersistList values -- avoid the need for a migration to fill in empty lists. -- also useful when Persistent is not the only one filling in the data fromPersistValue (PersistNull) = Right [] fromPersistValue x = Left $ T.pack $ "Expected PersistList, received: " ++ show x instance PersistField a => PersistField (V.Vector a) where toPersistValue = toPersistValue . V.toList fromPersistValue = either (\e -> Left ("Vector: " `T.append` e)) (Right . V.fromList) . fromPersistValue instance (Ord a, PersistField a) => PersistField (S.Set a) where toPersistValue = PersistList . fmap toPersistValue . S.toList fromPersistValue (PersistList list) = S.fromList <$> fromPersistList list fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t) fromPersistValue (PersistByteString bs) | Just values <- A.decode' (L.fromChunks [bs]) = S.fromList <$> fromPersistList values fromPersistValue PersistNull = Right S.empty fromPersistValue x = Left $ T.pack $ "Expected PersistSet, received: " ++ show x instance (PersistField a, PersistField b) => PersistField (a,b) where toPersistValue (x,y) = PersistList [toPersistValue x, toPersistValue y] fromPersistValue v = case fromPersistValue v of Right [x,y] -> (,) <$> fromPersistValue x <*> fromPersistValue y Left e -> Left e _ -> Left $ T.pack $ "Expected 2 item PersistList, received: " ++ show v instance PersistField v => PersistField (IM.IntMap v) where toPersistValue = toPersistValue . IM.toList fromPersistValue = fmap IM.fromList . fromPersistValue instance PersistField v => PersistField (M.Map T.Text v) where toPersistValue = PersistMap . fmap (second toPersistValue) . M.toList fromPersistValue = fromPersistMap <=< getPersistMap instance PersistField PersistValue where toPersistValue = id fromPersistValue = Right fromPersistList :: PersistField a => [PersistValue] -> Either T.Text [a] fromPersistList = mapM fromPersistValue fromPersistMap :: PersistField v => [(T.Text, PersistValue)] -> Either T.Text (M.Map T.Text v) fromPersistMap = foldShortLeft fromPersistValue [] where -- a fold that short-circuits on Left. foldShortLeft f = go where go acc [] = Right $ M.fromList acc go acc ((k, v):kvs) = case f v of Left e -> Left e Right v' -> go ((k,v'):acc) kvs -- | FIXME Add documentation to that. getPersistMap :: PersistValue -> Either T.Text [(T.Text, PersistValue)] getPersistMap (PersistMap kvs) = Right kvs getPersistMap (PersistText t) = getPersistMap (PersistByteString $ TE.encodeUtf8 t) getPersistMap (PersistByteString bs) | Just pairs <- A.decode' (L.fromChunks [bs]) = Right pairs getPersistMap PersistNull = Right [] getPersistMap x = Left $ T.pack $ "Expected PersistMap, received: " ++ show x data SomePersistField = forall a. PersistField a => SomePersistField a instance PersistField SomePersistField where toPersistValue (SomePersistField a) = toPersistValue a fromPersistValue x = fmap SomePersistField (fromPersistValue x :: Either Text Text) instance PersistField Checkmark where toPersistValue Active = PersistBool True toPersistValue Inactive = PersistNull fromPersistValue PersistNull = Right Inactive fromPersistValue (PersistBool True) = Right Active fromPersistValue (PersistInt64 1) = Right Active fromPersistValue (PersistByteString i) = case readInt i of Just (0,"") -> Left $ T.pack "PersistField Checkmark: found unexpected 0 value" Just (1,"") -> Right Active xs -> Left $ T.pack $ "PersistField Checkmark failed parsing PersistByteString xs["++show xs++"] i["++show i++"]" fromPersistValue (PersistBool False) = Left $ T.pack "PersistField Checkmark: found unexpected FALSE value" fromPersistValue other = Left $ T.pack $ "PersistField Checkmark: unknown value " ++ show other persistent-2.7.1/Database/Persist/Class/PersistStore.hs0000644000000000000000000002574113173255472021335 0ustar0000000000000000{-# LANGUAGE TypeFamilies, FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ConstraintKinds #-} module Database.Persist.Class.PersistStore ( HasPersistBackend (..) , IsPersistBackend (..) , PersistRecordBackend , liftPersist , PersistCore (..) , PersistStoreRead (..) , PersistStoreWrite (..) , getEntity , getJust , getJustEntity , belongsTo , belongsToJust , insertEntity , insertRecord , ToBackendKey(..) , BackendCompatible(..) ) where import qualified Data.Text as T import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Exception.Lifted (throwIO) import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.Reader (MonadReader (ask), runReaderT) import Database.Persist.Class.PersistEntity import Database.Persist.Class.PersistField import Database.Persist.Types import qualified Data.Aeson as A -- | Class which allows the plucking of a @BaseBackend backend@ from some larger type. -- For example, -- @ -- instance HasPersistBackend (SqlReadBackend, Int) where -- type BaseBackend (SqlReadBackend, Int) = SqlBackend -- persistBackend = unSqlReadBackend . fst -- @ class HasPersistBackend backend where type BaseBackend backend persistBackend :: backend -> BaseBackend backend -- | Class which witnesses that @backend@ is essentially the same as @BaseBackend backend@. -- That is, they're isomorphic and @backend@ is just some wrapper over @BaseBackend backend@. class (HasPersistBackend backend) => IsPersistBackend backend where -- | This function is how we actually construct and tag a backend as having read or write capabilities. -- It should be used carefully and only when actually constructing a @backend@. Careless use allows us -- to accidentally run a write query against a read-only database. mkPersistBackend :: BaseBackend backend -> backend -- | This class witnesses that two backend are compatible, and that you can -- convert from the @sub@ backend into the @sup@ backend. This is similar -- to the 'HasPersistBackend' and 'IsPersistBackend' classes, but where you -- don't want to fix the type associated with the 'PersistEntityBackend' of -- a record. -- -- Generally speaking, where you might have: -- -- @ -- foo :: -- ( 'PersistEntity' record -- , 'PeristEntityBackend' record ~ 'BaseBackend' backend -- , 'IsSqlBackend' backend -- ) -- @ -- -- this can be replaced with: -- -- @ -- foo :: -- ( 'PersistEntity' record, -- , 'PersistEntityBackend' record ~ backend -- , 'BackendCompatible' 'SqlBackend' backend -- ) -- @ -- -- This works for 'SqlReadBackend' because of the @instance 'BackendCompatible' 'SqlBackend' 'SqlReadBackend'@, without needing to go through the 'BaseBackend' type family. -- -- Likewise, functions that are currently hardcoded to use 'SqlBackend' can be generalized: -- -- @ -- -- before: -- asdf :: 'ReaderT' 'SqlBackend' m () -- asdf = pure () -- -- -- after: -- asdf' :: 'BackendCompatible' SqlBackend backend => ReaderT backend m () -- asdf' = withReaderT 'projectBackend' asdf -- @ -- -- @since 2.7.1 class BackendCompatible sup sub where projectBackend :: sub -> sup -- | A convenient alias for common type signatures type PersistRecordBackend record backend = (PersistEntity record, PersistEntityBackend record ~ BaseBackend backend) liftPersist :: (MonadIO m, MonadReader backend m, HasPersistBackend backend) => ReaderT (BaseBackend backend) IO b -> m b liftPersist f = do env <- ask liftIO $ runReaderT f (persistBackend env) -- | 'ToBackendKey' converts a 'PersistEntity' 'Key' into a 'BackendKey' -- This can be used by each backend to convert between a 'Key' and a plain -- Haskell type. For Sql, that is done with 'toSqlKey' and 'fromSqlKey'. -- -- By default, a 'PersistEntity' uses the default 'BackendKey' for its Key -- and is an instance of ToBackendKey -- -- A 'Key' that instead uses a custom type will not be an instance of -- 'ToBackendKey'. class ( PersistEntity record , PersistEntityBackend record ~ backend , PersistCore backend ) => ToBackendKey backend record where toBackendKey :: Key record -> BackendKey backend fromBackendKey :: BackendKey backend -> Key record class PersistCore backend where data BackendKey backend class ( Show (BackendKey backend), Read (BackendKey backend) , Eq (BackendKey backend), Ord (BackendKey backend) , PersistCore backend , PersistField (BackendKey backend), A.ToJSON (BackendKey backend), A.FromJSON (BackendKey backend) ) => PersistStoreRead backend where -- | Get a record by identifier, if available. get :: (MonadIO m, PersistRecordBackend record backend) => Key record -> ReaderT backend m (Maybe record) class ( Show (BackendKey backend), Read (BackendKey backend) , Eq (BackendKey backend), Ord (BackendKey backend) , PersistStoreRead backend , PersistField (BackendKey backend), A.ToJSON (BackendKey backend), A.FromJSON (BackendKey backend) ) => PersistStoreWrite backend where -- | Create a new record in the database, returning an automatically created -- key (in SQL an auto-increment id). insert :: (MonadIO m, PersistRecordBackend record backend) => record -> ReaderT backend m (Key record) -- | Same as 'insert', but doesn't return a @Key@. insert_ :: (MonadIO m, PersistRecordBackend record backend) => record -> ReaderT backend m () insert_ record = insert record >> return () -- | Create multiple records in the database and return their 'Key's. -- -- If you don't need the inserted 'Key's, use 'insertMany_'. -- -- The MongoDB and PostgreSQL backends insert all records and -- retrieve their keys in one database query. -- -- The SQLite and MySQL backends use the slow, default implementation of -- @mapM insert@. insertMany :: (MonadIO m, PersistRecordBackend record backend) => [record] -> ReaderT backend m [Key record] insertMany = mapM insert -- | Same as 'insertMany', but doesn't return any 'Key's. -- -- The MongoDB, PostgreSQL, SQLite and MySQL backends insert all records in -- one database query. insertMany_ :: (MonadIO m, PersistRecordBackend record backend) => [record] -> ReaderT backend m () insertMany_ x = insertMany x >> return () -- | Same as 'insertMany_', but takes an 'Entity' instead of just a record. -- -- Useful when migrating data from one entity to another -- and want to preserve ids. -- -- The MongoDB backend inserts all the entities in one database query. -- -- The SQL backends use the slow, default implementation of -- @mapM_ insertKey@. insertEntityMany :: (MonadIO m, PersistRecordBackend record backend) => [Entity record] -> ReaderT backend m () insertEntityMany = mapM_ (\(Entity k record) -> insertKey k record) -- | Create a new record in the database using the given key. insertKey :: (MonadIO m, PersistRecordBackend record backend) => Key record -> record -> ReaderT backend m () -- | Put the record in the database with the given key. -- Unlike 'replace', if a record with the given key does not -- exist then a new record will be inserted. repsert :: (MonadIO m, PersistRecordBackend record backend) => Key record -> record -> ReaderT backend m () -- | Replace the record in the database with the given -- key. Note that the result is undefined if such record does -- not exist, so you must use 'insertKey or 'repsert' in -- these cases. replace :: (MonadIO m, PersistRecordBackend record backend) => Key record -> record -> ReaderT backend m () -- | Delete a specific record by identifier. Does nothing if record does -- not exist. delete :: (MonadIO m, PersistRecordBackend record backend) => Key record -> ReaderT backend m () -- | Update individual fields on a specific record. update :: (MonadIO m, PersistRecordBackend record backend) => Key record -> [Update record] -> ReaderT backend m () -- | Update individual fields on a specific record, and retrieve the -- updated value from the database. -- -- Note that this function will throw an exception if the given key is not -- found in the database. updateGet :: (MonadIO m, PersistRecordBackend record backend) => Key record -> [Update record] -> ReaderT backend m record updateGet key ups = do update key ups get key >>= maybe (liftIO $ throwIO $ KeyNotFound $ show key) return -- | Same as 'get', but for a non-null (not Maybe) foreign key. -- Unsafe unless your database is enforcing that the foreign key is valid. getJust :: ( PersistStoreRead backend , Show (Key record) , PersistRecordBackend record backend , MonadIO m ) => Key record -> ReaderT backend m record getJust key = get key >>= maybe (liftIO $ throwIO $ PersistForeignConstraintUnmet $ T.pack $ show key) return -- | Same as 'getJust', but returns an 'Entity' instead of just the record. -- -- @since 2.6.1 getJustEntity :: (PersistEntityBackend record ~ BaseBackend backend ,MonadIO m ,PersistEntity record ,PersistStoreRead backend) => Key record -> ReaderT backend m (Entity record) getJustEntity key = do record <- getJust key return $ Entity { entityKey = key , entityVal = record } -- | Curry this to make a convenience function that loads an associated model. -- -- > foreign = belongsTo foreignId belongsTo :: ( PersistStoreRead backend , PersistEntity ent1 , PersistRecordBackend ent2 backend , MonadIO m ) => (ent1 -> Maybe (Key ent2)) -> ent1 -> ReaderT backend m (Maybe ent2) belongsTo foreignKeyField model = case foreignKeyField model of Nothing -> return Nothing Just f -> get f -- | Same as 'belongsTo', but uses @getJust@ and therefore is similarly unsafe. belongsToJust :: ( PersistStoreRead backend , PersistEntity ent1 , PersistRecordBackend ent2 backend , MonadIO m ) => (ent1 -> Key ent2) -> ent1 -> ReaderT backend m ent2 belongsToJust getForeignKey model = getJust $ getForeignKey model -- | Like @insert@, but returns the complete @Entity@. insertEntity :: ( PersistStoreWrite backend , PersistRecordBackend e backend , MonadIO m ) => e -> ReaderT backend m (Entity e) insertEntity e = do eid <- insert e return $ Entity eid e -- | Like @get@, but returns the complete @Entity@. getEntity :: ( PersistStoreRead backend , PersistRecordBackend e backend , MonadIO m ) => Key e -> ReaderT backend m (Maybe (Entity e)) getEntity key = do maybeModel <- get key return $ fmap (key `Entity`) maybeModel -- | Like 'insertEntity' but just returns the record instead of 'Entity'. -- -- @since 2.6.1 insertRecord :: (PersistEntityBackend record ~ BaseBackend backend ,PersistEntity record ,MonadIO m ,PersistStoreWrite backend) => record -> ReaderT backend m record insertRecord record = do insert_ record return $ record persistent-2.7.1/Database/Persist/Sql/Migration.hs0000644000000000000000000001222213170567656020307 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} module Database.Persist.Sql.Migration ( parseMigration , parseMigration' , printMigration , showMigration , getMigration , runMigration , runMigrationSilent , runMigrationUnsafe , migrate ) where import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.IO.Class import Control.Monad.Trans.Writer import Control.Monad.Trans.Reader (ReaderT (..), ask) import Control.Monad (liftM, unless) import Data.Text (Text, unpack, snoc, isPrefixOf, pack) import qualified Data.Text.IO import System.IO import System.IO.Silently (hSilence) import Control.Monad.Trans.Control (liftBaseOp_) import Database.Persist.Sql.Types import Database.Persist.Sql.Raw import Database.Persist.Types allSql :: CautiousMigration -> [Sql] allSql = map snd safeSql :: CautiousMigration -> [Sql] safeSql = allSql . filter (not . fst) -- | Given a 'Migration', this parses it and returns either a list of -- errors associated with the migration or a list of migrations to do. parseMigration :: MonadIO m => Migration -> ReaderT SqlBackend m (Either [Text] CautiousMigration) parseMigration = liftIOReader . liftM go . runWriterT . execWriterT where go ([], sql) = Right sql go (errs, _) = Left errs liftIOReader (ReaderT m) = ReaderT $ liftIO . m -- | Like 'parseMigration', but instead of returning the value in an -- 'Either' value, it calls 'error' on the error values. parseMigration' :: MonadIO m => Migration -> ReaderT SqlBackend m (CautiousMigration) parseMigration' m = do x <- parseMigration m case x of Left errs -> error $ unlines $ map unpack errs Right sql -> return sql -- | Prints a migration. printMigration :: MonadIO m => Migration -> ReaderT SqlBackend m () printMigration m = showMigration m >>= mapM_ (liftIO . Data.Text.IO.putStrLn) -- | Convert a 'Migration' to a list of 'Text' values corresponding to their -- 'Sql' statements. showMigration :: MonadIO m => Migration -> ReaderT SqlBackend m [Text] showMigration m = map (flip snoc ';') `liftM` getMigration m -- | Return all of the 'Sql' values associated with the given migration. -- Calls 'error' if there's a parse error on any migration. getMigration :: MonadIO m => Migration -> ReaderT SqlBackend m [Sql] getMigration m = do mig <- parseMigration' m return $ allSql mig -- | Runs a migration. If the migration fails to parse or if any of the -- migrations are unsafe, then this calls 'error' to halt the program. runMigration :: MonadIO m => Migration -> ReaderT SqlBackend m () runMigration m = runMigration' m False >> return () -- | Same as 'runMigration', but returns a list of the SQL commands executed -- instead of printing them to stderr. runMigrationSilent :: (MonadBaseControl IO m, MonadIO m) => Migration -> ReaderT SqlBackend m [Text] runMigrationSilent m = liftBaseOp_ (hSilence [stderr]) $ runMigration' m True -- | Run the given migration against the database. If the migration fails -- to parse, or there are any unsafe migrations, then this will error at -- runtime. This returns a list of the migrations that were executed. runMigration' :: MonadIO m => Migration -> Bool -- ^ is silent? -> ReaderT SqlBackend m [Text] runMigration' m silent = do mig <- parseMigration' m if any fst mig then error $ concat [ "\n\nDatabase migration: manual intervention required.\n" , "The unsafe actions are prefixed by '***' below:\n\n" , unlines $ map displayMigration mig ] else mapM (executeMigrate silent) $ sortMigrations $ safeSql mig where displayMigration :: (Bool, Sql) -> String displayMigration (True, s) = "*** " ++ unpack s ++ ";" displayMigration (False, s) = " " ++ unpack s ++ ";" -- | Like 'runMigration', but this will perform the unsafe database -- migrations instead of erroring out. runMigrationUnsafe :: MonadIO m => Migration -> ReaderT SqlBackend m () runMigrationUnsafe m = do mig <- parseMigration' m mapM_ (executeMigrate False) $ sortMigrations $ allSql mig executeMigrate :: MonadIO m => Bool -> Text -> ReaderT SqlBackend m Text executeMigrate silent s = do unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ unpack s rawExecute s [] return s -- | Sort the alter DB statements so tables are created before constraints are -- added. sortMigrations :: [Sql] -> [Sql] sortMigrations x = filter isCreate x ++ filter (not . isCreate) x where -- Note the use of lower-case e. This (hack) allows backends to explicitly -- choose to have this special sorting applied. isCreate t = pack "CREATe " `isPrefixOf` t -- | Given a list of old entity definitions and a new 'EntityDef' in -- @val@, this creates a 'Migration' to update the old list of definitions -- with the new one. migrate :: [EntityDef] -> EntityDef -> Migration migrate allDefs val = do conn <- lift $ lift ask res <- liftIO $ connMigrateSql conn allDefs (getStmtConn conn) val either tell (lift . tell) res persistent-2.7.1/Database/Persist/Sql/Internal.hs0000644000000000000000000000467113170567656020143 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} -- | Intended for creating new backends. module Database.Persist.Sql.Internal ( mkColumns , defaultAttribute ) where import Database.Persist.Types import Database.Persist.Quasi import Data.Char (isSpace) import Data.Text (Text) import qualified Data.Text as T 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 = (cols, entityUniques t, entityForeigns t) where cols :: [Column] cols = map go (entityFields t) tn :: DBName tn = entityDB t go :: FieldDef -> Column go fd = Column (fieldDB fd) (nullable (fieldAttrs fd) /= NotNullable || entitySum t) (fieldSqlType fd) (defaultAttribute $ fieldAttrs fd) Nothing (maxLen $ fieldAttrs fd) (ref (fieldDB fd) (fieldReference fd) (fieldAttrs fd)) 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 -> ReferenceDef -> [Attr] -> Maybe (DBName, DBName) -- table name, constraint name ref c fe [] | ForeignRef f _ <- fe = Just (resolveTableName allDefs f, refName tn c) | otherwise = Nothing ref _ _ ("noreference":_) = Nothing ref c _ (a:_) | Just x <- T.stripPrefix "reference=" a = Just (DBName x, refName tn c) ref c x (_:as) = ref c x as refName :: DBName -> DBName -> DBName refName (DBName table) (DBName column) = DBName $ Data.Monoid.mconcat [table, "_", column, "_fkey"] resolveTableName :: [EntityDef] -> HaskellName -> DBName resolveTableName [] (HaskellName hn) = error $ "Table not found: " `Data.Monoid.mappend` T.unpack hn resolveTableName (e:es) hn | entityHaskell e == hn = entityDB e | otherwise = resolveTableName es hn persistent-2.7.1/Database/Persist/Sql/Types.hs0000644000000000000000000001004513170567656017463 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} module Database.Persist.Sql.Types ( module Database.Persist.Sql.Types , SqlBackend (..), SqlReadBackend (..), SqlWriteBackend (..) , Statement (..), LogFunc, InsertSqlResult (..) , readToUnknown, readToWrite, writeToUnknown , SqlBackendCanRead, SqlBackendCanWrite, SqlReadT, SqlWriteT, IsSqlBackend ) where import Control.Exception (Exception) import Control.Monad.Trans.Resource (ResourceT) import Control.Monad.Logger (NoLoggingT) import Control.Monad.Trans.Reader (ReaderT (..)) import Control.Monad.Trans.Writer (WriterT) import Data.Typeable (Typeable) import Database.Persist.Types import Database.Persist.Sql.Types.Internal import Data.Pool (Pool) import Data.Text (Text) -- | Deprecated synonym for @SqlBackend@. type Connection = SqlBackend {-# DEPRECATED Connection "Please use SqlBackend instead" #-} data Column = Column { cName :: !DBName , cNull :: !Bool , cSqlType :: !SqlType , cDefault :: !(Maybe Text) , cDefaultConstraintName :: !(Maybe DBName) , cMaxLen :: !(Maybe Integer) , cReference :: !(Maybe (DBName, DBName)) -- table name, constraint name } deriving (Eq, Ord, Show) data PersistentSqlException = StatementAlreadyFinalized Text | Couldn'tGetSQLConnection deriving (Typeable, Show) instance Exception PersistentSqlException type SqlPersistT = ReaderT SqlBackend type SqlPersist = SqlPersistT {-# DEPRECATED SqlPersist "Please use SqlPersistT instead" #-} type SqlPersistM = SqlPersistT (NoLoggingT (ResourceT IO)) type Sql = Text -- Bool indicates if the Sql is safe type CautiousMigration = [(Bool, Sql)] type Migration = WriterT [Text] (WriterT CautiousMigration (ReaderT SqlBackend IO)) () type ConnectionPool = Pool SqlBackend -- $rawSql -- -- Although it covers most of the useful cases, @persistent@'s -- API may not be enough for some of your tasks. May be you need -- some complex @JOIN@ query, or a database-specific command -- needs to be issued. -- -- To issue raw SQL queries, use 'rawSql'. It does all the hard work of -- automatically parsing the rows of the result. It may return: -- -- * 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@. -- You may use a Haskell type (such as in your entity -- definitions), for example @Single Text@ or @Single Int@, -- or you may get the raw column value with @Single -- 'PersistValue'@. -- -- * A tuple combining any of these (including other tuples). -- Using tuples allows you to return many entities in one -- query. -- -- The only difference between issuing SQL queries with 'rawSql' -- and using other means is that we have an /entity selection/ -- /placeholder/, the double question mark @??@. It /must/ be -- used whenever you want to @SELECT@ an 'Entity' from your -- query. Here's a sample SQL query @sampleStmt@ that may be -- issued: -- -- @ -- SELECT ??, ?? -- FROM \"Person\", \"Likes\", \"Object\" -- WHERE \"Person\".id = \"Likes\".\"personId\" -- AND \"Object\".id = \"Likes\".\"objectId\" -- AND \"Person\".name LIKE ? -- @ -- -- To use that query, you could say -- -- @ -- do results <- 'rawSql' sampleStmt [\"%Luke%\"] -- forM_ results $ -- \\( Entity personKey person -- , Entity objectKey object -- ) -> do ... -- @ -- -- Note that 'rawSql' knows how to replace the double question -- marks @??@ because of the type of the @results@. -- | A single column (see 'rawSql'). Any 'PersistField' may be -- used here, including 'PersistValue' (which does not do any -- processing). newtype Single a = Single {unSingle :: a} deriving (Eq, Ord, Show, Read) persistent-2.7.1/Database/Persist/Sql/Raw.hs0000644000000000000000000002343613170567656017120 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} module Database.Persist.Sql.Raw where import Database.Persist import Database.Persist.Sql.Types import Database.Persist.Sql.Class import qualified Data.Map as Map import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (ReaderT, ask, MonadReader) import Data.Acquire (allocateAcquire, Acquire, mkAcquire, with) import Data.IORef (writeIORef, readIORef, newIORef) import Control.Exception (throwIO) import Control.Monad (when, liftM) import Data.Text (Text, pack) import Control.Monad.Logger (logDebugNS, runLoggingT) import Data.Int (Int64) import qualified Data.Text as T import Data.Conduit import Control.Monad.Trans.Resource (MonadResource,release) rawQuery :: (MonadResource m, MonadReader env m, HasPersistBackend env, BaseBackend env ~ SqlBackend) => Text -> [PersistValue] -> Source m [PersistValue] rawQuery sql vals = do srcRes <- liftPersist $ rawQueryRes sql vals (releaseKey, src) <- allocateAcquire srcRes src release releaseKey rawQueryRes :: (MonadIO m1, MonadIO m2, IsSqlBackend env) => Text -> [PersistValue] -> ReaderT env m1 (Acquire (Source m2 [PersistValue])) rawQueryRes sql vals = do conn <- persistBackend `liftM` ask let make = do runLoggingT (logDebugNS (pack "SQL") $ T.append sql $ pack $ "; " ++ show vals) (connLogFunc conn) getStmtConn conn sql return $ do stmt <- mkAcquire make stmtReset stmtQuery stmt vals -- | Execute a raw SQL statement rawExecute :: MonadIO m => Text -- ^ SQL statement, possibly with placeholders. -> [PersistValue] -- ^ Values to fill the placeholders. -> ReaderT SqlBackend m () rawExecute x y = liftM (const ()) $ rawExecuteCount x y -- | Execute a raw SQL statement and return the number of -- rows it has modified. rawExecuteCount :: (MonadIO m, IsSqlBackend backend) => Text -- ^ SQL statement, possibly with placeholders. -> [PersistValue] -- ^ Values to fill the placeholders. -> ReaderT backend m Int64 rawExecuteCount sql vals = do conn <- persistBackend `liftM` ask runLoggingT (logDebugNS (pack "SQL") $ T.append sql $ pack $ "; " ++ show vals) (connLogFunc conn) stmt <- getStmt sql res <- liftIO $ stmtExecute stmt vals liftIO $ stmtReset stmt return res getStmt :: (MonadIO m, IsSqlBackend backend) => Text -> ReaderT backend m Statement getStmt sql = do conn <- persistBackend `liftM` ask liftIO $ getStmtConn conn sql getStmtConn :: SqlBackend -> Text -> IO Statement getStmtConn conn sql = do smap <- liftIO $ readIORef $ connStmtMap conn case Map.lookup sql smap of Just stmt -> return stmt Nothing -> do stmt' <- liftIO $ connPrepare conn sql iactive <- liftIO $ newIORef True let stmt = Statement { stmtFinalize = do active <- readIORef iactive if active then do stmtFinalize stmt' writeIORef iactive False else return () , stmtReset = do active <- readIORef iactive when active $ stmtReset stmt' , stmtExecute = \x -> do active <- readIORef iactive if active then stmtExecute stmt' x else throwIO $ StatementAlreadyFinalized sql , stmtQuery = \x -> do active <- liftIO $ readIORef iactive if active then stmtQuery stmt' x else liftIO $ throwIO $ StatementAlreadyFinalized sql } liftIO $ writeIORef (connStmtMap conn) $ Map.insert sql stmt smap return stmt -- | Execute a raw SQL statement and return its results as a -- list. -- -- If you're using 'Entity'@s@ (which is quite likely), then you -- /must/ use entity selection placeholders (double question -- mark, @??@). These @??@ placeholders are then replaced for -- the names of the columns that we need for your entities. -- You'll receive an error if you don't use the placeholders. -- Please see the 'Entity'@s@ documentation for more details. -- -- You may put value placeholders (question marks, @?@) in your -- SQL query. These placeholders are then replaced by the values -- you pass on the second parameter, already correctly escaped. -- You may want to use 'toPersistValue' to help you constructing -- the placeholder values. -- -- Since you're giving a raw SQL statement, you don't get any -- guarantees regarding safety. If 'rawSql' is not able to parse -- the results of your query back, then an exception is raised. -- However, most common problems are mitigated by using the -- entity selection placeholder @??@, and you shouldn't see any -- error at all if you're not using 'Single'. -- -- Some example of 'rawSql' based on this schema: -- -- @ -- share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -- Person -- name String -- age Int Maybe -- deriving Show -- BlogPost -- title String -- authorId PersonId -- deriving Show -- |] -- @ -- -- Examples based on the above schema: -- -- @ -- getPerson :: MonadIO m => ReaderT SqlBackend m [Entity Person] -- getPerson = rawSql "select ?? from person where name=?" [PersistText "john"] -- -- getAge :: MonadIO m => ReaderT SqlBackend m [Single Int] -- getAge = rawSql "select person.age from person where name=?" [PersistText "john"] -- -- getAgeName :: MonadIO m => ReaderT SqlBackend m [(Single Int, Single Text)] -- getAgeName = rawSql "select person.age, person.name from person where name=?" [PersistText "john"] -- -- getPersonBlog :: MonadIO m => ReaderT SqlBackend m [(Entity Person, Entity BlogPost)] -- getPersonBlog = rawSql "select ??,?? from person,blog_post where person.id = blog_post.author_id" [] -- @ -- -- Minimal working program for PostgreSQL backend based on the above concepts: -- -- > {-# LANGUAGE EmptyDataDecls #-} -- > {-# LANGUAGE FlexibleContexts #-} -- > {-# LANGUAGE GADTs #-} -- > {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- > {-# LANGUAGE MultiParamTypeClasses #-} -- > {-# LANGUAGE OverloadedStrings #-} -- > {-# LANGUAGE QuasiQuotes #-} -- > {-# LANGUAGE TemplateHaskell #-} -- > {-# LANGUAGE TypeFamilies #-} -- > -- > import Control.Monad.IO.Class (liftIO) -- > import Control.Monad.Logger (runStderrLoggingT) -- > import Database.Persist -- > import Control.Monad.Reader -- > import Data.Text -- > import Database.Persist.Sql -- > import Database.Persist.Postgresql -- > import Database.Persist.TH -- > -- > share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -- > Person -- > name String -- > age Int Maybe -- > deriving Show -- > |] -- > -- > conn = "host=localhost dbname=new_db user=postgres password=postgres port=5432" -- > -- > getPerson :: MonadIO m => ReaderT SqlBackend m [Entity Person] -- > getPerson = rawSql "select ?? from person where name=?" [PersistText "sibi"] -- > -- > liftSqlPersistMPool y x = liftIO (runSqlPersistMPool y x) -- > -- > main :: IO () -- > main = runStderrLoggingT $ withPostgresqlPool conn 10 $ liftSqlPersistMPool $ do -- > runMigration migrateAll -- > xs <- getPerson -- > liftIO (print xs) -- > rawSql :: (RawSql a, MonadIO m) => Text -- ^ SQL statement, possibly with placeholders. -> [PersistValue] -- ^ Values to fill the placeholders. -> ReaderT SqlBackend m [a] rawSql stmt = run where getType :: (x -> m [a]) -> a getType = error "rawSql.getType" x = getType run process = rawSqlProcessRow withStmt' colSubsts params sink = do srcRes <- rawQueryRes sql params liftIO $ with srcRes ($$ sink) where sql = T.concat $ makeSubsts colSubsts $ T.splitOn placeholder stmt placeholder = "??" makeSubsts (s:ss) (t:ts) = t : s : makeSubsts ss ts makeSubsts [] [] = [] makeSubsts [] ts = [T.intercalate placeholder ts] makeSubsts ss [] = error (concat err) where err = [ "rawsql: there are still ", show (length ss) , "'??' placeholder substitutions to be made " , "but all '??' placeholders have already been " , "consumed. Please read 'rawSql's documentation " , "on how '??' placeholders work." ] run params = do conn <- ask let (colCount, colSubsts) = rawSqlCols (connEscapeName conn) x withStmt' colSubsts params $ firstRow colCount firstRow colCount = do mrow <- await case mrow of Nothing -> return [] Just row | colCount == length row -> getter mrow | otherwise -> fail $ concat [ "rawSql: wrong number of columns, got " , show (length row), " but expected ", show colCount , " (", rawSqlColCountReason x, ")." ] getter = go id where go acc Nothing = return (acc []) go acc (Just row) = case process row of Left err -> fail (T.unpack err) Right r -> await >>= go (acc . (r:)) persistent-2.7.1/Database/Persist/Sql/Run.hs0000644000000000000000000001124713170567656017130 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Database.Persist.Sql.Run where import Database.Persist.Class.PersistStore import Database.Persist.Sql.Types import Database.Persist.Sql.Raw import Control.Monad.Trans.Control import Data.Pool as P import Control.Monad.Trans.Reader hiding (local) import Control.Monad.Trans.Resource import Control.Monad.Logger import Control.Monad.Base import Control.Exception.Lifted (onException, bracket) import Control.Monad.IO.Class import Control.Exception (mask) import System.Timeout (timeout) import Data.IORef (readIORef, writeIORef, newIORef) import qualified Data.Map as Map import Control.Monad (liftM) -- | Get a connection from the pool, run the given action, and then return the -- connection to the pool. -- -- Note: This function previously timed out after 2 seconds, but this behavior -- was buggy and caused more problems than it solved. Since version 2.1.2, it -- performs no timeout checks. runSqlPool :: (MonadBaseControl IO m, IsSqlBackend backend) => ReaderT backend m a -> Pool backend -> m a runSqlPool r pconn = withResource pconn $ runSqlConn r -- | Like 'withResource', but times out the operation if resource -- allocation does not complete within the given timeout period. -- -- @since 2.0.0 withResourceTimeout :: forall a m b. (MonadBaseControl IO m) => Int -- ^ Timeout period in microseconds -> Pool a -> (a -> m b) -> m (Maybe b) {-# SPECIALIZE withResourceTimeout :: Int -> Pool a -> (a -> IO b) -> IO (Maybe b) #-} withResourceTimeout ms pool act = control $ \runInIO -> mask $ \restore -> do mres <- timeout ms $ takeResource pool case mres of Nothing -> runInIO $ return (Nothing :: Maybe b) Just (resource, local) -> do ret <- restore (runInIO (liftM Just $ act resource)) `onException` destroyResource pool local resource putResource local resource return ret {-# INLINABLE withResourceTimeout #-} runSqlConn :: (MonadBaseControl IO m, IsSqlBackend backend) => ReaderT backend m a -> backend -> m a runSqlConn r conn = control $ \runInIO -> mask $ \restore -> do let conn' = persistBackend conn getter = getStmtConn conn' restore $ connBegin conn' getter x <- onException (restore $ runInIO $ runReaderT r conn) (restore $ connRollback conn' getter) restore $ connCommit conn' getter return x runSqlPersistM :: (IsSqlBackend backend) => ReaderT backend (NoLoggingT (ResourceT IO)) a -> backend -> IO a runSqlPersistM x conn = runResourceT $ runNoLoggingT $ runSqlConn x conn runSqlPersistMPool :: (IsSqlBackend backend) => ReaderT backend (NoLoggingT (ResourceT IO)) a -> Pool backend -> IO a runSqlPersistMPool x pool = runResourceT $ runNoLoggingT $ runSqlPool x pool liftSqlPersistMPool :: (MonadIO m, IsSqlBackend backend) => ReaderT backend (NoLoggingT (ResourceT IO)) a -> Pool backend -> m a liftSqlPersistMPool x pool = liftIO (runSqlPersistMPool x pool) withSqlPool :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, IsSqlBackend backend) => (LogFunc -> IO backend) -- ^ create a new connection -> Int -- ^ connection count -> (Pool backend -> m a) -> m a withSqlPool mkConn connCount f = bracket (createSqlPool mkConn connCount) (liftIO . destroyAllResources) f createSqlPool :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, IsSqlBackend backend) => (LogFunc -> IO backend) -> Int -> m (Pool backend) createSqlPool mkConn size = do logFunc <- askLogFunc liftIO $ createPool (mkConn logFunc) close' 1 20 size -- NOTE: This function is a terrible, ugly hack. It would be much better to -- just clean up monad-logger. -- -- FIXME: in a future release, switch over to the new askLoggerIO function -- added in monad-logger 0.3.10. That function was not available at the time -- this code was written. askLogFunc :: forall m. (MonadBaseControl IO m, MonadLogger m) => m LogFunc askLogFunc = do ref <- liftBase $ newIORef undefined liftBaseWith $ \run -> writeIORef ref run runInBase <- liftBase $ readIORef ref return $ \a b c d -> do _ <- runInBase (monadLoggerLog a b c d) return () withSqlConn :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, IsSqlBackend backend) => (LogFunc -> IO backend) -> (backend -> m a) -> m a withSqlConn open f = do logFunc <- askLogFunc bracket (liftIO $ open logFunc) (liftIO . close') f close' :: (IsSqlBackend backend) => backend -> IO () close' conn = do readIORef (connStmtMap $ persistBackend conn) >>= mapM_ stmtFinalize . Map.elems connClose $ persistBackend conn persistent-2.7.1/Database/Persist/Sql/Class.hs0000644000000000000000000002576613170567656017444 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE PatternGuards #-} #if !MIN_VERSION_base(4,8,0) {-# LANGUAGE OverlappingInstances #-} #endif module Database.Persist.Sql.Class ( RawSql (..) , PersistFieldSql (..) ) where import Control.Applicative as A ((<$>), (<*>)) import Database.Persist import Data.Monoid ((<>)) import Database.Persist.Sql.Types import Data.Text (Text, intercalate, pack) import Data.Maybe (fromMaybe) import Data.Fixed import Data.Proxy (Proxy) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Map as M import qualified Data.IntMap as IM import qualified Data.Set as S import Data.Time (UTCTime, TimeOfDay, Day) import Data.Int import Data.Word import Data.ByteString (ByteString) import Text.Blaze.Html (Html) import Data.Bits (bitSizeMaybe) import qualified Data.Vector as V #if MIN_VERSION_base(4,8,0) import Numeric.Natural (Natural) #endif -- | Class for data types that may be retrived from a 'rawSql' -- query. class RawSql a where -- | Number of columns that this data type needs and the list -- of substitutions for @SELECT@ placeholders @??@. rawSqlCols :: (DBName -> Text) -> a -> (Int, [Text]) -- | A string telling the user why the column count is what -- it is. rawSqlColCountReason :: a -> String -- | Transform a row of the result into the data type. rawSqlProcessRow :: [PersistValue] -> Either Text a instance PersistField a => RawSql (Single a) where rawSqlCols _ _ = (1, []) rawSqlColCountReason _ = "one column for a 'Single' data type" rawSqlProcessRow [pv] = Single A.<$> fromPersistValue pv rawSqlProcessRow _ = Left $ pack "RawSql (Single a): wrong number of columns." instance (PersistEntity a, PersistEntityBackend a ~ backend, IsPersistBackend backend) => RawSql (Key a) where rawSqlCols _ key = (length $ keyToValues key, []) rawSqlColCountReason key = "The primary key is composed of " ++ (show $ length $ keyToValues key) ++ " columns" rawSqlProcessRow = keyFromValues instance (PersistEntity record, PersistEntityBackend record ~ backend, IsPersistBackend backend) => RawSql (Entity record) where rawSqlCols escape _ent = (length sqlFields, [intercalate ", " sqlFields]) where sqlFields = map (((name <> ".") <>) . escape) $ map fieldDB -- Hacky for a composite key because -- it selects the same field multiple times $ entityKeyFields entDef ++ entityFields entDef name = escape (entityDB entDef) entDef = entityDef (Nothing :: Maybe record) rawSqlColCountReason a = case fst (rawSqlCols (error "RawSql") a) of 1 -> "one column for an 'Entity' data type without fields" n -> show n ++ " columns for an 'Entity' data type" rawSqlProcessRow row = case splitAt nKeyFields row of (rowKey, rowVal) -> Entity A.<$> keyFromValues rowKey A.<*> fromPersistValues rowVal where nKeyFields = length $ entityKeyFields entDef entDef = entityDef (Nothing :: Maybe record) -- | @since 1.0.1 instance RawSql a => RawSql (Maybe a) where rawSqlCols e = rawSqlCols e . extractMaybe rawSqlColCountReason = rawSqlColCountReason . extractMaybe rawSqlProcessRow cols | all isNull cols = return Nothing | otherwise = case rawSqlProcessRow cols of Right v -> Right (Just v) Left msg -> Left $ "RawSql (Maybe a): not all columns were Null " <> "but the inner parser has failed. Its message " <> "was \"" <> msg <> "\". Did you apply Maybe " <> "to a tuple, perhaps? The main use case for " <> "Maybe is to allow OUTER JOINs to be written, " <> "in which case 'Maybe (Entity v)' is used." where isNull PersistNull = True isNull _ = False instance (RawSql a, RawSql b) => RawSql (a, b) where rawSqlCols e x = rawSqlCols e (fst x) # rawSqlCols e (snd x) where (cnta, lsta) # (cntb, lstb) = (cnta + cntb, lsta ++ lstb) rawSqlColCountReason x = rawSqlColCountReason (fst x) ++ ", " ++ rawSqlColCountReason (snd x) rawSqlProcessRow = let x = getType processRow getType :: (z -> Either y x) -> x getType = error "RawSql.getType" colCountFst = fst $ rawSqlCols (error "RawSql.getType2") (fst x) processRow row = let (rowFst, rowSnd) = splitAt colCountFst row in (,) <$> rawSqlProcessRow rowFst <*> rawSqlProcessRow rowSnd in colCountFst `seq` processRow -- Avoids recalculating 'colCountFst'. instance (RawSql a, RawSql b, RawSql c) => RawSql (a, b, c) where rawSqlCols e = rawSqlCols e . from3 rawSqlColCountReason = rawSqlColCountReason . from3 rawSqlProcessRow = fmap to3 . rawSqlProcessRow from3 :: (a,b,c) -> ((a,b),c) from3 (a,b,c) = ((a,b),c) to3 :: ((a,b),c) -> (a,b,c) to3 ((a,b),c) = (a,b,c) instance (RawSql a, RawSql b, RawSql c, RawSql d) => RawSql (a, b, c, d) where rawSqlCols e = rawSqlCols e . from4 rawSqlColCountReason = rawSqlColCountReason . from4 rawSqlProcessRow = fmap to4 . rawSqlProcessRow from4 :: (a,b,c,d) -> ((a,b),(c,d)) from4 (a,b,c,d) = ((a,b),(c,d)) to4 :: ((a,b),(c,d)) -> (a,b,c,d) to4 ((a,b),(c,d)) = (a,b,c,d) instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e) => RawSql (a, b, c, d, e) where rawSqlCols e = rawSqlCols e . from5 rawSqlColCountReason = rawSqlColCountReason . from5 rawSqlProcessRow = fmap to5 . rawSqlProcessRow from5 :: (a,b,c,d,e) -> ((a,b),(c,d),e) from5 (a,b,c,d,e) = ((a,b),(c,d),e) to5 :: ((a,b),(c,d),e) -> (a,b,c,d,e) to5 ((a,b),(c,d),e) = (a,b,c,d,e) instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f) => RawSql (a, b, c, d, e, f) where rawSqlCols e = rawSqlCols e . from6 rawSqlColCountReason = rawSqlColCountReason . from6 rawSqlProcessRow = fmap to6 . rawSqlProcessRow from6 :: (a,b,c,d,e,f) -> ((a,b),(c,d),(e,f)) from6 (a,b,c,d,e,f) = ((a,b),(c,d),(e,f)) to6 :: ((a,b),(c,d),(e,f)) -> (a,b,c,d,e,f) to6 ((a,b),(c,d),(e,f)) = (a,b,c,d,e,f) instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g) => RawSql (a, b, c, d, e, f, g) where rawSqlCols e = rawSqlCols e . from7 rawSqlColCountReason = rawSqlColCountReason . from7 rawSqlProcessRow = fmap to7 . rawSqlProcessRow from7 :: (a,b,c,d,e,f,g) -> ((a,b),(c,d),(e,f),g) from7 (a,b,c,d,e,f,g) = ((a,b),(c,d),(e,f),g) to7 :: ((a,b),(c,d),(e,f),g) -> (a,b,c,d,e,f,g) to7 ((a,b),(c,d),(e,f),g) = (a,b,c,d,e,f,g) instance (RawSql a, RawSql b, RawSql c, RawSql d, RawSql e, RawSql f, RawSql g, RawSql h) => RawSql (a, b, c, d, e, f, g, h) where rawSqlCols e = rawSqlCols e . from8 rawSqlColCountReason = rawSqlColCountReason . from8 rawSqlProcessRow = fmap to8 . rawSqlProcessRow from8 :: (a,b,c,d,e,f,g,h) -> ((a,b),(c,d),(e,f),(g,h)) from8 (a,b,c,d,e,f,g,h) = ((a,b),(c,d),(e,f),(g,h)) to8 :: ((a,b),(c,d),(e,f),(g,h)) -> (a,b,c,d,e,f,g,h) to8 ((a,b),(c,d),(e,f),(g,h)) = (a,b,c,d,e,f,g,h) extractMaybe :: Maybe a -> a extractMaybe = fromMaybe (error "Database.Persist.GenericSql.extractMaybe") class PersistField a => PersistFieldSql a where sqlType :: Proxy a -> SqlType #ifndef NO_OVERLAP #if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPING #-} PersistFieldSql [Char] where #else instance PersistFieldSql [Char] where #endif sqlType _ = SqlString #endif instance PersistFieldSql ByteString where sqlType _ = SqlBlob instance PersistFieldSql T.Text where sqlType _ = SqlString instance PersistFieldSql TL.Text where sqlType _ = SqlString instance PersistFieldSql Html where sqlType _ = SqlString instance PersistFieldSql Int where sqlType _ | Just x <- bitSizeMaybe (0 :: Int), x <= 32 = SqlInt32 | otherwise = SqlInt64 instance PersistFieldSql Int8 where sqlType _ = SqlInt32 instance PersistFieldSql Int16 where sqlType _ = SqlInt32 instance PersistFieldSql Int32 where sqlType _ = SqlInt32 instance PersistFieldSql Int64 where sqlType _ = SqlInt64 instance PersistFieldSql Word where sqlType _ = SqlInt64 instance PersistFieldSql Word8 where sqlType _ = SqlInt32 instance PersistFieldSql Word16 where sqlType _ = SqlInt32 instance PersistFieldSql Word32 where sqlType _ = SqlInt64 instance PersistFieldSql Word64 where sqlType _ = SqlInt64 instance PersistFieldSql Double where sqlType _ = SqlReal instance PersistFieldSql Bool where sqlType _ = SqlBool instance PersistFieldSql Day where sqlType _ = SqlDay instance PersistFieldSql TimeOfDay where sqlType _ = SqlTime instance PersistFieldSql UTCTime where sqlType _ = SqlDayTime #if MIN_VERSION_base(4,8,0) instance {-# OVERLAPPABLE #-} PersistFieldSql a => PersistFieldSql [a] where #else instance PersistFieldSql a => PersistFieldSql [a] where #endif sqlType _ = SqlString instance PersistFieldSql a => PersistFieldSql (V.Vector a) where sqlType _ = SqlString instance (Ord a, PersistFieldSql a) => PersistFieldSql (S.Set a) where sqlType _ = SqlString instance (PersistFieldSql a, PersistFieldSql b) => PersistFieldSql (a,b) where sqlType _ = SqlString instance PersistFieldSql v => PersistFieldSql (IM.IntMap v) where sqlType _ = SqlString instance PersistFieldSql v => PersistFieldSql (M.Map T.Text v) where sqlType _ = SqlString instance PersistFieldSql PersistValue where sqlType _ = SqlInt64 -- since PersistValue should only be used like this for keys, which in SQL are Int64 instance PersistFieldSql Checkmark where sqlType _ = SqlBool instance (HasResolution a) => PersistFieldSql (Fixed a) where sqlType a = SqlNumeric long prec where prec = round $ (log $ fromIntegral $ resolution n) / (log 10 :: Double) -- FIXME: May lead to problems with big numbers long = prec + 10 -- FIXME: Is this enough ? n = 0 _mn = return n `asTypeOf` a instance PersistFieldSql Rational where sqlType _ = SqlNumeric 32 20 -- need to make this field big enough to handle Rational to Mumber string conversion for ODBC #if MIN_VERSION_base(4,8,0) instance PersistFieldSql Natural where sqlType _ = SqlInt64 #endif -- An embedded Entity instance (PersistField record, PersistEntity record) => PersistFieldSql (Entity record) where sqlType _ = SqlString persistent-2.7.1/Database/Persist/Sql/Orphan/PersistQuery.hs0000644000000000000000000004410613170567656022272 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Sql.Orphan.PersistQuery ( deleteWhereCount , updateWhereCount , decorateSQLWithLimitOffset ) where import Database.Persist hiding (updateField) import Database.Persist.Sql.Util ( entityColumnNames, parseEntityValues, isIdField) import Database.Persist.Sql.Types import Database.Persist.Sql.Raw import Database.Persist.Sql.Orphan.PersistStore (withRawQuery) import Database.Persist.Sql.Util (dbIdColumns) import qualified Data.Text as T import Data.Text (Text) import Data.Monoid (Monoid (..), (<>)) import Data.Int (Int64) import Control.Monad.IO.Class import Control.Monad.Trans.Reader (ReaderT, ask, withReaderT) import Control.Exception (throwIO) import qualified Data.Conduit.List as CL import Data.Conduit import Data.ByteString.Char8 (readInteger) import Data.Maybe (isJust) import Data.List (transpose, inits, find) -- orphaned instance for convenience of modularity instance PersistQueryRead SqlBackend where count filts = do conn <- ask let wher = if null filts then "" else filterClause False conn filts let sql = mconcat [ "SELECT COUNT(*) FROM " , connEscapeName conn $ entityDB t , wher ] withRawQuery sql (getFiltsValues conn filts) $ do mm <- CL.head case mm of Just [PersistInt64 i] -> return $ fromIntegral i Just [PersistDouble i] ->return $ fromIntegral (truncate i :: Int64) -- gb oracle Just [PersistByteString i] -> case readInteger i of -- gb mssql Just (ret,"") -> return $ fromIntegral ret xs -> error $ "invalid number i["++show i++"] xs[" ++ show xs ++ "]" Just xs -> error $ "count:invalid sql return xs["++show xs++"] sql["++show sql++"]" Nothing -> error $ "count:invalid sql returned nothing sql["++show sql++"]" where t = entityDef $ dummyFromFilts filts selectSourceRes filts opts = do conn <- ask srcRes <- rawQueryRes (sql conn) (getFiltsValues conn filts) return $ fmap ($= CL.mapM parse) srcRes where (limit, offset, orders) = limitOffsetOrder opts parse vals = case parseEntityValues t vals of Left s -> liftIO $ throwIO $ PersistMarshalError s Right row -> return row t = entityDef $ dummyFromFilts filts wher conn = if null filts then "" else filterClause False conn filts ord conn = case map (orderClause False conn) orders of [] -> "" ords -> " ORDER BY " <> T.intercalate "," ords cols = T.intercalate ", " . entityColumnNames t sql conn = connLimitOffset conn (limit,offset) (not (null orders)) $ mconcat [ "SELECT " , cols conn , " FROM " , connEscapeName conn $ entityDB t , wher conn , ord conn ] selectKeysRes filts opts = do conn <- ask srcRes <- rawQueryRes (sql conn) (getFiltsValues conn filts) return $ fmap ($= CL.mapM parse) srcRes where t = entityDef $ dummyFromFilts filts cols conn = T.intercalate "," $ dbIdColumns conn t wher conn = if null filts then "" else filterClause False conn filts sql conn = connLimitOffset conn (limit,offset) (not (null orders)) $ mconcat [ "SELECT " , cols conn , " FROM " , connEscapeName conn $ entityDB t , wher conn , ord conn ] (limit, offset, orders) = limitOffsetOrder opts ord conn = case map (orderClause False conn) orders of [] -> "" ords -> " ORDER BY " <> T.intercalate "," ords parse xs = do keyvals <- case entityPrimary t of Nothing -> case xs of [PersistInt64 x] -> return [PersistInt64 x] [PersistDouble x] -> return [PersistInt64 (truncate x)] -- oracle returns Double _ -> return xs Just 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 Right k -> return k Left err -> error $ "selectKeysImpl: keyFromValues failed" <> show err instance PersistQueryRead SqlReadBackend where count filts = withReaderT persistBackend $ count filts selectSourceRes filts opts = withReaderT persistBackend $ selectSourceRes filts opts selectKeysRes filts opts = withReaderT persistBackend $ selectKeysRes filts opts instance PersistQueryRead SqlWriteBackend where count filts = withReaderT persistBackend $ count filts selectSourceRes filts opts = withReaderT persistBackend $ selectSourceRes filts opts selectKeysRes filts opts = withReaderT persistBackend $ selectKeysRes filts opts instance PersistQueryWrite SqlBackend where deleteWhere filts = do _ <- deleteWhereCount filts return () updateWhere filts upds = do _ <- updateWhereCount filts upds return () instance PersistQueryWrite SqlWriteBackend where deleteWhere filts = withReaderT persistBackend $ deleteWhere filts updateWhere filts upds = withReaderT persistBackend $ updateWhere filts upds -- | Same as 'deleteWhere', but returns the number of rows affected. -- -- @since 1.1.5 deleteWhereCount :: (PersistEntity val, MonadIO m, PersistEntityBackend val ~ SqlBackend, IsSqlBackend backend) => [Filter val] -> ReaderT backend m Int64 deleteWhereCount filts = withReaderT persistBackend $ do conn <- ask let t = entityDef $ dummyFromFilts filts let wher = if null filts then "" else filterClause False conn filts sql = mconcat [ "DELETE FROM " , connEscapeName conn $ entityDB t , wher ] rawExecuteCount sql $ getFiltsValues conn filts -- | Same as 'updateWhere', but returns the number of rows affected. -- -- @since 1.1.5 updateWhereCount :: (PersistEntity val, MonadIO m, SqlBackend ~ PersistEntityBackend val, IsSqlBackend backend) => [Filter val] -> [Update val] -> ReaderT backend m Int64 updateWhereCount _ [] = return 0 updateWhereCount filts upds = withReaderT persistBackend $ do conn <- ask let wher = if null filts then "" else filterClause False conn filts let sql = mconcat [ "UPDATE " , connEscapeName conn $ entityDB t , " SET " , T.intercalate "," $ map (go' conn . go) upds , wher ] let dat = map updatePersistValue upds `Data.Monoid.mappend` getFiltsValues conn filts rawExecuteCount sql dat where t = entityDef $ dummyFromFilts filts go'' n Assign = n <> "=?" go'' n Add = mconcat [n, "=", n, "+?"] go'' n Subtract = mconcat [n, "=", n, "-?"] go'' n Multiply = mconcat [n, "=", n, "*?"] go'' n Divide = mconcat [n, "=", n, "/?"] go'' _ (BackendSpecificUpdate up) = error $ T.unpack $ "BackendSpecificUpdate" `mappend` up `mappend` "not supported" go' conn (x, pu) = go'' (connEscapeName conn x) pu go x = (updateField x, updateUpdate x) updateField (Update f _ _) = fieldName f updateField _ = error "BackendUpdate not implemented" fieldName :: forall record typ. (PersistEntity record, PersistEntityBackend record ~ SqlBackend) => EntityField record typ -> DBName fieldName f = fieldDB $ persistFieldDef f dummyFromFilts :: [Filter v] -> Maybe v dummyFromFilts _ = Nothing getFiltsValues :: forall val. (PersistEntity val, PersistEntityBackend val ~ SqlBackend) => SqlBackend -> [Filter val] -> [PersistValue] getFiltsValues conn = snd . filterClauseHelper False False conn OrNullNo data OrNull = OrNullYes | OrNullNo filterClauseHelper :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) => Bool -- ^ include table name? -> Bool -- ^ include WHERE? -> SqlBackend -> OrNull -> [Filter val] -> (Text, [PersistValue]) filterClauseHelper includeTable includeWhere conn orNull filters = (if not (T.null sql) && includeWhere then " WHERE " <> sql else sql, vals) where (sql, vals) = combineAND filters combineAND = combine " AND " combine s fs = (T.intercalate s $ map wrapP a, mconcat b) where (a, b) = unzip $ map go fs wrapP x = T.concat ["(", x, ")"] go (BackendFilter _) = error "BackendFilter not expected" go (FilterAnd []) = ("1=1", []) go (FilterAnd fs) = combineAND fs go (FilterOr []) = ("1=0", []) go (FilterOr fs) = combine " OR " fs go (Filter field value pfilter) = let t = entityDef $ dummyFromFilts [Filter field value pfilter] 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 <> "? ") (compositeFields pdef)) in (wrapSql sqlcl,xs) ([PersistList xs], Ne, _) -> 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 (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 (compositeFields pdef) xxs) in (wrapSql (T.intercalate " or " (map wrapSql sqls)), concat xxs) ([PersistList xs], _, True) -> 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 in (wrapSql sqlcl, concat (tail (inits xs))) (_, BackendSpecificFilter _, _) -> error "unhandled type BackendSpecificFilter for composite/non id primary keys" _ -> error $ "unhandled type/filter for composite/non id primary keys pfilter=" ++ show pfilter ++ " persistList="++show allVals (True, Just pdef, []) -> error $ "empty list given as filter value filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef (True, Just pdef, _) -> error $ "unhandled error for composite/non id primary keys filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef _ -> case (isNull, pfilter, length notNullVals) of (True, Eq, _) -> (name <> " IS NULL", []) (True, Ne, _) -> (name <> " IS NOT NULL", []) (False, Ne, _) -> (T.concat [ "(" , name , " IS NULL OR " , name , " <> " , qmarks , ")" ], notNullVals) -- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since -- not all databases support those words directly. (_, In, 0) -> ("1=2" <> orNullSuffix, []) (False, In, _) -> (name <> " IN " <> qmarks <> orNullSuffix, allVals) (True, In, _) -> (T.concat [ "(" , name , " IS NULL OR " , name , " IN " , qmarks , ")" ], notNullVals) (False, NotIn, 0) -> ("1=1", []) (True, NotIn, 0) -> (name <> " IS NOT NULL", []) (False, NotIn, _) -> (T.concat [ "(" , name , " IS NULL OR " , name , " NOT IN " , qmarks , ")" ], notNullVals) (True, NotIn, _) -> (T.concat [ "(" , name , " IS NOT NULL AND " , name , " NOT IN " , qmarks , ")" ], notNullVals) _ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals) where isCompFilter Lt = True isCompFilter Le = True isCompFilter Gt = True isCompFilter Ge = True isCompFilter _ = False wrapSql sqlcl = "(" <> sqlcl <> ")" fromPersistList (PersistList xs) = xs fromPersistList other = error $ "expected PersistList but found " ++ show other filterValueToPersistValues :: forall a. PersistField a => Either a [a] -> [PersistValue] filterValueToPersistValues v = map toPersistValue $ either return id v orNullSuffix = case orNull of OrNullYes -> mconcat [" OR ", name, " IS NULL"] OrNullNo -> "" isNull = any (== PersistNull) allVals notNullVals = filter (/= PersistNull) allVals allVals = filterValueToPersistValues value tn = connEscapeName conn $ entityDB $ entityDef $ dummyFromFilts [Filter field value pfilter] name = (if includeTable then ((tn <> ".") <>) else id) $ connEscapeName conn $ fieldName field qmarks = case value of Left _ -> "?" Right x -> let x' = filter (/= PersistNull) $ map toPersistValue x in "(" <> T.intercalate "," (map (const "?") x') <> ")" showSqlFilter Eq = "=" showSqlFilter Ne = "<>" showSqlFilter Gt = ">" showSqlFilter Lt = "<" showSqlFilter Ge = ">=" showSqlFilter Le = "<=" showSqlFilter In = " IN " showSqlFilter NotIn = " NOT IN " showSqlFilter (BackendSpecificFilter s) = s updatePersistValue :: Update v -> PersistValue updatePersistValue (Update _ v _) = toPersistValue v updatePersistValue _ = error "BackendUpdate not implemented" filterClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) => Bool -- ^ include table name? -> SqlBackend -> [Filter val] -> Text filterClause b c = fst . filterClauseHelper b True c OrNullNo orderClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) => Bool -- ^ include the table name -> SqlBackend -> SelectOpt val -> Text orderClause includeTable conn o = case o of 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 dummyFromOrder _ = Nothing tn = connEscapeName conn $ entityDB $ entityDef $ dummyFromOrder o name :: (PersistEntityBackend record ~ SqlBackend, PersistEntity record) => EntityField record typ -> Text name x = (if includeTable then ((tn <> ".") <>) else id) $ connEscapeName conn $ fieldName x -- | Generates sql for limit and offset for postgres, sqlite and mysql. decorateSQLWithLimitOffset::Text -> (Int,Int) -> Bool -> Text -> Text decorateSQLWithLimitOffset nolimit (limit,offset) _ sql = let lim = case (limit, offset) of (0, 0) -> "" (0, _) -> T.cons ' ' nolimit (_, _) -> " LIMIT " <> T.pack (show limit) off = if offset == 0 then "" else " OFFSET " <> T.pack (show offset) in mconcat [ sql , lim , off ] persistent-2.7.1/Database/Persist/Sql/Orphan/PersistStore.hs0000644000000000000000000003465413173255472022261 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Rank2Types #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Sql.Orphan.PersistStore ( withRawQuery , BackendKey(..) , toSqlKey , fromSqlKey , getFieldName , getTableName , tableDBName , fieldDBName ) where import Database.Persist import Database.Persist.Sql.Types import Database.Persist.Sql.Raw import Database.Persist.Sql.Util (dbIdColumns, keyAndEntityColumnNames) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import qualified Data.Text as T import Data.Text (Text, unpack) import Data.Monoid (mappend, (<>)) import Control.Monad.IO.Class import Data.ByteString.Char8 (readInteger) import Data.Maybe (isJust) import Data.List (find) import Control.Monad.Trans.Reader (ReaderT, ask, withReaderT) import Data.Acquire (with) import Data.Int (Int64) import Web.PathPieces (PathPiece) import Web.HttpApiData (ToHttpApiData, FromHttpApiData) import Database.Persist.Sql.Class (PersistFieldSql) import qualified Data.Aeson as A import Control.Exception.Lifted (throwIO) import Database.Persist.Class () withRawQuery :: MonadIO m => Text -> [PersistValue] -> C.Sink [PersistValue] IO a -> ReaderT SqlBackend m a withRawQuery sql vals sink = do srcRes <- rawQueryRes sql vals liftIO $ with srcRes (C.$$ sink) toSqlKey :: ToBackendKey SqlBackend record => Int64 -> Key record toSqlKey = fromBackendKey . SqlBackendKey fromSqlKey :: ToBackendKey SqlBackend record => Key record -> Int64 fromSqlKey = unSqlBackendKey . toBackendKey whereStmtForKey :: PersistEntity record => SqlBackend -> Key record -> Text whereStmtForKey conn k = T.intercalate " AND " $ map (<> "=? ") $ dbIdColumns conn entDef where entDef = entityDef $ dummyFromKey k -- | get the SQL string for the table that a PeristEntity represents -- Useful for raw SQL queries -- -- Your backend may provide a more convenient tableName function -- which does not operate in a Monad getTableName :: forall record m backend. ( PersistEntity record , PersistEntityBackend record ~ SqlBackend , IsSqlBackend backend , Monad m ) => record -> ReaderT backend m Text getTableName rec = withReaderT persistBackend $ do conn <- ask return $ connEscapeName conn $ tableDBName rec -- | useful for a backend to implement tableName by adding escaping tableDBName :: (PersistEntity record) => record -> DBName tableDBName rec = entityDB $ entityDef (Just rec) -- | get the SQL string for the field that an EntityField represents -- Useful for raw SQL queries -- -- Your backend may provide a more convenient fieldName function -- which does not operate in a Monad getFieldName :: forall record typ m backend. ( PersistEntity record , PersistEntityBackend record ~ SqlBackend , IsSqlBackend backend , Monad m ) => EntityField record typ -> ReaderT backend m Text getFieldName rec = withReaderT persistBackend $ do conn <- ask return $ connEscapeName conn $ fieldDBName rec -- | useful for a backend to implement fieldName by adding escaping fieldDBName :: forall record typ. (PersistEntity record) => EntityField record typ -> DBName fieldDBName = fieldDB . persistFieldDef instance PersistCore SqlBackend where newtype BackendKey SqlBackend = SqlBackendKey { unSqlBackendKey :: Int64 } deriving (Show, Read, Eq, Ord, Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON) instance PersistCore SqlReadBackend where newtype BackendKey SqlReadBackend = SqlReadBackendKey { unSqlReadBackendKey :: Int64 } deriving (Show, Read, Eq, Ord, Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON) instance PersistCore SqlWriteBackend where newtype BackendKey SqlWriteBackend = SqlWriteBackendKey { unSqlWriteBackendKey :: Int64 } deriving (Show, Read, Eq, Ord, Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON) instance BackendCompatible SqlBackend SqlBackend where projectBackend = id instance BackendCompatible SqlBackend SqlReadBackend where projectBackend = unSqlReadBackend instance BackendCompatible SqlBackend SqlWriteBackend where projectBackend = unSqlWriteBackend instance PersistStoreWrite SqlBackend where update _ [] = return () update k upds = do conn <- ask let go'' n Assign = n <> "=?" go'' n Add = T.concat [n, "=", n, "+?"] go'' n Subtract = T.concat [n, "=", n, "-?"] go'' n Multiply = T.concat [n, "=", n, "*?"] go'' n Divide = T.concat [n, "=", n, "/?"] go'' _ (BackendSpecificUpdate up) = error $ T.unpack $ "BackendSpecificUpdate" `Data.Monoid.mappend` up `mappend` "not supported" let go' (x, pu) = go'' (connEscapeName conn x) pu let wher = whereStmtForKey conn k let sql = T.concat [ "UPDATE " , connEscapeName conn $ tableDBName $ recordTypeFromKey k , " SET " , T.intercalate "," $ map (go' . go) upds , " WHERE " , wher ] rawExecute sql $ map updatePersistValue upds `mappend` keyToValues k where go x = (fieldDB $ updateFieldDef x, updateUpdate x) insert val = do conn <- ask let esql = connInsertSql conn t vals key <- case esql of ISRSingle sql -> withRawQuery sql vals $ do x <- CL.head case x of Just [PersistInt64 i] -> case keyFromValues [PersistInt64 i] of Left err -> error $ "SQL insert: keyFromValues: PersistInt64 " `mappend` show i `mappend` " " `mappend` unpack err Right k -> return k Nothing -> error $ "SQL insert did not return a result giving the generated ID" Just vals' -> case keyFromValues vals' of Left _ -> error $ "Invalid result from a SQL insert, got: " ++ show vals' Right k -> return k ISRInsertGet sql1 sql2 -> do rawExecute sql1 vals withRawQuery sql2 [] $ do mm <- CL.head 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 -> 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 $ 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 Left e -> error $ "ISRManyKeys: unexpected keyvals result: " `mappend` unpack e 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 insertMany [] = return [] insertMany vals = do conn <- ask case connInsertManySql conn of Nothing -> mapM insert vals Just insertManyFn -> do case insertManyFn ent valss of ISRSingle sql -> rawSql sql (concat valss) _ -> error "ISRSingle is expected from the connInsertManySql function" where ent = entityDef vals valss = map (map toPersistValue . toPersistFields) vals insertMany_ [] = return () insertMany_ vals0 = do conn <- ask case connMaxParams conn of Nothing -> insertMany_' vals0 Just maxParams -> let chunkSize = maxParams `div` length (entityFields t) in mapM_ insertMany_' (chunksOf chunkSize vals0) where insertMany_' vals = do conn <- ask let valss = map (map toPersistValue . toPersistFields) vals let sql = T.concat [ "INSERT INTO " , connEscapeName conn (entityDB t) , "(" , T.intercalate "," $ map (connEscapeName conn . fieldDB) $ entityFields t , ") VALUES (" , T.intercalate "),(" $ replicate (length valss) $ T.intercalate "," $ map (const "?") (entityFields t) , ")" ] rawExecute sql (concat valss) t = entityDef vals0 -- Implement this here to avoid depending on the split package chunksOf _ [] = [] chunksOf size xs = let (chunk, rest) = splitAt size xs in chunk : chunksOf size rest replace k val = do conn <- ask let t = entityDef $ Just val let wher = whereStmtForKey conn k let sql = T.concat [ "UPDATE " , connEscapeName conn (entityDB t) , " SET " , T.intercalate "," (map (go conn . fieldDB) $ entityFields t) , " WHERE " , wher ] vals = map toPersistValue (toPersistFields val) `mappend` keyToValues k rawExecute sql vals where go conn x = connEscapeName conn x `T.append` "=?" insertKey = insrepHelper "INSERT" repsert key value = do mExisting <- get key case mExisting of Nothing -> insertKey key value Just _ -> replace key value delete k = do conn <- ask rawExecute (sql conn) (keyToValues k) where wher conn = whereStmtForKey conn k sql conn = T.concat [ "DELETE FROM " , connEscapeName conn $ tableDBName $ recordTypeFromKey k , " WHERE " , wher conn ] instance PersistStoreWrite SqlWriteBackend where insert v = withReaderT persistBackend $ insert v insertMany vs = withReaderT persistBackend $ insertMany vs insertMany_ vs = withReaderT persistBackend $ insertMany_ vs insertKey k v = withReaderT persistBackend $ insertKey k v repsert k v = withReaderT persistBackend $ repsert k v replace k v = withReaderT persistBackend $ replace k v delete k = withReaderT persistBackend $ delete k update k upds = withReaderT persistBackend $ update k upds instance PersistStoreRead SqlBackend where get k = do conn <- ask let t = entityDef $ dummyFromKey k let cols = T.intercalate "," $ map (connEscapeName conn . fieldDB) $ entityFields t noColumns :: Bool noColumns = null $ entityFields t let wher = whereStmtForKey conn k let sql = T.concat [ "SELECT " , if noColumns then "*" else cols , " FROM " , connEscapeName conn $ entityDB t , " WHERE " , wher ] withRawQuery sql (keyToValues k) $ do res <- CL.head case res of Nothing -> return Nothing Just vals -> case fromPersistValues $ if noColumns then [] else vals of Left e -> error $ "get " ++ show k ++ ": " ++ unpack e Right v -> return $ Just v instance PersistStoreRead SqlReadBackend where get k = withReaderT persistBackend $ get k instance PersistStoreRead SqlWriteBackend where get k = withReaderT persistBackend $ get k dummyFromKey :: Key record -> Maybe record dummyFromKey = Just . recordTypeFromKey recordTypeFromKey :: Key record -> record recordTypeFromKey _ = error "dummyFromKey" insrepHelper :: (MonadIO m, PersistEntity val) => Text -> Key val -> val -> ReaderT SqlBackend m () insrepHelper command k record = do conn <- ask let columnNames = keyAndEntityColumnNames entDef conn rawExecute (sql conn columnNames) vals where entDef = entityDef $ Just record sql conn columnNames = T.concat [ command , " INTO " , connEscapeName conn (entityDB entDef) , "(" , T.intercalate "," columnNames , ") VALUES(" , T.intercalate "," (map (const "?") columnNames) , ")" ] vals = entityValues (Entity k record) updateFieldDef :: PersistEntity v => Update v -> FieldDef updateFieldDef (Update f _ _) = persistFieldDef f updateFieldDef (BackendUpdate {}) = error "updateFieldDef did not expect BackendUpdate" updatePersistValue :: Update v -> PersistValue updatePersistValue (Update _ v _) = toPersistValue v updatePersistValue (BackendUpdate {}) = error "updatePersistValue did not expect BackendUpdate" persistent-2.7.1/Database/Persist/Sql/Orphan/PersistUnique.hs0000644000000000000000000001263113170567656022431 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Sql.Orphan.PersistUnique () where import Control.Exception (throwIO) import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Trans.Reader (ReaderT) import Database.Persist import Database.Persist.Sql.Types import Database.Persist.Sql.Raw import Database.Persist.Sql.Orphan.PersistStore (withRawQuery) import Database.Persist.Sql.Util (dbColumns, parseEntityValues) import qualified Data.Text as T import Data.Monoid (mappend, (<>)) import qualified Data.Conduit.List as CL import Control.Monad.Trans.Reader (ask, withReaderT) defaultUpsert :: (MonadIO m ,PersistEntity record ,PersistUniqueWrite backend ,PersistEntityBackend record ~ BaseBackend backend) => record -> [Update record] -> ReaderT backend m (Entity record) defaultUpsert record updates = do uniqueKey <- onlyUnique record upsertBy uniqueKey record updates escape :: DBName -> T.Text escape (DBName s) = T.pack $ '"' : escapeQuote (T.unpack s) ++ "\"" where escapeQuote "" = "" escapeQuote ('"':xs) = "\"\"" ++ escapeQuote xs escapeQuote (x:xs) = x : escapeQuote xs instance PersistUniqueWrite SqlBackend where upsert record updates = do conn <- ask uniqueKey <- onlyUnique record case connUpsertSql conn of Just upsertSql -> case updates of [] -> defaultUpsert record updates _:_ -> do let upds = T.intercalate "," $ map (go' . go) updates sql = upsertSql t upds vals = (map toPersistValue $ toPersistFields record) ++ (map updatePersistValue updates) ++ (unqs uniqueKey) go'' n Assign = n <> "=?" go'' n Add = T.concat [n, "=", escape (entityDB t) <> ".", n, "+?"] go'' n Subtract = T.concat [n, "=", escape (entityDB t) <> ".", n, "-?"] go'' n Multiply = T.concat [n, "=", escape (entityDB t) <> ".", n, "*?"] go'' n Divide = T.concat [n, "=", escape (entityDB t) <> ".", n, "/?"] go'' _ (BackendSpecificUpdate up) = error $ T.unpack $ "BackendSpecificUpdate" `Data.Monoid.mappend` up `mappend` "not supported" go' (x, pu) = go'' (connEscapeName conn x) pu go x = (fieldDB $ updateFieldDef x, updateUpdate x) x <- rawSql sql vals return $ head x Nothing -> defaultUpsert record updates where t = entityDef $ Just record unqs uniqueKey = concat $ map (persistUniqueToValues) [uniqueKey] deleteBy uniq = do conn <- ask let sql' = sql conn vals = persistUniqueToValues uniq rawExecute sql' vals where t = entityDef $ dummyFromUnique uniq go = map snd . persistUniqueToFieldNames go' conn x = connEscapeName conn x `mappend` "=?" sql conn = T.concat [ "DELETE FROM " , connEscapeName conn $ entityDB t , " WHERE " , T.intercalate " AND " $ map (go' conn) $ go uniq] instance PersistUniqueWrite SqlWriteBackend where deleteBy uniq = withReaderT persistBackend $ deleteBy uniq instance PersistUniqueRead SqlBackend where getBy uniq = do conn <- ask let sql = T.concat [ "SELECT " , T.intercalate "," $ dbColumns conn t , " FROM " , connEscapeName conn $ entityDB t , " WHERE " , sqlClause conn] uvals = persistUniqueToValues uniq withRawQuery sql uvals $ do row <- CL.head case row of Nothing -> return Nothing Just [] -> error "getBy: empty row" Just vals -> case parseEntityValues t vals of Left err -> liftIO $ throwIO $ PersistMarshalError err Right r -> return $ Just r where sqlClause conn = T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq go conn x = connEscapeName conn x `mappend` "=?" t = entityDef $ dummyFromUnique uniq toFieldNames' = map snd . persistUniqueToFieldNames instance PersistUniqueRead SqlReadBackend where getBy uniq = withReaderT persistBackend $ getBy uniq instance PersistUniqueRead SqlWriteBackend where getBy uniq = withReaderT persistBackend $ getBy uniq dummyFromUnique :: Unique v -> Maybe v dummyFromUnique _ = Nothing updateFieldDef :: PersistEntity v => Update v -> FieldDef updateFieldDef (Update f _ _) = persistFieldDef f updateFieldDef (BackendUpdate{}) = error "updateFieldDef did not expect BackendUpdate" updatePersistValue :: Update v -> PersistValue updatePersistValue (Update _ v _) = toPersistValue v updatePersistValue (BackendUpdate{}) = error "updatePersistValue did not expect BackendUpdate" persistent-2.7.1/test/main.hs0000644000000000000000000000713213170567656014371 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} import Test.Hspec import Database.Persist.Quasi import Database.Persist.Types main :: IO () main = hspec $ do describe "tokenization" $ do it "handles normal words" $ tokenize " foo bar baz" `shouldBe` [ Spaces 1 , Token "foo" , Spaces 3 , Token "bar" , Spaces 2 , Token "baz" ] it "handles quotes" $ tokenize " \"foo bar\" \"baz\"" `shouldBe` [ Spaces 2 , Token "foo bar" , Spaces 2 , Token "baz" ] it "handles quotes mid-token" $ tokenize " x=\"foo bar\" \"baz\"" `shouldBe` [ Spaces 2 , Token "x=foo bar" , Spaces 2 , Token "baz" ] it "handles escaped quote mid-token" $ tokenize " x=\\\"foo bar\" \"baz\"" `shouldBe` [ Spaces 2 , Token "x=\\\"foo" , Spaces 1 , Token "bar\"" , Spaces 2 , Token "baz" ] it "handles unnested parantheses" $ tokenize " (foo bar) (baz)" `shouldBe` [ Spaces 2 , Token "foo bar" , Spaces 2 , Token "baz" ] it "handles unnested parantheses mid-token" $ tokenize " x=(foo bar) (baz)" `shouldBe` [ Spaces 2 , Token "x=foo bar" , Spaces 2 , Token "baz" ] it "handles nested parantheses" $ tokenize " (foo (bar)) (baz)" `shouldBe` [ Spaces 2 , Token "foo (bar)" , Spaces 2 , Token "baz" ] it "escaping" $ tokenize " (foo \\(bar) y=\"baz\\\"\"" `shouldBe` [ Spaces 2 , Token "foo (bar" , Spaces 2 , Token "y=baz\"" ] it "mid-token quote in later token" $ tokenize "foo bar baz=(bin\")" `shouldBe` [ Token "foo" , Spaces 1 , Token "bar" , Spaces 1 , Token "baz=bin\"" ] describe "parseFieldType" $ do it "simple types" $ parseFieldType "FooBar" `shouldBe` Right (FTTypeCon Nothing "FooBar") it "module types" $ parseFieldType "Data.Map.FooBar" `shouldBe` Right (FTTypeCon (Just "Data.Map") "FooBar") it "application" $ parseFieldType "Foo Bar" `shouldBe` Right ( FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar") it "application multiple" $ parseFieldType "Foo Bar Baz" `shouldBe` Right ( (FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar") `FTApp` FTTypeCon Nothing "Baz" ) it "parens" $ do let foo = FTTypeCon Nothing "Foo" bar = FTTypeCon Nothing "Bar" baz = FTTypeCon Nothing "Baz" 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` Right ( foo `FTApp` bars `FTApp` baz) persistent-2.7.1/LICENSE0000644000000000000000000000207513170567656013140 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. persistent-2.7.1/Setup.lhs0000755000000000000000000000016213170567656013741 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain persistent-2.7.1/persistent.cabal0000644000000000000000000001162313173255472015307 0ustar0000000000000000name: persistent version: 2.7.1 license: MIT license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman , Greg Weber synopsis: Type-safe, multi-backend data serialization. description: Hackage documentation generation is not reliable. For up to date documentation, please see: . category: Database, Yesod stability: Stable cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/book/persistent bug-reports: https://github.com/yesodweb/persistent/issues extra-source-files: ChangeLog.md README.md flag nooverlap default: False description: test out our assumption that OverlappingInstances is just for String library if flag(nooverlap) cpp-options: -DNO_OVERLAP build-depends: base >= 4.7 && < 5 , bytestring >= 0.9 , transformers >= 0.2.1 , time >= 1.1.4 , old-locale , text >= 0.8 , containers >= 0.2 , conduit >= 1.0 , resourcet >= 1.1 , exceptions >= 0.6 , monad-control >= 0.3 , lifted-base >= 0.1 , resource-pool >= 0.2.2.0 , path-pieces >= 0.1 , http-api-data >= 0.2 && < 0.4 , aeson >= 0.5 , monad-logger >= 0.3 , transformers-base , base64-bytestring , unordered-containers , vector , attoparsec , template-haskell , blaze-html >= 0.5 , blaze-markup >= 0.5.1 , silently , mtl , fast-logger >= 2.1 , scientific , tagged exposed-modules: Database.Persist Database.Persist.Quasi Database.Persist.Types Database.Persist.Class Database.Persist.Sql Database.Persist.Sql.Util Database.Persist.Sql.Types.Internal other-modules: Database.Persist.Types.Base Database.Persist.Class.DeleteCascade Database.Persist.Class.PersistEntity Database.Persist.Class.PersistQuery Database.Persist.Class.PersistUnique Database.Persist.Class.PersistConfig Database.Persist.Class.PersistField Database.Persist.Class.PersistStore Database.Persist.Sql.Migration Database.Persist.Sql.Internal Database.Persist.Sql.Types Database.Persist.Sql.Raw Database.Persist.Sql.Run Database.Persist.Sql.Class Database.Persist.Sql.Orphan.PersistQuery Database.Persist.Sql.Orphan.PersistStore Database.Persist.Sql.Orphan.PersistUnique ghc-options: -Wall test-suite test type: exitcode-stdio-1.0 main-is: test/main.hs build-depends: base >= 4.6 && < 5 , hspec >= 1.3 , containers , text , unordered-containers , time , old-locale , bytestring , vector , base64-bytestring , attoparsec , transformers , path-pieces , http-api-data >= 0.2 && < 0.4 , aeson , resourcet , monad-logger , conduit , monad-control , blaze-html , scientific , tagged , fast-logger >= 2.1 , lifted-base >= 0.1 , mtl , template-haskell , resource-pool cpp-options: -DTEST other-modules: Database.Persist.Class.PersistEntity Database.Persist.Class.PersistField Database.Persist.Quasi Database.Persist.Types Database.Persist.Types.Base source-repository head type: git location: git://github.com/yesodweb/persistent.git persistent-2.7.1/ChangeLog.md0000644000000000000000000000453313173255472014276 0ustar0000000000000000## 2.7.1 * Added an `insertUniqueEntity` function [#718](https://github.com/yesodweb/persistent/pull/718) * Added `BackendCompatible` class [#701](https://github.com/yesodweb/persistent/pull/701) ## 2.7.0 * Fix upsert behavior [#613](https://github.com/yesodweb/persistent/issues/613) * Atomic upsert query fixed for arithmatic operations [#662](https://github.com/yesodweb/persistent/issues/662) * Haddock and test coverage improved for upsert ## 2.6.1 * Fix edge case for `\<-. [Nothing]` * Introduce `connMaxParams` * Add 'getJustEntity' and 'insertRecord' convenience function * Minor Haddock improvment ## 2.6 * Add `connUpsertSql` type for providing backend-specific upsert sql support. ## 2.5 * read/write typeclass split * add insertOrGet convenience function to PersistUnique ## 2.2.4.1 * Documentation updates [#515](https://github.com/yesodweb/persistent/pull/515) ## 2.2.4 * Workaround for side-exiting transformers in `runSqlConn` [#516](https://github.com/yesodweb/persistent/issues/516) ## 2.2.3 * PersistField instance for Natural * better oracle support in odbc ## 2.2.2 * Add liftSqlPersistMPool function * support http-api-data for url serialization ## 2.2.1 * Migration failure message with context * Fix insertKey for composite keys ## 2.2 * Add a `RawSql` instance for `Key`. This allows selecting primary keys using functions like `rawSql`. [#407](https://github.com/yesodweb/persistent/pull/407) * SqlBackend support for an optimized `insertMany` ## 2.1.6 Important! If persistent-template is not upgraded to 2.1.3.3 you might need to make sure `Int64` is in scope for your model declarations. * add showMigration function * explicitly use Int64 for foreign key references ## 2.1.5 Add `dbIdColumnsEsc` to Sql.Utils. Used in persistent-postgresql 2.1.5.2 ## 2.1.4 * Fix getBy with a primary key. #342 ## 2.1.3 * Break self-referencing cycles in the entity declarations ## 2.1.2 * Error with `Double`s without a decimal part [#378](https://github.com/yesodweb/persistent/issues/378) * `runSqlPool` does not perform timeout checks. ## 2.1.1.6 * One extra feature for #939: use `logDebugN` instead ## 2.1.1.5 * Better SQL logging [Yesod issue #939](https://github.com/yesodweb/yesod/issues/939) ## 2.1.1.3 Parse UTCTime in 8601 format [#339](https://github.com/yesodweb/persistent/issues/339) ## 2.1.1.1 Support for monad-control 1.0 persistent-2.7.1/README.md0000644000000000000000000000032013170567656013401 0ustar0000000000000000## persistent Type-safe, data serialization. You must use a specific backend in order to make this useful. For more information, see [the chapter in the Yesod book](http://www.yesodweb.com/book/persistent).