module HLRDB
(
Identifier
, IsIdentifier(..)
, genId
, genId'
, identifierTimestamp
, declareBasic
, declareIntegral
, declareBasicZero
, declareList
, declareSet
, declareHSet
, declareSSet
, declareGlobalBasic
, declareGlobalIntegral
, declareGlobalBasicZero
, declareGlobalList
, declareGlobalSet
, declareGlobalHSet
, declareGlobalSSet
, setExpireIn
, setExpireAt
, encodePath
, foldPath
, Store
, module HLRDB.Core
) where
import HLRDB.Core
import HLRDB.Internal
import Data.Time.Exts.Unix
import Data.Time.Exts.Base (Calendar(Gregorian))
import Database.Redis
import GHC.Int
import GHC.Generics
import Data.String (IsString(fromString))
import Data.Store
import Data.ByteString (ByteString,take,drop,unpack)
import qualified Data.ByteString
import qualified Crypto.Hash as H
import qualified Data.ByteArray as H
import Data.Monoid ((<>))
import System.Random
import GHC.Word
import Data.Bits
import Control.Monad
import qualified Data.ByteString.Base64 as B64
import Data.Hashable (Hashable)
newtype Identifier =
Identifier (Int32,Word32,Word16,Word8)
deriving (Generic,Eq,Ord,Hashable)
instance Show Identifier where
show = show . B64.encode . encode
class IsIdentifier a where
toIdentifier :: a -> Identifier
fromIdentifier :: Identifier -> a
instance IsIdentifier Identifier where
toIdentifier = id
fromIdentifier = id
instance Store Identifier where
size = ConstSize 11
peek = fmap Identifier
$ (,,,) <$> peek <*> peek <*> peek <*> peek
poke (Identifier (a,b,c,d)) =
poke a >> poke b >> poke c >> poke d
genId :: IsIdentifier a => IO a
genId = getCurrentUnixDateTime >>= genId'
offset :: Int64
offset = 2524608000
genId' :: IsIdentifier a => UnixDateTime 'Gregorian -> IO a
genId' (UnixDateTime i64) = do
let t :: Int32 = fromIntegral (i64 offset)
w64 :: Word64 <- randomIO
let (a,w32) = w64tow32w32 w64
let (b,x) = w32tow16w16 w32
let (c,_) = w16tow8w8 x
return $ fromIdentifier $ Identifier (t , a , b , c)
where
w64tow32w32 :: Word64 -> (Word32, Word32)
w64tow32w32 i = (fromIntegral i , fromIntegral (rotate i 32))
w32tow16w16 :: Word32 -> (Word16, Word16)
w32tow16w16 i = (fromIntegral i , fromIntegral (rotate i 16))
w16tow8w8 :: Word16 -> (Word8,Word8)
w16tow8w8 i = (fromIntegral i , fromIntegral (rotate i 8))
identifierTimestamp :: IsIdentifier a => a -> UnixDateTime 'Gregorian
identifierTimestamp i =
let (Identifier (t,_,_,_)) = toIdentifier i in
UnixDateTime $ offset + fromIntegral t
newtype PathName = PathName ByteString
instance IsString PathName where
fromString =
PathName
. Data.ByteString.take 5
. H.convert . H.hashFinalize
. (H.hashUpdate (H.hashInit :: H.Context H.MD5) :: ByteString -> H.Context H.MD5)
. fromString
encodePath :: IsIdentifier a => PathName -> a -> ByteString
encodePath (PathName n) =
(<>) n . encode . toIdentifier
failDecode :: PeekException -> a
failDecode e = error $ "Unexpected data encoding from Redis: " <> show e
decode' :: Store a => ByteString -> a
decode' bs = case Data.Store.decode bs of
Left e -> failDecode e
Right a -> a
declareBasic :: (IsIdentifier i, Store v) => PathName -> RedisBasic i (Maybe v)
declareBasic pathName = RKeyValue $
E (encodePath pathName)
(fmap encode)
. (=<<)
. flip (.) Data.Store.decode $ \case
Left _ -> Nothing
Right x -> Just x
declareIntegral :: (IsIdentifier i, Integral b) => PathName -> RedisIntegral i b
declareIntegral p =
RKeyValueInteger (encodePath p) toInteger fromIntegral
declareBasicZero :: (IsIdentifier i, Store v) => PathName -> v -> RedisBasic i v
declareBasicZero pathName zero = RKeyValue $
E (encodePath pathName)
(Just . encode)
$ \case
Nothing -> zero
Just bs -> case Data.Store.decode bs of
Left _ -> zero
Right x -> x
declareList :: (IsIdentifier i, Store v) => PathName -> Maybe TrimScheme -> RedisList i v
declareList pathName = RList $ E (encodePath pathName) (pure . encode) (decode' . runIdentity)
declareHSet :: (IsIdentifier i, Store s, Store v) => PathName -> RedisHSet i s v
declareHSet pathName =
RHSet (E (encodePath pathName) (pure . encode) (decode' . runIdentity)) (HSET encode decode')
declareSet :: (IsIdentifier i, Store v) => PathName -> RedisSet i v
declareSet pathName =
RSet $ E (encodePath pathName) (pure . encode) (decode' . runIdentity)
declareSSet :: (IsIdentifier i, Store v) => PathName -> Maybe TrimScheme -> RedisSSet i v
declareSSet pathName =
RSortedSet $ E (encodePath pathName) (pure . encode) (decode' . runIdentity)
declareGlobalBasic :: Store v => PathName -> RedisBasic () (Maybe v)
declareGlobalBasic (PathName p) = RKeyValue $ E (const p) (fmap encode) $ \case
Just bs -> case Data.Store.decode bs of
Left _ -> Nothing
Right x -> Just x
Nothing -> Nothing
declareGlobalIntegral :: Integral b => PathName -> RedisIntegral () b
declareGlobalIntegral (PathName p) = RKeyValueInteger (const p) toInteger fromIntegral
declareGlobalBasicZero :: Store v => PathName -> v -> RedisBasic () v
declareGlobalBasicZero (PathName p) zero = RKeyValue $
E (const p)
(Just . encode)
$ \case
Nothing -> zero
Just bs -> case Data.Store.decode bs of
Left _ -> zero
Right x -> x
declareGlobalList :: Store v => PathName -> Maybe TrimScheme -> RedisList () v
declareGlobalList (PathName p) = RList $ E (const p) (pure . encode) (decode' . runIdentity)
declareGlobalHSet :: (Store s , Store v) => PathName -> RedisHSet () s v
declareGlobalHSet (PathName p) =
RHSet (E (const p) (pure . encode) (decode' . runIdentity)) (HSET encode decode')
declareGlobalSet :: Store v => PathName -> RedisSet () v
declareGlobalSet (PathName p) =
RSet $ E (const p) (pure . encode) (decode' . runIdentity)
declareGlobalSSet :: Store v => PathName -> Maybe TrimScheme -> RedisSSet () v
declareGlobalSSet (PathName p) =
RSortedSet $ E (const p) (pure . encode) (decode' . runIdentity)
setExpireIn :: MonadRedis m => RedisStructure v a b -> a -> Integer -> m ()
setExpireIn p k = liftRedis . ignore . expire (primKey p k)
setExpireAt :: MonadRedis m => RedisStructure v a b -> a -> UnixDateTime 'Gregorian -> m ()
setExpireAt p k (UnixDateTime t) = liftRedis $ ignore $ expireat (primKey p k) (toInteger t)
scanGlob :: IsIdentifier i => RedisStructure s i v -> ByteString
scanGlob = pathGlob . extractPathName
where
pathGlob :: ByteString -> ByteString
pathGlob p =
let bs :: [ Word8 ] = unpack p in
foldr (\c a -> enc c <> a) "*" bs
where
enc :: Word8 -> ByteString
enc 42 = "\\*"
enc 63 = "\\?"
enc 91 = "\\["
enc w = Data.ByteString.pack [ w ]
extractPathName :: (IsIdentifier i) => RedisStructure s i v -> ByteString
extractPathName p = Data.ByteString.take 5 $ primKey p zeroIdentifier
where
zeroIdentifier :: (IsIdentifier i) => i
zeroIdentifier = fromIdentifier $ Identifier (0,0,0,0)
foldPath :: (MonadRedis m , IsIdentifier i , Store v) => RedisStructure s i v -> (a -> i -> m a) -> a -> m a
foldPath p f z = go (cursor0,z)
where
go (c,a) = do
(c', bs) <- unwrap $ scanOpts c defaultScanOpts { scanMatch = Just m }
!a' <- Control.Monad.foldM (\x -> f x . fromIdentifier . decodeEx . Data.ByteString.drop 5) a bs
if c' == cursor0
then pure a'
else go (c',a')
m = scanGlob p