mirror of
https://github.com/scarf-sh/tie.git
synced 2024-11-23 11:14:05 +03:00
764e907252
INLINABLE makes sure to include the applications unfolding into
the haskell interface (despite it's possibly large size). It allows
users to specialize the function at use-site:
```
import Scarf.Public.Api (application)
{-# SPECIALIZE application @AppIO #-}
```
407 lines
12 KiB
Plaintext
407 lines
12 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.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.Response.Test
|
|
import Test.Response.Test2
|
|
|
|
data Api m = Api {
|
|
-- | test
|
|
test ::
|
|
m TestResponse,
|
|
-- | test
|
|
test2 ::
|
|
m Test2Response
|
|
}
|
|
|
|
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
|
|
|
|
["test2"] ->
|
|
case Network.Wai.requestMethod request of
|
|
"GET" ->
|
|
run request (do
|
|
response <- Control.Monad.Catch.handle pure (test2 api)
|
|
Control.Monad.IO.Class.liftIO (respond $! (toResponse response))
|
|
)
|
|
x ->
|
|
unsupportedMethod x
|
|
|
|
_ ->
|
|
notFound request respond
|
|
where
|
|
unsupportedMethod _ =
|
|
respond (Network.Wai.responseBuilder (toEnum 405) [] mempty)
|
|
{-# INLINABLE application #-}
|
|
---------------------
|
|
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
|
|
|
|
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.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.Response
|
|
|
|
data TestResponse
|
|
= TestResponse200 Network.Wai.StreamingBody
|
|
|
|
instance Control.Exception.Exception TestResponse
|
|
|
|
instance ToResponse TestResponse where
|
|
toResponse (TestResponse200 x) =
|
|
Network.Wai.responseStream (toEnum 200) ([(Network.HTTP.Types.hContentType, "text/csv")]) x
|
|
|
|
instance Show TestResponse where
|
|
show _ = "TestResponse {}"
|
|
---------------------
|
|
Test/Response/Test2.hs
|
|
|
|
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
module Test.Response.Test2 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.Response
|
|
|
|
data Test2Response
|
|
= Test2Response200 Data.Aeson.Value
|
|
deriving (Show)
|
|
|
|
instance Control.Exception.Exception Test2Response
|
|
|
|
instance ToResponse Test2Response where
|
|
toResponse (Test2Response200 x) =
|
|
Network.Wai.responseBuilder (toEnum 200) ([(Network.HTTP.Types.hContentType, "application/json")]) (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x))
|
|
---------------------
|
|
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.Response.Test2 |