persistent-1.2.2.0/0000755000000000000000000000000012166672125012250 5ustar0000000000000000persistent-1.2.2.0/LICENSE0000644000000000000000000000207512166672125013261 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-1.2.2.0/persistent.cabal0000644000000000000000000000734212166672125015442 0ustar0000000000000000name: persistent version: 1.2.2.0 license: MIT license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman synopsis: Type-safe, multi-backend data serialization. description: Type-safe, data serialization. You must use a specific backend in order to make this useful. category: Database, Yesod stability: Stable cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/book/persistent 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 && < 5 , bytestring >= 0.9 , transformers >= 0.2.1 , time >= 1.1.4 , text >= 0.8 , containers >= 0.2 , conduit >= 1.0 , resourcet >= 0.4 , monad-control >= 0.3 , lifted-base >= 0.1 , pool-conduit >= 0.1.2 , path-pieces >= 0.1 , 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 exposed-modules: Database.Persist Database.Persist.Quasi Database.Persist.Types Database.Persist.Class Database.Persist.Sql 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 && < 5 , hspec >= 1.3 , containers , text , unordered-containers , time , bytestring , vector , base64-bytestring , attoparsec , transformers , path-pieces , aeson , resourcet , monad-logger , conduit , monad-control , blaze-html cpp-options: -DTEST source-repository head type: git location: git://github.com/yesodweb/persistent.git persistent-1.2.2.0/Setup.lhs0000644000000000000000000000016212166672125014057 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain persistent-1.2.2.0/test/0000755000000000000000000000000012166672125013227 5ustar0000000000000000persistent-1.2.2.0/test/main.hs0000644000000000000000000000525012166672125014511 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 unnested parantheses" $ tokenize " (foo bar) (baz)" `shouldBe` [ Spaces 2 , Token "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) \"baz\\\"\"" `shouldBe` [ Spaces 2 , Token "foo (bar" , Spaces 2 , Token "baz\"" ] describe "parseFieldType" $ do it "simple types" $ parseFieldType "FooBar" `shouldBe` Just (FTTypeCon Nothing "FooBar") it "module types" $ parseFieldType "Data.Map.FooBar" `shouldBe` Just (FTTypeCon (Just "Data.Map") "FooBar") it "application" $ parseFieldType "Foo Bar" `shouldBe` Just ( FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar") it "application multiple" $ parseFieldType "Foo Bar Baz" `shouldBe` Just ( (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` Just ( foo `FTApp` (bar `FTApp` baz)) it "lists" $ do let foo = FTTypeCon Nothing "Foo" bar = FTTypeCon Nothing "Bar" bars = FTList bar baz = FTTypeCon Nothing "Baz" parseFieldType "Foo [Bar] Baz" `shouldBe` Just ( foo `FTApp` bars `FTApp` baz) describe "stripId" $ do it "works" $ (parseFieldType "FooId" >>= stripId) `shouldBe` Just "Foo" persistent-1.2.2.0/Database/0000755000000000000000000000000012166672125013754 5ustar0000000000000000persistent-1.2.2.0/Database/Persist.hs0000644000000000000000000000455712166672125015754 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} module Database.Persist ( module Database.Persist.Class , module Database.Persist.Types -- * query combinators , (=.), (+=.), (-=.), (*=.), (/=.) , (==.), (!=.), (<.), (>.), (<=.), (>=.) , (<-.), (/<-.) , (||.) -- * JSON Utilities , listToJSON , mapToJSON , getPersistMap -- * Other utililities , 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) import Data.Aeson.Encode (fromValue) infixr 3 =., +=., -=., *=., /=. (=.), (+=.), (-=.), (*=.), (/=.) :: forall v typ. PersistField typ => EntityField v typ -> typ -> Update v -- | assign a field a value f =. a = Update f a Assign -- | assign a field by addition (+=) f +=. a = Update f a Add -- | assign a field by subtraction (-=) f -=. a = Update f a Subtract -- | assign a field by multiplication (*=) f *=. a = Update f a Multiply -- | assign a field by division (/=) f /=. a = Update f a Divide infix 4 ==., <., <=., >., >=., !=. (==.), (!=.), (<.), (<=.), (>.), (>=.) :: forall v typ. PersistField typ => EntityField v typ -> typ -> Filter v f ==. a = Filter f (Left a) Eq f !=. a = Filter f (Left a) Ne f <. a = Filter f (Left a) Lt f <=. a = Filter f (Left a) Le f >. a = Filter f (Left a) Gt f >=. a = Filter f (Left a) Ge infix 4 <-., /<-. (<-.), (/<-.) :: forall v typ. PersistField typ => EntityField v typ -> [typ] -> Filter v -- | In f <-. a = Filter f (Right a) In -- | NotIn f /<-. a = Filter f (Right a) NotIn infixl 3 ||. (||.) :: forall v. [Filter v] -> [Filter v] -> [Filter v] -- | the OR of two lists of filters a ||. b = [FilterOr [FilterAnd a, FilterAnd b]] listToJSON :: [PersistValue] -> T.Text listToJSON = toStrict . toLazyText . fromValue . toJSON mapToJSON :: [(T.Text, PersistValue)] -> T.Text mapToJSON = toStrict . toLazyText . fromValue . toJSON 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-1.2.2.0/Database/Persist/0000755000000000000000000000000012166672125015405 5ustar0000000000000000persistent-1.2.2.0/Database/Persist/Types.hs0000644000000000000000000000064412166672125017051 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TypeFamilies #-} module Database.Persist.Types ( module Database.Persist.Types.Base , SomePersistField (..) , Update (..) , SelectOpt (..) , BackendSpecificFilter , Filter (..) , Key , Entity (..) ) where import Database.Persist.Types.Base import Database.Persist.Class.PersistField import Database.Persist.Class.PersistEntity persistent-1.2.2.0/Database/Persist/Class.hs0000644000000000000000000000152612166672125017012 0ustar0000000000000000module Database.Persist.Class ( -- * PersistStore PersistStore (..) , getJust , belongsTo , belongsToJust -- * PersistUnique , PersistUnique (..) , getByValue , insertBy , replaceUnique -- * PersistQuery , PersistQuery (..) , selectList , selectKeysList -- * DeleteCascade , DeleteCascade (..) , deleteCascadeWhere -- * PersistEntity , PersistEntity (..) -- * PersistField , PersistField (..) -- * PersistConfig , PersistConfig (..) ) 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 persistent-1.2.2.0/Database/Persist/Sql.hs0000644000000000000000000000260112166672125016477 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 , rawQuery , rawExecute , rawExecuteCount , rawSql , deleteWhereCount , updateWhereCount , transactionSave , transactionUndo , getStmtConn -- * Internal , module Database.Persist.Sql.Internal ) where import Database.Persist import Database.Persist.Sql.Types import Database.Persist.Sql.Class import Database.Persist.Sql.Run 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 -- | Commit the current transaction and begin a new one. -- -- Since 1.2.0 transactionSave :: MonadSqlPersist m => m () transactionSave = do conn <- askSqlConn 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 :: MonadSqlPersist m => m () transactionUndo = do conn <- askSqlConn let getter = getStmtConn conn liftIO $ connRollback conn getter >> connBegin conn getter persistent-1.2.2.0/Database/Persist/Quasi.hs0000644000000000000000000002302412166672125017024 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module Database.Persist.Quasi ( parse , PersistSettings (..) , upperCaseSettings , lowerCaseSettings , stripId , nullable #if TEST , Token (..) , tokenize , parseFieldType #endif ) where import Prelude hiding (lines) import Database.Persist.Types import Data.Char import Data.Maybe (mapMaybe, fromMaybe) import Data.Text (Text) import qualified Data.Text as T import Control.Arrow ((&&&)) import qualified Data.Map as M import Data.List (foldl') data ParseState a = PSDone | PSFail | PSSuccess a Text parseFieldType :: Text -> Maybe FieldType parseFieldType t0 = case go t0 of PSSuccess ft t' | T.all isSpace t' -> Just ft _ -> Nothing where go t = case goMany id t of PSSuccess (ft:fts) t' -> PSSuccess (foldl' FTApp ft fts) t' PSSuccess [] _ -> PSFail PSFail -> PSFail PSDone -> PSDone go1 t = case T.uncons t of Nothing -> PSDone Just (c, t') | isSpace c -> go1 $ T.dropWhile isSpace t' | c == '(' -> case go t' of PSSuccess ft t'' -> case T.uncons $ T.dropWhile isSpace t'' of Just (')', t''') -> PSSuccess ft t''' _ -> PSFail _ -> PSFail | c == '[' -> case go t' of PSSuccess ft t'' -> case T.uncons $ T.dropWhile isSpace t'' of Just (']', t''') -> PSSuccess (FTList ft) t''' _ -> PSFail _ -> PSFail | isUpper c -> let (a, b) = T.break (\x -> isSpace x || x `elem` "()[]") t in PSSuccess (getCon a) b | otherwise -> PSFail getCon t = case T.breakOnEnd "." t of (_, "") -> FTTypeCon Nothing t ("", _) -> FTTypeCon Nothing t (a, b) -> FTTypeCon (Just $ T.init a) b goMany front t = case go1 t of PSSuccess x t' -> goMany (front . (x:)) t' _ -> PSSuccess (front []) t data PersistSettings = PersistSettings { psToDBName :: !(Text -> Text) , psStrictFields :: !Bool -- ^ Whether fields are by default strict. Default value: @True@. -- -- Since 1.2 } upperCaseSettings :: PersistSettings upperCaseSettings = PersistSettings { psToDBName = id , psStrictFields = True } lowerCaseSettings :: PersistSettings lowerCaseSettings = PersistSettings { psToDBName = let go c | isUpper c = T.pack ['_', toLower c] | otherwise = T.singleton c in T.dropWhile (== '_') . T.concatMap go , psStrictFields = True } -- | 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 | otherwise = let (token, rest) = T.break isSpace t in Token token : tokenize rest where 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 = toEnts lines where toEnts (Line indent (name:entattribs) : rest) = let (x, y) = span ((> indent) . lineIndent) rest in mkEntityDef ps name entattribs x : toEnts y toEnts (Line _ []:rest) = toEnts rest toEnts [] = [] -- | Construct an entity definition. mkEntityDef :: PersistSettings -> Text -- ^ name -> [Attr] -- ^ entity attributes -> [Line] -- ^ indented lines -> EntityDef () mkEntityDef ps name entattribs lines = EntityDef (HaskellName name') (DBName $ getDbName ps name' entattribs) (DBName $ idName entattribs) entattribs cols uniqs derives extras isSum where (isSum, name') = case T.uncons name of Just ('+', x) -> (True, x) _ -> (False, name) (attribs, extras) = splitExtras lines idName [] = "id" idName (t:ts) = case T.stripPrefix "id=" t of Nothing -> idName ts Just s -> s uniqs = mapMaybe (takeUniqs ps cols) attribs derives = concat $ mapMaybe takeDerives attribs cols :: [FieldDef ()] cols = mapMaybe (takeCols ps) attribs splitExtras :: [Line] -> ([[Text]], M.Map Text [[Text]]) splitExtras [] = ([], M.empty) splitExtras (Line indent [name]:rest) | not (T.null name) && isUpper (T.head name) = let (children, rest') = span ((> indent) . lineIndent) rest (x, y) = splitExtras rest' in (x, M.insert name (map tokens children) y) splitExtras (Line _ ts:rest) = let (x, y) = splitExtras rest in (ts:x, y) takeCols :: PersistSettings -> [Text] -> Maybe (FieldDef ()) takeCols _ ("deriving":_) = Nothing takeCols ps (n':typ:rest) | not (T.null n) && isLower (T.head n) = case parseFieldType typ of Nothing -> error $ "Invalid field type: " ++ show typ Just ft -> Just FieldDef { fieldHaskell = HaskellName n , fieldDB = DBName $ getDbName ps n rest , fieldType = ft , fieldSqlType = () , fieldAttrs = rest , fieldStrict = fromMaybe (psStrictFields ps) mstrict , fieldEmbedded = Nothing } 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) = case T.stripPrefix "sql=" a of Nothing -> getDbName ps n as Just s -> s takeUniqs :: PersistSettings -> [FieldDef a] -> [Text] -> Maybe UniqueDef takeUniqs ps defs (n:rest) | not (T.null n) && isUpper (T.head n) = Just $ UniqueDef (HaskellName n) (DBName $ psToDBName ps 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 takeUniqs _ _ _ = Nothing takeDerives :: [Text] -> Maybe [Text] takeDerives ("deriving":rest) = Just rest takeDerives _ = Nothing stripId :: FieldType -> Maybe Text stripId (FTTypeCon Nothing t) = T.stripSuffix "Id" t stripId _ = Nothing nullable :: [Text] -> IsNullable nullable s | "Maybe" `elem` s = Nullable ByMaybeAttr | "nullable" `elem` s = Nullable ByNullableAttr | otherwise = NotNullable persistent-1.2.2.0/Database/Persist/Class/0000755000000000000000000000000012166672125016452 5ustar0000000000000000persistent-1.2.2.0/Database/Persist/Class/PersistStore.hs0000644000000000000000000001217112166672125021456 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies, FlexibleContexts #-} module Database.Persist.Class.PersistStore ( PersistStore (..) , getJust , belongsTo , belongsToJust ) where import qualified Prelude import Prelude hiding ((++), show) import qualified Data.Text as T import Control.Monad.Trans.Error (Error (..)) import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Monoid (Monoid) import Control.Exception.Lifted (throwIO) import Data.Conduit.Internal (Pipe, ConduitM) import Control.Monad.Logger (LoggingT) import Control.Monad.Trans.Identity ( IdentityT) import Control.Monad.Trans.List ( ListT ) import Control.Monad.Trans.Maybe ( MaybeT ) import Control.Monad.Trans.Error ( ErrorT ) import Control.Monad.Trans.Reader ( ReaderT ) import Control.Monad.Trans.Cont ( ContT ) import Control.Monad.Trans.State ( StateT ) import Control.Monad.Trans.Writer ( WriterT ) import Control.Monad.Trans.RWS ( RWST ) import Control.Monad.Trans.Resource ( ResourceT) import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST ) import qualified Control.Monad.Trans.State.Strict as Strict ( StateT ) import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) import Database.Persist.Class.PersistEntity import Database.Persist.Types class MonadIO m => PersistStore m where type PersistMonadBackend m -- | Get a record by identifier, if available. get :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val) => Key val -> m (Maybe val) -- | Create a new record in the database, returning an automatically created -- key (in SQL an auto-increment id). insert :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val) => val -> m (Key val) -- | Same as 'insert', but doesn't return a @Key@. insert_ :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val) => val -> m () insert_ val = insert val >> return () -- | Create multiple records in the database. -- SQL backends currently use the slow default implementation of -- @mapM insert@ insertMany :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val) => [val] -> m [Key val] insertMany = mapM insert -- | Create a new record in the database using the given key. insertKey :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> 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 :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> 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 :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val) => Key val -> val -> m () -- | Delete a specific record by identifier. Does nothing if record does -- not exist. delete :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val) => Key val -> m () -- | 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 :: (PersistStore m, PersistEntity val, Show (Key val), PersistMonadBackend m ~ PersistEntityBackend val) => Key val -> m val getJust key = get key >>= maybe (liftIO $ throwIO $ PersistForeignConstraintUnmet $ T.pack $ Prelude.show key) return -- | curry this to make a convenience function that loads an associated model -- > foreign = belongsTo foeignId belongsTo :: (PersistStore m , PersistEntity ent1 , PersistEntity ent2 , PersistMonadBackend m ~ PersistEntityBackend ent2 ) => (ent1 -> Maybe (Key ent2)) -> ent1 -> 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 :: (PersistStore m , PersistEntity ent1 , PersistEntity ent2 , PersistMonadBackend m ~ PersistEntityBackend ent2) => (ent1 -> Key ent2) -> ent1 -> m ent2 belongsToJust getForeignKey model = getJust $ getForeignKey model #define DEF(T) { type PersistMonadBackend (T m) = PersistMonadBackend m; insert = lift . insert; insertKey k = lift . insertKey k; repsert k = lift . repsert k; replace k = lift . replace k; delete = lift . delete; get = lift . get } #define GO(T) instance (PersistStore m) => PersistStore (T m) where DEF(T) #define GOX(X, T) instance (X, PersistStore m) => PersistStore (T m) where DEF(T) GO(LoggingT) GO(IdentityT) GO(ListT) GO(MaybeT) GOX(Error e, ErrorT e) GO(ReaderT r) GO(ContT r) GO(StateT s) GO(ResourceT) GO(Pipe l i o u) GO(ConduitM i o) GOX(Monoid w, WriterT w) GOX(Monoid w, RWST r w s) GOX(Monoid w, Strict.RWST r w s) GO(Strict.StateT s) GOX(Monoid w, Strict.WriterT w) #undef DEF #undef GO #undef GOX persistent-1.2.2.0/Database/Persist/Class/PersistEntity.hs0000644000000000000000000001134312166672125021636 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} module Database.Persist.Class.PersistEntity ( PersistEntity (..) , Update (..) , SelectOpt (..) , BackendSpecificFilter , Filter (..) , Key , Entity (..) ) where import Database.Persist.Types.Base import Database.Persist.Class.PersistField import Data.Text (Text) import Data.Aeson (ToJSON (..), FromJSON (..), object, (.:), (.=), Value (Object)) import Control.Applicative ((<$>), (<*>)) -- | A single database entity. For example, if writing a blog application, a -- blog entry would be an entry, containing fields such as title and content. class PersistEntity val where -- | Parameters: val and datatype of the field data EntityField val :: * -> * persistFieldDef :: EntityField val typ -> FieldDef SqlType type PersistEntityBackend val -- | Unique keys in existence on this entity. data Unique val entityDef :: Monad m => m val -> EntityDef SqlType toPersistFields :: val -> [SomePersistField] fromPersistValues :: [PersistValue] -> Either Text val persistUniqueToFieldNames :: Unique val -> [(HaskellName, DBName)] persistUniqueToValues :: Unique val -> [PersistValue] persistUniqueKeys :: val -> [Unique val] persistIdField :: EntityField val (Key val) fieldLens :: EntityField val field -> (forall f. Functor f => (field -> f field) -> Entity val -> f (Entity val)) data Update v = forall typ. PersistField typ => Update { updateField :: EntityField v typ , updateValue :: typ , updateUpdate :: PersistUpdate -- FIXME Replace with expr down the road } data SelectOpt v = forall typ. Asc (EntityField v typ) | forall typ. Desc (EntityField v typ) | OffsetBy Int | LimitTo Int type family BackendSpecificFilter b v -- | 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. data Filter v = forall typ. PersistField typ => Filter { filterField :: EntityField v typ , filterValue :: Either typ [typ] -- FIXME , filterFilter :: PersistFilter -- FIXME } | FilterAnd [Filter v] -- ^ convenient for internal use, not needed for the API | FilterOr [Filter v] | BackendFilter (BackendSpecificFilter (PersistEntityBackend v) v) -- | Helper wrapper, equivalent to @Key (PersistEntityBackend val) val@. -- -- Since 1.1.0 type Key val = KeyBackend (PersistEntityBackend val) val -- | Datatype that represents an entity, with both its key and -- its Haskell representation. -- -- When using the an 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 entity = Entity { entityKey :: Key entity , entityVal :: entity } deriving (Eq, Ord, Show, Read) instance ToJSON e => ToJSON (Entity e) where toJSON (Entity k v) = object [ "key" .= k , "value" .= v ] instance FromJSON e => FromJSON (Entity e) where parseJSON (Object o) = Entity <$> o .: "key" <*> o .: "value" parseJSON _ = fail "FromJSON Entity: not an object" persistent-1.2.2.0/Database/Persist/Class/PersistUnique.hs0000644000000000000000000001436312166672125021635 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies, FlexibleContexts #-} module Database.Persist.Class.PersistUnique ( PersistUnique (..) , getByValue , insertBy , replaceUnique ) where import qualified Prelude import Prelude hiding ((++), show) import Control.Monad (liftM) import Control.Monad.Trans.Error (Error (..)) import Control.Monad.Trans.Class (lift) import Data.Monoid (Monoid) import Data.List ((\\)) import Data.Conduit.Internal (Pipe) import Control.Monad.Logger (LoggingT) import Control.Monad.Trans.Identity ( IdentityT) import Control.Monad.Trans.List ( ListT ) import Control.Monad.Trans.Maybe ( MaybeT ) import Control.Monad.Trans.Error ( ErrorT ) import Control.Monad.Trans.Reader ( ReaderT ) import Control.Monad.Trans.Cont ( ContT ) import Control.Monad.Trans.State ( StateT ) import Control.Monad.Trans.Writer ( WriterT ) import Control.Monad.Trans.RWS ( RWST ) import Control.Monad.Trans.Resource ( ResourceT) import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST ) import qualified Control.Monad.Trans.State.Strict as Strict ( StateT ) import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistEntity -- | Queries against unique keys (other than the id). -- -- Please read the general Persistent documentation to learn how to create -- Unique keys. -- SQL backends automatically create uniqueness constraints, but for MongoDB you must manually place a unique index on the field. -- -- 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 tryting to catch the correct exception and determing the column of failure. -- * an exception will automatically abort the current SQL transaction class PersistStore m => PersistUnique m where -- | Get a record by unique key, if available. Returns also the identifier. getBy :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => Unique val -> m (Maybe (Entity val)) -- | Delete a specific record by unique key. Does nothing if no record -- matches. deleteBy :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => Unique val -> m () -- | Like 'insert', but returns 'Nothing' when the record -- couldn't be inserted because of a uniqueness constraint. insertUnique :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => val -> m (Maybe (Key val)) insertUnique datum = do conflict <- checkUnique datum case conflict of Nothing -> Just `liftM` insert datum Just _ -> return Nothing -- | Insert a value, checking for conflicts with any unique constraints. If a -- duplicate exists in the database, it is returned as 'Left'. Otherwise, the -- new 'Key is returned as 'Right'. insertBy :: (PersistEntity val, PersistUnique m, PersistEntityBackend val ~ PersistMonadBackend m) => val -> m (Either (Entity val) (Key val)) insertBy val = do res <- getByValue val case res of Nothing -> Right `liftM` insert val Just z -> return $ Left z -- | A modification of 'getBy', which takes the 'PersistEntity' itself instead -- of a 'Unique' value. Returns a value matching /one/ of the unique keys. This -- function makes the most sense on entities with a single 'Unique' -- constructor. getByValue :: (PersistEntity value, PersistUnique m, PersistEntityBackend value ~ PersistMonadBackend m) => value -> m (Maybe (Entity value)) getByValue = checkUniques . persistUniqueKeys where checkUniques [] = return Nothing checkUniques (x:xs) = do y <- getBy x case y of Nothing -> checkUniques xs Just z -> return $ Just z -- | 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 Unque violation -- -- Since 1.2.2.0 replaceUnique :: (Eq record, Eq (Unique record), PersistEntityBackend record ~ PersistMonadBackend m, PersistEntity record, PersistStore m, PersistUnique m) => Key record -> record -> 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 = uniqueKeysOriginal \\ uniqueKeysNew 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 :: (PersistEntityBackend record ~ PersistMonadBackend m, PersistEntity record, PersistUnique m) => record -> m (Maybe (Unique record)) checkUnique = checkUniqueKeys . persistUniqueKeys checkUniqueKeys :: (PersistEntity record, PersistUnique m, PersistEntityBackend record ~ PersistMonadBackend m) => [Unique record] -> m (Maybe (Unique record)) checkUniqueKeys [] = return Nothing checkUniqueKeys (x:xs) = do y <- getBy x case y of Nothing -> checkUniqueKeys xs Just _ -> return (Just x) #define DEF(T) { getBy = lift . getBy; deleteBy = lift . deleteBy; insertUnique = lift . insertUnique } #define GO(T) instance (PersistUnique m) => PersistUnique (T m) where DEF(T) #define GOX(X, T) instance (X, PersistUnique m) => PersistUnique (T m) where DEF(T) GO(LoggingT) GO(IdentityT) GO(ListT) GO(MaybeT) GOX(Error e, ErrorT e) GO(ReaderT r) GO(ContT r) GO(StateT s) GO(ResourceT) GO(Pipe l i o u) GOX(Monoid w, WriterT w) GOX(Monoid w, RWST r w s) GOX(Monoid w, Strict.RWST r w s) GO(Strict.StateT s) GOX(Monoid w, Strict.WriterT w) #undef DEF #undef GO #undef GOX persistent-1.2.2.0/Database/Persist/Class/PersistQuery.hs0000644000000000000000000001157412166672125021475 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} module Database.Persist.Class.PersistQuery ( PersistQuery (..) , selectList , selectKeysList ) where import Control.Exception (throwIO) import Database.Persist.Types import Control.Monad.Trans.Error (Error (..)) import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Monoid (Monoid) import Data.Conduit.Internal (Pipe, ConduitM) import Control.Monad.Logger (LoggingT) import Control.Monad.Trans.Identity ( IdentityT) import Control.Monad.Trans.List ( ListT ) import Control.Monad.Trans.Maybe ( MaybeT ) import Control.Monad.Trans.Error ( ErrorT ) import Control.Monad.Trans.Reader ( ReaderT ) import Control.Monad.Trans.Cont ( ContT ) import Control.Monad.Trans.State ( StateT ) import Control.Monad.Trans.Writer ( WriterT ) import Control.Monad.Trans.RWS ( RWST ) import Control.Monad.Trans.Resource ( ResourceT) import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST ) import qualified Control.Monad.Trans.State.Strict as Strict ( StateT ) import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistEntity class PersistStore m => PersistQuery m where -- | Update individual fields on a specific record. update :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m) => Key val -> [Update val] -> 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 :: (PersistEntity val, PersistMonadBackend m ~ PersistEntityBackend val) => Key val -> [Update val] -> m val updateGet key ups = do update key ups get key >>= maybe (liftIO $ throwIO $ KeyNotFound $ show key) return -- | Update individual fields on any record matching the given criterion. updateWhere :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m) => [Filter val] -> [Update val] -> m () -- | Delete all records matching the given criterion. deleteWhere :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m) => [Filter val] -> m () -- | Get all records matching the given criterion in the specified order. -- Returns also the identifiers. selectSource :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m) => [Filter val] -> [SelectOpt val] -> C.Source m (Entity val) -- | get just the first record for the criterion selectFirst :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m) => [Filter val] -> [SelectOpt val] -> m (Maybe (Entity val)) selectFirst filts opts = selectSource filts ((LimitTo 1):opts) C.$$ CL.head -- | Get the 'Key's of all records matching the given criterion. selectKeys :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m) => [Filter val] -> [SelectOpt val] -> C.Source m (Key val) -- | The total number of records fulfilling the given criterion. count :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m) => [Filter val] -> m Int -- | Call 'selectSource' but return the result as a list. selectList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m) => [Filter val] -> [SelectOpt val] -> m [Entity val] selectList a b = selectSource a b C.$$ CL.consume -- | Call 'selectKeys' but return the result as a list. selectKeysList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m) => [Filter val] -> [SelectOpt val] -> m [Key val] selectKeysList a b = selectKeys a b C.$$ CL.consume #define DEF(T) { update k = lift . update k; updateGet k = lift . updateGet k; updateWhere f = lift . updateWhere f; deleteWhere = lift . deleteWhere; selectSource f = C.transPipe lift . selectSource f; selectFirst f = lift . selectFirst f; selectKeys f = C.transPipe lift . selectKeys f; count = lift . count } #define GO(T) instance (PersistQuery m) => PersistQuery (T m) where DEF(T) #define GOX(X, T) instance (X, PersistQuery m) => PersistQuery (T m) where DEF(T) GO(LoggingT) GO(IdentityT) GO(ListT) GO(MaybeT) GOX(Error e, ErrorT e) GO(ReaderT r) GO(ContT r) GO(StateT s) GO(ResourceT) GO(Pipe l i o u) GO(ConduitM i o) GOX(Monoid w, WriterT w) GOX(Monoid w, RWST r w s) GOX(Monoid w, Strict.RWST r w s) GO(Strict.StateT s) GOX(Monoid w, Strict.WriterT w) #undef DEF #undef GO #undef GOX persistent-1.2.2.0/Database/Persist/Class/PersistConfig.hs0000644000000000000000000000421512166672125021567 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 ((<$>)) 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 <$> 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-1.2.2.0/Database/Persist/Class/PersistField.hs0000644000000000000000000003274212166672125021413 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} #ifndef NO_OVERLAP {-# LANGUAGE OverlappingInstances #-} #endif module Database.Persist.Class.PersistField ( PersistField (..) , SomePersistField (..) , getPersistMap ) where import Database.Persist.Types.Base import Data.Time (Day(..), TimeOfDay, UTCTime) #ifdef HIGH_PRECISION_DATE import Data.Time.Clock.POSIX (posixSecondsToUTCTime) #endif import Data.Time.LocalTime (ZonedTime) import Data.ByteString.Char8 (ByteString, unpack) import Control.Applicative import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word, Word8, Word16, Word32, Word64) import Data.Text (Text) 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.Text.Encoding as TE -- | 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 instance PersistField String where 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 (PersistZonedTime (ZT z)) = Right $ Prelude.show z 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 (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 <$> fromPersistValue x instance PersistField T.Text where toPersistValue = PersistText fromPersistValue = either (Left . T.pack) Right . 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 x = Left $ T.pack $ "Expected Integer, received: " ++ show x instance PersistField Int8 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x instance PersistField Int16 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x instance PersistField Int32 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x instance PersistField Int64 where toPersistValue = PersistInt64 . fromIntegral fromPersistValue (PersistInt64 i) = Right $ fromIntegral i fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x instance PersistField 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 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 $ "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 x = Left $ "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 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 _ -> Left $ T.pack $ "Expected UTCTime, received " ++ show x 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 instance PersistField ZonedTime where toPersistValue = PersistZonedTime . ZT fromPersistValue (PersistZonedTime (ZT z)) = Right z fromPersistValue x@(PersistText t) = case reads $ T.unpack t of (z, _):_ -> Right z _ -> Left $ T.pack $ "Expected ZonedTime, received " ++ show x fromPersistValue x@(PersistByteString s) = case reads $ unpack s of (z, _):_ -> Right z _ -> Left $ T.pack $ "Expected ZonedTime, received " ++ show x fromPersistValue x = Left $ T.pack $ "Expected ZonedTime, received: " ++ show x instance PersistField a => PersistField (Maybe a) where toPersistValue Nothing = PersistNull toPersistValue (Just a) = toPersistValue a fromPersistValue PersistNull = Right Nothing fromPersistValue x = fmap Just $ fromPersistValue x instance PersistField a => PersistField [a] where toPersistValue = PersistList . map 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 (Ord a, PersistField a) => PersistField (S.Set a) where toPersistValue = PersistList . map toPersistValue . S.toList fromPersistValue (PersistList list) = either Left (Right . S.fromList) $ fromPersistList list fromPersistValue (PersistText t) = fromPersistValue (PersistByteString $ TE.encodeUtf8 t) fromPersistValue (PersistByteString bs) | Just values <- A.decode' (L.fromChunks [bs]) = either Left (Right . S.fromList) $ fromPersistList values fromPersistValue x = Left $ 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 (PersistList (vx:vy:[])) = case (fromPersistValue vx, fromPersistValue vy) of (Right x, Right y) -> Right (x, y) (Left e, _) -> Left e (_, Left e) -> Left e fromPersistValue x = Left $ T.pack $ "Expected 2 item PersistList, received: " ++ show x instance PersistField v => PersistField (M.Map T.Text v) where toPersistValue = PersistMap . map (\(k,v) -> (k, toPersistValue v)) . M.toList fromPersistValue = fromPersistMap <=< getPersistMap instance PersistField PersistValue where toPersistValue = id fromPersistValue = Right deriving instance PersistField (KeyBackend backend entity) 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 kvs = case ( foldl (\eithAssocs (k,v) -> case (eithAssocs, fromPersistValue v) of (Left e, _) -> Left e (_, Left e) -> Left e (Right assocs, Right v') -> Right ((k,v'):assocs) ) (Right []) kvs ) of Right vs -> Right $ M.fromList vs Left e -> Left e 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 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 (PersistBool False) = Left $ T.pack "PersistField Checkmark: found unexpected FALSE value" fromPersistValue other = Left $ T.pack $ "PersistField Checkmark: unknown value " ++ show other persistent-1.2.2.0/Database/Persist/Class/DeleteCascade.hs0000644000000000000000000000130512166672125021453 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 class (PersistStore m, PersistEntity a, PersistEntityBackend a ~ PersistMonadBackend m) => DeleteCascade a m where deleteCascade :: Key a -> m () deleteCascadeWhere :: (DeleteCascade a m, PersistQuery m) => [Filter a] -> m () deleteCascadeWhere filts = selectKeys filts [] C.$$ CL.mapM_ deleteCascade persistent-1.2.2.0/Database/Persist/Types/0000755000000000000000000000000012166672125016511 5ustar0000000000000000persistent-1.2.2.0/Database/Persist/Types/Base.hs0000644000000000000000000003141712166672125017725 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE DeriveDataTypeable #-} module Database.Persist.Types.Base where import qualified Data.Aeson as A import Control.Exception (Exception) import Web.PathPieces (PathPiece (..)) import Control.Monad.Trans.Error (Error (..)) import Data.Typeable (Typeable) import Data.Text (Text, pack) import qualified Data.Text as T import qualified Data.Attoparsec.Number as AN 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 Data.Time (Day, TimeOfDay, UTCTime) import Data.Int (Int64) import qualified Data.Text.Read 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.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone) import Data.Map (Map) import qualified Data.HashMap.Strict as HM import Data.Word (Word32) import Numeric (showHex, readHex) -- | 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 PathPiece Checkmark where toPathPiece = pack . show fromPathPiece txt = case reads (T.unpack txt) of [(a, "")] -> Just a _ -> 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 sqlType = EntityDef { entityHaskell :: !HaskellName , entityDB :: !DBName , entityID :: !DBName , entityAttrs :: ![Attr] , entityFields :: ![FieldDef sqlType] , entityUniques :: ![UniqueDef] , entityDerives :: ![Text] , entityExtra :: !(Map Text [ExtraLine]) , entitySum :: !Bool } deriving (Show, Eq, Read, Ord, Functor) 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 sqlType = 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 , fieldEmbedded :: Maybe (EntityDef ()) -- ^ indicates that the field uses an embedded entity } deriving (Show, Eq, Read, Ord, Functor) data UniqueDef = UniqueDef { uniqueHaskell :: !HaskellName , uniqueDBName :: !DBName , uniqueFields :: ![(HaskellName, DBName)] , uniqueAttrs :: ![Attr] } 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 -- | Avoid orphan instances. newtype ZT = ZT ZonedTime deriving (Show, Read, Typeable) instance Eq ZT where ZT a /= ZT b = zonedTimeToLocalTime a /= zonedTimeToLocalTime b || zonedTimeZone a /= zonedTimeZone b instance Ord ZT where ZT a `compare` ZT b = zonedTimeToUTC a `compare` zonedTimeToUTC b -- | 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 | PersistZonedTime ZT | PersistNull | PersistList [PersistValue] | PersistMap [(Text, PersistValue)] | PersistObjectId ByteString -- ^ intended especially for MongoDB backend deriving (Show, Read, Eq, Typeable, Ord) instance PathPiece PersistValue where fromPathPiece t = case Data.Text.Read.signed Data.Text.Read.decimal t of Right (i, t') | T.null t' -> Just $ PersistInt64 i _ -> Just $ PersistText t toPathPiece x = case fromPersistValueText x of Left e -> error e Right y -> y fromPersistValueText :: PersistValue -> Either String 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 (PersistZonedTime (ZT z)) = Right $ T.pack $ show z 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" instance A.ToJSON PersistValue where toJSON (PersistText t) = A.String $ T.cons 's' t toJSON (PersistByteString b) = A.String $ T.cons 'b' $ TE.decodeUtf8 $ B64.encode b toJSON (PersistInt64 i) = A.Number $ fromIntegral i toJSON (PersistDouble d) = A.Number $ AN.D d toJSON (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 (PersistZonedTime z) = A.String $ T.pack $ 'z' : show z 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 (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 ('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 ('z', t) -> fmap PersistZonedTime $ 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 #-} parseJSON (A.Number (AN.I i)) = return $ PersistInt64 $ fromInteger i parseJSON (A.Number (AN.D d)) = return $ PersistDouble d parseJSON (A.Bool b) = return $ PersistBool b parseJSON A.Null = return $ PersistNull parseJSON (A.Array a) = fmap PersistList (mapM A.parseJSON $ V.toList a) parseJSON (A.Object o) = fmap PersistMap $ mapM go $ HM.toList o where go (k, v) = fmap ((,) k) $ A.parseJSON v -- | A SQL data type. Naming attempts to reflect the underlying Haskell -- datatypes, eg SqlString instead of SqlVarchar. Different SQL databases may -- have different translations for these types. data SqlType = SqlString | SqlInt32 | SqlInt64 | SqlReal | SqlNumeric Word32 Word32 | SqlBool | SqlDay | SqlTime | SqlDayTime | SqlDayTimeZoned | SqlBlob | SqlOther T.Text -- ^ a backend-specific name deriving (Show, Read, Eq, Typeable, Ord) newtype KeyBackend backend entity = Key { unKey :: PersistValue } deriving (Show, Read, Eq, Ord) type family KeyEntity key type instance KeyEntity (KeyBackend backend entity) = entity instance A.ToJSON (KeyBackend backend entity) where toJSON (Key val) = A.toJSON val instance A.FromJSON (KeyBackend backend entity) where parseJSON = fmap Key . A.parseJSON data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le | In | NotIn | BackendSpecificFilter T.Text deriving (Read, Show) data UpdateGetException = KeyNotFound String deriving Typeable instance Show UpdateGetException where show (KeyNotFound key) = "Key not found during updateGet: " ++ key instance Exception UpdateGetException data PersistUpdate = Assign | Add | Subtract | Multiply | Divide -- FIXME need something else here deriving (Read, Show, Enum, Bounded) persistent-1.2.2.0/Database/Persist/Sql/0000755000000000000000000000000012166672125016144 5ustar0000000000000000persistent-1.2.2.0/Database/Persist/Sql/Types.hs0000644000000000000000000001550112166672125017606 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} module Database.Persist.Sql.Types where import Control.Exception (Exception) import Control.Monad.Trans.Resource (MonadResource (..), MonadThrow (..), ResourceT) import Control.Monad.Logger (MonadLogger (..), NoLoggingT) import Control.Monad.Trans.Control import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Reader (ReaderT (..)) import Control.Applicative (Applicative (..)) import Control.Monad.Trans.Writer (WriterT) import Control.Monad.Base (MonadBase (..)) import Control.Monad (MonadPlus (..)) import Data.Typeable (Typeable) import Control.Monad (liftM) import Database.Persist.Types import Data.Text (Text, pack) import qualified Data.Text as T import Data.IORef (IORef) import Data.Map (Map) import Data.Int (Int64) import Data.Conduit (Source) import Data.Conduit.Pool (Pool) import Web.PathPieces import Control.Exception (throw) import qualified Data.Text.Read data InsertSqlResult = ISRSingle Text | ISRInsertGet Text Text data Connection = Connection { connPrepare :: Text -> IO Statement -- | table name, column names, id name, either 1 or 2 statements to run , connInsertSql :: DBName -> [DBName] -> DBName -> InsertSqlResult , connStmtMap :: IORef (Map Text Statement) , connClose :: IO () , connMigrateSql :: [EntityDef SqlType] -> (Text -> IO Statement) -> EntityDef SqlType -> 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 } data Statement = Statement { stmtFinalize :: IO () , stmtReset :: IO () , stmtExecute :: [PersistValue] -> IO Int64 , stmtQuery :: forall m. MonadResource m => [PersistValue] -> Source m [PersistValue] } data Column = Column { cName :: !DBName , cNull :: !Bool , cSqlType :: !SqlType , cDefault :: !(Maybe Text) , 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 data SqlBackend newtype SqlPersistT m a = SqlPersistT { unSqlPersistT :: ReaderT Connection m a } deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadPlus) type SqlPersist = SqlPersistT {-# DEPRECATED SqlPersist "Please use SqlPersistT instead" #-} type SqlPersistM = SqlPersistT (NoLoggingT (ResourceT IO)) instance MonadThrow m => MonadThrow (SqlPersistT m) where monadThrow = lift . monadThrow instance MonadBase backend m => MonadBase backend (SqlPersistT m) where liftBase = lift . liftBase instance MonadBaseControl backend m => MonadBaseControl backend (SqlPersistT m) where newtype StM (SqlPersistT m) a = StMSP {unStMSP :: ComposeSt SqlPersistT m a} liftBaseWith = defaultLiftBaseWith StMSP restoreM = defaultRestoreM unStMSP instance MonadTransControl SqlPersistT where newtype StT SqlPersistT a = StReader {unStReader :: a} liftWith f = SqlPersistT $ ReaderT $ \r -> f $ \t -> liftM StReader $ runReaderT (unSqlPersistT t) r restoreT = SqlPersistT . ReaderT . const . liftM unStReader instance MonadResource m => MonadResource (SqlPersistT m) where liftResourceT = lift . liftResourceT instance MonadLogger m => MonadLogger (SqlPersistT m) where monadLoggerLog a b c = lift . monadLoggerLog a b c type Sql = Text -- Bool indicates if the Sql is safe type CautiousMigration = [(Bool, Sql)] type Migration m = WriterT [Text] (WriterT CautiousMigration m) () type ConnectionPool = Pool Connection instance PathPiece (KeyBackend SqlBackend entity) where toPathPiece (Key (PersistInt64 i)) = toPathPiece i toPathPiece k = throw $ PersistInvalidField $ pack $ "Invalid Key: " ++ show k fromPathPiece t = case Data.Text.Read.signed Data.Text.Read.decimal t of Right (i, t') | T.null t' -> Just $ Key $ PersistInt64 i _ -> Nothing -- $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 you could use 'R.withStmt', which -- allows you to do anything you need. However, its API is -- /low-level/ and you need to parse each row yourself. However, -- most of your complex queries will have simple results -- some -- of your entities and maybe a couple of derived columns. -- -- This is where 'rawSql' comes in. Like 'R.withStmt', you may -- issue /any/ SQL query. However, it does all the hard work for -- you and automatically parses 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-1.2.2.0/Database/Persist/Sql/Internal.hs0000644000000000000000000000477212166672125020266 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} -- | Intended for creating new backends. module Database.Persist.Sql.Internal ( mkColumns ) 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 (Monoid, mappend, mconcat) import Data.Maybe (mapMaybe, listToMaybe) import Database.Persist.Sql.Types -- | Create the list of columns for the given entity. mkColumns :: [EntityDef a] -> EntityDef SqlType -> ([Column], [UniqueDef]) mkColumns allDefs t = (cols, entityUniques t) where cols :: [Column] cols = map go (entityFields t) tn :: DBName tn = entityDB t go :: FieldDef SqlType -> Column go fd = Column (fieldDB fd) (nullable (fieldAttrs fd) /= NotNullable || entitySum t) (maybe (fieldSqlType fd) SqlOther (listToMaybe $ mapMaybe (T.stripPrefix "sqltype=") $ fieldAttrs fd)) (def $ fieldAttrs fd) (maxLen $ fieldAttrs fd) (ref (fieldDB fd) (fieldType fd) (fieldAttrs fd)) def :: [Attr] -> Maybe Text def [] = Nothing def (a:as) | Just d <- T.stripPrefix "default=" a = Just d | otherwise = def as maxLen :: [Attr] -> Maybe Integer maxLen [] = Nothing maxLen (a:as) | Just d <- T.stripPrefix "maxlen=" a = case reads (T.unpack d) of [(i, s)] | all isSpace s -> Just i _ -> error $ "Could not parse maxlen field with value " ++ show d ++ " on " ++ show tn | otherwise = maxLen as ref :: DBName -> FieldType -> [Attr] -> Maybe (DBName, DBName) -- table name, constraint name ref c ft [] | Just f <- stripId ft = Just (resolveTableName allDefs $ HaskellName 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 $ mconcat [table, "_", column, "_fkey"] resolveTableName :: [EntityDef a] -> HaskellName -> DBName resolveTableName [] (HaskellName hn) = error $ "Table not found: " `mappend` T.unpack hn resolveTableName (e:es) hn | entityHaskell e == hn = entityDB e | otherwise = resolveTableName es hn persistent-1.2.2.0/Database/Persist/Sql/Class.hs0000644000000000000000000002646712166672125017564 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} #ifndef NO_OVERLAP {-# LANGUAGE OverlappingInstances #-} #endif module Database.Persist.Sql.Class ( MonadSqlPersist (..) , RawSql (..) , PersistFieldSql (..) ) where import Control.Applicative ((<$>), (<*>)) import Database.Persist import Data.Monoid ((<>)) import Database.Persist.Sql.Types import Control.Arrow ((&&&)) import Data.Text (Text, intercalate, pack) import Data.Maybe (fromMaybe) import Data.Fixed import Data.Monoid (Monoid) import Control.Monad.Trans.Class (lift) import Control.Monad.Logger (LoggingT) import Control.Monad.Trans.Identity ( IdentityT) import Control.Monad.Trans.List ( ListT ) import Control.Monad.Trans.Maybe ( MaybeT ) import Control.Monad.Trans.Error ( ErrorT, Error) import Control.Monad.Trans.Cont ( ContT ) import Control.Monad.Trans.State ( StateT ) import Control.Monad.Trans.Writer ( WriterT ) import Control.Monad.Trans.RWS ( RWST ) import Control.Monad.Trans.Reader ( ReaderT, ask ) import Control.Monad.Trans.Resource ( ResourceT ) import Data.Conduit.Internal (Pipe, ConduitM) import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST ) import qualified Control.Monad.Trans.State.Strict as Strict ( StateT ) import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (MonadTrans) import Control.Monad.Logger (MonadLogger) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Map as M import qualified Data.Set as S import Data.Time (ZonedTime, UTCTime, TimeOfDay, Day) import Data.Int import Data.Word import Data.ByteString (ByteString) import Text.Blaze.Html (Html) import Data.Bits (bitSize) class (MonadIO m, MonadLogger m) => MonadSqlPersist m where askSqlConn :: m Connection default askSqlConn :: (MonadSqlPersist m, MonadTrans t, MonadLogger (t m)) => t m Connection askSqlConn = lift askSqlConn instance (MonadIO m, MonadLogger m) => MonadSqlPersist (SqlPersistT m) where askSqlConn = SqlPersistT ask #define GO(T) instance (MonadSqlPersist m) => MonadSqlPersist (T m) #define GOX(X, T) instance (X, MonadSqlPersist m) => MonadSqlPersist (T m) GO(LoggingT) GO(IdentityT) GO(ListT) GO(MaybeT) GOX(Error e, ErrorT e) GO(ReaderT r) GO(ContT r) GO(StateT s) GO(ResourceT) GO(Pipe l i o u) GO(ConduitM i o) GOX(Monoid w, WriterT w) GOX(Monoid w, RWST r w s) GOX(Monoid w, Strict.RWST r w s) GO(Strict.StateT s) GOX(Monoid w, Strict.WriterT w) #undef GO #undef GOX -- | 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 <$> fromPersistValue pv rawSqlProcessRow _ = Left $ pack "RawSql (Single a): wrong number of columns." instance PersistEntity a => RawSql (Entity a) where rawSqlCols escape = ((+1) . length . entityFields &&& process) . entityDef . Just . entityVal where process ed = (:[]) $ intercalate ", " $ map ((name ed <>) . escape) $ (entityID ed:) $ map fieldDB $ entityFields ed name ed = escape (entityDB ed) <> "." 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 (idCol:ent) = Entity <$> fromPersistValue idCol <*> fromPersistValues ent rawSqlProcessRow _ = Left "RawSql (Entity a): wrong number of columns." -- | 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 :: Monad m => m a -> SqlType #ifndef NO_OVERLAP instance PersistFieldSql String where 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 _ | bitSize (0 :: Int) <= 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 instance PersistFieldSql ZonedTime where sqlType _ = SqlDayTimeZoned instance PersistFieldSql a => PersistFieldSql [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 (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 22 12 -- FIXME: Ambigous, 12 is from Pico which is used to convert Rational to number string persistent-1.2.2.0/Database/Persist/Sql/Raw.hs0000644000000000000000000001365112166672125017237 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} 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 (liftIO) import Data.IORef (writeIORef, readIORef, newIORef) import Control.Exception (throwIO) import Control.Monad (when, liftM) import Data.Text (Text, pack) import Control.Monad.Logger (logDebugS) import Data.Int (Int64) import Control.Monad.Trans.Class (lift) import qualified Data.Text as T import Data.Conduit rawQuery :: (MonadSqlPersist m, MonadResource m) => Text -> [PersistValue] -> Source m [PersistValue] rawQuery sql vals = do lift $ $logDebugS (pack "SQL") $ pack $ show sql ++ " " ++ show vals conn <- lift askSqlConn bracketP (getStmtConn conn sql) stmtReset (flip stmtQuery vals) rawExecute :: MonadSqlPersist m => Text -> [PersistValue] -> m () rawExecute x y = liftM (const ()) $ rawExecuteCount x y rawExecuteCount :: MonadSqlPersist m => Text -> [PersistValue] -> m Int64 rawExecuteCount sql vals = do $logDebugS (pack "SQL") $ pack $ show sql ++ " " ++ show vals stmt <- getStmt sql res <- liftIO $ stmtExecute stmt vals liftIO $ stmtReset stmt return res getStmt :: MonadSqlPersist m => Text -> m Statement getStmt sql = do conn <- askSqlConn liftIO $ getStmtConn conn sql getStmtConn :: Connection -> 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'. rawSql :: (RawSql a, MonadSqlPersist m, MonadResource m) => Text -- ^ SQL statement, possibly with placeholders. -> [PersistValue] -- ^ Values to fill the placeholders. -> m [a] rawSql stmt = run where getType :: (x -> m [a]) -> a getType = error "rawSql.getType" x = getType run process = rawSqlProcessRow withStmt' colSubsts params = do rawQuery sql params 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 <- askSqlConn 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-1.2.2.0/Database/Persist/Sql/Run.hs0000644000000000000000000000423612166672125017251 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module Database.Persist.Sql.Run where import Database.Persist.Sql.Types import Database.Persist.Sql.Raw import Data.Conduit.Pool import Control.Monad.Trans.Reader import Control.Monad.Trans.Resource import Control.Monad.Logger import Control.Monad.Base import Control.Exception.Lifted (onException) import Control.Monad.IO.Class import Control.Exception.Lifted (bracket) import Data.IORef (readIORef) import qualified Data.Map as Map import Control.Exception.Lifted (throwIO) -- | Get a connection from the pool, run the given action, and then return the -- connection to the pool. runSqlPool :: MonadBaseControl IO m => SqlPersistT m a -> Pool Connection -> m a runSqlPool r pconn = do mres <- withResourceTimeout 2000000 pconn $ runSqlConn r maybe (throwIO Couldn'tGetSQLConnection) return mres runSqlConn :: MonadBaseControl IO m => SqlPersistT m a -> Connection -> m a runSqlConn (SqlPersistT r) conn = do let getter = getStmtConn conn liftBase $ connBegin conn getter x <- onException (runReaderT r conn) (liftBase $ connRollback conn getter) liftBase $ connCommit conn getter return x runSqlPersistM :: SqlPersistM a -> Connection -> IO a runSqlPersistM x conn = runResourceT $ runNoLoggingT $ runSqlConn x conn runSqlPersistMPool :: SqlPersistM a -> Pool Connection -> IO a runSqlPersistMPool x pool = runResourceT $ runNoLoggingT $ runSqlPool x pool withSqlPool :: MonadIO m => IO Connection -- ^ create a new connection -> Int -- ^ connection count -> (Pool Connection -> m a) -> m a withSqlPool mkConn connCount f = do pool <- createSqlPool mkConn connCount f pool createSqlPool :: MonadIO m => IO Connection -> Int -> m (Pool Connection) createSqlPool mkConn = liftIO . createPool mkConn close' 1 20 withSqlConn :: (MonadIO m, MonadBaseControl IO m) => IO Connection -> (Connection -> m a) -> m a withSqlConn open = bracket (liftIO open) (liftIO . close') close' :: Connection -> IO () close' conn = do readIORef (connStmtMap conn) >>= mapM_ stmtFinalize . Map.elems connClose conn persistent-1.2.2.0/Database/Persist/Sql/Migration.hs0000644000000000000000000000736012166672125020437 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} module Database.Persist.Sql.Migration ( parseMigration , parseMigration' , printMigration , 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 (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.Class import Database.Persist.Sql.Raw import Database.Persist.Types allSql :: CautiousMigration -> [Sql] allSql = map snd unsafeSql :: CautiousMigration -> [Sql] unsafeSql = allSql . filter fst safeSql :: CautiousMigration -> [Sql] safeSql = allSql . filter (not . fst) parseMigration :: Monad m => Migration m -> m (Either [Text] CautiousMigration) parseMigration = liftM go . runWriterT . execWriterT where go ([], sql) = Right sql go (errs, _) = Left errs -- like parseMigration, but call error or return the CautiousMigration parseMigration' :: Monad m => Migration m -> m (CautiousMigration) parseMigration' m = do x <- parseMigration m case x of Left errs -> error $ unlines $ map unpack errs Right sql -> return sql printMigration :: MonadIO m => Migration m -> m () printMigration m = do mig <- parseMigration' m mapM_ (liftIO . Data.Text.IO.putStrLn . flip snoc ';') (allSql mig) getMigration :: (MonadBaseControl IO m, MonadIO m) => Migration m -> m [Sql] getMigration m = do mig <- parseMigration' m return $ allSql mig runMigration :: MonadSqlPersist m => Migration m -> 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, MonadSqlPersist m) => Migration m -> m [Text] runMigrationSilent m = liftBaseOp_ (hSilence [stderr]) $ runMigration' m True runMigration' :: MonadSqlPersist m => Migration m -> Bool -- ^ is silent? -> m [Text] runMigration' m silent = do mig <- parseMigration' m case unsafeSql mig of [] -> mapM (executeMigrate silent) $ sortMigrations $ safeSql mig errs -> error $ concat [ "\n\nDatabase migration: manual intervention required.\n" , "The following actions are considered unsafe:\n\n" , unlines $ map (\s -> " " ++ unpack s ++ ";") $ errs ] runMigrationUnsafe :: MonadSqlPersist m => Migration m -> m () runMigrationUnsafe m = do mig <- parseMigration' m mapM_ (executeMigrate False) $ sortMigrations $ allSql mig executeMigrate :: MonadSqlPersist m => Bool -> Text -> 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 migrate :: MonadSqlPersist m => [EntityDef SqlType] -> EntityDef SqlType -> Migration m migrate allDefs val = do conn <- askSqlConn res <- liftIO $ connMigrateSql conn allDefs (getStmtConn conn) val either tell (lift . tell) res persistent-1.2.2.0/Database/Persist/Sql/Orphan/0000755000000000000000000000000012166672125017373 5ustar0000000000000000persistent-1.2.2.0/Database/Persist/Sql/Orphan/PersistStore.hs0000644000000000000000000001040412166672125022374 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Sql.Orphan.PersistStore () where import Database.Persist import Database.Persist.Sql.Types import Database.Persist.Sql.Class import Database.Persist.Sql.Raw import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import Control.Monad.Logger import qualified Data.Text as T import Data.Text (Text, unpack) import Data.Monoid (mappend) import Control.Monad.IO.Class instance (C.MonadResource m, MonadLogger m) => PersistStore (SqlPersistT m) where type PersistMonadBackend (SqlPersistT m) = SqlBackend insert val = do conn <- askSqlConn let esql = connInsertSql conn (entityDB t) (map fieldDB $ entityFields t) (entityID t) i <- case esql of ISRSingle sql -> rawQuery sql vals C.$$ do x <- CL.head case x of Just [PersistInt64 i] -> return i Nothing -> error $ "SQL insert did not return a result giving the generated ID" Just vals' -> error $ "Invalid result from a SQL insert, got: " ++ show vals' ISRInsertGet sql1 sql2 -> do rawExecute sql1 vals rawQuery sql2 [] C.$$ do Just [PersistInt64 i] <- CL.head return i return $ Key $ PersistInt64 i where t = entityDef $ Just val vals = map toPersistValue $ toPersistFields val replace k val = do conn <- askSqlConn let t = entityDef $ Just val let sql = T.concat [ "UPDATE " , connEscapeName conn (entityDB t) , " SET " , T.intercalate "," (map (go conn . fieldDB) $ entityFields t) , " WHERE " , connEscapeName conn $ entityID t , "=?" ] vals = map toPersistValue (toPersistFields val) `mappend` [unKey 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 get k = do conn <- askSqlConn let t = entityDef $ dummyFromKey k let cols = T.intercalate "," $ map (connEscapeName conn . fieldDB) $ entityFields t let sql = T.concat [ "SELECT " , cols , " FROM " , connEscapeName conn $ entityDB t , " WHERE " , connEscapeName conn $ entityID t , "=?" ] vals' = [unKey k] rawQuery sql vals' C.$$ do res <- CL.head case res of Nothing -> return Nothing Just vals -> case fromPersistValues vals of Left e -> error $ "get " ++ show (unKey k) ++ ": " ++ unpack e Right v -> return $ Just v delete k = do conn <- askSqlConn rawExecute (sql conn) [unKey k] where t = entityDef $ dummyFromKey k sql conn = T.concat [ "DELETE FROM " , connEscapeName conn $ entityDB t , " WHERE " , connEscapeName conn $ entityID t , "=?" ] dummyFromKey :: KeyBackend SqlBackend v -> Maybe v dummyFromKey _ = Nothing insrepHelper :: (MonadIO m, PersistEntity val, MonadLogger m, MonadSqlPersist m) => Text -> Key val -> val -> m () insrepHelper command (Key k) val = do conn <- askSqlConn rawExecute (sql conn) vals where t = entityDef $ Just val sql conn = T.concat [ command , " INTO " , connEscapeName conn (entityDB t) , "(" , T.intercalate "," $ map (connEscapeName conn) $ entityID t : map fieldDB (entityFields t) , ") VALUES(" , T.intercalate "," ("?" : map (const "?") (entityFields t)) , ")" ] vals = k : map toPersistValue (toPersistFields val) persistent-1.2.2.0/Database/Persist/Sql/Orphan/PersistUnique.hs0000644000000000000000000000437212166672125022555 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Sql.Orphan.PersistUnique () where import Database.Persist import Database.Persist.Sql.Types import Database.Persist.Sql.Class import Database.Persist.Sql.Raw import Database.Persist.Sql.Orphan.PersistStore () import qualified Data.Text as T import Data.Monoid ((<>)) import Control.Monad.Logger import qualified Data.Conduit.List as CL import Data.Conduit instance (MonadResource m, MonadLogger m) => PersistUnique (SqlPersistT m) where deleteBy uniq = do conn <- askSqlConn 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 <> "=?" sql conn = T.concat [ "DELETE FROM " , connEscapeName conn $ entityDB t , " WHERE " , T.intercalate " AND " $ map (go' conn) $ go uniq ] getBy uniq = do conn <- askSqlConn let cols = T.intercalate "," $ (connEscapeName conn $ entityID t) : map (connEscapeName conn . fieldDB) (entityFields t) let sql = T.concat [ "SELECT " , cols , " FROM " , connEscapeName conn $ entityDB t , " WHERE " , sqlClause conn ] vals' = persistUniqueToValues uniq rawQuery sql vals' $$ do row <- CL.head case row of Nothing -> return Nothing Just (PersistInt64 k:vals) -> case fromPersistValues vals of Left s -> error $ T.unpack s Right x -> return $ Just (Entity (Key $ PersistInt64 k) x) Just _ -> error "Database.Persist.GenericSql: Bad list in getBy" where sqlClause conn = T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq go conn x = connEscapeName conn x <> "=?" t = entityDef $ dummyFromUnique uniq toFieldNames' = map snd . persistUniqueToFieldNames dummyFromUnique :: Unique v -> Maybe v dummyFromUnique _ = Nothing persistent-1.2.2.0/Database/Persist/Sql/Orphan/PersistQuery.hs0000644000000000000000000003026412166672125022413 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Sql.Orphan.PersistQuery ( deleteWhereCount , updateWhereCount ) where import Database.Persist import Database.Persist.Sql.Types import Database.Persist.Sql.Class import Database.Persist.Sql.Raw import Database.Persist.Sql.Orphan.PersistStore () import qualified Data.Text as T import Data.Text (Text) import Data.Monoid (Monoid (..), (<>)) import Data.Int (Int64) import Control.Monad.Logger import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Exception (throwIO) import qualified Data.Conduit.List as CL import Data.Conduit -- orphaned instance for convenience of modularity instance (MonadResource m, MonadLogger m) => PersistQuery (SqlPersistT m) where update _ [] = return () update k upds = do conn <- askSqlConn 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, "/?"] let go' (x, pu) = go'' (connEscapeName conn x) pu let sql = T.concat [ "UPDATE " , connEscapeName conn $ entityDB t , " SET " , T.intercalate "," $ map (go' . go) upds , " WHERE " , connEscapeName conn $ entityID t , "=?" ] rawExecute sql $ map updatePersistValue upds `mappend` [unKey k] where t = entityDef $ dummyFromKey k go x = (fieldDB $ updateFieldDef x, updateUpdate x) count filts = do conn <- askSqlConn let wher = if null filts then "" else filterClause False conn filts let sql = mconcat [ "SELECT COUNT(*) FROM " , connEscapeName conn $ entityDB t , wher ] rawQuery sql (getFiltsValues conn filts) $$ do Just [PersistInt64 i] <- CL.head return $ fromIntegral i where t = entityDef $ dummyFromFilts filts selectSource filts opts = do conn <- lift askSqlConn rawQuery (sql conn) (getFiltsValues conn filts) $= CL.mapM parse where (limit, offset, orders) = limitOffsetOrder opts parse vals = case fromPersistValues' vals of Left s -> liftIO $ throwIO $ PersistMarshalError s Right row -> return row t = entityDef $ dummyFromFilts filts fromPersistValues' (PersistInt64 x:xs) = do case fromPersistValues xs of Left e -> Left e Right xs' -> Right (Entity (Key $ PersistInt64 x) xs') fromPersistValues' _ = Left "error in fromPersistValues'" 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 lim conn = case (limit, offset) of (0, 0) -> "" (0, _) -> T.cons ' ' $ connNoLimit conn (_, _) -> " LIMIT " <> T.pack (show limit) off = if offset == 0 then "" else " OFFSET " <> T.pack (show offset) cols conn = T.intercalate "," $ (connEscapeName conn $ entityID t) : map (connEscapeName conn . fieldDB) (entityFields t) sql conn = mconcat [ "SELECT " , cols conn , " FROM " , connEscapeName conn $ entityDB t , wher conn , ord conn , lim conn , off ] selectKeys filts opts = do conn <- lift askSqlConn rawQuery (sql conn) (getFiltsValues conn filts) $= CL.mapM parse where parse [PersistInt64 i] = return $ Key $ PersistInt64 i parse y = liftIO $ throwIO $ PersistMarshalError $ "Unexpected in selectKeys: " <> T.pack (show y) t = entityDef $ dummyFromFilts filts wher conn = if null filts then "" else filterClause False conn filts sql conn = mconcat [ "SELECT " , connEscapeName conn $ entityID t , " FROM " , connEscapeName conn $ entityDB t , wher conn , ord conn , lim conn , off ] (limit, offset, orders) = limitOffsetOrder opts ord conn = case map (orderClause False conn) orders of [] -> "" ords -> " ORDER BY " <> T.intercalate "," ords lim conn = case (limit, offset) of (0, 0) -> "" (0, _) -> T.cons ' ' $ connNoLimit conn (_, _) -> " LIMIT " <> T.pack (show limit) off = if offset == 0 then "" else " OFFSET " <> T.pack (show offset) deleteWhere filts = do _ <- deleteWhereCount filts return () updateWhere filts upds = do _ <- updateWhereCount filts upds return () -- | Same as 'deleteWhere', but returns the number of rows affected. -- -- Since 1.1.5 deleteWhereCount :: (PersistEntity val, MonadSqlPersist m) => [Filter val] -> m Int64 deleteWhereCount filts = do conn <- askSqlConn 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, MonadSqlPersist m) => [Filter val] -> [Update val] -> m Int64 updateWhereCount _ [] = return 0 updateWhereCount filts upds = do conn <- askSqlConn 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 `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' conn (x, pu) = go'' (connEscapeName conn x) pu go x = (fieldDB $ updateFieldDef x, updateUpdate x) updateFieldDef :: PersistEntity v => Update v -> FieldDef SqlType updateFieldDef (Update f _ _) = persistFieldDef f dummyFromFilts :: [Filter v] -> Maybe v dummyFromFilts _ = Nothing getFiltsValues :: forall val. PersistEntity val => Connection -> [Filter val] -> [PersistValue] getFiltsValues conn = snd . filterClauseHelper False False conn OrNullNo data OrNull = OrNullYes | OrNullNo filterClauseHelper :: PersistEntity val => Bool -- ^ include table name? -> Bool -- ^ include WHERE? -> Connection -> 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) = case (isNull, pfilter, varCount) 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) (_, NotIn, 0) -> ("1=1", []) (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 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 $ fieldDB $ persistFieldDef field qmarks = case value of Left _ -> "?" Right x -> let x' = filter (/= PersistNull) $ map toPersistValue x in "(" <> T.intercalate "," (map (const "?") x') <> ")" varCount = case value of Left _ -> 1 Right x -> length 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 filterClause :: PersistEntity val => Bool -- ^ include table name? -> Connection -> [Filter val] -> Text filterClause b c = fst . filterClauseHelper b True c OrNullNo orderClause :: PersistEntity val => Bool -- ^ include the table name -> Connection -> SelectOpt val -> Text orderClause includeTable conn o = case o of Asc x -> name $ persistFieldDef x Desc x -> name (persistFieldDef x) <> " DESC" _ -> 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 x = (if includeTable then ((tn <> ".") <>) else id) $ connEscapeName conn $ fieldDB x dummyFromKey :: KeyBackend SqlBackend v -> Maybe v dummyFromKey _ = Nothing