ez-couch 0.3.1 → 0.4.0

raw patch · 23 files changed

+774/−301 lines, 23 filesdep +hashabledep +vectordep −sybPVP ok

version bump matches the API change (PVP)

Dependencies added: hashable, vector

Dependencies removed: syb

API changes (from Hackage documentation)

Files

• ez-couch.cabal +11/−6
• src/Control/Retry.hs +1/−1
• src/EZCouch.hs +47/−26
• src/EZCouch/Action.hs +13/−6
• src/EZCouch/Base62.hs +31/−0
• src/EZCouch/Design.hs +52/−19
• src/EZCouch/Doc.hs +0/−27
• src/EZCouch/Entity.hs +27/−0
• src/EZCouch/EntityIsolation.hs +112/−0
• src/EZCouch/Ids.hs +9/−22
• src/EZCouch/Isolation.hs +6/−5
• src/EZCouch/JS.hs +74/−0
• src/EZCouch/Model/Design.hs +3/−3
• src/EZCouch/Model/EntityIsolation.hs +24/−0
• src/EZCouch/Model/Isolation.hs +3/−3
• src/EZCouch/Model/View.hs +1/−1
• src/EZCouch/ReadAction.hs +119/−44
• src/EZCouch/Sweeper.hs +45/−0
• src/EZCouch/Try.hs +3/−2
• src/EZCouch/Types.hs +20/−32
• src/EZCouch/View.hs +141/−21
• src/EZCouch/WriteAction.hs +32/−29
• src/Util/PrettyPrint.hs +0/−54

@@ -1,5 +1,5 @@ name:               ez-couch-version:            0.3.1+version:            0.4.0 cabal-version:      >=1.8 build-type:         Simple license:            MIT@@ -10,7 +10,7 @@ stability:          experimental homepage:           https://github.com/nikita-volkov/ez-couch bug-reports:        https://github.com/nikita-volkov/ez-couch/issues-synopsis:           A high level library for working with CouchDB+synopsis:           A high level static library for working with CouchDB description:        EZCouch is a library which takes a mission of bringing the topmost level of abstraction for working with CouchDB from Haskell. It abstracts away from loose concepts of this database and brings a strict static API over standard ADTs.  category:           Database, CouchDB @@ -20,13 +20,15 @@   exposed-modules:  EZCouch   other-modules:    Control.Retry                     Database.CouchDB.Conduit.View.Query-                    EZCouch.Doc+                    EZCouch.Base62+                    EZCouch.Entity                     EZCouch.Action                     EZCouch.WriteAction                     EZCouch.Design                     EZCouch.Encoding                     EZCouch.Ids                     EZCouch.Isolation+                    EZCouch.JS                     EZCouch.Model.Design                     EZCouch.Model.Isolation                     EZCouch.Model.View@@ -38,7 +40,9 @@                     EZCouch.View                     Network.HTTP.Conduit.Request                     Util.Logging-                    Util.PrettyPrint+                    EZCouch.Model.EntityIsolation+                    EZCouch.EntityIsolation+                    EZCouch.Sweeper   build-depends:    base >= 4.5 && < 5,                     ghc-prim >= 0.2,                     time >= 1.4,@@ -50,7 +54,6 @@                     hslogger >= 1.2,                     old-locale >= 1.0,                     text >= 0.11,-                    syb >= 0.3,                     containers >= 0.4,                     unordered-containers >= 0.2,                     bytestring >= 0.9,@@ -60,7 +63,9 @@                     resourcet >= 0.3,                     string-conversions >= 0.2,                     classy-prelude >= 0.4.4,-                    classy-prelude-conduit >= 0.4+                    classy-prelude-conduit >= 0.4,+                    hashable >= 1.1,+                    vector   source-repository head   type:             git

@@ -24,7 +24,7 @@         exceptionInterval = listToMaybe . drop attempt . exceptionIntervals         processException e            | Just i <- exceptionInterval e = do-              Logging.logM 3 "Control.Retry"+              Logging.logM 0 "Control.Retry"                 $ "Error occurred: " ++ show e ++ ". "                    ++ "Retrying with a " ++ show (i `div` sec) ++ "s delay."               unless (i == 0) (liftIO (threadDelay i)) 

@@ -1,68 +1,89 @@ {-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, ScopedTypeVariables, DeriveDataTypeable, DeriveFunctor #-}--- | EZCouch is a library which takes a mission of bringing the topmost level of abstraction for working with CouchDB from Haskell. It abstracts away from loose concepts of this database and brings a strict static API over standard ADTs. +-- | EZCouch is a library which takes a mission of bringing the topmost level of abstraction for working with CouchDB in Haskell. It abstracts away from loose concepts of this database and brings a strict static API over standard ADTs.  module EZCouch (   -- * CRUD Monadic Functions for Working with Records   -- | All monadic functions are split into /CRUD/ categories. The functions with a /Multiple/ suffix are better alternatives for performing multiple operations at once.    -- ** Creating -  create,-  createMultiple,+  createEntity,+  createEntities,   -- ** Reading -  -- | All reading actions accept a `ReadOptions` parameter which specifies how filtering and ordering should go.-  readOne,-  readMultiple,-  readExists,-  readIds,+  readEntities,+  readRandomEntities,+  readEntity,+  readKeysExist,   readKeys,   readCount,+  KeysSelection(..),   -- ** Updating -  update,-  updateMultiple,+  updateEntity,+  updateEntities,   -- ** Deleting -  delete,-  deleteMultiple,+  deleteEntity,+  deleteEntities,      -- * Server Time   readTime,    -- * Working with Views-  createOrUpdateView,  +  View(..),+  ViewKey(..),    -- * Transactions-  -- | CouchDB doesn't provide a way to do traditional locking-based transactions, as it applies an Optimistic Concurrency Control strategy (<http://en.wikipedia.org/wiki/Optimistic_concurrency_control>). EZCouch approaches the issue by abstracting over it.-  inIsolation,-+  -- | CouchDB doesn't provide a way to do traditional locking-based transactions, as it applies an Optimistic Concurrency Control strategy (<http://en.wikipedia.org/wiki/Optimistic_concurrency_control>). EZCouch approaches the issue by providing a way to easily isolate entities from being accessed by concurrent clients, which you can use to build all kinds of transactions upon.+  isolateEntity,+  isolateEntities,+  releaseIsolation,+  releaseIsolations,+  deleteIsolation,+  deleteIsolations,+  Isolation,+  isolationEntity,   -- * Types   Persisted(..),-  EZCouchException(..),-  View(..),-  ReadOptions(..),-  readOptions,-  ConnectionSettings(..),-  defaultPort,    -- * Helpers   tryOperation,    -- * Execution Monad-  MonadAction(..),+  MonadAction,   run,   runWithManager,+  ConnectionSettings(..),+  defaultPort,+  EZCouchException(..),    -- * Classes which records should implement-  Doc(..),+  Entity(..),   -- ** Aeson re-exports   ToJSON(..),   FromJSON(..) ) where +import Prelude ()+import ClassyPrelude+ import EZCouch.Action import EZCouch.Types import EZCouch.ReadAction import EZCouch.WriteAction import EZCouch.View-import EZCouch.Doc+import EZCouch.Entity import EZCouch.Time-import EZCouch.Isolation import EZCouch.Try+import EZCouch.EntityIsolation+import qualified EZCouch.Sweeper as Sweeper import Data.Aeson++import Control.Monad.Reader+import Control.Monad.Trans.Resource+import qualified Network.HTTP.Conduit as HTTP++runWithManager manager settings action = +  flip runReaderT (settings, manager) $ runResourceT $ do+    resourceForkIO $ lift $ Sweeper.runSweeper+    lift $ action++run settings action = HTTP.withManager $ \manager -> +  runWithManager manager settings action+

@@ -19,6 +19,18 @@  logM lvl = Logging.logM lvl "EZCouch.Action" ++data ConnectionSettings +  = ConnectionSettings {  +      connectionSettingsHost :: Text,+      connectionSettingsPort :: Int,+      connectionSettingsAuth :: Maybe (Text, Text),+      connectionSettingsDatabase :: Text+    }++defaultPort = 5984 :: Int++ -- | All EZCouch operations are performed in this monad. class (MonadBaseControl IO m, MonadResource m, MonadReader (ConnectionSettings, Manager) m) => MonadAction m where @@ -46,7 +58,7 @@         queryString = query,         requestBody = RequestBodyLBS body,         checkStatus = checkStatus,-        responseTimeout = Just $ 10 ^ 6 * 10+        responseTimeout = Just $ 10 ^ 6 * 30       }       where         authenticated@@ -93,10 +105,5 @@ putAction path = getResponseJSON HTTP.methodPut (Just path) postAction path = getResponseJSON HTTP.methodPost (Just path) getAction path = getResponseJSON HTTP.methodGet (Just path)--runWithManager manager settings action = -  runReaderT action (settings, manager)-run settings action = HTTP.withManager $ \manager -> -  runWithManager manager settings action  packPath = Blaze.toByteString . HTTP.encodePathSegments . filter (/="")

