packages feed

ez-couch 0.4.1 → 0.4.2

raw patch · 13 files changed

+76/−68 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

+ EZCouch: ResponseException :: Text -> EZCouchException

Files

ez-couch.cabal view
@@ -1,5 +1,5 @@ name:               ez-couch-version:            0.4.1+version:            0.4.2 cabal-version:      >=1.8 build-type:         Simple license:            MIT@@ -18,8 +18,7 @@   hs-source-dirs:   src   extensions:       PatternGuards   exposed-modules:  EZCouch-  other-modules:    Control.Retry-                    Database.CouchDB.Conduit.View.Query+  other-modules:    Database.CouchDB.Conduit.View.Query                     EZCouch.Base62                     EZCouch.Entity                     EZCouch.Action@@ -34,6 +33,7 @@                     EZCouch.Model.View                     EZCouch.Parsing                     EZCouch.ReadAction+                    EZCouch.Retry                     EZCouch.Time                     EZCouch.Try                     EZCouch.Types@@ -43,6 +43,7 @@                     EZCouch.Model.EntityIsolation                     EZCouch.EntityIsolation                     EZCouch.Sweeper+                    EZCouch.Logging   build-depends:    base >= 4.5 && < 5,                     ghc-prim >= 0.2,                     time >= 1.4,
− src/Control/Retry.hs 
@@ -1,36 +0,0 @@-{-# 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 0 "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/EZCouch/Action.hs view
@@ -5,21 +5,19 @@ import ClassyPrelude.Conduit import Control.Exception (SomeException(..)) import Control.Monad.Reader-import Control.Retry import System.IO.Error (ioeGetErrorString) import EZCouch.Types+import EZCouch.Logging+import EZCouch.Retry 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" - data ConnectionSettings    = ConnectionSettings {         connectionSettingsHost :: Text,@@ -58,7 +56,7 @@         queryString = query,         requestBody = RequestBodyLBS body,         checkStatus = checkStatus,-        responseTimeout = Just $ 10 ^ 6 * 30+        responseTimeout = Just $ 10 ^ 6 * 5       }       where         authenticated@@ -72,7 +70,7 @@   => Request m   -> m (Response (ResumableSource m ByteString)) performRequest request = do-  logM 0 $ "Performing a " +  logLn 0 $ "Performing a "      ++ show (HTTP.method request)      ++ " at " ++ show (HTTP.url request)   (_, manager) <- ask@@ -85,6 +83,7 @@       | elem code [200, 201, 202, 304] = Nothing       | otherwise = Just $ SomeException $ StatusCodeException status headers     exceptionIntervals (ConnectionException {}) = [10^3, 10^6, 10^6*10]+    exceptionIntervals (ServerException {}) = [10^6, 10^6*10, 10^6*60]     exceptionIntervals _ = []     handleHttpException e = case e of       FailedConnectionException host port -> throwIO $ ConnectionException $
src/EZCouch/Entity.hs view
@@ -19,9 +19,9 @@ instance (GEntity a) => GEntity (M1 i c a) where   gEntityType = gEntityType . unM1 -instance (Constructor c) => GEntity (C1 c a) where-  gEntityType = const . pack $ conName (undefined :: t c a p)-+instance (Datatype d) => GEntity (D1 d a) where+  gEntityType = const . pack $ datatypeName (undefined :: t d a p)+   instance (GEntity a, GEntity b) => GEntity (a :+: b) where   gEntityType (L1 x) = gEntityType x   gEntityType (R1 x) = gEntityType x
src/EZCouch/EntityIsolation.hs view
@@ -14,11 +14,9 @@ import EZCouch.ReadAction import EZCouch.WriteAction import EZCouch.Try+import EZCouch.Logging 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@@ -46,7 +44,7 @@   results <- isolateEntities timeout . singleton $ persisted   case results of     [result] -> return result-    _ -> throwIO $ ServerException $ "EZCouch.EntityIsolation.isolateEntity"+    _ -> throwIO $ ResponseException $ "EZCouch.EntityIsolation.isolateEntity"  -- | Does the same as `isolateEntity` but for multiple entities and in a single -- request.@@ -87,7 +85,7 @@ releaseIsolation =    releaseIsolations . singleton >=> maybe fail return . listToMaybe   where-    fail = throwIO $ ServerException "EZCouch.EntityIsolation.releaseIsolation"+    fail = throwIO $ ResponseException "EZCouch.EntityIsolation.releaseIsolation"  releaseIsolations :: (MonadAction m, Entity e)   => [Isolation e]
src/EZCouch/Isolation.hs view
@@ -7,15 +7,12 @@  import EZCouch.Time import EZCouch.Types-import EZCouch.Action hiding (logM)+import EZCouch.Action import EZCouch.ReadAction import EZCouch.WriteAction import EZCouch.View import EZCouch.Model.Isolation as Isolation--import qualified Util.Logging as Logging--logM lvl = Logging.logM lvl "EZCouch.Isolation"+import EZCouch.Logging  -- | 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 @@ -33,18 +30,18 @@         Just isolation -> do           if (Isolation.since . persistedValue) isolation < Time.addUTCTime (negate $ fromIntegral timeout) time             then do -              logM 0 $ "Deleting outdated isolation: " ++ id'+              logLn 0 $ "Deleting outdated isolation: " ++ id'               tryToDelete isolation               inIsolation timeout id action             else do-              logM 0 $ "Skipping a busy isolation: " ++ id'+              logLn 0 $ "Skipping a busy isolation: " ++ id'               return Nothing         Nothing -> do-          logM 0 $ "Skipping a finished isolation: " ++ id'+          logLn 0 $ "Skipping a finished isolation: " ++ id'           return Nothing     Left e -> throwIO e     Right isolation -> do-      logM 0 $ "Performing an isolation: " ++ id'+      logLn 0 $ "Performing an isolation: " ++ id'       finally (Just <$> action) (deleteEntity isolation)   where      id' = "EZCouchIsolation-" ++ id
+ src/EZCouch/Logging.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, DeriveGeneric #-}+module EZCouch.Logging where++import Prelude ()+import ClassyPrelude+import qualified Util.Logging as Logging++logLn lvl = Logging.logLn lvl "EZCouch"
src/EZCouch/ReadAction.hs view
@@ -8,6 +8,7 @@ import EZCouch.Types import EZCouch.Parsing import EZCouch.View+import EZCouch.Logging import qualified EZCouch.Encoding as Encoding import qualified Database.CouchDB.Conduit.View.Query as CC import qualified System.Random as Random@@ -39,6 +40,9 @@     HTTP.StatusCodeException (HTTP.Status code _) _        | code `elem` [404, 500]        -> do+        logLn 2 $ "View " +          ++ fromMaybe undefined (viewGeneratedName view) +          ++ " does not exist. Generating."         createOrUpdateView view          action path qps body     _ -> throwIO e
+ src/EZCouch/Retry.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}+module EZCouch.Retry where++import Prelude ()+import ClassyPrelude+import Control.Concurrent+import EZCouch.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+              logLn 2 +                $ "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/EZCouch/Sweeper.hs view
@@ -17,11 +17,11 @@ import EZCouch.Model.EntityIsolation (EntityIsolation) import qualified EZCouch.Model.EntityIsolation as EntityIsolation import EZCouch.Isolation-import qualified Util.Logging as Logging+import EZCouch.Logging    runSweeper = forever $ do-  Logging.logM 0 "EZCouch.Sweeper" $ "Sweeping zombie entity isolations"+  logLn 2 $ "Sweeping zombie entity isolations"   readZombieEntityIsolations >>= releaseIsolations   liftIO $ threadDelay $ 10 ^ 6 * 60 * 60 * 24 * 2
src/EZCouch/Time.hs view
@@ -20,7 +20,7 @@     Just time -> return time     Nothing -> throwIO $ ParsingException $ "Couldn't parse date: `" ++ decodeUtf8 value ++ "`"   | otherwise = getHeadersTime tail-getHeadersTime _ = throwIO $ ServerException "No date header in response"+getHeadersTime _ = throwIO $ ResponseException "No date header in response"  toTime = parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z"    . unpack . asText . decodeUtf8
src/EZCouch/Types.hs view
@@ -38,9 +38,10 @@   -- ^ 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+  | ResponseException Text   -- ^ E.g., server provided an unexpected response   | ConnectionException Text+  | ServerException Text   deriving (Show, Typeable) instance Exception EZCouchException
src/Util/Logging.hs view
@@ -15,8 +15,8 @@ import Data.Time (getZonedTime, getCurrentTime, formatTime) import Control.Concurrent (myThreadId) -logM :: (MonadIO m) => Int -> Text -> Text -> m ()-logM level logger message = liftIO $ +logLn :: (MonadIO m) => Int -> Text -> Text -> m ()+logLn level logger message = liftIO $    Logger.logM (unpack logger) (levelPriority level) (unpack message)  initialize = initializeWithFormat "$level $time, $logger: $message"