Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 2208daf6a0
Fetching contributors…

Cannot retrieve contributors at this time

220 lines (176 sloc) 6.859 kb
{-# LANGUAGE OverloadedStrings #-}
{-|
Snap-agnostic low-level CRUD operations. No model definitions are used
on this level. Instead, objects must be
This module may be used for batch uploading of database data.
-}
module Snap.Snaplet.Redson.Snapless.CRUD
( -- * CRUD operations
create
, update
, delete
-- * Redis helpers
, 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
------------------------------------------------------------------------------
-- | Build Redis key given model name and instance id
instanceKey :: ModelName -> InstanceId -> B.ByteString
instanceKey model id = B.concat [model, ":", id]
------------------------------------------------------------------------------
-- | Cut instance model and id from Redis key
--
-- >>> keyToId "case:32198"
-- 32198
keyToId :: B.ByteString -> InstanceId
keyToId key = B.tail $ B.dropWhile (/= 0x3a) key
------------------------------------------------------------------------------
-- | Get Redis key which stores id counter for model
modelIdKey :: ModelName -> B.ByteString
modelIdKey model = B.concat ["global:", model, ":id"]
------------------------------------------------------------------------------
-- | Get Redis key which stores timeline for model
modelTimeline :: ModelName -> B.ByteString
modelTimeline model = B.concat ["global:", model, ":timeline"]
------------------------------------------------------------------------------
-- | Build Redis key for field index of model.
modelIndex :: ModelName
-> B.ByteString -- ^ Field name
-> B.ByteString -- ^ Field value
-> B.ByteString
modelIndex model field value = B.concat [model, ":", field, ":", value]
------------------------------------------------------------------------------
-- | Strip value of punctuation, spaces, convert all to lowercase.
collate :: FieldValue -> FieldValue
collate = E.encodeUtf8 . T.toLower .
(T.filter (\c -> (not (isSpace c || isPunctuation c)))) .
E.decodeUtf8
------------------------------------------------------------------------------
-- | Perform provided action for every indexed field in commit.
--
-- Action is called with index field name and its value in commit.
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)
------------------------------------------------------------------------------
-- | Create reverse indices for new commit.
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 ()
------------------------------------------------------------------------------
-- | Remove indices previously created by commit (should contain all
-- indexed fields only).
deleteIndices :: ModelName
-> InstanceId -- ^ Instance id.
-> [(FieldName, FieldValue)] -- ^ Commit with old
-- indexed values (zipped
-- from HMGET).
-> Redis ()
deleteIndices mname id commit =
mapM_ (\(i, v) -> srem (modelIndex mname i v) [id])
commit
------------------------------------------------------------------------------
-- | Get old values of index fields stored under key.
getOldIndices :: B.ByteString -> [FieldName] -> Redis [Maybe B.ByteString]
getOldIndices key findices = do
reply <- hmget key findices
return $ case reply of
Left _ -> []
Right l -> l
------------------------------------------------------------------------------
-- | Extract values of named fields from commit.
onlyFields :: Commit -> [FieldName] -> [Maybe FieldValue]
onlyFields commit names = map (flip M.lookup commit) names
------------------------------------------------------------------------------
-- | Create new instance in Redis and indices for it.
--
-- Bump model id counter and update timeline, return new instance id.
--
-- TODO: Support pubsub from here
create :: ModelName -- ^ Model name
-> Commit -- ^ Key-values of instance data
-> [FieldIndex]
-> Redis (Either Reply InstanceId)
create mname commit findices = do
-- Take id from global:model:id
Right n <- incr $ modelIdKey mname
newId <- return $ (BU.fromString . show) n
-- Save new instance
_ <- hmset (instanceKey mname newId) (M.toList commit)
_ <- lpush (modelTimeline mname) [newId]
createIndices mname newId commit findices
return (Right newId)
------------------------------------------------------------------------------
-- | Modify existing instance in Redis, updating indices
--
-- TODO: Handle non-existing instance as error here?
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 ())
------------------------------------------------------------------------------
-- | Remove existing instance in Redis, cleaning up old indices.
--
-- Does not check if instance exists.
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 ())
Jump to Line
Something went wrong with that request. Please try again.