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