@@ -0,0 +1,31 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+module EZCouch.Base62 where++import Prelude ()+import ClassyPrelude+import qualified Data.List as List+import Data.Vector ((!))+import Data.Bits++chars = ['0'..'9'] ++ ['A'..'Z'] ++ ['a'..'z']+charsVector = asVector . fromList $ chars+charsLength = fromIntegral $ length charsVector++-- | Produces individual values for the whole range of ints including negatives. If you know that the value will allways be positive use `encodeUnsigned` instead.+encodeSigned64 = encodeUnsigned . zzEncode64 ++encodeUnsigned 0 = charsVector ! 0 : []+encodeUnsigned a = if a >= 0+  then reverse . encodeUnsigned' $ a+  else error $ "EZCouch.Base62.encodeUnsigned: Negative value: " ++ show a+  where+    encodeUnsigned' 0 = []+    encodeUnsigned' a = charsVector ! fromIntegral c : encodeUnsigned' b+      where+        b = div a charsLength +        c = mod a charsLength++zzEncode64 :: Int64 -> Word64+zzEncode64 x = fromIntegral ((x `shiftL` 1) `xor` (x `shiftR` 63))

@@ -4,43 +4,76 @@ import Prelude () import ClassyPrelude import GHC.Generics-import EZCouch.Doc+import EZCouch.Entity import Data.Aeson import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP.Conduit as HTTP+import qualified Data.Map as Map -import EZCouch.ReadAction import EZCouch.Action import EZCouch.WriteAction import EZCouch.Types import EZCouch.Parsing  import EZCouch.Model.Design+import EZCouch.Model.View (View)+import qualified EZCouch.Model.View as View  -readDesign :: (MonadAction m, Doc a) => m (Maybe (Persisted (Design a)))+readDesign :: (MonadAction m, Entity a) => m (Maybe (Persisted (Design a))) readDesign = result   where-    result -      = (flip catch) processException-        $ getAction ["_design", designName] [] "" -          >>= runParser errorPersistedParser-          >>= return . either (const Nothing) Just+    result = (flip catch) processException $ +      getAction ["_design", designName] [] "" +        >>= runParser errorPersistedParser+        >>= return . either (const Nothing) Just       where-        designName = docType $ (undefined :: m (Maybe (Persisted (Design a))) -> a) result+        designName = entityType $ (undefined :: m (Maybe (Persisted (Design a))) -> a) result         processException (HTTP.StatusCodeException (HTTP.Status 404 _) _) = return Nothing         processException e = throwIO e -createOrUpdateDesign :: (MonadAction m, Doc a) => Design a -> m ()-createOrUpdateDesign design = do-  design' <- readDesign-  case design' of-    Just (Persisted id rev design'') -> if design'' == design-      then return ()-      else void $ update $ Persisted id rev design-    Nothing -> void $ createDesign design+createOrUpdateDesign :: (MonadAction m, Entity a) => Design a -> m (Persisted (Design a))+createOrUpdateDesign design = +  createDesign design `catch` \e -> case e of+    OperationException {} -> do+      design' <- readDesign+      case design' of+        Just design'@(Persisted id rev design'') -> if design'' == design+          then return design'+          else updateEntity $ Persisted id rev design+        Nothing -> throwIO e+    _ -> throwIO e -createDesign :: (MonadAction m, Doc a) => Design a -> m (Persisted (Design a))-createDesign design = createWithId id design+createDesign :: (MonadAction m, Entity a) => Design a -> m (Persisted (Design a))+createDesign design = createIdentifiedEntity (id, design)   where     id = "_design/" ++ designName design+++updateDesignView :: (MonadAction m, Entity a)  +  => Persisted (Design a) -> Text -> View -> m (Persisted (Design a))+updateDesignView +  design@(Persisted designId designRev (Design viewsMap))+  viewName+  view +  | Just existingView <- lookup viewName viewsMap +    = if existingView == view+        then return design+        else updateViewsMap $ Map.adjust (const $ view) viewName viewsMap+  | otherwise+    = updateViewsMap $ insert viewName view viewsMap+  where +    updateViewsMap = updateEntity . Persisted designId designRev . Design++createOrUpdateDesignView :: (MonadAction m, Entity a)+  => Text -> View -> m (Persisted (Design a))+createOrUpdateDesignView viewName view = +  createDesign newDesign `catch` \e -> case e of+    OperationException {} -> do+      existingDesign <- readDesign+      case existingDesign of+        Just existingDesign -> updateDesignView existingDesign viewName view+        Nothing -> throwIO e+    _ -> throwIO e+  where+    newDesign = Design $ fromList [(viewName, view)]

