ez-couch 0.5.1 → 0.6.0

raw patch · 7 files changed

+54/−42 lines, 7 filesdep ~classy-preludedep ~classy-prelude-conduitPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: classy-prelude, classy-prelude-conduit

API changes (from Hackage documentation)

Files

• ez-couch.cabal +3/−3
• src/EZCouch.hs +7/−4
• src/EZCouch/Action.hs +9/−7
• src/EZCouch/Parsing.hs +14/−12
• src/EZCouch/Retry.hs +0/−10
• src/EZCouch/Time.hs +19/−4
• src/EZCouch/WriteAction.hs +2/−2

@@ -1,5 +1,5 @@ name:               ez-couch-version:            0.5.1+version:            0.6.0 cabal-version:      >=1.8 build-type:         Simple license:            MIT@@ -65,8 +65,8 @@                     random >= 1.0,                     resourcet >= 0.3,                     string-conversions >= 0.2,-                    classy-prelude >= 0.4.4,-                    classy-prelude-conduit >= 0.4,+                    classy-prelude >= 0.5.0,+                    classy-prelude-conduit,                     hashable >= 1.1,                     vector  

@@ -48,6 +48,7 @@    -- * Execution Monad   MonadAction,+  Environment,   run,   runWithManager,   ConnectionSettings(..),@@ -80,11 +81,13 @@ 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+  flip runReaderT (settings, manager, fromIntegral 0) $ do+    timeDeviation <- getTimeDeviation+    withTimeDeviation timeDeviation $ runResourceT $ do+      resourceForkIO $ lift $ Sweeper.runSweeper+      lift $ action  run settings action = HTTP.withManager $ \manager ->    runWithManager manager settings action-

@@ -10,6 +10,7 @@ import EZCouch.Logging import EZCouch.Retry import EZCouch.Crash+import Data.Time import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP.Conduit as HTTP import qualified Network.HTTP.Conduit.Request as HTTP@@ -29,11 +30,12 @@  defaultPort = 5984 :: Int +type Environment = (ConnectionSettings, HTTP.Manager, NominalDiffTime)  -- | All EZCouch operations are performed in this monad.-class (MonadBaseControl IO m, MonadResource m, MonadReader (ConnectionSettings, HTTP.Manager) m) => MonadAction m where+class (MonadBaseControl IO m, MonadResource m, MonadReader Environment m) => MonadAction m where -instance (MonadResource m, MonadBaseControl IO m) => MonadAction (ReaderT (ConnectionSettings, HTTP.Manager) m) +instance (MonadResource m, MonadBaseControl IO m) => MonadAction (ReaderT Environment m)   generateRequest :: (MonadAction m)    => HTTP.Method@@ -42,7 +44,7 @@   -> LByteString   -> m (HTTP.Request m) generateRequest method dbPath qps body = do-  (settings, _) <- ask+  (settings, _, _) <- ask   return $ settingsRequest settings   where     headers = [("Content-Type", "application/json")]@@ -71,12 +73,12 @@   logLn 0 $ "Performing a "      ++ show (HTTP.method request)      ++ " at " ++ show (HTTP.url request)-  (_, manager) <- ask+  (_, manager, _) <- ask   retrying exceptionIntervals $      processResponse =<< http' request manager   where-    exceptionIntervals (ConnectionException {}) = [10^3, 10^6, 10^6*10]-    exceptionIntervals (ServerException {}) = [10^3, 10^6, 10^6*10]+    exceptionIntervals (ConnectionException {}) = map (*10^6) [0, 1, 5]+    exceptionIntervals (ServerException {}) = map (*10^6) [0, 1, 5]     exceptionIntervals _ = []  http' request manager = @@ -138,7 +140,7 @@         Aeson.Success _ ->            throwIO $ ServerException $ "Status " ++ show code ++ " response: " ++ (decodeUtf8 . toStrict . Aeson.encode) json         Aeson.Error m -> -          crash $ (pack) m ++ ". Response body: " ++ (toStrict . decodeUtf8 . Aeson.encode) json+          throwIO $ ServerException $ "Status " ++ show code     _ | code >= 400 ->       crash $ "Unexpected status code: " ++ show code ++ ", " ++ (decodeUtf8) msg     _ -> return $ ResponseOk response

