mirror of
https://github.com/scarf-sh/tie.git
synced 2024-11-30 01:33:37 +03:00
564 lines
17 KiB
Plaintext
564 lines
17 KiB
Plaintext
Test/Api.hs
|
|
|
|
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
module Test.Api where
|
|
|
|
import qualified Control.Applicative
|
|
import qualified Control.Exception
|
|
import qualified Control.Monad
|
|
import qualified Control.Monad.IO.Class
|
|
import qualified Data.Aeson
|
|
import qualified Data.Aeson.Encoding
|
|
import qualified Data.Aeson.Parser
|
|
import qualified Data.Aeson.Types
|
|
import qualified Data.Attoparsec.ByteString
|
|
import qualified Data.List
|
|
import qualified Data.List.NonEmpty
|
|
import qualified Data.Map
|
|
import qualified Data.Maybe
|
|
import qualified Data.Text
|
|
import qualified Data.Time
|
|
import qualified Data.Text.Encoding
|
|
import qualified GHC.Float
|
|
import qualified GHC.Int
|
|
import qualified GHC.Types
|
|
import qualified Network.HTTP.Types
|
|
import qualified Network.Wai
|
|
import qualified Web.HttpApiData
|
|
|
|
import Test.Request
|
|
import Test.Response
|
|
|
|
|
|
|
|
import Test.Schemas.Test
|
|
|
|
import Test.Response.Test
|
|
|
|
data Api m = Api {
|
|
-- | test
|
|
test ::
|
|
m TestResponse
|
|
}
|
|
|
|
application :: (Control.Monad.IO.Class.MonadIO m) => (forall a . Network.Wai.Request -> m a -> IO a) -> Api m -> Network.Wai.Application -> Network.Wai.Application
|
|
application run api notFound request respond =
|
|
case Network.Wai.pathInfo request of
|
|
["test"] ->
|
|
case Network.Wai.requestMethod request of
|
|
"GET" ->
|
|
run request (do
|
|
response <- test api
|
|
Control.Monad.IO.Class.liftIO (respond $! (toResponse response))
|
|
)
|
|
x ->
|
|
unsupportedMethod x
|
|
|
|
_ ->
|
|
notFound request respond
|
|
where
|
|
unsupportedMethod _ =
|
|
respond (Network.Wai.responseBuilder Network.HTTP.Types.status405 [] mempty)
|
|
{-# INLINABLE application #-}
|
|
---------------------
|
|
Test/Request.hs
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Test.Request
|
|
( -- * Parameters
|
|
Style (..),
|
|
pathVariable,
|
|
requiredQueryParameter,
|
|
requiredQueryParameters,
|
|
optionalQueryParameter,
|
|
optionalQueryParameters,
|
|
requiredHeader,
|
|
optionalHeader,
|
|
|
|
-- * Request body
|
|
parseRequestBody,
|
|
jsonBodyParser,
|
|
formBodyParser,
|
|
)
|
|
where
|
|
|
|
import Data.Aeson (FromJSON, parseJSON)
|
|
import qualified Data.Aeson.Parser
|
|
import qualified Data.Aeson.Types
|
|
import Data.Attoparsec.ByteString (eitherResult, parseWith)
|
|
import Data.ByteString (ByteString)
|
|
import qualified Data.ByteString as ByteString
|
|
import qualified Data.ByteString.Lazy as LBS
|
|
import Data.Coerce (coerce)
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
import qualified Data.List as List
|
|
import qualified Data.List.NonEmpty as NonEmpty
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Text
|
|
import qualified Network.HTTP.Media
|
|
import Network.HTTP.Types (HeaderName, hContentType)
|
|
import qualified Network.Wai as Wai
|
|
import System.IO.Unsafe (unsafeInterleaveIO)
|
|
import Web.FormUrlEncoded
|
|
( FromForm,
|
|
parseAll,
|
|
urlDecodeAsForm,
|
|
urlDecodeForm,
|
|
)
|
|
import Web.HttpApiData
|
|
( FromHttpApiData,
|
|
parseHeader,
|
|
parseQueryParam,
|
|
parseUrlPiece,
|
|
parseUrlPieces,
|
|
)
|
|
|
|
pathVariable ::
|
|
FromHttpApiData a =>
|
|
-- | Path variable value
|
|
Text ->
|
|
(a -> Wai.Application) ->
|
|
Wai.Application
|
|
pathVariable value withVariable = \request respond ->
|
|
case parseUrlPiece value of
|
|
Left _err ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Right x ->
|
|
withVariable x request respond
|
|
{-# INLINEABLE pathVariable #-}
|
|
|
|
data Style
|
|
= FormStyle
|
|
| CommaDelimitedStyle
|
|
| SpaceDelimitedStyle
|
|
| PipeDelimitedStyle
|
|
|
|
newtype CommaDelimitedValue a = CommaDelimitedValue {unCommaDelimitedValue :: [a]}
|
|
|
|
instance FromHttpApiData a => FromHttpApiData (CommaDelimitedValue a) where
|
|
parseUrlPiece input = do
|
|
xs <- parseUrlPieces (Text.splitOn "," input)
|
|
pure (CommaDelimitedValue xs)
|
|
|
|
newtype SpaceDelimitedValue a = SpaceDelimitedValue {unSpaceDelimitedValue :: [a]}
|
|
|
|
instance FromHttpApiData a => FromHttpApiData (SpaceDelimitedValue a) where
|
|
parseUrlPiece input = do
|
|
xs <- parseUrlPieces (Text.splitOn " " input)
|
|
pure (SpaceDelimitedValue xs)
|
|
|
|
newtype PipeDelimitedValue a = PipeDelimitedValue {unPipeDelimitedValue :: [a]}
|
|
|
|
instance FromHttpApiData a => FromHttpApiData (PipeDelimitedValue a) where
|
|
parseUrlPiece input = do
|
|
xs <- parseUrlPieces (Text.splitOn "|" input)
|
|
pure (PipeDelimitedValue xs)
|
|
|
|
requiredQueryParameters ::
|
|
FromHttpApiData a =>
|
|
Style ->
|
|
ByteString ->
|
|
(NonEmpty.NonEmpty a -> Wai.Application) ->
|
|
Wai.Application
|
|
requiredQueryParameters style name withParam =
|
|
case style of
|
|
FormStyle -> \request respond ->
|
|
case urlDecodeForm (LBS.fromStrict (ByteString.drop 1 (Wai.rawQueryString request))) of
|
|
Left error ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Right form ->
|
|
case parseAll (Text.decodeUtf8 name) form of
|
|
Left _ ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Right [] ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Right (x : xs) ->
|
|
withParam (x NonEmpty.:| xs) request respond
|
|
SpaceDelimitedStyle ->
|
|
requiredQueryParameter
|
|
name
|
|
( \xs -> \request respond ->
|
|
case NonEmpty.nonEmpty (unSpaceDelimitedValue xs) of
|
|
Nothing ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Just xs ->
|
|
withParam xs request respond
|
|
)
|
|
PipeDelimitedStyle ->
|
|
requiredQueryParameter
|
|
name
|
|
( \xs -> \request respond ->
|
|
case NonEmpty.nonEmpty (unPipeDelimitedValue xs) of
|
|
Nothing ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Just xs ->
|
|
withParam xs request respond
|
|
)
|
|
CommaDelimitedStyle ->
|
|
requiredQueryParameter
|
|
name
|
|
( \xs -> \request respond ->
|
|
case NonEmpty.nonEmpty (unCommaDelimitedValue xs) of
|
|
Nothing ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Just xs ->
|
|
withParam xs request respond
|
|
)
|
|
|
|
optionalQueryParameters ::
|
|
FromHttpApiData a =>
|
|
Style ->
|
|
ByteString ->
|
|
(Maybe (NonEmpty.NonEmpty a) -> Wai.Application) ->
|
|
Wai.Application
|
|
optionalQueryParameters style name withParam =
|
|
case style of
|
|
FormStyle -> \request respond ->
|
|
case urlDecodeForm (LBS.fromStrict (ByteString.drop 1 (Wai.rawQueryString request))) of
|
|
Left error ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Right form ->
|
|
case parseAll (Text.decodeUtf8 name) form of
|
|
Left _ ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Right [] ->
|
|
withParam Nothing request respond
|
|
Right (x : xs) ->
|
|
withParam (Just (x NonEmpty.:| xs)) request respond
|
|
SpaceDelimitedStyle ->
|
|
optionalQueryParameter
|
|
name
|
|
False
|
|
( \xs ->
|
|
withParam (xs >>= NonEmpty.nonEmpty . unSpaceDelimitedValue)
|
|
)
|
|
PipeDelimitedStyle ->
|
|
optionalQueryParameter
|
|
name
|
|
False
|
|
( \xs ->
|
|
withParam (xs >>= NonEmpty.nonEmpty . unPipeDelimitedValue)
|
|
)
|
|
CommaDelimitedStyle ->
|
|
optionalQueryParameter
|
|
name
|
|
False
|
|
( \xs ->
|
|
withParam (xs >>= NonEmpty.nonEmpty . unCommaDelimitedValue)
|
|
)
|
|
|
|
requiredQueryParameter ::
|
|
FromHttpApiData a =>
|
|
ByteString ->
|
|
(a -> Wai.Application) ->
|
|
Wai.Application
|
|
requiredQueryParameter name withParam = \request respond ->
|
|
case List.lookup name (Wai.queryString request) of
|
|
Nothing ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Just Nothing ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Just (Just value) ->
|
|
case parseQueryParam (Text.decodeUtf8 value) of
|
|
Left _err ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Right x ->
|
|
withParam x request respond
|
|
{-# INLINEABLE requiredQueryParameter #-}
|
|
|
|
optionalQueryParameter ::
|
|
FromHttpApiData a =>
|
|
ByteString ->
|
|
-- | Allow empty, e.g. "x="
|
|
Bool ->
|
|
(Maybe a -> Wai.Application) ->
|
|
Wai.Application
|
|
optionalQueryParameter name allowEmpty withParam = \request respond ->
|
|
case List.lookup name (Wai.queryString request) of
|
|
Nothing ->
|
|
withParam Nothing request respond
|
|
Just Nothing
|
|
| allowEmpty ->
|
|
withParam Nothing request respond
|
|
| otherwise ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Just (Just value) ->
|
|
case parseQueryParam (Text.decodeUtf8 value) of
|
|
Left _err ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Right x ->
|
|
withParam (Just x) request respond
|
|
{-# INLINEABLE optionalQueryParameter #-}
|
|
|
|
optionalHeader ::
|
|
FromHttpApiData a =>
|
|
HeaderName ->
|
|
(Maybe a -> Wai.Application) ->
|
|
Wai.Application
|
|
optionalHeader name withHeader = \request respond ->
|
|
case List.lookup name (Wai.requestHeaders request) of
|
|
Nothing ->
|
|
withHeader Nothing request respond
|
|
Just value ->
|
|
case parseHeader value of
|
|
Left _err ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Right x ->
|
|
withHeader (Just x) request respond
|
|
{-# INLINEABLE optionalHeader #-}
|
|
|
|
requiredHeader ::
|
|
FromHttpApiData a =>
|
|
HeaderName ->
|
|
(a -> Wai.Application) ->
|
|
Wai.Application
|
|
requiredHeader name withHeader = \request respond ->
|
|
case List.lookup name (Wai.requestHeaders request) of
|
|
Nothing ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Just value ->
|
|
case parseHeader value of
|
|
Left _err ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Right x ->
|
|
withHeader x request respond
|
|
{-# INLINEABLE requiredHeader #-}
|
|
|
|
data BodyParser a
|
|
= BodyParser
|
|
Network.HTTP.Media.MediaType
|
|
((a -> Wai.Application) -> Wai.Application)
|
|
|
|
jsonBodyParser :: FromJSON a => BodyParser a
|
|
jsonBodyParser = BodyParser "application/json" parseRequestBodyJSON
|
|
{-# INLINE jsonBodyParser #-}
|
|
|
|
formBodyParser :: FromForm a => BodyParser a
|
|
formBodyParser = BodyParser "application/xxx-form-urlencoded" parseRequestBodyForm
|
|
{-# INLINE formBodyParser #-}
|
|
|
|
parseRequestBody :: [BodyParser a] -> (a -> Wai.Application) -> Wai.Application
|
|
parseRequestBody parsers withBody = \request respond -> do
|
|
let contentType =
|
|
fromMaybe
|
|
"application/octet-stream"
|
|
(List.lookup hContentType (Wai.requestHeaders request))
|
|
|
|
bodyParser =
|
|
Network.HTTP.Media.mapAccept
|
|
[(mediaType, parser) | BodyParser mediaType parser <- parsers]
|
|
contentType
|
|
|
|
case bodyParser of
|
|
Just parseBody ->
|
|
parseBody withBody request respond
|
|
Nothing ->
|
|
respond (Wai.responseBuilder (toEnum 415) [] mempty)
|
|
{-# INLINE parseRequestBody #-}
|
|
|
|
parseRequestBodyJSON :: FromJSON a => (a -> Wai.Application) -> Wai.Application
|
|
parseRequestBodyJSON withBody = \request respond -> do
|
|
result <- parseWith (Wai.getRequestBodyChunk request) Data.Aeson.Parser.json' mempty
|
|
case eitherResult result of
|
|
Left _err ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Right value ->
|
|
case Data.Aeson.Types.parseEither Data.Aeson.parseJSON value of
|
|
Left _err ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Right body ->
|
|
withBody body request respond
|
|
{-# INLINEABLE parseRequestBodyJSON #-}
|
|
|
|
parseRequestBodyForm :: FromForm a => (a -> Wai.Application) -> Wai.Application
|
|
parseRequestBodyForm withBody = \request respond -> do
|
|
-- Reads the body using lazy IO. Not great but it gets us
|
|
-- going and is pretty local.
|
|
let getBodyBytes :: IO [ByteString]
|
|
getBodyBytes = do
|
|
chunk <- Wai.getRequestBodyChunk request
|
|
case chunk of
|
|
"" -> pure []
|
|
_ -> do
|
|
rest <- unsafeInterleaveIO getBodyBytes
|
|
pure (chunk : rest)
|
|
|
|
bytes <- getBodyBytes
|
|
case urlDecodeAsForm (LBS.fromChunks bytes) of
|
|
Left _err ->
|
|
respond (Wai.responseBuilder (toEnum 400) [] mempty)
|
|
Right form ->
|
|
withBody form request respond
|
|
{-# INLINEABLE parseRequestBodyForm #-}
|
|
|
|
---------------------
|
|
Test/Response.hs
|
|
|
|
module Test.Response
|
|
( ToResponse (..),
|
|
)
|
|
where
|
|
|
|
import qualified Network.Wai
|
|
|
|
class ToResponse a where
|
|
toResponse :: a -> Network.Wai.Response
|
|
|
|
---------------------
|
|
Test/Response/Test.hs
|
|
|
|
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
module Test.Response.Test where
|
|
|
|
import qualified Control.Applicative
|
|
import qualified Control.Exception
|
|
import qualified Control.Monad
|
|
import qualified Control.Monad.IO.Class
|
|
import qualified Data.Aeson
|
|
import qualified Data.Aeson.Encoding
|
|
import qualified Data.Aeson.Parser
|
|
import qualified Data.Aeson.Types
|
|
import qualified Data.Attoparsec.ByteString
|
|
import qualified Data.List
|
|
import qualified Data.List.NonEmpty
|
|
import qualified Data.Map
|
|
import qualified Data.Maybe
|
|
import qualified Data.Text
|
|
import qualified Data.Time
|
|
import qualified Data.Text.Encoding
|
|
import qualified GHC.Float
|
|
import qualified GHC.Int
|
|
import qualified GHC.Types
|
|
import qualified Network.HTTP.Types
|
|
import qualified Network.Wai
|
|
import qualified Web.HttpApiData
|
|
|
|
import Test.Schemas.Test
|
|
|
|
import Test.Response
|
|
|
|
data TestResponse
|
|
= TestResponse200 Test
|
|
deriving (Show)
|
|
|
|
instance ToResponse TestResponse where
|
|
toResponse (TestResponse200 x) =
|
|
Network.Wai.responseBuilder Network.HTTP.Types.status200 ([(Network.HTTP.Types.hContentType, "application/json")]) (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x))
|
|
---------------------
|
|
Test/Schemas/Test.hs
|
|
|
|
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
module Test.Schemas.Test where
|
|
|
|
import qualified Control.Applicative
|
|
import qualified Control.Exception
|
|
import qualified Control.Monad
|
|
import qualified Control.Monad.IO.Class
|
|
import qualified Data.Aeson
|
|
import qualified Data.Aeson.Encoding
|
|
import qualified Data.Aeson.Parser
|
|
import qualified Data.Aeson.Types
|
|
import qualified Data.Attoparsec.ByteString
|
|
import qualified Data.List
|
|
import qualified Data.List.NonEmpty
|
|
import qualified Data.Map
|
|
import qualified Data.Maybe
|
|
import qualified Data.Text
|
|
import qualified Data.Time
|
|
import qualified Data.Text.Encoding
|
|
import qualified GHC.Float
|
|
import qualified GHC.Int
|
|
import qualified GHC.Types
|
|
import qualified Network.HTTP.Types
|
|
import qualified Network.Wai
|
|
import qualified Web.HttpApiData
|
|
|
|
|
|
|
|
|
|
|
|
data Test = Test
|
|
{
|
|
a :: (Data.Maybe.Maybe (GHC.Int.Int32)),
|
|
b :: (Data.Maybe.Maybe (GHC.Int.Int64)),
|
|
c :: (Data.Maybe.Maybe (GHC.Float.Double)),
|
|
d :: (Data.Maybe.Maybe (GHC.Float.Float)),
|
|
e :: (Data.Maybe.Maybe (GHC.Float.Double)),
|
|
f :: (Data.Maybe.Maybe (GHC.Int.Int))
|
|
}
|
|
deriving (Show)
|
|
|
|
instance Data.Aeson.ToJSON Test where
|
|
toJSON Test {..} = Data.Aeson.object
|
|
([
|
|
]
|
|
++ [ "a" Data.Aeson..= a | Just a <- [a] ]
|
|
++ [ "b" Data.Aeson..= b | Just b <- [b] ]
|
|
++ [ "c" Data.Aeson..= c | Just c <- [c] ]
|
|
++ [ "d" Data.Aeson..= d | Just d <- [d] ]
|
|
++ [ "e" Data.Aeson..= e | Just e <- [e] ]
|
|
++ [ "f" Data.Aeson..= f | Just f <- [f] ])
|
|
|
|
toEncoding Test {..} = Data.Aeson.Encoding.pairs
|
|
( maybe mempty (Data.Aeson.Encoding.pair "a" . Data.Aeson.toEncoding) a <>
|
|
maybe mempty (Data.Aeson.Encoding.pair "b" . Data.Aeson.toEncoding) b <>
|
|
maybe mempty (Data.Aeson.Encoding.pair "c" . Data.Aeson.toEncoding) c <>
|
|
maybe mempty (Data.Aeson.Encoding.pair "d" . Data.Aeson.toEncoding) d <>
|
|
maybe mempty (Data.Aeson.Encoding.pair "e" . Data.Aeson.toEncoding) e <>
|
|
maybe mempty (Data.Aeson.Encoding.pair "f" . Data.Aeson.toEncoding) f
|
|
)
|
|
|
|
instance Data.Aeson.FromJSON Test where
|
|
parseJSON = Data.Aeson.withObject "Test" $ \o ->
|
|
Test
|
|
<$> o Data.Aeson..:? "a"
|
|
<*> o Data.Aeson..:? "b"
|
|
<*> o Data.Aeson..:? "c"
|
|
<*> o Data.Aeson..:? "d"
|
|
<*> o Data.Aeson..:? "e"
|
|
<*> o Data.Aeson..:? "f"
|
|
---------------------
|
|
test.cabal
|
|
|
|
cabal-version: 3.0
|
|
name: test
|
|
version: 0.1.0.0
|
|
library
|
|
build-depends:
|
|
, aeson
|
|
, attoparsec
|
|
, base
|
|
, bytestring
|
|
, containers
|
|
, ghc-prim
|
|
, http-api-data
|
|
, http-media
|
|
, http-types
|
|
, text
|
|
, time
|
|
, unordered-containers
|
|
, wai
|
|
exposed-modules:
|
|
Test.Api
|
|
Test.Request
|
|
Test.Response
|
|
Test.Response.Test
|
|
Test.Schemas.Test |