mirror of
https://github.com/scarf-sh/tie.git
synced 2024-11-23 11:14:05 +03:00
443 lines
13 KiB
Plaintext
443 lines
13 KiB
Plaintext
Test/Api.hs
|
|
|
|
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
module Test.Api where
|
|
|
|
import qualified Control.Applicative
|
|
import qualified Control.Exception
|
|
import qualified Control.Monad
|
|
import qualified Control.Monad.Catch
|
|
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.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.Catch.MonadCatch m, 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 <- Control.Monad.Catch.handle pure (test api)
|
|
Control.Monad.IO.Class.liftIO (respond $! (toResponse response))
|
|
)
|
|
x ->
|
|
unsupportedMethod x
|
|
|
|
_ ->
|
|
notFound request respond
|
|
where
|
|
unsupportedMethod _ =
|
|
respond (Network.Wai.responseBuilder (toEnum 405) [] mempty)
|
|
---------------------
|
|
Test/Request.hs
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Test.Request
|
|
( pathVariable,
|
|
requiredQueryParameter,
|
|
optionalQueryParameter,
|
|
requiredHeader,
|
|
optionalHeader,
|
|
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 qualified Data.List as List
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Text
|
|
import Network.HTTP.Types (HeaderName, hContentType)
|
|
import qualified Network.Wai as Wai
|
|
import System.IO.Unsafe (unsafeInterleaveIO)
|
|
import Web.FormUrlEncoded (FromForm, urlDecodeAsForm)
|
|
import Web.HttpApiData
|
|
( FromHttpApiData,
|
|
parseHeader,
|
|
parseQueryParam,
|
|
parseUrlPiece,
|
|
)
|
|
|
|
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 #-}
|
|
|
|
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 ByteString ((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
|
|
"text/html"
|
|
(List.lookup hContentType (Wai.requestHeaders request))
|
|
|
|
bodyParser =
|
|
List.find
|
|
(\(BodyParser expectedContentType _) -> expectedContentType == contentType)
|
|
parsers
|
|
|
|
case bodyParser of
|
|
Just (BodyParser _ 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
|
|
|
|
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
module Test.Response where
|
|
|
|
import qualified Control.Applicative
|
|
import qualified Control.Exception
|
|
import qualified Control.Monad
|
|
import qualified Control.Monad.Catch
|
|
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.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
|
|
|
|
class ToResponse a where
|
|
toResponse :: a -> Network.Wai.Response
|
|
---------------------
|
|
Test/Response/Test.hs
|
|
|
|
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# 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.Catch
|
|
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.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 Control.Exception.Exception TestResponse
|
|
|
|
instance ToResponse TestResponse where
|
|
toResponse (TestResponse200 x) =
|
|
Network.Wai.responseBuilder (toEnum 200) ([(Network.HTTP.Types.hContentType, "application/json")]) (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x))
|
|
---------------------
|
|
Test/Schemas/Test.hs
|
|
|
|
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# 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.Catch
|
|
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.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,
|
|
"b" Data.Aeson..= b,
|
|
"c" Data.Aeson..= c,
|
|
"d" Data.Aeson..= d,
|
|
"e" Data.Aeson..= e,
|
|
"f" Data.Aeson..= f
|
|
]
|
|
|
|
toEncoding Test {..} = Data.Aeson.Encoding.pairs
|
|
( Data.Aeson.Encoding.pair "a" (Data.Aeson.toEncoding a) <>
|
|
Data.Aeson.Encoding.pair "b" (Data.Aeson.toEncoding b) <>
|
|
Data.Aeson.Encoding.pair "c" (Data.Aeson.toEncoding c) <>
|
|
Data.Aeson.Encoding.pair "d" (Data.Aeson.toEncoding d) <>
|
|
Data.Aeson.Encoding.pair "e" (Data.Aeson.toEncoding e) <>
|
|
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
|
|
, exceptions
|
|
, ghc-prim
|
|
, http-api-data
|
|
, http-types
|
|
, text
|
|
, time
|
|
, wai
|
|
exposed-modules:
|
|
Test.Api
|
|
Test.Request
|
|
Test.Response
|
|
Test.Response.Test
|
|
Test.Schemas.Test |