diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,7 @@ +# Changelog + +## 0.2.1 + +* Added `RequestBody` to the `Request` type. This allows user to have content in request's body with the desired `Content-Type`. +* Added `Request` pattern synonym. +* Added `Field` data type for aliasing field names. diff --git a/src/WebApi/Client.hs b/src/WebApi/Client.hs --- a/src/WebApi/Client.hs +++ b/src/WebApi/Client.hs @@ -22,33 +22,49 @@ {-# LANGUAGE UndecidableInstances #-} module WebApi.Client ( - -- * Client related functions + -- * Client related functions client , fromClientResponse , toClientRequest - , link - - -- * Types + , link + + -- * Types , ClientSettings (..) , UnknownClientException + + -- * Connection manager + , HC.Manager + , HC.newManager + , HC.closeManager + , HC.withManager + , HC.HasHttpManager (..) + + -- ** Connection manager settings + , HC.ManagerSettings + , HC.defaultManagerSettings + , HC.tlsManagerSettings ) where +import Blaze.ByteString.Builder (toByteString) import Control.Exception import Data.ByteString (ByteString) import Data.Either (isRight) import Data.List (find) import Data.Proxy import Data.Text.Encoding (decodeUtf8) -import Data.Typeable (Typeable) +import Data.Typeable (Typeable) import qualified Network.HTTP.Client as HC import qualified Network.HTTP.Client.MultipartFormData as HC -import Network.HTTP.Media (mapContentMedia) +import qualified Network.HTTP.Client.TLS as HC (tlsManagerSettings) +import Network.HTTP.Media (RenderHeader (..), + mapContentMedia) import Network.HTTP.Types hiding (Query) import Network.Wai.Parse (fileContent) import WebApi.ContentTypes import WebApi.Contract import WebApi.Internal import WebApi.Param +import WebApi.Util -- | Datatype representing the settings related to client. data ClientSettings = ClientSettings { baseUrl :: String -- ^ base url of the API being called. @@ -93,7 +109,7 @@ decode' :: ( Decodings (ContentTypes m r) a ) => apiRes m r -> ByteString -> Either String a - decode' r o = case getContentType hcResp of + decode' r o = case getContentType (HC.responseHeaders hcResp) 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)) @@ -112,6 +128,8 @@ , ToParam (FileParam m r) 'FileParam , SingMethod m , MkPathFormatString r + , PartEncodings (RequestBody m r) + , ToHListRecTuple (StripContents (RequestBody m r)) ) => HC.Request -> Request m r -> IO HC.Request toClientRequest clientReq req = do let cReq' = clientReq @@ -124,14 +142,27 @@ cReqUE = if Prelude.null formPar then cReqQP else HC.urlEncodedBody formPar cReqQP - cReqMP = if Prelude.null filePar - then return cReqUE - else HC.formDataBody (Prelude.map (\(pname, finfo) -> HC.partFileSource (decodeUtf8 pname) (fileContent finfo)) filePar) cReqUE + fileParts = if Prelude.null filePar + then [] + else Prelude.map (\(pname, finfo) -> HC.partFileSource (decodeUtf8 pname) (fileContent finfo)) filePar + cReqMP = if Prelude.null filePar && Prelude.null formPar + then case partEncs of + (_ : _) -> do + let (mt, b) = firstPart + return cReqUE { HC.requestHeaders = HC.requestHeaders cReqUE ++ [(hContentType, renderHeader mt)] + , HC.requestBody = HC.RequestBodyBS $ toByteString b + } + [] -> return cReqUE + else if not (Prelude.null filePar) then HC.formDataBody fileParts cReqUE else return cReqUE cReqMP where queryPar = toQueryParam $ queryParam req formPar = toFormParam $ formParam req filePar = toFileParam $ fileParam req uriPath = renderUriPath (HC.path clientReq) (pathParam req) req + firstPart = head . head $ partEncs + partEncs = partEncodings cts (toRecTuple cts' (requestBody req)) + cts = Proxy :: Proxy (RequestBody m r) + 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 ~ () @@ -142,10 +173,12 @@ , ToParam (FileParam m r) 'FileParam , FromHeader (HeaderOut m r) , Decodings (ContentTypes m r) (ApiOut m r) - , Decodings (ContentTypes m r) (ApiErr m r) + , Decodings (ContentTypes m r) (ApiErr m r) , ParamErrToApiErr (ApiErr m r) , SingMethod m , MkPathFormatString r + , PartEncodings (RequestBody m r) + , ToHListRecTuple (StripContents (RequestBody m r)) ) => ClientSettings -> Request m r -> IO (Response m r) client sett req = do cReqInit <- HC.parseUrl (baseUrl sett) @@ -157,4 +190,3 @@ deriving (Typeable, Show) instance Exception UnknownClientException where - diff --git a/src/WebApi/ContentTypes.hs b/src/WebApi/ContentTypes.hs --- a/src/WebApi/ContentTypes.hs +++ b/src/WebApi/ContentTypes.hs @@ -13,13 +13,18 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TupleSections #-} module WebApi.ContentTypes ( -- * Predefined Content Types. JSON , PlainText + , OctetStream + , MultipartFormData + , UrlEncoded -- * Creating custom Content Types. + , Content , Accept (..) , Encode (..) , Decode (..) @@ -31,6 +36,9 @@ -- * Internal classes. , Encodings (..) , Decodings (..) + , PartEncodings (..) + , PartDecodings (..) + , StripContents ) where import Blaze.ByteString.Builder (Builder) @@ -38,10 +46,13 @@ import Data.Aeson (ToJSON (..), FromJSON (..), eitherDecodeStrict) import Data.Aeson.Encode (encodeToByteStringBuilder) import Data.ByteString (ByteString) +import Data.Maybe (fromMaybe) import Data.Proxy import qualified Data.Text as TextS import Data.Text.Encoding (decodeUtf8) import Network.HTTP.Media.MediaType +import Network.HTTP.Media (mapContentMedia) +import WebApi.Util -- | Type representing content type of @application/json@. @@ -53,6 +64,12 @@ -- | Type representing content type of @application/octetstream@. data OctetStream +-- | Type representing content type of @multipart/form-data@. +data MultipartFormData + +-- | Type representing content type of @application/x-www-form-urlencoded@. +data UrlEncoded + -- | Encodings of type for all content types `ctypes`. class Encodings (ctypes :: [*]) a where encodings :: Proxy ctypes -> a -> [(MediaType, Builder)] @@ -92,6 +109,12 @@ instance Accept OctetStream where contentType _ = "application" // "octet-stream" +instance Accept MultipartFormData where + contentType _ = "multipart" // "form-data" + +instance Accept UrlEncoded where + contentType _ = "application" // "x-www-form-urlencoded" + -- | Encode a type into a specific content type. class (Accept a) => Encode a c where encode :: Proxy a -> c -> Builder @@ -122,4 +145,45 @@ fromText :: TextS.Text -> Maybe a instance FromText TextS.Text where - fromText = Just . id + fromText = Just + +--newtype Content (ctypes :: [*]) (a :: *) = Content { getContent :: a } +data Content (ctypes :: [*]) (a :: *) + +class PartEncodings (xs :: [*]) where + partEncodings :: Proxy xs + -> HListToRecTuple (StripContents xs) + -> [[(MediaType, Builder)]] + +instance (PartEncodings ts, Encodings ctypes (StripContent t), MkContent t ~ Content ctypes a) => PartEncodings (t ': ts) where + partEncodings _ (t, ts) = encodings (Proxy :: Proxy ctypes) t : partEncodings (Proxy :: Proxy ts) ts + +instance PartEncodings '[] where + partEncodings _ () = [] + +class PartDecodings (xs :: [*]) where + partDecodings :: Proxy xs -> [(ByteString, ByteString)] -> Either String (HListToRecTuple (StripContents xs)) + +instance (PartDecodings ts, Decodings ctypes (StripContent t), MkContent t ~ Content ctypes a) => PartDecodings (t ': ts) where + partDecodings _ ((ctype, partBody) : xs) = do + let decs = decodings (Proxy :: Proxy ctypes) partBody + (decValE :: Maybe (Either String (StripContent t))) = mapContentMedia decs ctype + decVal <- fromMaybe (Left "Error 415: No Matching Content Type") decValE + (decVal, ) <$> partDecodings (Proxy :: Proxy ts) xs + partDecodings _ [] = error "Error!: This shouldn't have happened" + +instance PartDecodings '[] where + partDecodings _ _ = Right () + +type family MkContent a where + MkContent (Content ctypes a) = Content ctypes a + MkContent a = Content '[JSON] a + +type family StripContents (a :: [*]) :: [*] where + StripContents (t ': ts) = StripContent t ': StripContents ts + StripContents '[] = '[] + +type family StripContent a where + StripContent (Content ctypes t) = t + StripContent t = t + diff --git a/src/WebApi/Contract.hs b/src/WebApi/Contract.hs --- a/src/WebApi/Contract.hs +++ b/src/WebApi/Contract.hs @@ -16,13 +16,13 @@ -} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms #-} module WebApi.Contract (-- * API Contract WebApi (..) @@ -30,7 +30,17 @@ -- * Request and Response , PathParam' - , Request (..) + , Request + , queryParam + , formParam + , fileParam + , headerIn + , cookieIn + , method + , requestBody + , pathParam + , pattern Req + , pattern Request , Response (..) , ApiError (..) , OtherError (..) @@ -40,11 +50,15 @@ ) where import Control.Exception (SomeException) +import Data.Proxy import Data.Text +import Data.Text.Encoding +import GHC.Exts import Network.HTTP.Types import WebApi.ContentTypes import WebApi.Method import WebApi.Versioning +import WebApi.Util -- | Describes a collection of web apis. class (OrdVersion (Version p)) => WebApi (p :: *) where @@ -55,8 +69,18 @@ type Version p = Major 0 + +{- NOTE: + The contract has to satisfy the invariant - (FormParam m r, FileParam m r) + and RequestBody m r are mutually exclusive i.e., if RequestBody is non @()@ + then FormParam and FileParam should necessarily be @()@ and vice-versa. + Take a look at 'ReqInvariant' for more info.-} + -- | Describes a contract for a single API end point. -class (SingMethod m, WebApi p) => ApiContract (p :: *) (m :: *) (r :: *) where +class ( SingMethod m + , WebApi p + , ReqInvariant (FormParam m r) (FileParam m r) (RequestBody m r)) + => ApiContract (p :: *) (m :: *) (r :: *) where -- | Type of path param that this end point takes in. -- Defaults to @PathParam' m r@. type PathParam m r @@ -90,6 +114,22 @@ -- | List of Content Types that this end point can serve. -- Defaults to @[JSON]@. type ContentTypes m r :: [*] + -- | List of datatypes this end point expects in the request body. + -- + -- One can specify request's Content-Type by wrapping the data type using 'Content'. + -- If the element in the list is not wrapped with 'Content', then + -- @application/json@ is used as the Content-Type. + -- + -- > '[Content [PlainText] ] -- This goes as "application/text" + -- > '[] -- This goes as "application/json" + -- + -- Currently, it is only possible to have a single entity in request body. + -- Thus 'RequestBody' can only be a singleton list. This restriction might be + -- lifted in a later version. + -- + -- If it is @[]@, Content-Type is decided by @FormParam m r@ and @FileParam m r@. + -- Defaults to @[]@ + type RequestBody m r :: [*] type PathParam m r = PathParam' m r type QueryParam m r = () @@ -100,6 +140,7 @@ type CookieOut m r = () type HeaderOut m r = () type ApiErr m r = () + type RequestBody m r = '[] type ContentTypes m r = '[JSON] -- | Type of the path params that a route 'r' has. If a custom routing system is being used, @@ -108,15 +149,16 @@ type family PathParam' m r :: * -- | Datatype representing a request to route `r` with method `m`. -data Request m r = Req +data Request m r = Req' - { pathParam :: PathParam m r -- ^ Path params of the request. - , queryParam :: QueryParam m r -- ^ Query params of the request. - , formParam :: FormParam m r -- ^ Form params of the request. - , fileParam :: FileParam m r -- ^ File params of the request. - , headerIn :: HeaderIn m r -- ^ Header params of the request. - , cookieIn :: CookieIn m r -- ^ Cookie params of the request. - , method :: Text + { pathParam :: PathParam m r -- ^ Path params of the request. + , queryParam :: QueryParam m r -- ^ Query params of the request. + , formParam :: FormParam m r -- ^ Form params of the request. + , fileParam :: FileParam m r -- ^ File params of the request. + , headerIn :: HeaderIn m r -- ^ Header params of the request. + , cookieIn :: CookieIn m r -- ^ Cookie params of the request. + , requestBody :: HListToTuple (StripContents (RequestBody m r)) -- ^ Body of the request + , method :: Text } -- | Datatype representing a response from route `r` with method `m`. @@ -138,3 +180,45 @@ -- | Datatype representing an unknown failure. data OtherError = OtherError { exception :: SomeException } + +-- | Used for constructing 'Request' +pattern Request :: () => (SingMethod m) + => PathParam m r + -> QueryParam m r + -> FormParam m r + -> FileParam m r + -> HeaderIn m r + -> CookieIn m r + -> HListToTuple (StripContents (RequestBody m r)) + -> Request m r +pattern Request pp qp fp fip hi ci rb <- Req' pp qp fp fip hi ci rb _ where + Request pp qp fp fip hi ci rb = + let rt = _reqToRoute rq + rq = Req' pp qp fp fip hi ci rb (_getMethodName rt) + in rq + +-- | Exists only for compatability reasons. This will be removed in the next version. +-- Use 'Request' pattern instead +pattern Req :: () => (SingMethod m, HListToTuple (StripContents (RequestBody m r)) ~ ()) + => PathParam m r + -> QueryParam m r + -> FormParam m r + -> FileParam m r + -> HeaderIn m r + -> CookieIn m r + -> Text + -> Request m r +pattern Req pp qp fp fip hi ci m = Req' pp qp fp fip hi ci () m + +_reqToRoute :: Request m r -> Proxy m +_reqToRoute _ = Proxy + +_getMethodName :: (SingMethod m) => Proxy m -> Text +_getMethodName = decodeUtf8 . singMethod + +-- | Used for maintaining requestBody invariant +type family ReqInvariant (form :: *) (file :: *) (body :: [*]) :: Constraint where + ReqInvariant () () '[] = () + ReqInvariant () () '[a] = () + ReqInvariant a b '[] = () + ReqInvariant a b c = "Error" ~ "This combination is not supported" diff --git a/src/WebApi/Internal.hs b/src/WebApi/Internal.hs --- a/src/WebApi/Internal.hs +++ b/src/WebApi/Internal.hs @@ -9,32 +9,35 @@ {-# LANGUAGE TypeFamilies #-} module WebApi.Internal where -import Blaze.ByteString.Builder (Builder, toByteString) +import Blaze.ByteString.Builder (Builder, toByteString) import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8 (fromText) import Control.Exception -import Control.Monad.Catch (MonadCatch) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Resource (runResourceT, withInternalState) -import Data.ByteString (ByteString) -import Data.ByteString.Char8 (pack, unpack) -import Data.List (find, foldl') -import Data.Monoid ((<>)) +import Control.Monad.Catch (MonadCatch) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Resource (runResourceT, + withInternalState) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack, unpack) +import Data.List (find, foldl') +import Data.Monoid ((<>)) +import Data.Maybe (fromMaybe) import Data.Proxy -import Data.Text (Text) -import qualified Data.Text as T (pack) -import Data.Text.Encoding (decodeUtf8) -import Data.Typeable (Typeable) -import qualified Network.HTTP.Client as HC -import Network.HTTP.Media (MediaType, mapAcceptMedia, matchAccept) -import Network.HTTP.Media.RenderHeader (renderHeader) -import Network.HTTP.Types hiding (Query) -import Network.URI (URI (..)) -import qualified Network.Wai as Wai -import qualified Network.Wai.Parse as Wai +import Data.Text (Text) +import qualified Data.Text as T (pack) +import Data.Text.Encoding (decodeUtf8) +import Data.Typeable (Typeable) +import Network.HTTP.Media (MediaType, mapAcceptMedia, + matchAccept) +import Network.HTTP.Media.RenderHeader (renderHeader) +import Network.HTTP.Types hiding (Query) +import Network.URI (URI (..)) +import qualified Network.Wai as Wai +import qualified Network.Wai.Parse as Wai import Web.Cookie import WebApi.ContentTypes import WebApi.Contract import WebApi.Param +import WebApi.Util data RouteResult a = NotMatched | Matched a @@ -47,28 +50,44 @@ Matched result -> respond result NotMatched -> respond (Wai.responseLBS notFound404 [] "") -fromWaiRequest :: ( FromParam (QueryParam m r) 'QueryParam +fromWaiRequest :: forall m r. + ( FromParam (QueryParam m r) 'QueryParam , FromParam (FormParam m r) 'FormParam , FromParam (FileParam m r) 'FileParam , FromHeader (HeaderIn m r) , FromParam (CookieIn m r) 'Cookie + , ToHListRecTuple (StripContents (RequestBody m r)) + , PartDecodings (RequestBody m r) + , SingMethod m ) => Wai.Request -> PathParam m r -> IO (Validation [ParamErr] (Request m r)) fromWaiRequest waiReq pathPar = do - (formPar, filePar) <- runResourceT $ withInternalState $ - \internalState -> Wai.parseRequestBody (Wai.tempFileBackEnd internalState) waiReq - - return $ Req <$> pure pathPar + let mContentTy = getContentType $ Wai.requestHeaders waiReq + (formPar, filePar, rBody) <- case hasFormData mContentTy of + Just _ -> do + (formPar, filePar) <- runResourceT $ withInternalState $ + \internalState -> Wai.parseRequestBody (Wai.tempFileBackEnd internalState) waiReq + print $ hasFormData $ getContentType $ Wai.requestHeaders waiReq + return (formPar, filePar, []) + Nothing -> do + bdy <- Wai.requestBody waiReq + print bdy + return ([], [], [(fromMaybe (renderHeader $ contentType (Proxy :: Proxy OctetStream)) mContentTy, bdy)]) + + return $ Request <$> pure pathPar <*> (fromQueryParam $ Wai.queryString waiReq) <*> (fromFormParam formPar) <*> (fromFileParam filePar) <*> (fromHeader $ Wai.requestHeaders waiReq) <*> (fromCookie $ maybe [] parseCookies (getCookie waiReq)) - <*> (pure $ decodeUtf8 $ Wai.requestMethod waiReq) + <*> (fromBody rBody) + where + hasFormData x = matchAccept [contentType (Proxy :: Proxy MultipartFormData), contentType (Proxy :: Proxy UrlEncoded)] =<< x + fromBody x = Validation $ either (const (Left [NotFound "415"])) (Right . fromRecTuple (Proxy :: Proxy (StripContents (RequestBody m r)))) $ partDecodings (Proxy :: Proxy (RequestBody m r)) x toWaiResponse :: ( ToHeader (HeaderOut m r) - , ToParam (CookieOut m r) 'Cookie + , ToParam (CookieOut m r) 'Cookie , Encodings (ContentTypes m r) (ApiOut m r) , Encodings (ContentTypes m r) (ApiErr m r) ) => Wai.Request -> Response m r -> Wai.Response @@ -97,7 +116,7 @@ handleHeaders :: Maybe [Header] -> Maybe [(ByteString, ByteString)] -> [Header] handleHeaders hds cks = handleHeaders' (maybe [] id hds) (maybe [] id cks) - + handleHeaders' :: [Header] -> [(ByteString, ByteString)] -> [Header] handleHeaders' hds cookies = let ckHs = map (\(ck, cv) -> (hSetCookie , renderSC ck cv)) cookies in hds <> ckHs @@ -118,7 +137,7 @@ , uriQuery = maybe "" renderQuery' query } where renderQuery' :: (ToParam query 'QueryParam) => query -> String - renderQuery' = unpack . renderQuery False . toQueryParam + renderQuery' = unpack . renderQuery True . toQueryParam renderUriPath :: ( ToParam path 'PathParam , MkPathFormatString r @@ -167,11 +186,11 @@ -- | Binds implementation to interface and provides a pluggable handler monad for the endpoint handler implementation. class ( MonadCatch (HandlerM p) , MonadIO (HandlerM p) - , WebApi (ApiInterface p) + , WebApi (ApiInterface p) ) => WebApiImplementation (p :: *) where -- | Type of the handler 'Monad'. It should implement 'MonadCatch' and 'MonadIO' classes. Defaults to 'IO'. type HandlerM p :: * -> * - type ApiInterface p :: * + type ApiInterface p :: * -- provides common defaulting information for api handlers -- | Create a value of @IO a@ from @HandlerM p a@. @@ -192,7 +211,7 @@ -- | Type of segments of a Path. data PathSegment = StaticSegment Text -- ^ A static segment | Hole -- ^ A dynamic segment - deriving Show + deriving (Show, Eq) -- | Describe representation of the route. class MkPathFormatString r where @@ -211,7 +230,7 @@ handleApiException _ = return . Failure . Left . apiException handleSomeException :: (query ~ '[], Monad (HandlerM p)) => p -> SomeException -> (HandlerM p) (Query (Response m r) query) -handleSomeException _ = return . Failure . Right . OtherError +handleSomeException _ = return . Failure . Right . OtherError getCookie :: Wai.Request -> Maybe ByteString getCookie = fmap snd . find ((== hCookie) . fst) . Wai.requestHeaders @@ -222,10 +241,11 @@ hSetCookie :: HeaderName hSetCookie = "Set-Cookie" -getContentType :: HC.Response a -> Maybe ByteString -getContentType = fmap snd . find ((== hContentType) . fst) . HC.responseHeaders +getContentType :: ResponseHeaders -> Maybe ByteString +getContentType = fmap snd . find ((== hContentType) . fst) -newtype Tagged (s :: [*]) b = Tagged { unTagged :: b } +newtype Tagged (s :: [*]) b = Tagged { unTagged :: b } toTagged :: Proxy s -> b -> Tagged s b toTagged _ = Tagged + diff --git a/src/WebApi/Mock.hs b/src/WebApi/Mock.hs --- a/src/WebApi/Mock.hs +++ b/src/WebApi/Mock.hs @@ -23,15 +23,15 @@ ) where import Control.Exception -import Data.Proxy (Proxy (..)) -import Data.Text.Encoding (decodeUtf8) import Data.Typeable (Typeable) import GHC.Generics (Generic) import Network.HTTP.Types (Status, ok200) import qualified Network.Wai as Wai import WebApi.Internal import WebApi.Contract +import WebApi.ContentTypes import WebApi.Server +import WebApi.Util import Test.QuickCheck (Arbitrary, generate, arbitrary) data Route' m r = Route' @@ -116,16 +116,14 @@ , Arbitrary (FileParam m r) , Arbitrary (HeaderIn m r) , Arbitrary (CookieIn m r) + , Arbitrary (HListToTuple (StripContents (RequestBody m r))) , SingMethod m ) => route m r -> IO (Request m r) -mockClient r = - Req <$> generate arbitrary - <*> generate arbitrary - <*> generate arbitrary - <*> generate arbitrary - <*> generate arbitrary - <*> generate arbitrary - <*> pure (decodeUtf8 $ singMethod (reproxy r)) - - where reproxy :: route m r -> Proxy m - reproxy = const Proxy +mockClient _ = + Request <$> generate arbitrary + <*> generate arbitrary + <*> generate arbitrary + <*> generate arbitrary + <*> generate arbitrary + <*> generate arbitrary + <*> generate arbitrary diff --git a/src/WebApi/Param.hs b/src/WebApi/Param.hs --- a/src/WebApi/Param.hs +++ b/src/WebApi/Param.hs @@ -28,7 +28,6 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -66,14 +65,15 @@ , fromNonNestedParam -- * Wrappers + , Field (..) , JsonOf (..) , OptValue (..) , FileInfo (..) , NonNested (..) - -- * Helpers + -- * Helpers , ParamK (..) - , filePath + , filePath , nest ) where @@ -82,7 +82,8 @@ import Blaze.ByteString.Builder.Char.Utf8 (fromChar) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as A -import Data.ByteString as SB hiding (index, isPrefixOf) +import Data.ByteString as SB hiding (index, + isPrefixOf) import qualified Data.ByteString as SB (isPrefixOf) import Data.ByteString.Builder (byteString, char7, toLazyByteString) @@ -94,7 +95,7 @@ import Data.CaseInsensitive as CI import Data.Foldable as Fold (foldl') import Data.Int -import qualified Data.List as L (find) +import qualified Data.List as L (find) import Data.Monoid ((<>)) import Data.Proxy import qualified Data.Text as T (Text, pack, uncons) @@ -110,11 +111,12 @@ import qualified Data.Vector as V import Data.Word import GHC.Generics +import GHC.TypeLits import Network.HTTP.Types import Network.HTTP.Types as Http (Header, QueryItem) import qualified Network.Wai.Parse as Wai (FileInfo (..)) --- | A type for holding a file. +-- | A type for holding a file. newtype FileInfo = FileInfo { fileInfo :: Wai.FileInfo FilePath } deriving (Eq, Show) @@ -133,7 +135,7 @@ newtype OptValue a = OptValue { toMaybe :: Maybe a} deriving (Show, Read, Eq, Ord) --- | Serializing 'JsonOf' will produce a JSON representation of the value contained within. This is useful if params has to be sent as JSON. +-- | Serializing 'JsonOf' will produce a JSON representation of the value contained within. This is useful if params has to be sent as JSON. newtype JsonOf a = JsonOf {getValue :: a} deriving (Show, Read, Eq, Ord) @@ -161,7 +163,7 @@ DeSerializedData 'FileParam = Wai.FileInfo FilePath DeSerializedData 'Cookie = ByteString --- | Datatype representing the parsed result of params. +-- | Datatype representing the parsed result of params. newtype Validation e a = Validation { getValidation :: Either e a } deriving (Eq, Functor, Show) @@ -176,15 +178,15 @@ toQueryParam :: (ToParam a 'QueryParam) => a -> Query toQueryParam = toParam (Proxy :: Proxy 'QueryParam) "" --- | Serialize a type into form params. +-- | Serialize a type into form params. toFormParam :: (ToParam a 'FormParam) => a -> [(ByteString, ByteString)] toFormParam = toParam (Proxy :: Proxy 'FormParam) "" --- | Serialize a type into file params. +-- | Serialize a type into file params. toFileParam :: (ToParam a 'FileParam) => a -> [(ByteString, Wai.FileInfo FilePath)] toFileParam = toParam (Proxy :: Proxy 'FileParam) "" --- | Serialize a type into path params. +-- | Serialize a type into path params. toPathParam :: (ToParam a 'PathParam) => a -> [ByteString] toPathParam = toParam (Proxy :: Proxy 'PathParam) "" @@ -192,7 +194,7 @@ toCookie :: (ToParam a 'Cookie) => a -> [(ByteString, ByteString)] toCookie = toParam (Proxy :: Proxy 'Cookie) "" --- | (Try to) Deserialize a type from query params. +-- | (Try to) Deserialize a type from query params. fromQueryParam :: (FromParam a 'QueryParam) => Query -> Validation [ParamErr] a fromQueryParam par = fromParam (Proxy :: Proxy 'QueryParam) "" $ Trie.fromList par @@ -200,7 +202,7 @@ fromFormParam :: (FromParam a 'FormParam) => [(ByteString, ByteString)] -> Validation [ParamErr] a fromFormParam par = fromParam (Proxy :: Proxy 'FormParam) "" $ Trie.fromList par --- | (Try to) Deserialize a type from file params. +-- | (Try to) Deserialize a type from file params. fromFileParam :: (FromParam a 'FileParam) => [(ByteString, Wai.FileInfo FilePath)] -> Validation [ParamErr] a fromFileParam par = fromParam (Proxy :: Proxy 'FileParam) "" $ Trie.fromList par @@ -343,7 +345,7 @@ instance DecodeParam Char where decodeParam str = case decodeUtf8' str of - Right txt -> maybe Nothing (Just . fst) (T.uncons txt) + Right txt -> fmap fst (T.uncons txt) Left _ -> Nothing instance EncodeParam T.Text where @@ -1153,7 +1155,7 @@ True -> Validation $ Right [] False -> let pars = Prelude.map (\(nkey, kv) -> fromParam pt nkey kv :: Validation [ParamErr] a) kvitems - in (Prelude.reverse) <$> Fold.foldl' accRes (Validation $ Right []) pars + in Prelude.reverse <$> Fold.foldl' accRes (Validation $ Right []) pars where kvs' = submap key kvs kvitems = Prelude.takeWhile (not . Prelude.null . snd) (Prelude.map (\ix -> let ixkey = key `nest` (ASCII.pack $ show ix) @@ -1397,7 +1399,7 @@ Left ex -> utf8DecodeError "ToJSON ParamErr" (show ex) Right bs' -> A.object ["ParseErr" A..= [bs', msg]] --- | Convert the 'ParamErr' that occured during deserialization into 'ApiErr' type which can then be put in 'Response'. +-- | Convert the 'ParamErr' that occured during deserialization into 'ApiErr' type which can then be put in 'Response'. class ParamErrToApiErr apiErr where toApiErr :: [ParamErr] -> apiErr @@ -1428,6 +1430,30 @@ data ParamSettings = ParamSettings deriving (Show, Eq) +-- | Used to alias the field name while serailizing FromParam/ToParam instances +-- +-- > data Foo = Foo { foobar :: Field "foo_bar" Int} -- fieldname would be aliased to foo_bar instead of foobar +newtype Field (s :: Symbol) a = Field { unField :: a } + +instance (ToParam a parK) => ToParam (Field s a) parK where + toParam pt pfx = toParam pt pfx . unField + +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 + +class Meta a (b :: Bool) where + meta :: Proxy a -> Proxy b -> (ByteString -> ByteString) + +instance (KnownSymbol s) => Meta (Field s a) 'True where + meta _ _ = const $ ASCII.pack (symbolVal (Proxy :: Proxy s)) + +instance Meta a 'False where + meta _ _ = id + -- | Serialize a type to the header params class ToHeader a where toHeader :: a -> [Http.Header] @@ -1550,11 +1576,12 @@ where dtN = T.pack $ datatypeName (undefined :: (M1 D t f) a) -instance (GFromParam f parK, Selector t) => GFromParam (M1 S t f) parK where +instance (GFromParam f parK, Selector t, f ~ (K1 i c), Meta c (IsMeta 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)) in case fldN of "" -> M1 <$> gfromParam pt (pfx `nest` numberedFld pa) pa psett (submap pfx kvs) - _ -> M1 <$> gfromParam pt (pfx `nest` fldN) pa psett (submap pfx kvs) + _ -> M1 <$> gfromParam pt (pfx `nest` (modSelName fldN)) pa psett (submap pfx kvs) instance (FromParam c parK) => GFromParam (K1 i c) parK where gfromParam pt pfx _ _ kvs = K1 <$> fromParam pt pfx kvs @@ -1583,11 +1610,12 @@ 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) => GToParam (M1 S t f) parK where +instance (GToParam f parK, Selector t, f ~ (K1 i c), Meta c (IsMeta 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)) in case fldN of "" -> gtoParam pt (pfx `nest` numberedFld pa) pa psett x - _ -> gtoParam pt (pfx `nest` fldN) pa psett x + _ -> gtoParam pt (pfx `nest` (modSelName fldN)) pa psett x instance (ToParam Unit parK) => GToParam U1 parK where gtoParam pt pfx _ _ _ = toParam pt pfx Unit diff --git a/src/WebApi/Router.hs b/src/WebApi/Router.hs --- a/src/WebApi/Router.hs +++ b/src/WebApi/Router.hs @@ -49,6 +49,7 @@ import WebApi.Contract import WebApi.Internal import WebApi.Param +import WebApi.Util -- | Datatype representing a endpoint. data Route (ms :: [*]) (r :: *) @@ -130,18 +131,6 @@ FilterDynP (p1 ': p2) = FilterDynP p2 FilterDynP '[] = '[] -type family HListToTuple (xs :: [*]) :: * where - HListToTuple '[] = () - HListToTuple '[p1] = p1 - HListToTuple '[p1, p2] = (p1, p2) - HListToTuple '[p1, p2, p3] = (p1, p2, p3) - HListToTuple '[p1, p2, p3, p4] = (p1, p2, p3, p4) - HListToTuple '[p1, p2, p3, p4, p5] = (p1, p2, p3, p4, p5) - HListToTuple '[p1, p2, p3, p4, p5, p6] = (p1, p2, p3, p4, p5, p6) - HListToTuple '[p1, p2, p3, p4, p5, p6, p7] = (p1, p2, p3, p4, p5, p6, p7) - HListToTuple '[p1, p2, p3, p4, p5, p6, p7, p8] = (p1, p2, p3, p4, p5, p6, p7, p8) - HListToTuple '[p1, p2, p3, p4, p5, p6, p7, p8, p9] = (p1, p2, p3, p4, p5, p6, p7, p8, p9) - infixr 5 :++ type family (:++) (as :: [k]) (bs :: [k]) :: [k] where '[] :++ bs = bs @@ -210,6 +199,8 @@ , Encodings (ContentTypes m (Static piece)) (ApiErr m (Static piece)) , PathParam m (Static piece) ~ () , ParamErrToApiErr (ApiErr m (Static piece)) + , ToHListRecTuple (StripContents (RequestBody m (Static piece))) + , PartDecodings (RequestBody m (Static piece)) , Typeable m , Typeable (Static piece) , WebApiImplementation s @@ -243,6 +234,8 @@ , ToHeader (HeaderOut m route) , ToParam (CookieOut m route) 'Cookie , ParamErrToApiErr (ApiErr m route) + , ToHListRecTuple (StripContents (RequestBody m route)) + , PartDecodings (RequestBody m route) , Typeable m , Typeable route , WebApiImplementation s @@ -280,6 +273,8 @@ , ToParam (CookieOut m route) 'Cookie , DecodeParam lpiece , ParamErrToApiErr (ApiErr m route) + , ToHListRecTuple (StripContents (RequestBody m route)) + , PartDecodings (RequestBody m route) , Typeable m , Typeable route , WebApiImplementation s @@ -315,6 +310,8 @@ , ToParam (CookieOut m route) 'Cookie , DecodeParam t , ParamErrToApiErr (ApiErr m route) + , ToHListRecTuple (StripContents (RequestBody m route)) + , PartDecodings (RequestBody m route) , Typeable m , Typeable route , WebApiImplementation s diff --git a/src/WebApi/Util.hs b/src/WebApi/Util.hs new file mode 100644 --- /dev/null +++ b/src/WebApi/Util.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module WebApi.Util where + +import Data.Proxy (Proxy) + +type family HListToTuple (xs :: [*]) :: * where + HListToTuple '[] = () + HListToTuple '[p1] = p1 + HListToTuple '[p1, p2] = (p1, p2) + HListToTuple '[p1, p2, p3] = (p1, p2, p3) + HListToTuple '[p1, p2, p3, p4] = (p1, p2, p3, p4) + HListToTuple '[p1, p2, p3, p4, p5] = (p1, p2, p3, p4, p5) + HListToTuple '[p1, p2, p3, p4, p5, p6] = (p1, p2, p3, p4, p5, p6) + HListToTuple '[p1, p2, p3, p4, p5, p6, p7] = (p1, p2, p3, p4, p5, p6, p7) + HListToTuple '[p1, p2, p3, p4, p5, p6, p7, p8] = (p1, p2, p3, p4, p5, p6, p7, p8) + HListToTuple '[p1, p2, p3, p4, p5, p6, p7, p8, p9] = (p1, p2, p3, p4, p5, p6, p7, p8, p9) + +type family HListToRecTuple (xs :: [*]) :: * where + HListToRecTuple (x ': xs) = (x, HListToRecTuple xs) + HListToRecTuple '[] = () + +class ToHListRecTuple (xs :: [*]) where + toRecTuple :: Proxy xs -> HListToTuple xs -> HListToRecTuple xs + fromRecTuple :: Proxy xs -> HListToRecTuple xs -> HListToTuple xs + +instance ToHListRecTuple '[] where + toRecTuple _ () = () + fromRecTuple _ () = () + +instance (HListToRecTuple '[p1] ~ (p1, ())) => ToHListRecTuple '[p1] where + toRecTuple _ (p1) = (p1, ()) + fromRecTuple _ (p1, ()) = (p1) + +instance ToHListRecTuple '[p1, p2] where + toRecTuple _ (p1, p2) = (p1, (p2, ())) + fromRecTuple _ (p1, (p2, ())) = (p1, p2) + +instance ToHListRecTuple '[p1, p2, p3] where + toRecTuple _ (p1, p2, p3) = (p1, (p2, (p3, ()))) + fromRecTuple _ (p1, (p2, (p3, ()))) = (p1, p2, p3) + +instance ToHListRecTuple '[p1, p2, p3, p4] where + toRecTuple _ (p1, p2, p3, p4) = (p1, (p2, (p3, (p4, ())))) + fromRecTuple _ (p1, (p2, (p3, (p4, ())))) = (p1, p2, p3, p4) + +instance ToHListRecTuple '[p1, p2, p3, p4, p5] where + toRecTuple _ (p1, p2, p3, p4, p5) = (p1, (p2, (p3, (p4, (p5, ()))))) + fromRecTuple _ (p1, (p2, (p3, (p4, (p5, ()))))) = (p1, p2, p3, p4, p5) + +instance ToHListRecTuple '[p1, p2, p3, p4, p5, p6] where + toRecTuple _ (p1, p2, p3, p4, p5, p6) = (p1, (p2, (p3, (p4, (p5, (p6, ())))))) + fromRecTuple _ (p1, (p2, (p3, (p4, (p5, (p6, ())))))) = (p1, p2, p3, p4, p5, p6) + +instance ToHListRecTuple '[p1, p2, p3, p4, p5, p6, p7] where + toRecTuple _ (p1, p2, p3, p4, p5, p6, p7) = (p1, (p2, (p3, (p4, (p5, (p6, (p7, ()))))))) + fromRecTuple _ (p1, (p2, (p3, (p4, (p5, (p6, (p7, ()))))))) = (p1, p2, p3, p4, p5, p6, p7) + +instance ToHListRecTuple '[p1, p2, p3, p4, p5, p6, p7, p8] where + toRecTuple _ (p1, p2, p3, p4, p5, p6, p7, p8) = (p1, (p2, (p3, (p4, (p5, (p6, (p7, (p8, ())))))))) + fromRecTuple _ (p1, (p2, (p3, (p4, (p5, (p6, (p7, (p8, ())))))))) = (p1, p2, p3, p4, p5, p6, p7, p8) + +instance ToHListRecTuple '[p1, p2, p3, p4, p5, p6, p7, p8, p9] where + toRecTuple _ (p1, p2, p3, p4, p5, p6, p7, p8, p9) = (p1, (p2, (p3, (p4, (p5, (p6, (p7, (p8, (p9, ()))))))))) + fromRecTuple _ (p1, (p2, (p3, (p4, (p5, (p6, (p7, (p8, (p9, ()))))))))) = (p1, p2, p3, p4, p5, p6, p7, p8, p9) diff --git a/tests/WebApi/RequestSpec.hs b/tests/WebApi/RequestSpec.hs --- a/tests/WebApi/RequestSpec.hs +++ b/tests/WebApi/RequestSpec.hs @@ -2,6 +2,7 @@ module WebApi.RequestSpec (spec) where import WebApi +import Data.Aeson import Data.Text (Text) import Network.HTTP.Types.Method (methodPut, methodDelete, methodHead ,methodPatch, methodConnect, methodTrace, methodOptions) @@ -50,6 +51,9 @@ data FiP = FiP { fip :: FileInfo } deriving (Show, Eq, Generic) +data RB = RB { rb :: Text } + deriving (Show, Eq, Generic) + instance FromParam QP 'QueryParam where instance FromParam FoP 'FormParam where instance FromParam CP 'Cookie where @@ -61,6 +65,8 @@ instance ToParam CP 'Cookie where instance ToHeader HP where instance ToParam FiP 'FileParam where + +instance FromJSON RB type ApiR = Static "api" -- type QuickCheckR = Static "autogen" @@ -101,6 +107,7 @@ type HeaderIn PUT ApiR = HP type CookieIn PUT ApiR = CP -- type FormParam PUT ApiR = FoP + type RequestBody PUT ApiR = '[RB] type ApiOut PUT ApiR = () type ApiErr PUT ApiR = Text @@ -184,8 +191,9 @@ postHtmlForm "api?qp1=5&qp2=True&qp3.Left=foo" [("fop", "foobar")] `shouldRespondWith` 200 context "PUT Request" $ do it "should be 200 ok" $ do - let headers = formHeaders [("HP1.hp1", "5")] [("cp", "True")] - request methodPut "api" headers "" `shouldRespondWith` "[]" { matchStatus = 200 } + let headers = formHeaders [("HP1.hp1", "5"), ("Content-Type", "application/json")] [("cp", "True")] + bdy = "{\"rb\":\"foobar\"}" + request methodPut "api" headers bdy `shouldRespondWith` "[]" { matchStatus = 200 } context "DELETE Request" $ do it "should be 200 ok" $ do request methodDelete "api" [] "" `shouldRespondWith` "[]" { matchStatus = 200 } @@ -209,5 +217,6 @@ request "TEST" "api" [] "" `shouldRespondWith` "[]" { matchStatus = 200 } context "When request is incomplete" $ do it "should be 400 ok" $ do - let headers = formHeaders [("HP2.hp2", "True")] [] - request methodPut "api" headers "" `shouldRespondWith` "\"[NotFound \\\"cp\\\"]\"" { matchStatus = 400 } + let headers = formHeaders [("HP2.hp2", "True"), ("Content-Type", "application/json")] [] + bdy = "{\"rb\":\"foobar\"}" + request methodPut "api" headers bdy `shouldRespondWith` "\"[NotFound \\\"cp\\\"]\"" { matchStatus = 400 } 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.0.0 +version: 0.2.1.0 synopsis: WAI based library for web api description: WAI based library for web api homepage: http://byteally.github.io/webapi/ @@ -15,6 +15,7 @@ cabal-version: >=1.10 category: Web build-type: Simple +extra-source-files: ChangeLog.md source-repository head type: git location: https://github.com/byteally/webapi @@ -33,15 +34,15 @@ , WebApi.Method , WebApi.Mock - -- other-modules: + 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.11 - , aeson >=0.8 && <0.9 + , vector >=0.10 && < 0.12 + , aeson >=0.8 && <0.10 , http-types == 0.8.* , blaze-builder == 0.4.* , bytestring-trie == 0.2.*