diff --git a/ez-couch.cabal b/ez-couch.cabal --- a/ez-couch.cabal +++ b/ez-couch.cabal @@ -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, diff --git a/src/EZCouch/Action.hs b/src/EZCouch/Action.hs --- a/src/EZCouch/Action.hs +++ b/src/EZCouch/Action.hs @@ -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 diff --git a/src/EZCouch/Crash.hs b/src/EZCouch/Crash.hs new file mode 100644 --- /dev/null +++ b/src/EZCouch/Crash.hs @@ -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 diff --git a/src/EZCouch/Design.hs b/src/EZCouch/Design.hs --- a/src/EZCouch/Design.hs +++ b/src/EZCouch/Design.hs @@ -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 = diff --git a/src/EZCouch/Model/Error.hs b/src/EZCouch/Model/Error.hs new file mode 100644 --- /dev/null +++ b/src/EZCouch/Model/Error.hs @@ -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" diff --git a/src/EZCouch/Parsing.hs b/src/EZCouch/Parsing.hs --- a/src/EZCouch/Parsing.hs +++ b/src/EZCouch/Parsing.hs @@ -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 `" diff --git a/src/EZCouch/ReadAction.hs b/src/EZCouch/ReadAction.hs --- a/src/EZCouch/ReadAction.hs +++ b/src/EZCouch/ReadAction.hs @@ -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 diff --git a/src/EZCouch/Types.hs b/src/EZCouch/Types.hs --- a/src/EZCouch/Types.hs +++ b/src/EZCouch/Types.hs @@ -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 diff --git a/src/EZCouch/WriteAction.hs b/src/EZCouch/WriteAction.hs --- a/src/EZCouch/WriteAction.hs +++ b/src/EZCouch/WriteAction.hs @@ -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 = []