diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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`. diff --git a/src/WebApi/Client.hs b/src/WebApi/Client.hs --- a/src/WebApi/Client.hs +++ b/src/WebApi/Client.hs @@ -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 diff --git a/src/WebApi/ContentTypes.hs b/src/WebApi/ContentTypes.hs --- a/src/WebApi/ContentTypes.hs +++ b/src/WebApi/ContentTypes.hs @@ -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 diff --git a/src/WebApi/Contract.hs b/src/WebApi/Contract.hs --- a/src/WebApi/Contract.hs +++ b/src/WebApi/Contract.hs @@ -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 diff --git a/src/WebApi/Internal.hs b/src/WebApi/Internal.hs --- a/src/WebApi/Internal.hs +++ b/src/WebApi/Internal.hs @@ -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@ diff --git a/src/WebApi/Param.hs b/src/WebApi/Param.hs --- a/src/WebApi/Param.hs +++ b/src/WebApi/Param.hs @@ -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 diff --git a/src/WebApi/Server.hs b/src/WebApi/Server.hs --- a/src/WebApi/Server.hs +++ b/src/WebApi/Server.hs @@ -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 diff --git a/tests/WebApi/MockSpec.hs b/tests/WebApi/MockSpec.hs --- a/tests/WebApi/MockSpec.hs +++ b/tests/WebApi/MockSpec.hs @@ -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 diff --git a/tests/WebApi/RequestSpec.hs b/tests/WebApi/RequestSpec.hs --- a/tests/WebApi/RequestSpec.hs +++ b/tests/WebApi/RequestSpec.hs @@ -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) "" diff --git a/tests/WebApi/ResponseSpec.hs b/tests/WebApi/ResponseSpec.hs --- a/tests/WebApi/ResponseSpec.hs +++ b/tests/WebApi/ResponseSpec.hs @@ -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 diff --git a/webapi.cabal b/webapi.cabal --- a/webapi.cabal +++ b/webapi.cabal @@ -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