diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2015, byteally +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of webapi nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/WebApi.hs b/src/WebApi.hs new file mode 100644 --- /dev/null +++ b/src/WebApi.hs @@ -0,0 +1,17 @@ +module WebApi + ( module WebApi.Contract + , module WebApi.ContentTypes + , module WebApi.Server + , module WebApi.Client + , module WebApi.Versioning + , module WebApi.Param + , module WebApi.Mock + ) where + +import WebApi.Contract +import WebApi.ContentTypes +import WebApi.Server +import WebApi.Client +import WebApi.Versioning +import WebApi.Param +import WebApi.Mock diff --git a/src/WebApi/Client.hs b/src/WebApi/Client.hs new file mode 100644 --- /dev/null +++ b/src/WebApi/Client.hs @@ -0,0 +1,160 @@ +{-| +Module : WebApi.Client +License : BSD3 +Stability : experimental + +Provides a client for a web api for a given contract. +-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module WebApi.Client + ( + -- * Client related functions + client + , fromClientResponse + , toClientRequest + , link + + -- * Types + , ClientSettings (..) + , UnknownClientException + ) where + +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 qualified Network.HTTP.Client as HC +import qualified Network.HTTP.Client.MultipartFormData as HC +import Network.HTTP.Media (mapContentMedia) +import Network.HTTP.Types hiding (Query) +import Network.Wai.Parse (fileContent) +import WebApi.ContentTypes +import WebApi.Contract +import WebApi.Internal +import WebApi.Param + +-- | Datatype representing the settings related to client. +data ClientSettings = ClientSettings { baseUrl :: String -- ^ base url of the API being called. + , connectionManager :: HC.Manager -- ^ connection manager for the connection. + } + +data Route' m r = Route' + +-- | 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 ~ () + ) => HC.Response HC.BodyReader -> IO (Response m r) +fromClientResponse hcResp = do + let status = HC.responseStatus hcResp + hdrsOut = HC.responseHeaders hcResp + respBody = HC.responseBody hcResp + 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 + 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)) + + where toParamErr :: Either String a -> Either [ParamErr] a + toParamErr (Left _str) = Left [] + toParamErr (Right r) = Right r + + decode' :: ( Decodings (ContentTypes m r) a + ) => apiRes m r -> ByteString -> Either String a + decode' r o = case getContentType 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)) + + 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 + +-- | Creates a request from the 'Request' type. +toClientRequest :: forall m r.( ToParam (PathParam m r) 'PathParam + , ToParam (QueryParam m r) 'QueryParam + , ToParam (FormParam m r) 'FormParam + , ToHeader (HeaderIn m r) + , ToParam (FileParam m r) 'FileParam + , SingMethod m + , MkPathFormatString r + ) => HC.Request -> Request m r -> IO HC.Request +toClientRequest clientReq req = do + let cReq' = clientReq + { HC.method = singMethod (Proxy :: Proxy m) + , HC.path = uriPath + , HC.requestHeaders = toHeader $ headerIn req + -- , HC.cookieJar = error "TODO: cookieJar" + } + cReqQP = HC.setQueryString queryPar cReq' + 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 + cReqMP + where queryPar = toQueryParam $ queryParam req + formPar = toFormParam $ formParam req + filePar = toFileParam $ fileParam req + uriPath = renderUriPath (HC.path clientReq) (pathParam req) req + +-- | Given a `Request` type, create the request and obtain a response. Gives back a 'Response'. +client :: ( CookieOut m r ~ () + , ToParam (PathParam m r) 'PathParam + , ToParam (QueryParam m r) 'QueryParam + , ToParam (FormParam m r) 'FormParam + , ToHeader (HeaderIn m r) + , ToParam (FileParam m r) 'FileParam + , 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 + ) => ClientSettings -> Request m r -> IO (Response m r) +client sett req = do + cReqInit <- HC.parseUrl (baseUrl sett) + cReq <- toClientRequest cReqInit req + HC.withResponse cReq (connectionManager sett) fromClientResponse + +-- | This exception is used to signal an irrecoverable error while deserializing the response. +data UnknownClientException = UnknownClientException + deriving (Typeable, Show) + +instance Exception UnknownClientException where + diff --git a/src/WebApi/ContentTypes.hs b/src/WebApi/ContentTypes.hs new file mode 100644 --- /dev/null +++ b/src/WebApi/ContentTypes.hs @@ -0,0 +1,125 @@ +{-| +Module : WebApi.ContentTypes +License : BSD3 +Stability : experimental +-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module WebApi.ContentTypes + ( + -- * Predefined Content Types. + JSON + , PlainText + + -- * Creating custom Content Types. + , Accept (..) + , Encode (..) + , Decode (..) + + -- * Converting from and to 'Text' + , FromText (..) + , ToText (..) + + -- * Internal classes. + , Encodings (..) + , Decodings (..) + ) where + +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8 (fromText) +import Data.Aeson (ToJSON (..), FromJSON (..), eitherDecodeStrict) +import Data.Aeson.Encode (encodeToByteStringBuilder) +import Data.ByteString (ByteString) +import Data.Proxy +import qualified Data.Text as TextS +import Data.Text.Encoding (decodeUtf8) +import Network.HTTP.Media.MediaType + + +-- | Type representing content type of @application/json@. +data JSON + +-- | Type representing content type of @text/plain@. +data PlainText + +-- | Type representing content type of @application/octetstream@. +data OctetStream + +-- | Encodings of type for all content types `ctypes`. +class Encodings (ctypes :: [*]) a where + encodings :: Proxy ctypes -> a -> [(MediaType, Builder)] + +instance ( Accept ctype + , Encode ctype a + , Encodings ctypes a + ) => Encodings (ctype ': ctypes) a where + encodings _ a = (contentType (Proxy :: Proxy ctype), encode (Proxy :: Proxy ctype) a) : encodings (Proxy :: Proxy ctypes) a + +instance Encodings '[] a where + encodings _ _ = [] + +-- | Decodings of type for all content types `ctypes`. +class Decodings (ctypes :: [*]) a where + decodings :: Proxy ctypes -> ByteString -> [(MediaType, Either String a)] + +instance ( Accept ctype + , Decode ctype a + , Decodings ctypes a + ) => Decodings (ctype ': ctypes) a where + decodings _ bs = (contentType (Proxy :: Proxy ctype), decode (Proxy :: Proxy ctype) bs) : decodings (Proxy :: Proxy ctypes) bs + +instance Decodings '[] a where + decodings _ _ = [] + +-- | Singleton class for content type. +class Accept ctype where + contentType :: Proxy ctype -> MediaType + +instance Accept JSON where + contentType _ = "application" // "json" + +instance Accept PlainText where + contentType _ = "text" // "plain" /: ("charset", "utf-8") + +instance Accept OctetStream where + contentType _ = "application" // "octet-stream" + +-- | Encode a type into a specific content type. +class (Accept a) => Encode a c where + encode :: Proxy a -> c -> Builder + +instance (ToJSON c) => Encode JSON c where + encode _ = encodeToByteStringBuilder . toJSON + +instance (ToText a) => Encode PlainText a where + encode _ = Utf8.fromText . toText + +-- | (Try to) Decode a type from a specific content type. +class (Accept c) => Decode c a where + decode :: Proxy c -> ByteString -> Either String a + +instance (FromJSON a) => Decode JSON a where + decode _ = eitherDecodeStrict + +instance (FromText a) => Decode PlainText a where + decode _ = maybe (Left "Couldn't parse: ") Right . fromText . decodeUtf8 + +class ToText a where + toText :: a -> TextS.Text + +instance ToText TextS.Text where + toText = id + +class FromText a where + fromText :: TextS.Text -> Maybe a + +instance FromText TextS.Text where + fromText = Just . id diff --git a/src/WebApi/Contract.hs b/src/WebApi/Contract.hs new file mode 100644 --- /dev/null +++ b/src/WebApi/Contract.hs @@ -0,0 +1,139 @@ +{-| + +Module : WebApi.Contract +License : BSD3 +Stability : experimental + +Provides the contract for the web api. The contract consists of 'WebApi' and 'ApiContract' classes. +'WebApi' contains information related to the entire group of APIs whereas 'ApiContract' is concerned with information related to each end point. Once the contract is written, it can be then used to + +* Write a 'WebApiImplementation' and corresponding 'ApiHandler' for it. +* Get a client for web api. +* Get a mock server and a mock client for web api. + +... and possibly more. + +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +module WebApi.Contract + (-- * API Contract + WebApi (..) + , ApiContract (..) + + -- * Request and Response + , PathParam' + , Request (..) + , Response (..) + , ApiError (..) + , OtherError (..) + + -- * Methods + , module WebApi.Method + ) where + +import Control.Exception (SomeException) +import Data.Text +import Network.HTTP.Types +import WebApi.ContentTypes +import WebApi.Method +import WebApi.Versioning + +-- | Describes a collection of web apis. +class (OrdVersion (Version p)) => WebApi (p :: *) where + -- | Version of the web api. + type Version p :: * + -- | List of all end points that this web api provides. + type Apis p :: [*] + + type Version p = Major 0 + +-- | Describes a contract for a single API end point. +class (SingMethod m, WebApi p) => ApiContract (p :: *) (m :: *) (r :: *) where + -- | Type of path param that this end point takes in. + -- Defaults to @PathParam' m r@. + type PathParam m r + -- | Type of query param that this end point takes in. + -- Defaults to @()@. + type QueryParam m r + -- | Type form params that this end point takes in. + -- Defaults to @()@. + type FormParam m r + -- | Type of file params that this end point takes in. + -- Defaults to @()@. + type FileParam m r + -- | Type of header params that this end point takes in. + -- Defaults to @()@. + type HeaderIn m r + -- | Type of cookie params that this end point takes in. + -- Defaults to @()@. + type CookieIn m r + -- | Type of result of this end point when successful. + -- Defaults to @()@. + type ApiOut m r + -- | Type of result of this end point when a known failure occurs. + -- Defaults to @()@. + type ApiErr m r + -- | Type of headers of this end point gives out. + -- Defaults to @()@. + type HeaderOut m r + -- | Type of cookies of this end point gives out. + -- Defaults to @()@. + type CookieOut m r + -- | List of Content Types that this end point can serve. + -- Defaults to @[JSON]@. + type ContentTypes m r :: [*] + + type PathParam m r = PathParam' m r + type QueryParam m r = () + type FormParam m r = () + type FileParam m r = () + type HeaderIn m r = () + type CookieIn m r = () + type CookieOut m r = () + type HeaderOut m r = () + type ApiErr 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, +-- then you will have to give an instance for 'PathParam'' for types being used in routing. +-- Please take a look at the existing instances of 'PathParam'' for reference. +type family PathParam' m r :: * + +-- | Datatype representing a request to route `r` with method `m`. +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 + } + +-- | Datatype representing a response from route `r` with method `m`. +data Response m r = Success Status (ApiOut m r) (HeaderOut m r) (CookieOut m r) + | Failure (Either (ApiError m r) OtherError) + +{- +data Api m r = forall handM.(Monad handM) => Api + { runApi :: Request m r -> handM (Response m r) } +-} + +-- | Datatype representing a known failure from route `r` with method `m`. +data ApiError m r = ApiError + { code :: Status + , err :: (ApiErr m r) + , headerOut :: Maybe (HeaderOut m r) + , cookieOut :: Maybe (CookieOut m r) + } + +-- | Datatype representing an unknown failure. +data OtherError = OtherError { exception :: SomeException } diff --git a/src/WebApi/Internal.hs b/src/WebApi/Internal.hs new file mode 100644 --- /dev/null +++ b/src/WebApi/Internal.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module WebApi.Internal where + +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 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 Web.Cookie +import WebApi.ContentTypes +import WebApi.Contract +import WebApi.Param + + +data RouteResult a = NotMatched | Matched a + +type RoutingApplication = Wai.Request -> (RouteResult Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived + +toApplication :: RoutingApplication -> Wai.Application +toApplication app request respond = + app request $ \routeResult -> case routeResult of + Matched result -> respond result + NotMatched -> respond (Wai.responseLBS notFound404 [] "") + +fromWaiRequest :: ( FromParam (QueryParam m r) 'QueryParam + , FromParam (FormParam m r) 'FormParam + , FromParam (FileParam m r) 'FileParam + , FromHeader (HeaderIn m r) + , FromParam (CookieIn m r) 'Cookie + ) => 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 + <*> (fromQueryParam $ Wai.queryString waiReq) + <*> (fromFormParam formPar) + <*> (fromFileParam filePar) + <*> (fromHeader $ Wai.requestHeaders waiReq) + <*> (fromCookie $ maybe [] parseCookies (getCookie waiReq)) + <*> (pure $ decodeUtf8 $ Wai.requestMethod waiReq) + +toWaiResponse :: ( ToHeader (HeaderOut m r) + , 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 +toWaiResponse wreq resp = case resp of + Success status out hdrs cookies -> case encode' resp out of + Just (ctype, o') -> let hds = (hContentType, renderHeader ctype) : handleHeaders' (toHeader hdrs) (toCookie cookies) + in Wai.responseBuilder status hds o' + Nothing -> Wai.responseBuilder notAcceptable406 [] "Matching content type not found" + Failure (Left (ApiError status errs hdrs cookies)) -> case encode' resp errs of + Just (ctype, errs') -> let hds = (hContentType, renderHeader ctype) : handleHeaders (toHeader <$> hdrs) (toCookie <$> cookies) + in Wai.responseBuilder status hds errs' + Nothing -> Wai.responseBuilder notAcceptable406 [] "Matching content type not found" + Failure (Right (OtherError ex)) -> Wai.responseBuilder internalServerError500 [] (Utf8.fromText (T.pack (displayException ex))) + + where encode' :: ( Encodings (ContentTypes m r) a + ) => apiRes m r -> a -> Maybe (MediaType, Builder) + encode' r o = case getAccept wreq of + Just acc -> let ecs = encodings (reproxy r) o + in (,) <$> matchAccept (map fst ecs) acc <*> mapAcceptMedia ecs acc + Nothing -> case encodings (reproxy r) o of + (x : _) -> Just x + _ -> Nothing + + reproxy :: apiRes m r -> Proxy (ContentTypes m r) + reproxy = const Proxy + + 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 + renderSC k v = toByteString (renderSetCookie (def { setCookieName = k, setCookieValue = v })) + +-- | Generate a type safe URL for a given route type. The URI can be used for setting a base URL if required. +link :: ( ToParam (QueryParam m r) 'QueryParam + , MkPathFormatString r + , ToParam (PathParam m r) 'PathParam + ) => + route m r + -> URI + -> PathParam m r + -> Maybe (QueryParam m r) + -> URI +link r base paths query = base + { uriPath = unpack $ renderUriPath (pack $ uriPath base) paths r + , uriQuery = maybe "" renderQuery' query + } + where renderQuery' :: (ToParam query 'QueryParam) => query -> String + renderQuery' = unpack . renderQuery False . toQueryParam + +renderUriPath :: ( ToParam path 'PathParam + , MkPathFormatString r + ) => ByteString -> path -> route m r -> ByteString +renderUriPath basePth p r = case basePth of + "" -> renderPaths p r + "/" -> renderPaths p r + _ -> basePth `mappend` renderPaths p r + +renderPaths :: ( ToParam path 'PathParam + , MkPathFormatString r + ) => path -> route m r -> ByteString +renderPaths p r = toByteString + $ encodePathSegments $ uriPathPieces (toPathParam p) + + where uriPathPieces :: [ByteString] -> [Text] + uriPathPieces dynVs = reverse $ fst $ foldl' (flip fillHoles) ([], dynVs) (mkPathFormatString (toRoute r)) + + fillHoles :: PathSegment -> ([Text], [ByteString]) -> ([Text], [ByteString]) + fillHoles (StaticSegment t) (segs, dynVs) = (t : segs, dynVs) + 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 = const Proxy + +-- | Describes the implementation of a single API end point corresponding to @ApiContract (ApiInterface p) m r@ +class (ApiContract (ApiInterface p) m r) => ApiHandler (p :: *) (m :: *) (r :: *) where + -- | Handler for the API end point which returns a 'Response'. + -- + -- TODO : 'query' type parameter is an experimental one used for trying out dependently typed params. + -- This parameter will let us refine the 'ApiOut' to the structure that is requested by the client. + -- for eg : graph.facebook.com/bgolub?fields=id,name,picture + -- + -- This feature is not finalized and might get changed \/ removed. + -- Currently the return type of handler is equivalent to `Response m r` + -- + handler :: (query ~ '[]) + => Tagged query p + -> Request m r + -> HandlerM p (Query (Response m r) query) + +type family Query (t :: *) (query :: [*]) :: * where + Query t '[] = t + +-- | 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) + ) => WebApiImplementation (p :: *) where + -- | Type of the handler 'Monad'. It should implement 'MonadCatch' and 'MonadIO' classes. Defaults to 'IO'. + type HandlerM p :: * -> * + type ApiInterface p :: * + -- provides common defaulting information for api handlers + + -- | Create a value of @IO a@ from @HandlerM p a@. + toIO :: p -> HandlerM p a -> IO a + + default toIO :: (HandlerM p ~ IO) => p -> HandlerM p a -> IO a + toIO _ = id + + type HandlerM p = IO + +-- | Type of settings of the server. +data ServerSettings = ServerSettings + +-- | Default server settings. +serverSettings :: ServerSettings +serverSettings = ServerSettings + +-- | Type of segments of a Path. +data PathSegment = StaticSegment Text -- ^ A static segment + | Hole -- ^ A dynamic segment + deriving Show + +-- | Describe representation of the route. +class MkPathFormatString r where + -- | Given a route, this function should produce the @[PathSegment]@ of that route. This gives the flexibility to hook in a different routing system into the application. + mkPathFormatString :: Proxy r -> [PathSegment] + +-- | Type of Exception raised in a handler. +data ApiException m r = ApiException { apiException :: ApiError m r } + +instance Show (ApiException m r) where + show (ApiException _) = "ApiException" + +instance (Typeable m, Typeable r) => Exception (ApiException m r) where + +handleApiException :: (query ~ '[], Monad (HandlerM p)) => p -> ApiException m r -> (HandlerM p) (Query (Response m r) query) +handleApiException _ = return . Failure . Left . apiException + +handleSomeException :: (query ~ '[], Monad (HandlerM p)) => p -> SomeException -> (HandlerM p) (Query (Response m r) query) +handleSomeException _ = return . Failure . Right . OtherError + +getCookie :: Wai.Request -> Maybe ByteString +getCookie = fmap snd . find ((== hCookie) . fst) . Wai.requestHeaders + +getAccept :: Wai.Request -> Maybe ByteString +getAccept = fmap snd . find ((== hAccept) . fst) . Wai.requestHeaders + +hSetCookie :: HeaderName +hSetCookie = "Set-Cookie" + +getContentType :: HC.Response a -> Maybe ByteString +getContentType = fmap snd . find ((== hContentType) . fst) . HC.responseHeaders + +newtype Tagged (s :: [*]) b = Tagged { unTagged :: b } + +toTagged :: Proxy s -> b -> Tagged s b +toTagged _ = Tagged diff --git a/src/WebApi/Method.hs b/src/WebApi/Method.hs new file mode 100644 --- /dev/null +++ b/src/WebApi/Method.hs @@ -0,0 +1,89 @@ +{-| +Module : WebApi.ContentTypes +License : BSD3 +Stability : experimental + +Defines various types to represent the HTTP methods. + +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +module WebApi.Method + ( + -- * Methods + GET + , POST + , PUT + , DELETE + , HEAD + , PATCH + , TRACE + , OPTIONS + , CONNECT + , CUSTOM + + -- * Internal + , SingMethod (..) + ) where + +import Data.ByteString.Char8 (pack) +import Data.Proxy +import GHC.TypeLits +import Network.HTTP.Types + +-- | Type representing a GET method. +data GET +-- | Type representing a POST method. +data POST +-- | Type representing a PUT method. +data PUT +-- | Type representing a DELETE method. +data DELETE +-- | Type representing a HEAD method. +data HEAD +-- | Type representing a PATCH method. +data PATCH +-- | Type representing a OPTIONS method. +data OPTIONS +-- | Type representing a TRACE method. +data TRACE +-- | Type representing a CONNECT method. +data CONNECT +-- | Type representing a Custom method. +data CUSTOM (m :: Symbol) + +-- | Singleton class for method types. +class SingMethod (meth :: *) where + singMethod :: Proxy meth -> Method + +instance SingMethod GET where + singMethod = const methodGet + +instance SingMethod POST where + singMethod = const methodPost + +instance SingMethod PUT where + singMethod = const methodPut + +instance SingMethod DELETE where + singMethod = const methodDelete + +instance SingMethod OPTIONS where + singMethod = const methodOptions + +instance SingMethod HEAD where + singMethod = const methodHead + +instance SingMethod TRACE where + singMethod = const methodTrace + +instance SingMethod PATCH where + singMethod = const methodPatch + +instance SingMethod CONNECT where + singMethod = const methodConnect + +instance KnownSymbol m => SingMethod (CUSTOM m) where + singMethod = const $ pack $ symbolVal (Proxy :: Proxy m) diff --git a/src/WebApi/Mock.hs b/src/WebApi/Mock.hs new file mode 100644 --- /dev/null +++ b/src/WebApi/Mock.hs @@ -0,0 +1,131 @@ +{-| +Module : WebApi.Mock +License : BSD3 +Stability : experimental + +Once a contract is defined for a web api, a mock server and client for it can be obtained. 'Arbitrary' instances of the data types used in 'Request' and 'Response' is used to generate the request and response. Note that if a different mocking behaviour is required, it is easy enough to write a different implementation. Please take a look at the reference implementation of 'MockServer' for details. +-} + +{-# LANGUAGE TypeFamilies, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, DataKinds, FlexibleContexts, ScopedTypeVariables, DeriveGeneric #-} +module WebApi.Mock + ( + -- * Mock Server + mockServerSettings + , mockResponse + , mockServer + , MockServer (..) + , MockServerSettings (..) + , MockServerException (..) + , ResponseData (..) + + -- * Mock Client + , mockClient + ) 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.Server +import Test.QuickCheck (Arbitrary, generate, arbitrary) + +data Route' m r = Route' + +-- | Datatype representing a mock server. The parameterization over `p` allows it to be a mock server for any `p`. +newtype MockServer p = MockServer { mockServerSett :: MockServerSettings } + deriving (Eq, Show) + +-- | Determine the data constructor of `Response` to be generated in `mockServer`. +data ResponseData = SuccessData + | ApiErrorData Status + | OtherErrorData + deriving (Eq, Show) + +-- | Settings related to mock server. +data MockServerSettings = MockServerSettings { responseData :: ResponseData } + deriving (Eq, Show) + +-- | Default mock server settings. +mockServerSettings :: MockServerSettings +mockServerSettings = MockServerSettings SuccessData + +instance (WebApi p) => WebApiImplementation (MockServer p) where + type ApiInterface (MockServer p) = p + +instance ( ApiContract p m r + , Arbitrary (ApiOut m r) + , Arbitrary (ApiErr m r) + , Arbitrary (HeaderOut m r) + , Arbitrary (CookieOut m r) + , Typeable m + , Typeable r + ) => ApiHandler (MockServer p) m r where + handler mock _ = mockResponse (Route' :: Route' m r) ((mockServerSett . unTagged) mock) + +-- | Create a mock response from endpoint information and `MockServerSettings` +mockResponse :: forall route m r. ( Arbitrary (ApiOut m r) + , Arbitrary (HeaderOut m r) + , Arbitrary (CookieOut m r) + , Arbitrary (ApiErr m r) + , Typeable m + , Typeable r + ) => route m r -> MockServerSettings -> IO (Response m r) +mockResponse _ msett = case responseData msett of + SuccessData -> mockSuccess + ApiErrorData st -> mockApiError st + OtherErrorData -> mockOtherError + + where mockSuccess :: IO (Response m r) + mockSuccess = do + aout <- generate arbitrary + hout <- generate arbitrary + cout <- generate arbitrary + respondWith ok200 aout hout cout + + mockApiError :: Status -> IO (Response m r) + mockApiError status = do + aerr <- generate arbitrary + herr <- generate arbitrary + cerr <- generate arbitrary + raiseWith status aerr herr cerr + + mockOtherError :: IO (Response m r) + mockOtherError = do + oerr <- generate arbitrary + return (Failure (Right (OtherError (SomeException $ MockServerException oerr)))) + +-- | Datatype representing a mock exception. This exception will be put inside `OtherError`. +data MockServerException = MockServerException { exceptionMsg :: String } + deriving (Show, Generic) + +instance Exception MockServerException + +-- | Create a mock server. +mockServer :: (Router (MockServer p) (Apis p) '(CUSTOM "", '[])) => ServerSettings -> MockServer p -> Wai.Application +mockServer = serverApp + +-- | Create a mock client. +mockClient :: ( Arbitrary (PathParam m r) + , Arbitrary (QueryParam m r) + , Arbitrary (FormParam m r) + , Arbitrary (FileParam m r) + , Arbitrary (HeaderIn m r) + , Arbitrary (CookieIn 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 diff --git a/src/WebApi/Param.hs b/src/WebApi/Param.hs new file mode 100644 --- /dev/null +++ b/src/WebApi/Param.hs @@ -0,0 +1,1608 @@ +{-| +Module : WebApi.Param +License : BSD3 +Stability : experimental + +Param serialization and deserialization. 'ToParam' and 'EncodeParam' are responsible for serialization part. +'EncodeParam' converts the value into a wire format. 'ToParam' is responsible for creating (nested) key value pairs, which can be then used to deserialize to original type. For example + +@ +encodeParam 5 == "5" + +data Foo = Foo { foo :: Int } + deriving (Show, Eq, Generic) + +data Bar = Bar { bar :: Foo } + deriving (Show, Eq, Generic) + +instance ToParam Foo 'FormParam +instance ToParam Bar 'FormParam + +toParam (Proxy :: Proxy 'FormParam) "" (Bar (Foo 5)) == [("bar.foo","5")] +@ + +Deserialization works analogously, 'FromParam' and 'DecodeParam' are counterparts to 'ToParam' and 'EncodeParam' respectively. Generic instances are provided for all of them. This means that the user only need to derive Generic in their type, and provide instance with an empty body. Note that for headers 'FromHeader' and 'ToHeader' is being used in place of 'FromParam' and 'ToParam'. Nesting is not supported for headers. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module WebApi.Param + ( -- * Serialization + ToParam (..) + , EncodeParam (..) + , ToHeader (..) + , SerializedData + , toQueryParam + , toFormParam + , toFileParam + , toPathParam + , toCookie + , toNonNestedParam + + -- * Deserialization + , FromParam (..) + , DecodeParam (..) + , FromHeader (..) + , Validation (..) + , ParamErr (..) + , ParamErrToApiErr (..) + , DeSerializedData + , fromQueryParam + , fromFormParam + , fromFileParam + , fromCookie + , lookupParam + , fromNonNestedParam + + -- * Wrappers + , JsonOf (..) + , OptValue (..) + , FileInfo (..) + , NonNested (..) + + -- * Helpers + , ParamK (..) + , filePath + , nest + ) where + + +import Blaze.ByteString.Builder (toByteString) +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 qualified Data.ByteString as SB (isPrefixOf) +import Data.ByteString.Builder (byteString, char7, + toLazyByteString) +import Data.ByteString.Char8 as ASCII (pack, readInteger, + split, unpack) +import Data.ByteString.Lazy (toStrict) +import qualified Data.ByteString.Lex.Fractional as LexF +import Data.ByteString.Lex.Integral +import Data.CaseInsensitive as CI +import Data.Foldable as Fold (foldl') +import Data.Int +import qualified Data.List as L (find) +import Data.Monoid ((<>)) +import Data.Proxy +import qualified Data.Text as T (Text, pack, uncons) +import Data.Text.Encoding (decodeUtf8', encodeUtf8) +import Data.Time.Calendar (Day) +import Data.Time.Clock (UTCTime) +import Data.Time.Format (FormatTime, + defaultTimeLocale, + formatTime, parseTimeM) +import Data.Trie as Trie +import Data.Typeable +import Data.Vector (Vector) +import qualified Data.Vector as V +import Data.Word +import GHC.Generics +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. +newtype FileInfo = FileInfo { fileInfo :: Wai.FileInfo FilePath } + deriving (Eq, Show) + +-- | Obtain the file path from 'FileInfo'. +filePath :: FileInfo -> FilePath +filePath = Wai.fileContent . fileInfo + +-- | (Kind) Describes the various types of Param. +data ParamK = QueryParam + | FormParam + | FileParam + | PathParam + | Cookie + +-- | Use this type if a key is required but the value is optional. +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. +newtype JsonOf a = JsonOf {getValue :: a} + deriving (Show, Read, Eq, Ord) + +data Unit = Unit + deriving (Show, Eq) + +instance ToJSON a => ToJSON (JsonOf a) where + toJSON (JsonOf a) = toJSON a + +instance FromJSON a => FromJSON (JsonOf a) where + parseJSON jval = JsonOf `fmap` parseJSON jval + +-- | Define result of serialization of a type of kind 'ParamK'. +type family SerializedData (par :: ParamK) where + SerializedData 'QueryParam = Http.QueryItem + SerializedData 'FormParam = (ByteString, ByteString) + SerializedData 'FileParam = (ByteString, Wai.FileInfo FilePath) + SerializedData 'PathParam = ByteString + SerializedData 'Cookie = (ByteString, ByteString) + +-- | Define result of deserialization of a type of kind 'ParamK'. +type family DeSerializedData (par :: ParamK) where + DeSerializedData 'QueryParam = Maybe ByteString + DeSerializedData 'FormParam = ByteString + DeSerializedData 'FileParam = Wai.FileInfo FilePath + DeSerializedData 'Cookie = ByteString + +-- | Datatype representing the parsed result of params. +newtype Validation e a = Validation { getValidation :: Either e a } + deriving (Eq, Functor, Show) + +instance Monoid e => Applicative (Validation e) where + pure = Validation . Right + Validation a <*> Validation b = Validation $ + case a of + Right va -> fmap va b + Left ea -> either (Left . mappend ea) (const $ Left ea) b + +-- | Serialize a type into query params. +toQueryParam :: (ToParam a 'QueryParam) => a -> Query +toQueryParam = toParam (Proxy :: Proxy 'QueryParam) "" + +-- | Serialize a type into form params. +toFormParam :: (ToParam a 'FormParam) => a -> [(ByteString, ByteString)] +toFormParam = toParam (Proxy :: Proxy 'FormParam) "" + +-- | 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. +toPathParam :: (ToParam a 'PathParam) => a -> [ByteString] +toPathParam = toParam (Proxy :: Proxy 'PathParam) "" + +-- | Serialize a type into cookie. +toCookie :: (ToParam a 'Cookie) => a -> [(ByteString, ByteString)] +toCookie = toParam (Proxy :: Proxy 'Cookie) "" + +-- | (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 + +-- | (Try to) Deserialize a type from form params. +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. +fromFileParam :: (FromParam a 'FileParam) => [(ByteString, Wai.FileInfo FilePath)] -> Validation [ParamErr] a +fromFileParam par = fromParam (Proxy :: Proxy 'FileParam) "" $ Trie.fromList par + +-- | (Try to) Deserialize a type from cookie. +fromCookie :: (FromParam a 'Cookie) => [(ByteString, ByteString)] -> Validation [ParamErr] a +fromCookie par = fromParam (Proxy :: Proxy 'Cookie) "" $ Trie.fromList par + +-- | Serialize a type to a given type of kind 'ParamK'. +class ToParam a (parK :: ParamK) where + toParam :: Proxy (parK :: ParamK) -> ByteString -> a -> [SerializedData parK] + + default toParam :: (Generic a, GToParam (Rep a) parK) => Proxy (parK :: ParamK) -> ByteString -> a -> [SerializedData parK] + toParam pt pfx = gtoParam pt pfx (ParamAcc 0 False) ParamSettings . from + +-- | (Try to) Deserialize a type from a given type of kind 'ParamK'. +class FromParam a (parK :: ParamK) where + fromParam :: Proxy (parK :: ParamK) -> ByteString -> Trie (DeSerializedData parK) -> Validation [ParamErr] a + + default fromParam :: (Generic a, GFromParam (Rep a) parK) => Proxy (parK :: ParamK) -> ByteString -> Trie (DeSerializedData parK) -> Validation [ParamErr] a + fromParam pt pfx = (fmap to) . gfromParam pt pfx (ParamAcc 0 False) ParamSettings + +-- | Serialize a type to 'ByteString'. +class EncodeParam (t :: *) where + encodeParam :: t -> ByteString + + default encodeParam :: (Generic t, GHttpParam (Rep t)) => t -> ByteString + encodeParam = gEncodeParam . from + +-- | (Try to) Deserialize a type from 'ByteString'. +class DecodeParam (t :: *) where + decodeParam :: ByteString -> Maybe t + + default decodeParam :: (Generic t, GHttpParam (Rep t)) => ByteString -> Maybe t + decodeParam = (fmap to) . gDecodeParam + +instance EncodeParam ByteString where + encodeParam = id + +instance DecodeParam ByteString where + decodeParam = Just + +instance EncodeParam Int where + encodeParam i = ASCII.pack $ show i + +instance DecodeParam Int where + decodeParam str = case readSigned readDecimal str of + Just (v, "") -> Just v + _ -> Nothing + +instance EncodeParam Int8 where + encodeParam i = ASCII.pack $ show i + +instance DecodeParam Int8 where + decodeParam str = case readSigned readDecimal str of + Just (v, "") -> Just v + _ -> Nothing + +instance EncodeParam Int16 where + encodeParam i = ASCII.pack $ show i + +instance DecodeParam Int16 where + decodeParam str = case readSigned readDecimal str of + Just (v, "") -> Just v + _ -> Nothing + +instance EncodeParam Int32 where + encodeParam i = ASCII.pack $ show i + +instance DecodeParam Int32 where + decodeParam str = case readSigned readDecimal str of + Just (v, "") -> Just v + _ -> Nothing + +instance EncodeParam Int64 where + encodeParam i = ASCII.pack $ show i + +instance DecodeParam Int64 where + decodeParam str = case readSigned readDecimal str of + Just (v, "") -> Just v + _ -> Nothing + +instance EncodeParam Word where + encodeParam i = ASCII.pack $ show i + +instance DecodeParam Word where + decodeParam str = case readDecimal str of + Just (v, "") -> Just v + _ -> Nothing + +instance EncodeParam Word8 where + encodeParam i = ASCII.pack $ show i + +instance DecodeParam Word8 where + decodeParam str = case readDecimal str of + Just (v, "") -> Just v + _ -> Nothing + +instance EncodeParam Word16 where + encodeParam i = ASCII.pack $ show i + +instance DecodeParam Word16 where + decodeParam str = case readDecimal str of + Just (v, "") -> Just v + _ -> Nothing + +instance EncodeParam Word32 where + encodeParam i = ASCII.pack $ show i + +instance DecodeParam Word32 where + decodeParam str = case readDecimal str of + Just (v, "") -> Just v + _ -> Nothing + +instance EncodeParam Word64 where + encodeParam i = ASCII.pack $ show i + +instance DecodeParam Word64 where + decodeParam str = case readDecimal str of + Just (v, "") -> Just v + _ -> Nothing + +instance EncodeParam Float where + encodeParam d = ASCII.pack $ show d + +instance DecodeParam Float where + decodeParam str = case readSigned LexF.readExponential str of + Just (v, "") -> Just v + _ -> Nothing + +instance EncodeParam Double where + encodeParam d = ASCII.pack $ show d + +instance DecodeParam Double where + decodeParam str = case readSigned LexF.readExponential str of + Just (v, "") -> Just v + _ -> Nothing + +instance EncodeParam Char where + encodeParam = toByteString . fromChar + +instance DecodeParam Char where + decodeParam str = case decodeUtf8' str of + Right txt -> maybe Nothing (Just . fst) (T.uncons txt) + Left _ -> Nothing + +instance EncodeParam T.Text where + encodeParam = encodeUtf8 + +instance DecodeParam T.Text where + decodeParam str = case decodeUtf8' str of + Right txt -> Just txt + Left _ -> Nothing + +instance EncodeParam Day where + encodeParam day = ASCII.pack $ show day + +instance DecodeParam Day where + decodeParam str = case reads $ ASCII.unpack str of + [(a,"")] -> Just a + _ -> Nothing + +instance EncodeParam UTCTime where + encodeParam t = ASCII.pack $ formatTime defaultTimeLocale format t + where + format = "%FT%T." ++ formatSubseconds t ++ "Z" + +instance DecodeParam UTCTime where + decodeParam str = case parseTimeM True defaultTimeLocale "%FT%T%QZ" (ASCII.unpack str) of + Just d -> Just d + _ -> Nothing + +formatSubseconds :: (FormatTime t) => t -> String +formatSubseconds = formatTime defaultTimeLocale "%q" + +instance EncodeParam Unit where + encodeParam _ = "()" + +instance DecodeParam Unit where + decodeParam str = case str of + "()" -> Just Unit + _ -> Nothing + +instance (EncodeParam a, EncodeParam b) => EncodeParam (a,b) where + encodeParam (a,b) = toStrict $ toLazyByteString $ byteString (encodeParam a) + <> char7 ',' + <> byteString (encodeParam b) + +instance (DecodeParam a, DecodeParam b) => DecodeParam (a,b) where + decodeParam str = case ASCII.split ',' str of + [str1, str2] -> (,) <$> decodeParam str1 <*> decodeParam str2 + _ -> Nothing + +instance EncodeParam Bool where + encodeParam i = ASCII.pack $ show i + +instance DecodeParam Bool where + decodeParam str | str == "True" = Just True + decodeParam str | str == "False" = Just False + | otherwise = Nothing + +instance EncodeParam Integer where + encodeParam i = ASCII.pack $ show i + +instance DecodeParam Integer where + decodeParam str = case ASCII.readInteger str of + Just (i, "") -> Just i + _ -> Nothing + +instance (ToJSON a) => EncodeParam (JsonOf a) where + encodeParam (JsonOf a) = toStrict $ A.encode a + +instance (FromJSON a) => DecodeParam (JsonOf a) where + decodeParam str = A.decodeStrict' str + +class GHttpParam f where + gEncodeParam :: f a -> ByteString + gDecodeParam :: ByteString -> Maybe (f a) + +instance (GHttpParam f) => GHttpParam (D1 c f) where + gEncodeParam (M1 c) = gEncodeParam c + gDecodeParam str = M1 <$> (gDecodeParam str) + +instance (GHttpParam f, GHttpParam g) => GHttpParam (f :+: g) where + gEncodeParam (L1 l) = gEncodeParam l + gEncodeParam (R1 r) = gEncodeParam r + gDecodeParam str = case L1 <$> gDecodeParam str of + l1@(Just _) -> l1 + _ -> R1 <$> gDecodeParam str + +instance (GHttpParam f, Constructor c) => GHttpParam (C1 c f) where + gEncodeParam con@(M1 c) = const (ASCII.pack $ conName con) $ gEncodeParam c + gDecodeParam str = if (ASCII.pack $ conName (undefined :: (C1 c f) a)) == str + then M1 <$> gDecodeParam str + else Nothing + +instance GHttpParam U1 where + gEncodeParam U1 = error "Panic! Unreacheable code @ GHttpParam U1" + gDecodeParam _ = Just U1 + +-- | Use this type if for serialization \/ deserialization nesting is not required. The type contained within most likely requires 'EncodeParam' \/ 'DecodeParam'. +newtype NonNested a = NonNested { getNonNestedParam :: a } + deriving (Show, Eq, Read) + +-- | Serialize a type without nesting. +toNonNestedParam :: (ToParam (NonNested a) parK, EncodeParam a) => 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 par pfx kvs = getNonNestedParam <$> fromParam par pfx kvs + +instance (EncodeParam a) => ToParam (NonNested a) 'QueryParam where + toParam _ pfx (NonNested val) = [(pfx, Just $ encodeParam val)] + +instance (EncodeParam a) => ToParam (NonNested a) 'FormParam where + toParam _ pfx (NonNested val) = [(pfx, encodeParam val)] + +instance (EncodeParam a) => ToParam (NonNested a) 'Cookie where + toParam _ pfx (NonNested val) = [(pfx, encodeParam val)] + +instance (DecodeParam a, Typeable a) => FromParam (NonNested a) 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right $ NonNested v + _ -> Validation $ Left [ParseErr key $ T.pack $ "Unable to cast to " ++ (show $ typeOf (Proxy :: Proxy a))] + _ -> Validation $ Left [NotFound key] + +instance (DecodeParam a, Typeable a) => FromParam (NonNested a) 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right $ NonNested v + _ -> Validation $ Left [ParseErr key $ T.pack $ "Unable to cast to " ++ (show $ typeOf (Proxy :: Proxy a))] + _ -> Validation $ Left [NotFound key] + +instance (DecodeParam a, Typeable a) => FromParam (NonNested a) 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right $ NonNested v + _ -> Validation $ Left [ParseErr key $ T.pack $ "Unable to cast to " ++ (show $ typeOf (Proxy :: Proxy a))] + _ -> Validation $ Left [NotFound key] + +instance ToParam () parK where + toParam _ _ _ = [] + +instance ToHeader () where + toHeader _ = [] + +instance ToParam Unit 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance ToParam Unit 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Unit 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Int 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance ToParam Int 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Int 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Int8 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance ToParam Int8 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Int8 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Int16 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance ToParam Int16 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Int16 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Int32 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance ToParam Int32 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Int32 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Int64 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance ToParam Int64 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Int64 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Word 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance ToParam Word 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Word 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Word8 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance ToParam Word8 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Word8 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Word16 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance ToParam Word16 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Word16 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Word32 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance ToParam Word32 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Word32 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Word64 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance ToParam Word64 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Word64 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Integer 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance ToParam Integer 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Integer 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Bool 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance ToParam Bool 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Bool 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Double 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance ToParam Double 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Double 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Float 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance ToParam Float 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Float 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Char 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance ToParam Char 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Char 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam T.Text 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance ToParam T.Text 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam T.Text 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam ByteString 'QueryParam where + toParam _ pfx val = [(pfx, Just $ val)] + +instance ToParam ByteString 'FormParam where + toParam _ pfx val = [(pfx, val)] + +instance ToParam ByteString 'Cookie where + toParam _ pfx val = [(pfx, val)] + +instance ToParam Day 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance ToParam Day 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam Day 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam UTCTime 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance ToParam UTCTime 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam UTCTime 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance (EncodeParam a) => ToParam (OptValue a) 'QueryParam where + toParam _ pfx (OptValue (Just val)) = [(pfx, Just $ encodeParam val)] + toParam _ pfx (OptValue Nothing) = [(pfx, Nothing)] + +instance (EncodeParam a) => ToParam (OptValue a) 'FormParam where + toParam _ pfx (OptValue (Just val)) = [(pfx, encodeParam val)] + toParam _ _ (OptValue Nothing) = [] + +instance (EncodeParam a) => ToParam (OptValue a) 'Cookie where + toParam _ pfx (OptValue (Just val)) = [(pfx, encodeParam val)] + toParam _ _ (OptValue Nothing) = [] + +instance (ToJSON a, FromJSON a) => ToParam (JsonOf a) 'QueryParam where + toParam _ pfx val = [(pfx, Just $ encodeParam val)] + +instance (ToJSON a, FromJSON a) => ToParam (JsonOf a) 'FormParam where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance (ToJSON a, FromJSON a) => ToParam (JsonOf a) 'Cookie where + toParam _ pfx val = [(pfx, encodeParam val)] + +instance ToParam a par => ToParam (Maybe a) par where + toParam pt pfx (Just val) = toParam pt pfx val + toParam _ _ Nothing = [] + +instance (ToParam a par, ToParam b par) => ToParam (Either a b) par where + toParam pt pfx (Left e) = toParam pt (pfx `nest` "Left") e + toParam pt pfx (Right v) = toParam pt (pfx `nest` "Right") v + +instance ToParam a par => ToParam [a] par where + toParam pt pfx vals = Prelude.concatMap (\(ix, v) -> toParam pt (pfx `nest` (ASCII.pack $ show ix)) v) $ Prelude.zip [(0 :: Word)..] vals + +instance ToParam a par => ToParam (Vector a) par where + toParam pt pfx vals = toParam pt pfx (V.toList vals) + +instance FromParam () parK where + fromParam _ _ _ = pure () + +instance FromHeader () where + fromHeader _ = pure () + +instance FromParam Unit 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to NullaryConstructor"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Unit 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to NullaryConstructor"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Unit 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to NullaryConstructor"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Bool 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Bool"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Bool 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Bool"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Bool 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Bool"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Char 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Char"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Char 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Char"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Char 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Char"] + _ -> Validation $ Left [NotFound key] + +instance FromParam UTCTime 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to UTCTime (ISO-8601)"] + _ -> Validation $ Left [NotFound key] + +instance FromParam UTCTime 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to UTCTime (ISO-8601)"] + _ -> Validation $ Left [NotFound key] + +instance FromParam UTCTime 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to UTCTime (ISO-8601)"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Int 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Int"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Int 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Int"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Int 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Int"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Int8 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Int8"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Int8 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Int8"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Int8 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Int8"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Int16 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Int16"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Int16 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Int16"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Int16 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Int16"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Int32 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Int32"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Int32 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Int32"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Int32 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Int32"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Int64 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Int64"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Int64 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Int64"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Int64 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Int64"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Integer 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Int64"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Integer 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Int64"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Integer 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Int64"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Word 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Word"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Word 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Word"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Word 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Word"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Word8 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Word8"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Word8 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Word8"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Word8 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Word8"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Word16 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Word16"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Word16 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Word16"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Word16 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Word16"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Word32 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Word32"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Word32 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Word32"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Word32 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Word32"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Word64 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Word64"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Word64 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Word64"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Word64 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Word64"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Double 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Double"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Double 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Double"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Double 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Double"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Float 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Float"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Float 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Float"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Float 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Float"] + _ -> Validation $ Left [NotFound key] + +instance FromParam ByteString 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to ByteString"] + _ -> Validation $ Left [NotFound key] + +instance FromParam ByteString 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to ByteString"] + _ -> Validation $ Left [NotFound key] + +instance FromParam ByteString 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to ByteString"] + _ -> Validation $ Left [NotFound key] + +instance FromParam a par => FromParam (Maybe a) par where + fromParam pt key kvs = case Trie.null kvs' of + True -> Validation $ Right Nothing + False -> case (fromParam pt key kvs' :: Validation [ParamErr] a) of + Validation (Right val) -> Validation $ Right $ Just val + Validation (Left errs) -> Validation $ Left errs + where kvs' = submap key kvs + +instance (FromParam a par, FromParam b par) => FromParam (Either a b) par where + fromParam pt key kvs = case Trie.null kvsL of + True -> case Trie.null kvsR of + True -> Validation $ Left [ParseErr key "Unable to cast to Either"] + False -> Right <$> fromParam pt keyR kvsR + False -> Left <$> fromParam pt keyL kvsL + where kvsL = submap keyL kvs + kvsR = submap keyR kvs + keyL = (key `nest` "Left") + keyR = (key `nest` "Right") + +instance FromParam T.Text 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Text"] + _ -> Validation $ Left [NotFound key] + +instance FromParam T.Text 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Text"] + _ -> Validation $ Left [NotFound key] + +instance FromParam T.Text 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Text"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Day 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Day"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Day 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Day"] + _ -> Validation $ Left [NotFound key] + +instance FromParam Day 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right v + _ -> Validation $ Left [ParseErr key "Unable to cast to Day"] + _ -> Validation $ Left [NotFound key] + +instance (Show (DeSerializedData par), FromParam a par) => FromParam [a] par where + fromParam pt key kvs = case Trie.null kvs' of + 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 + where kvs' = submap key kvs + kvitems = Prelude.takeWhile (not . Prelude.null . snd) (Prelude.map (\ix -> + let ixkey = key `nest` (ASCII.pack $ show ix) + in (ixkey, submap ixkey kvs')) [(0 :: Word) .. 2000]) + accRes acc elemt = case (acc, elemt) of + (Validation (Right as), Validation (Right e)) -> Validation $ Right (e:as) + (Validation (Left as), Validation (Right _)) -> Validation $ Left as + (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 + fromParam pt key kvs = case fromParam pt key kvs of + Validation (Right v) -> Validation $ Right (V.fromList v) + Validation (Left err) -> Validation (Left err) + +instance (DecodeParam a) => FromParam (OptValue a) 'QueryParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just (Just par) -> case decodeParam par of + Just v -> Validation $ Right $ OptValue $ Just v + _ -> Validation $ Left [ParseErr key "Unable to cast to OptValue"] + Just Nothing -> Validation $ Right $ OptValue Nothing + _ -> Validation $ Left [NotFound key] + +instance (DecodeParam a) => FromParam (OptValue a) 'FormParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right $ OptValue $ Just v + _ -> Validation $ Left [ParseErr key "Unable to cast to OptValue"] + _ -> Validation $ Left [NotFound key] + +instance (DecodeParam a) => FromParam (OptValue a) 'Cookie where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> case decodeParam par of + Just v -> Validation $ Right $ OptValue $ Just v + _ -> Validation $ Left [ParseErr key "Unable to cast to OptValue"] + _ -> Validation $ Left [NotFound key] + +instance ToParam FileInfo 'FileParam where + toParam _ key (FileInfo val) = [(key, val)] + +instance FromParam FileInfo 'FileParam where + fromParam pt key kvs = case lookupParam pt key kvs of + Just par -> Validation $ Right (FileInfo par) + Nothing -> Validation $ Left [NotFound key] + +instance ToParam ByteString 'PathParam where + toParam _ _ v = [encodeParam v] + +instance ToParam Int 'PathParam where + toParam _ _ v = [encodeParam v] + +instance ToParam Int8 'PathParam where + toParam _ _ v = [encodeParam v] + +instance ToParam Int16 'PathParam where + toParam _ _ v = [encodeParam v] + +instance ToParam Int32 'PathParam where + toParam _ _ v = [encodeParam v] + +instance ToParam Int64 'PathParam where + toParam _ _ v = [encodeParam v] + +instance ToParam Word 'PathParam where + toParam _ _ v = [encodeParam v] + +instance ToParam Word8 'PathParam where + toParam _ _ v = [encodeParam v] + +instance ToParam Word16 'PathParam where + toParam _ _ v = [encodeParam v] + +instance ToParam Word32 'PathParam where + toParam _ _ v = [encodeParam v] + +instance ToParam Word64 'PathParam where + toParam _ _ v = [encodeParam v] + +instance ToParam Float 'PathParam where + toParam _ _ v = [encodeParam v] + +instance ToParam Double 'PathParam where + toParam _ _ v = [encodeParam v] + +instance ToParam Char 'PathParam where + toParam _ _ v = [encodeParam v] + +instance ToParam T.Text 'PathParam where + toParam _ _ v = [encodeParam v] + +instance ToParam Day 'PathParam where + toParam _ _ v = [encodeParam v] + +instance ToParam UTCTime 'PathParam where + toParam _ _ v = [encodeParam v] + +instance ToParam Bool 'PathParam where + toParam _ _ v = [encodeParam v] + +instance ToParam Integer 'PathParam where + toParam _ _ v = [encodeParam v] + +instance (ToJSON a) => ToParam (JsonOf a) 'PathParam where + toParam _ _ v = [encodeParam v] + +instance ( EncodeParam a + , EncodeParam b + ) => ToParam (a, b) 'PathParam where + toParam _ _ (a, b) = [encodeParam a, encodeParam b] + +instance ( EncodeParam a + , EncodeParam b + , EncodeParam c + ) => ToParam (a, b, c) 'PathParam where + toParam _ _ (a, b, c) = [ encodeParam a + , encodeParam b + , encodeParam c + ] + +instance ( EncodeParam a + , EncodeParam b + , EncodeParam c + , EncodeParam d + ) => ToParam (a, b, c, d) 'PathParam where + toParam _ _ (a, b, c, d) + = [ encodeParam a + , encodeParam b + , encodeParam c + , encodeParam d + ] + +instance ( EncodeParam a + , EncodeParam b + , EncodeParam c + , EncodeParam d + , EncodeParam e + ) => ToParam (a, b, c, d, e) 'PathParam where + toParam _ _ (a, b, c, d, e) + = [ encodeParam a + , encodeParam b + , encodeParam c + , encodeParam d + , encodeParam e + ] + +instance ( EncodeParam a + , EncodeParam b + , EncodeParam c + , EncodeParam d + , EncodeParam e + , EncodeParam f + ) => ToParam (a, b, c, d, e, f) 'PathParam where + toParam _ _ (a, b, c, d, e, f) + = [ encodeParam a + , encodeParam b + , encodeParam c + , encodeParam d + , encodeParam e + , encodeParam f + ] + +instance ( EncodeParam a + , EncodeParam b + , EncodeParam c + , EncodeParam d + , EncodeParam e + , EncodeParam f + , EncodeParam g + , EncodeParam h + ) => ToParam (a, b, c, d, e, f, g, h) 'PathParam where + toParam _ _ (a, b, c, d, e, f, g, h) + = [ encodeParam a + , encodeParam b + , encodeParam c + , encodeParam d + , encodeParam e + , encodeParam f + , encodeParam g + , encodeParam h + ] + +instance ( EncodeParam a + , EncodeParam b + , EncodeParam c + , EncodeParam d + , EncodeParam e + , EncodeParam f + , EncodeParam g + , EncodeParam h + , EncodeParam i + ) => ToParam (a, b, c, d, e, f, g, h, i) 'PathParam where + toParam _ _ (a, b, c, d, e, f, g, h, i) + = [ encodeParam a + , encodeParam b + , encodeParam c + , encodeParam d + , encodeParam e + , encodeParam f + , encodeParam g + , encodeParam h + , encodeParam i + ] + +instance ( EncodeParam a + , EncodeParam b + , EncodeParam c + , EncodeParam d + , EncodeParam e + , EncodeParam f + , EncodeParam g + , EncodeParam h + , EncodeParam i + , EncodeParam j + ) => ToParam (a, b, c, d, e, f, g, h, i, j) 'PathParam where + toParam _ _ (a, b, c, d, e, f, g, h, i, j) + = [ encodeParam a + , encodeParam b + , encodeParam c + , encodeParam d + , encodeParam e + , encodeParam f + , encodeParam g + , encodeParam h + , encodeParam i + , encodeParam j + ] + +-- | Errors that occured during deserialization. +data ParamErr = NotFound ByteString -- ^ The key was not found. + | ParseErr ByteString T.Text -- ^ A parse error occured while deserializing the type. + deriving (Show, Eq) + +utf8DecodeError :: String -> String -> a +utf8DecodeError src msg = error $ "Error decoding Bytes into UTF8 string at: " ++ src ++ " Message: " ++ msg + +instance ToJSON ParamErr where + toJSON (NotFound bs) = case decodeUtf8' bs of + Left ex -> utf8DecodeError "ToJSON ParamErr" (show ex) + Right bs' -> A.object ["NotFound" A..= bs'] + toJSON (ParseErr bs msg) = case decodeUtf8' bs of + 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'. +class ParamErrToApiErr apiErr where + toApiErr :: [ParamErr] -> apiErr + +instance ParamErrToApiErr () where + toApiErr = const () + +instance ParamErrToApiErr T.Text where + toApiErr errs = T.pack (show errs) + +instance ParamErrToApiErr A.Value where + toApiErr errs = toJSON errs + +-- | Nest the key with a prefix. +-- +-- > nest "pfx" "key" == "pfx.key" +-- > nest "" "key" == "key" +nest :: ByteString -> ByteString -> ByteString +nest s1 s2 | SB.null s1 = s2 + | otherwise = SB.concat [s1, ".", s2] + +-- | Lookup a value from the 'Trie' using the given key. +lookupParam :: Proxy (parK :: ParamK) -> ByteString -> Trie (DeSerializedData parK) -> Maybe (DeSerializedData parK) +lookupParam _ key kvs = Trie.lookup key kvs + +data ParamAcc = ParamAcc { index :: Int, isSum :: Bool } + deriving (Show, Eq) + +data ParamSettings = ParamSettings + deriving (Show, Eq) + +-- | Serialize a type to the header params +class ToHeader a where + toHeader :: a -> [Http.Header] + + default toHeader :: (Generic a, GToHeader (Rep a)) => a -> [Http.Header] + toHeader = gtoHeader "" (ParamAcc 0 False) ParamSettings . from + +-- | (Try to) Deserialize a type from the header params +class FromHeader a where + fromHeader :: [Http.Header] -> Validation [ParamErr] a + + default fromHeader :: (Generic a, GFromHeader (Rep a)) => [Http.Header] -> Validation [ParamErr] a + fromHeader = (fmap to) . gfromHeader "" (ParamAcc 0 False) ParamSettings + +class GToHeader f where + gtoHeader :: ByteString -> ParamAcc -> ParamSettings -> f a -> [Http.Header] + +instance (GToHeader f, GToHeader g) => GToHeader (f :+: g) where + gtoHeader pfx pa psett (L1 x) = gtoHeader pfx (pa { isSum = True }) psett x + gtoHeader pfx pa psett (R1 y) = gtoHeader pfx (pa { isSum = True }) psett y + +instance (GToHeader f, GToHeader g) => GToHeader (f :*: g) where + gtoHeader pfx pa psett (x :*: y) = gtoHeader pfx pa psett x ++ gtoHeader pfx (pa { index = index pa + 1 }) psett y + +instance (EncodeParam c) => GToHeader (K1 i c) where + gtoHeader pfx _ _ (K1 x) = [(mk pfx, encodeParam x)] + +instance (GToHeader f, Constructor t) => GToHeader (M1 C t f) where + gtoHeader pfx pa psett con@(M1 x) = case isSum pa of + True -> gtoHeader (pfx `nest` ASCII.pack (conName con)) (pa { index = 0 }) psett x + False -> gtoHeader pfx (pa { index = 0 }) psett x + +instance (GToHeader f) => GToHeader (M1 D t f) where + gtoHeader pfx pa psett (M1 x) = gtoHeader pfx pa psett x + +instance (GToHeader f, Selector t) => GToHeader (M1 S t f) where + gtoHeader pfx pa psett m@(M1 x) = let fldN = ASCII.pack (selName m) + in case fldN of + "" -> gtoHeader (pfx `nest` numberedFld pa) pa psett x + _ -> gtoHeader (pfx `nest` fldN) pa psett x + +instance GToHeader U1 where + gtoHeader pfx _ _ _ = [(mk pfx, encodeParam Unit)] + +class GFromHeader f where + gfromHeader :: ByteString -> ParamAcc -> ParamSettings -> [Http.Header] -> Validation [ParamErr] (f a) + +instance (GFromHeader f, GFromHeader g) => GFromHeader (f :*: g) where + gfromHeader pfx pa psett kvs = (:*:) <$> gfromHeader pfx pa psett kvs + <*> gfromHeader pfx (pa { index = index pa + 1 }) psett kvs + +instance (GFromHeader f, GFromHeader g) => GFromHeader (f :+: g) where + gfromHeader pfx pa psett kvs = case L1 <$> gfromHeader pfx (pa { isSum = True }) psett kvs of + l1@(Validation (Right _)) -> l1 + Validation (Left []) -> R1 <$> gfromHeader pfx (pa { isSum = True }) psett kvs + l1 -> l1 + +instance (GFromHeader f, Constructor t) => GFromHeader (M1 C t f) where + gfromHeader pfx pa psett kvs = + let conN = ASCII.pack (conName (undefined :: (M1 C t f) a)) + in case isSum pa of + True -> case isMemberH (pfx `nest` conN) kvs of + True -> M1 <$> gfromHeader (pfx `nest` conN) pa psett kvs + False -> Validation $ Left [] + False -> M1 <$> gfromHeader pfx pa psett kvs + +instance (GFromHeader f, Datatype t) => GFromHeader (M1 D t f) where + gfromHeader pfx pa psett kvs = case M1 <$> gfromHeader pfx pa psett kvs of + Validation (Left []) -> Validation (Left [ParseErr pfx ("Unable to cast to SumType: " <> dtN)]) + v -> v + + where dtN = T.pack $ datatypeName (undefined :: (M1 D t f) a) + +instance (GFromHeader f, Selector t) => GFromHeader (M1 S t f) where + gfromHeader pfx pa psett kvs = let fldN = (ASCII.pack $ (selName (undefined :: (M1 S t f) a))) + in case fldN of + "" -> M1 <$> gfromHeader (pfx `nest` numberedFld pa) pa psett kvs + _ -> M1 <$> gfromHeader (pfx `nest` fldN) pa psett kvs + +instance (DecodeParam c) => GFromHeader (K1 i c) where + gfromHeader key _ _ kvs = case lookupH key kvs of + Just v -> case decodeParam v of + Just v' -> Validation (Right $ K1 v') -- K1 <$> fromParam pt pfx kvs + Nothing -> Validation $ Left [ParseErr key "Unable to cast to "] + _ -> Validation $ Left [NotFound key] + +instance GFromHeader U1 where + gfromHeader key _ _ kvs = case lookupH key kvs of + Just v -> case (decodeParam v :: Maybe Unit) of + Just _ -> Validation (Right U1) + Nothing -> Validation $ Left [ParseErr key "Unable to cast to "] + _ -> Validation $ Left [NotFound key] + +class GFromParam f (parK :: ParamK) where + gfromParam :: Proxy (parK :: ParamK) -> ByteString -> ParamAcc -> ParamSettings -> Trie (DeSerializedData parK) -> Validation [ParamErr] (f a) + +instance (GFromParam f parK, GFromParam g parK) => GFromParam (f :*: g) parK where + gfromParam pt pfx pa psett kvs = (:*:) <$> gfromParam pt pfx pa psett kvs + <*> gfromParam pt pfx (pa { index = index pa + 1 }) psett kvs + +instance (GFromParam f parK, GFromParam g parK) => GFromParam (f :+: g) parK where + gfromParam pt pfx pa psett kvs = case L1 <$> gfromParam pt pfx (pa { isSum = True }) psett kvs of + l1@(Validation (Right _)) -> l1 + Validation (Left []) -> R1 <$> gfromParam pt pfx (pa { isSum = True }) psett kvs + l1 -> l1 + +instance (GFromParam f parK, Constructor t) => GFromParam (M1 C t f) parK where + gfromParam pt pfx pa psett kvs = + let conN = ASCII.pack (conName (undefined :: (M1 C t f) a)) + in case isSum pa of + True -> case Trie.null $ submap (pfx `nest` conN) kvs of + False -> M1 <$> gfromParam pt (pfx `nest` conN) pa psett kvs + True -> Validation $ Left [] + False -> M1 <$> gfromParam pt pfx pa psett kvs + +instance (GFromParam f parK, Datatype t) => GFromParam (M1 D t f) parK where + gfromParam pt pfx pa psett kvs = case M1 <$> gfromParam pt pfx pa psett kvs of + Validation (Left []) -> Validation (Left [ParseErr pfx ("Unable to cast to SumType: " <> dtN)]) + v -> v + + where dtN = T.pack $ datatypeName (undefined :: (M1 D t f) a) + +instance (GFromParam f parK, Selector t) => GFromParam (M1 S t f) parK where + gfromParam pt pfx pa psett kvs = let fldN = (ASCII.pack $ (selName (undefined :: (M1 S t f) a))) + 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) + +instance (FromParam c parK) => GFromParam (K1 i c) parK where + gfromParam pt pfx _ _ kvs = K1 <$> fromParam pt pfx kvs + +instance (FromParam Unit parK) => GFromParam U1 parK where + gfromParam pt key _ _ kvs = const U1 <$> (fromParam pt key kvs :: Validation [ParamErr] Unit) + +class GToParam f (parK :: ParamK) where + gtoParam :: Proxy (parK :: ParamK) -> ByteString -> ParamAcc -> ParamSettings -> f a -> [SerializedData parK] + +instance (GToParam f parK, GToParam g parK) => GToParam (f :*: g) parK where + gtoParam pt pfx pa psett (x :*: y) = gtoParam pt pfx pa psett x ++ gtoParam pt pfx (pa { index = index pa + 1 }) psett y + +instance (GToParam f parK, GToParam g parK) => GToParam (f :+: g) parK where + gtoParam pt pfx pa psett(L1 x) = gtoParam pt pfx (pa { isSum = True }) psett x + gtoParam pt pfx pa psett (R1 y) = gtoParam pt pfx (pa { isSum = True }) psett y + +instance (ToParam c parK) => GToParam (K1 i c) parK where + gtoParam pt pfx _ _ (K1 x) = toParam pt pfx x + +instance (GToParam f parK, Constructor t) => GToParam (M1 C t f) parK where + gtoParam pt pfx pa psett con@(M1 x) = case isSum pa of + True -> gtoParam pt (pfx `nest` ASCII.pack (conName con)) (pa { index = 0 }) psett x + False -> gtoParam pt pfx (pa { index = 0 }) psett x + +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 + gtoParam pt pfx pa psett m@(M1 x) = let fldN = ASCII.pack (selName m) + in case fldN of + "" -> gtoParam pt (pfx `nest` numberedFld pa) pa psett x + _ -> gtoParam pt (pfx `nest` fldN) pa psett x + +instance (ToParam Unit parK) => GToParam U1 parK where + gtoParam pt pfx _ _ _ = toParam pt pfx Unit + +numberedFld :: ParamAcc -> ByteString +numberedFld pa = ASCII.pack $ show (index pa) + +isMemberH :: ByteString -> [Header] -> Bool +isMemberH k = maybe False (const True) . lookupH' isPrefixOf k + +lookupH :: ByteString -> [Header] -> Maybe ByteString +lookupH = lookupH' (==) + +lookupH' :: (CI ByteString -> CI ByteString -> Bool) -> ByteString -> [Header] -> Maybe ByteString +lookupH' f k = fmap snd . L.find ((f $ mk k) . fst) + +isPrefixOf :: CI ByteString -> CI ByteString -> Bool +isPrefixOf n h = foldedCase n `SB.isPrefixOf` foldedCase h diff --git a/src/WebApi/Router.hs b/src/WebApi/Router.hs new file mode 100644 --- /dev/null +++ b/src/WebApi/Router.hs @@ -0,0 +1,380 @@ +{-| + +Module : WebApi.Contract +License : BSD3 +Stability : experimental +-} + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module WebApi.Router + ( -- * Route types + Static + , Root + , (:/) + -- * Default routing implementation + , Route + , Router (..) + , router + , ToPieces + -- * Custom routing + , PathSegment (..) + , MkPathFormatString (..) + ) where + +import Control.Exception (SomeException (..)) +import Control.Monad.Catch (catches, Handler (..), MonadCatch) +import Data.Proxy +import Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Typeable (Typeable) +import GHC.TypeLits +import Network.HTTP.Types hiding (Query) +import Network.Wai (pathInfo, requestMethod) +import WebApi.ContentTypes +import WebApi.Contract +import WebApi.Internal +import WebApi.Param + +-- | Datatype representing a endpoint. +data Route (ms :: [*]) (r :: *) + +data StaticPiece (s :: Symbol) + +data DynamicPiece (t :: *) + +-- | Datatype representing a route. +data (:/) (p1 :: k) (p2 :: k1) +infixr 5 :/ + +type instance PathParam' m (Static s) = () +type instance PathParam' m (p1 :/ p2) = HListToTuple (FilterDynP (ToPieces (p1 :/ p2))) + +-- | Datatype representing a static path piece. +data Static (s :: Symbol) + +type Root = Static "" + + +data PieceType :: * -> * where + SPiece :: Proxy (p :: Symbol) -> PieceType (StaticPiece p) + DPiece :: !val -> PieceType (DynamicPiece val) + +data ParsedRoute :: (*, [*]) -> * where + Nil :: Proxy method -> ParsedRoute '(method, '[]) + ConsStaticPiece :: Proxy (p :: Symbol) -> ParsedRoute '(method, ps) -> ParsedRoute '(method, ((StaticPiece p) ': ps)) + ConsDynamicPiece :: !t -> ParsedRoute '(method, ps) -> ParsedRoute '(method, ((DynamicPiece t) ': ps)) + +data HList :: [*] -> * where + HNil :: HList '[] + (:*) :: !a -> HList as -> HList (a ': as) +infixr 5 :* + +fromParsedRoute :: (PathParam m (FromPieces pths) ~ HListToTuple (FilterDynP pths)) + => ParsedRoute '(m, pths) -> PathParam m (FromPieces pths) +fromParsedRoute proutes = case dropStaticPiece proutes of + HNil -> () + p1 :* HNil -> p1 + p1 :* p2 :* HNil -> (p1, p2) + p1 :* p2 :* p3 :* HNil -> (p1, p2, p3) + p1 :* p2 :* p3 :* p4 :* HNil -> (p1, p2, p3, p4) + p1 :* p2 :* p3 :* p4 :* p5 :* HNil -> (p1, p2, p3, p4, p5) + p1 :* p2 :* p3 :* p4 :* p5 :* p6 :* HNil -> (p1, p2, p3, p4, p5, p6) + p1 :* p2 :* p3 :* p4 :* p5 :* p6 :* p7 :* HNil -> (p1, p2, p3, p4, p5, p6, p7) + p1 :* p2 :* p3 :* p4 :* p5 :* p6 :* p7 :* p8 :* HNil -> (p1, p2, p3, p4, p5, p6, p7, p8) + p1 :* p2 :* p3 :* p4 :* p5 :* p6 :* p7 :* p8 :* p9 :* HNil -> (p1, p2, p3, p4, p5, p6, p7, p8, p9) + _ -> error "Panic: Unable to parse routes. Only 25 path parameter are supported" + +dropStaticPiece :: ParsedRoute '(m, pths) -> HList (FilterDynP pths) +dropStaticPiece (Nil _) = HNil +dropStaticPiece (ConsStaticPiece _ ps) = dropStaticPiece ps +dropStaticPiece (ConsDynamicPiece p ps) = p :* dropStaticPiece ps + +-- | Convert the path into a flat hierarchy. +type family ToPieces (r :: k) :: [*] where + ToPieces (Static s) = '[StaticPiece s] + ToPieces ((p1 :: Symbol) :/ (p2 :: Symbol)) = '[StaticPiece p1, StaticPiece p2] + ToPieces ((p1 :: *) :/ (p2 :: Symbol)) = '[DynamicPiece p1, StaticPiece p2] + ToPieces ((p1 :: Symbol) :/ (p2 :/ p3)) = StaticPiece p1 ': ToPieces (p2 :/ p3) + ToPieces ((p1 :: *) :/ (p2 :/ p3)) = DynamicPiece p1 ': ToPieces (p2 :/ p3) + ToPieces ((p1 :: *) :/ (p2 :: *)) = '[DynamicPiece p1, DynamicPiece p2] + ToPieces ((p1 :: Symbol) :/ (p2 :: *)) = '[StaticPiece p1, DynamicPiece p2] + +type family FromPieces (pps :: [*]) :: * where + FromPieces '[StaticPiece s] = Static s + FromPieces '[StaticPiece p1, StaticPiece p2] = p1 :/ p2 + FromPieces '[DynamicPiece p1, DynamicPiece p2] = p1 :/ p2 + FromPieces '[StaticPiece p1, DynamicPiece p2] = p1 :/ p2 + FromPieces '[DynamicPiece p1, StaticPiece p2] = p1 :/ p2 + FromPieces ((StaticPiece p1) ': ((StaticPiece p2) ': pps)) = p1 :/ (FromPieces ((StaticPiece p2) ': pps)) + FromPieces ((DynamicPiece p1) ': ((DynamicPiece p2) ': pps)) = p1 :/ (FromPieces ((DynamicPiece p2) ': pps)) + FromPieces ((StaticPiece p1) ': ((DynamicPiece p2) ': pps)) = p1 :/ (FromPieces ((DynamicPiece p2) ': pps)) + FromPieces ((DynamicPiece p1) ': ((StaticPiece p2) ': pps)) = p1 :/ (FromPieces ((StaticPiece p2) ': pps)) + +type family FilterDynP (ps :: [*]) :: [*] where + FilterDynP (DynamicPiece p1 ': p2) = p1 ': FilterDynP p2 + 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 + (a ': as) :++ bs = a ': (as :++ bs) + +-- | Class to do the default routing. +class Router (server :: *) (r :: k) (pr :: (*, [*])) where + route :: ( iface ~ (ApiInterface server) + -- , HandlerM server + ) => Proxy r -> server -> ParsedRoute pr -> RoutingApplication + +type family MarkDyn (pp :: *) :: * where + MarkDyn (p1 :/ t) = (p1 :/ t) + MarkDyn (t :: *) = DynamicPiece t + +instance (Router s r '(m, '[]), SingMethod m) => Router s (Route (m ': ms) r) pr where + route _ _s _ request respond = + case requestMethod request == meth of + True -> route (Proxy :: Proxy r) _s (Nil (Proxy :: Proxy m)) request respond + False -> respond NotMatched + where meth = singMethod (Proxy :: Proxy m) + +instance Router s (Route '[] r) pr where + route _ _s _ _request respond = respond NotMatched + +instance (Router s route pr, Router s routes pr) => Router s ((route :: *) ': routes) pr where + route _ _s parsedRoute request respond = + route (Proxy :: Proxy route) _s parsedRoute request $ \case + Matched a -> respond $ Matched a + NotMatched -> route (Proxy :: Proxy routes) _s parsedRoute request respond + +instance Router s '[] pr where + route _ _s _ _ respond = respond NotMatched + +instance (Router s (MarkDyn rest) '(m, (pp :++ '[DynamicPiece piece])), DecodeParam piece) + => Router s ((piece :: *) :/ (rest :: *)) '(m, pp) where + route _ _s parsedRoute request respond = + case pathInfo request of + (lpth : rpths) -> case (decodeParam (encodeUtf8 lpth) :: Maybe piece) of + Just dynPiece -> route (Proxy :: Proxy (MarkDyn rest)) _s (snocParsedRoute parsedRoute $ DPiece dynPiece) request {pathInfo = rpths} respond + Nothing -> respond NotMatched + _ -> respond $ NotMatched + +instance (Router s (MarkDyn rest) '(m, (pp :++ '[StaticPiece piece])), KnownSymbol piece) + => Router s ((piece :: Symbol) :/ (rest :: *)) '(m, pp) where + route _ _s parsedRoute request respond = + case pathInfo request of + (lpth : rpths) | lpieceTxt == lpth -> route (Proxy :: Proxy (MarkDyn rest)) _s (snocParsedRoute parsedRoute $ SPiece (Proxy :: Proxy piece)) request {pathInfo = rpths} respond + _ -> respond $ NotMatched + where lpieceTxt = symTxt (Proxy :: Proxy piece) + + +-- Base Cases +instance ( KnownSymbol piece, ApiHandler s m (Static piece) + , ToHeader (HeaderOut m (Static piece)) + , ToParam (CookieOut m (Static piece)) 'Cookie + , FromParam (QueryParam m (Static piece)) 'QueryParam + , FromParam (FormParam m (Static piece)) 'FormParam + , FromParam (FileParam m (Static piece)) 'FileParam + , FromHeader (HeaderIn m (Static piece)) + , FromParam (CookieIn m (Static piece)) 'Cookie + , Encodings (ContentTypes m (Static piece)) (ApiOut m (Static piece)) + , Encodings (ContentTypes m (Static piece)) (ApiErr m (Static piece)) + , PathParam m (Static piece) ~ () + , ParamErrToApiErr (ApiErr m (Static piece)) + , Typeable m + , Typeable (Static piece) + , WebApiImplementation s + ) => Router s (Static piece) '(m, pp) where + route _ serv _ request respond = + case pathInfo request of + (pth : []) | symTxt (Proxy :: Proxy piece) == pth -> respond . Matched =<< getResponse + [] | T.null $ symTxt (Proxy :: Proxy piece) -> respond . Matched =<< getResponse + _ -> respond $ NotMatched + where getResponse = do + apiReq' <- fromWaiRequest request () + response <- case apiReq' of + Validation (Right apiReq) -> toIO serv $ handler' serv (Proxy :: Proxy '[]) (apiReq :: Request m (Static piece)) + Validation (Left errs) -> return $ Failure $ Left $ ApiError badRequest400 (toApiErr errs) Nothing Nothing + return $ toWaiResponse request response + +instance ( KnownSymbol lpiece + , KnownSymbol rpiece + , paths ~ (pp :++ '[StaticPiece lpiece, StaticPiece rpiece]) + , paths ~ ((pp :++ '[StaticPiece lpiece]) :++ '[StaticPiece rpiece]) + , route ~ (FromPieces paths) + , ApiHandler s m route + , PathParam m route ~ HListToTuple (FilterDynP paths) + , FromParam (QueryParam m route) 'QueryParam + , FromParam (FormParam m route) 'FormParam + , FromParam (FileParam m route) 'FileParam + , FromParam (CookieIn m route) 'Cookie + , FromHeader (HeaderIn m route) + , Encodings (ContentTypes m route) (ApiErr m route) + , Encodings (ContentTypes m route) (ApiOut m route) + , ToHeader (HeaderOut m route) + , ToParam (CookieOut m route) 'Cookie + , ParamErrToApiErr (ApiErr m route) + , Typeable m + , Typeable route + , WebApiImplementation s + ) => Router s ((lpiece :: Symbol) :/ (rpiece :: Symbol)) '(m, pp) where + route _ serv parsedRoute request respond = + case pathInfo request of + (lpth : rpth : []) | lpieceTxt == lpth && rpieceTxt == rpth -> respond . Matched =<< getResponse + _ -> respond NotMatched + where lpieceTxt = symTxt (Proxy :: Proxy lpiece) + rpieceTxt = symTxt (Proxy :: Proxy rpiece) + pRoute :: ParsedRoute '(m, paths) + pRoute = snocParsedRoute (snocParsedRoute parsedRoute $ SPiece (Proxy :: Proxy lpiece)) $ SPiece (Proxy :: Proxy rpiece) + pathPar = fromParsedRoute pRoute + getResponse = do + apiReq' <- fromWaiRequest request pathPar + response <- case apiReq' of + Validation (Right apiReq) -> toIO serv $ handler' serv (Proxy :: Proxy '[]) (apiReq :: Request m route) + Validation (Left errs) -> return $ Failure $ Left $ ApiError badRequest400 (toApiErr errs) Nothing Nothing + return $ toWaiResponse request response + +instance ( KnownSymbol rpiece + , paths ~ (pp :++ '[DynamicPiece lpiece, StaticPiece rpiece]) + , paths ~ ((pp :++ '[DynamicPiece lpiece]) :++ '[StaticPiece rpiece]) + , route ~ (FromPieces paths) + , ApiHandler s m route + , PathParam m route ~ HListToTuple (FilterDynP paths) + , FromParam (QueryParam m route) 'QueryParam + , FromParam (FormParam m route) 'FormParam + , FromParam (FileParam m route) 'FileParam + , FromParam (CookieIn m route) 'Cookie + , FromHeader (HeaderIn m route) + , Encodings (ContentTypes m route) (ApiErr m route) + , Encodings (ContentTypes m route) (ApiOut m route) + , ToHeader (HeaderOut m route) + , ToParam (CookieOut m route) 'Cookie + , DecodeParam lpiece + , ParamErrToApiErr (ApiErr m route) + , Typeable m + , Typeable route + , WebApiImplementation s + ) => Router s ((lpiece :: *) :/ (rpiece :: Symbol)) '(m, pp) where + route _ serv parsedRoute request respond = + case pathInfo request of + (lpth : rpth : []) | rpieceTxt == rpth -> case (decodeParam (encodeUtf8 lpth) :: Maybe lpiece) of + Just dynVal -> respond . Matched =<< getResponse dynVal + Nothing -> respond NotMatched + _ -> respond NotMatched + where rpieceTxt = symTxt (Proxy :: Proxy rpiece) + getResponse dynVal = do + let pRoute :: ParsedRoute '(m, paths) + pRoute = snocParsedRoute (snocParsedRoute parsedRoute $ DPiece dynVal) $ SPiece (Proxy :: Proxy rpiece) + apiReq' <- fromWaiRequest request (fromParsedRoute pRoute) + response <- case apiReq' of + Validation (Right apiReq) -> toIO serv $ handler' serv (Proxy :: Proxy '[]) (apiReq :: Request m route) + Validation (Left errs) -> return $ Failure $ Left $ ApiError badRequest400 (toApiErr errs) Nothing Nothing + return $ toWaiResponse request response + + +instance ( route ~ (FromPieces (pp :++ '[DynamicPiece t])) + , ApiHandler s m route + , PathParam m route ~ HListToTuple (FilterDynP (pp :++ '[DynamicPiece t])) + , FromParam (QueryParam m route) 'QueryParam + , FromParam (FormParam m route) 'FormParam + , FromParam (FileParam m route) 'FileParam + , FromParam (CookieIn m route) 'Cookie + , FromHeader (HeaderIn m route) + , Encodings (ContentTypes m route) (ApiErr m route) + , Encodings (ContentTypes m route) (ApiOut m route) + , ToHeader (HeaderOut m route) + , ToParam (CookieOut m route) 'Cookie + , DecodeParam t + , ParamErrToApiErr (ApiErr m route) + , Typeable m + , Typeable route + , WebApiImplementation s + ) => Router s (DynamicPiece t) '(m, pp) where + route _ serv parsedRoute request respond = + case pathInfo request of + (lpth : []) -> case (decodeParam (encodeUtf8 lpth) :: Maybe t) of + Just dynVal -> respond . Matched =<< getResponse dynVal + Nothing -> respond NotMatched + _ -> respond NotMatched + where getResponse dynVal = do + let pRoute :: ParsedRoute '(m, (pp :++ '[DynamicPiece t])) + pRoute = snocParsedRoute parsedRoute $ DPiece dynVal + apiReq' <- fromWaiRequest request (fromParsedRoute pRoute) + response <- case apiReq' of + Validation (Right apiReq) -> toIO serv $ handler' serv (Proxy :: Proxy '[]) (apiReq :: Request m route) + Validation (Left errs) -> return $ Failure $ Left $ ApiError badRequest400 (toApiErr errs) Nothing Nothing + return $ toWaiResponse request response + +router :: ( iface ~ (ApiInterface server) + , Router server apis '(CUSTOM "", '[]) + ) => Proxy apis -> server -> RoutingApplication +router apis s = route apis s emptyParsedRoutes + +-- Helpers + +symTxt :: KnownSymbol sym => proxy sym -> Text +symTxt sym = pack (symbolVal sym) + +emptyParsedRoutes :: ParsedRoute '(CUSTOM "", '[]) +emptyParsedRoutes = Nil Proxy + +snocParsedRoute :: ParsedRoute '(method, ps) -> PieceType pt -> ParsedRoute '(method, ps :++ '[pt]) +snocParsedRoute nil@Nil{} (SPiece sym) = sym `ConsStaticPiece` nil +snocParsedRoute nil@Nil{} (DPiece val) = val `ConsDynamicPiece` nil +snocParsedRoute (ConsStaticPiece sym routes) symOrVal = (ConsStaticPiece sym $ snocParsedRoute routes symOrVal) +snocParsedRoute (ConsDynamicPiece sym routes) symOrVal = (ConsDynamicPiece sym $ snocParsedRoute routes symOrVal) + +instance (MkFormatStr (ToPieces (a :/ b))) => MkPathFormatString (a :/ b) where + mkPathFormatString _ = mkFormatStr (Proxy :: Proxy (ToPieces (a :/ b))) + +instance (KnownSymbol s) => MkPathFormatString (Static s) where + mkPathFormatString _ = mkFormatStr (Proxy :: Proxy (ToPieces (Static s))) + +class MkFormatStr (xs :: [*]) where + mkFormatStr :: Proxy xs -> [PathSegment] + +instance (KnownSymbol s, MkFormatStr xs) => MkFormatStr (StaticPiece s ': xs) where + mkFormatStr _ = StaticSegment (T.pack (symbolVal (Proxy :: Proxy s))) : mkFormatStr (Proxy :: Proxy xs) + +instance (MkFormatStr xs) => MkFormatStr (DynamicPiece s ': xs) where + mkFormatStr _ = Hole : mkFormatStr (Proxy :: Proxy xs) + +instance MkFormatStr '[] where + mkFormatStr _ = [] + +handler' :: forall query p m r. + ( query ~ '[] + , MonadCatch (HandlerM p) + , ApiHandler p m r + , Typeable m + , Typeable r) => p -> Proxy query -> Request m r -> HandlerM p (Query (Response m r) query) +handler' serv p req = (handler (toTagged p serv) req) `catches` excepHandlers + where excepHandlers :: [Handler (HandlerM p) (Query (Response m r) query)] + excepHandlers = [ Handler (\ (ex :: ApiException m r) -> handleApiException serv ex) + , Handler (\ (ex :: SomeException) -> handleSomeException serv ex) ] diff --git a/src/WebApi/Server.hs b/src/WebApi/Server.hs new file mode 100644 --- /dev/null +++ b/src/WebApi/Server.hs @@ -0,0 +1,101 @@ +{-| +Module : WebApi.Server +License : BSD3 +Stability : experimental + +Provides the implementation of web api. Given a contract, an implementation of the web api can be provided by using 'WebApiImplementation' and 'ApiHandler'. 'WebApiImplementation' has the information pertaining to web api as a whole. 'ApiHandler' provides a way to write the handler for a particular API end point. + +Comparing with the "WebApi.Contract", 'WebApi' and 'ApiContract' has the same relationship as 'WebApiImplementation' and 'ApiHandler'. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module WebApi.Server + ( + -- * Creating a WAI application + serverApp + , serverSettings + , ServerSettings + + -- * Implementation of Api + , ApiHandler (..) + , ApiException (..) + , WebApiImplementation (..) + , respond + , respondWith + , raise + , raiseWith + + -- * Wrapping and unwrapping a 'Tagged' + , unTagged + , toTagged + + -- * Routing + , module WebApi.Router + , link + ) where + +import Control.Monad.Catch +import Data.Proxy +import Data.Typeable +import Network.HTTP.Types hiding (Query) +import qualified Network.Wai as Wai +import WebApi.Contract +import WebApi.Internal +import WebApi.Router + +-- | Creates a successful response from its components. It is assumed that 'HeaderOut' and 'CookieOut' has default definitions. +respond :: ( Monad handM + , (HeaderOut m r) ~ () + , (CookieOut m r) ~ () + ) => ApiOut m r + -> handM (Response m r) +respond out = respondWith ok200 out () () + +-- | Creates a successful response from its components. +respondWith :: ( Monad handM + ) => Status + -> ApiOut m r + -> HeaderOut m r + -> CookieOut m r + -> handM (Response m r) +respondWith status out hdrs cook = return $ Success status out hdrs cook + +-- | This function short circuits returning an `ApiError`.It is assumed that 'HeaderOut' and 'CookieOut' has default definitions. +raise :: ( MonadThrow handM + , Typeable m + , Typeable r + ) => Status + -> ApiErr m r + -> handM (Response m r) +raise status errs = raiseWith' (ApiError status errs Nothing Nothing) + +-- | This function short circuits returning an `ApiError`. +raiseWith :: ( Monad handM + , MonadThrow handM + , Typeable m + , Typeable r + ) => Status + -> ApiErr m r + -> HeaderOut m r + -> CookieOut m r + -> handM (Response m r) +raiseWith status errs hdrs cook = raiseWith' (ApiError status errs (Just hdrs) (Just cook)) + +raiseWith' :: ( MonadThrow handM + , Typeable m + , Typeable r + ) => ApiError m r + -> handM (Response m r) +raiseWith' = throwM . ApiException + +-- | Create a WAI application from the information specified in `WebApiImplementation`, `WebApi`, `ApiContract` and `ApiHandler` classes. +serverApp :: ( iface ~ (ApiInterface server) + , Router server (Apis iface) '(CUSTOM "", '[]) + ) => ServerSettings -> server -> Wai.Application +serverApp _ server = toApplication $ router (apis server) server + where apis :: server -> Proxy (Apis (ApiInterface server)) + apis = const Proxy diff --git a/src/WebApi/Versioning.hs b/src/WebApi/Versioning.hs new file mode 100644 --- /dev/null +++ b/src/WebApi/Versioning.hs @@ -0,0 +1,68 @@ +{-| +Module : WebApi.Versioning +License : BSD3 +Stability : experimental +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +module WebApi.Versioning + ( + -- * Versioning styles + MajorMinor (..) + , Major (..) + + -- * Building custom versions + , OrdVersion (..) + , VersionOrd + , compareVersion + ) where + +import Data.Proxy +import GHC.TypeLits + +-- | Comparison between versions. +class OrdVersion (ver :: *) where + cmpVersion :: (ver ~ ((proxy :: k -> *) (v1 :: k)), ord ~ (VersionOrd (proxy v1) (proxy v2)), SingOrd ord) => proxy v1 -> proxy (v2 :: k) -> Proxy ord + cmpVersion _ _ = (Proxy :: Proxy ord) + +-- | Singleton class for ordering +class SingOrd (ord :: Ordering) where + singOrd :: proxy ord -> Ordering + +instance SingOrd 'EQ where + singOrd = const EQ + +instance SingOrd 'LT where + singOrd = const LT + +instance SingOrd 'GT where + singOrd = const GT + +-- | Defines ordering of versions. +type family VersionOrd (v1 :: k) (v2 :: k) :: Ordering + +-- | Comparison between two versions. Returns an 'Ord'. +-- +-- >>> compareVersion (MajorMinor :: MajorMinor (0, 0)) (MajorMinor :: MajorMinor (0, 1)) == LT +-- True +compareVersion :: (OrdVersion (proxy v1), SingOrd (VersionOrd (proxy v1) (proxy v2))) => proxy (v1 :: k) -> proxy (v2 :: k) -> Ordering +compareVersion v1 v2 = singOrd $ cmpVersion v1 v2 + +-- | A Style of versioning which has a Major version and a Minor version. +data MajorMinor (ver :: (Nat, Nat)) = MajorMinor + +-- | A Style of versioning which has only has a Major version. +data Major (maj :: Nat) = Major + +type instance VersionOrd (Major (m :: Nat)) (Major (n :: Nat)) = (CmpNat m n) +type instance VersionOrd (MajorMinor '(maj1, min1)) (MajorMinor '(maj2, min2)) = 'EQ + + +instance OrdVersion (Major maj) where +instance OrdVersion (MajorMinor '(maj, min)) where diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/tests/WebApi/ClientSpec.hs b/tests/WebApi/ClientSpec.hs new file mode 100644 --- /dev/null +++ b/tests/WebApi/ClientSpec.hs @@ -0,0 +1,9 @@ +module WebApi.ClientSpec where + +import Test.Hspec + +spec :: Spec +spec = describe "Webapi client" $ do + it "can create proper requests" $ + pending + diff --git a/tests/WebApi/MockSpec.hs b/tests/WebApi/MockSpec.hs new file mode 100644 --- /dev/null +++ b/tests/WebApi/MockSpec.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, OverloadedStrings, DataKinds, TypeOperators, TypeSynonymInstances, FlexibleInstances, DeriveGeneric #-} +module WebApi.MockSpec (spec) where + +import Data.Aeson +import GHC.Generics +import WebApi +import Test.Hspec +import Test.Hspec.Wai +import Test.QuickCheck +import qualified Network.Wai as Wai + +withApp :: SpecWith Wai.Application -> Spec +withApp = with (return mockApp) + +mockApp :: Wai.Application +mockApp = mockServer serverSettings (MockServer mockServerSettings :: MockServer MockSpec) + +data MockSpec = MockSpec + +type MockApi = Static "mock" + +data QP = QP { qp1 :: Int, qp2 :: Bool } + deriving (Show, Eq, Generic) + +data MockOut = MockOut { out1 :: Int + , out2 :: Bool + , out3 :: Char + } deriving (Show, Eq, Generic) + +instance ToJSON MockOut where +instance FromParam QP 'QueryParam where +instance Arbitrary MockOut where + arbitrary = MockOut <$> arbitrary + <*> arbitrary + <*> arbitrary + +instance WebApi MockSpec where + type Apis MockSpec = '[ Route '[GET] MockApi ] + +instance ApiContract MockSpec GET MockApi where + type QueryParam GET MockApi = QP + type ApiOut GET MockApi = MockOut + + +spec :: Spec +spec = withApp $ describe "WebApi mockserver" $ do + it "should be 200 ok" $ do + get "mock?qp1=5&qp2=True" `shouldRespondWith` 200 diff --git a/tests/WebApi/RequestSpec.hs b/tests/WebApi/RequestSpec.hs new file mode 100644 --- /dev/null +++ b/tests/WebApi/RequestSpec.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, OverloadedStrings, DataKinds, TypeOperators, TypeSynonymInstances, FlexibleInstances, DeriveGeneric #-} +module WebApi.RequestSpec (spec) where + +import WebApi +import Data.Text (Text) +import Network.HTTP.Types.Method (methodPut, methodDelete, methodHead + ,methodPatch, methodConnect, methodTrace, methodOptions) +import Test.Hspec +import Test.Hspec.Wai (with, request, shouldRespondWith, postHtmlForm, matchStatus) +import qualified Test.Hspec.Wai as Hspec.Wai (get) +import GHC.Generics +import Data.ByteString (ByteString) +import Data.Monoid ((<>)) +import Data.List (foldl') +import qualified Network.Wai as Wai +import Data.CaseInsensitive (mk) +import Network.HTTP.Types.Header (Header, hCookie) +import Prelude hiding (FilePath) + +withApp :: SpecWith Wai.Application -> Spec +withApp = with (return reqSpecApp) + +reqSpecApp :: Wai.Application +reqSpecApp = serverApp serverSettings ReqSpecImpl + +data ReqSpec +data ReqSpecImpl = ReqSpecImpl + +{- +data Profile = Profile { name :: Text, age :: Age , desc :: Text } + deriving (Show, Eq, Generic) + +newtype Age = Age { unAge :: Int } + deriving (Show, Eq, Generic) +-} + +data QP = QP { qp1 :: Int , qp2 :: Maybe Bool, qp3 :: Either Text Double } + deriving (Show, Eq, Generic) + +data FoP = FoP { fop :: ByteString } + deriving (Show, Eq, Generic) + +data CP = CP { cp :: Bool } + deriving (Show, Eq, Generic) + +data HP = HP1 { hp1 :: Int } + | HP2 { hp2 :: Bool } + deriving (Show, Eq, Generic) + +data FiP = FiP { fip :: FileInfo } + deriving (Show, Eq, Generic) + +instance FromParam QP 'QueryParam where +instance FromParam FoP 'FormParam where +instance FromParam CP 'Cookie where +instance FromHeader HP where +instance FromParam FiP 'FileParam where + +instance ToParam QP 'QueryParam where +instance ToParam FoP 'FormParam where +instance ToParam CP 'Cookie where +instance ToHeader HP where +instance ToParam FiP 'FileParam where + +type ApiR = Static "api" +-- type QuickCheckR = Static "autogen" + +instance WebApi ReqSpec where + type Version ReqSpec = MajorMinor '(0, 1) + type Apis ReqSpec = '[ Route '[ GET + , POST + , PUT + , DELETE + , HEAD + , PATCH + , TRACE + , CONNECT + , (CUSTOM ("TEST")) + ] ApiR + ] + +instance WebApiImplementation ReqSpecImpl where + type ApiInterface ReqSpecImpl = ReqSpec + +instance ApiContract ReqSpec GET ApiR where + type QueryParam GET ApiR = QP + type ApiOut GET ApiR = () + +instance ApiContract ReqSpec POST ApiR where + type QueryParam POST ApiR = QP + -- type FileParam POST ApiR = FiP + -- type HeaderIn POST ApiR = HP + -- type CookieIn POST ApiR = CP + type FormParam POST ApiR = FoP + type ApiOut POST ApiR = () + type ApiErr POST ApiR = Text + +instance ApiContract ReqSpec PUT ApiR where + -- type QueryParam PUT ApiR = QP + type HeaderIn PUT ApiR = HP + type CookieIn PUT ApiR = CP + -- type FormParam PUT ApiR = FoP + type ApiOut PUT ApiR = () + type ApiErr PUT ApiR = Text + +instance ApiContract ReqSpec DELETE ApiR where + -- type QueryParam DELETE ApiR = QP + -- type HeaderIn DELETE ApiR = HP + -- type CookieIn DELETE ApiR = CP + -- type FormParam DELETE ApiR = FoP + type ApiOut DELETE ApiR = () + +instance ApiContract ReqSpec HEAD ApiR where + -- type QueryParam HEAD ApiR = QP + type ApiOut HEAD ApiR = () + +instance ApiContract ReqSpec PATCH ApiR where + -- type QueryParam PATCH ApiR = QP + -- type HeaderIn PATCH ApiR = HP + -- type CookieIn PATCH ApiR = CP + -- type FormParam PATCH ApiR = FoP + type ApiOut PATCH ApiR = () + +instance ApiContract ReqSpec TRACE ApiR where + -- type QueryParam TRACE ApiR = QP + -- type HeaderIn TRACE ApiR = HP + -- type CookieIn TRACE ApiR = CP + -- type FormParam TRACE ApiR = FoP + type ApiOut TRACE ApiR = () + +instance ApiContract ReqSpec CONNECT ApiR where + -- type QueryParam CONNECT ApiR = QP + -- type HeaderIn CONNECT ApiR = HP + -- type CookieIn CONNECT ApiR = CP + -- type FormParam CONNECT ApiR = FoP + type ApiOut CONNECT ApiR = () + +instance ApiContract ReqSpec (CUSTOM "TEST") ApiR where + -- type QueryParam (CUSTOM "TEST") ApiR = QP + -- type HeaderIn (CUSTOM "TEST") ApiR = HP + -- type CookieIn (CUSTOM "TEST") ApiR = CP + -- type FormParam (CUSTOM "TEST") ApiR = FoP + type ApiOut (CUSTOM "TEST") ApiR = () + +instance ApiHandler ReqSpecImpl (CUSTOM "TEST") ApiR where + handler _ _ = respond () +instance ApiHandler ReqSpecImpl CONNECT ApiR where + handler _ _ = respond () +instance ApiHandler ReqSpecImpl TRACE ApiR where + handler _ _ = respond () +instance ApiHandler ReqSpecImpl HEAD ApiR where + handler _ _ = respond () +instance ApiHandler ReqSpecImpl PATCH ApiR where + handler _ _ = respond () +instance ApiHandler ReqSpecImpl GET ApiR where + handler _ _ = respond () +instance ApiHandler ReqSpecImpl POST ApiR where + handler _ _ = respond () +instance ApiHandler ReqSpecImpl PUT ApiR where + handler _ _ = respond () +instance ApiHandler ReqSpecImpl DELETE ApiR where + handler _ _ = respond () + +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) + + serializeCookie = foldl' (\acc (k, v) -> acc <> ";" <> k <> "=" <> v) "" + +spec :: Spec +spec = withApp $ describe "WebApi request with payload" $ do + context "GET Request" $ do + it "should be 200 ok" $ do + Hspec.Wai.get "api?qp1=5&qp2=True&qp3.Right=15.60" `shouldRespondWith` 200 + context "POST Request" $ do + it "should be 200 ok" $ do + 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 } + context "DELETE Request" $ do + it "should be 200 ok" $ do + request methodDelete "api" [] "" `shouldRespondWith` "[]" { matchStatus = 200 } + context "HEAD Request" $ do + it "should be 200 ok" $ do + request methodHead "api" [] "" `shouldRespondWith` "[]" { matchStatus = 200 } + context "PATCH Request" $ do + it "should be 200 ok" $ do + request methodPatch "api" [] "" `shouldRespondWith` "[]" { matchStatus = 200 } + context "TRACE Request" $ do + it "should be 200 ok" $ do + request methodTrace "api" [] "" `shouldRespondWith` "[]" { matchStatus = 200 } + context "OPTIONS Request" $ do + it "should be 200 ok" $ do + request methodOptions "api" [] "" `shouldRespondWith` "[]" { matchStatus = 200 } + context "CONNECT Request" $ do + it "should be 200 ok" $ do + request methodConnect "api" [] "" `shouldRespondWith` "[]" { matchStatus = 200 } + context "CUSTOM TEST Request" $ do + it "should be 200 ok" $ do + 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 } diff --git a/tests/WebApi/ResponseSpec.hs b/tests/WebApi/ResponseSpec.hs new file mode 100644 --- /dev/null +++ b/tests/WebApi/ResponseSpec.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, OverloadedStrings, DataKinds, TypeOperators, TypeSynonymInstances, FlexibleInstances, DeriveGeneric #-} + +module WebApi.ResponseSpec (spec) where + +import GHC.Generics +import WebApi +import Test.Hspec +import qualified Network.Wai as Wai +import Test.Hspec.Wai (with, get, request, shouldRespondWith, matchStatus, (<:>), matchHeaders) +import Network.HTTP.Media.MediaType +import Network.HTTP.Types +import Data.Text +import Data.Aeson (ToJSON (..)) + +withApp :: SpecWith Wai.Application -> Spec +withApp = with (return respSpecApp) + +respSpecApp :: Wai.Application +respSpecApp = serverApp serverSettings RespSpecImpl + +data RespSpec +data RespSpecImpl = RespSpecImpl + +data Out = Out { out :: Text } + deriving (Show, Eq, Generic) +data HOut = HOut { hOut :: Text } + deriving (Show, Eq, Generic) +data COut = COut { cOut :: Text } + deriving (Show, Eq, Generic) +data Err = Err { err :: Text } + deriving (Show, Eq, Generic) + +instance ToJSON Err +instance ToJSON Out +instance ToHeader HOut + +instance ToParam COut 'Cookie + + +instance ParamErrToApiErr Err where + toApiErr = const (Err "fail") + +type ApiResp = Static "apiresp" +type ApiWithHeaders = Static "apih" +type ApiWithError = Static "apierror" +type TextCType = Static "text" +type LazyEncoding = Static "lazyencoding" + +instance WebApi RespSpec where + type Apis RespSpec = '[ Route '[GET] ApiResp + , Route '[GET] ApiWithHeaders + , Route '[GET] ApiWithError + , Route '[GET] TextCType + , Route '[GET] LazyEncoding] + +instance WebApiImplementation RespSpecImpl where + type ApiInterface RespSpecImpl = RespSpec + type HandlerM RespSpecImpl = IO + +instance ApiContract RespSpec GET ApiResp where + type ApiOut GET ApiResp = Out + +instance ApiContract RespSpec GET ApiWithHeaders where + type ApiOut GET ApiWithHeaders = Out + type HeaderOut GET ApiWithHeaders = HOut + type CookieOut GET ApiWithHeaders = COut + +instance ApiContract RespSpec GET ApiWithError where + type ApiOut GET ApiWithError = Out + type ApiErr GET ApiWithError = Err + +instance ApiContract RespSpec GET TextCType where + type ApiOut GET TextCType = Text + type ApiErr GET TextCType = Text + type ContentTypes GET TextCType = '[PlainText] + +instance ApiContract RespSpec GET LazyEncoding where + type ApiOut GET LazyEncoding = Out + type ContentTypes GET LazyEncoding = '[DummyCType, JSON] + +instance ApiHandler RespSpecImpl GET ApiResp where + handler _ _ = respond (Out "Done") + +instance ApiHandler RespSpecImpl GET ApiWithHeaders where + handler _ _ = respondWith status200 (Out "Done") (HOut "header") (COut "cookie") + +instance ApiHandler RespSpecImpl GET ApiWithError where + handler _ _ = do + -- raise should short circuit + _ <- (raise status500 (Err "fail") :: IO (Response GET ApiWithError)) + -- raiseWith' _ -- (ApiError status500 (Err "fail") Nothing Nothing) -- :: ApiError GET ApiWithError) + -- which means respond will never get called + respond (Out "Done") + +instance ApiHandler RespSpecImpl GET TextCType where + handler _ _ = respond "plaintext" + +instance ApiHandler RespSpecImpl GET LazyEncoding where + handler _ _ = respond (Out "Done") + + +data DummyCType +instance Accept DummyCType where + contentType _ = "application" // "dummy" + +instance Encode DummyCType a where + encode _ = error "Dummy content type not implemented" + +spec :: Spec +spec = withApp $ describe "WebApi response" $ do + context "Simple Response" $ do + it "should be 200 ok" $ do + get "apiresp" `shouldRespondWith` 200 + context "Response with response header and cookies" $ do + it "should be 200 ok" $ do + get "apih" `shouldRespondWith` "{\"out\":\"Done\"}" { matchHeaders = [ "hOut" <:> "header" + , "Set-Cookie" <:> "cOut=cookie" + , "Content-Type" <:> "application/json"] + , matchStatus = 200 } + context "Response with api error" $ do + it "should be 500 ok" $ do + get "apierror" `shouldRespondWith` 500 + context "Response with text as content type" $ do + it "should be 200 ok" $ do + get "text" `shouldRespondWith` "plaintext" { matchHeaders = ["Content-Type" <:> "text/plain;charset=utf-8"] + , matchStatus = 200 } + context "Response should get encoded lazily" $ do + it "should be 200 ok" $ do + let h = [(hAccept, "application/json")] + request methodGet "lazyencoding" h "" `shouldRespondWith` "{\"out\":\"Done\"}" { matchHeaders = ["Content-Type" <:> "application/json"] + , matchStatus = 200 } + diff --git a/tests/WebApi/RouteSpec.hs b/tests/WebApi/RouteSpec.hs new file mode 100644 --- /dev/null +++ b/tests/WebApi/RouteSpec.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, OverloadedStrings, DataKinds, TypeOperators, TypeSynonymInstances, FlexibleInstances #-} +module WebApi.RouteSpec (spec) where + +import WebApi +import Data.Text (Text) +import Test.Hspec +import Test.Hspec.Wai +import qualified Network.Wai as Wai + +withApp :: SpecWith Wai.Application -> Spec +withApp = with (return routingSpecApp) + +routingSpecApp :: Wai.Application +routingSpecApp = serverApp serverSettings RoutingSpecImpl + +data RoutingSpec +data RoutingSpecImpl = RoutingSpecImpl + +type StaticRoute1 = "this":/"is":/"a":/"static":/"route" +type StaticRoute2 = Static "static_route" + +type RouteWithParam = "param":/Int +type RouteWithParamAtBegin = Bool:/"param" +type RouteWithParams = Text:/"param1":/Int:/"param2" +type OverlappingRoute = "foo":/"param1":/Int:/"param2" + +instance WebApi RoutingSpec where + type Version RoutingSpec = MajorMinor '(0, 1) + type Apis RoutingSpec = '[ Route '[GET] StaticRoute1 + , Route '[GET] StaticRoute2 + , Route '[GET] RouteWithParam + , Route '[GET] RouteWithParamAtBegin + , Route '[GET] OverlappingRoute + , Route '[GET] RouteWithParams + ] + +instance ApiContract RoutingSpec GET StaticRoute1 where + type ApiOut GET StaticRoute1 = () + +instance ApiContract RoutingSpec GET StaticRoute2 where + type ApiOut GET StaticRoute2 = () + +instance ApiContract RoutingSpec GET RouteWithParam where + type ApiOut GET RouteWithParam = () + +instance ApiContract RoutingSpec GET RouteWithParamAtBegin where + type ApiOut GET RouteWithParamAtBegin = Text + +instance ApiContract RoutingSpec GET RouteWithParams where + type ApiOut GET RouteWithParams = Text + +instance ApiContract RoutingSpec GET OverlappingRoute where + type ApiOut GET OverlappingRoute = Text + +instance WebApiImplementation RoutingSpecImpl where + type HandlerM RoutingSpecImpl = IO + type ApiInterface RoutingSpecImpl = RoutingSpec + + +instance ApiHandler RoutingSpecImpl GET StaticRoute1 where + handler _ _ = respond () + +instance ApiHandler RoutingSpecImpl GET StaticRoute2 where + handler _ _ = respond () + +instance ApiHandler RoutingSpecImpl GET RouteWithParam where + handler _ _ = respond () + +instance ApiHandler RoutingSpecImpl GET RouteWithParamAtBegin where + handler _ _ = respond "RouteWithParamAtBegin" + +instance ApiHandler RoutingSpecImpl GET RouteWithParams where + handler _ _ = respond "RouteWithParams" + +instance ApiHandler RoutingSpecImpl GET OverlappingRoute where + handler _ _ = respond "OverlappingRoute" + + +spec :: Spec +spec = withApp $ describe "WebApi routing" $ do + context "static route with only one piece" $ do + it "should be 200 ok" $ do + get "static_route" `shouldRespondWith` 200 + context "static route with many pieces" $ do + it "should be 200 ok" $ do + get "this/is/a/static/route" `shouldRespondWith` 200 + context "route with param" $ do + it "should be 200 ok" $ do + get "param/5" `shouldRespondWith` 200 + context "route with param at beginning" $ do + it "should be 200 ok returning RouteWithParamAtBegin" $ do + get "True/param" `shouldRespondWith` "\"RouteWithParamAtBegin\"" { matchStatus = 200 } + context "route with multiple params" $ do + it "should be 200 ok returning RouteWithParams" $ do + get "bar/param1/5/param2" `shouldRespondWith` "\"RouteWithParams\"" { matchStatus = 200 } + context "overlapping route selected by order" $ do + it "should be 200 ok returning OverlappingRoute" $ do + get "foo/param1/5/param2" `shouldRespondWith` "\"OverlappingRoute\"" { matchStatus = 200 } + context "non existing route" $ do + it "should be 404 ok" $ do + get "foo/param1/5/param3" `shouldRespondWith` 404 + diff --git a/webapi.cabal b/webapi.cabal new file mode 100644 --- /dev/null +++ b/webapi.cabal @@ -0,0 +1,92 @@ +-- Initial webapi.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: webapi +version: 0.1.0.0 +synopsis: WAI based library for web api +description: WAI based library for web api +homepage: http://byteally.github.io/webapi/ +license: BSD3 +license-file: LICENSE +author: Magesh B +maintainer: magesh85@gmail.com +-- copyright: +-- extra-source-files: +cabal-version: >=1.10 +category: Web +build-type: Simple +source-repository head + type: git + location: https://github.com/byteally/webapi + + +library + exposed-modules: WebApi + , WebApi.Contract + , WebApi.Client + , WebApi.ContentTypes + , WebApi.Internal + , WebApi.Router + , WebApi.Server + , WebApi.Versioning + , WebApi.Param + , WebApi.Method + , WebApi.Mock + + -- other-modules: + -- 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 + , http-types == 0.8.* + , blaze-builder == 0.4.* + , bytestring-trie == 0.2.* + , bytestring-lexing == 0.5.* + , wai == 3.0.* + , wai-extra == 3.0.* + , 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.* + , QuickCheck == 2.8.* + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +test-suite unit-tests + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: WebApi.RequestSpec + , WebApi.ResponseSpec + , WebApi.RouteSpec + , WebApi.ClientSpec + , WebApi.MockSpec + + hs-source-dirs: tests + default-language: Haskell2010 + cpp-options: -DTEST + -- ghc-options: -Wall + build-depends: base >=4.7 && <4.9 + , wai == 3.0.* + , wai-extra == 3.0.* + , warp == 3.1.* + , http-types == 0.8.* + , hspec == 2.1.* + , hspec-wai == 0.6.* + , text == 1.2.* + , bytestring == 0.10.* + , time == 1.5.* + , vector == 0.10.* + , QuickCheck == 2.8.* + , webapi