{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Database.Persist.Redis.Store
    ( execRedisT
    , RedisBackend
    )where

import Control.Monad.IO.Class (MonadIO (..))
import Data.Aeson(FromJSON(..), ToJSON(..))
import Data.Text (Text, pack)
import qualified Database.Redis as R
import Web.HttpApiData (ToHttpApiData (..), FromHttpApiData (..), parseUrlPieceMaybe)
import Web.PathPieces (PathPiece(..))

import Database.Persist
import Database.Persist.Redis.Config (RedisT, thisConnection)
import Database.Persist.Redis.Internal
import Database.Persist.Redis.Update
import qualified Database.Persist.Sql as Sql

type RedisBackend = R.Connection

-- | Fetches a next key from <object>_id record
createKey :: (R.RedisCtx m f, PersistEntity val) => val -> m (f Integer)
createKey :: val -> m (f Integer)
createKey val
val = do
    let keyId :: ByteString
keyId = val -> ByteString
forall val. PersistEntity val => val -> ByteString
toKeyId val
val
    ByteString -> m (f Integer)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> m (f Integer)
R.incr ByteString
keyId

desugar :: R.TxResult a -> Either String a
desugar :: TxResult a -> Either String a
desugar (R.TxSuccess a
x) =  a -> Either String a
forall a b. b -> Either a b
Right a
x
desugar TxResult a
R.TxAborted = String -> Either String a
forall a b. a -> Either a b
Left String
"Transaction aborted!"
desugar (R.TxError String
string) = String -> Either String a
forall a b. a -> Either a b
Left String
string

-- | Execute Redis transaction inside RedisT monad transformer
execRedisT :: (MonadIO m) => R.RedisTx (R.Queued a) -> RedisT m a
execRedisT :: RedisTx (Queued a) -> RedisT m a
execRedisT RedisTx (Queued a)
action = do
    Connection
conn <- RedisT m Connection
forall (m :: * -> *). Monad m => RedisT m Connection
thisConnection
    TxResult a
result <- IO (TxResult a) -> ReaderT Connection m (TxResult a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TxResult a) -> ReaderT Connection m (TxResult a))
-> IO (TxResult a) -> ReaderT Connection m (TxResult a)
forall a b. (a -> b) -> a -> b
$ Connection -> Redis (TxResult a) -> IO (TxResult a)
forall a. Connection -> Redis a -> IO a
R.runRedis Connection
conn (Redis (TxResult a) -> IO (TxResult a))
-> Redis (TxResult a) -> IO (TxResult a)
forall a b. (a -> b) -> a -> b
$ RedisTx (Queued a) -> Redis (TxResult a)
forall a. RedisTx (Queued a) -> Redis (TxResult a)
R.multiExec RedisTx (Queued a)
action -- this is the question if we should support transaction here
    let r :: Either String a
r = TxResult a -> Either String a
forall a. TxResult a -> Either String a
desugar TxResult a
result
    case Either String a
r of
        (Right a
x) -> a -> RedisT m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
        (Left String
x)  -> IO a -> RedisT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> RedisT m a) -> IO a -> RedisT m a
forall a b. (a -> b) -> a -> b
$ String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
x

instance HasPersistBackend R.Connection where
  type BaseBackend R.Connection = R.Connection
  persistBackend :: Connection -> BaseBackend Connection
persistBackend = Connection -> BaseBackend Connection
forall a. a -> a
id

