5d75bd0 · typeable/req

git.iko.soy/typeable/req

Add a way to avoid orphans (#26)

commit5d75bd09e7ba0227a169d2e3b819a469eb57332b authorMark Karpov <markkarpov92@gmail.com> dateMon 7 Aug 2017, 14:06 (9 years ago) parent73525b0

4 files changed+77−10

compare with master

unifiedsplit

CHANGELOG.md+5 Network/HTTP/Req.hs+42 httpbin-tests/Network/HTTP/ReqSpec.hs+27−10 req.cabal+3

CHANGELOG.md+5

@@ -1,3 +1,8 @@

1+## Req 0.4.0

3+* Added the `Req` monad and `runReq` function to run it. This allows to use

4+ `req` without defining new (orphan) instances.

16## Req 0.3.1

38* Added `basicAuthUnsafe`.

Network/HTTP/Req.hs+42

@@ -95,6 +95,7 @@

9595{-# LANGUAGE FlexibleInstances #-}

9696{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9797{-# LANGUAGE KindSignatures #-}

98+{-# LANGUAGE MultiParamTypeClasses #-}

9899{-# LANGUAGE OverloadedStrings #-}

99100{-# LANGUAGE RankNTypes #-}

100101{-# LANGUAGE RecordWildCards #-}

@@ -123,6 +124,8 @@ module Network.HTTP.Req

123124 -- $embedding-requests

124125 , MonadHttp (..)

125126 , HttpConfig (..)

127+ , Req

128+ , runReq

126129 -- * Request

127130 -- ** Method

128131 -- $method

@@ -213,7 +216,10 @@ import Control.Applicative

213216import Control.Arrow (first, second)

214217import Control.Exception (Exception, try, handle, throwIO)

215218import Control.Monad

219+import Control.Monad.Base

216220import Control.Monad.IO.Class

221+import Control.Monad.Reader

222+import Control.Monad.Trans.Control

217223import Control.Retry

218224import Data.Aeson (ToJSON (..), FromJSON (..))

219225import Data.ByteString (ByteString)

@@ -582,6 +588,42 @@ instance RequestComponent HttpConfig where

582588 , L.redirectCount = httpConfigRedirectCount

583589 , LI.requestManagerOverride = httpConfigAltManager }

584590

591+-- | A monad that allows to run 'req' in any 'IO'-enabled monad without

592+-- having to define new instances.

593+--

594+-- @since 0.4.0

595+

596+newtype Req a = Req (ReaderT HttpConfig IO a)

597+ deriving ( Functor

598+ , Applicative

599+ , Monad

600+ , MonadIO )

601+

602+instance MonadBase IO Req where

603+ liftBase = liftIO

604+

605+instance MonadBaseControl IO Req where

606+ type StM Req a = a

607+ liftBaseWith f = Req . ReaderT $ \r -> f (runReq r)

608+ {-# INLINEABLE liftBaseWith #-}

609+ restoreM = Req . ReaderT . const . return

610+ {-# INLINEABLE restoreM #-}

611+

612+instance MonadHttp Req where

613+ handleHttpException = Req . lift . throwIO

614+ getHttpConfig = Req ask

615+

616+-- | Run a computation in the 'Req' monad with the given 'HttpConfig'. In

617+-- case of exceptional situation an 'HttpException' will be thrown.

618+--

619+-- @since 0.4.0

620+

621+runReq :: MonadIO m

622+ => HttpConfig -- ^ 'HttpConfig' to use

623+ -> Req a -- ^ Computation to run

624+ -> m a

625+runReq config (Req m) = liftIO (runReaderT m config)

626+

585627----------------------------------------------------------------------------

586628-- Request—Method

587629

httpbin-tests/Network/HTTP/ReqSpec.hs+27−10

@@ -9,8 +9,9 @@ module Network.HTTP.ReqSpec

99 ( spec )

1010where

1111

12−import Control.Exception (throwIO)

12+import Control.Exception

1313import Control.Monad.Reader

14+import Control.Monad.Trans.Control

1415import Data.Aeson (Value (..), ToJSON (..), object, (.=))

1516import Data.Default.Class

1617import Data.IORef

@@ -41,16 +42,17 @@ import Data.Word (Word)

4142spec :: Spec

4243spec = do

4344

44− describe "exception throwing on non 2xx-status codes" $

45− it "throws indeed for non-2xx" $ do

46− let selector :: HttpException -> Bool

47− selector (VanillaHttpException

48− (L.HttpExceptionRequest _

49− (L.StatusCodeException response chunk))) =

50− L.responseStatus response == Y.status404 && not (B.null chunk)

51− selector _ = False

45+ describe "exception throwing on non-2xx status codes" $

46+ it "throws indeed for non-2xx" $

5247 req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty

53− `shouldThrow` selector

48+ `shouldThrow` selector404

49+

50+ describe "exception throwing on non-2xx status codes (Req monad)" $

51+ it "throws indeed for non-2xx" $

52+ asIO . runReq def $

53+ liftBaseWith $ \run ->

54+ run (req GET (httpbin /: "foo") NoReqBody ignoreResponse mempty)

55+ `shouldThrow` selector404

5456

5557 describe "response check via httpConfigCheckResponse" $

5658 context "if it's set to always throw" $

@@ -401,6 +403,15 @@ checkStatusCode code =

401403 NoReqBody ignoreResponse mempty

402404 responseStatusCode r `shouldBe` code

403405

406+-- | Exception selector that selects only 404 “Not found” exceptions.

407+

408+selector404 :: HttpException -> Bool

409+selector404 (VanillaHttpException

410+ (L.HttpExceptionRequest _

411+ (L.StatusCodeException response chunk))) =

412+ L.responseStatus response == Y.status404 && not (B.null chunk)

413+selector404 _ = False

414+

404415-- | Empty JSON 'Object'.

405416

406417emptyObject :: Value

@@ -410,3 +421,9 @@ emptyObject = Object HM.empty

410421

411422reflectJSON :: ToJSON a => a -> Text

412423reflectJSON = T.decodeUtf8 . BL.toStrict . A.encode

424+

425+-- | Clarify to the type checker that the inner computation is in the 'IO'

426+-- monad.

427+

428+asIO :: IO a -> IO a

429+asIO = id

req.cabal+3

@@ -39,11 +39,13 @@ library

3939 , http-client >= 0.5 && < 0.6

4040 , http-client-tls >= 0.3.2 && < 0.4

4141 , http-types >= 0.8 && < 10.0

42+ , monad-control >= 1.0 && < 1.1

4243 , mtl >= 2.0 && < 3.0

4344 , retry >= 0.7 && < 0.8

4445 , text >= 0.2 && < 1.3

4546 , time >= 1.2 && < 1.9

4647 , transformers >= 0.4 && < 0.6

48+ , transformers-base

4749 if !impl(ghc >= 8.0)

4850 build-depends: semigroups == 0.18.*

4951 exposed-modules: Network.HTTP.Req

@@ -92,6 +94,7 @@ test-suite httpbin-tests

9294 , hspec >= 2.0 && < 3.0

9395 , http-client >= 0.5 && < 0.6

9496 , http-types >= 0.8 && < 10.0

97+ , monad-control >= 1.0 && < 1.1

9598 , mtl >= 2.0 && < 3.0

9699 , req

97100 , retry >= 0.7 && < 0.8