module Snap.Snaplet.Redson.Snapless.CRUD
(
create
, update
, delete
, InstanceId
, instanceKey
, modelIndex
, modelTimeline
, collate
, onlyFields
)
where
import Prelude hiding (id)
import Control.Monad.State
import Data.Functor
import Data.Maybe
import Data.Char
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.ByteString.UTF8 as BU (fromString)
import qualified Data.Map as M
import Database.Redis
import Snap.Snaplet.Redson.Snapless.Metamodel
type InstanceId = B.ByteString
instanceKey :: ModelName -> InstanceId -> B.ByteString
instanceKey model id = B.concat [model, ":", id]
keyToId :: B.ByteString -> InstanceId
keyToId key = B.tail $ B.dropWhile (/= 0x3a) key
modelIdKey :: ModelName -> B.ByteString
modelIdKey model = B.concat ["global:", model, ":id"]
modelTimeline :: ModelName -> B.ByteString
modelTimeline model = B.concat ["global:", model, ":timeline"]
modelIndex :: ModelName
-> B.ByteString
-> B.ByteString
-> B.ByteString
modelIndex model field value = B.concat [model, ":", field, ":", value]
collate :: FieldValue -> FieldValue
collate = E.encodeUtf8 . T.toLower .
(T.filter (\c -> (not (isSpace c || isPunctuation c)))) .
E.decodeUtf8
forIndices :: Commit
-> [FieldIndex]
-> (FieldName -> FieldValue -> Redis ())
-> Redis ()
forIndices commit findices action =
mapM_ (\i -> case (M.lookup i commit) of
Just v -> action i v
Nothing -> return ())
(fst <$> findices)
createIndices :: ModelName
-> InstanceId
-> Commit
-> [FieldIndex]
-> Redis ()
createIndices mname id commit findices =
forIndices commit findices $
\i rawVal ->
let
v = collate rawVal
in
when (v /= "") $
sadd (modelIndex mname i v) [id] >> return ()
deleteIndices :: ModelName
-> InstanceId
-> [(FieldName, FieldValue)]
-> Redis ()
deleteIndices mname id commit =
mapM_ (\(i, v) -> srem (modelIndex mname i v) [id])
commit
getOldIndices :: B.ByteString -> [FieldName] -> Redis [Maybe B.ByteString]
getOldIndices key findices = do
reply <- hmget key findices
return $ case reply of
Left _ -> []
Right l -> l
onlyFields :: Commit -> [FieldName] -> [Maybe FieldValue]
onlyFields commit names = map (flip M.lookup commit) names
create :: ModelName
-> Commit
-> [FieldIndex]
-> Redis (Either Reply InstanceId)
create mname commit findices = do
Right n <- incr $ modelIdKey mname
newId <- return $ (BU.fromString . show) n
_ <- hmset (instanceKey mname newId) (M.toList commit)
_ <- lpush (modelTimeline mname) [newId]
createIndices mname newId commit findices
return (Right newId)
update :: ModelName
-> InstanceId
-> Commit
-> [FieldIndex]
-> Redis (Either Reply ())
update mname id commit findices =
let
key = instanceKey mname id
unpacked = M.toList commit
newFields = map fst unpacked
indnames = fst <$> findices
in do
old <- getOldIndices key indnames
hmset key unpacked
deleteIndices mname id $
zip (filter (flip elem newFields) indnames)
(catMaybes old)
createIndices mname id commit findices
return (Right ())
delete :: ModelName
-> InstanceId
-> [FieldIndex]
-> Redis (Either Reply ())
delete mname id findices =
let
key = instanceKey mname id
indnames = fst <$> findices
in do
old <- getOldIndices key indnames
lrem (modelTimeline mname) 1 id >> del [key]
deleteIndices mname id (zip indnames (catMaybes old))
return (Right ())