instance PersistCore R.Connection where
    newtype BackendKey R.Connection = RedisKey Text
        deriving (Int -> BackendKey Connection -> ShowS
[BackendKey Connection] -> ShowS
BackendKey Connection -> String
(Int -> BackendKey Connection -> ShowS)
-> (BackendKey Connection -> String)
-> ([BackendKey Connection] -> ShowS)
-> Show (BackendKey Connection)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BackendKey Connection] -> ShowS
$cshowList :: [BackendKey Connection] -> ShowS
show :: BackendKey Connection -> String
$cshow :: BackendKey Connection -> String
showsPrec :: Int -> BackendKey Connection -> ShowS
$cshowsPrec :: Int -> BackendKey Connection -> ShowS
Show, ReadPrec [BackendKey Connection]
ReadPrec (BackendKey Connection)
Int -> ReadS (BackendKey Connection)
ReadS [BackendKey Connection]
(Int -> ReadS (BackendKey Connection))
-> ReadS [BackendKey Connection]
-> ReadPrec (BackendKey Connection)
-> ReadPrec [BackendKey Connection]
-> Read (BackendKey Connection)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BackendKey Connection]
$creadListPrec :: ReadPrec [BackendKey Connection]
readPrec :: ReadPrec (BackendKey Connection)
$creadPrec :: ReadPrec (BackendKey Connection)
readList :: ReadS [BackendKey Connection]
$creadList :: ReadS [BackendKey Connection]
readsPrec :: Int -> ReadS (BackendKey Connection)
$creadsPrec :: Int -> ReadS (BackendKey Connection)
Read, BackendKey Connection -> BackendKey Connection -> Bool
(BackendKey Connection -> BackendKey Connection -> Bool)
-> (BackendKey Connection -> BackendKey Connection -> Bool)
-> Eq (BackendKey Connection)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BackendKey Connection -> BackendKey Connection -> Bool
$c/= :: BackendKey Connection -> BackendKey Connection -> Bool
== :: BackendKey Connection -> BackendKey Connection -> Bool
$c== :: BackendKey Connection -> BackendKey Connection -> Bool
Eq, Eq (BackendKey Connection)
Eq (BackendKey Connection)
-> (BackendKey Connection -> BackendKey Connection -> Ordering)
-> (BackendKey Connection -> BackendKey Connection -> Bool)
-> (BackendKey Connection -> BackendKey Connection -> Bool)
-> (BackendKey Connection -> BackendKey Connection -> Bool)
-> (BackendKey Connection -> BackendKey Connection -> Bool)
-> (BackendKey Connection
    -> BackendKey Connection -> BackendKey Connection)
-> (BackendKey Connection
    -> BackendKey Connection -> BackendKey Connection)
-> Ord (BackendKey Connection)
BackendKey Connection -> BackendKey Connection -> Bool
BackendKey Connection -> BackendKey Connection -> Ordering
BackendKey Connection
-> BackendKey Connection -> BackendKey Connection
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BackendKey Connection
-> BackendKey Connection -> BackendKey Connection
$cmin :: BackendKey Connection
-> BackendKey Connection -> BackendKey Connection
max :: BackendKey Connection
-> BackendKey Connection -> BackendKey Connection
$cmax :: BackendKey Connection
-> BackendKey Connection -> BackendKey Connection
>= :: BackendKey Connection -> BackendKey Connection -> Bool
$c>= :: BackendKey Connection -> BackendKey Connection -> Bool
> :: BackendKey Connection -> BackendKey Connection -> Bool
$c> :: BackendKey Connection -> BackendKey Connection -> Bool
<= :: BackendKey Connection -> BackendKey Connection -> Bool
$c<= :: BackendKey Connection -> BackendKey Connection -> Bool
< :: BackendKey Connection -> BackendKey Connection -> Bool
$c< :: BackendKey Connection -> BackendKey Connection -> Bool
compare :: BackendKey Connection -> BackendKey Connection -> Ordering
$ccompare :: BackendKey Connection -> BackendKey Connection -> Ordering
$cp1Ord :: Eq (BackendKey Connection)
Ord, BackendKey Connection -> PersistValue
PersistValue -> Either Text (BackendKey Connection)
(BackendKey Connection -> PersistValue)
-> (PersistValue -> Either Text (BackendKey Connection))
-> PersistField (BackendKey Connection)
forall a.
(a -> PersistValue)
-> (PersistValue -> Either Text a) -> PersistField a
fromPersistValue :: PersistValue -> Either Text (BackendKey Connection)
$cfromPersistValue :: PersistValue -> Either Text (BackendKey Connection)
toPersistValue :: BackendKey Connection -> PersistValue
$ctoPersistValue :: BackendKey Connection -> PersistValue
PersistField, Value -> Parser [BackendKey Connection]
Value -> Parser (BackendKey Connection)
(Value -> Parser (BackendKey Connection))
-> (Value -> Parser [BackendKey Connection])
-> FromJSON (BackendKey Connection)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [BackendKey Connection]
$cparseJSONList :: Value -> Parser [BackendKey Connection]
parseJSON :: Value -> Parser (BackendKey Connection)
$cparseJSON :: Value -> Parser (BackendKey Connection)
FromJSON, [BackendKey Connection] -> Encoding
[BackendKey Connection] -> Value
BackendKey Connection -> Encoding
BackendKey Connection -> Value
(BackendKey Connection -> Value)
-> (BackendKey Connection -> Encoding)
-> ([BackendKey Connection] -> Value)
-> ([BackendKey Connection] -> Encoding)
-> ToJSON (BackendKey Connection)
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [BackendKey Connection] -> Encoding
$ctoEncodingList :: [BackendKey Connection] -> Encoding
toJSONList :: [BackendKey Connection] -> Value
$ctoJSONList :: [BackendKey Connection] -> Value
toEncoding :: BackendKey Connection -> Encoding
$ctoEncoding :: BackendKey Connection -> Encoding
toJSON :: BackendKey Connection -> Value
$ctoJSON :: BackendKey Connection -> Value
ToJSON)

