module Database.Persist.Base
( PersistValue (..)
, SqlType (..)
, PersistField (..)
, PersistEntity (..)
, EntityDef (..)
, PersistBackend (..)
, PersistFilter (..)
, PersistUpdate (..)
, PersistOrder (..)
, SomePersistField (..)
, selectList
, insertBy
, checkUnique
, DeleteCascade (..)
, deleteCascadeWhere
, PersistException (..)
) where
import Language.Haskell.TH.Syntax
import Data.Time (Day, TimeOfDay, UTCTime)
import Data.ByteString.Char8 (ByteString, unpack)
import Control.Applicative
import Data.Typeable (Typeable)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Word (Word8, Word16, Word32, Word64)
import Text.Hamlet
import qualified Data.Text as T
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Enumerator
import qualified Control.Exception as E
import Data.Bits (bitSize)
import Control.Monad (liftM)
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
data PersistValue = PersistString String
| PersistByteString ByteString
| PersistInt64 Int64
| PersistDouble Double
| PersistBool Bool
| PersistDay Day
| PersistTimeOfDay TimeOfDay
| PersistUTCTime UTCTime
| PersistNull
deriving (Show, Read, Eq, Typeable)
data SqlType = SqlString
| SqlInt32
| SqlInteger
| SqlReal
| SqlBool
| SqlDay
| SqlTime
| SqlDayTime
| SqlBlob
deriving (Show, Read, Eq, Typeable)
class PersistField a where
toPersistValue :: a -> PersistValue
fromPersistValue :: PersistValue -> Either String a
sqlType :: a -> SqlType
isNullable :: a -> Bool
isNullable _ = False
instance PersistField String where
toPersistValue = PersistString
fromPersistValue (PersistString s) = Right s
fromPersistValue (PersistByteString bs) =
Right $ T.unpack $ T.decodeUtf8With T.lenientDecode bs
fromPersistValue (PersistInt64 i) = Right $ show i
fromPersistValue (PersistDouble d) = Right $ show d
fromPersistValue (PersistDay d) = Right $ show d
fromPersistValue (PersistTimeOfDay d) = Right $ show d
fromPersistValue (PersistUTCTime d) = Right $ show d
fromPersistValue PersistNull = Left "Unexpected null"
fromPersistValue (PersistBool b) = Right $ show b
sqlType _ = SqlString
instance PersistField ByteString where
toPersistValue = PersistByteString
fromPersistValue (PersistByteString bs) = Right bs
fromPersistValue x = T.encodeUtf8 . T.pack <$> fromPersistValue x
sqlType _ = SqlBlob
instance PersistField T.Text where
toPersistValue = PersistString . T.unpack
fromPersistValue (PersistByteString bs) =
Right $ T.decodeUtf8With T.lenientDecode bs
fromPersistValue v = fmap T.pack $ fromPersistValue v
sqlType _ = SqlString
instance PersistField Html where
toPersistValue = PersistByteString . S.concat . L.toChunks . renderHtml
fromPersistValue = fmap unsafeByteString . fromPersistValue
sqlType _ = SqlString
instance PersistField Int where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ "Expected Integer, received: " ++ show x
sqlType x = case bitSize x of
32 -> SqlInt32
_ -> SqlInteger
instance PersistField Int8 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ "Expected Integer, received: " ++ show x
sqlType _ = SqlInt32
instance PersistField Int16 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ "Expected Integer, received: " ++ show x
sqlType _ = SqlInt32
instance PersistField Int32 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ "Expected Integer, received: " ++ show x
sqlType _ = SqlInt32
instance PersistField Int64 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ "Expected Integer, received: " ++ show x
sqlType _ = SqlInteger
instance PersistField Word8 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x
sqlType _ = SqlInt32
instance PersistField Word16 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x
sqlType _ = SqlInt32
instance PersistField Word32 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x
sqlType _ = SqlInteger
instance PersistField Word64 where
toPersistValue = PersistInt64 . fromIntegral
fromPersistValue (PersistInt64 i) = Right $ fromIntegral i
fromPersistValue x = Left $ "Expected Wordeger, received: " ++ show x
sqlType _ = SqlInteger
instance PersistField Double where
toPersistValue = PersistDouble
fromPersistValue (PersistDouble d) = Right d
fromPersistValue x = Left $ "Expected Double, received: " ++ show x
sqlType _ = SqlReal
instance PersistField Bool where
toPersistValue = PersistBool
fromPersistValue (PersistBool b) = Right b
fromPersistValue (PersistInt64 i) = Right $ i /= 0
fromPersistValue x = Left $ "Expected Bool, received: " ++ show x
sqlType _ = SqlBool
instance PersistField Day where
toPersistValue = PersistDay
fromPersistValue (PersistDay d) = Right d
fromPersistValue x@(PersistString s) =
case reads s of
(d, _):_ -> Right d
_ -> Left $ "Expected Day, received " ++ show x
fromPersistValue x@(PersistByteString s) =
case reads $ unpack s of
(d, _):_ -> Right d
_ -> Left $ "Expected Day, received " ++ show x
fromPersistValue x = Left $ "Expected Day, received: " ++ show x
sqlType _ = SqlDay
instance PersistField TimeOfDay where
toPersistValue = PersistTimeOfDay
fromPersistValue (PersistTimeOfDay d) = Right d
fromPersistValue x@(PersistString s) =
case reads s of
(d, _):_ -> Right d
_ -> Left $ "Expected TimeOfDay, received " ++ show x
fromPersistValue x@(PersistByteString s) =
case reads $ unpack s of
(d, _):_ -> Right d
_ -> Left $ "Expected TimeOfDay, received " ++ show x
fromPersistValue x = Left $ "Expected TimeOfDay, received: " ++ show x
sqlType _ = SqlTime
instance PersistField UTCTime where
toPersistValue = PersistUTCTime
fromPersistValue (PersistUTCTime d) = Right d
fromPersistValue x@(PersistString s) =
case reads s of
(d, _):_ -> Right d
_ -> Left $ "Expected UTCTime, received " ++ show x
fromPersistValue x@(PersistByteString s) =
case reads $ unpack s of
(d, _):_ -> Right d
_ -> Left $ "Expected UTCTime, received " ++ show x
fromPersistValue x = Left $ "Expected UTCTime, received: " ++ show x
sqlType _ = SqlDayTime
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
sqlType _ = sqlType (error "this is the problem" :: a)
isNullable _ = True
class PersistEntity val where
data Key val
data Update val
data Filter val
data Order val
data Unique val
entityDef :: val -> EntityDef
toPersistFields :: val -> [SomePersistField]
fromPersistValues :: [PersistValue] -> Either String val
halfDefined :: val
toPersistKey :: Int64 -> Key val
fromPersistKey :: Key val -> Int64
showPersistKey :: Key val -> String
persistFilterToFieldName :: Filter val -> String
persistFilterToFilter :: Filter val -> PersistFilter
persistFilterToValue :: Filter val -> Either PersistValue [PersistValue]
persistOrderToFieldName :: Order val -> String
persistOrderToOrder :: Order val -> PersistOrder
persistUpdateToFieldName :: Update val -> String
persistUpdateToUpdate :: Update val -> PersistUpdate
persistUpdateToValue :: Update val -> PersistValue
persistUniqueToFieldNames :: Unique val -> [String]
persistUniqueToValues :: Unique val -> [PersistValue]
persistUniqueKeys :: val -> [Unique val]
data SomePersistField = forall a. PersistField a => SomePersistField a
instance PersistField SomePersistField where
toPersistValue (SomePersistField a) = toPersistValue a
fromPersistValue x = fmap SomePersistField (fromPersistValue x :: Either String String)
sqlType (SomePersistField a) = sqlType a
class Monad m => PersistBackend m where
insert :: PersistEntity val => val -> m (Key val)
replace :: PersistEntity val => Key val -> val -> m ()
update :: PersistEntity val => Key val -> [Update val] -> m ()
updateWhere :: PersistEntity val => [Filter val] -> [Update val] -> m ()
delete :: PersistEntity val => Key val -> m ()
deleteBy :: PersistEntity val => Unique val -> m ()
deleteWhere :: PersistEntity val => [Filter val] -> m ()
get :: PersistEntity val => Key val -> m (Maybe val)
getBy :: PersistEntity val => Unique val -> m (Maybe (Key val, val))
select :: PersistEntity val
=> [Filter val]
-> [Order val]
-> Int
-> Int
-> Enumerator (Key val, val) m a
selectKeys :: PersistEntity val
=> [Filter val]
-> Enumerator (Key val) m a
count :: PersistEntity val => [Filter val] -> m Int
insertBy :: (PersistEntity v, PersistBackend m)
=> v -> m (Either (Key v, 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
checkUnique :: (PersistEntity val, PersistBackend 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
selectList :: (PersistEntity val, PersistBackend m, Monad m)
=> [Filter val]
-> [Order val]
-> Int
-> Int
-> m [(Key val, val)]
selectList a b c d = do
res <- run $ select a b c d ==<< consume
case res of
Left e -> error $ show e
Right x -> return x
data EntityDef = EntityDef
{ entityName :: String
, entityAttribs :: [String]
, entityColumns :: [(String, String, [String])]
, entityUniques :: [(String, [String])]
, entityDerives :: [String]
}
deriving Show
instance Lift EntityDef where
lift (EntityDef a b c d e) = do
x <- [|EntityDef|]
a' <- lift a
b' <- lift b
c' <- lift c
d' <- lift d
e' <- lift e
return $ x `AppE` a' `AppE` b' `AppE` c' `AppE` d' `AppE` e'
data PersistFilter = Eq | Ne | Gt | Lt | Ge | Le | In | NotIn
deriving (Read, Show)
instance Lift PersistFilter where
lift Eq = [|Eq|]
lift Ne = [|Ne|]
lift Gt = [|Gt|]
lift Lt = [|Lt|]
lift Ge = [|Ge|]
lift Le = [|Le|]
lift In = [|In|]
lift NotIn = [|NotIn|]
data PersistOrder = Asc | Desc
deriving (Read, Show)
instance Lift PersistOrder where
lift Asc = [|Asc|]
lift Desc = [|Desc|]
class PersistEntity a => DeleteCascade a where
deleteCascade :: PersistBackend m => Key a -> m ()
deleteCascadeWhere :: (DeleteCascade a, PersistBackend m)
=> [Filter a] -> m ()
deleteCascadeWhere filts = do
res <- run $ selectKeys filts $ Continue iter
case res of
Left e -> error $ show e
Right () -> return ()
where
iter EOF = Iteratee $ return $ Yield () EOF
iter (Chunks keys) = Iteratee $ do
mapM_ deleteCascade keys
return $ Continue iter
data PersistException = PersistMarshalException String
deriving (Show, Typeable)
instance E.Exception PersistException
data PersistUpdate = Update | Add | Subtract | Multiply | Divide
deriving (Read, Show)
instance Lift PersistUpdate where
lift Update = [|Update|]
lift Add = [|Add|]
lift Subtract = [|Subtract|]
lift Multiply = [|Multiply|]
lift Divide = [|Divide|]