webapi 0.2.0.0 → 0.2.1.0
raw patch · 11 files changed
+420/−112 lines, 11 files
Files
- ChangeLog.md +7/−0
- src/WebApi/Client.hs +44/−12
- src/WebApi/ContentTypes.hs +65/−1
- src/WebApi/Contract.hs +95/−11
- src/WebApi/Internal.hs +55/−35
- src/WebApi/Mock.hs +11/−13
- src/WebApi/Param.hs +48/−20
- src/WebApi/Router.hs +9/−12
- src/WebApi/Util.hs +68/−0
- tests/WebApi/RequestSpec.hs +13/−4
- webapi.cabal +5/−4
+ ChangeLog.md view
@@ -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.
src/WebApi/Client.hs view
@@ -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-
src/WebApi/ContentTypes.hs view
@@ -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+
src/WebApi/Contract.hs view
@@ -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] <Desired-DataType>] -- This goes as "application/text"+ -- > '[<Desired-DataType>] -- 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"
src/WebApi/Internal.hs view
@@ -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+
src/WebApi/Mock.hs view
@@ -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
src/WebApi/Param.hs view
@@ -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
src/WebApi/Router.hs view
@@ -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
+ src/WebApi/Util.hs view
@@ -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)
tests/WebApi/RequestSpec.hs view
@@ -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 }
webapi.cabal view
@@ -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.*