instance PersistStoreRead R.Connection where
    get :: Key record -> ReaderT Connection m (Maybe record)
get Key record
k = do
        [(ByteString, ByteString)]
r <- RedisTx (Queued [(ByteString, ByteString)])
-> RedisT m [(ByteString, ByteString)]
forall (m :: * -> *) a.
MonadIO m =>
RedisTx (Queued a) -> RedisT m a
execRedisT (RedisTx (Queued [(ByteString, ByteString)])
 -> RedisT m [(ByteString, ByteString)])
-> RedisTx (Queued [(ByteString, ByteString)])
-> RedisT m [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ ByteString -> RedisTx (Queued [(ByteString, ByteString)])
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> m (f [(ByteString, ByteString)])
R.hgetall (Key record -> ByteString
forall val. PersistEntity val => Key val -> ByteString
unKey Key record
k)
        if [(ByteString, ByteString)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ByteString, ByteString)]
r
            then Maybe record -> ReaderT Connection m (Maybe record)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe record
forall a. Maybe a
Nothing
            else do
                Entity Key record
_ record
val <- IO (Entity record) -> ReaderT Connection m (Entity record)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Entity record) -> ReaderT Connection m (Entity record))
-> IO (Entity record) -> ReaderT Connection m (Entity record)
forall a b. (a -> b) -> a -> b
$ Key record -> [(ByteString, ByteString)] -> IO (Entity record)
forall (m :: * -> *) val.
(MonadFail m, PersistEntity val) =>
Key val -> [(ByteString, ByteString)] -> m (Entity val)
mkEntity Key record
k [(ByteString, ByteString)]
r
                Maybe record -> ReaderT Connection m (Maybe record)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe record -> ReaderT Connection m (Maybe record))
-> Maybe record -> ReaderT Connection m (Maybe record)
forall a b. (a -> b) -> a -> b
$ record -> Maybe record
forall a. a -> Maybe a
Just record
val

instance PersistStoreWrite R.Connection where
    insert :: record -> ReaderT Connection m (Key record)
insert record
val = do
        Integer
