packages feed

ez-couch 0.4.3 → 0.5.0

raw patch · 9 files changed

+128/−58 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

ez-couch.cabal view
@@ -1,5 +1,5 @@ name:               ez-couch-version:            0.4.3+version:            0.5.0 cabal-version:      >=1.8 build-type:         Simple license:            MIT@@ -44,6 +44,8 @@                     EZCouch.EntityIsolation                     EZCouch.Sweeper                     EZCouch.Logging+                    EZCouch.Model.Error+                    EZCouch.Crash   build-depends:    base >= 4.5 && < 5,                     ghc-prim >= 0.2,                     time >= 1.4,
src/EZCouch/Action.hs view
@@ -9,14 +9,15 @@ 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 EZCouch.Crash+import qualified Network.HTTP.Types as HTTP+import qualified Network.HTTP.Conduit as HTTP+import qualified Network.HTTP.Conduit.Request as HTTP import qualified Database.CouchDB.Conduit.View.Query as CC import qualified Blaze.ByteString.Builder as Blaze import qualified Data.Aeson as Aeson import qualified Data.Conduit.Attoparsec as Atto-+import qualified EZCouch.Model.Error as Error  data ConnectionSettings    = ConnectionSettings {  @@ -30,80 +31,112 @@   -- | All EZCouch operations are performed in this monad.-class (MonadBaseControl IO m, MonadResource m, MonadReader (ConnectionSettings, Manager) m) => MonadAction m where+class (MonadBaseControl IO m, MonadResource m, MonadReader (ConnectionSettings, HTTP.Manager) m) => MonadAction m where -instance (MonadResource m, MonadBaseControl IO m) => MonadAction (ReaderT (ConnectionSettings, Manager) m) +instance (MonadResource m, MonadBaseControl IO m) => MonadAction (ReaderT (ConnectionSettings, HTTP.Manager) m)   generateRequest :: (MonadAction m) -  => Method+  => HTTP.Method   -> Maybe [Text]   -> [CC.CouchQP]   -> LByteString-  -> m (Request m)+  -> m (HTTP.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+    query = HTTP.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 * 5+      authenticated $ HTTP.def {+        HTTP.method = method,+        HTTP.host = encodeUtf8 host,+        HTTP.requestHeaders = headers,+        HTTP.port = port,+        HTTP.path = packPath $ maybe [] (database : ) $ dbPath,+        HTTP.queryString = query,+        HTTP.requestBody = HTTP.RequestBodyLBS body,+        HTTP.checkStatus = \_ _ -> Nothing,+        HTTP.responseTimeout = Just $ 10 ^ 6 * 5       }       where         authenticated-          | Just (username, password) <- auth = applyBasicAuth (encodeUtf8 username) (encodeUtf8 password)+          | Just (username, password) <- auth = HTTP.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))+  => HTTP.Request m+  -> m (Response (HTTP.Response (UnparsedBody m))) performRequest request = do   logLn 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+  retrying exceptionIntervals $ +    processResponse =<< 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 (ServerException {}) = [10^6, 10^6*10, 10^6*60]+    exceptionIntervals (ServerException {}) = [10^3, 10^6, 10^6*10]     exceptionIntervals _ = []++http' request manager = +  (flip catch) handleIOException $+    (flip catch) handleHttpException $ +      HTTP.http request manager+  where     handleHttpException e = case e of-      FailedConnectionException host port -> throwIO $ ConnectionException $ +      HTTP.FailedConnectionException host port -> throwIO $ ConnectionException $          "FailedConnectionException: " ++ pack host ++ " " ++ show port-      ResponseTimeout -> throwIO $ ConnectionException $ "ResponseTimeout"+      HTTP.ResponseTimeout -> throwIO $ ConnectionException $ "ResponseTimeout"       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+  case response of+    ResponseNotFound -> crash $ "Getting headers from a Not Found response"+    ResponseOk response -> do+      HTTP.responseBody response $$+- return ()+      return $ HTTP.responseHeaders response  getResponseJSON method path qps body = do   response <- performRequest =<< generateRequest method path qps body -  responseBody response $$+- Atto.sinkParser Aeson.json+  case response of+    ResponseOk response -> do+      json <- HTTP.responseBody response $$+- Atto.sinkParser Aeson.json+      return $ ResponseOk json+    ResponseNotFound -> return ResponseNotFound  putAction path = getResponseJSON HTTP.methodPut (Just path) postAction path = getResponseJSON HTTP.methodPost (Just path) getAction path = getResponseJSON HTTP.methodGet (Just path)  packPath = Blaze.toByteString . HTTP.encodePathSegments . filter (/="")++type UnparsedBody m = ResumableSource m ByteString++-- | +data Response r =+  ResponseNotFound |+  ResponseOk r++processResponse :: MonadAction m+  => HTTP.Response (UnparsedBody m) -> m (Response (HTTP.Response (UnparsedBody m)))+processResponse response@(HTTP.Response (HTTP.Status code msg) _ headers body) =+  case code of+    -- Handle status 500 by extracting a possible "Not found response" or +    -- throwing a ServerException otherwise+    _ | code `elem` [404, 500] -> do+      json <- body $$+- Atto.sinkParser Aeson.json+      case Aeson.fromJSON json of+        Aeson.Success (Error.Error "error" (Just reason) _)+          | isPrefixOf "{{try_clause,{not_found,missing}}" reason+          -> return ResponseNotFound+        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+    _ | code >= 400 ->+      crash $ "Unexpected status code: " ++ show code ++ ", " ++ (decodeUtf8) msg+    _ -> return $ ResponseOk response
+ src/EZCouch/Crash.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, DeriveGeneric #-}+module EZCouch.Crash where++import Prelude ()+import ClassyPrelude+++crash msg = error $ unpack $ asText $ "EZCouch bug occurred, please report it. " ++ msg
src/EZCouch/Design.hs view
@@ -23,14 +23,14 @@ 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 = do+      getAction ["_design", designName] [] "" >>= \r -> case r of+        ResponseNotFound -> return Nothing+        ResponseOk json -> +          runParser errorPersistedParser json +            >>= return . either (const Nothing) Just       where         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, Entity a) => Design a -> m (Persisted (Design a)) createOrUpdateDesign design =
+ src/EZCouch/Model/Error.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, DeriveGeneric #-}+module EZCouch.Model.Error where++import Prelude ()+import ClassyPrelude+import GHC.Generics+import Data.Aeson hiding (Error)++data Error = +  Error {+    error :: Text, +    reason :: Maybe Text, +    stack :: Maybe [Text]+  } +  deriving (Show, Eq, Generic)++instance FromJSON Error where+  parseJSON = withObject "Error" $ \o -> +    Error <$> o .: "error" <*> o .:? "reason" <*> o .:? "stack"
src/EZCouch/Parsing.hs view
@@ -97,6 +97,7 @@     = Left $ unexpectedJSONValue o  + fromJSON' json = case fromJSON json of   Aeson.Success z -> Right $ z   Aeson.Error s -> Left $ "fromJSON failed with a message `"
src/EZCouch/ReadAction.hs view
@@ -9,6 +9,7 @@ import EZCouch.Parsing import EZCouch.View import EZCouch.Logging+import EZCouch.Crash import qualified EZCouch.Encoding as Encoding import qualified Database.CouchDB.Conduit.View.Query as CC import qualified System.Random as Random@@ -35,17 +36,18 @@   -> 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-        logLn 2 $ "View " -          ++ fromMaybe undefined (viewGeneratedName view) -          ++ " does not exist. Generating."-        createOrUpdateView view -        action path qps body-    _ -> throwIO e+readAction view mode skip limit desc includeDocs = do+  result <- action path qps body +  case result of+    ResponseNotFound -> do+      logLn 2 $ "View " +        ++ fromMaybe undefined (viewGeneratedName view) +        ++ " does not exist. Generating."+      createOrUpdateView view +      action path qps body >>= \r -> case r of+        ResponseNotFound -> crash "readAction keeps getting a ResponseNotFound"+        ResponseOk json -> return json+    ResponseOk json -> return json   where     action = case mode of       KeysSelectionList {} -> postAction
src/EZCouch/Types.hs view
@@ -41,7 +41,9 @@   | ResponseException Text   -- ^ E.g., server provided an unexpected response   | ConnectionException Text+  -- ^ Either a connection got closed or a timeout passed   | ServerException Text+  -- ^ A weird status 500 response   deriving (Show, Typeable) instance Exception EZCouchException
src/EZCouch/WriteAction.hs view
@@ -9,6 +9,7 @@ import EZCouch.Types import EZCouch.Entity import EZCouch.Parsing+import EZCouch.Crash import qualified EZCouch.Encoding as Encoding import qualified Database.CouchDB.Conduit.View.Query as CC import Data.Aeson as Aeson@@ -23,8 +24,10 @@   -> m [(Text, Maybe Text)]   -- ^ Maybe rev by id. Nothing on failure. writeOperationsAction ops =-  postAction path qps body >>= -    runParser (rowsParser2 >=> mapM idRevParser . toList)+  postAction path qps body >>= \r -> case r of+    ResponseNotFound -> crash $ "EZCouch.WriteAction.writeOperationsAction: unexpected Not Found response"+    ResponseOk json -> +      runParser (rowsParser2 >=> mapM idRevParser . toList) json   where     path = ["_bulk_docs"]     qps = []