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