keyId <- RedisTx (Queued Integer) -> RedisT m Integer
forall (m :: * -> *) a.
MonadIO m =>
RedisTx (Queued a) -> RedisT m a
execRedisT (RedisTx (Queued Integer) -> RedisT m Integer)
-> RedisTx (Queued Integer) -> RedisT m Integer
forall a b. (a -> b) -> a -> b
$ record -> RedisTx (Queued Integer)
forall (m :: * -> *) (f :: * -> *) val.
(RedisCtx m f, PersistEntity val) =>
val -> m (f Integer)
createKey record
val
        let textKey :: Text
textKey = record -> Integer -> Text
forall val. PersistEntity val => val -> Integer -> Text
toKeyText record
val Integer
keyId
        Key record
key <- IO (Key record) -> ReaderT Connection m (Key record)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Key record) -> ReaderT Connection m (Key record))
-> IO (Key record) -> ReaderT Connection m (Key record)
forall a b. (a -> b) -> a -> b
$ Text -> IO (Key record)
forall (m :: * -> *) val.
(Monad m, MonadFail m, PersistEntity val) =>
Text -> m (Key val)
toKey Text
textKey
        Key record -> record -> ReaderT Connection m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
insertKey Key record
key record
val
        Key record -> ReaderT Connection m (Key record)
forall (m :: * -> *) a. Monad m => a -> m a
return Key record
key

    insertKey :: Key record -> record -> ReaderT Connection m ()
insertKey Key record
k record
val = do
        let fields :: [(ByteString, ByteString)]
fields = record -> [(ByteString, ByteString)]
forall val. PersistEntity val => val -> [(ByteString, ByteString)]
toInsertFields record
val
        -- Inserts a hash map into <object>_<id> record
        Status
_ <- RedisTx (Queued Status) -> RedisT m Status
forall (m :: * -> *) a.
MonadIO m =>
RedisTx (Queued a) -> RedisT m a
execRedisT (RedisTx (Queued Status) -> RedisT m Status)
-> RedisTx (Queued Status) -> RedisT m Status
forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, ByteString)] -> RedisTx (Queued Status)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> [(ByteString, ByteString)] -> m (f Status)
R.hmset (Key record -> ByteString
forall val. PersistEntity val => Key val -> ByteString
unKey Key record
k) [(ByteString, ByteString)]
fields
        () -> ReaderT Connection m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    repsert :: Key record -> record -> ReaderT Connection m ()
repsert Key record
k record
val = do
        Integer
_ <- RedisTx (Queued Integer) -> RedisT m Integer
forall (m :: * -> *) a.
MonadIO m =>
RedisTx (Queued a) -> RedisT m a
execRedisT (RedisTx (Queued Integer) -> RedisT m Integer)
-> RedisTx (Queued Integer) -> RedisT m Integer
forall a b. (a -> b) -> a -> b
$ [ByteString] -> RedisTx (Queued Integer)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
[ByteString] -> m (f Integer)
R.del [Key record -> ByteString
forall val. PersistEntity val => Key val -> ByteString
unKey Key record
k]
        Key record -> record -> ReaderT Connection m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
insertKey Key record
k record
val
        () -> ReaderT Connection m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    replace :: Key record -> record -> ReaderT Connection m ()
replace Key record
k record
val = do
        Key record -> ReaderT Connection m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m ()
delete Key record
k
        Key record -> record -> ReaderT Connection m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
insertKey Key record
k record
val
        () -> ReaderT Connection m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    delete :: Key record -> ReaderT Connection m ()
delete Key record
k = do
        Integer
r <- RedisTx (Queued Integer) -> RedisT m Integer
forall (m :: * -> *) a.
MonadIO m =>
RedisTx (Queued a) -> RedisT m a
execRedisT (RedisTx (Queued Integer) -> RedisT m Integer)
-> RedisTx (Queued Integer) -> RedisT m Integer
forall a b. (a -> b) -> a -> b
$ [ByteString] -> RedisTx (Queued Integer)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
[ByteString] -> m (f Integer)
R.del [Key record -> ByteString
forall val. PersistEntity val => Key val -> ByteString
unKey Key record
k]
        case Integer
