diff --git a/Database/Persist.hs b/Database/Persist.hs --- a/Database/Persist.hs +++ b/Database/Persist.hs @@ -5,18 +5,6 @@ ( module Database.Persist.Class , module Database.Persist.Types - -- * Store functions - , insertBy - , getJust - , belongsTo - , belongsToJust - , getByValue - - -- * Query functions - , selectList - , selectKeysList - , deleteCascadeWhere - -- * query combinators , (=.), (+=.), (-=.), (*=.), (/=.) , (==.), (!=.), (<.), (>.), (<=.), (>=.) @@ -36,75 +24,11 @@ import Database.Persist.Class import Database.Persist.Class.PersistField (getPersistMap) import qualified Data.Text as T -import qualified Control.Exception as E -import Control.Monad (liftM) -import Control.Monad.IO.Class (MonadIO, liftIO) -import qualified Data.Conduit as C -import qualified Data.Conduit.List as CL import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder (toLazyText) import Data.Aeson (toJSON) import Data.Aeson.Encode (fromValue) --- | Insert a value, checking for conflicts with any unique constraints. If a --- duplicate exists in the database, it is returned as 'Left'. Otherwise, the --- new 'Key is returned as 'Right'. -insertBy :: (PersistEntity v, PersistStore m, PersistUnique m, PersistMonadBackend m ~ PersistEntityBackend v) - => v -> m (Either (Entity v) (Key v)) -insertBy val = - go $ persistUniqueKeys val - where - go [] = Right `liftM` insert val - go (x:xs) = do - y <- getBy x - case y of - Nothing -> go xs - Just z -> return $ Left z - --- | A modification of 'getBy', which takes the 'PersistEntity' itself instead --- of a 'Unique' value. Returns a value matching /one/ of the unique keys. This --- function makes the most sense on entities with a single 'Unique' --- constructor. -getByValue :: (PersistEntity v, PersistUnique m, PersistEntityBackend v ~ PersistMonadBackend m) - => v -> m (Maybe (Entity v)) -getByValue val = - go $ persistUniqueKeys val - where - go [] = return Nothing - go (x:xs) = do - y <- getBy x - case y of - Nothing -> go xs - Just z -> return $ Just z - --- | curry this to make a convenience function that loads an associated model --- > foreign = belongsTo foeignId -belongsTo :: - (PersistStore m - , PersistEntity ent1 - , PersistEntity ent2 - , PersistMonadBackend m ~ PersistEntityBackend ent2 - ) => (ent1 -> Maybe (Key ent2)) -> ent1 -> m (Maybe ent2) -belongsTo foreignKeyField model = case foreignKeyField model of - Nothing -> return Nothing - Just f -> get f - --- | same as belongsTo, but uses @getJust@ and therefore is similarly unsafe -belongsToJust :: - (PersistStore m - , PersistEntity ent1 - , PersistEntity ent2 - , PersistMonadBackend m ~ PersistEntityBackend ent2) - => (ent1 -> Key ent2) -> ent1 -> m ent2 -belongsToJust getForeignKey model = getJust $ getForeignKey model - --- | Same as get, but for a non-null (not Maybe) foreign key --- Unsafe unless your database is enforcing that the foreign key is valid -getJust :: (PersistStore m, PersistEntity val, Show (Key val), PersistMonadBackend m ~ PersistEntityBackend val) => Key val -> m val -getJust key = get key >>= maybe - (liftIO $ E.throwIO $ PersistForeignConstraintUnmet $ T.pack $ show key) - return - infixr 3 =., +=., -=., *=., /=. (=.), (+=.), (-=.), (*=.), (/=.) :: forall v typ. PersistField typ => EntityField v typ -> typ -> Update v -- | assign a field a value @@ -139,24 +63,6 @@ (||.) :: forall v. [Filter v] -> [Filter v] -> [Filter v] -- | the OR of two lists of filters a ||. b = [FilterOr [FilterAnd a, FilterAnd b]] - --- | Call 'selectSource' but return the result as a list. -selectList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m) - => [Filter val] - -> [SelectOpt val] - -> m [Entity val] -selectList a b = selectSource a b C.$$ CL.consume - --- | Call 'selectKeys' but return the result as a list. -selectKeysList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m) - => [Filter val] - -> [SelectOpt val] - -> m [Key val] -selectKeysList a b = selectKeys a b C.$$ CL.consume - -deleteCascadeWhere :: (DeleteCascade a m, PersistQuery m) - => [Filter a] -> m () -deleteCascadeWhere filts = selectKeys filts [] C.$$ CL.mapM_ deleteCascade listToJSON :: [PersistValue] -> T.Text listToJSON = toStrict . toLazyText . fromValue . toJSON diff --git a/Database/Persist/Class.hs b/Database/Persist/Class.hs --- a/Database/Persist/Class.hs +++ b/Database/Persist/Class.hs @@ -1,11 +1,36 @@ module Database.Persist.Class - ( DeleteCascade (..) - , PersistEntity (..) - , PersistQuery (..) + ( + -- * PersistStore + PersistStore (..) + , getJust + , belongsTo + , belongsToJust + + -- * PersistUnique , PersistUnique (..) - , PersistConfig (..) + , getByValue + , insertBy + , replaceUnique + + -- * PersistQuery + , PersistQuery (..) + , selectList + , selectKeysList + + -- * DeleteCascade + , DeleteCascade (..) + , deleteCascadeWhere + + -- * PersistEntity + , PersistEntity (..) + -- * PersistField , PersistField (..) - , PersistStore (..) + -- * PersistConfig + , PersistConfig (..) + + -- * JSON utilities + , keyValueEntityToJSON, keyValueEntityFromJSON + , entityIdToJSON, entityIdFromJSON ) where import Database.Persist.Class.DeleteCascade diff --git a/Database/Persist/Class/DeleteCascade.hs b/Database/Persist/Class/DeleteCascade.hs --- a/Database/Persist/Class/DeleteCascade.hs +++ b/Database/Persist/Class/DeleteCascade.hs @@ -2,10 +2,19 @@ {-# LANGUAGE TypeFamilies #-} module Database.Persist.Class.DeleteCascade ( DeleteCascade (..) + , deleteCascadeWhere ) where import Database.Persist.Class.PersistStore +import Database.Persist.Class.PersistQuery import Database.Persist.Class.PersistEntity +import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL + class (PersistStore m, PersistEntity a, PersistEntityBackend a ~ PersistMonadBackend m) => DeleteCascade a m where deleteCascade :: Key a -> m () + +deleteCascadeWhere :: (DeleteCascade a m, PersistQuery m) + => [Filter a] -> m () +deleteCascadeWhere filts = selectKeys filts [] C.$$ CL.mapM_ deleteCascade diff --git a/Database/Persist/Class/PersistEntity.hs b/Database/Persist/Class/PersistEntity.hs --- a/Database/Persist/Class/PersistEntity.hs +++ b/Database/Persist/Class/PersistEntity.hs @@ -10,74 +10,109 @@ , Filter (..) , Key , Entity (..) + + , keyValueEntityToJSON, keyValueEntityFromJSON + , entityIdToJSON, entityIdFromJSON ) where import Database.Persist.Types.Base import Database.Persist.Class.PersistField import Data.Text (Text) +import qualified Data.Text as T import Data.Aeson (ToJSON (..), FromJSON (..), object, (.:), (.=), Value (Object)) +import Data.Aeson.Types (Parser) import Control.Applicative ((<$>), (<*>)) +import Data.Monoid (mappend) +import qualified Data.HashMap.Strict as HM --- | A single database entity. For example, if writing a blog application, a --- blog entry would be an entry, containing fields such as title and content. -class PersistEntity val where - -- | Parameters: val and datatype of the field - data EntityField val :: * -> * - persistFieldDef :: EntityField val typ -> FieldDef SqlType +-- | 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 PersistEntity record where + -- | An 'EntityField' is parameterised by the Haskell record it belongs to + -- and the additional type of that field + data EntityField record :: * -> * - type PersistEntityBackend val + -- | return meta-data for a given 'EntityField' + persistFieldDef :: EntityField record typ -> FieldDef SqlType - -- | Unique keys in existence on this entity. - data Unique val + -- | Persistent allows multiple different backends + type PersistEntityBackend record - entityDef :: Monad m => m val -> EntityDef SqlType - toPersistFields :: val -> [SomePersistField] - fromPersistValues :: [PersistValue] -> Either Text val + -- | Unique keys besided the Key + data Unique record - persistUniqueToFieldNames :: Unique val -> [(HaskellName, DBName)] - persistUniqueToValues :: Unique val -> [PersistValue] - persistUniqueKeys :: val -> [Unique val] + -- | retrieve the EntityDef meta-data for the record + entityDef :: Monad m => m record -> EntityDef SqlType - persistIdField :: EntityField val (Key val) + -- | Get the database fields of a record + toPersistFields :: record -> [SomePersistField] - fieldLens :: EntityField val field - -> (forall f. Functor f => (field -> f field) -> Entity val -> f (Entity val)) + -- | Convert from database values to a Haskell record + fromPersistValues :: [PersistValue] -> Either Text record -data Update v = forall typ. PersistField typ => Update - { updateField :: EntityField v typ + persistUniqueToFieldNames :: Unique record -> [(HaskellName, DBName)] + persistUniqueToValues :: Unique record -> [PersistValue] + persistUniqueKeys :: record -> [Unique record] + + persistIdField :: EntityField record (Key record) + + fieldLens :: EntityField record field + -> (forall f. Functor f => (field -> f field) -> Entity record -> f (Entity record)) + +-- | updataing a database entity +-- +-- Persistent users use combinators to create these +data Update record = forall typ. PersistField typ => Update + { updateField :: EntityField record typ , updateValue :: typ - , updateUpdate :: PersistUpdate -- FIXME Replace with expr down the road + -- FIXME Replace with expr down the road + , updateUpdate :: PersistUpdate } -data SelectOpt v = forall typ. Asc (EntityField v typ) - | forall typ. Desc (EntityField v typ) - | OffsetBy Int - | LimitTo Int +-- | 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 b v +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. -data Filter v = forall typ. PersistField typ => Filter - { filterField :: EntityField v typ +-- +-- 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 v] -- ^ convenient for internal use, not needed for the API - | FilterOr [Filter v] - | BackendFilter (BackendSpecificFilter (PersistEntityBackend v) v) + | FilterAnd [Filter record] -- ^ convenient for internal use, not needed for the API + | FilterOr [Filter record] + | BackendFilter + (BackendSpecificFilter (PersistEntityBackend record) record) -- | Helper wrapper, equivalent to @Key (PersistEntityBackend val) val@. -- -- Since 1.1.0 -type Key val = KeyBackend (PersistEntityBackend val) val +type Key record = KeyBackend (PersistEntityBackend record) record --- | Datatype that represents an entity, with both its key and --- its Haskell representation. +-- | Datatype that represents an entity, with both its 'Key' and +-- its Haskell record representation. -- --- When using the an SQL-based backend (such as SQLite or +-- 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 @@ -109,13 +144,85 @@ , entityVal :: entity } deriving (Eq, Ord, Show, Read) -instance ToJSON e => ToJSON (Entity e) where - toJSON (Entity k v) = object - [ "key" .= k - , "value" .= v - ] -instance FromJSON e => FromJSON (Entity e) where - parseJSON (Object o) = Entity - <$> o .: "key" - <*> o .: "value" - parseJSON _ = fail "FromJSON Entity: not an object" +-- | Predefined @toJSON@. The resulting JSON looks like +-- @{\"key\": 1, \"value\": {\"name\": ...}}@. +-- +-- The typical usage is: +-- +-- @ +-- instance ToJSON User where +-- toJSON = keyValueEntityToJSON +-- @ +keyValueEntityToJSON :: ToJSON e => Entity e -> 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 User where +-- parseJSON = keyValueEntityFromJSON +-- @ +keyValueEntityFromJSON :: FromJSON e => Value -> Parser (Entity e) +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 User where +-- toJSON = entityIdToJSON +-- @ +entityIdToJSON :: ToJSON e => Entity e -> 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 User where +-- parseJSON = entityIdFromJSON +-- @ +entityIdFromJSON :: FromJSON e => Value -> Parser (Entity e) +entityIdFromJSON value@(Object o) = Entity <$> o .: "id" <*> parseJSON value +entityIdFromJSON _ = fail "entityIdFromJSON: not an object" + +instance PersistField entity => PersistField (Entity entity) 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", k):afterRest -> + case fromPersistValue (PersistMap (before ++ afterRest)) of + Right record -> Right $ Entity (Key k) record + Left err -> Left err + _ -> 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" diff --git a/Database/Persist/Class/PersistField.hs b/Database/Persist/Class/PersistField.hs --- a/Database/Persist/Class/PersistField.hs +++ b/Database/Persist/Class/PersistField.hs @@ -20,11 +20,12 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime) #endif import Data.Time.LocalTime (ZonedTime) -import Data.ByteString.Char8 (ByteString, unpack) +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 ((<>)) @@ -69,6 +70,7 @@ 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 @@ -91,28 +93,33 @@ instance PersistField Int where toPersistValue = PersistInt64 . fromIntegral - fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue x = Left $ T.pack $ "Expected Integer, received: " ++ show x + 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 x = Left $ T.pack $ "Expected Integer, received: " ++ show x + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue (PersistDouble i) = Right (truncate i :: Int8) -- oracle + 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 x = Left $ T.pack $ "Expected Integer, received: " ++ show x + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue (PersistDouble i) = Right (truncate i :: Int16) -- oracle + 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 x = Left $ T.pack $ "Expected Integer, received: " ++ show x + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue (PersistDouble i) = Right (truncate i :: Int32) -- oracle + 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 x = Left $ T.pack $ "Expected Integer, received: " ++ show x + fromPersistValue (PersistInt64 i) = Right $ fromIntegral i + fromPersistValue (PersistDouble i) = Right (truncate i :: Int64) -- oracle + fromPersistValue x = Left $ T.pack $ "int64 Expected Integer, received: " ++ show x instance PersistField Word where toPersistValue = PersistInt64 . fromIntegral @@ -153,7 +160,7 @@ _ -> Left $ "Can not read " <> t <> " as Fixed" fromPersistValue (PersistDouble d) = Right $ realToFrac d fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue x = Left $ "Expected Rational, received: " <> T.pack (show x) + fromPersistValue x = Left $ "PersistField Fixed:Expected Rational, received: " <> T.pack (show x) instance PersistField Rational where toPersistValue = PersistRational @@ -163,12 +170,20 @@ [(a, "")] -> Right $ toRational (a :: Pico) _ -> Left $ "Can not read " <> t <> " as Rational (Pico in fact)" fromPersistValue (PersistInt64 i) = Right $ fromIntegral i - fromPersistValue x = Left $ "Expected Rational, received: " <> T.pack (show x) + 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 @@ -280,17 +295,15 @@ fromPersistMap :: PersistField v => [(T.Text, PersistValue)] -> Either T.Text (M.Map T.Text v) -fromPersistMap kvs = - case ( - foldl (\eithAssocs (k,v) -> - case (eithAssocs, fromPersistValue v) of - (Left e, _) -> Left e - (_, Left e) -> Left e - (Right assocs, Right v') -> Right ((k,v'):assocs) - ) (Right []) kvs - ) of - Right vs -> Right $ M.fromList vs - Left e -> Left e +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 diff --git a/Database/Persist/Class/PersistQuery.hs b/Database/Persist/Class/PersistQuery.hs --- a/Database/Persist/Class/PersistQuery.hs +++ b/Database/Persist/Class/PersistQuery.hs @@ -2,6 +2,8 @@ {-# LANGUAGE TypeFamilies #-} module Database.Persist.Class.PersistQuery ( PersistQuery (..) + , selectList + , selectKeysList ) where import Control.Exception (throwIO) @@ -83,6 +85,21 @@ -- | The total number of records fulfilling the given criterion. count :: (PersistEntity val, PersistEntityBackend val ~ PersistMonadBackend m) => [Filter val] -> m Int + +-- | Call 'selectSource' but return the result as a list. +selectList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m) + => [Filter val] + -> [SelectOpt val] + -> m [Entity val] +selectList a b = selectSource a b C.$$ CL.consume + +-- | Call 'selectKeys' but return the result as a list. +selectKeysList :: (PersistEntity val, PersistQuery m, PersistEntityBackend val ~ PersistMonadBackend m) + => [Filter val] + -> [SelectOpt val] + -> m [Key val] +selectKeysList a b = selectKeys a b C.$$ CL.consume + #define DEF(T) { update k = lift . update k; updateGet k = lift . updateGet k; updateWhere f = lift . updateWhere f; deleteWhere = lift . deleteWhere; selectSource f = C.transPipe lift . selectSource f; selectFirst f = lift . selectFirst f; selectKeys f = C.transPipe lift . selectKeys f; count = lift . count } #define GO(T) instance (PersistQuery m) => PersistQuery (T m) where DEF(T) diff --git a/Database/Persist/Class/PersistStore.hs b/Database/Persist/Class/PersistStore.hs --- a/Database/Persist/Class/PersistStore.hs +++ b/Database/Persist/Class/PersistStore.hs @@ -1,16 +1,22 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies, FlexibleContexts #-} module Database.Persist.Class.PersistStore ( PersistStore (..) + , getJust + , belongsTo + , belongsToJust ) where import qualified Prelude import Prelude hiding ((++), show) +import qualified Data.Text as T + import Control.Monad.Trans.Error (Error (..)) import Control.Monad.Trans.Class (lift) -import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Monoid (Monoid) +import Control.Exception.Lifted (throwIO) import Data.Conduit.Internal (Pipe, ConduitM) import Control.Monad.Logger (LoggingT) @@ -30,6 +36,7 @@ import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) import Database.Persist.Class.PersistEntity +import Database.Persist.Types class MonadIO m => PersistStore m where type PersistMonadBackend m @@ -76,6 +83,34 @@ -- not exist. delete :: (PersistMonadBackend m ~ PersistEntityBackend val, PersistEntity val) => Key val -> m () + +-- | Same as get, but for a non-null (not Maybe) foreign key +-- Unsafe unless your database is enforcing that the foreign key is valid +getJust :: (PersistStore m, PersistEntity val, Show (Key val), PersistMonadBackend m ~ PersistEntityBackend val) => Key val -> m val +getJust key = get key >>= maybe + (liftIO $ throwIO $ PersistForeignConstraintUnmet $ T.pack $ Prelude.show key) + return + +-- | curry this to make a convenience function that loads an associated model +-- > foreign = belongsTo foeignId +belongsTo :: + (PersistStore m + , PersistEntity ent1 + , PersistEntity ent2 + , PersistMonadBackend m ~ PersistEntityBackend ent2 + ) => (ent1 -> Maybe (Key ent2)) -> ent1 -> m (Maybe ent2) +belongsTo foreignKeyField model = case foreignKeyField model of + Nothing -> return Nothing + Just f -> get f + +-- | same as belongsTo, but uses @getJust@ and therefore is similarly unsafe +belongsToJust :: + (PersistStore m + , PersistEntity ent1 + , PersistEntity ent2 + , PersistMonadBackend m ~ PersistEntityBackend ent2) + => (ent1 -> Key ent2) -> ent1 -> m ent2 +belongsToJust getForeignKey model = getJust $ getForeignKey model #define DEF(T) { type PersistMonadBackend (T m) = PersistMonadBackend m; insert = lift . insert; insertKey k = lift . insertKey k; repsert k = lift . repsert k; replace k = lift . replace k; delete = lift . delete; get = lift . get } #define GO(T) instance (PersistStore m) => PersistStore (T m) where DEF(T) diff --git a/Database/Persist/Class/PersistUnique.hs b/Database/Persist/Class/PersistUnique.hs --- a/Database/Persist/Class/PersistUnique.hs +++ b/Database/Persist/Class/PersistUnique.hs @@ -1,7 +1,11 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies, FlexibleContexts #-} module Database.Persist.Class.PersistUnique ( PersistUnique (..) + , getByValue + , insertBy + , replaceUnique + , checkUnique ) where import qualified Prelude @@ -11,6 +15,7 @@ import Control.Monad.Trans.Error (Error (..)) import Control.Monad.Trans.Class (lift) import Data.Monoid (Monoid) +import Data.List ((\\)) import Data.Conduit.Internal (Pipe) import Control.Monad.Logger (LoggingT) @@ -35,7 +40,14 @@ -- -- Please read the general Persistent documentation to learn how to create -- Unique keys. --- SQL backends automatically create uniqueness constraints, but for MongoDB you must place a unique index on the field. +-- SQL backends automatically create uniqueness constraints, but for MongoDB you must manually place a unique index on the field. +-- +-- Some functions in this module (insertUnique, insertBy, and replaceUnique) first query the unique indexes to check for conflicts. +-- You could instead optimistically attempt to perform the operation (e.g. replace instead of replaceUnique). However, +-- +-- * there is some fragility to trying to catch the correct exception and determing the column of failure. +-- +-- * an exception will automatically abort the current SQL transaction class PersistStore m => PersistUnique m where -- | Get a record by unique key, if available. Returns also the identifier. getBy :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => Unique val -> m (Maybe (Entity val)) @@ -48,9 +60,77 @@ -- couldn't be inserted because of a uniqueness constraint. insertUnique :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val) => val -> m (Maybe (Key val)) insertUnique datum = do - isUnique <- checkUnique datum - if isUnique then Just `liftM` insert datum else return Nothing + conflict <- checkUnique datum + case conflict of + Nothing -> Just `liftM` insert datum + Just _ -> return Nothing +-- | Insert a value, checking for conflicts with any unique constraints. If a +-- duplicate exists in the database, it is returned as 'Left'. Otherwise, the +-- new 'Key is returned as 'Right'. +insertBy :: (PersistEntity val, PersistUnique m, PersistEntityBackend val ~ PersistMonadBackend m) + => val -> m (Either (Entity val) (Key val)) + +insertBy val = do + res <- getByValue val + case res of + Nothing -> Right `liftM` insert val + Just z -> return $ Left z + +-- | A modification of 'getBy', which takes the 'PersistEntity' itself instead +-- of a 'Unique' value. Returns a value matching /one/ of the unique keys. This +-- function makes the most sense on entities with a single 'Unique' +-- constructor. +getByValue :: (PersistEntity value, PersistUnique m, PersistEntityBackend value ~ PersistMonadBackend m) + => value -> m (Maybe (Entity value)) +getByValue = checkUniques . persistUniqueKeys + where + checkUniques [] = return Nothing + checkUniques (x:xs) = do + y <- getBy x + case y of + Nothing -> checkUniques xs + Just z -> return $ Just z + + +-- | Attempt to replace the record of the given key with the given new record. +-- First query the unique fields to make sure the replacement maintains uniqueness constraints. +-- Return 'Nothing' if the replacement was made. +-- If uniqueness is violated, return a 'Just' with the 'Unique' violation +-- +-- Since 1.2.2.0 +replaceUnique :: (Eq record, Eq (Unique record), PersistEntityBackend record ~ PersistMonadBackend m, PersistEntity record, PersistStore m, PersistUnique m) + => Key record -> record -> m (Maybe (Unique record)) +replaceUnique key datumNew = getJust key >>= replaceOriginal + where + uniqueKeysNew = persistUniqueKeys datumNew + replaceOriginal original = do + conflict <- checkUniqueKeys changedKeys + case conflict of + Nothing -> replace key datumNew >> return Nothing + (Just conflictingKey) -> return $ Just conflictingKey + where + changedKeys = 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 :: (PersistEntityBackend record ~ PersistMonadBackend m, PersistEntity record, PersistUnique m) + => record -> m (Maybe (Unique record)) +checkUnique = checkUniqueKeys . persistUniqueKeys + +checkUniqueKeys :: (PersistEntity record, PersistUnique m, PersistEntityBackend record ~ PersistMonadBackend m) + => [Unique record] -> m (Maybe (Unique record)) +checkUniqueKeys [] = return Nothing +checkUniqueKeys (x:xs) = do + y <- getBy x + case y of + Nothing -> checkUniqueKeys xs + Just _ -> return (Just x) + #define DEF(T) { getBy = lift . getBy; deleteBy = lift . deleteBy; insertUnique = lift . insertUnique } #define GO(T) instance (PersistUnique m) => PersistUnique (T m) where DEF(T) #define GOX(X, T) instance (X, PersistUnique m) => PersistUnique (T m) where DEF(T) @@ -74,19 +154,3 @@ #undef DEF #undef GO #undef GOX - --- | Check whether there are any conflicts for unique keys with this entity and --- existing entities in the database. --- --- Returns 'True' if the entity would be unique, and could thus safely be --- 'insert'ed; returns 'False' on a conflict. -checkUnique :: (PersistEntityBackend val ~ PersistMonadBackend m, PersistEntity val, PersistUnique m) => val -> m Bool -checkUnique val = - go $ persistUniqueKeys val - where - go [] = return True - go (x:xs) = do - y <- getBy x - case y of - Nothing -> go xs - Just _ -> return False diff --git a/Database/Persist/Quasi.hs b/Database/Persist/Quasi.hs --- a/Database/Persist/Quasi.hs +++ b/Database/Persist/Quasi.hs @@ -18,12 +18,13 @@ import Prelude hiding (lines) import Database.Persist.Types import Data.Char -import Data.Maybe (mapMaybe, fromMaybe) +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.List (foldl',find) +import Data.Monoid (mappend) data ParseState a = PSDone | PSFail | PSSuccess a Text @@ -179,14 +180,36 @@ -- | Divide lines into blocks and make entity definitions. parseLines :: PersistSettings -> [Line] -> [EntityDef ()] parseLines ps lines = - toEnts 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 + in mkEntityDef ps name entattribs x : toEnts y toEnts (Line _ []:rest) = toEnts rest toEnts [] = [] +fixForeignKeysAll :: [EntityDef ()] -> [EntityDef ()] +fixForeignKeysAll ents = map fixForeignKeys ents + where fixForeignKeys :: EntityDef () -> EntityDef () + fixForeignKeys ent = ent { entityForeigns = map (fixForeignKey ent) (entityForeigns ent) } + -- check the count and the sqltypes match and update the foreignFields with the names of the primary columns + chktypes :: [FieldDef ()] -> HaskellName -> [FieldDef ()] -> HaskellName -> Bool + chktypes fflds fkey pflds pkey = case (filter ((== fkey) . fieldHaskell) fflds, filter ((== pkey) . fieldHaskell) pflds) of + ([ffld],[pfld]) -> fieldType ffld == fieldType pfld + xs -> error $ "unexpected result "++ show xs + fixForeignKey :: EntityDef () -> ForeignDef -> ForeignDef + fixForeignKey fent fdef = + case find ((== foreignRefTableHaskell fdef) . entityHaskell) ents of + Just pent -> case entityPrimary pent of + Just pdef -> if length (foreignFields fdef) == length (primaryFields pdef) + then fdef { foreignFields = zipWith (\(a,b,_,_) (a',b') -> + if chktypes (entityFields fent) a (entityFields pent) a' + then (a,b,a',b') + else error ("type mismatch between foreign key and primary column" ++ show (a,a') ++ " primary ent="++show pent ++ " foreign ent="++show fent)) (foreignFields fdef) (primaryFields pdef) } + else error $ "found " ++ show (length (foreignFields fdef)) ++ " fkeys and " ++ show (length (primaryFields pdef)) ++ " pkeys: fdef=" ++ show fdef ++ " pdef=" ++ show pdef + Nothing -> error $ "no explicit primary key fdef="++show fdef++ " fent="++show fent + Nothing -> error $ "could not find table " ++ show (foreignRefTableHaskell fdef) ++ " fdef=" ++ show fdef ++ " allnames=" ++ show (map (unHaskellName . entityHaskell) ents) ++ "\n\nents=" ++ show ents + -- | Construct an entity definition. mkEntityDef :: PersistSettings -> Text -- ^ name @@ -198,7 +221,7 @@ (HaskellName name') (DBName $ getDbName ps name' entattribs) (DBName $ idName entattribs) - entattribs cols uniqs derives + entattribs cols primary uniqs foreigns derives extras isSum where @@ -212,7 +235,17 @@ case T.stripPrefix "id=" t of Nothing -> idName ts Just s -> s - uniqs = mapMaybe (takeUniqs ps cols) attribs + + (primarys, uniqs, foreigns) = foldl' (\(a,b,c) attr -> + let (a',b',c') = takeConstraint ps name' cols attr + squish xs m = xs `mappend` maybeToList m + in (squish a a', squish b b', squish c c')) ([],[],[]) attribs + + primary = case primarys of + [] -> Nothing + [p] -> Just p + _ -> error $ "found more than one primary key in table[" ++ show name' ++ "]" + derives = concat $ mapMaybe takeDerives attribs cols :: [FieldDef ()] @@ -258,15 +291,45 @@ Nothing -> getDbName ps n as Just s -> s -takeUniqs :: PersistSettings +takeConstraint :: PersistSettings + -> Text -> [FieldDef a] -> [Text] - -> Maybe UniqueDef -takeUniqs ps defs (n:rest) + -> (Maybe PrimaryDef, Maybe UniqueDef, Maybe ForeignDef) +takeConstraint ps tableName defs (n:rest) | not (T.null n) && isUpper (T.head n) = takeConstraint' + where takeConstraint' + | n == "Primary" = (Just $ takePrimary defs rest, Nothing, Nothing) + | n == "Unique" = (Nothing, Just $ takeUniq ps tableName defs rest, Nothing) + | n == "Foreign" = (Nothing, Nothing, Just $ takeForeign ps tableName defs rest) + | otherwise = (Nothing, Just $ takeUniq ps "" defs (n:rest), Nothing) -- retain compatibility with original unique constraint +takeConstraint _ _ _ _ = (Nothing, Nothing, Nothing) + +takePrimary :: [FieldDef a] + -> [Text] + -> PrimaryDef +takePrimary defs pkcols + = PrimaryDef + (map (HaskellName &&& getDBName defs) pkcols) + attrs + where + (_, attrs) = break ("!" `T.isPrefixOf`) pkcols + getDBName [] t = error $ "Unknown column in primary key constraint: " ++ show t + getDBName (d:ds) t + | nullable (fieldAttrs d) /= NotNullable = error $ "primary key column cannot be nullable: " ++ show t + | fieldHaskell d == HaskellName t = fieldDB d + | otherwise = getDBName ds t + +-- Unique UppercaseConstraintName list of lowercasefields +takeUniq :: PersistSettings + -> Text + -> [FieldDef a] + -> [Text] + -> UniqueDef +takeUniq ps tableName defs (n:rest) | not (T.null n) && isUpper (T.head n) - = Just $ UniqueDef + = UniqueDef (HaskellName n) - (DBName $ psToDBName ps n) + (DBName $ psToDBName ps (tableName `T.append` n)) (map (HaskellName &&& getDBName defs) fields) attrs where @@ -275,7 +338,30 @@ getDBName (d:ds) t | fieldHaskell d == HaskellName t = fieldDB d | otherwise = getDBName ds t -takeUniqs _ _ _ = Nothing +takeUniq _ tableName _ xs = error $ "invalid unique constraint on table[" ++ show tableName ++ "] expecting an uppercase constraint name xs=" ++ show xs + +takeForeign :: PersistSettings + -> Text + -> [FieldDef a] + -> [Text] + -> ForeignDef +takeForeign ps tableName defs (refTableName:n:rest) + | not (T.null n) && isLower (T.head n) + = ForeignDef + (HaskellName refTableName) + (DBName $ psToDBName ps refTableName) + (HaskellName n) + (DBName $ psToDBName ps (tableName `T.append` n)) + (map (\f -> (HaskellName f, getDBName defs f, HaskellName "", DBName "")) fields) + attrs + where + (fields,attrs) = break ("!" `T.isPrefixOf`) rest + getDBName [] t = error $ "Unknown column in foreign key constraint: " ++ show t + getDBName (d:ds) t + | nullable (fieldAttrs d) /= NotNullable = error $ "foreign key column cannot be nullable: " ++ show t + | fieldHaskell d == HaskellName t = fieldDB d + | otherwise = getDBName ds t +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 diff --git a/Database/Persist/Sql.hs b/Database/Persist/Sql.hs --- a/Database/Persist/Sql.hs +++ b/Database/Persist/Sql.hs @@ -15,6 +15,7 @@ , getStmtConn -- * Internal , module Database.Persist.Sql.Internal + , decorateSQLWithLimitOffset ) where import Database.Persist @@ -25,7 +26,7 @@ import Database.Persist.Sql.Migration import Database.Persist.Sql.Internal -import Database.Persist.Sql.Orphan.PersistQuery +import Database.Persist.Sql.Orphan.PersistQuery import Database.Persist.Sql.Orphan.PersistStore () import Database.Persist.Sql.Orphan.PersistUnique () import Control.Monad.IO.Class diff --git a/Database/Persist/Sql/Class.hs b/Database/Persist/Sql/Class.hs --- a/Database/Persist/Sql/Class.hs +++ b/Database/Persist/Sql/Class.hs @@ -311,4 +311,11 @@ n = 0 _mn = return n `asTypeOf` a instance PersistFieldSql Rational where - sqlType _ = SqlNumeric 22 12 -- FIXME: Ambigous, 12 is from Pico which is used to convert Rational to number string + sqlType _ = SqlNumeric 32 20 -- need to make this field big enough to handle Rational to Mumber string conversion for ODBC + +-- perhaps a SQL user can figure this sqlType out? +-- It is really intended for MongoDB though. +instance PersistField entity => PersistFieldSql (Entity entity) where + sqlType _ = SqlOther "embedded entity, hard to type" +instance PersistFieldSql (KeyBackend SqlBackend a) where + sqlType _ = SqlInt64 diff --git a/Database/Persist/Sql/Internal.hs b/Database/Persist/Sql/Internal.hs --- a/Database/Persist/Sql/Internal.hs +++ b/Database/Persist/Sql/Internal.hs @@ -3,6 +3,7 @@ -- | Intended for creating new backends. module Database.Persist.Sql.Internal ( mkColumns + , convertKey ) where import Database.Persist.Types @@ -15,9 +16,9 @@ import Database.Persist.Sql.Types -- | Create the list of columns for the given entity. -mkColumns :: [EntityDef a] -> EntityDef SqlType -> ([Column], [UniqueDef]) +mkColumns :: [EntityDef a] -> EntityDef SqlType -> ([Column], [UniqueDef], [ForeignDef]) mkColumns allDefs t = - (cols, entityUniques t) + (cols, entityUniques t, entityForeigns t) where cols :: [Column] cols = map go (entityFields t) @@ -35,6 +36,7 @@ SqlOther (listToMaybe $ mapMaybe (T.stripPrefix "sqltype=") $ fieldAttrs fd)) (def $ fieldAttrs fd) + Nothing (maxLen $ fieldAttrs fd) (ref (fieldDB fd) (fieldType fd) (fieldAttrs fd)) @@ -77,3 +79,8 @@ resolveTableName (e:es) hn | entityHaskell e == hn = entityDB e | otherwise = resolveTableName es hn + +convertKey :: Bool -> KeyBackend t t1 -> [PersistValue] +convertKey True (Key (PersistList fks)) = fks +convertKey False (Key ret@(PersistInt64 _)) = [ret] +convertKey composite k = error $ "invalid key type " ++ show k ++ " composite=" ++ show composite diff --git a/Database/Persist/Sql/Orphan/PersistQuery.hs b/Database/Persist/Sql/Orphan/PersistQuery.hs --- a/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -4,6 +4,7 @@ module Database.Persist.Sql.Orphan.PersistQuery ( deleteWhereCount , updateWhereCount + , decorateSQLWithLimitOffset ) where import Database.Persist @@ -11,6 +12,7 @@ import Database.Persist.Sql.Class import Database.Persist.Sql.Raw import Database.Persist.Sql.Orphan.PersistStore () +import Database.Persist.Sql.Internal (convertKey) import qualified Data.Text as T import Data.Text (Text) import Data.Monoid (Monoid (..), (<>)) @@ -21,6 +23,9 @@ 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 (MonadResource m, MonadLogger m) => PersistQuery (SqlPersistT m) where @@ -33,17 +38,20 @@ go'' n Multiply = T.concat [n, "=", n, "*?"] go'' n Divide = T.concat [n, "=", n, "/?"] let go' (x, pu) = go'' (connEscapeName conn x) pu + let composite = isJust $ entityPrimary t + let wher = case entityPrimary t of + Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (snd fld) <> "=? ") $ primaryFields pdef + Nothing -> connEscapeName conn (entityID t) <> "=?" let sql = T.concat [ "UPDATE " , connEscapeName conn $ entityDB t , " SET " , T.intercalate "," $ map (go' . go) upds , " WHERE " - , connEscapeName conn $ entityID t - , "=?" + , wher ] rawExecute sql $ - map updatePersistValue upds `mappend` [unKey k] + map updatePersistValue upds `mappend` (convertKey composite k) where t = entityDef $ dummyFromKey k go x = (fieldDB $ updateFieldDef x, updateUpdate x) @@ -59,8 +67,15 @@ , wher ] rawQuery sql (getFiltsValues conn filts) $$ do - Just [PersistInt64 i] <- CL.head - return $ fromIntegral i + 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 @@ -68,19 +83,38 @@ conn <- lift askSqlConn rawQuery (sql conn) (getFiltsValues conn filts) $= CL.mapM parse where + composite = isJust $ entityPrimary t (limit, offset, orders) = limitOffsetOrder opts parse vals = - case fromPersistValues' vals of - Left s -> liftIO $ throwIO $ PersistMarshalError s - Right row -> return row + case entityPrimary t of + Just pdef -> + let pks = map fst $ primaryFields pdef + keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) vals + in case fromPersistValuesComposite' keyvals vals of + Left s -> liftIO $ throwIO $ PersistMarshalError s + Right row -> return row + Nothing -> + case fromPersistValues' vals of + Left s -> liftIO $ throwIO $ PersistMarshalError s + Right row -> return row t = entityDef $ dummyFromFilts filts - fromPersistValues' (PersistInt64 x:xs) = do + fromPersistValues' (PersistInt64 x:xs) = case fromPersistValues xs of Left e -> Left e Right xs' -> Right (Entity (Key $ PersistInt64 x) xs') - fromPersistValues' _ = Left "error in fromPersistValues'" + fromPersistValues' (PersistDouble x:xs) = -- oracle returns Double + case fromPersistValues xs of + Left e -> Left e + Right xs' -> Right (Entity (Key $ PersistInt64 (truncate x)) xs') -- convert back to int64 + fromPersistValues' xs = Left $ T.pack ("error in fromPersistValues' xs=" ++ show xs) + + fromPersistValuesComposite' keyvals xs = + case fromPersistValues xs of + Left e -> Left e + Right xs' -> Right (Entity (Key $ PersistList keyvals) xs') + wher conn = if null filts then "" else filterClause False conn filts @@ -88,46 +122,37 @@ case map (orderClause False conn) orders of [] -> "" ords -> " ORDER BY " <> T.intercalate "," ords - lim conn = case (limit, offset) of - (0, 0) -> "" - (0, _) -> T.cons ' ' $ connNoLimit conn - (_, _) -> " LIMIT " <> T.pack (show limit) - off = if offset == 0 - then "" - else " OFFSET " <> T.pack (show offset) cols conn = T.intercalate "," - $ (connEscapeName conn $ entityID t) - : map (connEscapeName conn . fieldDB) (entityFields t) - sql conn = mconcat + $ ((if composite then [] else [connEscapeName conn $ entityID t]) + <> map (connEscapeName conn . fieldDB) (entityFields t)) + sql conn = connLimitOffset conn (limit,offset) (not (null orders)) $ mconcat [ "SELECT " , cols conn , " FROM " , connEscapeName conn $ entityDB t , wher conn , ord conn - , lim conn - , off ] selectKeys filts opts = do conn <- lift askSqlConn rawQuery (sql conn) (getFiltsValues conn filts) $= CL.mapM parse where - parse [PersistInt64 i] = return $ Key $ PersistInt64 i - parse y = liftIO $ throwIO $ PersistMarshalError $ "Unexpected in selectKeys: " <> T.pack (show y) t = entityDef $ dummyFromFilts filts + cols conn = case entityPrimary t of + Just pdef -> T.intercalate "," $ map (connEscapeName conn . snd) $ primaryFields pdef + Nothing -> connEscapeName conn $ entityID t + wher conn = if null filts then "" else filterClause False conn filts - sql conn = mconcat + sql conn = connLimitOffset conn (limit,offset) (not (null orders)) $ mconcat [ "SELECT " - , connEscapeName conn $ entityID t + , cols conn , " FROM " , connEscapeName conn $ entityDB t , wher conn , ord conn - , lim conn - , off ] (limit, offset, orders) = limitOffsetOrder opts @@ -136,14 +161,18 @@ case map (orderClause False conn) orders of [] -> "" ords -> " ORDER BY " <> T.intercalate "," ords - lim conn = case (limit, offset) of - (0, 0) -> "" - (0, _) -> T.cons ' ' $ connNoLimit conn - (_, _) -> " LIMIT " <> T.pack (show limit) - off = if offset == 0 - then "" - else " OFFSET " <> T.pack (show offset) + parse xs = case entityPrimary t of + Nothing -> + case xs of + [PersistInt64 x] -> return $ Key $ PersistInt64 x + [PersistDouble x] -> return $ Key $ PersistInt64 (truncate x) -- oracle returns Double + _ -> liftIO $ throwIO $ PersistMarshalError $ "Unexpected in selectKeys False: " <> T.pack (show xs) + Just pdef -> + let pks = map fst $ primaryFields pdef + keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) xs + in return $ Key $ PersistList keyvals + deleteWhere filts = do _ <- deleteWhereCount filts return () @@ -241,53 +270,96 @@ go (FilterAnd fs) = combineAND fs go (FilterOr []) = ("1=0", []) go (FilterOr fs) = combine " OR " fs - go (Filter field value pfilter) = - case (isNull, pfilter, varCount) of - (True, Eq, _) -> (name <> " IS NULL", []) - (True, Ne, _) -> (name <> " IS NOT NULL", []) - (False, Ne, _) -> (T.concat - [ "(" - , name - , " IS NULL OR " - , name - , " <> " - , qmarks - , ")" - ], notNullVals) - -- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since - -- not all databases support those words directly. - (_, In, 0) -> ("1=2" <> orNullSuffix, []) - (False, In, _) -> (name <> " IN " <> qmarks <> orNullSuffix, allVals) - (True, In, _) -> (T.concat - [ "(" - , name - , " IS NULL OR " - , name - , " IN " - , qmarks - , ")" - ], notNullVals) - (_, NotIn, 0) -> ("1=1", []) - (False, NotIn, _) -> (T.concat - [ "(" - , name - , " IS NULL OR " - , name - , " NOT IN " - , qmarks - , ")" - ], notNullVals) - (True, NotIn, _) -> (T.concat - [ "(" - , name - , " IS NOT NULL AND " - , name - , " NOT IN " - , qmarks - , ")" - ], notNullVals) - _ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals) + go (Filter field value pfilter) = + let t = entityDef $ dummyFromFilts [Filter field value pfilter] + in case (fieldDB (persistFieldDef field) == DBName "id", entityPrimary t, allVals) of + -- need to check the id field in a safer way: entityId? + (True, Just pdef, (PersistList ys:_)) -> + if length (primaryFields pdef) /= length ys + then error $ "wrong number of entries in primaryFields vs PersistList allVals=" ++ show allVals + else + case (allVals, pfilter, isCompFilter pfilter) of + ([PersistList xs], Eq, _) -> + let sqlcl=T.intercalate " and " (map (\a -> connEscapeName conn (snd a) <> showSqlFilter pfilter <> "? ") (primaryFields pdef)) + in (wrapSql sqlcl,xs) + ([PersistList xs], Ne, _) -> + let sqlcl=T.intercalate " or " (map (\a -> connEscapeName conn (snd a) <> showSqlFilter pfilter <> "? ") (primaryFields pdef)) + in (wrapSql sqlcl,xs) + (_, In, _) -> + let xxs = transpose (map fromPersistList allVals) + sqls=map (\(a,xs) -> connEscapeName conn (snd a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (primaryFields 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 (snd a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (primaryFields pdef) xxs) + in (wrapSql (T.intercalate " or " (map wrapSql sqls)), concat xxs) + ([PersistList xs], _, True) -> + let zs = tail (inits (primaryFields 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 (snd 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 @@ -358,3 +430,20 @@ dummyFromKey :: KeyBackend SqlBackend v -> Maybe v dummyFromKey _ = Nothing + +-- | 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 + ] diff --git a/Database/Persist/Sql/Orphan/PersistStore.hs b/Database/Persist/Sql/Orphan/PersistStore.hs --- a/Database/Persist/Sql/Orphan/PersistStore.hs +++ b/Database/Persist/Sql/Orphan/PersistStore.hs @@ -7,33 +7,53 @@ import Database.Persist.Sql.Types import Database.Persist.Sql.Class import Database.Persist.Sql.Raw +import Database.Persist.Sql.Internal (convertKey) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import Control.Monad.Logger import qualified Data.Text as T import Data.Text (Text, unpack) -import Data.Monoid (mappend) +import Data.Monoid (mappend, (<>)) import Control.Monad.IO.Class +import Data.ByteString.Char8 (readInteger) +import Data.Maybe (isJust) +import Data.List (find) instance (C.MonadResource m, MonadLogger m) => PersistStore (SqlPersistT m) where type PersistMonadBackend (SqlPersistT m) = SqlBackend insert val = do conn <- askSqlConn - let esql = connInsertSql conn (entityDB t) (map fieldDB $ entityFields t) (entityID t) - i <- + let esql = connInsertSql conn t vals + key <- case esql of ISRSingle sql -> rawQuery sql vals C.$$ do x <- CL.head case x of - Just [PersistInt64 i] -> return i + Just [PersistInt64 i] -> return $ Key $ PersistInt64 i Nothing -> error $ "SQL insert did not return a result giving the generated ID" Just vals' -> error $ "Invalid result from a SQL insert, got: " ++ show vals' ISRInsertGet sql1 sql2 -> do rawExecute sql1 vals rawQuery sql2 [] C.$$ do - Just [PersistInt64 i] <- CL.head - return i - return $ Key $ PersistInt64 i + mm <- CL.head + case mm of + Just [PersistInt64 i] -> return $ Key $ PersistInt64 i + Just [PersistDouble i] ->return $ Key $ PersistInt64 $ truncate i -- oracle need this! + Just [PersistByteString i] -> case readInteger i of -- mssql + Just (ret,"") -> return $ Key $ PersistInt64 $ fromIntegral ret + xs -> error $ "invalid number i["++show i++"] xs[" ++ show xs ++ "]" + Just xs -> error $ "invalid sql2 return xs["++show xs++"] sql2["++show sql2++"] sql1["++show sql1++"]" + Nothing -> error $ "invalid sql2 returned nothing sql2["++show sql2++"] sql1["++show sql1++"]" + 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 fst $ primaryFields pdef + keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) fs + in return $ Key $ PersistList keyvals + + return key where t = entityDef $ Just val vals = map toPersistValue $ toPersistFields val @@ -66,19 +86,21 @@ get k = do conn <- askSqlConn let t = entityDef $ dummyFromKey k + let composite = isJust $ entityPrimary t let cols = T.intercalate "," $ map (connEscapeName conn . fieldDB) $ entityFields t + let wher = case entityPrimary t of + Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (snd fld) <> "=? ") $ primaryFields pdef + Nothing -> connEscapeName conn (entityID t) <> "=?" let sql = T.concat [ "SELECT " , cols , " FROM " , connEscapeName conn $ entityDB t , " WHERE " - , connEscapeName conn $ entityID t - , "=?" + , wher ] - vals' = [unKey k] - rawQuery sql vals' C.$$ do + rawQuery sql (convertKey composite k) C.$$ do res <- CL.head case res of Nothing -> return Nothing @@ -89,15 +111,19 @@ delete k = do conn <- askSqlConn - rawExecute (sql conn) [unKey k] + rawExecute (sql conn) (convertKey composite k) where t = entityDef $ dummyFromKey k + composite = isJust $ entityPrimary t + wher conn = + case entityPrimary t of + Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (snd fld) <> "=? ") $ primaryFields pdef + Nothing -> connEscapeName conn (entityID t) <> "=?" sql conn = T.concat [ "DELETE FROM " , connEscapeName conn $ entityDB t , " WHERE " - , connEscapeName conn $ entityID t - , "=?" + , wher conn ] dummyFromKey :: KeyBackend SqlBackend v -> Maybe v diff --git a/Database/Persist/Sql/Orphan/PersistUnique.hs b/Database/Persist/Sql/Orphan/PersistUnique.hs --- a/Database/Persist/Sql/Orphan/PersistUnique.hs +++ b/Database/Persist/Sql/Orphan/PersistUnique.hs @@ -32,8 +32,10 @@ getBy uniq = do conn <- askSqlConn - let cols = T.intercalate "," $ (connEscapeName conn $ entityID t) - : map (connEscapeName conn . fieldDB) (entityFields t) + let flds = map (connEscapeName conn . fieldDB) (entityFields t) + let cols = case entityPrimary t of + Just _ -> T.intercalate "," flds + Nothing -> T.intercalate "," $ (connEscapeName conn $ entityID t) : flds let sql = T.concat [ "SELECT " , cols @@ -51,7 +53,11 @@ case fromPersistValues vals of Left s -> error $ T.unpack s Right x -> return $ Just (Entity (Key $ PersistInt64 k) x) - Just _ -> error "Database.Persist.GenericSql: Bad list in getBy" + Just (PersistDouble k:vals) -> -- oracle + case fromPersistValues vals of + Left s -> error $ T.unpack s + Right x -> return $ Just (Entity (Key $ PersistInt64 $ truncate k) x) + Just xs -> error $ "Database.Persist.GenericSql: Bad list in getBy xs="++show xs where sqlClause conn = T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq diff --git a/Database/Persist/Sql/Run.hs b/Database/Persist/Sql/Run.hs --- a/Database/Persist/Sql/Run.hs +++ b/Database/Persist/Sql/Run.hs @@ -33,7 +33,7 @@ return x runSqlPersistM :: SqlPersistM a -> Connection -> IO a -runSqlPersistM x conn = runResourceT $ runNoLoggingT $ runReaderT (unSqlPersistT x) conn +runSqlPersistM x conn = runResourceT $ runNoLoggingT $ runSqlConn x conn runSqlPersistMPool :: SqlPersistM a -> Pool Connection -> IO a runSqlPersistMPool x pool = runResourceT $ runNoLoggingT $ runSqlPool x pool diff --git a/Database/Persist/Sql/Types.hs b/Database/Persist/Sql/Types.hs --- a/Database/Persist/Sql/Types.hs +++ b/Database/Persist/Sql/Types.hs @@ -35,11 +35,12 @@ data InsertSqlResult = ISRSingle Text | ISRInsertGet Text Text + | ISRManyKeys Text [PersistValue] data Connection = Connection { connPrepare :: Text -> IO Statement -- | table name, column names, id name, either 1 or 2 statements to run - , connInsertSql :: DBName -> [DBName] -> DBName -> InsertSqlResult + , connInsertSql :: EntityDef SqlType -> [PersistValue] -> InsertSqlResult , connStmtMap :: IORef (Map Text Statement) , connClose :: IO () , connMigrateSql @@ -53,6 +54,7 @@ , connEscapeName :: DBName -> Text , connNoLimit :: Text , connRDBMS :: Text + , connLimitOffset :: (Int,Int) -> Bool -> Text -> Text } data Statement = Statement @@ -69,6 +71,7 @@ , cNull :: !Bool , cSqlType :: !SqlType , cDefault :: !(Maybe Text) + , cDefaultConstraintName :: !(Maybe DBName) , cMaxLen :: !(Maybe Integer) , cReference :: !(Maybe (DBName, DBName)) -- table name, constraint name } diff --git a/Database/Persist/Types/Base.hs b/Database/Persist/Types/Base.hs --- a/Database/Persist/Types/Base.hs +++ b/Database/Persist/Types/Base.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExistentialQuantification #-} @@ -21,14 +20,15 @@ import Data.Time (Day, TimeOfDay, UTCTime) import Data.Int (Int64) import qualified Data.Text.Read -import Data.ByteString (ByteString) +import Data.ByteString (ByteString, foldl') +import Data.Bits (shiftL, shiftR) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 import Data.Time.LocalTime (ZonedTime, zonedTimeToUTC, zonedTimeToLocalTime, zonedTimeZone) import Data.Map (Map) import qualified Data.HashMap.Strict as HM import Data.Word (Word32) -#if MIN_VERSION_aeson(0, 7, 0) -import qualified Data.Scientific -#endif +import Numeric (showHex, readHex) -- | A 'Checkmark' should be used as a field type whenever a -- uniqueness constraint should guarantee that a certain kind of @@ -106,7 +106,9 @@ , entityID :: !DBName , entityAttrs :: ![Attr] , entityFields :: ![FieldDef sqlType] + , entityPrimary :: Maybe PrimaryDef , entityUniques :: ![UniqueDef] + , entityForeigns:: ![ForeignDef] , entityDerives :: ![Text] , entityExtra :: !(Map Text [ExtraLine]) , entitySum :: !Bool @@ -148,6 +150,22 @@ } deriving (Show, Eq, Read, Ord) +data PrimaryDef = PrimaryDef + { primaryFields :: ![(HaskellName, DBName)] + , primaryAttrs :: ![Attr] + } + deriving (Show, Eq, Read, Ord) + +data ForeignDef = ForeignDef + { foreignRefTableHaskell :: !HaskellName + , foreignRefTableDBName :: !DBName + , foreignConstraintNameHaskell :: !HaskellName + , foreignConstraintNameDBName :: !DBName + , foreignFields :: ![(HaskellName, DBName, HaskellName, DBName)] -- foreignkey name gb our field plus corresponding other primary field:make this a real adt + , foreignAttrs :: ![Attr] + } + deriving (Show, Eq, Read, Ord) + data PersistException = PersistError Text -- ^ Generic Exception | PersistMarshalError Text @@ -184,15 +202,44 @@ | PersistNull | PersistList [PersistValue] | PersistMap [(Text, PersistValue)] - | PersistObjectId ByteString -- ^ intended especially for MongoDB backend + | 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 PathPiece PersistValue where fromPathPiece t = case Data.Text.Read.signed Data.Text.Read.decimal t of Right (i, t') | T.null t' -> Just $ PersistInt64 i - _ -> Just $ PersistText t + _ -> case reads $ T.unpack t of + [(fks, "")] -> Just $ PersistList fks + _ -> Just $ PersistText t toPathPiece x = case fromPersistValueText x of Left e -> error e @@ -214,18 +261,13 @@ 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 (PersistDouble d) = A.Number $ AN.D d toJSON (PersistRational r) = A.String $ T.pack $ 'r' : show r toJSON (PersistBool b) = A.Bool b toJSON (PersistTimeOfDay t) = A.String $ T.pack $ 't' : show t @@ -235,12 +277,30 @@ toJSON PersistNull = A.Null toJSON (PersistList l) = A.Array $ V.fromList $ map A.toJSON l toJSON (PersistMap m) = A.object $ map (second A.toJSON) m - toJSON (PersistObjectId o) = A.String $ T.cons 'o' $ TE.decodeUtf8 $ B64.encode o + 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 @@ -249,25 +309,27 @@ Just ('z', t) -> fmap PersistZonedTime $ readMay t Just ('d', t) -> fmap PersistDay $ readMay t Just ('r', t) -> fmap PersistRational $ readMay t - Just ('o', t) -> either (fail "Invalid base64") (return . PersistObjectId) - $ B64.decode $ TE.encodeUtf8 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" -#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 + -- taken from crypto-api + -- |@i2bs bitLen i@ converts @i@ to a 'ByteString' of @bitLen@ bits (must be a multiple of 8). + i2bs :: Int -> Integer -> BS.ByteString + i2bs l i = BS.unfoldr (\l' -> if l' < 0 then Nothing else Just (fromIntegral (i `shiftR` l'), l' - 8)) (l-8) + {-# INLINE i2bs #-} + + parseJSON (A.Number (AN.I i)) = return $ PersistInt64 $ fromInteger i parseJSON (A.Number (AN.D d)) = return $ PersistDouble d -#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) diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 1.2.3.3 +version: 1.3.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -43,7 +43,6 @@ , blaze-html >= 0.5 , blaze-markup >= 0.5.1 , silently - , scientific exposed-modules: Database.Persist Database.Persist.Quasi @@ -95,7 +94,6 @@ , conduit , monad-control , blaze-html - , scientific cpp-options: -DTEST