chatwork 0.1.1.5 → 0.1.2.0

raw patch · 8 files changed

+110/−17 lines, 8 filesdep +retrydep ~reqPVP ok

version bump matches the API change (PVP)

Dependencies added: retry

Dependency ranges changed: req

API changes (from Hackage documentation)

Files

chatwork.cabal +7/−4
src/ChatWork.hs +2/−0
src/ChatWork/MonadHttpIO.hs +2/−0
src/ChatWork/Types.hs +2/−2
src/ChatWork/Types/Base.hs +3/−2
src/ChatWork/Types/Rooms.hs +1/−1
src/ChatWork/Utils.hs +92/−8
test/ChatWork/Test/Types.hs +1/−0

chatwork.cabal view

@@ -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 <https://github.com/matsubara0507/chatwork#readme> 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

src/ChatWork.hs view

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fno-warn-dodgy-exports #-}
+
 -- |
 -- This module is re-export all endpoint functions and types from this package.
 --

src/ChatWork/MonadHttpIO.hs view

@@ -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.

src/ChatWork/Types.hs view

@@ -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'

src/ChatWork/Types/Base.hs view

@@ -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(..)

src/ChatWork/Types/Rooms.hs view

@@ -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

src/ChatWork/Utils.hs view

@@ -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.

test/ChatWork/Test/Types.hs view

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module ChatWork.Test.Types
     ( MessageParams (..)