r of
            Integer
0 -> IO () -> ReaderT Connection m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Connection m ())
-> IO () -> ReaderT Connection m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"there is no such key!"
            Integer
1 -> () -> ReaderT Connection m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Integer
_ -> IO () -> ReaderT Connection m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Connection m ())
-> IO () -> ReaderT Connection m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"there are a lot of such keys!"

    update :: Key record -> [Update record] -> ReaderT Connection m ()
update Key record
_ [] = () -> ReaderT Connection m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    update Key record
k [Update record]
upds = do
        [(ByteString, ByteString)]
r <- RedisTx (Queued [(ByteString, ByteString)])
-> RedisT m [(ByteString, ByteString)]
forall (m :: * -> *) a.
MonadIO m =>
RedisTx (Queued a) -> RedisT m a
execRedisT (RedisTx (Queued [(ByteString, ByteString)])
 -> RedisT m [(ByteString, ByteString)])
-> RedisTx (Queued [(ByteString, ByteString)])
-> RedisT m [(ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ ByteString -> RedisTx (Queued [(ByteString, ByteString)])
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> m (f [(ByteString, ByteString)])
R.hgetall (Key record -> ByteString
forall val. PersistEntity val => Key val -> ByteString
unKey Key record
k)
        if [(ByteString, ByteString)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ByteString, ByteString)]
r
            then () -> ReaderT Connection m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            else do
                Entity record
v <- IO (Entity record) -> ReaderT Connection m (Entity record)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Entity record) -> ReaderT Connection m (Entity record))
-> IO (Entity record) -> ReaderT Connection m (Entity record)
forall a b. (a -> b) -> a -> b
$ Key record -> [(ByteString, ByteString)] -> IO (Entity record)
forall (m :: * -> *) val.
(MonadFail m, PersistEntity val) =>
Key val -> [(ByteString, ByteString)] -> m (Entity val)
mkEntity Key record
k [(ByteString, ByteString)]
r
                let (Entity Key record
_ record
val) = Entity record -> [Update record] -> Entity record
forall val.
PersistEntity val =>
Entity val -> [Update val] -> Entity val
cmdUpdate Entity record
v [Update record]
upds
                Key record -> record -> ReaderT Connection m ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> record -> ReaderT backend m ()
insertKey Key record
k record
val
        () -> ReaderT Connection m ()
forall (m :: * -> *) a. Monad m => a -> m a
return()

instance ToHttpApiData (BackendKey RedisBackend) where
    toUrlPiece :: BackendKey Connection -> Text
toUrlPiece (RedisKey txt) = Text
txt

instance FromHttpApiData (BackendKey RedisBackend) where
    parseUrlPiece :: Text -> Either Text (BackendKey Connection)
parseUrlPiece = BackendKey Connection -> Either Text (BackendKey Connection)
forall (m :: * -> *) a. Monad m => a -> m a
return (BackendKey Connection -> Either Text (BackendKey Connection))
-> (Text -> BackendKey Connection)
-> Text
-> Either Text (BackendKey Connection)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> BackendKey Connection
RedisKey
-- some checking that entity exists and it is in format of entityname_id is omitted

instance PathPiece (BackendKey RedisBackend) where
  toPathPiece :: BackendKey Connection -> Text
toPathPiece   = BackendKey Connection -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece
  fromPathPiece :: Text -> Maybe (BackendKey Connection)
fromPathPiece = Text -> Maybe (BackendKey Connection)
forall a. FromHttpApiData a => Text -> Maybe a
parseUrlPieceMaybe

instance Sql.PersistFieldSql (BackendKey RedisBackend) where
    sqlType :: Proxy (BackendKey Connection) -> SqlType
sqlType Proxy (BackendKey Connection)
_ = Text -> SqlType
Sql.SqlOther (String -> Text
pack String
"doesn't make much sense for Redis backend")