@@ -1,27 +0,0 @@-{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, FlexibleInstances, TypeSynonymInstances, DefaultSignatures, OverlappingInstances, TypeOperators, DeriveGeneric #-}-module EZCouch.Doc where--import Prelude ()-import ClassyPrelude --import GHC.Generics-import Data.Aeson--class (ToJSON a, FromJSON a) => Doc a where-  docType :: a -> Text--  default docType :: (Generic a, GDoc (Rep a)) => a -> Text-  docType = gDocType . from--class GDoc f where -  gDocType :: f a -> Text--instance (GDoc a) => GDoc (M1 i c a) where-  gDocType = gDocType . unM1--instance (Constructor c) => GDoc (C1 c a) where-  gDocType = const . pack $ conName (undefined :: t c a p)--instance (GDoc a, GDoc b) => GDoc (a :+: b) where-  gDocType (L1 x) = gDocType x-  gDocType (R1 x) = gDocType x

@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, FlexibleInstances, TypeSynonymInstances, DefaultSignatures, OverlappingInstances, TypeOperators, DeriveGeneric #-}+module EZCouch.Entity where++import Prelude ()+import ClassyPrelude ++import GHC.Generics+import Data.Aeson++class (ToJSON a, FromJSON a) => Entity a where+  entityType :: a -> Text++  default entityType :: (Generic a, GDoc (Rep a)) => a -> Text+  entityType = gDocType . from++class GDoc f where +  gDocType :: f a -> Text++instance (GDoc a) => GDoc (M1 i c a) where+  gDocType = gDocType . unM1++instance (Constructor c) => GDoc (C1 c a) where+  gDocType = const . pack $ conName (undefined :: t c a p)++instance (GDoc a, GDoc b) => GDoc (a :+: b) where+  gDocType (L1 x) = gDocType x+  gDocType (R1 x) = gDocType x

@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, DeriveGeneric #-}+module EZCouch.EntityIsolation where++import Prelude ()+import ClassyPrelude+import qualified Data.Traversable as Traversable+import qualified Data.List as List+import qualified Data.Time as Time+import Data.Aeson+import EZCouch.Time+import EZCouch.Types+import EZCouch.Action+import EZCouch.Entity+import EZCouch.ReadAction+import EZCouch.WriteAction+import EZCouch.Try+import qualified EZCouch.Model.EntityIsolation as Model+import qualified Util.Logging as Logging++logM lvl = Logging.logM lvl "EZCouch.EntityIsolation"++data Isolation e = Isolation {+  isolationIdRev :: IdRev Model.EntityIsolation,+  isolationIdentified :: Identified e+}+isolationEntity = identifiedValue . isolationIdentified++-- | Protect the entity from being accessed by concurrent clients until you +-- release it using `releaseIsolation`, delete it with the isolation using +-- `deleteIsolation`, or the timeout passes and it gets considered to be zombie +-- and gets released automatically some time later.+-- +-- The automatic releasing gets done by a sweeper daemon running in background+-- when EZCouch is being used on a timely basis and on its launch.+isolateEntity :: (MonadAction m, Entity e) +  => Int+  -- ^ A timeout in seconds. If the isolation does not get released when it+  -- passes, it gets considered to be zombie caused by client interrupt, then+  -- when the sweeper daemon hits the next cycle it will release the entity.+  -> Persisted e+  -- ^ The entity to isolate.+  -> m (Maybe (Isolation e))+  -- ^ Either the isolation or nothing if the entity has been already isolated+  -- by concurrent client.+isolateEntity timeout persisted = do +  results <- isolateEntities timeout . singleton $ persisted+  case results of+    [result] -> return result+    _ -> throwIO $ ServerException $ "EZCouch.EntityIsolation.isolateEntity"++-- | Does the same as `isolateEntity` but for multiple entities and in a single+-- request.+isolateEntities :: (MonadAction m, Entity e)+  => Int+  -> [Persisted e]+  -> m ([Maybe (Isolation e)])+isolateEntities timeout entities = do+  till <- Time.addUTCTime (fromIntegral timeout) <$> readTime+  results <- createIdentifiedEntities $+    map (entityIsolationId &&& entityIsolationModel till) entities+  forM (List.zip entities results) $ \r -> case r of+    (entity, Right isolation) -> return $ Just $ +      Isolation (persistedIdRev isolation) (persistedIdentified entity)+    _ -> return Nothing++entityIsolationModel :: (Entity e) +  => Time.UTCTime -> Persisted e -> Model.EntityIsolation+entityIsolationModel till entity =+  Model.EntityIsolation+    (persistedId entity)+    (toJSON $ persistedValue entity)+    till++entityIsolationId :: Persisted e -> Text+entityIsolationId entity = +  entityType (undefined :: Model.EntityIsolation) +    ++ "-" ++ persistedId entity++-- | Restore the entity document under the same id and drop the isolation.+releaseIsolation :: (MonadAction m, Entity e)+  => Isolation e -- ^ The isolation returned by `isolateEntity`.+  -> m (Persisted e) -- ^ The restored entity.+releaseIsolation = +  releaseIsolations . singleton >=> maybe fail return . listToMaybe+  where+    fail = throwIO $ ServerException "EZCouch.EntityIsolation.releaseIsolation"++releaseIsolations :: (MonadAction m, Entity e)+  => [Isolation e]+  -> m [Persisted e]+releaseIsolations isolations = do+  results <- createIdentifiedEntities $ map isolationIdentified isolations+  case sequence results of+    Left _ -> throwIO $ OperationException $ +      "Could not recreate entities under following ids when releasing the isolation: " ++ show (map fst . lefts $ results)+    Right entities -> do+      deleteEntitiesByIdRevs $ map isolationIdRev isolations+      return entities++-- | Get rid of both the isolation and the entity. The entity won't get restored+-- by the sweeper daemon after.+deleteIsolation :: (MonadAction m, Entity e)+  => Isolation e+  -> m ()+deleteIsolation = deleteIsolations . singleton++deleteIsolations :: (MonadAction m, Entity e)+  => [Isolation e]+  -> m ()+deleteIsolations isolations = +  deleteEntitiesByIdRevs $ map isolationIdRev isolations+

@@ -1,33 +1,20 @@ module EZCouch.Ids (generateId) where -import Data.Char-import Data.IntMap (fromList, (!))+import Prelude ()+import ClassyPrelude import Data.Time.Clock.POSIX import System.Random-import Control.Applicative--chars = ['0'..'9'] ++ ['A'..'Z'] ++ ['a'..'z']-charsLength = length chars-charsMap = fromList $ zip [0..charsLength] chars--encode = reverse . encode_-  where-    encode_ a -      | a < charsLength = charsMap ! a : []-      | otherwise = charsMap ! c : encode_ b-      where-        b = div a charsLength -        c = mod a charsLength+import EZCouch.Base62  getPicos = getPOSIXTime >>= return . round . (* 1000000)-getRndSuffix l = randomRIO (0, charsLength ^ l) >>= return . zeroPad l . encode+getRndSuffix l = (randomRIO (0, charsLength ^ l) :: IO Word64) >>= +  return . zeroPad l . encodeUnsigned   where      zeroPad l s = (replicate (l - length s) '0') ++ s   -generateId = (++) <$> fmap encode getPicos <*> getRndSuffix 3 +generateId = (++) <$> fmap encodeUnsigned getPicos <*> getRndSuffix 3   main = do-  generateId >>= putStrLn -  generateId >>= putStrLn -  generateId >>= putStrLn -  generateId >>= putStrLn +  generateId >>= putStrLn . pack+  generateId >>= putStrLn . pack+  generateId >>= putStrLn . pack

@@ -2,7 +2,7 @@ module EZCouch.Isolation where  import Prelude ()-import ClassyPrelude hiding (delete)+import ClassyPrelude import qualified Data.Time as Time  import EZCouch.Time@@ -10,6 +10,7 @@ import EZCouch.Action hiding (logM) import EZCouch.ReadAction import EZCouch.WriteAction+import EZCouch.View import EZCouch.Model.Isolation as Isolation  import qualified Util.Logging as Logging@@ -24,10 +25,10 @@   -> m (Maybe a) -- ^ Either the action's result or `Nothing` if it didn't get executed. inIsolation timeout id action = do   time <- readTime -  result <- (try $ createWithId id' $ Isolation time)+  result <- try $ createIdentifiedEntity (id', Isolation time)   case result of     Left (OperationException _) -> do-      isolation <- readOne $ readOptions { readOptionsKeys = Just [id'] }+      isolation <- readEntity ViewById (KeysSelectionList [id']) 0 False       case isolation of         Just isolation -> do           if (Isolation.since . persistedValue) isolation < Time.addUTCTime (negate $ fromIntegral timeout) time@@ -44,10 +45,10 @@     Left e -> throwIO e     Right isolation -> do       logM 0 $ "Performing an isolation: " ++ id'-      finally (Just <$> action) (delete isolation)+      finally (Just <$> action) (deleteEntity isolation)   where      id' = "EZCouchIsolation-" ++ id -tryToDelete doc = (const True <$> delete doc) `catch` \e -> case e of+tryToDelete doc = (const True <$> deleteEntity doc) `catch` \e -> case e of   OperationException _ -> return False   _ -> throwIO e

@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, DeriveGeneric #-}+module EZCouch.JS where++import Prelude ()+import ClassyPrelude+import GHC.Generics+import Data.Aeson+import qualified Data.Text.Lazy as LText++class ToJS a where+  toJS :: a -> Text++instance (ToJS a, ToJS b) => +  ToJS (a, b) +  where+    toJS (a, b) = "[" +      ++ toJS a ++ ", " +      ++ toJS b ++ "]"++instance (ToJS a, ToJS b, ToJS c) => +  ToJS (a, b, c) +  where+    toJS (a, b, c) = "[" +      ++ toJS a ++ ", " +      ++ toJS b ++ ", " +      ++ toJS c ++ "]"++instance (ToJS a, ToJS b, ToJS c, ToJS d) => +  ToJS (a, b, c, d) +  where+    toJS (a, b, c, d) = "[" +      ++ toJS a ++ ", " +      ++ toJS b ++ ", " +      ++ toJS c ++ ", " +      ++ toJS d ++ "]"++instance (ToJS a, ToJS b, ToJS c, ToJS d, ToJS e) => +  ToJS (a, b, c, d, e) +  where+    toJS (a, b, c, d, e) = "[" +      ++ toJS a ++ ", " +      ++ toJS b ++ ", " +      ++ toJS c ++ ", " +      ++ toJS d ++ ", " +      ++ toJS e ++ "]"++instance (ToJS a, ToJS b, ToJS c, ToJS d, ToJS e, ToJS f) => +  ToJS (a, b, c, d, e, f) +  where+    toJS (a, b, c, d, e, f) = "[" +      ++ toJS a ++ ", " +      ++ toJS b ++ ", " +      ++ toJS c ++ ", " +      ++ toJS d ++ ", " +      ++ toJS e ++ ", " +      ++ toJS f ++ "]"++instance (ToJS a, ToJS b, ToJS c, ToJS d, ToJS e, ToJS f, ToJS g) => +  ToJS (a, b, c, d, e, f, g) +  where+    toJS (a, b, c, d, e, f, g) = "[" +      ++ toJS a ++ ", " +      ++ toJS b ++ ", " +      ++ toJS c ++ ", " +      ++ toJS d ++ ", " +      ++ toJS e ++ ", " +      ++ toJS f ++ ", "+      ++ toJS g ++ "]"+++newtype JSON a = JSON a++instance (ToJSON a) => ToJS (JSON a) where+  toJS (JSON a) = LText.toStrict . decodeUtf8 . encode $ a

@@ -4,7 +4,7 @@ import Prelude () import ClassyPrelude import GHC.Generics-import EZCouch.Doc+import EZCouch.Entity import Data.Aeson import qualified EZCouch.Model.View as ViewModel @@ -15,6 +15,6 @@   deriving (Show, Eq, Generic) instance ToJSON (Design a) instance FromJSON (Design a)-instance (Doc a) => Doc (Design a)+instance (Entity a) => Entity (Design a) -designName = docType . (undefined :: Design a -> a)+designName = entityType . (undefined :: Design a -> a)

@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, DeriveGeneric #-}+module EZCouch.Model.EntityIsolation where++import Prelude ()+import ClassyPrelude+import GHC.Generics+import EZCouch.Entity+import EZCouch.Types+import Data.Aeson+import Data.Time++data EntityIsolation+  = EntityIsolation { +      entityId :: Text,+      entityValue :: Value, +      -- ^ A JSON value to simplify internal handling and reduce conversions.+      till :: UTCTime+    }+  deriving (Show, Eq, Generic)+instance ToJSON EntityIsolation+instance FromJSON EntityIsolation+instance Entity EntityIsolation where+  entityType = const "EZCouchEntityIsolation"+

@@ -4,7 +4,7 @@ import Prelude () import ClassyPrelude import GHC.Generics-import EZCouch.Doc+import EZCouch.Entity import Data.Aeson import Data.Time @@ -13,5 +13,5 @@   deriving (Show, Eq, Generic) instance ToJSON (Isolation) instance FromJSON (Isolation)-instance Doc (Isolation) where-  docType = const "EZCouchIsolation"+instance Entity (Isolation) where+  entityType = const "EZCouchIsolation"

@@ -4,7 +4,7 @@ import Prelude () import ClassyPrelude import GHC.Generics-import EZCouch.Doc+import EZCouch.Entity import Data.Aeson  data View = View { map :: Text, reduce :: Maybe Text }

@@ -1,63 +1,138 @@-{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, ScopedTypeVariables, DeriveDataTypeable, DeriveFunctor #-}+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, ScopedTypeVariables, DeriveDataTypeable, DeriveFunctor, GADTs #-} module EZCouch.ReadAction where  import Prelude () import ClassyPrelude.Conduit import EZCouch.Action-import EZCouch.Doc+import EZCouch.Entity import EZCouch.Types import EZCouch.Parsing+import EZCouch.View import qualified EZCouch.Encoding as Encoding import qualified Database.CouchDB.Conduit.View.Query as CC+import qualified System.Random as Random+import qualified EZCouch.Base62 as Base62+import qualified Network.HTTP.Conduit as HTTP+import qualified Network.HTTP.Types as HTTP import Data.Aeson.Types -readAction-  :: (MonadAction m, Doc a, ToJSON k)-  => Bool-  -> ReadOptions a k-  -> m (Value)-readAction includeDocs ro@(ReadOptions keys view desc limit skip) = case keys of-  Nothing -> getAction path (docTypeQPs ++ includeDocsQPs ++ optionsQPs) ""-  Just keys' -> postAction path (includeDocsQPs ++ optionsQPs) (Encoding.keysBody keys')-  where-    docType' = docType $ (undefined :: ReadOptions a k -> a) ro-    optionsQPs = catMaybes [descQP, limitQP, skipQP]-      where-        descQP = if desc then Just CC.QPDescending else Nothing-        limitQP = CC.QPLimit <$> limit-        skipQP = if skip /= 0 then Just $ CC.QPSkip skip else Nothing-    includeDocsQPs = if includeDocs then [CC.QPIncludeDocs] else []-    docTypeQPs = [CC.QPStartKey (docType' ++ "-"), CC.QPEndKey (docType' ++ ".")]-    path -      | Just view' <- view = ["_design", docType', "_view", viewName view']-      | otherwise = ["_all_docs"]-    descQP = if desc then Just CC.QPDescending else Nothing-    limitQP = CC.QPLimit <$> limit-    skipQP = if skip /= 0 then Just $ CC.QPSkip skip else Nothing +data KeysSelection k+  = KeysSelectionAll+  | KeysSelectionRange k k+  | KeysSelectionRangeStart k+  | KeysSelectionRangeEnd k+  | KeysSelectionList [k]+  deriving (Show, Eq) -readMultiple :: (MonadAction m, Doc a, ToJSON k) => ReadOptions a k -> m [Persisted a]-readMultiple options = -  readAction True options -    >>= runParser (rowsParser1 >=> mapM persistedParser . toList) -    >>= return . catMaybes -readOne :: (MonadAction m, Doc a, ToJSON k) => ReadOptions a k -> m (Maybe (Persisted a))-readOne options = listToMaybe <$> readMultiple options'+readAction :: (MonadAction m, Entity a, ToJSON k)+  => View a k -- ^ View+  -> KeysSelection k -- ^ Keys selection mode+  -> Int -- ^ Skip+  -> Maybe Int -- ^ Limit+  -> Bool -- ^ Descending+  -> Bool -- ^ Include docs+  -> m Value -- ^ An unparsed response body JSON+readAction view mode skip limit desc includeDocs = +  action path qps body `catch` \e -> case e of+    HTTP.StatusCodeException (HTTP.Status code _) _ +      | code `elem` [404, 500] +      -> do+        createOrUpdateView view +        action path qps body+    _ -> throwIO e   where-    options' = options { readOptionsLimit = Just 1 }+    action = case mode of+      KeysSelectionList {} -> postAction+      _ -> getAction+    path = viewPath view+    qps = catMaybes [+        includeDocsQP includeDocs,+        startKeyQP view mode,+        endKeyQP view mode,+        descQP desc,+        limitQP limit,+        skipQP skip+      ]+    body = case mode of +      KeysSelectionList keys -> Encoding.keysBody keys+      _ -> "" -readExists :: (MonadAction m, Doc a, ToJSON k, FromJSON k) => ReadOptions a k -> m [(k, Bool)]-readExists options = -  readAction False options++startKeyQP _ (KeysSelectionRange start end) = Just $ CC.QPStartKey start+startKeyQP _ (KeysSelectionRangeStart start) = Just $ CC.QPStartKey start+startKeyQP _ (KeysSelectionList {}) = Nothing+startKeyQP view@ViewById _ = Just $ CC.QPStartKey $ viewDocType view ++ "-"+startKeyQP _ _ = Nothing++endKeyQP _ (KeysSelectionRange start end) = Just $ CC.QPEndKey end+endKeyQP _ (KeysSelectionRangeEnd end) = Just $ CC.QPEndKey end+endKeyQP _ (KeysSelectionList {}) = Nothing+endKeyQP view@ViewById _ = Just $ CC.QPEndKey $ viewDocType view ++ "."+endKeyQP _ _ = Nothing++limitQP limit = CC.QPLimit <$> limit++skipQP skip = if skip /= 0 then Just $ CC.QPSkip skip else Nothing++descQP desc = if desc then Just CC.QPDescending else Nothing++includeDocsQP True = Just CC.QPIncludeDocs+includeDocsQP False = Nothing+++readKeys :: (MonadAction m, Entity a, ToJSON k, FromJSON k) +  => View a k -- ^ View+  -> KeysSelection k -- ^ Keys selection mode+  -> m [k] +readKeys view mode = fmap (map fst . filter snd) $ readKeysExist view mode++readCount :: (MonadAction m, Entity a, ToJSON k, FromJSON k)+  => View a k -- ^ View+  -> KeysSelection k -- ^ Keys selection mode+  -> m Int+readCount view mode = fmap length $ readKeys view mode++readKeysExist :: (MonadAction m, Entity a, ToJSON k, FromJSON k) +  => View a k -- ^ View+  -> KeysSelection k -- ^ Keys selection mode+  -> m [(k, Bool)] +  -- ^ An associative list of `Bool` values by keys designating the existance of appropriate entities+readKeysExist view mode =+  readAction view mode 0 Nothing False False     >>= runParser (rowsParser1 >=> mapM keyExistsParser . toList) -    -readIds :: (MonadAction m, Doc a) => ReadOptions a Text -> m [Text]-readIds = readKeys --- TODO: Test on returning ids for non-view queries-readKeys :: (MonadAction m, Doc a, ToJSON k, FromJSON k) => ReadOptions a k -> m [k]-readKeys = fmap (map fst . filter snd) . readExists+readEntities :: (MonadAction m, Entity a, ToJSON k)+  => View a k -- ^ View+  -> KeysSelection k -- ^ Keys selection mode+  -> Int -- ^ Skip+  -> Maybe Int -- ^ Limit+  -> Bool -- ^ Descending+  -> m [Persisted a]+readEntities view mode skip limit desc =+  readAction view mode skip limit desc True+    >>= runParser (rowsParser1 >=> mapM persistedParser . toList) +    >>= return . catMaybes -readCount :: (MonadAction m, Doc a, ToJSON k, FromJSON k) => ReadOptions a k -> m Int-readCount = fmap length . readKeys+readEntity :: (MonadAction m, Entity a, ToJSON k)+  => View a k -- ^ View+  -> KeysSelection k -- ^ Keys selection mode+  -> Int -- ^ Skip+  -> Bool -- ^ Descending+  -> m (Maybe (Persisted a))+readEntity view mode skip desc = +  listToMaybe <$> readEntities view mode skip (Just 1) desc++readRandomEntities :: (MonadAction m, Entity a) +  => Maybe Int -- ^ Limit+  -> m [Persisted a]+readRandomEntities limit = do+  startKey :: Double <- liftIO $ Random.randomRIO (0.0, 1.0)+  readEntities +    (ViewByKeys1 ViewKeyRandom) +    (KeysSelectionRangeStart startKey)+    0+    limit+    False+

@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, DeriveGeneric #-}+module EZCouch.Sweeper where++import Prelude ()+import ClassyPrelude+import qualified Data.Time as Time+import Control.Concurrent+import Data.Aeson+import EZCouch.Time+import EZCouch.Types+import EZCouch.Action+import EZCouch.Entity+import EZCouch.ReadAction+import EZCouch.WriteAction+import EZCouch.Try+import EZCouch.View+import EZCouch.Model.EntityIsolation (EntityIsolation)+import qualified EZCouch.Model.EntityIsolation as EntityIsolation+import EZCouch.Isolation+import qualified Util.Logging as Logging+++runSweeper = forever $ do+  Logging.logM 0 "EZCouch.Sweeper" $ "Sweeping zombie entity isolations"+  readZombieEntityIsolations >>= releaseIsolations+  liftIO $ threadDelay $ 10 ^ 6 * 60 * 60 * 24 * 2+++readZombieEntityIsolations :: (MonadAction m) +  => m [Persisted EntityIsolation]+readZombieEntityIsolations = do+  now <- readTime+  readEntities+    (ViewByKeys1 (ViewKeyField "till"))+    (KeysSelectionRangeEnd now)+    0+    Nothing+    False++releaseIsolations isolations = do+  createIdentifiedEntities $ map idAndValue isolations+  deleteEntities isolations++idAndValue =+  (EntityIsolation.entityId &&& EntityIsolation.entityValue) . persistedValue

@@ -8,9 +8,10 @@ import EZCouch.Types import EZCouch.WriteAction --- | Return `Nothing` if an action throws an `OperationException` or `Just` its result otherwise.+-- | Return `Nothing` if an action throws an `OperationException` or `Just` its +-- result otherwise. -- --- This is only useful for a modifying actions (Create, Update, Delete).+-- This is only useful for writing actions (Create, Update, Delete). tryOperation :: (MonadAction m) => m a -> m (Maybe a) tryOperation action = (Just <$> action) `catch` \e -> case e of   OperationException _ -> return Nothing

@@ -1,16 +1,32 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-} module EZCouch.Types where  import Prelude () import ClassyPrelude --import Data.Generics+import Data.Aeson+import GHC.Generics +-- | A wrapper for entity values which preserves the information required for+-- identifying the appropriate documents in the db. data Persisted a = Persisted { persistedId :: Text, persistedRev :: Text, persistedValue :: a }-  deriving (Show, Data, Typeable, Eq, Ord)+  deriving (Show, Typeable, Eq, Ord, Generic)+instance (ToJSON a) => ToJSON (Persisted a)+instance (FromJSON a) => FromJSON (Persisted a) +persistedIdRev :: Persisted a -> IdRev a+persistedIdRev (Persisted id rev _) = IdRev id rev +persistedIdentified :: Persisted a -> Identified a+persistedIdentified (Persisted id _ value) = (id, value)++type Identified a = (Text, a)+identifiedId (id, _) = id+identifiedValue (_, value) = value++data IdRev a = IdRev Text Text+ data EZCouchException    = ParsingException Text    -- ^ A response from CouchDB could not be parsed.@@ -19,34 +35,6 @@   | ServerException Text   -- ^ E.g., server provided an unexpected response   | ConnectionException Text-  deriving (Show, Data, Typeable)+  deriving (Show, Typeable) instance Exception EZCouchException --- | Identifies a Couch's design and view. The design name is implicitly resolved from the type parameter `a` and becomes the name of this type. The view name however must be specified explicitly.-newtype View a = View { viewName :: Text }-  deriving (Show, Data, Typeable, Eq, Ord)---data ReadOptions a k-  = ReadOptions {-      readOptionsKeys :: Maybe [k],-      readOptionsView :: Maybe (View a),-      readOptionsDescending :: Bool,-      readOptionsLimit :: Maybe Int,-      readOptionsSkip :: Int-    }-  deriving (Show, Data, Typeable, Eq, Ord)-  -readOptions :: ReadOptions a Text-readOptions = ReadOptions Nothing Nothing False Nothing 0---data ConnectionSettings -  = ConnectionSettings {  -      connectionSettingsHost :: Text,-      connectionSettingsPort :: Int,-      connectionSettingsAuth :: Maybe (Text, Text),-      connectionSettingsDatabase :: Text-    }--defaultPort = 5984 :: Int

@@ -1,35 +1,155 @@-{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, DeriveGeneric, GADTs, StandaloneDeriving #-} module EZCouch.View where  import Prelude () import ClassyPrelude+import GHC.Generics import Data.Aeson-import Data.Map (adjust) import EZCouch.Action-import EZCouch.Doc+import EZCouch.Entity import EZCouch.Types import EZCouch.Design  import EZCouch.WriteAction+import qualified Control.Monad as Monad+import qualified Data.Foldable as Foldable import qualified EZCouch.Model.Design as DesignModel import qualified EZCouch.Model.View as ViewModel+import qualified EZCouch.Base62 as Base62+import Data.Hashable +import EZCouch.JS +type ViewModel = ViewModel.View+type DesignModel = DesignModel.Design -createOrUpdateViewDesign :: (Doc a, MonadAction m) => Text -> Maybe Text -> View a -> m (Persisted (DesignModel.Design a))-createOrUpdateViewDesign mapV reduceV view-  = readDesign >>= maybe create update'-  where-    create = createDesign $ DesignModel.Design $ fromList [(viewName view, viewModel)]-    update' design@(Persisted id rev (DesignModel.Design viewsMap))-      | Just viewModel' <- lookup viewName' viewsMap-        = if viewModel' == viewModel-            then return design-            else update $ Persisted id rev $ DesignModel.Design $ adjust (const $ viewModel) viewName' viewsMap-    viewName' = viewName view-    viewModel = ViewModel.View mapV reduceV -createOrUpdateView :: (Doc a, MonadAction m) -  => Text       -- ^ /map/-function-  -> Maybe Text -- ^ /reduce/-function-  -> View a     -- ^ view identifier-  -> m ()-createOrUpdateView map reduce view = void $ createOrUpdateViewDesign map reduce view+data ViewKey a = +  ViewKeyField Text |+  -- ^ A path to a field value.+  -- +  -- Assuming the following record declarations:+  -- +  -- > data A = A { b :: B }+  -- > data B = B { c :: Int }+  -- +  -- A path value of @\"b.c\"@ will emit the values of the @c@ field of a JSON +  -- object representing the record @B@ in a view key of type @ViewKey A@.+  -- +  -- Yes, it's not static. But it's probably the only place in the library that +  -- the compiler doesn't check for you.+  ViewKeyRandom+  -- ^ This will emit a JavaScript @Math.random()@ value as a key. This is what +  -- makes the querying for random entities possible.+  deriving (Show, Eq)+++instance ToJS (ViewKey a) where+  toJS (ViewKeyField field) = "doc." ++ field+  toJS ViewKeyRandom = "Math.random()"+instance Hashable (ViewKey a) where+  hashWithSalt salt = hashWithSalt salt . toJS++data View entity keys where+  ViewById +    :: View entity Text+  ViewByKeys1 +    :: ViewKey a +    -> View entity a+  ViewByKeys2 +    :: ViewKey a +    -> ViewKey b +    -> View entity (a, b)+  ViewByKeys3 +    :: ViewKey a +    -> ViewKey b +    -> ViewKey c +    -> View entity (a, b, c)+  ViewByKeys4 +    :: ViewKey a +    -> ViewKey b +    -> ViewKey c +    -> ViewKey d +    -> View entity (a, b, c, d)+  ViewByKeys5 +    :: ViewKey a +    -> ViewKey b +    -> ViewKey c +    -> ViewKey d +    -> ViewKey e +    -> View entity (a, b, c, d, e)+  ViewByKeys6 +    :: ViewKey a +    -> ViewKey b +    -> ViewKey c +    -> ViewKey d +    -> ViewKey e +    -> ViewKey f +    -> View entity (a, b, c, d, e, f)+  ViewByKeys7 +    :: ViewKey a +    -> ViewKey b +    -> ViewKey c +    -> ViewKey d +    -> ViewKey e +    -> ViewKey f +    -> ViewKey g +    -> View entity (a, b, c, d, e, f, g)++deriving instance Show (View entity keys)+deriving instance Eq (View entity keys)+instance Hashable (View entity keys) where+  hashWithSalt salt view = case view of+    ViewById -> 0+    ViewByKeys1 a -> hashWithSalt salt a+    ViewByKeys2 a b -> hashWithSalt salt (a, b)+    ViewByKeys3 a b c -> hashWithSalt salt (a, b, c)+    ViewByKeys4 a b c d -> hashWithSalt salt (a, b, c, d)+    ViewByKeys5 a b c d e -> hashWithSalt salt (a, b, c, d, e)+    ViewByKeys6 a b c d e f -> hashWithSalt salt (a, b, c, d, e, f)+    ViewByKeys7 a b c d e f g -> hashWithSalt salt (a, b, c, d, e, f, g)+++viewGeneratedName :: View a k -> Maybe Text+viewGeneratedName view = case view of+  ViewById -> Nothing+  view -> Just $ pack . Base62.encodeSigned64 . fromIntegral . hash $ view++viewDocType :: (Entity a) => View a k -> Text+viewDocType = entityType . (undefined :: View a k -> a)++viewDesignName :: (Entity a) => View a k -> Maybe Text+viewDesignName ViewById = Nothing+viewDesignName view = entityType . (undefined :: View a k -> a) <$> Just view++viewKeysJS view = case view of+  ViewById -> Nothing+  ViewByKeys1 a -> Just $ toJS a+  ViewByKeys2 a b -> Just $ toJS (a, b)+  ViewByKeys3 a b c -> Just $ toJS (a, b, c)+  ViewByKeys4 a b c d -> Just $ toJS (a, b, c, d)+  ViewByKeys5 a b c d e -> Just $ toJS (a, b, c, d, e)+  ViewByKeys6 a b c d e f -> Just $ toJS (a, b, c, d, e, f)+  ViewByKeys7 a b c d e f g -> Just $ toJS (a, b, c, d, e, f, g)++viewMapFunctionJS :: (Entity a) => View a k -> Maybe Text+viewMapFunctionJS view = fmap concat $ sequence [+    pure "function (doc) { if (doc._id.lastIndexOf('",+    viewDesignName view,+    pure "-') == 0) emit(",+    viewKeysJS view,+    pure ", null) }"+  ]++viewPath :: (Entity a) => View a k -> [Text]+viewPath view = case view of+  ViewById -> ["_all_docs"]+  _ -> ["_design", fromMaybe undefined $ viewDesignName view, +        "_view", fromMaybe undefined $ viewGeneratedName view]++createOrUpdateView :: (MonadAction m, Entity a) +  => View a k +  -> m (Persisted (DesignModel a))+createOrUpdateView view+  | Just name <- viewGeneratedName view,+    Just model <- ViewModel.View <$> viewMapFunctionJS view <*> pure Nothing+    = createOrUpdateDesignView name model+  | otherwise = error "EZCouch.View.createOrUpdateView: Attempt to persist a view which does not support it"

@@ -7,7 +7,7 @@ import EZCouch.Ids  import EZCouch.Action import EZCouch.Types-import EZCouch.Doc+import EZCouch.Entity import EZCouch.Parsing import qualified EZCouch.Encoding as Encoding import qualified Database.CouchDB.Conduit.View.Query as CC@@ -18,7 +18,7 @@   | Update Text Text a   | Delete Text Text -writeOperationsAction :: (MonadAction m, Doc a) +writeOperationsAction :: (MonadAction m, ToJSON a)    => [WriteOperation a]    -> m [(Text, Maybe Text)]   -- ^ Maybe rev by id. Nothing on failure.@@ -39,24 +39,27 @@ operationJSON (Delete id rev)   = Aeson.object [("_id", toJSON id), ("_rev", toJSON rev), ("_deleted", Aeson.Bool True)]  -deleteMultiple :: (MonadAction m, Doc a) => [Persisted a] -> m ()-deleteMultiple vals = do-  results <- writeOperationsAction $ map toOperation vals+deleteEntitiesByIdRevs :: (MonadAction m, Entity a) => [IdRev a] -> m ()+deleteEntitiesByIdRevs idRevs = do+  results <- writeOperationsAction $ map toOperation idRevs   let failedIds = fmap fst $ filter (isNothing . snd) results   if null failedIds     then return ()     else throwIO $ OperationException $ "Couldn't delete entities by following ids: " ++ show failedIds   where-    toOperation :: Persisted a -> WriteOperation a-    toOperation (Persisted id rev val) = Delete id rev+    toOperation :: IdRev a -> WriteOperation a+    toOperation (IdRev id rev) = Delete id rev -delete :: (MonadAction m, Doc a) => Persisted a -> m ()-delete = deleteMultiple . singleton+deleteEntities :: (MonadAction m, Entity a) => [Persisted a] -> m ()+deleteEntities = deleteEntitiesByIdRevs . map persistedIdRev -createMultipleWithIds :: (MonadAction m, Doc a) -  => [(Text, a)] +deleteEntity :: (MonadAction m, Entity a) => Persisted a -> m ()+deleteEntity = deleteEntities . singleton++createIdentifiedEntities :: (MonadAction m, ToJSON a) +  => [Identified a]   -> m [Either (Text, a) (Persisted a)]-createMultipleWithIds idsToVals +createIdentifiedEntities idsToVals    = writeOperationsAction [Create id val | (id, val) <- idsToVals]       >>= mapM convertResult   where@@ -66,23 +69,23 @@     convertResult (id, Just rev) = fmap Right $        Persisted <$> pure id <*> pure rev <*> lookupThrowing id valById -createWithId :: (MonadAction m, Doc a)-  => Text-  -> a+createIdentifiedEntity :: (MonadAction m, Entity a)+  => Identified a   -> m (Persisted a)-createWithId id val = createMultipleWithIds [(id, val)] -  >>= return . join . fmap (either (const Nothing) Just) . listToMaybe -  >>= maybe (throwIO $ OperationException "Failed to create entity") return+createIdentifiedEntity = +  createIdentifiedEntities . singleton +    >=> return . join . fmap (either (const Nothing) Just) . listToMaybe +    >=> maybe (throwIO $ OperationException "Failed to create entity") return -createMultiple :: (MonadAction m, Doc a) => [a] -> m [Persisted a]-createMultiple = retry 10 +createEntities :: (MonadAction m, Entity a) => [a] -> m [Persisted a]+createEntities = retry 10    where     generateIdToVal val = do-      id <- fmap ((docType val ++ "-") ++) $ fmap fromString generateId+      id <- fmap ((entityType val ++ "-") ++) $ fmap fromString generateId       return (id, val)     retry attempts vals = do           idsToVals <- liftIO $ mapM generateIdToVal vals-      results <- createMultipleWithIds idsToVals+      results <- createIdentifiedEntities idsToVals       let (failures, successes) = partitionEithers results       if attempts > 0 || null failures          then do@@ -93,21 +96,21 @@         else           throwIO $ OperationException $ "Failed to generate unique ids" -create :: (MonadAction m, Doc a) => a -> m (Persisted a)-create = return . singleton >=> createMultiple >=> +createEntity :: (MonadAction m, Entity a) => a -> m (Persisted a)+createEntity = return . singleton >=> createEntities >=>    maybe (throwIO $ OperationException "Failed to create entity") return . listToMaybe -updateMultiple :: (MonadAction m, Doc a) => [Persisted a] -> m [Persisted a]-updateMultiple pVals+updateEntities :: (MonadAction m, Entity a) => [Persisted a] -> m [Persisted a]+updateEntities pVals   = writeOperationsAction [Update id rev val | Persisted id rev val <- pVals]       >>= mapM convertResult   where     valById = asMap $ fromList [(id, val) | Persisted id _ val <- pVals]-    convertResult (id, Nothing) = throwIO $ OperationException $ "Couldn't update all documents"+    convertResult (id, Nothing) = throwIO $ OperationException $ "Couldn't updateEntity all documents"     convertResult (id, Just rev) = Persisted <$> pure id <*> pure rev <*> lookupThrowing id valById -update :: (MonadAction m, Doc a) => Persisted a -> m (Persisted a)-update = return . singleton >=> updateMultiple >=> +updateEntity :: (MonadAction m, Entity a) => Persisted a -> m (Persisted a)+updateEntity = return . singleton >=> updateEntities >=>    maybe (throwIO $ OperationException "Failed to update entity") return . listToMaybe      lookupThrowing id cache = case lookup id cache of

@@ -1,54 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-module Util.PrettyPrint (tree, Data, Typeable) where--import Control.Applicative-import Data.Tree-import Data.Generics-import Data.String-import qualified Data.Text as Text--dataTree :: Data a => a -> Tree String-dataTree = fix . genericTree-  where-    genericTree :: Data a => a -> Tree String-    genericTree = dflt `extQ` text `extQ` string-      where-        text x = Node (Text.unpack x) []-        string x = Node x []-        dflt a = Node (showConstr (toConstr a)) (gmapQ genericTree a)-    fix (Node name forest)-      | name == "(:)" -      , a : b : [] <- forest-        = Node ":" $ (fix a) : (subForest $ fix b)-      | name == "(,)" = Node "," $ fix <$> forest-      | otherwise = Node name $ fix <$> forest---tree :: (Data a, IsString b) => a -> b-tree = fromString . unlines . draw . dataTree-  where-    draw :: Tree String -> [String]-    draw (Node x ts0) = x : drawSubTrees ts0-      where-        drawSubTrees [] = []-        drawSubTrees [t] =-            shift "- " "  " (draw t)-        drawSubTrees (t:ts) =-            shift "- " "| " (draw t) ++ drawSubTrees ts--        shift first other = zipWith (++) (first : repeat other)------- data SomeType = A [String] Int | B | C Int | D [[String]] ---   deriving (Typeable, Data)---- xxx = A ["a", "b", "c"] 9 ---     : C 3 ---     : B ---     : D [["asdf", "123", "ldskfjkl"], ["f"]]---     : []---- main = do---   putStrLn $ tree $ dataTree xxx