on master help sign in
Add ‘HttpBodyAllowed’ type family

This fixes a bug when e.g. POST request could not have no body.

commit2f0598dfd7909118cfa82aad21c514f6d9a0a379 authormrkkrp <markkarpov@opmbx.org> dateTue 8 Nov 2016, 14:11 (10 years ago) parentf78c7b7
1 file changed+39−11
Network/HTTP/Req.hs+39−11
Network/HTTP/Req.hs+39−11
@@ -97,6 +97,10 @@
9797{-# LANGUAGE ScopedTypeVariables #-}
9898{-# LANGUAGE TypeFamilies #-}
9999
100+#if MIN_VERSION_base(4,9,0)
101+{-# LANGUAGE UndecidableInstances #-}
102+#endif
103+
100104#if __GLASGOW_HASKELL__ >= 800
101105{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
102106#endif
@@ -143,6 +147,7 @@ module Network.HTTP.Req
143147 , FormUrlEncodedParam
144148 , HttpBody (..)
145149 , ProvidesBody
150+ , HttpBodyAllowed
146151 -- ** Optional parameters
147152 -- $optional-parameters
148153 , Option
@@ -211,7 +216,6 @@ import Data.List (nubBy)
211216import Data.List.NonEmpty (NonEmpty (..))
212217import Data.Proxy
213218import Data.Semigroup hiding (Option, option)
214−import Data.Text (Text)
215219import Data.Typeable (Typeable)
216220import GHC.Generics
217221import GHC.TypeLits
@@ -224,6 +228,7 @@ import qualified Data.ByteString as B
224228import qualified Data.ByteString.Lazy as BL
225229import qualified Data.CaseInsensitive as CI
226230import qualified Data.List.NonEmpty as NE
231+import qualified Data.Text as T
227232import qualified Data.Text.Encoding as T
228233import qualified Network.Connection as NC
229234import qualified Network.HTTP.Client as L
@@ -233,6 +238,12 @@ import qualified Network.HTTP.Req.AWS as AWS
233238import qualified Network.HTTP.Req.OAuth1 as OAuth1
234239import qualified Network.HTTP.Types as Y
235240
241+#if MIN_VERSION_base(4,9,0)
242+import Data.Kind (Constraint)
243+#else
244+import GHC.Exts (Constraint)
245+#endif
246+
236247----------------------------------------------------------------------------
237248-- Making a request
238249
@@ -369,7 +380,7 @@ req
369380 , HttpMethod method
370381 , HttpBody body
371382 , HttpResponse response
372− , AllowsBody method ~ ProvidesBody body )
383+ , HttpBodyAllowed (AllowsBody method) (ProvidesBody body) )
373384 => method -- ^ HTTP method
374385 -> Url scheme -- ^ 'Url' — location of resource
375386 -> body -- ^ Body of the request
@@ -657,20 +668,20 @@ instance HttpMethod method => RequestComponent (Womb "method" method) where
657668-- > https "юникод.рф"
658669-- > -- https://%D1%8E%D0%BD%D0%B8%D0%BA%D0%BE%D0%B4.%D1%80%D1%84
659670
660−data Url (scheme :: Scheme) = Url Scheme (NonEmpty Text)
671+data Url (scheme :: Scheme) = Url Scheme (NonEmpty T.Text)
661672 -- NOTE The second value is path segments in reversed order.
662673 deriving (Eq, Ord, Show, Data, Typeable, Generic)
663674
664675-- | Given host name, produce a 'Url' which have “http” as its scheme and
665676-- empty path. This also sets port to @80@.
666677
667−http :: Text -> Url 'Http
678+http :: T.Text -> Url 'Http
668679http = Url Http . pure
669680
670681-- | Given host name, produce a 'Url' which have “https” as its scheme and
671682-- empty path. This also sets port to @443@.
672683
673−https :: Text -> Url 'Https
684+https :: T.Text -> Url 'Https
674685https = Url Https . pure
675686
676687-- | Grow given 'Url' appending a single path segment to it. Note that the
@@ -684,7 +695,7 @@ Url secure path /~ segment = Url secure (NE.cons (toUrlPiece segment) path)
684695-- next URL piece is a 'Text' literal.
685696
686697infixl 5 /:
687−(/:) :: Url scheme -> Text -> Url scheme
698+(/:) :: Url scheme -> T.Text -> Url scheme
688699(/:) = (/~)
689700
690701-- | The 'parseUrlHttp' function provides an alternative method to get 'Url'
@@ -715,7 +726,7 @@ parseUrlHttps url' = do
715726-- | Get host\/collection of path pieces and possibly query parameters
716727-- already converted to 'Option'. This function is not public.
717728
718−parseUrlHelper :: ByteString -> Maybe (NonEmpty Text, Option scheme)
729+parseUrlHelper :: ByteString -> Maybe (NonEmpty T.Text, Option scheme)
719730parseUrlHelper url = do
720731 let (path', query') = B.break (== 0x3f) url
721732 query = mconcat (uncurry queryParam <$> Y.parseQueryText query')
@@ -819,7 +830,7 @@ instance HttpBody ReqBodyUrlEnc where
819830-- | An opaque monoidal value that allows to collect URL-encoded parameters
820831-- to be wrapped in 'ReqBodyUrlEnc'.
821832
822−newtype FormUrlEncodedParam = FormUrlEncodedParam [(Text, Maybe Text)]
833+newtype FormUrlEncodedParam = FormUrlEncodedParam [(T.Text, Maybe T.Text)]
823834 deriving (Semigroup, Monoid)
824835
825836instance QueryParam FormUrlEncodedParam where
@@ -852,6 +863,23 @@ type family ProvidesBody body :: CanHaveBody where
852863 ProvidesBody NoReqBody = 'NoBody
853864 ProvidesBody body = 'CanHaveBody
854865
866+-- | This type function allows any HTTP body if method says it
867+-- 'CanHaveBody'. When method says it should have 'NoBody', the only body
868+-- option to use is 'NoReqBody'.
869+--
870+-- __Note__: users of GHC 8.0.1 will see slightly more friendly error
871+-- messages when method does not allow a body and body is provided.
872+
873+type family HttpBodyAllowed
874+ (allowsBody :: CanHaveBody)
875+ (providesBody :: CanHaveBody) :: Constraint where
876+ HttpBodyAllowed 'NoBody 'NoBody = ()
877+ HttpBodyAllowed 'CanHaveBody body = ()
878+#if MIN_VERSION_base(4,9,0)
879+ HttpBodyAllowed 'NoBody 'CanHaveBody = TypeError
880+ ('Text "This HTTP method does not allow attaching a request body.")
881+#endif
882+
855883instance HttpBody body => RequestComponent (Womb "body" body) where
856884 getRequestMod (Womb body) = Endo $ \x ->
857885 x { L.requestBody = getRequestBody body
@@ -935,7 +963,7 @@ instance RequestComponent (Option scheme) where
935963-- > name =: value = queryParam name (pure value)
936964
937965infix 7 =:
938−(=:) :: (QueryParam param, ToHttpApiData a) => Text -> a -> param
966+(=:) :: (QueryParam param, ToHttpApiData a) => T.Text -> a -> param
939967name =: value = queryParam name (pure value)
940968
941969-- | Construct a flag, that is, valueless query parameter. For example, in
@@ -947,7 +975,7 @@ name =: value = queryParam name (pure value)
947975--
948976-- > queryFlag name = queryParam name Nothing
949977
950−queryFlag :: QueryParam param => Text -> param
978+queryFlag :: QueryParam param => T.Text -> param
951979queryFlag name = queryParam name (Nothing :: Maybe ())
952980
953981-- | A type class for query-parameter-like things. The reason to have
@@ -962,7 +990,7 @@ class QueryParam param where
962990 -- way). It's recommended to use @('=:')@ and 'queryFlag' instead of this
963991 -- method, because they are easier to read.
964992
965− queryParam :: ToHttpApiData a => Text -> Maybe a -> param
993+ queryParam :: ToHttpApiData a => T.Text -> Maybe a -> param
966994
967995instance QueryParam (Option scheme) where
968996 queryParam name mvalue =