webapi 0.2.1.0 → 0.2.2.0
raw patch · 11 files changed
+175/−103 lines, 11 filesdep ~aesondep ~basedep ~binary
Dependency ranges changed: aeson, base, binary, exceptions, hspec, http-types, time, transformers, vector, wai, wai-extra, warp
Files
- ChangeLog.md +3/−0
- src/WebApi/Client.hs +53/−20
- src/WebApi/ContentTypes.hs +17/−0
- src/WebApi/Contract.hs +14/−0
- src/WebApi/Internal.hs +16/−10
- src/WebApi/Param.hs +20/−20
- src/WebApi/Server.hs +1/−2
- tests/WebApi/MockSpec.hs +5/−5
- tests/WebApi/RequestSpec.hs +10/−10
- tests/WebApi/ResponseSpec.hs +4/−4
- webapi.cabal +32/−32
ChangeLog.md view
@@ -1,5 +1,8 @@ # Changelog +## 0.2.2+* Added support for GHC 8+ ## 0.2.1 * Added `RequestBody` to the `Request` type. This allows user to have content in request's body with the desired `Content-Type`.
src/WebApi/Client.hs view
@@ -75,7 +75,6 @@ -- | Creates the 'Response' type from the response body. fromClientResponse :: forall m r.( FromHeader (HeaderOut m r)- , ParamErrToApiErr (ApiErr m r) , Decodings (ContentTypes m r) (ApiOut m r) , Decodings (ContentTypes m r) (ApiErr m r) , CookieOut m r ~ ()@@ -87,25 +86,23 @@ respHdr = fromHeader hdrsOut :: Validation [ParamErr] (HeaderOut m r) -- respCk = fromCookie respBodyBS <- respBody- return $ case statusIsSuccessful status of- True -> case Success <$> pure status- <*> (Validation $ toParamErr $ decode' (Route' :: Route' m r) respBodyBS)- <*> respHdr- <*> pure () of+ return $ case Success <$> pure status+ <*> (Validation $ toParamErr $ decode' (Route' :: Route' m r) respBodyBS)+ <*> respHdr+ <*> pure () of Validation (Right success) -> success- Validation (Left errs) -> Failure $ Left $ ApiError status (toApiErr errs) Nothing Nothing- False -> case ApiError- <$> pure status- <*> (Validation $ toParamErr $ decode' (Route' :: Route' m r) respBodyBS)- <*> (Just <$> respHdr)- -- TODO: Handle cookies- <*> pure Nothing of- Validation (Right failure) -> (Failure . Left) failure- Validation (Left _errs) -> Failure $ Right (OtherError (toException UnknownClientException))-+ Validation (Left _errs) -> + case ApiError+ <$> pure status+ <*> (Validation $ toParamErr $ decode' (Route' :: Route' m r) respBodyBS)+ <*> (Just <$> respHdr)+ -- TODO: Handle cookies+ <*> pure Nothing of+ Validation (Right failure) -> (Failure . Left) failure+ Validation (Left _errs) -> Failure $ Right (OtherError (toException UnknownClientException)) where toParamErr :: Either String a -> Either [ParamErr] a toParamErr (Left _str) = Left []- toParamErr (Right r) = Right r+ toParamErr (Right r) = Right r decode' :: ( Decodings (ContentTypes m r) a ) => apiRes m r -> ByteString -> Either String a@@ -165,7 +162,8 @@ cts' = Proxy :: Proxy (StripContents (RequestBody m r)) -- | Given a `Request` type, create the request and obtain a response. Gives back a 'Response'.-client :: ( CookieOut m r ~ ()+client :: forall m r .+ ( CookieOut m r ~ () , ToParam (PathParam m r) 'PathParam , ToParam (QueryParam m r) 'QueryParam , ToParam (FormParam m r) 'FormParam@@ -174,7 +172,6 @@ , FromHeader (HeaderOut m r) , Decodings (ContentTypes m r) (ApiOut m r) , Decodings (ContentTypes m r) (ApiErr m r)- , ParamErrToApiErr (ApiErr m r) , SingMethod m , MkPathFormatString r , PartEncodings (RequestBody m r)@@ -183,7 +180,43 @@ client sett req = do cReqInit <- HC.parseUrl (baseUrl sett) cReq <- toClientRequest cReqInit req- HC.withResponse cReq (connectionManager sett) fromClientResponse+ catches (HC.withResponse cReq (connectionManager sett) fromClientResponse)+ [ Handler (\(ex :: HC.HttpException) -> do+ case ex of+ HC.StatusCodeException status resHeaders _ -> do+ let mBody = find ((== "X-Response-Body-Start") . fst) resHeaders+ bdy = case mBody of+ Nothing -> "[]"+ Just (_, body) -> body+ removeExtraHeaders = filter (\(x, _) -> (x /= "X-Request-URL") || (x /= "X-Response-Body-Start"))+ return $ case ApiError+ <$> pure status+ <*> (Validation $ toParamErr $ decode' resHeaders (Route' :: Route' m r) bdy)+ <*> (Just <$> (fromHeader . removeExtraHeaders $ resHeaders))+ -- TODO: Handle cookies+ <*> pure Nothing of+ Validation (Right failure) -> (Failure . Left) failure+ Validation (Left _errs) -> Failure $ Right (OtherError (toException UnknownClientException))+ _ -> return . Failure . Right . OtherError $ toException ex+ )+ , Handler (\(ex :: IOException) -> return . Failure . Right . OtherError $ toException ex)+ ]+ where toParamErr :: Either String a -> Either [ParamErr] a+ toParamErr (Left _str) = Left []+ toParamErr (Right r) = Right r++ decode' :: ( Decodings (ContentTypes m r) a+ ) => [Header] -> apiRes m r -> ByteString -> Either String a+ decode' h r o = case getContentType h of+ Just ctype -> let decs = decodings (reproxy r) o+ in maybe (firstRight (map snd decs)) id (mapContentMedia decs ctype)+ Nothing -> firstRight (map snd (decodings (reproxy r) o))++ reproxy :: apiRes m r -> Proxy (ContentTypes m r)+ reproxy = const Proxy++ firstRight :: [Either String b] -> Either String b+ firstRight = maybe (Left "Couldn't find matching Content-Type") id . find isRight -- | This exception is used to signal an irrecoverable error while deserializing the response. data UnknownClientException = UnknownClientException
src/WebApi/ContentTypes.hs view
@@ -4,6 +4,7 @@ Stability : experimental -} +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-}@@ -14,11 +15,13 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TupleSections #-}+ module WebApi.ContentTypes ( -- * Predefined Content Types. JSON , PlainText+ , HTML , OctetStream , MultipartFormData , UrlEncoded@@ -44,7 +47,11 @@ import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8 (fromText) import Data.Aeson (ToJSON (..), FromJSON (..), eitherDecodeStrict)+#if MIN_VERSION_aeson(0,9,0)+import Data.Aeson.Encode (encodeToBuilder)+#else import Data.Aeson.Encode (encodeToByteStringBuilder)+#endif import Data.ByteString (ByteString) import Data.Maybe (fromMaybe) import Data.Proxy@@ -61,6 +68,9 @@ -- | Type representing content type of @text/plain@. data PlainText +-- | Type representing content type of @text/html@.+data HTML+ -- | Type representing content type of @application/octetstream@. data OctetStream @@ -106,6 +116,9 @@ instance Accept PlainText where contentType _ = "text" // "plain" /: ("charset", "utf-8") +instance Accept HTML where+ contentType _ = "text" // "html" /: ("charset", "utf-8")+ instance Accept OctetStream where contentType _ = "application" // "octet-stream" @@ -120,7 +133,11 @@ encode :: Proxy a -> c -> Builder instance (ToJSON c) => Encode JSON c where+#if MIN_VERSION_aeson(0,9,0) + encode _ = encodeToBuilder . toJSON+#else encode _ = encodeToByteStringBuilder . toJSON+#endif instance (ToText a) => Encode PlainText a where encode _ = Utf8.fromText . toText
src/WebApi/Contract.hs view
@@ -15,6 +15,7 @@ -} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-}@@ -23,6 +24,11 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE PatternSynonyms #-}++#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE UndecidableSuperClasses #-}+#endif+ module WebApi.Contract (-- * API Contract WebApi (..)@@ -182,7 +188,11 @@ data OtherError = OtherError { exception :: SomeException } -- | Used for constructing 'Request'+#if __GLASGOW_HASKELL__ >= 800+pattern Request :: (SingMethod m)+#else pattern Request :: () => (SingMethod m)+#endif => PathParam m r -> QueryParam m r -> FormParam m r@@ -199,7 +209,11 @@ -- | Exists only for compatability reasons. This will be removed in the next version. -- Use 'Request' pattern instead+#if __GLASGOW_HASKELL__ >= 800+pattern Req :: (SingMethod m, HListToTuple (StripContents (RequestBody m r)) ~ ())+#else pattern Req :: () => (SingMethod m, HListToTuple (StripContents (RequestBody m r)) ~ ())+#endif => PathParam m r -> QueryParam m r -> FormParam m r
src/WebApi/Internal.hs view
@@ -1,12 +1,18 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE UndecidableSuperClasses #-}+#endif+ module WebApi.Internal where import Blaze.ByteString.Builder (Builder, toByteString)@@ -161,7 +167,7 @@ fillHoles Hole (segs, dynV: xs) = (decodeUtf8 dynV : segs, xs) fillHoles Hole (_segs, []) = error "Panic: fewer pathparams than holes" - toRoute :: (MkPathFormatString r) => route m r -> Proxy r+ toRoute :: route m r -> Proxy r toRoute = const Proxy -- | Describes the implementation of a single API end point corresponding to @ApiContract (ApiInterface p) m r@
src/WebApi/Param.hs view
@@ -447,11 +447,11 @@ deriving (Show, Eq, Read) -- | Serialize a type without nesting.-toNonNestedParam :: (ToParam (NonNested a) parK, EncodeParam a) => Proxy (parK :: ParamK) -> ByteString -> a -> [SerializedData parK]+toNonNestedParam :: (ToParam (NonNested a) parK) => Proxy (parK :: ParamK) -> ByteString -> a -> [SerializedData parK] toNonNestedParam par pfx a = toParam par pfx (NonNested a) -- | (Try to) Deserialize a type without nesting.-fromNonNestedParam :: (FromParam (NonNested a) parK, DecodeParam a) => Proxy (parK :: ParamK) -> ByteString -> Trie (DeSerializedData parK) -> Validation [ParamErr] a+fromNonNestedParam :: (FromParam (NonNested a) parK) => Proxy (parK :: ParamK) -> ByteString -> Trie (DeSerializedData parK) -> Validation [ParamErr] a fromNonNestedParam par pfx kvs = getNonNestedParam <$> fromParam par pfx kvs instance (EncodeParam a) => ToParam (NonNested a) 'QueryParam where@@ -682,13 +682,13 @@ toParam _ pfx (OptValue (Just val)) = [(pfx, encodeParam val)] toParam _ _ (OptValue Nothing) = [] -instance (ToJSON a, FromJSON a) => ToParam (JsonOf a) 'QueryParam where+instance (ToJSON a) => ToParam (JsonOf a) 'QueryParam where toParam _ pfx val = [(pfx, Just $ encodeParam val)] -instance (ToJSON a, FromJSON a) => ToParam (JsonOf a) 'FormParam where+instance (ToJSON a) => ToParam (JsonOf a) 'FormParam where toParam _ pfx val = [(pfx, encodeParam val)] -instance (ToJSON a, FromJSON a) => ToParam (JsonOf a) 'Cookie where+instance (ToJSON a) => ToParam (JsonOf a) 'Cookie where toParam _ pfx val = [(pfx, encodeParam val)] instance ToParam a par => ToParam (Maybe a) par where@@ -1150,7 +1150,7 @@ _ -> Validation $ Left [ParseErr key "Unable to cast to Day"] _ -> Validation $ Left [NotFound key] -instance (Show (DeSerializedData par), FromParam a par) => FromParam [a] par where+instance (FromParam a par) => FromParam [a] par where fromParam pt key kvs = case Trie.null kvs' of True -> Validation $ Right [] False ->@@ -1166,7 +1166,7 @@ (Validation (Right _), Validation (Left es)) -> Validation $ Left es (Validation (Left as), Validation (Left es)) -> Validation $ Left (es ++ as) -instance (Show (DeSerializedData par), FromParam a par) => FromParam (Vector a) par where+instance (FromParam a par) => FromParam (Vector a) par where fromParam pt key kvs = case fromParam pt key kvs of Validation (Right v) -> Validation $ Right (V.fromList v) Validation (Left err) -> Validation (Left err)@@ -1441,18 +1441,18 @@ instance (FromParam a parK) => FromParam (Field s a) parK where fromParam pt key kvs = Field <$> fromParam pt key kvs -type family IsMeta a where- IsMeta (Field s a) = 'True- IsMeta a = 'False+type family IsField a where+ IsField (Field s a) = 'True+ IsField a = 'False -class Meta a (b :: Bool) where- meta :: Proxy a -> Proxy b -> (ByteString -> ByteString)+class FieldModifier a (b :: Bool) where+ fieldMod :: Proxy a -> Proxy b -> (ByteString -> ByteString) -instance (KnownSymbol s) => Meta (Field s a) 'True where- meta _ _ = const $ ASCII.pack (symbolVal (Proxy :: Proxy s))+instance (KnownSymbol s) => FieldModifier (Field s a) 'True where+ fieldMod _ _ = const $ ASCII.pack (symbolVal (Proxy :: Proxy s)) -instance Meta a 'False where- meta _ _ = id+instance FieldModifier a 'False where+ fieldMod _ _ = id -- | Serialize a type to the header params class ToHeader a where@@ -1576,9 +1576,9 @@ where dtN = T.pack $ datatypeName (undefined :: (M1 D t f) a) -instance (GFromParam f parK, Selector t, f ~ (K1 i c), Meta c (IsMeta c)) => GFromParam (M1 S t f) parK where+instance (GFromParam f parK, Selector t, f ~ (K1 i c), FieldModifier c (IsField c)) => GFromParam (M1 S t f) parK where gfromParam pt pfx pa psett kvs = let fldN = (ASCII.pack $ (selName (undefined :: (M1 S t f) a)))- modSelName = meta (Proxy :: Proxy c) (Proxy :: Proxy (IsMeta c))+ modSelName = fieldMod (Proxy :: Proxy c) (Proxy :: Proxy (IsField c)) in case fldN of "" -> M1 <$> gfromParam pt (pfx `nest` numberedFld pa) pa psett (submap pfx kvs) _ -> M1 <$> gfromParam pt (pfx `nest` (modSelName fldN)) pa psett (submap pfx kvs)@@ -1610,9 +1610,9 @@ instance (GToParam f parK) => GToParam (M1 D t f) parK where gtoParam pt pfx pa psett (M1 x) = gtoParam pt pfx pa psett x -instance (GToParam f parK, Selector t, f ~ (K1 i c), Meta c (IsMeta c)) => GToParam (M1 S t f) parK where+instance (GToParam f parK, Selector t, f ~ (K1 i c), FieldModifier c (IsField c)) => GToParam (M1 S t f) parK where gtoParam pt pfx pa psett m@(M1 x) = let fldN = ASCII.pack (selName m)- modSelName = meta (Proxy :: Proxy c) (Proxy :: Proxy (IsMeta c))+ modSelName = fieldMod (Proxy :: Proxy c) (Proxy :: Proxy (IsField c)) in case fldN of "" -> gtoParam pt (pfx `nest` numberedFld pa) pa psett x _ -> gtoParam pt (pfx `nest` (modSelName fldN)) pa psett x
src/WebApi/Server.hs view
@@ -74,8 +74,7 @@ raise status errs = raiseWith' (ApiError status errs Nothing Nothing) -- | This function short circuits returning an `ApiError`.-raiseWith :: ( Monad handM- , MonadThrow handM+raiseWith :: ( MonadThrow handM , Typeable m , Typeable r ) => Status
tests/WebApi/MockSpec.hs view
@@ -15,16 +15,16 @@ mockApp :: Wai.Application mockApp = mockServer serverSettings (MockServer mockServerSettings :: MockServer MockSpec) -data MockSpec = MockSpec+data MockSpec type MockApi = Static "mock" -data QP = QP { qp1 :: Int, qp2 :: Bool }+data QP = QP { _qp1 :: Int, _qp2 :: Bool } deriving (Show, Eq, Generic) -data MockOut = MockOut { out1 :: Int- , out2 :: Bool- , out3 :: Char+data MockOut = MockOut { _out1 :: Int+ , _out2 :: Bool+ , _out3 :: Char } deriving (Show, Eq, Generic) instance ToJSON MockOut where
tests/WebApi/RequestSpec.hs view
@@ -35,23 +35,23 @@ deriving (Show, Eq, Generic) -} -data QP = QP { qp1 :: Int , qp2 :: Maybe Bool, qp3 :: Either Text Double }+data QP = QP { _qp1 :: Int , _qp2 :: Maybe Bool, _qp3 :: Either Text Double } deriving (Show, Eq, Generic) -data FoP = FoP { fop :: ByteString }+data FoP = FoP { _fop :: ByteString } deriving (Show, Eq, Generic) -data CP = CP { cp :: Bool }+data CP = CP { _cp :: Bool } deriving (Show, Eq, Generic) -data HP = HP1 { hp1 :: Int }- | HP2 { hp2 :: Bool }+data HP = HP1 { _hp1 :: Int }+ | HP2 { _hp2 :: Bool } deriving (Show, Eq, Generic) -data FiP = FiP { fip :: FileInfo }+data FiP = FiP { _fip :: FileInfo } deriving (Show, Eq, Generic) -data RB = RB { rb :: Text }+data RB = RB { _rb :: Text } deriving (Show, Eq, Generic) instance FromParam QP 'QueryParam where@@ -175,9 +175,9 @@ handler _ _ = respond ["GET", "POST"] formHeaders :: [(ByteString, ByteString)] -> [(ByteString, ByteString)] -> [Header]-formHeaders headerKvs cookieKvs = map toHeader headerKvs <> [toCookie cookieKvs]- where toHeader (k, v) = (mk k, v)- toCookie kvs = (hCookie, serializeCookie kvs)+formHeaders headerKvs cookieKvs = map toHeader' headerKvs <> [toCookie' cookieKvs]+ where toHeader' (k, v) = (mk k, v)+ toCookie' kvs = (hCookie, serializeCookie kvs) serializeCookie = foldl' (\acc (k, v) -> acc <> ";" <> k <> "=" <> v) ""
tests/WebApi/ResponseSpec.hs view
@@ -21,13 +21,13 @@ data RespSpec data RespSpecImpl = RespSpecImpl -data Out = Out { out :: Text }+data Out = Out { _out :: Text } deriving (Show, Eq, Generic) -data HOut = HOut { hOut :: Text }+data HOut = HOut { _hOut :: Text } deriving (Show, Eq, Generic) -data COut = COut { cOut :: Text }+data COut = COut { _cOut :: Text } deriving (Show, Eq, Generic)-data Err = Err { err :: Text }+data Err = Err { _err :: Text } deriving (Show, Eq, Generic) instance ToJSON Err
webapi.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: webapi-version: 0.2.1.0+version: 0.2.2.0 synopsis: WAI based library for web api description: WAI based library for web api homepage: http://byteally.github.io/webapi/@@ -36,29 +36,29 @@ other-modules: WebApi.Util -- other-extensions: - build-depends: base >=4.7 && <4.9- , text >=1.2 && <1.3- , containers >=0.5 && <0.6- , binary >=0.7 && <0.8- , bytestring >=0.10 && <0.11- , vector >=0.10 && < 0.12- , aeson >=0.8 && <0.10- , http-types == 0.8.*- , blaze-builder == 0.4.*+ build-depends: base >= 4.7 && < 5+ , text >= 1.2 && < 1.3 + , containers >= 0.5 && < 0.6+ , binary >= 0.7 && < 0.9+ , bytestring >= 0.10 && < 0.11+ , vector >= 0.10 && < 0.12+ , aeson >= 0.8 && < 0.12+ , http-types >= 0.8 && < 0.10+ , blaze-builder >= 0.4 && < 0.5 , bytestring-trie == 0.2.* , bytestring-lexing == 0.5.*- , wai == 3.0.*- , wai-extra == 3.0.*+ , wai >= 3.0 && < 3.3+ , wai-extra >= 3.0 && < 3.3 , case-insensitive == 1.2.* , http-client == 0.4.* , http-client-tls == 0.2.*- , network-uri == 2.6.* - , time == 1.5.*- , http-media == 0.6.*- , resourcet == 1.1.*- , exceptions == 0.8.*- , transformers == 0.4.*- , cookie == 0.4.*+ , network-uri >= 2.6 && < 2.7+ , time >= 1.5 && < 1.7+ , http-media >= 0.6 && < 0.7+ , resourcet >= 1.1 && < 1.2+ , exceptions >= 0.8 && < 1+ , transformers >= 0.4 && < 0.6+ , cookie >= 0.4 && < 0.5 , QuickCheck == 2.8.* hs-source-dirs: src@@ -77,20 +77,20 @@ hs-source-dirs: tests default-language: Haskell2010 cpp-options: -DTEST- -- ghc-options: -Wall - build-depends: base >=4.7 && <4.9- , aeson >=0.8 && <0.9+ ghc-options: -Wall+ build-depends: base >= 4.7 && < 5+ , aeson >= 0.8 && < 0.12 , case-insensitive == 1.2.*- , wai == 3.0.*- , wai-extra == 3.0.*- , warp == 3.1.*- , http-media == 0.6.*- , http-types == 0.8.*- , hspec == 2.1.*+ , wai >= 3.0 && < 3.3+ , wai-extra >= 3.0 && < 3.3+ , warp + , http-media >= 0.6 && < 0.7+ , http-types >= 0.8 && < 0.10+ , hspec >= 2.1 && < 2.3 , hspec-wai == 0.6.*- , text == 1.2.*- , bytestring == 0.10.*- , time == 1.5.*- , vector == 0.10.*+ , text >= 1.2 && < 1.3 + , bytestring >= 0.10 && < 0.11+ , vector >= 0.10 && < 0.12+ , time >= 1.5 && < 1.7 , QuickCheck == 2.8.* , webapi