module Database.Persist
(
PersistValue (..)
, SqlType (..)
, PersistField (..)
, PersistEntity (..)
) where
import Data.Time (Day, TimeOfDay, UTCTime)
import Data.ByteString.Char8 (ByteString, unpack)
import qualified Data.ByteString.UTF8 as BSU
import Control.Applicative
import Data.Typeable (Typeable)
import Data.Int (Int64)
import Text.Hamlet
import qualified Data.Text as T
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO)
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
| 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 $ BSU.toString 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 = BSU.fromString <$> fromPersistValue x
sqlType _ = SqlBlob
instance PersistField T.Text where
toPersistValue = PersistString . T.unpack
fromPersistValue = fmap T.pack . fromPersistValue
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 _ = SqlInteger
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 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
type PersistMonad val :: (* -> *) -> * -> *
data Key val
data Update val
data Filter val
data Order val
data Unique val
initialize :: MonadCatchIO m => val -> (PersistMonad val) m ()
insert :: MonadCatchIO m => val -> (PersistMonad val) m (Key val)
replace :: MonadCatchIO m => Key val -> val -> (PersistMonad val) m ()
update :: MonadCatchIO m => Key val -> [Update val]
-> (PersistMonad val) m ()
updateWhere :: MonadCatchIO m => [Filter val] -> [Update val]
-> (PersistMonad val) m ()
delete :: MonadCatchIO m => Key val -> (PersistMonad val) m ()
deleteBy :: MonadCatchIO m => Unique val -> (PersistMonad val) m ()
deleteWhere :: MonadCatchIO m => [Filter val] -> (PersistMonad val) m ()
get :: MonadCatchIO m => Key val -> (PersistMonad val) m (Maybe val)
getBy :: MonadCatchIO m => Unique val
-> (PersistMonad val) m (Maybe (Key val, val))
select :: MonadCatchIO m => [Filter val] -> [Order val]
-> (PersistMonad val) m [(Key val, val)]