diff --git a/chatwork.cabal b/chatwork.cabal --- a/chatwork.cabal +++ b/chatwork.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: chatwork -version: 0.1.1.5 +version: 0.1.2.0 synopsis: The ChatWork API in Haskell description: See README at homepage: https://github.com/matsubara0507/chatwork#readme @@ -57,7 +57,8 @@ , http-client >=0.5.5.0 && <0.6 , http-client-tls >=0.3.3.1 && <0.4 , http-types >=0.9.1 && <0.11 - , req >=0.3.0 && <0.6 + , req >=1.0.0 && <1.1.0 + , retry >=0.7.0 && <0.8 , text >=1.2.2.1 && <1.3 default-language: Haskell2010 @@ -77,7 +78,8 @@ , http-client >=0.5.5.0 && <0.6 , http-client-tls >=0.3.3.1 && <0.4 , http-types >=0.9.1 && <0.11 - , req >=0.3.0 && <0.6 + , req >=1.0.0 && <1.1.0 + , retry >=0.7.0 && <0.8 , text >=1.2.2.1 && <1.3 , chatwork default-language: Haskell2010 @@ -100,7 +102,8 @@ , http-client >=0.5.5.0 && <0.6 , http-client-tls >=0.3.3.1 && <0.4 , http-types >=0.9.1 && <0.11 - , req >=0.3.0 && <0.6 + , req >=1.0.0 && <1.1.0 + , retry >=0.7.0 && <0.8 , text >=1.2.2.1 && <1.3 , servant-server >=0.9.1.1 && <0.13 , warp >=3.2.11 && <3.3 diff --git a/src/ChatWork.hs b/src/ChatWork.hs --- a/src/ChatWork.hs +++ b/src/ChatWork.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-dodgy-exports #-} + -- | -- This module is re-export all endpoint functions and types from this package. -- diff --git a/src/ChatWork/MonadHttpIO.hs b/src/ChatWork/MonadHttpIO.hs --- a/src/ChatWork/MonadHttpIO.hs +++ b/src/ChatWork/MonadHttpIO.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | -- This module is that define MonadHttp type class instance of IO. -- if you want other definition, don't import this module. diff --git a/src/ChatWork/Types.hs b/src/ChatWork/Types.hs --- a/src/ChatWork/Types.hs +++ b/src/ChatWork/Types.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} --- {-# LANGUAGE OverlappingInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module ChatWork.Types ( -- * type synonym of Response Json @@ -35,7 +35,7 @@ type ChatWorkResponse a = JsonResponse (Either ChatWorkErrors a) instance {-# OVERLAPS #-} (FromJSON a) => FromJSON (Either ChatWorkErrors a) where - parseJSON v = ((Left <$> parseJSON v) <|> (Right <$> parseJSON v)) + parseJSON v = (Left <$> parseJSON v) <|> (Right <$> parseJSON v) -- | -- Helper Type Class of 'QueryParam' diff --git a/src/ChatWork/Types/Base.hs b/src/ChatWork/Types/Base.hs --- a/src/ChatWork/Types/Base.hs +++ b/src/ChatWork/Types/Base.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module ChatWork.Types.Base ( Room(..) diff --git a/src/ChatWork/Types/Rooms.hs b/src/ChatWork/Types/Rooms.hs --- a/src/ChatWork/Types/Rooms.hs +++ b/src/ChatWork/Types/Rooms.hs @@ -242,7 +242,7 @@ show DeleteRoom = "delete" instance FromForm DeleteRoomActionType where - fromForm f = parseUnique "action_type" f + fromForm = parseUnique "action_type" instance ToHttpApiData DeleteRoomActionType where toUrlPiece = pack . show diff --git a/src/ChatWork/Utils.hs b/src/ChatWork/Utils.hs --- a/src/ChatWork/Utils.hs +++ b/src/ChatWork/Utils.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} module ChatWork.Utils ( @@ -13,44 +15,126 @@ , strLength ) where +import Control.Exception (bracket, handle, mask_, throwIO, + try) +import Control.Monad ((>=>)) import Control.Monad.IO.Class (MonadIO (..)) +import Control.Retry (retrying) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B import Data.Default.Class (def) +import Data.IORef (modifyIORef', newIORef, + readIORef, writeIORef) import Data.List (lookup) import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (..)) import Network.Connection (initConnectionContext) import Network.HTTP.Client (BodyReader, Manager, ManagerSettings (..), Request, - Response (..), newManager) -import Network.HTTP.Client.Internal (constBodyReader) -import Network.HTTP.Client.TLS (mkManagerSettingsContext) + Response (..)) +import qualified Network.HTTP.Client as L +import qualified Network.HTTP.Client.Internal as LI +import qualified Network.HTTP.Client.TLS as L import Network.HTTP.Req (AllowsBody (..), CanHaveBody (..), + HttpConfig (..), + HttpException (..), HttpMethod (..), - HttpResponse (..), MonadHttp) + HttpResponse (..), + MonadHttp (..), getHttpConfig) import Network.HTTP.Types (methodDelete) import Network.HTTP.Types.Header (hContentLength) -- | -- Helper function that use custamized Manager getHttpResponse' :: (HttpResponse a, MonadHttp m) => Proxy a -> Request -> Manager -> m a -getHttpResponse' Proxy r _ = liftIO $ getHttpResponse r =<< fixEmptyStringManager +getHttpResponse' Proxy request _ = do + HttpConfig {..} <- getHttpConfig + let wrapVanilla = handle (throwIO . VanillaHttpException) + wrapExc = handle (throwIO . LI.toHttpException request) + withRRef = bracket + (newIORef Nothing) + (readIORef >=> mapM_ L.responseClose) + (liftIO . try . wrapVanilla . wrapExc) (withRRef $ \rref -> do + manager <- fixEmptyStringManager + let openResponse = mask_ $ do + r <- readIORef rref + mapM_ L.responseClose r + r' <- L.responseOpen request manager + writeIORef rref (Just r') + return r' + r <- retrying + httpConfigRetryPolicy + (\st r -> return $ httpConfigRetryJudge st r) + (const openResponse) + (preview, r') <- grabPreview bodyPreviewLength r + mapM_ LI.throwHttp (httpConfigCheckResponse request r' preview) + getHttpResponse r') + >>= either handleHttpException return fixEmptyStringManager :: IO Manager fixEmptyStringManager = do context <- initConnectionContext - let settings = mkManagerSettingsContext (Just context) def Nothing - newManager $ settings { managerModifyResponse = fixEmptyString } + let settings = L.mkManagerSettingsContext (Just context) def Nothing + L.newManager $ settings { managerModifyResponse = fixEmptyString } -- | -- if response is no contents, replace "[]". -- aeson return parse error when response is no content response fixEmptyString :: Response BodyReader -> IO (Response BodyReader) fixEmptyString res = do - reader <- constBodyReader ["[]"] + reader <- LI.constBodyReader ["[]"] let contentLength = fromMaybe "0" $ lookup hContentLength (responseHeaders res) return $ if contentLength /= "0" then res else res { responseBody = reader } + +---------------------------------------------------------------------------- +-- Helpers for response interpretations + +grabPreview :: Int -> L.Response L.BodyReader -> IO (ByteString, L.Response L.BodyReader) +grabPreview nbytes r = do + let br = L.responseBody r + (target, leftover, done) <- brReadN br nbytes + nref <- newIORef (0 :: Int) + let br' = do + n <- readIORef nref + let incn = modifyIORef' nref (+ 1) + case n of + 0 -> do + incn + if B.null target + then br' + else return target + 1 -> do + incn + if B.null leftover + then br' + else return leftover + _ -> + if done + then return B.empty + else br + return (target, r { L.responseBody = br' }) + +brReadN :: L.BodyReader -> Int -> IO (ByteString, ByteString, Bool) +brReadN br n = go 0 id id + where + go !tlen t l = do + chunk <- br + if B.null chunk + then return (r t, r l, True) + else do + let (target, leftover) = B.splitAt (n - tlen) chunk + tlen' = B.length target + t' = t . (target:) + l' = l . (leftover:) + if tlen + tlen' < n + then go (tlen + tlen') t' l' + else return (r t', r l', False) + r f = B.concat (f []) + +bodyPreviewLength :: Num a => a +bodyPreviewLength = 1024 -- | -- if want to use Delete HTTP methos with request param, use this type. diff --git a/test/ChatWork/Test/Types.hs b/test/ChatWork/Test/Types.hs --- a/test/ChatWork/Test/Types.hs +++ b/test/ChatWork/Test/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module ChatWork.Test.Types ( MessageParams (..)