packages feed

ez-couch (empty) → 0.3.0

raw patch · 25 files changed

+1333/−0 lines, 25 filesdep +aesondep +attoparsecdep +attoparsec-conduitsetup-changed

Dependencies added: aeson, attoparsec, attoparsec-conduit, base, blaze-builder, bytestring, classy-prelude, classy-prelude-conduit, containers, ghc-prim, hslogger, http-conduit, http-types, mtl, old-locale, random, resourcet, string-conversions, syb, text, time, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2013, Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ez-couch.cabal view
@@ -0,0 +1,67 @@+name:               ez-couch+version:            0.3.0+cabal-version:      >=1.8+build-type:         Simple+license:            MIT+license-file:       LICENSE+copyright:          (c) 2013, Nikita Volkov+author:             Nikita Volkov+maintainer:         Nikita Volkov <nikita.y.volkov@mail.ru>+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+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++library+  hs-source-dirs:   src+  extensions:       PatternGuards+  exposed-modules:  EZCouch+  other-modules:    Control.Retry+                    Database.CouchDB.Conduit.View.Query+                    EZCouch.Doc+                    EZCouch.Action+                    EZCouch.WriteAction+                    EZCouch.Design+                    EZCouch.Encoding+                    EZCouch.Ids+                    EZCouch.Isolation+                    EZCouch.Model.Design+                    EZCouch.Model.Isolation+                    EZCouch.Model.View+                    EZCouch.Parsing+                    EZCouch.ReadAction+                    EZCouch.Time+                    EZCouch.Try+                    EZCouch.Types+                    EZCouch.View+                    Network.HTTP.Conduit.Request+                    Util.Logging+                    Util.PrettyPrint+  build-depends:    base >= 4.5 && < 5,+                    ghc-prim >= 0.2,+                    time >= 1.4,+                    aeson >= 0.6,+                    attoparsec >= 0.10,+                    attoparsec-conduit >= 0.5,+                    http-conduit >= 1.8,+                    http-types >= 0.7,+                    hslogger >= 1.2,+                    old-locale >= 1.0,+                    text >= 0.11,+                    syb >= 0.3,+                    containers >= 0.4,+                    unordered-containers >= 0.2,+                    bytestring >= 0.9,+                    blaze-builder >= 0.3,+                    mtl >= 2.1,+                    random >= 1.0,+                    resourcet >= 0.3,+                    string-conversions >= 0.2,+                    classy-prelude >= 0.4.4,+                    classy-prelude-conduit >= 0.4++source-repository head+  type:             git+  location:         git://github.com/nikita-volkov/ez-couch.git
+ src/Control/Retry.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}+module Control.Retry where++import Prelude ()+import ClassyPrelude+import Control.Concurrent+import qualified Util.Logging as Logging+++retryingEither [] action = action +retryingEither (i:is) action = action >>= processResult+  where +    processResult (Left _) +      | i == 0 = retryingEither is action+      | otherwise = liftIO (threadDelay i) >> retryingEither is action+    processResult r = return r++retryingEither' = retryingEither defaultIntervals++retrying exceptionIntervals action = retrying_ 0+  where+    retrying_ attempt = catch action processException+      where+        exceptionInterval = listToMaybe . drop attempt . exceptionIntervals+        processException e +          | Just i <- exceptionInterval e = do+              Logging.logM 3 "Control.Retry"+                $ "Error occurred: " ++ show e ++ ". " +                  ++ "Retrying with a " ++ show (i `div` sec) ++ "s delay."+              unless (i == 0) (liftIO (threadDelay i)) +              retrying_ (attempt + 1)+          | otherwise = throwIO e++defaultIntervals = [sec, sec * 5, sec * 15]+sec = 10 ^ 6+
+ src/Database/CouchDB/Conduit/View/Query.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE OverloadedStrings, ExistentialQuantification, BangPatterns #-} ++-- | CouchDB View Query options.+--+--   For details see +--   <http://wiki.apache.org/couchdb/HTTP_view_API#Querying_Options>. Note, +--   because all options must be a proper URL encoded JSON, construction of +--   complex parameters can be very tedious. To simplify this, use 'mkQuery'.+ +module Database.CouchDB.Conduit.View.Query (+    -- * Creating Query+    CouchQP(..),+    mkQuery,+    +    -- * Parameter helpers+    qpUnit,+    qpNull+) where++import qualified Data.ByteString as B+import qualified Data.HashMap.Strict as MS+import qualified Data.Aeson as A+import Data.String.Conversions (cs, (<>))+import qualified Data.List as L++import qualified Network.HTTP.Types as HT++-- | CouchDB Query options primitives.+data CouchQP =+      forall a . A.ToJSON a => QPComplex B.ByteString a+        -- ^ Complex view query parameter.  +        --+        -- > couchQP [QPComplex "param" (["a", "b"] :: [String])]+        -- > [("param", Just "[\"a\",\"b\"]")]+        -- > ...?param=["a","b"]+        -- > +        -- > couchQP [QPComplex "key" (("a", 1) :: (String, Int))]+        -- > [("key", Just "[\"a\",0]")]+        -- > ...?param=["a",0]+        --+        -- It't just convert lazy 'BL.ByteString' from 'A.encode' to strict +        -- 'B.ByteString'. For more efficient use specific functions. +    +    | QPBS B.ByteString B.ByteString+        -- ^ Quoted 'B.ByteString' query parameter.+        --+        -- > ...?param="value" +    +    | QPInt B.ByteString Int+        -- ^ 'Int' query parameter.+        --+        -- > ...?param=100 +    +    | QPBool B.ByteString Bool+        -- ^ 'Bool' query parameter.+        --+        -- > ...?param=true+        +    | QPDescending+        -- ^ Reverse rows output.+        --+        -- > ...?descending=true +    +    | QPLimit Int+        -- ^ Limit rows. Use @Zero (0)@ to omit.+        --+        -- > ...?limit=5 +    +    | QPSkip Int+        -- ^ Skip rows. Use @Zero (0)@ to omit.+        --+        -- > ...?skip=10+    +    | QPStale Bool+        -- ^ Stale view. On @True@ sets @stale@ parameter to @ok@, else +        --   sets it to @update_after@.+        --    +        -- > ...?stale=ok+        -- > ...?stale=update_after+    +    | forall a . A.ToJSON a => QPKey a+        -- ^ @key@ query parameter.+        --+        -- > ...?key=...+        +    | forall a . A.ToJSON a => QPStartKey a+        -- ^ Row key to start with. Becomes @endkey@ if @descending@ turned on. +        --   See 'couchQuery'. +        --+        -- > ...?startkey=...+        -- > ...?descending=true?endkey=...+        +    | forall a . A.ToJSON a => QPEndKey a+        -- ^ Row key to start with. Becomes @startkey@ if @descending@ +        --   turned on. See 'couchQuery'. +        --+        -- > ...?endkey=...+        -- > ...?descending=true?startkey=...+        +    | forall a . A.ToJSON a => QPKeys a+        -- ^ Row key to start with. Use only with 'couchView' and +        --   'couchView_'. For large sets of @keys@ use 'couchViewPost' and +        --   'couchViewPost_'+        --+        -- > ...?keys=...+        +    | QPGroup+        -- ^ Turn on grouping.+        --+        -- > ...?group=true+    | QPGroupLevel Int+        -- ^ Set grouping level. Use @Zero (0)@ to omit.+        --+        -- > ...?group_level=2+    | QPReduce Bool+        -- ^ Control reduce.+        --+        -- > ...?reduce=true+        -- > ...?reduce=false+        +    | QPIncludeDocs+        -- ^ Turn on inclusion docs in view results.+        --+        -- > ...?include_docs=true+        +    | QPInclusiveEnd+        -- ^ Turn off inclusion @endkey@ in view results.+        --+        -- > ...?inclusive_end=false++    | QPUpdateSeq+        -- ^ Response includes an update_seq value indicating which sequence +        --   id of the database the view reflects+        --+        -- > ...?update_seq=true+        +    | QPStartKeyDocId B.ByteString+        -- ^ Document id to start with.+        --+        -- > ...?startkey_docid=...+    | QPEndKeyDocId B.ByteString+        -- ^ Document id to end with.+        --+        -- > ...?endkey_docid=...++-- | Make CouchDB query options.+mkQuery :: +       [CouchQP]    -- ^ Query options.+    -> HT.Query+mkQuery qs = +    concatMap parseqp qs+  where+    parseqp (QPComplex n v) = [(n, Just $ cs . A.encode $ v)]  +    parseqp (QPBS n v) = [(n, Just $ "\"" <> v <> "\"")]  +    parseqp (QPInt n v) = [(n, Just $ cs . show $ v)]  +    parseqp (QPBool n True) = [(n, Just "true")]  +    parseqp (QPBool n False) = [(n, Just "false")]  +    parseqp QPDescending = boolqp "descending" True  +    parseqp (QPLimit v) = intZeroQp "limit" v  +    parseqp (QPSkip v) = intZeroQp "skip" v+    parseqp (QPStale True) = [("stale", Just "ok")]+    parseqp (QPStale False) = [("stale", Just "update_after")]+    parseqp (QPKey v) = parseqp $ QPComplex "key" v+    parseqp (QPKeys v) = parseqp $ QPComplex "keys" v+    parseqp (QPStartKey v) = parseqp $ QPComplex +            (descDep "startkey" "endkey") v+    parseqp (QPEndKey v) = parseqp $ QPComplex +            (descDep "endkey" "startkey") v+    parseqp QPGroup = boolqp "group" True  +    parseqp (QPGroupLevel v) = intZeroQp "group_level" v  +    parseqp (QPReduce v) = boolqp "reduce" v+    parseqp QPIncludeDocs = boolqp "include_docs" True+    parseqp QPInclusiveEnd = boolqp "inclusive_end" False+    parseqp QPUpdateSeq = boolqp "update_seq" True+    parseqp (QPStartKeyDocId v) = parseqp $ QPComplex "startkey_docid" v+    parseqp (QPEndKeyDocId v) = parseqp $ QPComplex "endkey_docid" v+    +    -- | Boolean+    boolqp n v = parseqp $ QPBool n v+    -- | Ommitable int+    intZeroQp _ 0 = []+    intZeroQp n v = parseqp $ QPInt n v+    -- | Descending dependent param+    descDep a b = if isDesc then b else a+    +    !isDesc = case L.find isDesc' qs of+        Nothing -> False+        _ -> True+    isDesc' QPDescending = True +    isDesc' _ = False++++-- | Returns empty 'MS.HashMap'. Aeson will convert +--   this to @\{\}@ (JSON unit). This useful for @startkey@ and @endkey@.+--   +-- > couchQuery [QPStartKey (1, 0), QPEndKey (1, {})]+qpUnit :: MS.HashMap B.ByteString Bool+qpUnit = MS.empty++-- | Simply return 'A.Null'.+qpNull :: A.Value+qpNull = A.Null
+ src/EZCouch.hs view
@@ -0,0 +1,68 @@+{-# 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. +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,+  -- ** Reading +  -- | All reading actions accept a `ReadOptions` parameter which specifies how filtering and ordering should go.+  readOne,+  readMultiple,+  readExists,+  readIds,+  readKeys,+  readCount,+  -- ** Updating +  update,+  updateMultiple,+  -- ** Deleting +  delete,+  deleteMultiple,+  +  -- * Server Time+  readTime,++  -- * Working with Views+  createOrUpdateView,  ++  -- * 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,++  -- * Types+  Persisted(..),+  EZCouchException(..),+  View(..),+  ReadOptions(..),+  readOptions,+  ConnectionSettings(..),+  defaultPort,++  -- * Helpers+  tryOperation,++  -- * Execution Monad+  MonadAction(..),+  run,+  runWithManager,++  -- * Classes which records should implement+  Doc(..),+  -- ** Aeson re-exports+  ToJSON(..),+  FromJSON(..)+) where++import EZCouch.Action+import EZCouch.Types+import EZCouch.ReadAction+import EZCouch.WriteAction+import EZCouch.View+import EZCouch.Doc+import EZCouch.Time+import EZCouch.Isolation+import EZCouch.Try+import Data.Aeson
+ src/EZCouch/Action.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving, FlexibleInstances #-}+module EZCouch.Action where++import Prelude ()+import ClassyPrelude.Conduit+import Control.Exception (SomeException(..))+import Control.Monad.Reader+import Control.Retry+import System.IO.Error (ioeGetErrorString)+import EZCouch.Types+import Network.HTTP.Types as HTTP+import Network.HTTP.Conduit as HTTP+import Network.HTTP.Conduit.Request as HTTP+import qualified Database.CouchDB.Conduit.View.Query as CC+import qualified Blaze.ByteString.Builder as Blaze+import qualified Util.Logging as Logging+import qualified Data.Aeson as Aeson+import qualified Data.Conduit.Attoparsec as Atto++logM lvl = Logging.logM lvl "EZCouch.Action"++-- | All EZCouch operations are performed in this monad.+class (MonadBaseControl IO m, MonadResource m, MonadReader (ConnectionSettings, Manager) m) => MonadAction m where++instance (MonadResource m, MonadBaseControl IO m) => MonadAction (ReaderT (ConnectionSettings, Manager) m) ++generateRequest :: (MonadAction m) +  => Method+  -> Maybe [Text]+  -> [CC.CouchQP]+  -> LByteString+  -> m (Request m)+generateRequest method dbPath qps body = do+  (settings, _) <- ask+  return $ settingsRequest settings+  where+    headers = [("Content-Type", "application/json")]+    query = renderQuery False $ CC.mkQuery qps+    settingsRequest (ConnectionSettings host port auth database) =+      authenticated $ def {+        method = method,+        host = encodeUtf8 host,+        requestHeaders = headers,+        port = port,+        path = packPath $ maybe [] (database : ) $ dbPath,+        queryString = query,+        requestBody = RequestBodyLBS body,+        checkStatus = checkStatus,+        responseTimeout = Just $ 10 ^ 6 * 10+      }+      where+        authenticated+          | Just (username, password) <- auth = applyBasicAuth (encodeUtf8 username) (encodeUtf8 password)+          | otherwise = id+    checkStatus status@(Status code message) headers+      | elem code [200, 201, 202, 304] = Nothing+      | otherwise = Just $ SomeException $ StatusCodeException status headers++performRequest :: (MonadAction m) +  => Request m+  -> m (Response (ResumableSource m ByteString))+performRequest request = do+  logM 0 $ "Performing a " +    ++ show (HTTP.method request) +    ++ " at " ++ show (HTTP.url request)+  (_, manager) <- ask+  retrying exceptionIntervals $+    (flip catch) handleIOException $+      (flip catch) handleHttpException $ +        http request manager+  where+    checkStatus status@(Status code message) headers+      | elem code [200, 201, 202, 304] = Nothing+      | otherwise = Just $ SomeException $ StatusCodeException status headers+    exceptionIntervals (ConnectionException {}) = [10^3, 10^6, 10^6*10]+    exceptionIntervals _ = []+    handleHttpException e = case e of+      FailedConnectionException host port -> throwIO $ ConnectionException $ +        "FailedConnectionException: " ++ pack host ++ " " ++ show port+      otherwise -> throwIO e+    handleIOException e = throwIO $ ConnectionException $ +      "IOError: " ++ pack (ioeGetErrorString e)++getResponseHeaders method path qps body = do+  response <- performRequest =<< generateRequest method path qps body +  responseBody response $$+- return ()+  return $ responseHeaders response++getResponseJSON method path qps body = do+  response <- performRequest =<< generateRequest method path qps body +  responseBody response $$+- Atto.sinkParser Aeson.json++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 (/="")
+ src/EZCouch/Design.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, DeriveGeneric #-}+module EZCouch.Design where++import Prelude ()+import ClassyPrelude+import GHC.Generics+import EZCouch.Doc+import Data.Aeson+import qualified Network.HTTP.Types as HTTP+import qualified Network.HTTP.Conduit as HTTP++import EZCouch.ReadAction+import EZCouch.Action+import EZCouch.WriteAction+import EZCouch.Types+import EZCouch.Parsing++import EZCouch.Model.Design+++readDesign :: (MonadAction m, Doc a) => m (Maybe (Persisted (Design a)))+readDesign = result+  where+    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+        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++createDesign :: (MonadAction m, Doc a) => Design a -> m (Persisted (Design a))+createDesign design = createWithId id design+  where+    id = "_design/" ++ designName design
+ src/EZCouch/Doc.hs view
@@ -0,0 +1,27 @@+{-# 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
+ src/EZCouch/Encoding.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+module EZCouch.Encoding where++import Prelude ()+import ClassyPrelude +import Data.ByteString.Lazy.Char8 () -- export instances for LByteString+import Data.Aeson as Aeson++keysBody :: (ToJSON a) => a -> LByteString+keysBody keys = "{\"keys\":" ++ encode keys ++ "}"++insertPairs pairs (Object m) +  = Object $ fold (flip . uncurry $ insert) m pairs++
+ src/EZCouch/Ids.hs view
@@ -0,0 +1,33 @@+module EZCouch.Ids (generateId) where++import Data.Char+import Data.IntMap (fromList, (!))+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++getPicos = getPOSIXTime >>= return . round . (* 1000000)+getRndSuffix l = randomRIO (0, charsLength ^ l) >>= return . zeroPad l . encode+  where +    zeroPad l s = (replicate (l - length s) '0') ++ s  ++generateId = (++) <$> fmap encode getPicos <*> getRndSuffix 3 ++main = do+  generateId >>= putStrLn +  generateId >>= putStrLn +  generateId >>= putStrLn +  generateId >>= putStrLn
+ src/EZCouch/Isolation.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, DeriveGeneric #-}+module EZCouch.Isolation where++import Prelude ()+import ClassyPrelude hiding (delete)+import qualified Data.Time as Time++import EZCouch.Time+import EZCouch.Types+import EZCouch.Action hiding (logM)+import EZCouch.ReadAction+import EZCouch.WriteAction+import EZCouch.Model.Isolation as Isolation++import qualified Util.Logging as Logging++logM lvl = Logging.logM lvl "EZCouch.Isolation"++-- | Protect an action from being executed on multiple clients. Can be used to create transactions in a preemptive manner, i.e. instead of performing some actions and rolling back on transaction validation failure it does validation based on the provided identifier prior to actually executing the transaction. This function however does not provide you with atomicity guarantees (<http://en.wikipedia.org/wiki/Atomicity_(database_systems)>), as it does not rollback in case of client-interrupt - it's up to your algorithms to handle those cases.+inIsolation :: MonadAction m +  => Int -- ^ A timeout in seconds. If after reaching it a conflicting isolation marker still exists in the db, it gets considered to be zombie (probably caused by a client interruption). The marker gets deleted and the current action gets executed.+  -> Text -- ^ A unique isolation identifier. It's a common practice to provide a 'persistedId' of the primary entity involved in the transaction, which is supposed to uniquely identify it.+  -> m a -- ^ The action to protect. Nothing of it will be executed if an isolation with the same id is already running.+  -> 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)+  case result of+    Left (OperationException _) -> do+      isolation <- readOne $ readOptions { readOptionsKeys = Just [id'] }+      case isolation of+        Just isolation -> do+          if (Isolation.since . persistedValue) isolation < Time.addUTCTime (negate $ fromIntegral timeout) time+            then do +              logM 0 $ "Deleting outdated isolation: " ++ id'+              tryToDelete isolation+              inIsolation timeout id action+            else do+              logM 0 $ "Skipping a busy isolation: " ++ id'+              return Nothing+        Nothing -> do+          logM 0 $ "Skipping a finished isolation: " ++ id'+          return Nothing+    Left e -> throwIO e+    Right isolation -> do+      logM 0 $ "Performing an isolation: " ++ id'+      finally (Just <$> action) (delete isolation)+  where +    id' = "EZCouchIsolation-" ++ id++tryToDelete doc = (const True <$> delete doc) `catch` \e -> case e of+  OperationException _ -> return False+  _ -> throwIO e
+ src/EZCouch/Model/Design.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, DeriveGeneric #-}+module EZCouch.Model.Design where++import Prelude ()+import ClassyPrelude+import GHC.Generics+import EZCouch.Doc+import Data.Aeson+import qualified EZCouch.Model.View as ViewModel++data Design a +  = Design {+      views :: Map Text ViewModel.View+    }+  deriving (Show, Eq, Generic)+instance ToJSON (Design a)+instance FromJSON (Design a)+instance (Doc a) => Doc (Design a)++designName = docType . (undefined :: Design a -> a)
+ src/EZCouch/Model/Isolation.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, DeriveGeneric #-}+module EZCouch.Model.Isolation where++import Prelude ()+import ClassyPrelude+import GHC.Generics+import EZCouch.Doc+import Data.Aeson+import Data.Time++data Isolation +  = Isolation { since :: UTCTime }+  deriving (Show, Eq, Generic)+instance ToJSON (Isolation)+instance FromJSON (Isolation)+instance Doc (Isolation) where+  docType = const "EZCouchIsolation"
+ src/EZCouch/Model/View.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, DeriveGeneric #-}+module EZCouch.Model.View where++import Prelude ()+import ClassyPrelude+import GHC.Generics+import EZCouch.Doc+import Data.Aeson++data View = View { map :: Text, reduce :: Maybe Text }+  deriving (Show, Eq, Generic)+instance ToJSON View where+  toJSON (View map reduce) = object $ catMaybes +    [ Just ("map", toJSON map), +      (,) <$> pure "reduce" <*> toJSON <$> reduce ]+instance FromJSON View where+  parseJSON = withObject "View" $ \o -> +    View <$> o .: "map" <*> o .:? "reduce"  +
+ src/EZCouch/Parsing.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts #-}+module EZCouch.Parsing where++import Prelude ()+import ClassyPrelude+import Control.Monad.Trans.Resource+import qualified Data.Text.Lazy as Text+import EZCouch.Types+import Data.Aeson as Aeson ++type Parser a = Aeson.Value -> Either Text a++runParser parser response = +  either (throwIO . ParsingException) return $ parser response++rowsParser1 :: Parser (Vector Aeson.Value)+rowsParser1 json+  | Just (Aeson.Array rows) <- json .? "rows" = Right rows+  | otherwise = Left $ unexpectedJSONValue json++rowsParser2 :: Parser (Vector Aeson.Value)+rowsParser2 json+  | Aeson.Array rows <- json = Right rows+  | otherwise = Left $ unexpectedJSONValue json++idRevParser :: Parser (Text, Maybe Text)+idRevParser o @ (Aeson.Object m) +  | Just rev <- lookup "rev" m,+    Just id <- lookup "id" m+    = (,) <$> fromJSON' id <*> (Just <$> fromJSON' rev)+  | Just code <- lookup "error" m,+    Just reason <- lookup "reason" m,+    Just id <- lookup "id" m+    = (,) <$> fromJSON' id <*> pure Nothing+  | otherwise+    = Left $ unexpectedJSONValue o++keyExistsParser :: (FromJSON k) => Parser (k, Bool)+keyExistsParser o @ (Aeson.Object m) +  | Just "not_found" <- lookup "error" m,+    Just key <- lookup "key" m+    = (,) <$> fromJSON' key <*> pure False+  | Just (Aeson.Object valueM) <- lookup "value" m,+    Just (Aeson.Bool True) <- lookup "deleted" valueM,+    Just key <- lookup "key" m+    = (,) <$> fromJSON' key <*> pure False+  | Just id <- lookup "id" m,+    Just _ <- lookup "value" m,+    Just key <- lookup "key" m+    = (,) <$> fromJSON' key <*> pure True+  | otherwise+    = Left $ unexpectedJSONValue o++persistedParser :: (FromJSON a) => Parser (Maybe (Persisted a))+persistedParser o+  | Just (Aeson.Bool True) <- o .? "value" ?.? "deleted"+    = Right Nothing+  | Just id <- o .? "id", +    Just doc <- o .? "doc",+    Just rev <- doc .? "_rev"+    = fmap Just $ Persisted <$> fromJSON' id <*> fromJSON' rev <*> fromJSON' doc+  | otherwise+    = Left $ unexpectedJSONValue o++errorPersistedParser :: (FromJSON a) => Parser (Either (Text, Text) (Persisted a))+errorPersistedParser o @ (Aeson.Object m) +  | Just id <- lookup "_id" m,+    Just rev <- lookup "_rev" m+    = fmap Right $ Persisted <$> fromJSON' id <*> fromJSON' rev <*> fromJSON' o+  | Just error <- lookup "error" m, Just reason <- lookup "reason" m+    = fmap Left $ (,) <$> fromJSON' error <*> fromJSON' reason +  | otherwise+    = Left $ unexpectedJSONValue o++maybePersistedByKeyParser :: (FromJSON a, FromJSON k) => Parser (k, Maybe (Persisted a))+maybePersistedByKeyParser o @ (Aeson.Object m) +  -- deleted+  | Just id <- lookup "id" m,+    Just (Aeson.Object valueM) <- lookup "value" m,+    Just (Aeson.Bool True) <- lookup "deleted" valueM,+    Just rev <- lookup "rev" valueM,+    Just key <- lookup "key" m+    = (,) <$> fromJSON' key <*> pure Nothing+  -- found+  | Just id <- lookup "id" m,+    Just (Aeson.Object valueM) <- lookup "value" m,+    Just doc <- lookup "doc" m,+    Aeson.Object docM <- doc,+    Just rev <- lookup "_rev" docM,+    Just key <- lookup "key" m+    = (,) <$> fromJSON' key <*> (Just <$> (Persisted <$> fromJSON' id <*> fromJSON' rev <*> fromJSON' doc))+  -- not found+  | Just "not_found" <- lookup "error" m,+    Just key <- lookup "key" m+    = (,) <$> fromJSON' key <*> pure Nothing+  | otherwise+    = Left $ unexpectedJSONValue o+++fromJSON' json = case fromJSON json of+  Aeson.Success z -> Right $ z+  Aeson.Error s -> Left $ "fromJSON failed with a message `" +    ++ fromString s +    ++ "` on the following value: " +    ++ (Text.toStrict . decodeUtf8 $ Aeson.encode json) ++unexpectedJSONValue json = +  "Unexpected JSON value: " ++ (Text.toStrict . decodeUtf8 $ Aeson.encode json)++o .? k = pure o ?.? k+o ?.? k = o >>= objectKey k+objectKey k (Aeson.Object m) = lookup k m+objectKey _ _ = Nothing
+ src/EZCouch/ReadAction.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, ScopedTypeVariables, DeriveDataTypeable, DeriveFunctor #-}+module EZCouch.ReadAction where++import Prelude ()+import ClassyPrelude.Conduit+import EZCouch.Action+import EZCouch.Doc+import EZCouch.Types+import EZCouch.Parsing+import qualified EZCouch.Encoding as Encoding+import qualified Database.CouchDB.Conduit.View.Query as CC+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+++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'+  where+    options' = options { readOptionsLimit = Just 1 }++readExists :: (MonadAction m, Doc a, ToJSON k, FromJSON k) => ReadOptions a k -> m [(k, Bool)]+readExists options = +  readAction False options+    >>= 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++readCount :: (MonadAction m, Doc a, ToJSON k, FromJSON k) => ReadOptions a k -> m Int+readCount = fmap length . readKeys
+ src/EZCouch/Time.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, DeriveGeneric #-}+module EZCouch.Time where++import Prelude ()+import ClassyPrelude.Conduit+import System.Locale+import Data.Time+import qualified Network.HTTP.Types as HTTP++import EZCouch.Types+import EZCouch.Action++-- | Current time according to server.+readTime :: MonadAction m => m UTCTime +readTime = getResponseHeaders HTTP.methodGet mempty mempty mempty+  >>= getHeadersTime++getHeadersTime ((name, value) : tail) +  | name == HTTP.hDate = case toTime value of+    Just time -> return time+    Nothing -> throwIO $ ParsingException $ "Couldn't parse date: `" ++ decodeUtf8 value ++ "`"+  | otherwise = getHeadersTime tail+getHeadersTime _ = throwIO $ ServerException "No date header in response"++toTime = parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" +  . unpack . asText . decodeUtf8
+ src/EZCouch/Try.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, ScopedTypeVariables, DeriveDataTypeable, DeriveFunctor #-}+module EZCouch.Try where++import Prelude ()+import ClassyPrelude.Conduit++import EZCouch.Action+import EZCouch.Types+import EZCouch.WriteAction++-- | Return `Nothing` if an action throws an `OperationException` or `Just` its result otherwise.+-- +-- This is only useful for a modifying actions (Create, Update, Delete).+tryOperation :: (MonadAction m) => m a -> m (Maybe a)+tryOperation action = (Just <$> action) `catch` \e -> case e of+  OperationException _ -> return Nothing+  _ -> throwIO e
+ src/EZCouch/Types.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+module EZCouch.Types where++import Prelude ()+import ClassyPrelude ++import Data.Generics++data Persisted a = Persisted { persistedId :: Text, persistedRev :: Text, persistedValue :: a }+  deriving (Show, Data, Typeable, Eq, Ord)+++data EZCouchException +  = ParsingException Text +  -- ^ A response from CouchDB could not be parsed.+  | OperationException Text +  -- ^ An operation failed, e.g. a document couldn't be created or deleted.+  | ServerException Text+  -- ^ E.g., server provided an unexpected response+  | ConnectionException Text+  deriving (Show, Data, 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
+ src/EZCouch/View.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, DeriveGeneric #-}+module EZCouch.View where++import Prelude ()+import ClassyPrelude+import Data.Aeson+import Data.Map (adjust)+import EZCouch.Action+import EZCouch.Doc+import EZCouch.Types+import EZCouch.Design +import EZCouch.WriteAction+import qualified EZCouch.Model.Design as DesignModel+import qualified EZCouch.Model.View as ViewModel+++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
+ src/EZCouch/WriteAction.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, ScopedTypeVariables, DeriveDataTypeable, DeriveFunctor #-}+module EZCouch.WriteAction where++import Prelude ()+import ClassyPrelude.Conduit+import Control.Monad.Trans.Resource+import EZCouch.Ids +import EZCouch.Action+import EZCouch.Types+import EZCouch.Doc+import EZCouch.Parsing+import qualified EZCouch.Encoding as Encoding+import qualified Database.CouchDB.Conduit.View.Query as CC+import Data.Aeson as Aeson++data WriteOperation a+  = Create Text a+  | Update Text Text a+  | Delete Text Text++writeOperationsAction :: (MonadAction m, Doc a) +  => [WriteOperation a] +  -> m [(Text, Maybe Text)]+  -- ^ Maybe rev by id. Nothing on failure.+writeOperationsAction ops =+  postAction path qps body >>= +    runParser (rowsParser2 >=> mapM idRevParser . toList)+  where+    path = ["_bulk_docs"]+    qps = []+    body = writeOperationsBody ops++writeOperationsBody ops = Aeson.encode $ Aeson.object [("docs", Aeson.Array $ fromList $ map operationJSON ops)]++operationJSON (Create id a)+  = Encoding.insertPairs [("_id", toJSON id)] $ toJSON a+operationJSON (Update id rev a)+  = Encoding.insertPairs [("_id", toJSON id), ("_rev", toJSON rev)] $ toJSON a+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+  let failedIds = map 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++delete :: (MonadAction m, Doc a) => Persisted a -> m ()+delete = deleteMultiple . singleton++createMultipleWithIds :: (MonadAction m, Doc a) +  => [(Text, a)] +  -> m [Either (Text, a) (Persisted a)]+createMultipleWithIds idsToVals +  = writeOperationsAction [Create id val | (id, val) <- idsToVals]+      >>= mapM convertResult+  where+    valById = asMap $ fromList idsToVals+    convertResult (id, Nothing) = fmap Left $ +      (,) <$> pure id <*> lookupThrowing id valById+    convertResult (id, Just rev) = fmap Right $ +      Persisted <$> pure id <*> pure rev <*> lookupThrowing id valById++createWithId :: (MonadAction m, Doc a)+  => Text+  -> 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++createMultiple :: (MonadAction m, Doc a) => [a] -> m [Persisted a]+createMultiple = retry 10 +  where+    generateIdToVal val = do+      id <- fmap ((docType val ++ "-") ++) $ fmap fromString generateId+      return (id, val)+    retry attempts vals = do    +      idsToVals <- liftIO $ mapM generateIdToVal vals+      results <- createMultipleWithIds idsToVals+      let (failures, successes) = partitionEithers results+      if attempts > 0 || null failures +        then do+          let vals' = [val | (_, val) <- failures]+          let attempts' = if null successes then attempts - 1 else attempts+          remaining <- if null failures then return [] else retry attempts' vals'+          return $ remaining ++ successes+        else+          throwIO $ OperationException $ "Failed to generate unique ids"++create :: (MonadAction m, Doc a) => a -> m (Persisted a)+create = return . singleton >=> createMultiple >=> +  maybe (throwIO $ OperationException "Failed to create entity") return . listToMaybe++updateMultiple :: (MonadAction m, Doc a) => [Persisted a] -> m [Persisted a]+updateMultiple 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, Just rev) = Persisted <$> pure id <*> pure rev <*> lookupThrowing id valById++update :: (MonadAction m, Doc a) => Persisted a -> m (Persisted a)+update = return . singleton >=> updateMultiple >=> +  maybe (throwIO $ OperationException "Failed to update entity") return . listToMaybe+    +lookupThrowing id cache = case lookup id cache of+  Just val -> return val+  Nothing -> throwIO $ ParsingException $ "Unexpected id: " ++ show id
+ src/Network/HTTP/Conduit/Request.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+module Network.HTTP.Conduit.Request where++import Prelude ()+import ClassyPrelude+import Network.HTTP.Conduit++withHeader (name, value) request+  = request { requestHeaders = headers' }+  where+    headers = requestHeaders request+    headers' = (name, value) : filter ((/=) name . fst) headers++withHeaders newHeaders request+  = request { requestHeaders = headers' }+  where+    headers' = headersUnion newHeaders (requestHeaders request)++withDefaultHeaders headers request+  = request { requestHeaders = headers' }+  where+    headers' = headersUnion (requestHeaders request) headers++headersUnion headers1 headers2+  = headers1 ++ new+  where +    namesOfExisting = asSet . fromList $ map fst headers1+    new = filter (not . flip member namesOfExisting . fst) headers2++url r = concat [+    if secure r then "https" else "http",+    "://",+    host r,+    path r,+    if null $ queryString r then "" else "?" ++ queryString r+  ]++withResponseTimeout timeout request+  = request { responseTimeout = timeout }+  +fixedHTTP request manager +  = http request manager `catch` handleIOException+  where+    handleIOException (e :: IOException) = throwIO +      $ FailedConnectionException +          (unpack $ decodeUtf8 $ host request) +          (port request)+
+ src/Util/Logging.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+module Util.Logging where++import Prelude (String)+import ClassyPrelude ++import System.Log.Logger as Logger +import System.Log +import System.Log.Handler +import System.Log.Formatter+import System.Log.Handler.Simple hiding (formatter) +import System.IO++import System.Locale (defaultTimeLocale)+import Data.Time (getZonedTime, getCurrentTime, formatTime)+import Control.Concurrent (myThreadId)++logM :: (MonadIO m) => Int -> Text -> Text -> m ()+logM level logger message = liftIO $ +  Logger.logM (unpack logger) (levelPriority level) (unpack message)++initialize = initializeWithFormat "$level $time, $logger: $message"++initializeWithFormat :: Text -> IO ()+initializeWithFormat format = do+  updateGlobalLogger "" (Logger.setLevel DEBUG)++  removeAllHandlers+  h <- streamHandler stderr DEBUG+  h <- return $ setFormatter h (formatter format)+  updateGlobalLogger "" (setHandlers [h])++setLoggerLevel logger level = do+  updateGlobalLogger (unpack logger) (Logger.setLevel $ levelPriority level)++levelPriority level = case level of+  0 -> DEBUG+  1 -> INFO+  2 -> NOTICE+  3 -> WARNING+  4 -> ERROR+  5 -> CRITICAL+  6 -> ALERT+  x | x >= 7 -> EMERGENCY++priorityLevel p = fromMaybe undefined $ find ((==) p . levelPriority) [0..7]++formatter format h (prio, msg) loggername +  = replaceVarM +      [ +        ("time", formatTime defaultTimeLocale timeFormat <$> getZonedTime),+        ("utcTime", formatTime defaultTimeLocale timeFormat <$> getCurrentTime),+        ("message", return msg), +        ("priority", return $ show prio), +        ("level", return $ show $ priorityLevel prio), +        ("logger", return loggername), +        ("tid", show <$> myThreadId)+      ]+      $ unpack format+  where+    timeFormat = "%F %X %Z"+++-- | Replace some '$' variables in a string with supplied values+replaceVarM :: [(String, IO String)] -- ^ A list of (variableName, action to get the replacement string) pairs+           -> String   -- ^ String to perform substitution on+           -> IO String   -- ^ Resulting string+replaceVarM _ [] = return []+replaceVarM keyVals (s:ss) | s=='$' = do (f,rest) <- replaceStart keyVals ss+                                         repRest <- replaceVarM keyVals rest+                                         return $ f ++ repRest+                           | otherwise = replaceVarM keyVals ss >>= return . (s:)+    where+      replaceStart [] str = return ("$",str)+      replaceStart ((k,v):kvs) str | k `isPrefixOf` str = do vs <- v+                                                             return (vs, drop (length k) str)+                                   | otherwise = replaceStart kvs str+
+ src/Util/PrettyPrint.hs view
@@ -0,0 +1,54 @@+{-# 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