@@ -3,8 +3,6 @@  import Prelude () import ClassyPrelude-import Control.Monad.Trans.Resource-import qualified Data.Text.Lazy as Text import EZCouch.Types import Data.Aeson as Aeson  @@ -16,12 +14,12 @@ rowsParser1 :: Parser (Vector Aeson.Value) rowsParser1 json   | Just (Aeson.Array rows) <- json .? "rows" = Right rows-  | otherwise = Left $ unexpectedJSONValue json+  | otherwise = Left $ unexpectedJSONValue "rowsParser1" json  rowsParser2 :: Parser (Vector Aeson.Value) rowsParser2 json   | Aeson.Array rows <- json = Right rows-  | otherwise = Left $ unexpectedJSONValue json+  | otherwise = Left $ unexpectedJSONValue "rowsParser2" json  idRevParser :: Parser (Text, Maybe Text) idRevParser o @ (Aeson.Object m) @@ -33,7 +31,7 @@     Just id <- lookup "id" m     = (,) <$> fromJSON' id <*> pure Nothing   | otherwise-    = Left $ unexpectedJSONValue o+    = Left $ unexpectedJSONValue "idRevParser" o  keyExistsParser :: (FromJSON k) => Parser (k, Bool) keyExistsParser o @ (Aeson.Object m) @@ -49,7 +47,7 @@     Just key <- lookup "key" m     = (,) <$> fromJSON' key <*> pure True   | otherwise-    = Left $ unexpectedJSONValue o+    = Left $ unexpectedJSONValue "keyExistsParser" o  persistedParser :: (FromJSON a) => Parser (Maybe (Persisted a)) persistedParser o@@ -59,8 +57,10 @@     Just doc <- o .? "doc",     Just rev <- doc .? "_rev"     = fmap Just $ Persisted <$> fromJSON' id <*> fromJSON' rev <*> fromJSON' doc+  | o .? "doc" == Just Aeson.Null+    = Right Nothing   | otherwise-    = Left $ unexpectedJSONValue o+    = Left $ unexpectedJSONValue "persistedParser" o  errorPersistedParser :: (FromJSON a) => Parser (Either (Text, Text) (Persisted a)) errorPersistedParser o @ (Aeson.Object m) @@ -70,7 +70,7 @@   | Just error <- lookup "error" m, Just reason <- lookup "reason" m     = fmap Left $ (,) <$> fromJSON' error <*> fromJSON' reason    | otherwise-    = Left $ unexpectedJSONValue o+    = Left $ unexpectedJSONValue "errorPersistedParser" o  maybePersistedByKeyParser :: (FromJSON a, FromJSON k) => Parser (k, Maybe (Persisted a)) maybePersistedByKeyParser o @ (Aeson.Object m) @@ -94,7 +94,7 @@     Just key <- lookup "key" m     = (,) <$> fromJSON' key <*> pure Nothing   | otherwise-    = Left $ unexpectedJSONValue o+    = Left $ unexpectedJSONValue "maybePersistedByKeyParser" o   @@ -103,10 +103,12 @@   Aeson.Error s -> Left $ "fromJSON failed with a message `"      ++ fromString s      ++ "` on the following value: " -    ++ (Text.toStrict . decodeUtf8 $ Aeson.encode json) +    ++ (toStrict . decodeUtf8 $ Aeson.encode json)  -unexpectedJSONValue json = -  "Unexpected JSON value: " ++ (Text.toStrict . decodeUtf8 $ Aeson.encode json)+unexpectedJSONValue parserName json = +  parserName ++ ": "+    ++ "Unexpected JSON value: " +    ++ (toStrict . decodeUtf8 $ Aeson.encode json)  o .? k = pure o ?.? k o ?.? k = o >>= objectKey k

@@ -7,16 +7,6 @@ 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

@@ -6,14 +6,18 @@ import System.Locale import Data.Time import qualified Network.HTTP.Types as HTTP-+import Control.Monad.Reader import EZCouch.Types import EZCouch.Action --- | Current time according to server.+-- | Current time according to server. This function doesn't actually emit any+-- requests to the server, calculating the value from a deviation of local time+-- from server time determined at the beginning of the EZCouch session. readTime :: MonadAction m => m UTCTime -readTime = getResponseHeaders HTTP.methodGet mempty mempty mempty-  >>= getHeadersTime+readTime = do+  (_, _, deviation) <- ask+  localTime <- liftIO $ getCurrentTime+  return $ addUTCTime deviation localTime  getHeadersTime ((name, value) : tail)    | name == HTTP.hDate = case toTime value of@@ -24,3 +28,14 @@  toTime = parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z"    . unpack . asText . decodeUtf8++getTimeDeviation :: MonadAction m => m NominalDiffTime +getTimeDeviation = do+  dbTime <- getResponseHeaders HTTP.methodGet mempty mempty mempty+    >>= getHeadersTime+  localTime <- liftIO $ getCurrentTime+  return $ diffUTCTime dbTime localTime++withTimeDeviation :: (MonadAction m) => NominalDiffTime -> m a -> m a+withTimeDeviation timeDeviation =+  local (\(settings, manager, _) -> (settings, manager, timeDeviation)) 

@@ -61,7 +61,7 @@  createIdentifiedEntities :: (MonadAction m, ToJSON a)    => [Identified a]-  -> m [Either (Text, a) (Persisted a)]+  -> m [Either (Identified a) (Persisted a)] createIdentifiedEntities idsToVals    = writeOperationsAction [Create id val | (id, val) <- idsToVals]       >>= mapM convertResult@@ -118,4 +118,4 @@      lookupThrowing id cache = case lookup id cache of   Just val -> return val-  Nothing -> throwIO $ ParsingException $ "Unexpected id: " ++ show id+  Nothing -> throwIO $ ResponseException $ "Unexpected id: " ++ show id