diff --git a/CHANGELOG.md b/CHANGELOG.md deleted file mode 100644 --- a/CHANGELOG.md +++ /dev/null @@ -1,11 +0,0 @@ -# Changelog for `combo` - -All notable changes to this project will be documented in this file. - -The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), -and this project adheres to the -[Haskell Package Versioning Policy](https://pvp.haskell.org/). - -## Unreleased - -## 0.1.0.0 - YYYY-MM-DD diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,381 +1,19 @@ -# Mig - library to write composable and lightweight servers - -The Mig is a library to build lightweight composable servers. -There are only couple of combinators and Monoid instance. -With it we can build type-safe servers from small parts. - -The main strength is ability to build servers from parts -and flexible DSL which features only small amount of functions. - -I like [scotty](https://hackage.haskell.org/package/scotty) for being very -simple and [servant](https://hackage.haskell.org/package/servant-server) for being composable, type-safe -and how functions are used as handlers which provides decoupling of Web-handlers -from application logic. -But sometimes scotty feels too imperative and lacks servant's composability. -And servant with type-level magic and huge errors can feel to complicated. -So I wanted to create something in the middle. Something composable and simple -at the same time. -The name `mig` (pronounced as meeg) is a russian word for "instant moment". - -## How to install - -We can install from [hackage](https://hackage.haskell.org/package/mig) to use with cabal or use this snippet -to depend on latest source in stack. Put it in `stack.yaml` file: - -```yaml -extra-deps: -- git: https://github.com/anton-k/mig - commit: be9269b83bb944d8dede4d36a51fb1aa6fb26516 -``` - -## Quick start guide - -Let's create something cool with the library. - -### Hello world server - -As a starting point let's look at hello-world server: - -```haskell -module Main where - -import Mig -import Data.Text (Text) - -main :: IO () -main = runServer 8080 server - -server :: Server IO -server = - "api" /. "v1" /. "hello" /. hello - -hello :: Get Json IO Text -hello = pure "Hello World" -``` - -The main type is `Server`. We can think about it as function from request to response -which sometimes can produce no output: - -```haskell -newtype Server m = Server (Req -> m (Maybe Resp)) -``` - -It is parametrised by the underlying monad. -So far library supports only three types of monads: -* `IO`-monad -* `ReaderT` over `IO` with possible newtype-wrappers. -* `ReaderT env (ExceptT err) IO` - reader with `ExceptT` over `IO`. - -Also we can create our custom monads as newtype wrappers over those monads -and be able to use it with library. To do that we need to derive `HasServer` instance. -It can be done with deriving strategies (see `examples/Counter.hs`). - -To run server we can use functions: - -```haskell --- | Runs server on port -runServer :: Int -> Server IO -> IO () -runServer port server = ... - --- | Convert to WAI application -toApplication :: ServerConfig -> Server IO -> Wai.Application -``` - -The HTTP-method is specified with newtype wrapper `Get`: - -```haskell -newtype Get ty m a = Get (m a) -``` - -It has phantom-argument for type of the response. In this example we return `Text` -as response body with 200 ok status. It seems that we need two typed to specify result `ty` and `a`. - -Beside `Text` we also can return `Json`, `Html`, raw `ByteString` as response. But we have -several ways to render handler result to response body. For example we can convert Int as Text -and also as JSON. To distinguish between them we use phantom type for the type of response body. - -### Using monoid for route branches - -The server has Monoid instance. With it we can build -servers from several routes: - -```haskell -server :: Server IO -server = - "api" /. "v1" /. - mconcat - [ "hello" /. handle "hello" - , "bye" /. handle "bye" - ] - -handle :: Text -> Get Text IO Text -handle prefix = Get $ pure $ prefix <> " world" -``` - -Note how branching by path is done with `Monoid` method `mconcat`. -We use `Get` inside the function `handle`. - -### Query parameters - -We can turn a "world" into parameter: - -```haskell -server :: Server IO -server = - "api" /. "v1" /. - mconcat - [ "hello" /. handle "hello" - , "bye" /. handle "bye" - ] - -handle :: Text -> Query "who" Text -> Get Text IO Text -handle prefix (Query name) = Get $ pure $ prefix <> " " <> name -``` - -By changing the signature of the function we have requested required query -parameter called `"who"`. We use type-level string literals to encode name of the parameter. -It is provided with url: `api/v1/hello?who=john`. - -If we use `Optional` instead of `Query` parameter becomes optional and value -is wrapped in `Maybe`. - -### Capture URI-parts - -In the example we can note the duplication of path name `"hello/bye"` and that we -pass the same constants to our function `handle`. -We can capture that part of URI as argument with `Capture` argument: - -```haskell -server :: Server IO -server = - "api" /. "v1" /. handle - -handle :: Capture Text -> Query "who" Text -> Get Text IO Text -handle (Capture prefix) (Query name) = Get $ pure $ prefix <> " " <> name -``` - -This example is equivalent to previous one. Only we capture part of -the URI as text and use it in the message. Also with capture we can append all sorts of prefixes. - -### Route arguments - -The cool part of it is that handle function can have any amount of input arguments -wrapped in special newtypes and it will be decoded to proper server route. - -We have newtypes for: - -* `Query "name" type` - required query parameter (`FromHttpApiData`) -* `Optional "name" type` - optional query parameter (`FromHttpApiData`) -* `Capture type` - capture part of the URI between slashes `/`. (`FromHttpApiData`) -* `Body type` - input JSON body (`FromJSON`) -* `RawBody` - input body as raw lazy bytestring (is `ByteString`) -* `FormBody` - input URL-encoded form (it often comes from HTML-forms) (`FromForm`) -* `Header "name" ty` - access header by name (`FromHttpApiData`) -* `PathInfo` - access path info relative to the server (is `[Text]`) - -Class at in the parens is which class is used for convertion. -Often we can derive the instance of that class with newtype-deriving or with Generic-deriving. -We can change the number of arguments because the function `(/.)` is overloaded -by second argument and it can accept anything convertible to `Server` or an -instance of the class `ToServer`. - -### Route outputs - -Also `newtype` wrappers can control behavior of the output. -We already saw `Get`-wrapper. It encodes Http-method. Also we can use -`Post`, `Put`, `Delete`, etc. - -We have output wrappers for: - -* http-methods: `Get`, `Post`, `Put`, `Delete`, etc. -* append headers: `AddHeaders a` -* change response status: `SetStatus a` -* return error: `Either (Error ty) a` - -We can nest wrappers to apply several behaviors. -For example we can update header, possible return error and return Post-method: - -```haskell -handle :: Query "foo" Int -> Post Json IO (Either (Error Text) (AddHeaders FooResponse)) -``` - -Here `FooResponse` should have `ToJSON` instance. Possible implementation: - -```haskell -data FooResponse = FooResponse - { code :: Int - , message :: Text - } - deriving (Generic, ToJSON) - -handle (Query code) = Post $ do - message <- readMessageBycode code - pure $ Right $ AddHeaders headers $ FooResponse code message - where - headers = ["Trace-Code", Nothing] -``` - -### Errors - -The errors can be returned from route with `(Either (Error ty))` output wrapper. -We signify to the user that our route returns errors. -The `Error` type contains status and details for the error: - -```haskell -data Error a = Error - { status :: Status - -- error status - , body :: a - -- message or error details - } -``` - -Note that `ToServer` instance takes care about proper conversion of the error -value to the same response type as the main happy route branch. - -## Specific servers - -If we write server of specific type. For example if we write JSON API with IO-based server -we can import specific route newtype-wrappers: - -```haskell -import Mig.Json.IO -``` - -It will simplify the signatures of the functions: - -```haskell -handle :: Body FooRequest -> Post FooResponse -handle (Body req) = Post $ do - resp <- readResp req - pure resp -``` - -As `Post` becomes specified to `Json` and `IO`: - -```haskell -newtype Post a = Post (IO a) -``` - -There are similar modules for `Html`. If your server is not `IO`-based -Use import of `Mig.Json`. - -## Reader based servers - -There is very popular pattern of writing servers with monad `ReaderT ServerContext IO`. -The server context can contain shared context of the server and mutable stated wrapped in `TVar`'s -or IO-based interfaces. We can access the context inside handler and shared for all routes. - -The `mig` has support for Reader-pattern like monads. -Let's build a simple counter server as example. User can see current value with `get` and add -to the internal counter with method `put`. - -Let's define application monad first - -```haskell -newtype App a = App (ReaderT Env IO a) - deriving newtype (Functor, Applicative, Monad, MonadReader Env, MonadIO, HasServer) - -data Env = Env - { current :: IORef Int - } -``` - -Note the deriving of `HasServer`. It is defined for reader over IO. -With it we can convert the `Server App` to `IO`-based server: - -```haskell -renderServer :: Server App -> Env -> IO (Server IO) -``` - -So we can define our handlers with App-monad and render to `IO` to convert it to WAI-application -and run as server. - -Let's define the server: - -```haskell -counter :: Server App -counter = do - "counter" /. "api" /. - mconcat - [ "get" /. handleGet - , "put" /. handlePut - ] - -handleGet :: Get Text App Int -handelGet = -- todo - -handlePut :: Capture Int -> Post Text App () -handlePut (Capture val) = -- todo -``` - -We can render the server and run it: - -```haskell -main :: IO () -main = do - env <- initEnv - server <- renderServer counter env - runServer 8085 server -``` - -Let's define the missing parts: - -```haskell -initEnv :: IO Env -initEnv = Env <$> newIORef 0 - -handleGet :: Get Text App Int -handleGet = Get $ do - ref <- asks (.current) - liftIO $ readIORef ref - -handlePut :: Capture Int -> Get Json App () -handlePut (Capture val) = Get $ do - ref <- asks (.current) - liftIO $ atomicModifyIORef' ref (\cur -> (cur + val, ())) -``` - -So we have studied how we can use custom Reader-based monads. -The trick is to derive `HasServer` on newtype wrapper and -use method `renderServer` to convert to `IO`-based server. +## Core mig library -PS: this is an open question. Is it possible to create a function: +Core mig library provides tools to build HTTP servers and APIs. +With this library we can build lightweight and composable servers. +It is sort of servant for Simple/Boring haskell. -```haskell -hoistServer :: (Monad m, Monad n) => (forall a . m a -> n a) -> Server m -> Server n -``` +We build servers with type-safe DSL and we can convert a server +to low-level server representation and to OpenApi schema. -As it is defined in the servant. With it we would be able to use any monad. -But I'm not sure how to achieve that. Help is appreciated, as it will make library even better! -I guess it can be done with `MonadBaseControl` and if we turn the WAI function to: +Servers can be rendered to low level representation of `ServerFun`: ```haskell -toApplication :: MonadBaseControl m => Server m -> m Wai.Application +type ServerFun m = Request -> m (Maybe Response) ``` -## Conclusion - -We have walked through the whole library. As a summary of it's functions: we can - -* compose servers with path operator `(/.)` and monoid instance. -* define handlers as functions with various input and output newtype-wrappers - -I hope that you like the concept and will enjoy the library. See the directory [`examples`](https://github.com/anton-k/mig/tree/main/examples) for more examples. -We can run the examples with stack by running: - -``` -> make run -``` -in this repo. Change the Makefile to try different examples. - - -Also there are repos that show how to use library with most common -Haskell patterns to create web-servers: - -* [Handle pattern](https://github.com/anton-k/handle-pattern-mig-app) -* [Reader patten](https://github.com/anton-k/reader-pattern-mig-app) - -This is a very first sketch of the library. I guess it can become even better. -The feedback is appreciated. +There is library `mig-wai` that can convert `ServerFun` to `Wai.Application` +and we can run it with `warp` (see library `mig-server` for that). +The HTTP Api can be converted to `OpenApi` value defined in `openapi3` library. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/mig.cabal b/mig.cabal --- a/mig.cabal +++ b/mig.cabal @@ -4,72 +4,32 @@ -- -- see: https://github.com/sol/hpack -name: mig -version: 0.1.0.3 -synopsis: Build lightweight and composable servers -description: With library mig we can build lightweight and composable servers. - There are only couple of combinators to assemble servers from parts. - It supports generic handler functions as servant does. But strives to use more - simple model for API. It does not go to describing Server API at type level which - leads to simpler error messages. - . - The main features are: - . - * lightweight library - . - * expressive DSL to compose servers - . - * type-safe handlers - . - * handlers are encoded with generic haskell functions - . - * built on top of WAI and warp server libraries. - . - Example of hello world server: - . - > import Mig.Json.IO - > - > -- | We can render the server and run it on port 8085. - > -- It uses wai and warp. - > main :: IO () - > main = runServer 8085 server - > - > -- | Init simple hello world server which - > -- replies on a single route - > server :: Server IO - > server = - > "api" /. "v1" /. - > mconcat - > [ "hello" /. hello - > , "bye" /. bye - > ] - > - > -- | Handler takes no inputs and marked as Get HTTP-request that returns Text. - > hello :: Get Text - > hello = Get $ pure "Hello World" - > - > -- | Handle with URL-param query and json body input as Post HTTP-request that returns Text. - > bye :: Query "name" Text -> Body ByeRequest -> Post Text - > bye (Query name) (Body req) = Post $ - > pure $ "Bye to " <> name <> " " <> req.greeting - . - Please see: - . - * quick start guide at - . - * examples directory for more fun servers: at -category: Web -homepage: https://github.com/anton-k/mig#readme -bug-reports: https://github.com/anton-k/mig/issues -author: Anton Kholomiov -maintainer: anton.kholomiov@gmail.com -copyright: 2023 Anton Kholomiov -license: BSD3 -license-file: LICENSE -build-type: Simple +name: mig +version: 0.2.0.0 +synopsis: Build lightweight and composable servers +description: The Core for the mig server library. + With library mig we can build lightweight and composable servers. + There are only couple of combinators to assemble servers from parts. + It supports generic handler functions as servant does. But strives to use more + simple model for API. It does not go to describing Server API at type level which + leads to simpler error messages. + . + * quick start guide at + . + * examples directory for more servers: at + . + * reference for the main functions: +category: Web +homepage: https://github.com/anton-k/mig#readme +bug-reports: https://github.com/anton-k/mig/issues +author: Anton Kholomiov +maintainer: anton.kholomiov@gmail.com +copyright: 2023 Anton Kholomiov +license: BSD3 +license-file: LICENSE +build-type: Simple extra-source-files: README.md - CHANGELOG.md source-repository head type: git @@ -77,41 +37,94 @@ library exposed-modules: - Mig - Mig.Common - Mig.Html - Mig.Html.IO - Mig.Internal.Types - Mig.Json - Mig.Json.IO + Mig.Core + Mig.Core.Api + Mig.Core.Api.NormalForm.TreeApi + Mig.Core.Class + Mig.Core.Class.MediaType + Mig.Core.Class.Monad + Mig.Core.Class.Plugin + Mig.Core.Class.Response + Mig.Core.Class.Route + Mig.Core.Class.Server + Mig.Core.OpenApi + Mig.Core.Server + Mig.Core.Server.Cache + Mig.Core.ServerFun + Mig.Core.Types + Mig.Core.Types.Http + Mig.Core.Types.Info + Mig.Core.Types.Route other-modules: Paths_mig hs-source-dirs: src default-extensions: - ImportQualifiedPost OverloadedStrings TypeFamilies OverloadedRecordDot DuplicateRecordFields LambdaCase DerivingStrategies - DataKinds StrictData - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + AllowAmbiguousTypes + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wunused-packages build-depends: aeson , base >=4.7 && <5 , blaze-html - , blaze-markup , bytestring , case-insensitive , containers , exceptions + , extra + , filepath , http-api-data + , http-media , http-types + , insert-ordered-containers + , lens + , lrucache , mtl + , openapi3 + , safe , text - , wai - , warp + , transformers + default-language: GHC2021 + +test-suite mig-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.Api + Test.Server + Test.Server.Common + Test.Server.Counter + Test.Server.Hello + Test.Server.RouteArgs + Paths_mig + hs-source-dirs: + test + default-extensions: + OverloadedStrings + TypeFamilies + OverloadedRecordDot + DuplicateRecordFields + LambdaCase + DerivingStrategies + StrictData + AllowAmbiguousTypes + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wunused-packages -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base >=4.7 && <5 + , bytestring + , containers + , hspec + , http-api-data + , http-types + , mig + , mtl + , openapi3 + , text default-language: GHC2021 diff --git a/src/Mig.hs b/src/Mig.hs deleted file mode 100644 --- a/src/Mig.hs +++ /dev/null @@ -1,606 +0,0 @@ -{-# Language UndecidableInstances #-} --- | Main module to write servers --- --- Server is a function from response (Resp) to request (Req). Request is wrapped into monad. --- Library supports IO-monad and ReaderT over IO like monads. --- --- We can build servers from parts with flexible combinators. --- Let's build hello-world server: --- --- > main :: IO () --- > main = runServer 8080 server --- > --- > server :: Server IO --- > server = --- > "api" /. "v1" /. "hello" /. Get @Text handleHello --- > --- > handleHello :: IO Text --- > handleHello = pure "Hello World" --- --- We can iuse monoids to combine servers and newtype-wrappers to read various inputs. --- See readme of the repo for tutorial and docs. -module Mig - ( -- * types - Server (..) - -- * DSL - , Json - -- ** methods - , Get (..) - , Post (..) - , Put (..) - , Delete (..) - , Patch (..) - , Options (..) - -- ** path and query - -- | Build API for routes with queries and captures. - -- Use monoid to combine several routes together. - , (/.) - , Capture (..) - , Query (..) - , Optional (..) - , Body (..) - , RawBody (..) - , Header (..) - , FormBody (..) - , PathInfo (..) - - -- ** response - -- | How to modify response and attach specific info to it - , AddHeaders (..) - , SetStatus (..) - , setStatus - , addHeaders - - -- ** Errors - -- | How to report errors - , Error (..) - , handleError - - -- * Run - -- | Run server application - , runServer - , ServerConfig (..) - , toApplication - - -- ** Render - -- | Render Reader-IO monad servers to IO servers. - , HasServer (..) - , fromReader - - -- * Convertes - , ToTextResp (..) - , ToJsonResp (..) - , ToHtmlResp (..) - , FromText (..) - , ToText (..) - - -- * utils - , badRequest - , ToServer (..) - , withServerAction - - , module X - ) where - -import Mig.Internal.Types -import Mig.Internal.Types qualified as Resp (Resp (..)) - -import Web.HttpApiData as X -import Web.FormUrlEncoded as X -import Data.Bifunctor -import Data.Kind -import Data.String -import Data.Text (Text) -import Data.Text qualified as Text -import Data.Text.Encoding qualified as Text -import Data.Text.Lazy qualified as TL -import Data.Aeson (ToJSON, FromJSON) -import Data.Aeson qualified as Json -import Data.ByteString (ByteString) -import Data.ByteString.Lazy qualified as BL -import Text.Blaze.Html (Html) -import Text.Blaze.Html (ToMarkup) -import Text.Read (readMaybe) -import Control.Monad.Reader -import Control.Monad.Except -import GHC.TypeLits -import Data.Proxy -import Data.Map.Strict qualified as Map -import Network.HTTP.Types.Status as X -import Network.HTTP.Types.Method -import Network.HTTP.Types.Header (ResponseHeaders) -import Network.Wai.Handler.Warp qualified as Warp -import Control.Exception (throw) -import Data.Typeable - --- | Path constructor (right associative). Example: --- --- > server :: Server IO --- > server = --- > "api" /. "v1" /. --- > mconcat --- > [ "foo" /. Get @Json handleFoo --- > , "bar" /. Post @Json handleBar --- > ] --- > --- > handleFoo, handleBar :: IO Text -(/.) :: ToServer a => Text -> a -> Server (ServerMonad a) -(/.) path act = toWithPath path (toServer act) -infixr 4 /. - --- | Map internal monad of the server -hoistServer :: (forall a . m a -> n a) -> Server m -> Server n -hoistServer f (Server act) = Server (f . act) - --- | Aything convertible from text -class FromText a where - fromText :: Text -> Maybe a - -instance FromText ByteString where - fromText = Just . Text.encodeUtf8 - -instance FromText String where - fromText = Just . Text.unpack - -instance FromText Text where - fromText = Just - -instance FromText TL.Text where - fromText = Just . TL.fromStrict - -instance FromText Word where - fromText = readMaybe . Text.unpack - -instance FromText Int where - fromText = readMaybe . Text.unpack - -instance FromText Integer where - fromText = readMaybe . Text.unpack - -instance FromText Bool where - fromText = readMaybe . Text.unpack - -instance FromText Float where - fromText = readMaybe . Text.unpack - -newtype QueryName a = QueryName Text - deriving (IsString, Eq, Ord, Show) - -toWithQuery :: ByteString -> (Maybe ByteString -> Server m) -> Server m -toWithQuery name act = Server $ \req -> - unServer (act (Map.lookup name req.query)) req - -withQuery' :: FromHttpApiData a => QueryName a -> (Maybe a -> Server m) -> Server m -withQuery' (QueryName name) act = toWithQuery (Text.encodeUtf8 name) $ \mVal -> - let - -- TODO: do not ignore parse failure - mArg = either (const Nothing) Just . (parseQueryParam <=< first (Text.pack . show) . Text.decodeUtf8') =<< mVal - in - act mArg - -withQuery :: (Applicative m, FromHttpApiData a) => QueryName a -> (a -> Server m) -> Server m -withQuery (QueryName name) act = toWithQuery (Text.encodeUtf8 name) $ \mVal -> - let - -- TODO: do not ignore parse failure - mArg = either (const Nothing) Just . (parseQueryParam <=< first (Text.pack . show) . Text.decodeUtf8') =<< mVal - in - case mArg of - Just arg -> act arg - Nothing -> toConst (pure $ badRequest $ "Failed to parse arg: " <> name) - --- | Class contains types which can be converted to IO-based server to run as with WAI-interface. --- --- We can run plain IO-servers and ReaderT over IO based servers. Readers can be wrapped in newtypes. --- In that case we can derive automatically @HasServer@ instance. -class Monad m => HasServer m where - type ServerResult m :: Type - renderServer :: Server m -> ServerResult m - -instance HasServer IO where - type ServerResult IO = Server IO - renderServer = id - -instance HasServer (ReaderT env IO) where - type ServerResult (ReaderT env IO) = env -> IO (Server IO) - renderServer server initEnv = fromReader initEnv server - --- | Render reader server to IO-based server -fromReader :: env -> Server (ReaderT env IO) -> IO (Server IO) -fromReader env server = - flip runReaderT env $ ReaderT $ \e -> pure $ hoistServer (flip runReaderT e) server - -instance (Show a, Typeable a) => HasServer (ReaderT env (ExceptT (Error a) IO)) where - type ServerResult (ReaderT env (ExceptT (Error a) IO)) = - (Error a -> Server IO) -> env -> IO (Server IO) - - renderServer server handleErr initEnv = fromReaderExcept handleErr initEnv server - -fromReaderExcept :: - (Show a, Typeable a) => - (Error a -> Server IO) -> - env -> - Server (ReaderT env (ExceptT (Error a) IO)) -> IO (Server IO) -fromReaderExcept handleErr env server = - fmap (handleError handleErr) $ - flip runReaderT env $ ReaderT $ - \e -> pure $ hoistServer (either throw pure <=< runExceptT . flip runReaderT e) server - --- Prim types - --- | Type tag of Json-response. -data Json - --- server DSL - --- | Class ToServer contains anything convertible to @Server m@. We use it for flexuble composition --- of servers from functions with arbitrary number of arguments. Arguments can --- be of specific types: Query, Body, Optional, Capture, Header, etc. --- We use type-level strings to encode query-names. --- Example: --- --- > "api" /. "foo" /. --- > (\(Query @"argA" argA) (Optional @"argB" argB) (Body jsonRequest) -> Post @Json $ handleFoo argA argB jsonRequest) --- > --- > handleFoo :: Int -> Maybe Text -> FooRequest -> IO FooResponse --- > handleFoo = ... --- --- Note that we can use any amount of arguments. And type of the input is decoded fron newtype wrapper --- which is used with argument of the handler function. --- --- Also we can return pure errors with Either. Anything which can be returned from function --- can be wrapped to @Either (Error err)@. --- --- For example in previous case we can use function which returns errors as values: --- --- > type ServerError = Error Text --- > --- > handleFoo :: Int -> Maybe Text -> FooRequest -> IO (Either ServerError FooResponse) --- > handleFoo = ... --- --- the result of error response is automatically matched with normal response of the server --- and standard Error type lets us pass status to response and some details. -class Monad (ServerMonad a) => ToServer a where - type ServerMonad a :: (Type -> Type) - toServer :: a -> Server (ServerMonad a) - -instance Monad m => ToServer (Server m) where - type ServerMonad (Server m) = m - toServer = id - --- Status - --- | Set status to response. It can be ised inside any ToXxxResp value. Example: --- --- > "api" /. handleFoo --- > --- > handleFoo :: Get Text IO (SetStatus Text) --- > handleFoo = Get $ pure $ SetStatus status500 "Bad request" -data SetStatus a = SetStatus - { status :: Status - , content :: a - } - --- | Sets status for response of the server -setStatus :: Monad m => Status -> Server m -> Server m -setStatus st = mapResp $ \resp -> resp { Resp.status = st } - --- Headers - --- | Attach headers to response. It can be used inside any ToXxxResp value. --- Example: --- --- > "api" /. handleFoo --- > --- > handleFoo :: Get Text IO (AddHeaders Text) --- > handleFoo = Get $ pure $ AddHeaders headers "Hello foo" -data AddHeaders a = AddHeaders - { headers :: ResponseHeaders - , content :: a - } - --- | Adds headers for response of the server -addHeaders :: Monad m => ResponseHeaders -> Server m -> Server m -addHeaders headers = mapResp $ \resp -> resp { Resp.headers = resp.headers <> headers } - -mapResp :: Monad m => (Resp -> Resp) -> Server m -> Server m -mapResp f (Server act) = Server $ \req -> - fmap (fmap f) $ act req - --- text response - --- | Values convertible to Text (lazy) -class ToTextResp a where - toTextResp :: a -> Resp - -instance ToTextResp Text where - toTextResp = text - -instance ToTextResp TL.Text where - toTextResp = text - -instance ToTextResp Int where - toTextResp = text - -instance ToTextResp a => ToTextResp (AddHeaders a) where - toTextResp (AddHeaders headers content) = - resp { Resp.headers = resp.headers <> headers } - where - resp = toTextResp content - -instance ToTextResp a => ToTextResp (SetStatus a) where - toTextResp (SetStatus st content) = - setRespStatus st (toTextResp content) - -instance (ToText err, ToTextResp a) => ToTextResp (Either (Error err) a) where - toTextResp = either fromError toTextResp - where - fromError err = setRespStatus err.status (text err.body) - --- json response - --- | Values convertible to Json -class ToJsonResp a where - toJsonResp :: a -> Resp - -instance {-# OVERLAPPABLE #-} ToJSON a => ToJsonResp a where - toJsonResp = json - -instance ToJsonResp a => ToJsonResp (AddHeaders a) where - toJsonResp (AddHeaders headers content) = - resp { Resp.headers = resp.headers <> headers } - where - resp = toJsonResp content - -instance ToJsonResp a => ToJsonResp (SetStatus a) where - toJsonResp (SetStatus st content) = - setRespStatus st (toJsonResp content) - -instance (ToJSON err, ToJsonResp a) => ToJsonResp (Either (Error err) a) where - toJsonResp = either fromError toJsonResp - where - fromError err = setRespStatus err.status (json err.body) - --- html response - --- | Values convertible to Html -class ToHtmlResp a where - toHtmlResp :: a -> Resp - -instance ToMarkup a => ToHtmlResp a where - toHtmlResp = html - -instance ToHtmlResp a => ToHtmlResp (AddHeaders a) where - toHtmlResp (AddHeaders headers content) = - resp { Resp.headers = resp.headers <> headers } - where - resp = toHtmlResp content - -instance ToHtmlResp a => ToHtmlResp (SetStatus a) where - toHtmlResp (SetStatus st content) = - setRespStatus st (toHtmlResp content) - -instance (ToJSON err, ToHtmlResp a) => ToHtmlResp (Either (Error err) a) where - toHtmlResp = either fromError toHtmlResp - where - fromError err = setRespStatus err.status (json err.body) - --- Get - --- | Get method. Note that we can not use body input with Get-method, use Post for that. --- So with Get we can use only URI inputs (Query, Optional, Capture) -newtype Get ty m a = Get (m a) - -instance (Monad m, ToTextResp a) => ToServer (Get Text m a) where - type ServerMonad (Get Text m a) = m - toServer (Get act) = toMethod methodGet (toTextResp <$> act) - -instance (Monad m, ToJSON a) => ToServer (Get Json m a) where - type ServerMonad (Get Json m a) = m - toServer (Get act) = toMethod methodGet (json <$> act) - -instance (Monad m, ToHtmlResp a) => ToServer (Get Html m a) where - type ServerMonad (Get Html m a) = m - toServer (Get act) = toMethod methodGet (toHtmlResp <$> act) - -instance (Monad m) => ToServer (Get BL.ByteString m BL.ByteString) where - type ServerMonad (Get BL.ByteString m BL.ByteString) = m - toServer (Get act) = toMethod methodGet (raw <$> act) - -instance (Monad m) => ToServer (Get ByteString m ByteString) where - type ServerMonad (Get ByteString m ByteString) = m - toServer (Get act) = toMethod methodGet (raw . BL.fromStrict <$> act) - --- Post - --- | Post method -newtype Post ty m a = Post (m a) - -instance (Monad m, ToTextResp a) => ToServer (Post Text m a) where - type ServerMonad (Post Text m a) = m - toServer (Post act) = toMethod methodPost $ toTextResp <$> act - -instance (Monad m, ToJSON a) => ToServer (Post Json m a) where - type ServerMonad (Post Json m a) = m - toServer (Post act) = toMethod methodPost $ json <$> act - -instance (Monad m, ToHtmlResp a) => ToServer (Post Html m a) where - type ServerMonad (Post Html m a) = m - toServer (Post act) = toMethod methodPost (toHtmlResp <$> act) - --- Put - --- | Put method -newtype Put ty m a = Put (m a) - -instance (Monad m, ToTextResp a) => ToServer (Put Text m a) where - type ServerMonad (Put Text m a) = m - toServer (Put act) = toMethod methodPut $ toTextResp <$> act - -instance (Monad m, ToJSON a) => ToServer (Put Json m a) where - type ServerMonad (Put Json m a) = m - toServer (Put act) = toMethod methodPut $ json <$> act - -instance (Monad m, ToHtmlResp a) => ToServer (Put Html m a) where - type ServerMonad (Put Html m a) = m - toServer (Put act) = toMethod methodPut (toHtmlResp <$> act) - --- Delete - --- | Delete method -newtype Delete ty m a = Delete (m a) - -instance (Monad m, ToTextResp a) => ToServer (Delete Text m a) where - type ServerMonad (Delete Text m a) = m - toServer (Delete act) = toMethod methodDelete $ toTextResp <$> act - -instance (Monad m, ToJSON a) => ToServer (Delete Json m a) where - type ServerMonad (Delete Json m a) = m - toServer (Delete act) = toMethod methodDelete $ json <$> act - -instance (Monad m, ToHtmlResp a) => ToServer (Delete Html m a) where - type ServerMonad (Delete Html m a) = m - toServer (Delete act) = toMethod methodDelete (toHtmlResp <$> act) - --- Patch - --- | Patch method -newtype Patch ty m a = Patch (m a) - -instance (Monad m, ToTextResp a) => ToServer (Patch Text m a) where - type ServerMonad (Patch Text m a) = m - toServer (Patch act) = toMethod methodPatch $ toTextResp <$> act - -instance (Monad m, ToJSON a) => ToServer (Patch Json m a) where - type ServerMonad (Patch Json m a) = m - toServer (Patch act) = toMethod methodPatch $ json <$> act - -instance (Monad m, ToHtmlResp a) => ToServer (Patch Html m a) where - type ServerMonad (Patch Html m a) = m - toServer (Patch act) = toMethod methodPatch (toHtmlResp <$> act) - --- Options - --- | Options method -newtype Options ty m a = Options (m a) - -instance (Monad m, ToTextResp a) => ToServer (Options Text m a) where - type ServerMonad (Options Text m a) = m - toServer (Options act) = toMethod methodOptions $ toTextResp <$> act - -instance (Monad m, ToJSON a) => ToServer (Options Json m a) where - type ServerMonad (Options Json m a) = m - toServer (Options act) = toMethod methodOptions $ json <$> act - -instance (Monad m, ToHtmlResp a) => ToServer (Options Html m a) where - type ServerMonad (Options Html m a) = m - toServer (Options act) = toMethod methodOptions (toHtmlResp <$> act) - --- Query - --- | Mandatary query parameter. Name is encoded as type-level string. Example: --- --- > "api" /. handleFoo --- > --- > handleFoo :: Query "name" Int -> Server IO --- > handleFoo (Query arg) = ... -newtype Query (sym :: Symbol) a = Query a - -instance (FromHttpApiData a, ToServer b, KnownSymbol sym) => ToServer (Query sym a -> b) where - type ServerMonad (Query sym a -> b) = ServerMonad b - toServer act = withQuery (QueryName (Text.pack $ symbolVal (Proxy @sym))) (toServer . act . Query) - --- Optional query - --- | Optional query parameter. Name is encoded as type-level string. Example: --- --- > "api" /. handleFoo --- > --- > handleFoo :: Optional "name" -> Server IO --- > handleFoo (Optional maybeArg) = ... -newtype Optional (sym :: Symbol) a = Optional (Maybe a) - -instance (FromHttpApiData a, ToServer b, KnownSymbol sym) => ToServer (Optional sym a -> b) where - type ServerMonad (Optional sym a -> b) = ServerMonad b - toServer act = withQuery' (QueryName (fromString $ symbolVal (Proxy @sym))) (toServer . act . Optional) - --- | Capture - --- Captures part of the path. Example --- --- "api" /. "foo" /. (\(Capture n) -> handleFoo n) --- --- It will parse the paths: "api/foo/358" and pass 358 to @handleFoo@. -newtype Capture a = Capture a - -instance (FromHttpApiData a, ToServer b) => ToServer (Capture a -> b) where - type ServerMonad (Capture a -> b) = ServerMonad b - toServer act = toWithCapture $ \txt -> - case parseUrlPiece txt of - Right val -> toServer $ act $ Capture val - Left err -> toConst $ pure $ badRequest ("Failed to parse capture: " <> err) - --- Read Body input - --- | Reads Json body (lazy). We can limit the body size with server config. Example: --- --- > "api" /. "search" /. (\(Body request) -> handleSearch request) -newtype Body a = Body a - -instance (MonadIO (ServerMonad b), FromJSON a, ToServer b) => ToServer (Body a -> b) where - type ServerMonad (Body a -> b) = ServerMonad b - toServer act = toWithBody $ \val -> - case Json.eitherDecode val of - Right v -> toServer $ act $ Body v - Left err -> toConst $ pure $ badRequest $ "Failed to parse JSON body: " <> Text.pack err - --- | Reads raw body as lazy bytestring. We can limit the body size with server config. Example: --- --- > "api" /. "upload" /. (\(RawBody content) -> handleUpload content) -newtype RawBody = RawBody BL.ByteString - -instance (MonadIO (ServerMonad b), ToServer b) => ToServer (RawBody -> b) where - type ServerMonad (RawBody -> b) = ServerMonad b - toServer act = toWithBody $ toServer . act . RawBody - --- | Reads the URL encoded Form input -newtype FormBody a = FormBody a - -instance (ToServer b, MonadIO (ServerMonad b), FromForm a) => ToServer (FormBody a -> b) where - type ServerMonad (FormBody a -> b) = ServerMonad b - toServer act = toWithFormData (toServer . act . FormBody) - --- Request Headers - --- | Reads input header. Example: --- --- > "api" /. (\(Header @"Trace-Id" traceId) -> Post @Json (handleFoo traceId)) --- > --- > handleFoo :: Maybe ByteString -> IO FooResponse -newtype Header (sym :: Symbol) a = Header (Maybe a) - -instance (FromHttpApiData a, ToServer b, KnownSymbol sym) => ToServer (Header sym a -> b) where - type ServerMonad (Header sym a -> b) = ServerMonad b - toServer act = toWithHeader (fromString $ symbolVal (Proxy @sym)) (toServer . act . Header) - --- | Reads current path info -newtype PathInfo = PathInfo [Text] - -instance (ToServer b) => ToServer (PathInfo -> b) where - type ServerMonad (PathInfo -> b) = ServerMonad b - toServer act = toWithPathInfo (toServer . act . PathInfo) - --- | Appends action to the server -withServerAction :: Monad m => Server m -> m () -> Server m -withServerAction srv act = Server $ \req -> do - act - unServer srv req - -------------------------------------------------------------------------------------- --- WAI - --- | Run server on port -runServer :: Int -> Server IO -> IO () -runServer port server = - Warp.run port (toApplication config server) - where - config = ServerConfig { maxBodySize = Nothing } diff --git a/src/Mig/Common.hs b/src/Mig/Common.hs deleted file mode 100644 --- a/src/Mig/Common.hs +++ /dev/null @@ -1,52 +0,0 @@ --- | Module for HTML-based servers -module Mig.Common - ( -- * types - Server (..) - -- * DSL - , ToText (..) - , ToHtmlResp (..) - , FromText (..) - , ToServer (..) - , withServerAction - -- * path and query - , (/.) - , Capture (..) - , Query (..) - , Optional (..) - , Body (..) - , RawBody (..) - , Header (..) - , FormBody (..) - , PathInfo (..) - - -- * response - , AddHeaders (..) - , SetStatus (..) - , setStatus - , addHeaders - - -- * Errors - , Error (..) - , handleError - - -- * Render - , HasServer (..) - , fromReader - -- * Run - , ServerConfig (..) - , toApplication - , runServer - -- * utils - , badRequest - - , module X - ) where - -import Mig - ( Server (..), ToServer (..), ToText (..), ToHtmlResp (..), FromText (..), handleError, PathInfo (..) - , (/.), Capture (..), Query (..), Optional (..), Body (..), RawBody (..), Header (..), FormBody (..), AddHeaders (..), SetStatus (..) - , setStatus, addHeaders, HasServer (..), fromReader, ServerConfig (..), toApplication, runServer, badRequest, Error (..), withServerAction) - -import Network.HTTP.Types.Status as X -import Web.HttpApiData as X -import Web.FormUrlEncoded as X diff --git a/src/Mig/Core.hs b/src/Mig/Core.hs new file mode 100644 --- /dev/null +++ b/src/Mig/Core.hs @@ -0,0 +1,63 @@ +{-| Re-exports everything + +With library mig we can build lightweight and composable servers. +There are only couple of combinators to assemble servers from parts. +It supports generic handler functions as servant does. But strives to use more +simple model for API. It does not go to describing Server API at type level which +leads to simpler error messages. + +The main features are: + +* lightweight library + +* expressive DSL to compose servers + +* type-safe handlers which are encoded with generic haskell functions + +* built on top of WAI and warp server libraries. + +Example of hello world server. To run example use library @mig-server@ which is based on core library: + +> import Mig.Json.IO +> +> -- | We can render the server and run it on port 8085. +> -- It uses wai and warp. +> main :: IO () +> main = runServer 8085 server +> +> -- | Init simple hello world server which +> -- replies on a single route +> server :: Server IO +> server = +> "api/v1" /. +> [ "hello" /. hello +> , "bye" /. bye +> ] +> +> -- | Handler takes no inputs and marked as Get HTTP-request that returns Text. +> hello :: Get (Resp Text) +> hello = pure $ ok "Hello World" +> +> -- | Handle with URL-param query and capture as Get HTTP-request that returns Text. +> bye :: Query "name" Text -> Capture "suffix" -> Post (Resp Text) +> bye (Query name) (Capture suffix) = +> pure $ ok $ "Bye to " <> name <> " " <> suffix + +References: + +* quick start guide at + +* examples directory for more servers: at + +* reference for the main functions: +-} +module Mig.Core ( + module X, +) where + +import Mig.Core.Api as X +import Mig.Core.Class as X +import Mig.Core.OpenApi as X +import Mig.Core.Server as X +import Mig.Core.ServerFun as X +import Mig.Core.Types as X diff --git a/src/Mig/Core/Api.hs b/src/Mig/Core/Api.hs new file mode 100644 --- /dev/null +++ b/src/Mig/Core/Api.hs @@ -0,0 +1,227 @@ +-- | Core API description +module Mig.Core.Api ( + Api (..), + Path (..), + ApiNormal (..), + toNormalApi, + fromNormalApi, + PathItem (..), + getPath, + CaptureMap, + flatApi, + fromFlatApi, + MethodMap, + OutputMediaMap (..), + InputMediaMap (..), + MediaMap (..), +) where + +import Data.ByteString (ByteString) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.String +import Data.Text (Text) +import Data.Text qualified as Text +import Mig.Core.Class.Route qualified as Route +import Mig.Core.Types (RouteInfo (..), RouteOutput (..), getInputType) +import Network.HTTP.Media (mapAcceptMedia, mapContentMedia) +import Network.HTTP.Media.MediaType (MediaType) +import Network.HTTP.Types.Method +import System.FilePath +import Web.HttpApiData + +-- | HTTP API container +data Api a + = -- | alternative between two API's + Append (Api a) (Api a) + | -- | an empty API that does nothing + Empty + | -- | path prefix for an API + WithPath Path (Api a) + | -- | handle route + HandleRoute a + deriving (Functor, Foldable, Traversable, Show, Eq) + +instance Monoid (Api a) where + mempty = Empty + +instance Semigroup (Api a) where + (<>) = Append + +-- | Filters routes in the API with predicate +filterApi :: (a -> Bool) -> Api a -> Api a +filterApi check = \case + HandleRoute a -> if check a then HandleRoute a else Empty + Append a b -> + case rec a of + Empty -> rec b + otherA -> + case rec b of + Empty -> otherA + otherB -> Append otherA otherB + Empty -> Empty + WithPath path a -> case rec a of + Empty -> Empty + other -> WithPath path other + where + rec = filterApi check + +-- | converts API to efficient representation to fetch the route handlers by path +toNormalApi :: forall m. Api (Route.Route m) -> ApiNormal (Api (Route.Route m)) +toNormalApi api = ApiNormal $ fmap (fmap toInputMediaMap . toOutputMediaMap) (toMethodMap api) + where + filterEmpty :: Map key (Api val) -> Map key (Api val) + filterEmpty = Map.filter $ \case + Empty -> False + _ -> True + + toMethodMap :: Api (Route.Route m) -> MethodMap (Api (Route.Route m)) + toMethodMap a = + filterEmpty $ + Map.fromList $ + fmap + ( \m -> + (m, filterApi (\route -> route.info.method == Just m) a) + ) + methods + where + methods = foldMap (\route -> maybe [] pure route.info.method) a + + toInputMediaMap :: Api (Route.Route m) -> InputMediaMap (Api (Route.Route m)) + toInputMediaMap = InputMediaMap . toMediaMapBy getInputType + + toOutputMediaMap :: Api (Route.Route m) -> OutputMediaMap (Api (Route.Route m)) + toOutputMediaMap = OutputMediaMap . toMediaMapBy (\routeInfo -> Just routeInfo.output.media) + + toMediaMapBy :: (RouteInfo -> Maybe MediaType) -> Api (Route.Route m) -> MediaMap (Api (Route.Route m)) + toMediaMapBy getMedia a = + MediaMap (filterAnyCases $ toMediaApi <$> medias) a + where + medias = Set.toList $ foldMap (\route -> maybe Set.empty Set.singleton (getMedia route.info)) a + + toMediaApi media = (media, filterApi (\route -> getMedia route.info == Just media) a) + + -- filter out any cases as they are covered by second argument of MediaMap value + filterAnyCases = filter (("*/*" /=) . fst) + +-- | Read sub-api by HTTP method, accept-type and content-type +fromNormalApi :: Method -> ByteString -> ByteString -> ApiNormal a -> Maybe a +fromNormalApi method outputAccept inputContentType (ApiNormal methodMap) = do + OutputMediaMap outputMediaMap <- Map.lookup method methodMap + InputMediaMap inputMediaMap <- lookupMediaMapBy mapAcceptMedia outputMediaMap outputAccept + lookupMediaMapBy mapContentMedia inputMediaMap inputContentType + +-- | Efficient representation of API to fetch routes +newtype ApiNormal a = ApiNormal (MethodMap (OutputMediaMap (InputMediaMap a))) + deriving (Show, Eq, Functor) + +-- | Mthod map +type MethodMap a = Map Method a + +-- | filter by Content-Type header +newtype InputMediaMap a = InputMediaMap (MediaMap a) + deriving (Show, Eq, Functor) + +-- | filter by Accept header +newtype OutputMediaMap a = OutputMediaMap (MediaMap a) + deriving (Show, Eq, Functor) + +-- | Map by media type +data MediaMap a = MediaMap + { mapValues :: [(MediaType, a)] + , matchAll :: a + } + deriving (Show, Eq, Functor) + +-- | Lookup value by media type key +lookupMediaMapBy :: ([(MediaType, a)] -> ByteString -> Maybe a) -> MediaMap a -> ByteString -> Maybe a +lookupMediaMapBy getter (MediaMap m matchAll) media + | media == "*/*" = Just matchAll + | otherwise = getter m media + +{-| Path is a chain of elements which can be static types or capture. +There is @IsString@ instance which allows us to create paths from strings. Examples: + +> "api/v1/foo" ==> Path [StaticPath "api", StaticPath "v1", StaticPath "foo"] +> "api/v1/*" ==> Path [StaticPath "api", StaticPath "v1", CapturePath "*"] +-} +newtype Path = Path {unPath :: [PathItem]} + deriving newtype (Show, Eq, Ord, Semigroup, Monoid) + +instance ToHttpApiData Path where + toUrlPiece (Path ps) = Text.intercalate "/" $ fmap toUrlPiece ps + +instance ToHttpApiData PathItem where + toUrlPiece = \case + StaticPath txt -> txt + CapturePath txt -> "{" <> txt <> "}" + +instance IsString Path where + fromString = + Path . fmap (replaceCapture . Text.pack) . filter (not . any isPathSeparator) . splitDirectories + where + replaceCapture :: Text -> PathItem + replaceCapture path + | Text.head path == '$' = CapturePath (Text.tail path) + | path == "*" = CapturePath path + | otherwise = StaticPath path + +-- | Path can be a static item or capture with a name +data PathItem + = StaticPath Text + | CapturePath Text + deriving (Show, Eq, Ord) + +{-| Map of capture values extracted from path. +Keys are capture names. +-} +type CaptureMap = Map Text Text + +-- | Find an api item by path. Also it accumulates capture map along the way. +getPath :: [Text] -> Api a -> Maybe (a, CaptureMap) +getPath mainPath = go mempty (filter (not . Text.null) mainPath) + where + go :: CaptureMap -> [Text] -> Api a -> Maybe (a, CaptureMap) + go !captureMap path api = + case path of + [] -> case api of + HandleRoute a -> Just (a, captureMap) + Append a b -> maybe (go captureMap path b) Just (go captureMap path a) + _ -> Nothing + p : rest -> case api of + WithPath template restApi -> goPath captureMap p rest template restApi + Append a b -> maybe (go captureMap path b) Just (go captureMap path a) + _ -> Nothing + + goPath !captureMap !pathHead !pathTail (Path !template) restApi = + case template of + [] -> go captureMap (pathHead : pathTail) restApi + StaticPath apiHead : templateRest -> + if pathHead == apiHead + then goPathNext captureMap pathTail templateRest restApi + else Nothing + CapturePath name : templateRest -> + let nextCaptureMap = Map.insert name pathHead captureMap + in goPathNext nextCaptureMap pathTail templateRest restApi + + goPathNext !captureMap !pathTail !templateRest restApi = + case templateRest of + [] -> go captureMap pathTail restApi + _ -> case pathTail of + nextPathHead : nextPathTail -> goPath captureMap nextPathHead nextPathTail (Path templateRest) restApi + [] -> Nothing + +-- | Flattens API. Creates a flat list of paths and route handlers. +flatApi :: Api a -> [(Path, a)] +flatApi = go mempty + where + go prefix = \case + Empty -> mempty + Append a b -> go prefix a <> go prefix b + WithPath path a -> go (prefix <> path) a + HandleRoute a -> [(prefix, a)] + +-- | Constructs API from flat list of pairs of paths and route handlers. +fromFlatApi :: [(Path, a)] -> Api a +fromFlatApi = foldMap (\(path, route) -> WithPath path (HandleRoute route)) diff --git a/src/Mig/Core/Api/NormalForm/TreeApi.hs b/src/Mig/Core/Api/NormalForm/TreeApi.hs new file mode 100644 --- /dev/null +++ b/src/Mig/Core/Api/NormalForm/TreeApi.hs @@ -0,0 +1,195 @@ +{-| Normal form where on handler search API is +traversed in tree like facion without retraversal of the paths. +-} +module Mig.Core.Api.NormalForm.TreeApi ( + TreeApi (..), + CaptureCase (..), + getPath, + toTreeApi, +) where + +import Data.List qualified as List +import Data.List.Extra qualified as List +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (isNothing, mapMaybe) +import Data.Text (Text) +import Data.Text qualified as Text + +import Mig.Core.Api (Api (..), Path (..), PathItem (..)) + +type CaptureMap = Map Text Text + +-- | This form of API encodes path switch points as Map's so +-- it does not retraverse the routes and can find the right +-- branch on switch. In the plain api it tries the routes one by one +-- until it finds the right one. +data TreeApi a + = WithStaticPath [Text] (TreeApi a) + | WithCapturePath [Text] (TreeApi a) + | SwitchApi (Maybe a) (Map Text (TreeApi a)) (Maybe (CaptureCase a)) + deriving (Eq, Show, Functor) + +-- | Capture case alternative +data CaptureCase a = CaptureCase + { name :: Text + , api :: TreeApi a + } + deriving (Eq, Show, Functor) + +-- | Get a route by path, also extracts capture map +getPath :: [Text] -> TreeApi a -> Maybe (a, CaptureMap) +getPath mainPath = go mempty (filter (not . Text.null) mainPath) + where + go :: CaptureMap -> [Text] -> TreeApi a -> Maybe (a, CaptureMap) + go !captures !path !api = + case path of + [] -> + case api of + SwitchApi (Just result) _ _ -> Just (result, captures) + _ -> Nothing + headPath : tailPath -> + case api of + WithStaticPath static subApi -> onStaticPath captures (headPath : tailPath) static subApi + WithCapturePath names subApi -> onCapturePath captures (headPath : tailPath) names subApi + SwitchApi _ alternatives mCapture -> onSwitch captures headPath tailPath alternatives mCapture + + onStaticPath captures pathQuery staticPath subApi = do + rest <- checkPrefix staticPath pathQuery + go captures rest subApi + + onCapturePath captures pathQuery names subApi = do + (nextCaptures, nextPath) <- accumCapture captures names pathQuery + go nextCaptures nextPath subApi + + onSwitch captures headPath tailPath alternatives mCapture = + case Map.lookup headPath alternatives of + Just subApi -> go captures tailPath subApi + Nothing -> do + captureCase <- mCapture + go (Map.insert captureCase.name headPath captures) tailPath captureCase.api + +checkPrefix :: (Eq a) => [a] -> [a] -> Maybe [a] +checkPrefix (a : as) (b : bs) + | a == b = checkPrefix as bs + | otherwise = Nothing +checkPrefix [] b = Just b +checkPrefix _ _ = Nothing + +accumCapture :: CaptureMap -> [Text] -> [Text] -> Maybe (CaptureMap, [Text]) +accumCapture !captures !names !path = + case names of + [] -> Just (captures, path) + name : rest -> + case path of + pathHead : pathTail -> accumCapture (Map.insert name pathHead captures) rest pathTail + [] -> Nothing + +------------------------------------------------------------------------------------- + +-- | Converts api to tree normal form +toTreeApi :: Api a -> TreeApi a +toTreeApi = + joinPaths . \case + Empty -> SwitchApi Nothing mempty Nothing + WithPath path subApi -> case fromPathPrefix path of + Nothing -> toTreeApi subApi + Just prefix -> case prefix of + StaticPrefix ps rest -> WithStaticPath ps (toTreeApi $ WithPath rest subApi) + CapturePrefix ps rest -> WithCapturePath ps (toTreeApi $ WithPath rest subApi) + HandleRoute a -> SwitchApi (Just a) mempty Nothing + Append a b -> fromAlts $ orderAppends (collectAppends a <> collectAppends b) + +joinPaths :: TreeApi a -> TreeApi a +joinPaths = \case + SwitchApi mRoute alts mCapture -> SwitchApi mRoute (fmap joinPaths alts) (fmap joinCapturePaths mCapture) + WithStaticPath pathA (WithStaticPath pathB subApi) -> joinPaths (WithStaticPath (pathA ++ pathB) subApi) + WithCapturePath namesA (WithCapturePath namesB subApi) -> joinPaths (WithCapturePath (namesA ++ namesB) subApi) + WithStaticPath path subApi -> WithStaticPath path (joinPaths subApi) + WithCapturePath names subApi -> WithCapturePath names (joinPaths subApi) + where + joinCapturePaths x = x{api = joinPaths x.api} + +data Alts a = Alts + { appends :: [(Text, Api a)] + , capture :: Maybe (Text, Api a) + , route :: Maybe a + } + +data AppendItem a + = StaticAppend Text (Api a) + | RouteAppend a + | CaptureAppend Text (Api a) + +collectAppends :: Api a -> [AppendItem a] +collectAppends = \case + Empty -> [] + HandleRoute a -> [RouteAppend a] + Append a b -> collectAppends a <> collectAppends b + WithPath (Path items) subApi -> case items of + [] -> collectAppends subApi + StaticPath item : [] -> pure $ StaticAppend item subApi + StaticPath item : rest -> pure $ StaticAppend item (WithPath (Path rest) subApi) + CapturePath item : [] -> pure $ CaptureAppend item subApi + CapturePath item : rest -> pure $ CaptureAppend item (WithPath (Path rest) subApi) + +orderAppends :: [AppendItem a] -> Alts a +orderAppends items = + Alts + { appends = mapMaybe toAppend items + , capture = List.firstJust toCapture items + , route = List.firstJust toRoute items + } + where + toAppend = \case + StaticAppend name api -> Just (name, api) + _ -> Nothing + + toCapture = \case + CaptureAppend name api -> Just (name, api) + _ -> Nothing + + toRoute = \case + RouteAppend route -> Just route + _ -> Nothing + +fromAlts :: Alts a -> TreeApi a +fromAlts alts = + case getStaticSingleton of + Just (path, subApi) -> WithStaticPath [path] (toTreeApi subApi) + Nothing -> + case getCaptureSingleton of + Just (names, subApi) -> WithCapturePath [names] (toTreeApi subApi) + Nothing -> SwitchApi alts.route (fmap toTreeApi $ Map.fromList alts.appends) (fmap toCaptureCase alts.capture) + where + toCaptureCase (name, api) = CaptureCase name (toTreeApi api) + + getStaticSingleton = + case alts.appends of + [(path, subApi)] | isNothing alts.route && isNothing alts.capture -> Just (path, subApi) + _ -> Nothing + + getCaptureSingleton = + case alts.capture of + Just (name, subApi) | isNothing alts.route && null alts.appends -> Just (name, subApi) + _ -> Nothing + +data PathPrefix + = StaticPrefix [Text] Path + | CapturePrefix [Text] Path + +fromPathPrefix :: Path -> Maybe PathPrefix +fromPathPrefix (Path items) = case items of + [] -> Nothing + StaticPath item : rest -> Just (accumStatics [item] rest) + CapturePath item : rest -> Just (accumCaptures [item] rest) + where + accumStatics res rest = + case rest of + StaticPath item : nextRest -> accumStatics (item : res) nextRest + _ -> StaticPrefix (List.reverse res) (Path rest) + + accumCaptures res rest = + case rest of + CapturePath item : nextRest -> accumCaptures (item : res) nextRest + _ -> CapturePrefix (List.reverse res) (Path rest) diff --git a/src/Mig/Core/Class.hs b/src/Mig/Core/Class.hs new file mode 100644 --- /dev/null +++ b/src/Mig/Core/Class.hs @@ -0,0 +1,11 @@ +-- | Re-export mig classes +module Mig.Core.Class ( + module X, +) where + +import Mig.Core.Class.MediaType as X +import Mig.Core.Class.Monad as X +import Mig.Core.Class.Plugin as X +import Mig.Core.Class.Response as X +import Mig.Core.Class.Route as X +import Mig.Core.Class.Server as X diff --git a/src/Mig/Core/Class/MediaType.hs b/src/Mig/Core/Class/MediaType.hs new file mode 100644 --- /dev/null +++ b/src/Mig/Core/Class/MediaType.hs @@ -0,0 +1,134 @@ +{-| Classes for MediaType and proper converters of Http values +from/to parameters or request/response bodies. +-} +module Mig.Core.Class.MediaType ( + MediaType, + ToMediaType (..), + ToRespBody (..), + Json, + FormUrlEncoded, + OctetStream, + AnyMedia, + FromReqBody (..), +) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson qualified as Json +import Data.Bifunctor +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as BL +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Text.Lazy qualified as TextLazy +import Data.Text.Lazy.Encoding qualified as TextLazy +import Network.HTTP.Media.MediaType +import Text.Blaze.Html (Html, ToMarkup (..)) +import Text.Blaze.Html.Renderer.Utf8 (renderHtml) +import Web.FormUrlEncoded (FromForm, ToForm, urlDecodeAsForm, urlEncodeAsForm) + +-- | Conversion of type-level tags to media type values +class ToMediaType a where + toMediaType :: MediaType + +instance ToMediaType Text where + toMediaType = "text/plain" + +instance ToMediaType Html where + toMediaType = "text/html" + +{-| Media type octet stream is for passing raw byte-strings in the request body. +It is converted to "application/octet-stream" +-} +data OctetStream + +instance ToMediaType OctetStream where + toMediaType = "application/octet-stream" + +instance ToMediaType BL.ByteString where + toMediaType = "application/octet-stream" + +{-| Type-level tag for JSON media type +It is converted to "application/json" +-} +data Json + +instance ToMediaType Json where + toMediaType = "application/json" + +{-| Type-level tag for FORM url encoded media-type. +It is converted to "application/x-www-form-urlencoded" +-} +data FormUrlEncoded + +instance ToMediaType FormUrlEncoded where + toMediaType = "application/x-www-form-urlencoded" + +{-| Signifies any media. It prescribes the server renderer to lookup +media-type at run-time in the "Conten-Type" header. +As media-type it is rendered to "*/*". + +It is useful for values for which we want to derive content type +from run-time values. For example it is used for static file servers +to get media type from file extension. +-} +data AnyMedia + +instance ToMediaType AnyMedia where + toMediaType = "*/*" + +------------------------------------------------------------------------------------ +-- mime render (everything that can be rendered as HTTP-output) + +-- | Values that can be rendered to response body byte string. +class (ToMediaType ty) => ToRespBody ty b where + toRespBody :: b -> BL.ByteString + +instance (ToJSON a) => ToRespBody Json a where + toRespBody = Json.encode + +instance ToRespBody Text Text where + toRespBody = BL.fromStrict . Text.encodeUtf8 + +instance ToRespBody Text TextLazy.Text where + toRespBody = TextLazy.encodeUtf8 + +instance (ToMarkup a) => ToRespBody Html a where + toRespBody = renderHtml . toMarkup + +instance ToRespBody OctetStream BL.ByteString where + toRespBody = id + +instance ToRespBody OctetStream ByteString where + toRespBody = BL.fromStrict + +instance (ToForm a) => ToRespBody FormUrlEncoded a where + toRespBody = urlEncodeAsForm + +instance ToRespBody AnyMedia BL.ByteString where + toRespBody = id + +instance ToRespBody AnyMedia ByteString where + toRespBody = BL.fromStrict + +------------------------------------------------------------------------------------- +-- mime unrender (everything that can be parsed from HTTP-input) + +-- | Values that can be parsed from request byte string. +class (ToMediaType ty) => FromReqBody ty b where + fromReqBody :: BL.ByteString -> Either Text b + +instance FromReqBody Text Text where + fromReqBody = first (Text.pack . show) . Text.decodeUtf8' . BL.toStrict + +instance FromReqBody OctetStream BL.ByteString where + fromReqBody = Right + +instance FromReqBody OctetStream ByteString where + fromReqBody = Right . BL.toStrict + +instance (FromJSON a) => FromReqBody Json a where + fromReqBody = first Text.pack . Json.eitherDecode + +instance (FromForm a) => FromReqBody FormUrlEncoded a where + fromReqBody = urlDecodeAsForm diff --git a/src/Mig/Core/Class/Monad.hs b/src/Mig/Core/Class/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Mig/Core/Class/Monad.hs @@ -0,0 +1,16 @@ +-- | Type-level function to extract underlying server monad +module Mig.Core.Class.Monad ( + MonadOf, + Send (..), +) where + +import Data.Kind +import Mig.Core.Types.Http +import Mig.Core.Types.Route + +type family MonadOf a :: (Type -> Type) where + MonadOf (Send method m a) = m + MonadOf (Request -> m (Maybe Response)) = m + MonadOf (f m) = m + MonadOf (a -> b) = MonadOf b + MonadOf [a] = MonadOf a diff --git a/src/Mig/Core/Class/Plugin.hs b/src/Mig/Core/Class/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/Mig/Core/Class/Plugin.hs @@ -0,0 +1,231 @@ +{-| Plugins are useful to apply certain action to all routes in the server. +For example we can add generic logger or authorization bazed on common query parameter +or field of the body request that contains token of the session. + +The downside is that we work on low level of Requesnce/Response as we have rendered +all routes to ServerFun. But thw good part of it is that we can add generic action +to every route. + +Let's consider a simple example of adding logger to lall routes: + + +> logRoutes :: Server IO -> Server IO +> logRoutes = applyPlugin $ \(PathInfo path) -> prependServerAction $ +> when (path /= ["favicon.ico"] && headMay path /= Just "static") $ do +> logRoute site (Text.intercalate "/" path) +> +> -- | Logs the route info +> logRoute :: Site -> Text -> IO () +> logRoute site route = do +> time <- getCurrentTime +> site.logInfo $ route <> " page visited at: " <> Text.pack (show time) + +Here we use instance of ToPlugin for `PathInfo` to read full path for any route +and we use this information in the logger. + +We have various instances for everything that we can query from the request +and we can use this information to transform the server functions inside the routes. + +The instances work in the same manner as route handlers we can use as many arguments as +we wish and we use typed wrappers to query specific part of the request. +Thus we gain type-safety and get convenient interface to request the various parts of request. +-} +module Mig.Core.Class.Plugin ( + -- * class + ToPlugin (..), + Plugin (..), + PluginFun, + toPlugin, + fromPluginFun, + ($:), + applyPlugin, + RawResponse (..), + + -- * specific plugins + prependServerAction, + appendServerAction, + processResponse, + whenSecure, + processNoResponse, +) where + +import Control.Monad.IO.Class +import Data.OpenApi (ToParamSchema (..), ToSchema (..)) +import Data.Proxy +import Data.String +import GHC.TypeLits +import Web.HttpApiData + +import Mig.Core.Class.MediaType +import Mig.Core.Class.Monad +import Mig.Core.Class.Response +import Mig.Core.Server +import Mig.Core.ServerFun +import Mig.Core.Types + +-- | Low-level plugin function. +type PluginFun m = ServerFun m -> ServerFun m + +{-| Plugin can convert all routes of the server. +It is wrapper on top of @ServerFun m -> ServerFun m@. +We can apply plugins to servers with @applyPlugin@ function +also plugin has Monoid instance which is like Monoid.Endo or functional composition @(.)@. +-} +data Plugin m = Plugin + { info :: RouteInfo -> RouteInfo + -- ^ update api schema + , run :: PluginFun m + -- ^ run the plugin + } + +instance Monoid (Plugin m) where + mempty = Plugin id id + +instance Semigroup (Plugin m) where + (<>) a b = Plugin (a.info . b.info) (a.run . b.run) + +-- | Infix operator for @applyPlugin@ +($:) :: forall f. (ToPlugin f) => f -> Server (MonadOf f) -> Server (MonadOf f) +($:) = applyPlugin + +-- | Applies plugin to all routes of the server. +applyPlugin :: forall f. (ToPlugin f) => f -> Server (MonadOf f) -> Server (MonadOf f) +applyPlugin a = mapRouteInfo (toPluginInfo @f) . mapServerFun (toPluginFun a) + +{-| Values that can represent a plugin. +We use various newtype-wrappers to query type-safe info from request. +-} +class (MonadIO (MonadOf f)) => ToPlugin f where + toPluginInfo :: RouteInfo -> RouteInfo + toPluginFun :: f -> ServerFun (MonadOf f) -> ServerFun (MonadOf f) + +-- | Convert plugin-like value to plugin. +toPlugin :: forall f. (ToPlugin f) => f -> Plugin (MonadOf f) +toPlugin a = Plugin (toPluginInfo @f) (toPluginFun a) + +-- identity +instance (MonadIO m) => ToPlugin (PluginFun m) where + toPluginInfo = id + toPluginFun = id + +instance (MonadIO m) => ToPlugin (Plugin m) where + toPluginInfo = id + toPluginFun = (.run) + +fromPluginFun :: (MonadIO m) => PluginFun m -> Plugin m +fromPluginFun = toPlugin + +-- path info +instance (ToPlugin a) => ToPlugin (PathInfo -> a) where + toPluginInfo = id + toPluginFun f = \fun -> withPathInfo (\path -> toPluginFun (f (PathInfo path)) fun) + +-- full path info +instance (ToPlugin a) => ToPlugin (FullPathInfo -> a) where + toPluginInfo = id + toPluginFun f = \fun -> withFullPathInfo (\path -> toPluginFun (f (FullPathInfo path)) fun) + +-- is secure +instance (ToPlugin a) => ToPlugin (IsSecure -> a) where + toPluginInfo = id + toPluginFun f = \fun -> \req -> (toPluginFun (f (IsSecure req.isSecure)) fun) req + +instance (ToPlugin a) => ToPlugin (RawRequest -> a) where + toPluginInfo = id + toPluginFun f = \fun -> \req -> (toPluginFun (f (RawRequest req)) fun) req + +-- | Read low-level response. Note that it does not affect the API schema +newtype RawResponse = RawResponse (Maybe Response) + +instance (ToPlugin a) => ToPlugin (RawResponse -> a) where + toPluginInfo = id + toPluginFun f = \fun -> \req -> do + resp <- fun req + (toPluginFun (f (RawResponse resp)) fun) req + +-- request body +instance (FromReqBody ty a, ToSchema a, ToPlugin b) => ToPlugin (Body ty a -> b) where + toPluginInfo = addBodyInfo @ty @a . toPluginInfo @b + toPluginFun f = \fun -> withBody @ty (\body -> toPluginFun (f (Body body)) fun) + +-- header +instance (FromHttpApiData a, ToParamSchema a, ToPlugin b, KnownSymbol sym) => ToPlugin (Header sym a -> b) where + toPluginInfo = addHeaderInfo @sym @a . toPluginInfo @b + toPluginFun f = \fun -> withHeader (getName @sym) (\a -> toPluginFun (f (Header a)) fun) + +-- optional header +instance (FromHttpApiData a, ToParamSchema a, ToPlugin b, KnownSymbol sym) => ToPlugin (OptionalHeader sym a -> b) where + toPluginInfo = addOptionalHeaderInfo @sym @a . toPluginInfo @b + toPluginFun f = \fun -> withOptionalHeader (getName @sym) (\a -> toPluginFun (f (OptionalHeader a)) fun) + +-- query +instance (FromHttpApiData a, ToParamSchema a, ToPlugin b, KnownSymbol sym) => ToPlugin (Query sym a -> b) where + toPluginInfo = addQueryInfo @sym @a . toPluginInfo @b + toPluginFun f = \fun -> withQuery (getName @sym) (\a -> toPluginFun (f (Query a)) fun) + +-- optional query +instance (FromHttpApiData a, ToParamSchema a, ToPlugin b, KnownSymbol sym) => ToPlugin (Optional sym a -> b) where + toPluginInfo = addOptionalInfo @sym @a . toPluginInfo @b + toPluginFun f = \fun -> withOptional (getName @sym) (\a -> toPluginFun (f (Optional a)) fun) + +-- capture +instance (FromHttpApiData a, ToParamSchema a, ToPlugin b, KnownSymbol sym) => ToPlugin (Capture sym a -> b) where + toPluginInfo = addCaptureInfo @sym @a . toPluginInfo @b + toPluginFun f = \fun -> withCapture (getName @sym) (\a -> toPluginFun (f (Capture a)) fun) + +-- query flag +instance (ToPlugin b, KnownSymbol sym) => ToPlugin (QueryFlag sym -> b) where + toPluginInfo = addQueryFlagInfo @sym . toPluginInfo @b + toPluginFun f = \fun -> withQueryFlag (getName @sym) (\a -> toPluginFun (f (QueryFlag a)) fun) + +--------------------------------------------- +-- specific plugins + +-- | Prepends action to the server +prependServerAction :: forall m. (MonadIO m) => m () -> Plugin m +prependServerAction act = toPlugin go + where + go :: ServerFun m -> ServerFun m + go f = \req -> do + act + f req + +-- | Post appends action to the server +appendServerAction :: forall m. (MonadIO m) => m () -> Plugin m +appendServerAction act = toPlugin go + where + go :: ServerFun m -> ServerFun m + go f = \req -> do + resp <- f req + act + pure resp + +-- | Applies transformation to the response +processResponse :: forall m. (MonadIO m) => (m (Maybe Response) -> m (Maybe Response)) -> Plugin m +processResponse act = toPlugin go + where + go :: ServerFun m -> ServerFun m + go f = \req -> do + act (f req) + +-- | Execute request only if it is secure (made with SSL connection) +whenSecure :: forall m. (MonadIO m) => Plugin m +whenSecure = toPlugin $ \(IsSecure isSecure) -> + processResponse (if isSecure then id else const (pure Nothing)) + +-- | Sets default response if server response with Nothing. If it can not handle the request. +processNoResponse :: forall m a. (MonadIO m, IsResp a) => m a -> Plugin m +processNoResponse defaultResponse = toPlugin go + where + go :: PluginFun m + go fun = \req -> do + mResp <- fun req + case mResp of + Just resp -> pure (Just resp) + Nothing -> Just . toResponse <$> defaultResponse + +--------------------------------------------- +-- utils + +getName :: forall sym a. (KnownSymbol sym, IsString a) => a +getName = fromString (symbolVal (Proxy @sym)) diff --git a/src/Mig/Core/Class/Response.hs b/src/Mig/Core/Class/Response.hs new file mode 100644 --- /dev/null +++ b/src/Mig/Core/Class/Response.hs @@ -0,0 +1,193 @@ +-- | Generic response +module Mig.Core.Class.Response ( + Resp (..), + RespOr (..), + IsResp (..), + badReq, + internalServerError, + notImplemented, + redirect, + setHeader, +) where + +import Data.Bifunctor +import Data.ByteString.Lazy qualified as BL +import Data.Kind +import Data.Text (Text) +import Data.Text.Encoding qualified as Text +import Network.HTTP.Media.RenderHeader (RenderHeader (..)) +import Network.HTTP.Types.Header (HeaderName, ResponseHeaders) +import Network.HTTP.Types.Status (Status, internalServerError500, notImplemented501, ok200, status302, status400) +import Web.HttpApiData + +import Mig.Core.Class.MediaType (AnyMedia, MediaType, ToMediaType (..), ToRespBody (..)) +import Mig.Core.Types.Http (Response, ResponseBody (..), noContentResponse) +import Mig.Core.Types.Http qualified as Response (Response (..)) +import Mig.Core.Types.Http qualified as Types + +-- | Response with info on the media-type encoded as type. +data Resp (media :: Type) a = Resp + { status :: Status + -- ^ response status + , headers :: ResponseHeaders + -- ^ response headers + , body :: Maybe a + -- ^ response body. Nothing means "no content" in the body + } + deriving (Show, Eq, Functor) + +-- | Response that can contain an error. The error is represented with left case of an @Either@-type. +newtype RespOr ty err a = RespOr {unRespOr :: Either (Resp ty err) (Resp ty a)} + deriving (Show, Eq, Functor) + +------------------------------------------------------------------------------------- +-- response class + +{-| Values that can be converted to low-level response. + +The repsonse value is usually one of two cases: + +* @Resp a@ -- for routes which always produce a value + +* @RespOr err a@ - for routes that can also produce an error or value. + +* @Response@ - low-level HTTP-response. +-} +class IsResp a where + -- | the type of response body value + type RespBody a :: Type + + -- | the type of an error + type RespError a :: Type + + -- | the media tpye of resp + type RespMedia a :: Type + + -- | Returns valid repsonse with 200 status + ok :: RespBody a -> a + + -- | Returns an error with given status + bad :: Status -> RespError a -> a + + -- | response with no content + noContent :: Status -> a + + -- | Add some header to the response + addHeaders :: ResponseHeaders -> a -> a + + -- | Get response headers + getHeaders :: a -> ResponseHeaders + + -- | Sets repsonse status + setStatus :: Status -> a -> a + + -- | Get response body + getRespBody :: a -> Maybe (RespBody a) + + -- | Get response error + getRespError :: a -> Maybe (RespError a) + + -- | Get response status + getStatus :: a -> Status + + -- | Set the media type of the response + setMedia :: MediaType -> a -> a + setMedia media = addHeaders [("Content-Type", renderHeader media)] + + -- | Reads the media type by response type + getMedia :: MediaType + + -- | Converts value to low-level response + toResponse :: a -> Response + +-- | Set header for response +setHeader :: (IsResp a, ToHttpApiData h) => HeaderName -> h -> a -> a +setHeader name val = addHeaders [(name, toHeader val)] + +instance (ToRespBody ty a) => IsResp (Resp ty a) where + type RespBody (Resp ty a) = a + type RespError (Resp ty a) = a + type RespMedia (Resp ty a) = ty + + ok = Resp ok200 [] . Just + bad status = Resp status [] . Just + addHeaders hs x = x{headers = x.headers <> hs} + getHeaders x = x.headers + noContent st = Resp st [] Nothing + setStatus st x = x{status = st} + getStatus x = x.status + getMedia = toMediaType @ty + getRespBody x = x.body + getRespError x + | x.status == ok200 = Nothing + | otherwise = x.body + + toResponse a = Response.Response a.status headers body + where + media = toMediaType @ty + headers = a.headers <> [("Content-Type", renderHeader media)] + body = RawResp media (maybe "" (toRespBody @ty) a.body) + +instance IsResp Response where + type RespBody Response = BL.ByteString + type RespError Response = BL.ByteString + type RespMedia Response = AnyMedia + + ok = Response.Response ok200 [] . RawResp "*/*" + bad st = Response.Response st [] . RawResp "*/*" + addHeaders hs x = x{Response.headers = x.headers <> hs} + noContent = noContentResponse + setStatus st x = x{Response.status = st} + getMedia = "*/*" + getStatus x = x.status + getHeaders x = x.headers + getRespBody x = case x.body of + RawResp _ res -> Just res + _ -> Nothing + getRespError x + | x.status == ok200 = Nothing + | otherwise = getRespBody x + + toResponse = id + + setMedia media = addHeaders [("Content-Type", renderHeader media)] . updateBody + where + updateBody response = response{Response.body = setBodyMedia response.body} + + setBodyMedia = \case + RawResp _ content -> RawResp media content + other -> other + +instance (ToRespBody ty err, ToRespBody ty a) => IsResp (RespOr ty err a) where + type RespBody (RespOr ty err a) = a + type RespError (RespOr ty err a) = err + type RespMedia (RespOr ty err a) = ty + + ok = RespOr . Right . Resp ok200 [] . Just + bad status = RespOr . Left . bad status + addHeaders hs = RespOr . bimap (addHeaders hs) (addHeaders hs) . unRespOr + noContent st = RespOr $ Right (noContent st) + setStatus st = RespOr . bimap (setStatus st) (setStatus st) . unRespOr + getMedia = toMediaType @ty + getStatus (RespOr x) = either (.status) (.status) x + getHeaders (RespOr x) = either (.headers) (headers) x + getRespBody (RespOr x) = either (const Nothing) (.body) x + getRespError (RespOr x) = either (.body) (const Nothing) x + + toResponse = either toResponse toResponse . unRespOr + +-- | Bad request. The @bad@ response with 400 status. +badReq :: (IsResp a) => RespError a -> a +badReq = bad status400 + +-- | Internal server error. The @bad@ response with 500 status. +internalServerError :: (IsResp a) => RespError a -> a +internalServerError = bad internalServerError500 + +-- | Not implemented route. The @bad@ response with 501 status. +notImplemented :: (IsResp a) => RespError a -> a +notImplemented = bad notImplemented501 + +-- | Redirect to url. It is @bad@ response with 302 status and set header of "Location" to a given URL. +redirect :: (IsResp a) => Text -> a +redirect url = addHeaders [("Location", Text.encodeUtf8 url)] $ noContent status302 diff --git a/src/Mig/Core/Class/Route.hs b/src/Mig/Core/Class/Route.hs new file mode 100644 --- /dev/null +++ b/src/Mig/Core/Class/Route.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- | Creation of routes from functions. A route is a handler function +-- for single path of the server. +module Mig.Core.Class.Route ( + Route (..), + ToRoute (..), + toRoute, +) where + +import Control.Monad.IO.Class +import Data.OpenApi (ToParamSchema (..), ToSchema (..)) +import Data.Proxy +import Data.String +import GHC.TypeLits +import Mig.Core.Class.MediaType +import Mig.Core.Class.Monad +import Mig.Core.Class.Response (IsResp (..)) +import Mig.Core.ServerFun +import Mig.Core.Types +import Web.HttpApiData + +{-| Values that represent routes. +A route is a function of arbitrary number of arguments. Where +each argument is one of the special newtype-wrappers that +read type-safe information from HTTP-request and return type of the route function +is a value of something convertible to HTTP-request. +-} +class (MonadIO (MonadOf a)) => ToRoute a where + -- | Update API info + toRouteInfo :: RouteInfo -> RouteInfo + + -- | Convert to route + toRouteFun :: a -> ServerFun (MonadOf a) + +-- | Route contains API-info and how to run it +data Route m = Route + { info :: RouteInfo + -- ^ definition of the API (to use it in OpenApi or clients) + , run :: ServerFun m + -- ^ how to run a server + } + +-- | converts route-like value to route. +toRoute :: forall a. (ToRoute a) => a -> Route (MonadOf a) +toRoute a = + Route + { info = toRouteInfo @a emptyRouteInfo + , run = toRouteFun a + } + +------------------------------------------------------------------------------------- +-- identity instances + +instance (MonadIO m) => ToRoute (Route m) where + toRouteInfo = id + toRouteFun = (.run) + +------------------------------------------------------------------------------------- +-- request inputs + +instance (ToSchema a, FromReqBody media a, ToRoute b) => ToRoute (Body media a -> b) where + toRouteInfo = addBodyInfo @media @a . toRouteInfo @b + toRouteFun f = withBody @media (toRouteFun . f . Body) + +instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToRoute (Query sym a -> b) where + toRouteInfo = addQueryInfo @sym @a . toRouteInfo @b + toRouteFun f = withQuery (getName @sym) (toRouteFun . f . Query) + +instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToRoute (Optional sym a -> b) where + toRouteInfo = addOptionalInfo @sym @a . toRouteInfo @b + toRouteFun f = withOptional (getName @sym) (toRouteFun . f . Optional) + +instance (ToRoute b, KnownSymbol sym) => ToRoute (QueryFlag sym -> b) where + toRouteInfo = addQueryFlagInfo @sym . toRouteInfo @b + toRouteFun f = withQueryFlag (getName @sym) (toRouteFun . f . QueryFlag) + +instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToRoute (Capture sym a -> b) where + toRouteInfo = addCaptureInfo @sym @a . toRouteInfo @b + toRouteFun f = withCapture (getName @sym) (toRouteFun . f . Capture) + +instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToRoute (Header sym a -> b) where + toRouteInfo = addHeaderInfo @sym @a . toRouteInfo @b + toRouteFun f = withHeader (getName @sym) (toRouteFun . f . Header) + +instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToRoute (OptionalHeader sym a -> b) where + toRouteInfo = addOptionalHeaderInfo @sym @a . toRouteInfo @b + toRouteFun f = withOptionalHeader (getName @sym) (toRouteFun . f . OptionalHeader) + +instance (ToRoute b) => ToRoute (PathInfo -> b) where + toRouteInfo = toRouteInfo @b + toRouteFun f = withPathInfo (toRouteFun . f . PathInfo) + +instance (ToRoute b) => ToRoute (FullPathInfo -> b) where + toRouteInfo = toRouteInfo @b + toRouteFun f = withFullPathInfo (toRouteFun . f . FullPathInfo) + +instance (ToRoute b) => ToRoute (RawRequest -> b) where + toRouteInfo = toRouteInfo @b + toRouteFun f = \req -> toRouteFun (f (RawRequest req)) req + +instance (ToRoute b) => ToRoute (IsSecure -> b) where + toRouteInfo = toRouteInfo @b + toRouteFun f = \req -> toRouteFun (f (IsSecure req.isSecure)) req + +------------------------------------------------------------------------------------- +-- outputs + +instance {-# OVERLAPPABLE #-} (MonadIO m, IsResp a, IsMethod method) => ToRoute (Send method m a) where + toRouteInfo = setMethod (toMethod @method) (getMedia @a) + toRouteFun (Send a) = sendResponse $ toResponse <$> a + +--------------------------------------------- +-- utils + +getName :: forall sym a. (KnownSymbol sym, IsString a) => a +getName = fromString (symbolVal (Proxy @sym)) diff --git a/src/Mig/Core/Class/Server.hs b/src/Mig/Core/Class/Server.hs new file mode 100644 --- /dev/null +++ b/src/Mig/Core/Class/Server.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- | To server class +module Mig.Core.Class.Server ( + (/.), + ToServer (..), + HasServer (..), + hoistServer, + fromReader, + fromReaderExcept, +) where + +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.Reader +import Data.Kind +import Data.Text (Text) +import Mig.Core.Api qualified as Api +import Mig.Core.Class.Monad +import Mig.Core.Class.Route +import Mig.Core.Server (Server (..), mapServerFun) +import Mig.Core.ServerFun (ServerFun) +import Mig.Core.Types + +infixr 4 /. + +{-| Constructs server which can handle given path. Example: + +> "api/v1/get/info" /. handleInfo + +For captures we use wild-cards: + +> "api/v1/get/info/*" /. handleInfo + +And handle info has capture argument: + +> handleInfo :: Capture "nameA" -> Get IO (Resp Json value) + +The name for the capture is derived from the type signature of the route handler. +Note that if capture is in the last position of the path we can omit wild cards. +The proper amount of captures will be derived from the type signature of the handler. +-} +(/.) :: (ToServer a) => Api.Path -> a -> Server (MonadOf a) +(/.) path api + | null path.unPath = toServer api + | otherwise = + case unServer (toServer api) of + Api.WithPath rest a -> go rest a + other -> go mempty other + where + go rest a = Server $ Api.WithPath (path <> rest) a + +-- | Values that can be converted to server +class ToServer a where + -- | Convert value to server + toServer :: a -> Server (MonadOf a) + +-- identity + +instance ToServer (Server m) where + toServer = id + +-- list +instance (ToServer a) => ToServer [a] where + toServer = foldMap toServer + +-- routes +instance {-# OVERLAPPABLE #-} (ToRoute a) => ToServer a where + toServer a = Server $ Api.HandleRoute (toRoute a) + +------------------------------------------------------------------------------------- + +-- | Map internal monad of the server +hoistServer :: (forall a. m a -> n a) -> Server m -> Server n +hoistServer f (Server server) = + Server $ fmap (\x -> Route x.info (f . x.run)) server + +{-| Class contains types which can be converted to IO-based server to run as with WAI-interface. + +We can run plain IO-servers and ReaderT over IO based servers. Readers can be wrapped in newtypes. +In that case we can derive automatically @HasServer@ instance. +-} +class (Monad m) => HasServer m where + type ServerResult m :: Type + renderServer :: Server m -> ServerResult m + +instance HasServer IO where + type ServerResult IO = Server IO + renderServer = id + +instance HasServer (ReaderT env IO) where + type ServerResult (ReaderT env IO) = env -> Server IO + renderServer server initEnv = fromReader initEnv server + +-- | Render reader server to IO-based server +fromReader :: env -> Server (ReaderT env IO) -> Server IO +fromReader env = hoistServer (flip runReaderT env) + +instance HasServer (ReaderT env (ExceptT Text IO)) where + type + ServerResult (ReaderT env (ExceptT Text IO)) = + env -> Server IO + + renderServer server initEnv = fromReaderExcept initEnv server + +-- | Render reader with expetT server to IO-based server +fromReaderExcept :: + forall env. + env -> + Server (ReaderT env (ExceptT Text IO)) -> + Server IO +fromReaderExcept env = mapServerFun (handle env) + where + handle :: env -> ServerFun (ReaderT env (ExceptT Text IO)) -> ServerFun IO + handle e f = \req -> + handleError <$> runExceptT (runReaderT (f req) e) + + handleError :: Either Text (Maybe Response) -> Maybe Response + handleError = \case + Right mResp -> mResp + Left err -> Just $ badRequest @Text err diff --git a/src/Mig/Core/OpenApi.hs b/src/Mig/Core/OpenApi.hs new file mode 100644 --- /dev/null +++ b/src/Mig/Core/OpenApi.hs @@ -0,0 +1,183 @@ +-- | Renders mig-servers as OpenApi schemas +module Mig.Core.OpenApi ( + toOpenApi, +) where + +import Control.Lens (at, (%~), (&), (.~), (?~)) +import Data.Aeson (ToJSON (..)) +import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap +import Data.HashSet.InsOrd qualified as Set +import Data.Monoid (Endo (..)) +import Data.OpenApi hiding (Server (..)) +import Data.Proxy +import Data.Text (Text) +import Data.Text qualified as Text +import Mig.Core.Api (Api) +import Mig.Core.Api qualified as Api +import Mig.Core.Class.Route (Route (..)) +import Mig.Core.Server (Server (..), fillCaptures) +import Mig.Core.Types.Info (IsRequired (..), RouteInfo) +import Mig.Core.Types.Info qualified as Info +import Network.HTTP.Types.Method +import Network.HTTP.Types.Status (Status (..)) + +addCapture :: Text -> OpenApi -> OpenApi +addCapture captureName = + prependPath ("{" <> Text.unpack captureName <> "}") + +-- | Reads OpenApi schema for a server +toOpenApi :: Server m -> OpenApi +toOpenApi (Server x) = fromApiInfo (fmap (.info) $ fillCaptures x) + +fromApiInfo :: Api RouteInfo -> OpenApi +fromApiInfo = \case + Api.Empty -> mempty + Api.Append a b -> fromApiInfo a <> fromApiInfo b + Api.WithPath (Api.Path path) a -> foldr withPath (fromApiInfo a) path + Api.HandleRoute route -> fromRoute route + +withPath :: Api.PathItem -> OpenApi -> OpenApi +withPath = \case + Api.StaticPath pathName -> prependPath (Text.unpack pathName) + Api.CapturePath captureName -> addCapture captureName + +fromRoute :: RouteInfo -> OpenApi +fromRoute routeInfo = + appEndo + (foldMap (Endo . fromRouteInput) routeInfo.inputs) + (fromRouteOutput routeInfo) + +fromRouteOutput :: RouteInfo -> OpenApi +fromRouteOutput routeInfo = + mempty + & components . schemas .~ defs + & paths . at "/" + ?~ ( mempty + & method + ?~ ( mempty + & at code + ?~ Inline + ( mempty + & content + .~ InsOrdHashMap.fromList + [(t, mempty & schema .~ mref) | t <- responseContentTypes] + & headers .~ responseHeaders + ) + & tags .~ Set.fromList routeInfo.tags + & summary .~ nonEmptyText routeInfo.summary + & description .~ nonEmptyText routeInfo.description + ) + ) + where + method = case routeInfo.method of + Just m | m == methodGet -> get + Just m | m == methodPost -> post + Just m | m == methodPut -> put + Just m | m == methodDelete -> delete + Just m | m == methodOptions -> options + Just m | m == methodHead -> head_ + Just m | m == methodPatch -> patch + Just m | m == methodTrace -> trace + _ -> mempty + + code = routeInfo.output.status.statusCode + + responseContentTypes = [routeInfo.output.media] + + -- TODO: is it always empty? + responseHeaders = Inline <$> mempty + + Info.SchemaDefs defs mref = routeInfo.output.schema + +fromRouteInput :: Info.Describe Info.RouteInput -> OpenApi -> OpenApi +fromRouteInput descInput base = case descInput.content of + Info.ReqBodyInput inputType bodySchema -> onRequestBody inputType bodySchema + Info.RawBodyInput -> base + Info.CaptureInput captureName captureSchema -> onCapture captureName captureSchema + Info.QueryInput isRequired queryName querySchema -> onQuery isRequired queryName querySchema + Info.QueryFlagInput queryName -> onQueryFlag queryName + Info.HeaderInput isRequired headerName headerSchema -> onHeader isRequired headerName headerSchema + where + onCapture = onParam addDefaultResponse404 ParamPath (IsRequired True) + + onQuery = onParam addDefaultResponse400 ParamQuery + + onHeader = onParam addDefaultResponse400 ParamHeader + + onParam defResponse paramType (IsRequired isRequired) paramName paramSchema = + base + & addParam param + & defResponse paramName + where + param = + mempty + & name .~ paramName + & description .~ (nonEmptyText =<< descInput.description) + & required ?~ isRequired + & in_ .~ paramType + & schema ?~ (Inline paramSchema) + + onRequestBody bodyInputType (Info.SchemaDefs defs ref) = + base + & addRequestBody reqBody + & addDefaultResponse400 "body" + & components . schemas %~ (<> defs) + where + reqBody = + (mempty :: RequestBody) + & description .~ (nonEmptyText =<< descInput.description) + & content .~ InsOrdHashMap.fromList [(t, mempty & schema .~ ref) | t <- [bodyContentType]] + + bodyContentType = bodyInputType + + onQueryFlag queryName = + base + & addParam param + & addDefaultResponse400 queryName + where + param = + mempty + & name .~ queryName + & in_ .~ ParamQuery + & allowEmptyValue ?~ True + & schema + ?~ ( Inline $ + (toParamSchema (Proxy :: Proxy Bool)) + & default_ ?~ toJSON False + ) + +------------------------------------------------------------------------------------- +-- openapi utils + +nonEmptyText :: Text -> Maybe Text +nonEmptyText txt + | Text.null txt = Nothing + | otherwise = Just txt + +-- | Add RequestBody to every operations in the spec. +addRequestBody :: RequestBody -> OpenApi -> OpenApi +addRequestBody rb = allOperations . requestBody ?~ Inline rb + +-- | Add parameter to every operation in the spec. +addParam :: Param -> OpenApi -> OpenApi +addParam param = allOperations . parameters %~ (Inline param :) + +addDefaultResponse404 :: ParamName -> OpenApi -> OpenApi +addDefaultResponse404 pname = setResponseWith (\old _new -> alter404 old) 404 (return response404) + where + sname = markdownCode pname + description404 = sname <> " not found" + alter404 = description %~ ((sname <> " or ") <>) + response404 = mempty & description .~ description404 + +addDefaultResponse400 :: ParamName -> OpenApi -> OpenApi +addDefaultResponse400 pname = setResponseWith (\old _new -> alter400 old) 400 (return response400) + where + sname = markdownCode pname + description400 = "Invalid " <> sname + alter400 = description %~ (<> (" or " <> sname)) + response400 = mempty & description .~ description400 + +-- | Format given text as inline code in Markdown. +markdownCode :: Text -> Text +markdownCode s = "`" <> s <> "`" diff --git a/src/Mig/Core/Server.hs b/src/Mig/Core/Server.hs new file mode 100644 --- /dev/null +++ b/src/Mig/Core/Server.hs @@ -0,0 +1,426 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- | Server definition +module Mig.Core.Server ( + Server (..), + FindRoute (..), + treeApiStrategy, + plainApiStrategy, + mapServerFun, + mapResponse, + fromServer, + fromServerWithCache, + fillCaptures, + addTag, + setDescription, + setSummary, + mapRouteInfo, + staticFiles, + describeInputs, + atPath, + filterPath, + getServerPaths, + addPathLink, +) where + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as BL +import Data.List qualified as List +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe +import Data.String +import Data.Text (Text) +import Data.Text qualified as Text +import Safe (atMay, headMay) +import System.FilePath (takeExtension) +import Web.HttpApiData + +import Mig.Core.Api (Api, fromNormalApi, toNormalApi) +import Mig.Core.Api qualified as Api +import Mig.Core.Api.NormalForm.TreeApi qualified as TreeApi +import Mig.Core.Class.MediaType +import Mig.Core.Class.Response (IsResp (..), Resp (..)) +import Mig.Core.Class.Route +import Mig.Core.Server.Cache +import Mig.Core.ServerFun (ServerFun) +import Mig.Core.Types (Request (..), Response, setContent) +import Mig.Core.Types.Info (RouteInfo (..), RouteInput (..), describeInfoInputs, setOutputMedia) +import Mig.Core.Types.Info qualified as Describe (Describe (..)) +import Mig.Core.Types.Route + +{-| Server type. It is a function fron request to response. +Some servers does not return valid value. We use it to find right path. + +Example: + +> server :: Server IO +> server = +> "api/v1" /. +> [ "foo" /. handleFoo +> , "bar" /. handleBar +> ] +> +> handleFoo :: Query "name" Int -> Get IO (Resp Json Text) +> handleBar :: Post Json IO Text + +Note that server is monoid and it can be constructed with Monoid functions and +path constructor @(/.)@. To pass inputs for handler we can use special newtype wrappers: + +* @Query@ - for required query parameters +* @Optional@ - for optional query parameters +* @QueryFlag@ - for boolean query flags +* @Capture@ - for parsing elements of URI +* @Header@ - for parsing headers +* @OptionalHeader@ - for parsing optional headers +* @Body@ - fot request-body input + +and other request types. + +To distinguish by HTTP-method we use corresponding constructors: Get, Post, Put, etc. +Let's discuss the structure of the constructor. Let's take Get for example: + +> type Get m a = Send GET m a +> newtype Send method m a = Send (m a) + + Let's look at the arguments of he type + +* @method@ - type tag of the HTTP-method (GET, POST, PUT, DELETE, etc.) +* @m@ - underlying server monad +* @a@ - response type. It should be convertible to the type of the response (see @IsResp@ class). +-} +newtype Server m = Server {unServer :: Api (Route m)} + deriving newtype (Semigroup, Monoid) + +-- | Applies server function to all routes +mapServerFun :: (ServerFun m -> ServerFun n) -> Server m -> Server n +mapServerFun f (Server server) = Server $ fmap (\x -> Route x.info (f x.run)) server + +-- | Mapps response of the server +mapResponse :: (Functor m) => (Response -> Response) -> Server m -> Server m +mapResponse f = mapServerFun $ \fun -> fmap (fmap f) . fun + +-- | API route finder strategy. The API can be transformed to some normal form +-- for faster route lookup. So far we have two normal forms. +-- One is plain Api type as it is. And another one is tree-structure +-- where path switches are encoded with Map's. +data FindRoute normalForm m = FindRoute + { toNormalForm :: Api (Route m) -> normalForm (Route m) + , getPath :: [Text] -> normalForm (Route m) -> Maybe (Route m, Api.CaptureMap) + } + +-- | Use TreeApi normal form. Path switches are encoded as Maps. +treeApiStrategy :: FindRoute TreeApi.TreeApi m +treeApiStrategy = + FindRoute + { toNormalForm = TreeApi.toTreeApi + , getPath = TreeApi.getPath + } + +-- | Use plain api type. Just Api type as it is. +plainApiStrategy :: FindRoute Api.Api m +plainApiStrategy = + FindRoute + { toNormalForm = id + , getPath = Api.getPath + } + +{-| Converts server to server function. Server function can be used to implement low-level handlers +in various server-libraries. +-} +fromServer :: forall m normalForm. (Monad m) => FindRoute normalForm m -> Server m -> ServerFun m +fromServer strategy (Server server) = \req -> do + case getRoute req of + Just (routes, captureMap) -> routes.run req{capture = captureMap} + Nothing -> pure Nothing + where + serverNormal = fmap strategy.toNormalForm $ toNormalApi (fillCaptures server) + + getRoute req = do + api <- fromNormalApi req.method (getMediaType "Accept" req) (getMediaType "Content-Type" req) serverNormal + strategy.getPath req.path api + + getMediaType name req = fromMaybe "*/*" $ Map.lookup name req.headers + +{-| Converts server to server function. Server function can be used to implement low-level handlers +in various server-libraries. This function also uses LRU-cache to cache fetching of +the routes +-} +fromServerWithCache :: forall m normalForm. (MonadIO m) => FindRoute normalForm m -> RouteCache m -> Server m -> ServerFun m +fromServerWithCache strategy cache (Server server) = \req -> do + mRoute <- liftIO $ withCache cache getRouteCache (getCacheKey req) + case mRoute of + Just (CacheValue captureMap routes) -> routes.run req{capture = captureMap} + Nothing -> pure Nothing + where + serverNormal = fmap strategy.toNormalForm $ toNormalApi (fillCaptures server) + + getRouteCache :: CacheKey -> Maybe (CacheValue m) + getRouteCache key = do + api <- fromNormalApi key.method key.outputType key.inputType serverNormal + uncurry (flip CacheValue) <$> strategy.getPath key.path api + +getCacheKey :: Request -> CacheKey +getCacheKey req = + CacheKey + { inputType = getMediaType "Content-Type" + , outputType = getMediaType "Accept" + , method = req.method + , path = req.path + } + where + getMediaType name = fromMaybe "*/*" $ Map.lookup name req.headers + +{-| Substitutes all stars * for corresponding names in captures +if there are more captures in the route than in the path it adds +additional captures from the route to the path +-} +fillCaptures :: Api (Route m) -> Api (Route m) +fillCaptures = go mempty 0 + where + go pathSoFar n = \case + Api.WithPath path api -> + let (pathNext, m) = goPath (pathSoFar <> path) n path api + in Api.WithPath pathNext (go (pathSoFar <> path) m api) + Api.Append a b -> Api.Append (go pathSoFar n a) (go pathSoFar n b) + Api.Empty -> Api.Empty + Api.HandleRoute a -> goRoute pathSoFar n a + + goPath :: Api.Path -> Int -> Api.Path -> Api (Route m) -> (Api.Path, Int) + goPath pathSoFar n (Api.Path path) api = case path of + [] -> (Api.Path path, n) + Api.CapturePath "*" : rest -> + let (nextRest, m) = goPath pathSoFar (n + 1) (Api.Path rest) api + in case getCaptureName n api of + Just name -> (Api.Path [Api.CapturePath name] <> nextRest, m) + Nothing -> error $ "No capture argument for start in path " <> Text.unpack (toUrlPiece pathSoFar) <> " at the index: " <> show n + a : rest -> + let (nextRest, m) = goPath pathSoFar n (Api.Path rest) api + in (Api.Path [a] <> nextRest, m) + + goRoute pathSoFar pathCaptureCount route + | missingCapturesCount > 0 = withMissingCaptures pathSoFar [pathCaptureCount .. routeCaptureCount - 1] (Api.HandleRoute route) + | otherwise = Api.HandleRoute route + where + missingCapturesCount = routeCaptureCount - pathCaptureCount + + routeCaptureCount = captureCount route.info + + withMissingCaptures pathSoFar indexes route = + Api.WithPath (Api.Path $ Api.CapturePath <$> names) route + where + names = + fromMaybe (error $ "Not enough captures at path: " <> Text.unpack (toUrlPiece pathSoFar)) $ + mapM (\index -> getCaptureName index route) indexes + + captureCount routeInfo = List.foldl' count 0 routeInfo.inputs + where + count res inp = case inp.content of + CaptureInput _ _ -> 1 + res + _ -> res + +getCaptureName :: Int -> Api (Route m) -> Maybe Text +getCaptureName index = \case + Api.Append a _b -> rec a + Api.Empty -> Nothing + Api.WithPath _ a -> rec a + Api.HandleRoute a -> mapMaybe (toCapture . Describe.content) a.info.inputs `atMay` index + where + rec = getCaptureName index + + toCapture :: RouteInput -> Maybe Text + toCapture = \case + CaptureInput name _ -> Just name + _ -> Nothing + +-- | Adds tag to the route +addTag :: Text -> Server m -> Server m +addTag tag = mapRouteInfo (insertTag tag) + +-- | Sets description of the route +setDescription :: Text -> Server m -> Server m +setDescription desc = mapRouteInfo $ \info -> info{description = desc} + +-- | Sets summary of the route +setSummary :: Text -> Server m -> Server m +setSummary val = mapRouteInfo $ \info -> info{summary = val} + +-- | Maps over route API-information +mapRouteInfo :: (RouteInfo -> RouteInfo) -> Server m -> Server m +mapRouteInfo f (Server srv) = Server $ fmap (\route -> route{info = f route.info}) srv + +-- | Adds OpenApi tag to the route +insertTag :: Text -> RouteInfo -> RouteInfo +insertTag tag info = info{tags = tag : info.tags} + +{-| Appends descriptiton for the inputs. It passes pairs for @(input-name, input-description)@. +special name request-body is dedicated to request body input +nd raw-input is dedicated to raw input +-} +describeInputs :: [(Text, Text)] -> Server m -> Server m +describeInputs descs = mapRouteInfo (describeInfoInputs descs) + +{-| Serves static files. The file path is a path to where to server the file. +The media-type is derived from the extension. There is a special case if we need +to server the file from the rooot of the server we can omit everything from the path +but keep extension. Otherwise it is not able to derive the media type. + +It is convenient to use it with function @embedRecursiveDir@ from the library @file-embed@ or @file-embed-lzma@. +-} +staticFiles :: forall m. (MonadIO m) => [(FilePath, ByteString)] -> Server m +staticFiles files = + Server $ foldMap (uncurry serveFile) files + where + serveFile path content = + unServer . mapRouteInfo (setOutputMedia media) . Server $ + ( if headMay path == Just '.' + then id + else ((fromString path) `Api.WithPath`) + ) + (Api.HandleRoute (toRoute (getFile media content))) + where + media = getMediaType path + + getFile :: MediaType -> ByteString -> Get m (Resp AnyMedia BL.ByteString) + getFile ty fileContent = + Send $ + pure $ + addHeaders (setContent ty) $ + ok $ + BL.fromStrict fileContent + + getMediaType :: FilePath -> MediaType + getMediaType path = + fromMaybe "application/octet-stream" $ + Map.lookup (takeExtension path) extToMimeMap + +extToMimeMap :: Map String MediaType +extToMimeMap = + Map.fromList + [ (".aac", "audio/aac") -- AAC audio + , (".abw", "application/x-abiword") -- AbiWord document + , (".arc", "application/x-freearc") -- Archive document (multiple files embedded) + , (".avif", "image/avif") -- AVIF image + , (".avi", "video/x-msvideo") -- AVI: Audio Video Interleave + , (".azw", "application/vnd.amazon.ebook") -- Amazon Kindle eBook format + , (".bin", "application/octet-stream") -- Any kind of binary data + , (".bmp", "image/bmp") -- Windows OS/2 Bitmap Graphics + , (".bz", "application/x-bzip") -- BZip archive + , (".bz2", "application/x-bzip2") -- BZip2 archive + , (".cda", "application/x-cdf") -- CD audio + , (".csh", "application/x-csh") -- C-Shell script + , (".css", "text/css") -- Cascading Style Sheets (CSS) + , (".csv", "text/csv") -- Comma-separated values (CSV) + , (".doc", "application/msword") -- Microsoft Word + , (".docx", "application/vnd.openxmlformats-officedocument.wordprocessingml.document") -- Microsoft Word (OpenXML) + , (".eot", "application/vnd.ms-fontobject") -- MS Embedded OpenType fonts + , (".epub", "application/epub+zip") -- Electronic publication (EPUB) + , (".gz", "application/gzip") -- GZip Compressed Archive + , (".gif", "image/gif") -- Graphics Interchange Format (GIF) + , (".htm", "text/html") -- , .html HyperText Markup Language (HTML) + , (".ico", "image/vnd.microsoft.icon") -- Icon format + , (".ics", "text/calendar") -- iCalendar format + , (".jar", "application/java-archive") -- Java Archive (JAR) + , (".jpeg", "image/jpeg") -- JPEG images + , (".jpg", "image/jpeg") -- JPEG images + , (".js", "text/javascript") -- JavaScript (Specifications: HTML and RFC 9239) + , (".json", "application/json") -- JSON format + , (".jsonld", "application/ld+json") -- JSON-LD format + , (".mid", "audio/midi") -- Musical Instrument Digital Interface (MIDI) , audio/x-midi + , (".midi", "audio/midi") -- Musical Instrument Digital Interface (MIDI) , audio/x-midi + , (".mjs", "text/javascript") -- JavaScript module + , (".mp3", "audio/mpeg") -- MP3 audio + , (".mp4", "video/mp4") -- MP4 video + , (".mpeg", "video/mpeg") -- MPEG Video + , (".mpkg", "application/vnd.apple.installer+xml") -- Apple Installer Package + , (".odp", "application/vnd.oasis.opendocument.presentation") -- OpenDocument presentation document + , (".ods", "application/vnd.oasis.opendocument.spreadsheet") -- OpenDocument spreadsheet document + , (".odt", "application/vnd.oasis.opendocument.text") -- OpenDocument text document + , (".oga", "audio/ogg") -- OGG audio + , (".ogv", "video/ogg") -- OGG video + , (".ogx", "application/ogg") -- OGG + , (".opus", "audio/opus") -- Opus audio + , (".otf", "font/otf") -- OpenType font + , (".png", "image/png") -- Portable Network Graphics + , (".pdf", "application/pdf") -- Adobe Portable Document Format (PDF) + , (".php", "application/x-httpd-php") -- Hypertext Preprocessor (Personal Home Page) + , (".ppt", "application/vnd.ms-powerpoint") -- Microsoft PowerPoint + , (".pptx", "application/vnd.openxmlformats-officedocument.presentationml.presentation") -- Microsoft PowerPoint (OpenXML) + , (".rar", "application/vnd.rar") -- RAR archive + , (".rtf", "application/rtf") -- Rich Text Format (RTF) + , (".sh", "application/x-sh") -- Bourne shell script + , (".svg", "image/svg+xml") -- Scalable Vector Graphics (SVG) + , (".tar", "application/x-tar") -- Tape Archive (TAR) + , (".tif", "image/tiff") -- Tagged Image File Format (TIFF) + , (".tiff", "image/tiff") -- Tagged Image File Format (TIFF) + , (".ts", "video/mp2t") -- MPEG transport stream + , (".ttf", "font/ttf") -- TrueType Font + , (".txt", "text/plain") -- Text, (generally ASCII or ISO 8859-n) + , (".vsd", "application/vnd.visio") -- Microsoft Visio + , (".wav", "audio/wav") -- Waveform Audio Format + , (".weba", "audio/webm") -- WEBM audio + , (".webm", "video/webm") -- WEBM video + , (".webp", "image/webp") -- WEBP image + , (".woff", "font/woff") -- Web Open Font Format (WOFF) + , (".woff2", "font/woff2") -- Web Open Font Format (WOFF) + , (".xhtml", "application/xhtml+xml") -- XHTML + , (".xls", "application/vnd.ms-excel") -- Microsoft Excel + , (".xlsx", "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet") -- Microsoft Excel (OpenXML) + , (".xml", "application/xml") -- XML is recommended as of RFC 7303 (section 4.1), but text/xml is still used sometimes. You can assign a specific MIME type to a file with .xml extension depending on how its contents are meant to be interpreted. For instance, an Atom feed is application/atom+xml, but application/xml serves as a valid default. + , (".xul", "application/vnd.mozilla.xul+xml") -- XUL + , (".zip", "application/zip") -- ZIP archive + , (".3gp", "video/3gpp") -- 3GPP audio/video container ; audio/3gpp if it doesn't contain video + , (".3g2", "video/3gpp2") -- 3GPP2 audio/video container ; audio/3gpp2 if it doesn't contain video + , (".7z", "application/x-7z-compressed") -- 7-zip archive + ] + +{- i wonder what is analog of this function? +-- | Handle errors +handleError ::(Exception a, MonadCatch m) => (a -> Server m) -> Server m -> Server m +handleError handler (Server act) = Server $ \req -> + (act req) `catch` (\err -> unServer (handler err) req) +-} + +{-| Sub-server for a server on given path +it might be usefule to emulate links from one route to another within the server +or reuse part of the server inside another server. +-} +atPath :: forall m. Api.Path -> Server m -> Server m +atPath rootPath rootServer = maybe mempty Server $ find rootPath rootServer.unServer + where + find :: Api.Path -> Api (Route m) -> Maybe (Api (Route m)) + find (Api.Path path) server = case path of + [] -> Just server + _ -> + case server of + Api.Empty -> Nothing + Api.HandleRoute _ -> Nothing + Api.Append a b -> find (Api.Path path) a <|> find (Api.Path path) b + Api.WithPath (Api.Path pathB) serverB -> + flip find serverB =<< matchPath pathB path + + matchPath :: [Api.PathItem] -> [Api.PathItem] -> Maybe Api.Path + matchPath prefix path = case prefix of + [] -> Just (Api.Path path) + prefixHead : prefixTail -> do + (pathHead, pathTail) <- List.uncons path + guard (prefixHead == pathHead) + matchPath prefixTail pathTail + +filterPath :: (Api.Path -> Bool) -> Server m -> Server m +filterPath cond (Server a) = + Server (Api.fromFlatApi $ filter (cond . fst) $ Api.flatApi a) + +-- | Returns a list of all paths in the server +getServerPaths :: Server m -> [Api.Path] +getServerPaths (Server a) = fmap fst $ Api.flatApi (fillCaptures a) + +{-| Links one route of the server to another +so that every call to first path is redirected to the second path +-} +addPathLink :: Api.Path -> Api.Path -> Server m -> Server m +addPathLink from to server = + server <> Server (Api.WithPath from (atPath to server).unServer) diff --git a/src/Mig/Core/Server/Cache.hs b/src/Mig/Core/Server/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Mig/Core/Server/Cache.hs @@ -0,0 +1,68 @@ +-- | LRU cache to speedup fetching of the route handler +module Mig.Core.Server.Cache ( + CacheConfig (..), + CacheKey (..), + CacheValue (..), + RouteCache (..), + newRouteCache, + withCache, +) where + +import Control.Monad +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import Data.Cache.LRU.IO (AtomicLRU) +import Data.Cache.LRU.IO qualified as Lru +import Data.Text (Text) +import Mig.Core.Api (CaptureMap) +import Mig.Core.Class.Route (Route) +import Network.HTTP.Types.Method (Method) + +-- | Cache config +data CacheConfig = CacheConfig + { size :: Int + -- ^ how many items are allowed in the cache + , cacheFilter :: CacheKey -> Bool + -- ^ which route to cache + } + +-- | Route key identidfies the single item for caching +data CacheKey = CacheKey + { inputType :: ByteString -- ^ value of "Content-Type" header + , outputType :: ByteString -- ^ value of "Accept" header + , method :: Method -- ^ http method + , path :: [Text] -- ^ path to route (includes inlined captures) + } + deriving (Show, Eq, Ord) + +-- | Cache value +data CacheValue m = CacheValue + { captures :: CaptureMap -- ^ extracted capture map from the path + , route :: Route m -- ^ route handler + } + +-- | Route cache +data RouteCache m = RouteCache + { cacheFilter :: CacheKey -> Bool + -- ^ which route to cache (if True the route is cached) + , cache :: AtomicLRU CacheKey (CacheValue m) + -- ^ cache map + } + +-- | Allocates new cache +newRouteCache :: CacheConfig -> IO (RouteCache m) +newRouteCache config = + RouteCache config.cacheFilter <$> Lru.newAtomicLRU (Just (fromIntegral config.size)) + +-- | Caches the function of route finder +withCache :: RouteCache m -> (CacheKey -> Maybe (CacheValue m)) -> CacheKey -> IO (Maybe (CacheValue m)) +withCache (RouteCache cacheFilter cache) f key = do + mCacheResult <- liftIO $ Lru.lookup key cache + case mCacheResult of + Just result -> pure (Just result) + Nothing -> do + case f key of + Just result -> do + when (cacheFilter key) $ Lru.insert key result cache + pure (Just result) + Nothing -> pure Nothing diff --git a/src/Mig/Core/ServerFun.hs b/src/Mig/Core/ServerFun.hs new file mode 100644 --- /dev/null +++ b/src/Mig/Core/ServerFun.hs @@ -0,0 +1,162 @@ +{-| Low-level server representarion. +The server is a function from @Request@ to @Response@. + +> type ServerFun m = Request -> m (Maybe Response) + +To use the mig library with some server library like wai/warp we need +to provide conversion of type @ServerFun@ to the representarion of the given library. +We can convert mig server to @ServerFun@ with function @fromServer@. +The @Maybe@ type in the result encodes missing routes. +-} +module Mig.Core.ServerFun ( + ServerFun, + sendResponse, + withBody, + withRawBody, + withQuery, + withQueryFlag, + withOptional, + withCapture, + withHeader, + withOptionalHeader, + withPathInfo, + withFullPathInfo, + handleServerError, +) where + +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as BL +import Data.CaseInsensitive qualified as CI +import Data.Either (fromRight) +import Data.Either.Extra (eitherToMaybe) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text.Encoding qualified as Text +import Mig.Core.Class.MediaType +import Mig.Core.Types +import Network.HTTP.Types.Header (HeaderName) +import Network.HTTP.Types.Status (status500) +import Web.HttpApiData + +{-| Low-level representation of the server. +Missing route for a given request returns @Nothing@. +-} +type ServerFun m = Request -> m (Maybe Response) + +-- | Reads request body. +withBody :: forall media a m. (MonadIO m, FromReqBody media a) => (a -> ServerFun m) -> ServerFun m +withBody f = withRawBody $ \val -> \req -> + case fromReqBody @media val of + Right v -> f v req + Left err -> pure $ Just $ badRequest @Text $ "Failed to parse request body: " <> err + +-- | Reads low-level request body as byte string +withRawBody :: (MonadIO m) => (BL.ByteString -> ServerFun m) -> ServerFun m +withRawBody act = \req -> do + eBody <- liftIO req.readBody + case eBody of + Right body -> act body req + Left err -> pure $ Just $ setRespStatus status500 (okResponse @Text err) + +-- | Reads required query parameter +withQuery :: (Monad m, FromHttpApiData a) => Text -> (a -> ServerFun m) -> ServerFun m +withQuery name act = withQueryBy (join . getQuery name) processResponse + where + processResponse = handleMaybeInput errorMessage act + + errorMessage = "Failed to parse arg: " <> name + +-- | Reads query flag +withQueryFlag :: Text -> (Bool -> ServerFun m) -> ServerFun m +withQueryFlag name act = \req -> + let val = + case getQuery name req of + Just (Just "") -> True + Just (Just arg) -> + case parseQueryParam @Bool arg of + Right flag -> flag + Left _ -> False + Just Nothing -> True -- we interpret empty value as True for a flag + Nothing -> False + in act val req + +{-| The first maybe means that query with that name is missing +the second maybe is weather value is present or empty in the query +-} +getQuery :: Text -> Request -> Maybe (Maybe Text) +getQuery name req = + case Map.lookup (Text.encodeUtf8 name) req.query of + Just mBs -> + case mBs of + Just bs -> either (pure Nothing) (Just . Just) $ Text.decodeUtf8' bs + Nothing -> Just Nothing + Nothing -> Nothing + +handleMaybeInput :: (Applicative m) => Text -> (a -> ServerFun m) -> (Maybe a -> ServerFun m) +handleMaybeInput message act = \case + Just arg -> \req -> act arg req + Nothing -> const $ pure $ Just $ badRequest @Text message + +-- | reads optional query parameter +withOptional :: (FromHttpApiData a) => Text -> (Maybe a -> ServerFun m) -> ServerFun m +withOptional name act = withQueryBy (join . getQuery name) act + +-- | Generic query parameter reader +withQueryBy :: + (FromHttpApiData a) => + (Request -> Maybe Text) -> + (Maybe a -> ServerFun m) -> + ServerFun m +withQueryBy getVal act = \req -> + let -- TODO: do not ignore parse failure + mArg = either (const Nothing) Just . parseQueryParam =<< getVal req + in act mArg req + +-- | Reads capture from the path +withCapture :: (Monad m, FromHttpApiData a) => Text -> (a -> ServerFun m) -> ServerFun m +withCapture name act = withQueryBy getVal processResponse + where + getVal req = Map.lookup name req.capture + + processResponse = handleMaybeInput errorMessage act + + errorMessage = "Failed to parse capture: " <> name + +-- | reads request header +withHeader :: (Monad m, FromHttpApiData a) => HeaderName -> (a -> ServerFun m) -> ServerFun m +withHeader name act = withQueryBy getVal processResponse + where + getVal req = eitherToMaybe . parseHeader =<< Map.lookup name req.headers + + processResponse = handleMaybeInput errorMessage act + + errorMessage = "Failed to parse header: " <> headerNameToText name + +headerNameToText :: CI.CI ByteString -> Text +headerNameToText name = fromRight "" $ Text.decodeUtf8' $ CI.original name + +-- | Reads optional request header +withOptionalHeader :: (FromHttpApiData a) => HeaderName -> (Maybe a -> ServerFun m) -> ServerFun m +withOptionalHeader name act = withQueryBy getVal act + where + getVal req = eitherToMaybe . parseHeader =<< Map.lookup name req.headers + +-- | Reads full path (without qury parameters) +withPathInfo :: ([Text] -> ServerFun m) -> ServerFun m +withPathInfo act = \req -> act req.path req + +-- | Reads full path (without qury parameters) +withFullPathInfo :: (Text -> ServerFun m) -> ServerFun m +withFullPathInfo act = \req -> act (toFullPath req) req + +-- | Runs response getter action and returns it for any input request +sendResponse :: (Functor m) => m Response -> ServerFun m +sendResponse act = const $ fmap Just act + +-- | Handle errors +handleServerError :: (Exception a, MonadCatch m) => (a -> ServerFun m) -> ServerFun m -> ServerFun m +handleServerError handler act = \req -> + (act req) `catch` (\err -> handler err req) diff --git a/src/Mig/Core/Types.hs b/src/Mig/Core/Types.hs new file mode 100644 --- /dev/null +++ b/src/Mig/Core/Types.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- | Core types and functions +module Mig.Core.Types ( + module X, +) where + +import Mig.Core.Types.Http as X +import Mig.Core.Types.Info as X +import Mig.Core.Types.Route as X diff --git a/src/Mig/Core/Types/Http.hs b/src/Mig/Core/Types/Http.hs new file mode 100644 --- /dev/null +++ b/src/Mig/Core/Types/Http.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- | Core types and functions for HTTP +module Mig.Core.Types.Http ( + -- * types + Request (..), + Response (..), + ResponseBody (..), + HeaderMap, + QueryMap, + ToText (..), + + -- * responses + okResponse, + badResponse, + badRequest, + setContent, + noContentResponse, + + -- * utils + setRespStatus, + addRespHeaders, + toFullPath, +) where + +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as BL +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.String +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Text.Lazy qualified as TL +import Mig.Core.Class.MediaType (MediaType, ToMediaType (..), ToRespBody (..)) +import Network.HTTP.Media.RenderHeader +import Network.HTTP.Types.Header (HeaderName, ResponseHeaders) +import Network.HTTP.Types.Method (Method) +import Network.HTTP.Types.Status (Status, ok200, status500) + +-- | Http response +data Response = Response + { status :: Status + -- ^ status + , headers :: ResponseHeaders + -- ^ headers + , body :: ResponseBody + -- ^ response body + } + deriving (Show, Eq) + +-- | Response with no content +noContentResponse :: Status -> Response +noContentResponse status = Response status [] (RawResp "*/*" "") + +-- | Http response body +data ResponseBody + = RawResp MediaType BL.ByteString + | FileResp FilePath + | StreamResp + deriving (Show, Eq) + +-- | Http request +data Request = Request + { path :: [Text] + -- ^ URI path + , query :: QueryMap + -- ^ query parameters + , capture :: CaptureMap + -- ^ capture from path + , headers :: HeaderMap + -- ^ request headers + , method :: Method + -- ^ request method + , readBody :: IO (Either Text BL.ByteString) + -- ^ lazy body reader. Error can happen if size is too big (configured on running the server) + , isSecure :: Bool + -- ^ was this request made over SSL connection + } + +-- | Headers as map +type HeaderMap = Map HeaderName ByteString + +-- | Captures as map +type CaptureMap = Map Text Text + +-- | Map of query parameters for fast-access +type QueryMap = Map ByteString (Maybe ByteString) + +-- | Bad request response +badRequest :: forall media a. (ToRespBody media a) => a -> Response +badRequest message = badResponse @media status500 message + +-- | Values convertible to lazy text +class ToText a where + toText :: a -> Text + +instance ToText TL.Text where + toText = TL.toStrict + +instance ToText Text where + toText = id + +instance ToText Int where + toText = Text.pack . show + +instance ToText Float where + toText = Text.pack . show + +instance ToText String where + toText = fromString + +{-# INLINE setContent #-} + +-- | Headers to set content type +setContent :: MediaType -> ResponseHeaders +setContent media = + [("Content-Type", renderHeader media)] + +-- | Sets response status +setRespStatus :: Status -> Response -> Response +setRespStatus status (Response _ headers body) = Response status headers body + +addRespHeaders :: ResponseHeaders -> Response -> Response +addRespHeaders headers (Response status hs body) = Response status (headers <> hs) body + +-- | Respond with ok 200-status +okResponse :: forall mime a. (ToRespBody mime a) => a -> Response +okResponse = Response ok200 (setContent media) . RawResp media . toRespBody @mime + where + media = toMediaType @mime + +-- | Bad response qith given status +badResponse :: forall mime a. (ToRespBody mime a) => Status -> a -> Response +badResponse status = Response status (setContent media) . RawResp media . toRespBody @mime + where + media = toMediaType @mime + +toFullPath :: Request -> Text +toFullPath req = Text.intercalate "/" req.path <> queries + where + queries + | Map.null req.query = mempty + | otherwise = "?" <> Text.intercalate "&" (fmap fromQuery (Map.toList req.query)) + + fromQuery (name, mVal) = case mVal of + Just val -> nameText <> "=" <> Text.decodeUtf8 val + Nothing -> nameText + where + nameText = Text.decodeUtf8 name diff --git a/src/Mig/Core/Types/Info.hs b/src/Mig/Core/Types/Info.hs new file mode 100644 --- /dev/null +++ b/src/Mig/Core/Types/Info.hs @@ -0,0 +1,215 @@ +-- | Types that describe route info. We use it to derive OpenApi schema or clients. +module Mig.Core.Types.Info ( + RouteInfo (..), + RouteInput (..), + Describe (..), + noDescription, + getInputType, + RouteOutput (..), + IsRequired (..), + OutputSchema, + InputSchema, + SchemaDefs (..), + emptySchemaDefs, + toSchemaDefs, + addRouteInput, + setOutputMedia, + setMethod, + emptyRouteInfo, + describeInfoInputs, + + -- * api updates + addBodyInfo, + addHeaderInfo, + addOptionalHeaderInfo, + addQueryInfo, + addQueryFlagInfo, + addOptionalInfo, + addCaptureInfo, +) where + +import Data.List.Extra (firstJust) +import Data.Map.Strict qualified as Map +import Data.OpenApi +import Data.OpenApi.Declare (runDeclare) +import Data.Proxy +import Data.String +import Data.Text (Text) +import GHC.TypeLits +import Mig.Core.Class.MediaType +import Network.HTTP.Types.Method +import Network.HTTP.Types.Status + +-- | Information on route +data RouteInfo = RouteInfo + { method :: Maybe Method + -- ^ http method + , inputs :: [Describe RouteInput] + -- ^ route inputs + , output :: RouteOutput + -- ^ route outputs + , tags :: [Text] + -- ^ open-api tags + , description :: Text + -- ^ open-api description + , summary :: Text + -- ^ open-api summary + } + deriving (Show, Eq) + +newtype IsRequired = IsRequired Bool + deriving newtype (Show, Eq) + +-- | Values which have human-readable description. +data Describe a = Describe + { description :: Maybe Text + , content :: a + } + deriving (Show, Eq) + +-- | no description provided +noDescription :: a -> Describe a +noDescription = Describe Nothing + +{-| Appends descriptiton for the info +special name request-body is dedicated to request body input +nd raw-input is dedicated to raw input +-} +describeInfoInputs :: [(Text, Text)] -> RouteInfo -> RouteInfo +describeInfoInputs descs routeInfo = routeInfo{inputs = fmap addDesc routeInfo.inputs} + where + addDesc inp = + Describe (Map.lookup (getInputName inp) descMap) inp.content + + getInputName inp = + case inp.content of + ReqBodyInput _ _ -> "request-body" + RawBodyInput -> "raw-input" + CaptureInput captureName _ -> captureName + QueryInput _ queryName _ -> queryName + QueryFlagInput queryName -> queryName + HeaderInput _ headerName _ -> headerName + + descMap = Map.fromList descs + +-- | Route inputs +data RouteInput + = ReqBodyInput MediaType SchemaDefs + | RawBodyInput + | CaptureInput Text Schema + | QueryInput IsRequired Text Schema + | QueryFlagInput Text + | HeaderInput IsRequired Text Schema + deriving (Show, Eq) + +-- | Get input media-type +getInputType :: RouteInfo -> Maybe MediaType +getInputType route = firstJust (fromInput . (.content)) route.inputs + where + fromInput = \case + ReqBodyInput ty _ -> Just ty + _ -> Nothing + +-- | Input schema +type InputSchema = SchemaDefs + +-- | Route output +data RouteOutput = RouteOutput + { status :: Status + -- ^ http status + , media :: MediaType + -- ^ media type + , schema :: OutputSchema + -- ^ open-api schema + } + deriving (Show, Eq) + +-- | Output schema +type OutputSchema = SchemaDefs + +-- | Schem definition with references to the used sub-values +data SchemaDefs = SchemaDefs + { defs :: Definitions Schema + , ref :: Maybe (Referenced Schema) + } + deriving (Show, Eq) + +-- | Create schema definition +toSchemaDefs :: forall a. (ToSchema a) => SchemaDefs +toSchemaDefs = + SchemaDefs defs (Just ref) + where + (defs, ref) = runDeclare (declareSchemaRef (Proxy @a)) mempty + +-- | An empty schema definition +emptySchemaDefs :: SchemaDefs +emptySchemaDefs = SchemaDefs mempty Nothing + +-- | Add route input to route info list of inputs +addRouteInput :: RouteInput -> RouteInfo -> RouteInfo +addRouteInput inp = addRouteInputWithDescriptiton (noDescription inp) + +-- | Adds route input with description +addRouteInputWithDescriptiton :: Describe RouteInput -> RouteInfo -> RouteInfo +addRouteInputWithDescriptiton inp routeInfo = + routeInfo{inputs = inp : routeInfo.inputs} + +{-| Default empty route info. We update it as we construct the route with type-safe DSL. +Almost all values are derived from type signatures +-} +emptyRouteInfo :: RouteInfo +emptyRouteInfo = + RouteInfo Nothing [] (RouteOutput ok200 "*/*" emptySchemaDefs) [] "" "" + +-- | Set http-method of the route +setMethod :: Method -> MediaType -> RouteInfo -> RouteInfo +setMethod method mediaType routeInfo = + routeInfo + { method = Just method + , output = RouteOutput routeInfo.output.status mediaType emptySchemaDefs + } + +-- | Set output meida-type for the route +setOutputMedia :: MediaType -> RouteInfo -> RouteInfo +setOutputMedia mediaType routeInfo = + routeInfo{output = setMedia routeInfo.output} + where + setMedia outp = outp{media = mediaType} + +-- | Add parameter to the inputs of the route +addParamInfoBy :: forall sym a. (KnownSymbol sym, ToParamSchema a) => (Text -> Schema -> RouteInput) -> RouteInfo -> RouteInfo +addParamInfoBy cons = addRouteInput (cons (getName @sym) (toParamSchema (Proxy @a))) + +-- | Adds required header info to API schema +addHeaderInfo :: forall sym a. (KnownSymbol sym, ToParamSchema a) => RouteInfo -> RouteInfo +addHeaderInfo = addParamInfoBy @sym @a (HeaderInput (IsRequired True)) + +-- | Adds optional header info to API schema +addOptionalHeaderInfo :: forall sym a. (KnownSymbol sym, ToParamSchema a) => RouteInfo -> RouteInfo +addOptionalHeaderInfo = addParamInfoBy @sym @a (HeaderInput (IsRequired False)) + +-- | Adds required query info to API schema +addQueryInfo :: forall sym a. (KnownSymbol sym, ToParamSchema a) => RouteInfo -> RouteInfo +addQueryInfo = addParamInfoBy @sym @a (QueryInput (IsRequired True)) + +-- | Adds optional query info to API schema +addOptionalInfo :: forall sym a. (KnownSymbol sym, ToParamSchema a) => RouteInfo -> RouteInfo +addOptionalInfo = addParamInfoBy @sym @a (QueryInput (IsRequired False)) + +-- | Adds capture info to API schema +addCaptureInfo :: forall sym a. (KnownSymbol sym, ToParamSchema a) => RouteInfo -> RouteInfo +addCaptureInfo = addParamInfoBy @sym @a CaptureInput + +-- | Adds query flag to API schema +addQueryFlagInfo :: forall sym. (KnownSymbol sym) => RouteInfo -> RouteInfo +addQueryFlagInfo = addRouteInput (QueryFlagInput (getName @sym)) + +-- | Adds request body to API schema +addBodyInfo :: forall ty a. (ToMediaType ty, ToSchema a) => RouteInfo -> RouteInfo +addBodyInfo = addRouteInput (ReqBodyInput (toMediaType @ty) (toSchemaDefs @a)) + +--------------------------------------------- +-- utils + +getName :: forall sym a. (KnownSymbol sym, IsString a) => a +getName = fromString (symbolVal (Proxy @sym)) diff --git a/src/Mig/Core/Types/Route.hs b/src/Mig/Core/Types/Route.hs new file mode 100644 --- /dev/null +++ b/src/Mig/Core/Types/Route.hs @@ -0,0 +1,209 @@ +-- | Newtype wrappers for route DSL +module Mig.Core.Types.Route ( + -- * inputs + Body (..), + Query (..), + QueryFlag (..), + Optional (..), + Capture (..), + Header (..), + OptionalHeader (..), + PathInfo (..), + FullPathInfo (..), + RawRequest (..), + IsSecure (..), + + -- * outputs + Send (..), + Get, + Post, + Put, + Delete, + Options, + Head, + Patch, + Trace, + + -- ** Method tags + IsMethod (..), + GET, + POST, + PUT, + DELETE, + OPTIONS, + HEAD, + PATCH, + TRACE, +) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.Text (Text) +import GHC.TypeLits +import Network.HTTP.Types.Method + +import Mig.Core.Types.Http (Request) + +------------------------------------------------------------------------------------- +-- inputs + +-- | Generic case for request body. The type encodes a media type and value of the request body. +newtype Body media a = Body a + +{-| Required URL parameter query. + +> "api/route?foo=bar" ==> (Query bar) :: Query "foo" a +-} +newtype Query (sym :: Symbol) a = Query a + +{-| Optional URL parameter query. + +> "api/route?foo=bar" ==> (Optional maybeBar) :: Query "foo" a +-} +newtype Optional (sym :: Symbol) a = Optional (Maybe a) + +{-| Query flag. It is a boolean value in the URL-query. If it is missing +it is @False@ if it is in the query but does not have any value it is @True@. +Also it can have values @true/false@ in the query. +-} +newtype QueryFlag (sym :: Symbol) = QueryFlag Bool + +{-| Argument of capture from the query. + +> "api/route/{foo} if api/route/bar passed" ==> (Capture bar) :: Capture "Foo" barType +-} +newtype Capture (sym :: Symbol) a = Capture a + +{-| Reads value from the required header by name. For example if the request has header: + +> "foo": "bar" + +It reads the value: + +> (Header bar) :: Header "foo" barType +-} +newtype Header (sym :: Symbol) a = Header a + +{-| Reads value from the optional header by name. For example if the request has header: + +> "foo": "bar" + +It reads the value: + +> (OptionalHeader (Just bar)) :: OptionalHeader "foo" barType +-} +newtype OptionalHeader (sym :: Symbol) a = OptionalHeader (Maybe a) + +{-| Reads current path info. + +> "api/foo/bar" ==> PathInfo ["foo", "bar"] +-} +newtype PathInfo = PathInfo [Text] + +{-| Reads current full-path info with queries. + +> "api/foo/bar?param=value" ==> FullPathInfo "api/foo/bar?param=value" +-} +newtype FullPathInfo = FullPathInfo Text + +-- | Read low-level request. Note that it does not affect the API schema +newtype RawRequest = RawRequest Request + +-- | Reads info on weather the connection is secure (made over SSL). +newtype IsSecure = IsSecure Bool + +------------------------------------------------------------------------------------- +-- outputs + +{-| Route response type. It encodes the route method in the type +and which monad is used and which type the response has. + +The repsonse value is usually one of two cases: + +* @Resp media a@ -- for routes which always produce a value + +* @RespOr media err a@ - for routes that can also produce an error or value. + +See the class @IsResp@ for more details on response types. +-} +newtype Send method m a = Send {unSend :: m a} + deriving newtype (Functor, Applicative, Monad, MonadIO) + +instance MonadTrans (Send method) where + lift = Send + +-- | type-level GET-method tag +data GET + +-- | type-level POST-method tag +data POST + +-- | type-level PUT-method tag +data PUT + +-- | type-level DELETE-method tag +data DELETE + +-- | type-level OPTIONS-method tag +data OPTIONS + +-- | type-level HEAD-method tag +data HEAD + +-- | type-level PATCH-method tag +data PATCH + +-- | type-level TRACE-method tag +data TRACE + +-- | Get request +type Get m a = Send GET m a + +-- | Post request +type Post m a = Send POST m a + +-- | Put request +type Put m a = Send PUT m a + +-- | Delete request +type Delete m a = Send DELETE m a + +-- | Options request +type Options m a = Send OPTIONS m a + +-- | Head request +type Head m a = Send HEAD m a + +-- | Path request +type Patch m a = Send PATCH m a + +-- | trace request +type Trace m a = Send TRACE m a + +-- | Converts type-level tag for methods to value +class IsMethod a where + toMethod :: Method + +instance IsMethod GET where + toMethod = methodGet + +instance IsMethod POST where + toMethod = methodPost + +instance IsMethod PUT where + toMethod = methodPut + +instance IsMethod DELETE where + toMethod = methodDelete + +instance IsMethod OPTIONS where + toMethod = methodOptions + +instance IsMethod HEAD where + toMethod = methodHead + +instance IsMethod PATCH where + toMethod = methodPatch + +instance IsMethod TRACE where + toMethod = methodTrace diff --git a/src/Mig/Html.hs b/src/Mig/Html.hs deleted file mode 100644 --- a/src/Mig/Html.hs +++ /dev/null @@ -1,64 +0,0 @@ --- | Module for HTML-based servers -module Mig.Html - ( - -- * methods - Get (..) - , Post (..) - , Put (..) - , Delete (..) - , Patch (..) - , Options (..) - - -- * common - -- | Common re-exports - , module X - ) where - -import Mig.Common as X -import Mig.Internal.Types (toMethod) -import Network.HTTP.Types.Method - --- Get - --- | Get method. Note that we can not use body input with Get-method, use Post for that. --- So with Get we can use only URI inputs (Query, Optional, Capture) -newtype Get m a = Get (m a) - -instance (Monad m, ToHtmlResp a) => ToServer (Get m a) where - type ServerMonad (Get m a) = m - toServer (Get act) = toMethod methodGet (toHtmlResp <$> act) - --- | Post method -newtype Post m a = Post (m a) - -instance (Monad m, ToHtmlResp a) => ToServer (Post m a) where - type ServerMonad (Post m a) = m - toServer (Post act) = toMethod methodPost (toHtmlResp <$> act) - --- | Put method -newtype Put m a = Put (m a) - -instance (Monad m, ToHtmlResp a) => ToServer (Put m a) where - type ServerMonad (Put m a) = m - toServer (Put act) = toMethod methodPut (toHtmlResp <$> act) - --- | Delete method -newtype Delete m a = Delete (m a) - -instance (Monad m, ToHtmlResp a) => ToServer (Delete m a) where - type ServerMonad (Delete m a) = m - toServer (Delete act) = toMethod methodDelete (toHtmlResp <$> act) - --- | Patch method -newtype Patch m a = Patch (m a) - -instance (Monad m, ToHtmlResp a) => ToServer (Patch m a) where - type ServerMonad (Patch m a) = m - toServer (Patch act) = toMethod methodPatch (toHtmlResp <$> act) - --- | Options method -newtype Options m a = Options (m a) - -instance (Monad m, ToHtmlResp a) => ToServer (Options m a) where - type ServerMonad (Options m a) = m - toServer (Options act) = toMethod methodOptions (toHtmlResp <$> act) diff --git a/src/Mig/Html/IO.hs b/src/Mig/Html/IO.hs deleted file mode 100644 --- a/src/Mig/Html/IO.hs +++ /dev/null @@ -1,64 +0,0 @@ --- | Module for HTML-based servers -module Mig.Html.IO - ( - -- * methods - Get (..) - , Post (..) - , Put (..) - , Delete (..) - , Patch (..) - , Options (..) - - -- * common - -- | Common re-exports - , module X - ) where - -import Mig.Common as X -import Mig.Internal.Types (toMethod) -import Network.HTTP.Types.Method - --- Get - --- | Get method. Note that we can not use body input with Get-method, use Post for that. --- So with Get we can use only URI inputs (Query, Optional, Capture) -newtype Get a = Get (IO a) - -instance (ToHtmlResp a) => ToServer (Get a) where - type ServerMonad (Get a) = IO - toServer (Get act) = toMethod methodGet (toHtmlResp <$> act) - --- | Post method -newtype Post a = Post (IO a) - -instance (ToHtmlResp a) => ToServer (Post a) where - type ServerMonad (Post a) = IO - toServer (Post act) = toMethod methodPost (toHtmlResp <$> act) - --- | Put method -newtype Put a = Put (IO a) - -instance (ToHtmlResp a) => ToServer (Put a) where - type ServerMonad (Put a) = IO - toServer (Put act) = toMethod methodPut (toHtmlResp <$> act) - --- | Delete method -newtype Delete a = Delete (IO a) - -instance (ToHtmlResp a) => ToServer (Delete a) where - type ServerMonad (Delete a) = IO - toServer (Delete act) = toMethod methodDelete (toHtmlResp <$> act) - --- | Patch method -newtype Patch a = Patch (IO a) - -instance (ToHtmlResp a) => ToServer (Patch a) where - type ServerMonad (Patch a) = IO - toServer (Patch act) = toMethod methodPatch (toHtmlResp <$> act) - --- | Options method -newtype Options a = Options (IO a) - -instance (ToHtmlResp a) => ToServer (Options a) where - type ServerMonad (Options a) = IO - toServer (Options act) = toMethod methodOptions (toHtmlResp <$> act) diff --git a/src/Mig/Internal/Types.hs b/src/Mig/Internal/Types.hs deleted file mode 100644 --- a/src/Mig/Internal/Types.hs +++ /dev/null @@ -1,384 +0,0 @@ --- | Internal types and functions -module Mig.Internal.Types - ( -- * types - Server (..) - , Req (..) - , Resp (..) - , RespBody (..) - , QueryMap - , ToText (..) - , Error (..) - -- * constructors - , toConst - , toMethod - , toWithBody - , toWithCapture - , toWithPath - , toWithHeader - , toWithFormData - , toWithPathInfo - -- * responses - , text - , json - , html - , raw - , ok - , badRequest - , setContent - -- * WAI - , ServerConfig (..) - , Kilobytes - , toApplication - -- * utils - , setRespStatus - , handleError - , toResponse - , fromRequest - , pathHead - ) where - -import Data.Bifunctor -import Data.String -import Data.Text (Text) -import Data.Text qualified as Text -import Data.Text.Lazy qualified as TL -import Data.Aeson (ToJSON) -import Data.Aeson qualified as Json -import Data.ByteString (ByteString) -import Data.ByteString qualified as B -import Data.ByteString.Lazy qualified as BL -import Text.Blaze.Html (Html) -import Text.Blaze.Html (ToMarkup) -import Text.Blaze.Html qualified as Html -import Network.HTTP.Types.Method (Method) -import Network.HTTP.Types.Header (ResponseHeaders, RequestHeaders, HeaderName) -import Network.HTTP.Types.Status (Status, ok200, status500, status413) -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Text.Encoding qualified as Text -import Data.List qualified as List -import Network.Wai -import Text.Blaze.Renderer.Utf8 qualified as Html -import Data.Maybe -import Data.Sequence (Seq (..), (|>)) -import Data.Sequence qualified as Seq -import Data.Foldable -import Control.Monad.IO.Class -import Control.Monad.Catch -import Data.Typeable -import Web.FormUrlEncoded -import Web.HttpApiData -import Data.Either (fromRight) -import Data.CaseInsensitive qualified as CI - --- | Http response -data Resp = Resp - { status :: Status - -- ^ status - , headers :: ResponseHeaders - -- ^ headers - , body :: RespBody - -- ^ response body - } - -instance IsString Resp where - fromString = text . TL.pack - --- | Http response body -data RespBody - = TextResp Text - | HtmlResp Html - | JsonResp Json.Value - | FileResp FilePath - | StreamResp - | RawResp BL.ByteString - --- | Http request -data Req = Req - { path :: [Text] - -- ^ URI path - , query :: QueryMap - -- ^ query parameters - , headers :: RequestHeaders - -- ^ request headers - , method :: Method - -- ^ request method - , readBody :: IO (Either (Error Text) BL.ByteString) - -- ^ lazy body reader. Error can happen if size is too big (configured on running the server) - } - --- Errors - --- | Errors -data Error a = Error - { status :: Status - -- error status - , body :: a - -- message or error details - } - deriving (Show) - -instance (Typeable a, Show a) => Exception (Error a) where - --- | Map of query parameters for fast-access -type QueryMap = Map ByteString ByteString - --- | Bad request response -badRequest :: Text -> Resp -badRequest message = - Resp - { status = status500 - , headers = setContent "text/plain" - , body = TextResp message - } - --- | Server type. It is a function fron request to response. --- Some servers does not return valid value. We use it to find right path. --- --- Example: --- --- > server :: Server IO --- > server = --- > "api" /. "v1" /. --- > mconcat --- > [ "foo" /. (\(Query @"name" arg) -> Get @Json (handleFoo arg) --- > , "bar" /. Post @Json handleBar --- > ] --- > --- > handleFoo :: Int -> IO Text --- > handleBar :: IO Text --- --- Note that server is monoid and it can be constructed with Monoid functions and --- path constructor @(/.)@. To pass inputs for handler we can use special newtype wrappers: --- --- * @Query@ - for required query parameters --- * @Optional@ - for optional query parameters --- * @Capture@ - for parsing elements of URI --- * @Body@ - fot JSON-body input --- * @RawBody@ - for raw ByteString input --- * @Header@ - for headers --- --- To distinguish by HTTP-method we use corresponding constructors: Get, Post, Put, etc. --- Let's discuss the structure of the constructor. Let's take Get for example: --- --- > newtype Get ty m a = Get (m a) --- --- Let's look at the arguments of he type --- --- * @ty@ - type of the response. it can be: Text, Html, Json, ByteString --- * @m@ - underlying server monad --- * @a@ - result type. It should be convertible to the type of the response. --- --- also result can be wrapped to special data types to modify Http-response. --- we have wrappers: --- --- * @SetStatus@ - to set status --- * @AddHeaders@ - to append headers --- * @Either (Error err)@ - to response with errors -newtype Server m = Server { unServer :: Req -> m (Maybe Resp) } - --- | Replies to any http-method -toConst :: Functor m => m Resp -> Server m -toConst act = Server $ const $ Just <$> act - --- | Specify which method to reply -toMethod :: Monad m => Method -> m Resp -> Server m -toMethod method act = Server $ checkMethod method act - -checkMethod :: Monad m => Method -> m Resp -> Req -> m (Maybe Resp) -checkMethod method act req - | null req.path && req.method == method = Just <$> act - | otherwise = pure Nothing - --- | Reads full body as lazy bytestring -toWithBody :: MonadIO m => (BL.ByteString -> Server m) -> Server m -toWithBody act = Server $ \req -> do - eBody <- liftIO req.readBody - case eBody of - Right body -> unServer (act body) req - Left err -> pure $ Just $ setRespStatus err.status (text err.body) - --- | Reads URL-encoded form data -toWithFormData :: (FromForm a, MonadIO m) => (a -> Server m) -> Server m -toWithFormData act = Server $ \req -> do - eBody <- first (\(Error _ details) -> details) <$> liftIO req.readBody - case eBody >>= urlDecodeForm >>= fromForm of - Right a -> unServer (act a) req - Left err -> pure $ Just $ setRespStatus status413 $ badRequest err - --- | Size of the input body -type Kilobytes = Int - --- | Read request body in chunks -readRequestBody :: IO B.ByteString -> Maybe Kilobytes -> IO (Either (Error Text) [B.ByteString]) -readRequestBody readChunk maxSize = loop 0 Seq.empty - where - loop :: Kilobytes -> Seq B.ByteString -> IO (Either (Error Text) [B.ByteString]) - loop !currentSize !result - | isBigger currentSize = pure outOfSize - | otherwise = do - chunk <- readChunk - if B.null chunk - then pure $ Right (toList result) - else loop (currentSize + B.length chunk) (result |> chunk) - - outOfSize :: Either (Error Text) a - outOfSize = Left (Error status413 (Text.pack $ "Request is too big Jim!")) - - isBigger = case maxSize of - Just size -> \current -> current > size - Nothing -> const False - --- | Match path prefix -toWithPath :: Monad m => Text -> Server m -> Server m -toWithPath route act = Server $ \req -> - case hasPath route req.path of - Just restPath -> unServer act (req { path = restPath }) - _ -> pure Nothing - -type Path = [Text] - -hasPath :: Text -> Path -> Maybe Path -hasPath route (path:restPath) - | route == path = Just restPath - | otherwise = Nothing -hasPath _ _ = Nothing - --- | Reads capture URL-piece element -toWithCapture :: Monad m => (Text -> Server m) -> Server m -toWithCapture act = Server $ \req -> - case pathHead req of - Just (arg, nextReq) -> unServer (act arg) nextReq - Nothing -> pure Nothing - --- | Match on path prefix -pathHead :: Req -> Maybe (Text, Req) -pathHead req = - case req.path of - hd : tl -> Just (hd, req { path = tl }) - _ -> Nothing - --- | Read info from header -toWithHeader :: (Monad m, FromHttpApiData a) => HeaderName -> (Maybe a -> Server m) -> Server m -toWithHeader name act = Server $ \req -> - case fmap snd $ List.find ((== name) . fst) req.headers of - Just bs -> - case parseHeader bs of - Right val -> unServer (act (Just val)) req - Left err -> pure $ Just $ badRequest (errMessage err) - Nothing -> unServer (act Nothing) req - where - errMessage :: Text -> Text - errMessage err = "Failed to parse header " <> (fromRight "" $ Text.decodeUtf8' $ CI.original name) <> ": " <> err - --- | reads path info -toWithPathInfo :: ([Text] -> Server m) -> Server m -toWithPathInfo act = Server $ \req -> - unServer (act req.path) req - -instance Monad m => Semigroup (Server m) where - (<>) (Server serverA) (Server serverB) = Server $ \req -> do - mRespA <- serverA req - maybe (serverB req) (pure . Just) mRespA - -instance Monad m => Monoid (Server m) where - mempty = Server (const $ pure Nothing) - --- | Values convertible to lazy text -class ToText a where - toText :: a -> Text - -instance ToText TL.Text where - toText = TL.toStrict - -instance ToText Text where - toText = id - -instance ToText Int where - toText = Text.pack . show - -instance ToText Float where - toText = Text.pack . show - -instance ToText String where - toText = fromString - -{-# INLINE setContent #-} --- | Headers to set content type -setContent :: ByteString -> ResponseHeaders -setContent contentType = - [("Content-Type", contentType <>"; charset=utf-8")] - --- | Sets response status -setRespStatus :: Status -> Resp -> Resp -setRespStatus status (Resp _ headers body) = Resp status headers body - --- | Json response constructor -json :: (ToJSON resp) => resp -> Resp -json = (ok (setContent "text/json") . JsonResp . Json.toJSON) - --- | Text response constructor -text :: ToText a => a -> Resp -text = ok (setContent "text/plain") . TextResp . toText - --- | Html response constructor -html :: (ToMarkup a) => a -> Resp -html = ok (setContent "text/html") . HtmlResp . Html.toHtml - --- | Raw bytestring response constructor -raw :: BL.ByteString -> Resp -raw = ok (setContent "text/plain") . RawResp - --- | Respond with ok 200-status -ok :: ResponseHeaders -> RespBody -> Resp -ok headers body = Resp ok200 headers body - --- | Handle errors -handleError ::(Exception a, MonadCatch m) => (a -> Server m) -> Server m -> Server m -handleError handler (Server act) = Server $ \req -> - (act req) `catch` (\err -> unServer (handler err) req) - -------------------------------------------------------------------------------------- --- render to WAI - --- | Server config -data ServerConfig = ServerConfig - { maxBodySize :: Maybe Kilobytes - } - --- | Convert server to WAI-application -toApplication :: ServerConfig -> Server IO -> Application -toApplication config server req processResponse = do - mResp <- unServer (handleError onErr server) =<< fromRequest config.maxBodySize req - processResponse $ toResponse $ fromMaybe noResult mResp - where - noResult = badRequest "Server produces nothing" - - onErr :: SomeException -> Server IO - onErr err = toConst $ pure $ badRequest $ "Error: Exception has happened: " <> toText (show err) - --- | Convert response to low-level WAI-response -toResponse :: Resp -> Response -toResponse resp = - case resp.body of - TextResp textResp -> lbs $ BL.fromStrict (Text.encodeUtf8 textResp) - HtmlResp htmlResp -> lbs (Html.renderMarkup htmlResp) - JsonResp jsonResp -> lbs (Json.encode jsonResp) - FileResp file -> responseFile resp.status resp.headers file Nothing - RawResp str -> lbs str - StreamResp -> undefined - where - lbs = responseLBS resp.status resp.headers - --- | Read request from low-level WAI-request --- First argument limits the size of input body. The body is read in chunks. -fromRequest :: Maybe Kilobytes -> Request -> IO Req -fromRequest maxSize req = - pure $ Req - { path = pathInfo req - , query = Map.fromList $ mapMaybe (\(key, mVal) -> (key, ) <$> mVal) (queryString req) - , headers = requestHeaders req - , method = requestMethod req - , readBody = fmap (fmap BL.fromChunks) $ readRequestBody (getRequestBodyChunk req) maxSize - } - diff --git a/src/Mig/Json.hs b/src/Mig/Json.hs deleted file mode 100644 --- a/src/Mig/Json.hs +++ /dev/null @@ -1,65 +0,0 @@ --- | Module for HTML-based servers -module Mig.Json - ( - -- * methods - Get (..) - , Post (..) - , Put (..) - , Delete (..) - , Patch (..) - , Options (..) - - -- * common - -- | Common re-exports - , module X - ) where - -import Mig.Common as X -import Mig (ToJsonResp (..)) -import Mig.Internal.Types (toMethod) -import Network.HTTP.Types.Method - --- Get - --- | Get method. Note that we can not use body input with Get-method, use Post for that. --- So with Get we can use only URI inputs (Query, Optional, Capture) -newtype Get m a = Get (m a) - -instance (Monad m, ToJsonResp a) => ToServer (Get m a) where - type ServerMonad (Get m a) = m - toServer (Get act) = toMethod methodGet (toJsonResp <$> act) - --- | Post method -newtype Post m a = Post (m a) - -instance (Monad m, ToJsonResp a) => ToServer (Post m a) where - type ServerMonad (Post m a) = m - toServer (Post act) = toMethod methodPost (toJsonResp <$> act) - --- | Put method -newtype Put m a = Put (m a) - -instance (Monad m, ToJsonResp a) => ToServer (Put m a) where - type ServerMonad (Put m a) = m - toServer (Put act) = toMethod methodPut (toJsonResp <$> act) - --- | Delete method -newtype Delete m a = Delete (m a) - -instance (Monad m, ToJsonResp a) => ToServer (Delete m a) where - type ServerMonad (Delete m a) = m - toServer (Delete act) = toMethod methodDelete (toJsonResp <$> act) - --- | Patch method -newtype Patch m a = Patch (m a) - -instance (Monad m, ToJsonResp a) => ToServer (Patch m a) where - type ServerMonad (Patch m a) = m - toServer (Patch act) = toMethod methodPatch (toJsonResp <$> act) - --- | Options method -newtype Options m a = Options (m a) - -instance (Monad m, ToJsonResp a) => ToServer (Options m a) where - type ServerMonad (Options m a) = m - toServer (Options act) = toMethod methodOptions (toJsonResp <$> act) diff --git a/src/Mig/Json/IO.hs b/src/Mig/Json/IO.hs deleted file mode 100644 --- a/src/Mig/Json/IO.hs +++ /dev/null @@ -1,65 +0,0 @@ --- | Module for HTML-based servers -module Mig.Json.IO - ( - -- * methods - Get (..) - , Post (..) - , Put (..) - , Delete (..) - , Patch (..) - , Options (..) - - -- * common - -- | Common re-exports - , module X - ) where - -import Mig.Common as X -import Mig (ToJsonResp (..)) -import Mig.Internal.Types (toMethod) -import Network.HTTP.Types.Method - --- Get - --- | Get method. Note that we can not use body input with Get-method, use Post for that. --- So with Get we can use only URI inputs (Query, Optional, Capture) -newtype Get a = Get (IO a) - -instance (ToJsonResp a) => ToServer (Get a) where - type ServerMonad (Get a) = IO - toServer (Get act) = toMethod methodGet (toJsonResp <$> act) - --- | Post method -newtype Post a = Post (IO a) - -instance (ToJsonResp a) => ToServer (Post a) where - type ServerMonad (Post a) = IO - toServer (Post act) = toMethod methodPost (toJsonResp <$> act) - --- | Put method -newtype Put a = Put (IO a) - -instance (ToJsonResp a) => ToServer (Put a) where - type ServerMonad (Put a) = IO - toServer (Put act) = toMethod methodPut (toJsonResp <$> act) - --- | Delete method -newtype Delete a = Delete (IO a) - -instance (ToJsonResp a) => ToServer (Delete a) where - type ServerMonad (Delete a) = IO - toServer (Delete act) = toMethod methodDelete (toJsonResp <$> act) - --- | Patch method -newtype Patch a = Patch (IO a) - -instance (ToJsonResp a) => ToServer (Patch a) where - type ServerMonad (Patch a) = IO - toServer (Patch act) = toMethod methodPatch (toJsonResp <$> act) - --- | Options method -newtype Options a = Options (IO a) - -instance (ToJsonResp a) => ToServer (Options a) where - type ServerMonad (Options a) = IO - toServer (Options act) = toMethod methodOptions (toJsonResp <$> act) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,10 @@ +import Test.Api qualified as Api +import Test.Server qualified as Server + +import Test.Hspec + +main :: IO () +main = + hspec $ do + Api.spec + Server.spec diff --git a/test/Test/Api.hs b/test/Test/Api.hs new file mode 100644 --- /dev/null +++ b/test/Test/Api.hs @@ -0,0 +1,76 @@ +module Test.Api (spec) where + +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Mig.Core.Api +import Test.Hspec + +spec :: Spec +spec = describe "api" $ do + checkRoutes + checkCaptures + checkFlatApi + +notFound :: (Show a, Eq a) => Maybe a -> Expectation +notFound a = a `shouldBe` Nothing + +-- static routes + +checkRoutes :: Spec +checkRoutes = do + it "enter route (positive cases)" $ do + getPath ["api", "v1", "hello"] helloApi `shouldBe` Just ("hello", mempty) + getPath ["api", "v1", "bye"] helloApi `shouldBe` Just ("bye", mempty) + it "enter route (negative cases)" $ + mapM_ + notFound + [ getPath ["api", "v1"] helloApi + , getPath [] helloApi + , getPath ["api", "v1", "hello", "there"] helloApi + , getPath ["api", "v1"] (mempty @(Api Text)) + , getPath [] (mempty @(Api Text)) + ] + +helloApi :: Api Text +helloApi = + WithPath "api/v1" $ + mconcat + [ WithPath "hello" (HandleRoute "hello") + , WithPath "bye" (HandleRoute "bye") + ] + +-- captures + +checkCaptures :: Spec +checkCaptures = do + it "captures (positive cases)" $ do + getPath ["api", "capture1", "hello"] captureApi + `shouldBe` Just ("capture1", Map.fromList [("name1", "hello")]) + getPath ["api", "capture2", "hello", "bye"] captureApi + `shouldBe` Just ("capture2", Map.fromList [("name1", "hello"), ("name2", "bye")]) + + it "captures (negative cases)" $ + mapM_ + (notFound . flip getPath captureApi) + [ ["api", "capture1"] + , ["api", "capture2", "hello"] + , ["api", "capture2", "hello", "bye", "error"] + ] + +captureApi :: Api Text +captureApi = + WithPath "api" $ + mconcat + [ WithPath ("capture1" <> Path [CapturePath "name1"]) (HandleRoute "capture1") + , WithPath ("capture2" <> Path [CapturePath "name1", CapturePath "name2"]) (HandleRoute "capture2") + ] + +-- flat api + +checkFlatApi :: Spec +checkFlatApi = + it "flat api" $ + flatApi helloApi + `shouldBe` [ ("api/v1/hello", "hello") + , ("api/v1/bye", "bye") + ] diff --git a/test/Test/Server.hs b/test/Test/Server.hs new file mode 100644 --- /dev/null +++ b/test/Test/Server.hs @@ -0,0 +1,12 @@ +module Test.Server (spec) where + +import Test.Hspec +import Test.Server.Counter qualified as Counter +import Test.Server.Hello qualified as Hello +import Test.Server.RouteArgs qualified as RouteArgs + +spec :: Spec +spec = describe "server" $ do + Hello.spec + RouteArgs.spec + Counter.spec diff --git a/test/Test/Server/Common.hs b/test/Test/Server/Common.hs new file mode 100644 --- /dev/null +++ b/test/Test/Server/Common.hs @@ -0,0 +1,36 @@ +module Test.Server.Common ( + emptyReq, + jsonResp, + parseResp, +) where + +import Data.Aeson qualified as Json +import Data.Map.Strict qualified as Map +import Mig.Core +import Network.HTTP.Types.Method (methodGet) +import Network.HTTP.Types.Status (ok200) + +emptyReq :: Request +emptyReq = + Request + { path = [] + , query = mempty + , capture = mempty + , headers = Map.fromList [("Accept", "application/json")] + , method = methodGet + , readBody = pure (Right "") + , isSecure = False + } + +jsonResp :: (Json.ToJSON a) => a -> Response +jsonResp a = + Response + { status = ok200 + , headers = [("Content-Type", "application/json")] + , body = RawResp "application/json" (Json.encode a) + } + +parseResp :: (Json.FromJSON a) => Response -> Maybe a +parseResp resp = case resp.body of + RawResp "application/json" bsResp -> Json.decode bsResp + _ -> Nothing diff --git a/test/Test/Server/Counter.hs b/test/Test/Server/Counter.hs new file mode 100644 --- /dev/null +++ b/test/Test/Server/Counter.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DataKinds #-} + +-- | Test case for ReaderT based server +module Test.Server.Counter (spec) where + +import Control.Monad.Reader +import Data.IORef +import Data.Maybe +import Data.Text qualified as Text +import Mig.Core +import Network.HTTP.Types.Method (methodPost) +import Test.Hspec +import Test.Server.Common + +------------------------------------------------------------------------------------- +-- server definition + +newtype Env = Env (IORef Int) + +initEnv :: IO Env +initEnv = Env <$> newIORef 0 + +newtype App a = App (ReaderT Env IO a) + deriving newtype (Functor, Applicative, Monad, MonadReader Env, MonadIO) + +runApp :: Env -> App a -> IO a +runApp env (App act) = runReaderT act env + +{-| Server has two routes: + +* get - to querry current state +* put - to add some integer to the state +-} +server :: Server App +server = + "counter" + /. [ "get" /. handleGet + , "put" /. handlePut + ] + +-- | Get handler. It logs the call and returns current state +handleGet :: Get App (Resp Json Int) +handleGet = Send $ do + Env ref <- ask + liftIO $ ok <$> readIORef ref + +-- | Put handler. It logs the call and updates the state with integer which is read from URL +handlePut :: Capture "arg" Int -> Post App (Resp Json ()) +handlePut (Capture val) = Send $ do + Env ref <- ask + liftIO $ ok <$> atomicModifyIORef' ref (\cur -> (cur + val, ())) + +------------------------------------------------------------------------------------- +-- test cases + +spec :: Spec +spec = describe "counter server (ReaderT)" $ do + describe "plain route finder" $ specBy plainApiStrategy + describe "tree route finder" $ specBy treeApiStrategy + +specBy :: FindRoute normalForm App -> Spec +specBy findRoute = + it "run accumulator script" $ + script serverFun [1, 2, 3, 4] `shouldReturn` [1, 3, 6, 10] + where + serverFun = fromServer findRoute server + +{-| Puts inputs to server and returns result of "counter/get" method call +on each increment +-} +script :: ServerFun App -> [Int] -> IO [Int] +script f inputs = do + env <- initEnv + runApp env $ catMaybes <$> mapM go inputs + where + go :: Int -> App (Maybe Int) + go n = fmap (parseResp =<<) $ do + mRes <- f (putReq n) + if (isJust mRes) + then f getReq + else pure Nothing + + putReq :: Int -> Request + putReq increment = + emptyReq + { method = methodPost + , path = ["counter", "put", Text.pack (show increment)] + } + + getReq :: Request + getReq = emptyReq{path = ["counter", "get"]} diff --git a/test/Test/Server/Hello.hs b/test/Test/Server/Hello.hs new file mode 100644 --- /dev/null +++ b/test/Test/Server/Hello.hs @@ -0,0 +1,64 @@ +module Test.Server.Hello (spec) where + +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Mig.Core +import Mig.Core qualified as Request (Request (..)) +import Network.HTTP.Types.Method (methodPost) +import Test.Hspec +import Test.Server.Common + +-- hello world server + +server :: Server IO +server = + "api/v1" + /. [ "hello" /. handleHello + , "bye" /. handleBye + ] + +handleHello :: Get IO (Resp Json Text) +handleHello = pure $ ok "hello" + +handleBye :: Get IO (Resp Json Text) +handleBye = pure $ ok "bye" + +-- tests + +-- we use low-level representation of server as a function: Request -> m (Maybe Response) +-- to check server properties without launching in a full server environment +spec :: Spec +spec = describe "hello world server" $ do + describe "plain route finder" $ specBy plainApiStrategy + describe "tree route finder" $ specBy treeApiStrategy + +specBy :: FindRoute nf IO -> Spec +specBy finder = do + checkPositiveRoutes + checkNegativeRoutes + where + serverFun :: ServerFun IO + serverFun = fromServer finder server + + checkPositiveRoutes = do + it "call routes (positive case)" $ do + serverFun helloReq `shouldReturn` helloResp + serverFun byeReq `shouldReturn` byeResp + + checkNegativeRoutes = do + describe "negative cases" $ do + it "wrong path" $ do + serverFun emptyReq `shouldReturn` Nothing + serverFun wrongPathReq `shouldReturn` Nothing + it "wrong method" $ do + serverFun (helloReq{Request.method = methodPost}) `shouldReturn` Nothing + it "wrong output media type" $ do + serverFun (helloReq{Request.headers = Map.fromList [("Accept", "text/html")]}) `shouldReturn` Nothing + + helloReq = emptyReq{path = ["api", "v1", "hello"]} + helloResp = Just $ jsonResp @Text "hello" + + byeReq = emptyReq{path = ["api", "v1", "bye"]} + byeResp = Just $ jsonResp @Text "bye" + + wrongPathReq = emptyReq{path = ["api", "v2", "hello"]} diff --git a/test/Test/Server/RouteArgs.hs b/test/Test/Server/RouteArgs.hs new file mode 100644 --- /dev/null +++ b/test/Test/Server/RouteArgs.hs @@ -0,0 +1,395 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} + +-- | Tests for various inputs for requests +module Test.Server.RouteArgs (spec) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson qualified as Json +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as BL +import Data.Map.Strict qualified as Map +import Data.OpenApi (ToParamSchema, ToSchema) +import Data.String +import Data.Text (Text) +import Data.Text qualified as Text +import GHC.Generics (Generic) +import Mig.Core +import Mig.Core qualified as Request (Request (..)) +import Mig.Core qualified as Response (Response (..)) +import Network.HTTP.Types.Method (Method, methodGet, methodPost) +import Network.HTTP.Types.Status (badRequest400, status201) +import Test.Hspec +import Test.Server.Common +import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) + +------------------------------------------------------------------------------------- +-- server + +server :: Server IO +server = + "api" + /. [ "succ" + /. [ "query" /. handleSuccQuery + , "header" /. handleSuccHeader + , "optional" /. handleSuccOpt + , "optional-header" /. handleSuccHeaderOpt + ] + , -- several query params + "add" /. handleAdd + , -- query flag + "add-if" /. handleAddIf + , -- capture + "mul" /. handleMul + , -- json body as input + "add-json" /. handleAddJson + , -- return error + "square-root" /. handleSquareRoot + , "response" + /. [ "status" /. handleStatus + , "header" /. handleHeader + , "error1" /. handleError1 + , "error2" /. handleError2 + ] + ] + +{-| Using several inputs: header argument and required query +and using conditional output status +-} +handleSuccQuery :: Query "value" Int -> Get IO (Resp Json Int) +handleSuccQuery (Query n) = + pure $ ok (succ n) + +newtype Value = Value Int + deriving newtype (FromHttpApiData, ToHttpApiData, ToText, ToParamSchema) + +{-| Using several inputs: header argument and required query +and using conditional output status +-} +handleSuccHeader :: Header "value" Value -> Get IO (Resp Json Int) +handleSuccHeader (Header (Value n)) = do + pure $ ok (succ n) + +-- | Using optional query parameters and error as RespOr. +handleSuccOpt :: Optional "value" Int -> Get IO (RespOr Json Text Int) +handleSuccOpt (Optional n) = do + pure $ ok $ maybe 0 succ n + +-- | Using optional header parameters and error as RespOr. +handleSuccHeaderOpt :: OptionalHeader "value" Int -> Get IO (RespOr Json Text Int) +handleSuccHeaderOpt (OptionalHeader n) = do + pure $ ok $ maybe 0 succ n + +{-| Using custom headers in response and several input query parameters. +Note that function can have any number of arguments. +We encode the input type with proper type-wrapper. +-} +handleAdd :: Query "a" Int -> Query "b" Int -> Get IO (Resp Json Text) +handleAdd (Query a) (Query b) = do + pure $ ok $ toAddResult a b + +toAddResult :: Int -> Int -> Text +toAddResult a b = + Text.unwords ["Addition of", intToText a, "and", intToText b, "is", intToText $ a + b] + +intToText :: Int -> Text +intToText = Text.pack . show + +-- | Using query flag if flag is false returns 0 +handleAddIf :: Query "a" Int -> Query "b" Int -> QueryFlag "perform" -> Get IO (Resp Json Int) +handleAddIf (Query a) (Query b) (QueryFlag addFlag) = do + pure $ + ok $ + if addFlag + then (a + b) + else 0 + +{-| Using capture as arguments. This route expects two arguments +captured in URL. For example: + +> http://localhost:8085/hello/api/mul/3/100 +-} +handleMul :: Capture "a" Int -> Capture "b" Int -> Get IO (Resp Json Text) +handleMul (Capture a) (Capture b) = do + pure $ ok $ toMulResult a b + +toMulResult :: Int -> Int -> Text +toMulResult a b = + Text.unwords + ["Multiplication of", intToText a, "and", intToText b, "is", intToText $ a * b] + +data AddInput = AddInput + { a :: Int + , b :: Int + } + deriving (Generic, ToJSON, FromJSON, ToSchema) + +-- | Using JSON as input +handleAddJson :: Body Json AddInput -> Post IO (Resp Json Int) +handleAddJson (Body (AddInput a b)) = do + pure $ ok $ a + b + +handleSquareRoot :: Body Json Float -> Post IO (RespOr Json Text Float) +handleSquareRoot (Body arg) = + pure $ + if arg >= 0 + then ok (sqrt arg) + else bad badRequest400 sqrtError + +handleStatus :: Get IO (Resp Json Text) +handleStatus = pure $ setStatus status201 $ ok "Status is 201" + +handleHeader :: Capture "name" Text -> Capture "value" Text -> Get IO (Resp Json Text) +handleHeader (Capture name) (Capture value) = + pure $ setHeader (fromString $ Text.unpack name) value $ ok "Set custom header" + +handleError1 :: Get IO (Resp Json Text) +handleError1 = pure $ bad badRequest400 badRequestError + +handleError2 :: Capture "value" Int -> Get IO (RespOr Json Text Int) +handleError2 (Capture n) + | n > 0 = pure $ ok n + | otherwise = pure $ bad badRequest400 badRequestError + +badRequestError :: Text +badRequestError = "Error: bad request" + +sqrtError :: Text +sqrtError = "Argument for square root should be non-negative" + +------------------------------------------------------------------------------------- +-- test cases + +-- we use low-level representation of server as a function: Request -> m (Maybe Response) +-- to check server properties without launching in a full server environment +spec :: Spec +spec = describe "route args server: check route inputs" $ do + describe "plain route finder" $ specBy plainApiStrategy + describe "tree route finder" $ specBy treeApiStrategy + +specBy :: FindRoute normalForm IO -> Spec +specBy finder = do + describe "request" $ do + checkQuery + checkOptionalQuery + checkHeader + checkOptionalHeader + checkQueryFlag + checkCapture + checkBody + describe "response" $ do + checkStatus + checkHeaders + checkErrors + where + serverFun :: ServerFun IO + serverFun = fromServer finder server + + shouldReq :: forall a. (Json.FromJSON a, Show a, Eq a) => Request -> Maybe a -> Expectation + shouldReq req expected = + fmap (parseResp @a =<<) (serverFun req) `shouldReturn` expected + + toQuery :: forall a. (Json.ToJSON a) => ByteString -> a -> QueryMap + toQuery name val = Map.singleton name (Just $ BL.toStrict $ Json.encode @a val) + + jsonHeaders :: HeaderMap + jsonHeaders = Map.fromList [("accept", "application/json"), ("content-type", "application/json")] + + -- queries + + checkQuery :: Spec + checkQuery = + describe "query" $ do + it "one query" $ shouldReq @Int queryReq (Just 2) + it "missing query" $ shouldReq @Int (queryReq{query = mempty}) Nothing + it "two queries" $ shouldReq @Text (twoQueryReq 2 3) (Just $ toAddResult 2 3) + + queryReq :: Request + queryReq = + emptyReq + { path = ["api", "succ", "query"] + , query = toQuery @Int "value" 1 + } + + twoQueryReq :: Int -> Int -> Request + twoQueryReq a b = + emptyReq + { path = ["api", "add"] + , query = toQuery "a" a <> toQuery "b" b + } + + -- optional query + + checkOptionalQuery :: Spec + checkOptionalQuery = + describe "optional query" $ do + it "with query" $ shouldReq @Int optionalQueryReq (Just 2) + it "no query (ok, default case)" $ shouldReq @Int (optionalQueryReq{query = mempty}) (Just 0) + + optionalQueryReq :: Request + optionalQueryReq = + emptyReq + { path = ["api", "succ", "optional"] + , query = toQuery @Int "value" 1 + } + + -- query flag + + checkQueryFlag :: Spec + checkQueryFlag = + describe "query flag" $ do + it "flag true" $ shouldReq @Int (queryFlagReq (Just True) 2 3) (Just 5) + it "flag false" $ shouldReq @Int (queryFlagReq (Just False) 2 3) (Just 0) + it "flag missing" $ shouldReq @Int (queryFlagReq Nothing 2 3) (Just 0) + + queryFlagReq :: Maybe Bool -> Int -> Int -> Request + queryFlagReq mFlag a b = + emptyReq + { path = ["api", "add-if"] + , query = mconcat [toQuery "a" a, toQuery "b" b] <> maybe mempty (toQuery "perform") mFlag + } + + -- headers + + checkHeader :: Spec + checkHeader = + describe "header" $ do + describe "input header" $ do + it "positive case" $ shouldReq @Int headerReq (Just 2) + it "missing header" $ shouldReq @Int (headerReq{Request.headers = mempty}) Nothing + + headerReq :: Request + headerReq = + emptyReq + { path = ["api", "succ", "header"] + , Request.headers = Map.singleton "value" (BL.toStrict $ Json.encode @Int 1) + } + + -- optional headers + + checkOptionalHeader :: Spec + checkOptionalHeader = + describe "optional header" $ do + it "with header" $ shouldReq @Int optionalHeaderReq (Just 2) + it "no header (ok, default case)" $ shouldReq @Int (optionalHeaderReq{Request.headers = mempty}) (Just 0) + + optionalHeaderReq :: Request + optionalHeaderReq = + emptyReq + { path = ["api", "succ", "optional-header"] + , Request.headers = Map.singleton "value" (BL.toStrict $ Json.encode @Int 1) + } + + -- captures + + checkCapture :: Spec + checkCapture = + describe "capture" $ do + it "positive case" $ shouldReq @Text (captureReq [2, 3]) (Just (toMulResult 2 3)) + it "not enough captures" $ shouldReq @Text ((captureReq [2]){capture = mempty}) Nothing + it "too many captures" $ shouldReq @Text ((captureReq [2, 3, 4]){capture = mempty}) Nothing + it "missing captures" $ shouldReq @Text ((captureReq []){capture = mempty}) Nothing + + captureReq :: [Int] -> Request + captureReq args = + emptyReq + { path = ["api", "mul"] <> fmap (Text.pack . show) args + } + + -- body + + checkBody :: Spec + checkBody = + describe "body" $ do + it "positive case 1" $ shouldReq @Int (bodyReq methodPost 2 3) (Just 5) + it "positive case 2" $ shouldReq @Float (sqrtBodyReq 9) (Just 3) + it "no body" $ shouldReq @Int noBodyReq Nothing + it "wrong method" $ shouldReq @Int (bodyReq methodGet 2 2) Nothing + it "bad argument" $ shouldReq @Text (sqrtBodyReq (-9)) (Just sqrtError) + + bodyReq :: Method -> Int -> Int -> Request + bodyReq reqMethod a b = + emptyReq + { path = ["api", "add-json"] + , method = reqMethod + , readBody = pure $ Right $ Json.encode $ AddInput a b + , Request.headers = jsonHeaders + } + + noBodyReq :: Request + noBodyReq = + emptyReq + { path = ["api", "add-json"] + , method = methodPost + , Request.headers = jsonHeaders + } + + sqrtBodyReq :: Float -> Request + sqrtBodyReq a = + emptyReq + { path = ["api", "square-root"] + , method = methodPost + , readBody = pure $ Right $ Json.encode a + , Request.headers = jsonHeaders + } + + -- response status + + checkStatus :: Spec + checkStatus = + describe "status" $ do + it "can set result status" $ + (fmap (.status) <$> serverFun statusReq) `shouldReturn` Just status201 + it "can set error status" $ + (fmap (.status) <$> serverFun (sqrtBodyReq (-1))) `shouldReturn` Just badRequest400 + + statusReq :: Request + statusReq = + emptyReq + { path = ["api", "response", "status"] + } + + -- response headers + + checkHeaders :: Spec + checkHeaders = + describe "headers" $ + it "can set headers" $ + shouldHeader "foo" "bar" + where + shouldHeader name value = + fmap (any (== header) . Response.headers) <$> serverFun (customHeaderReq name value) + `shouldReturn` Just True + where + header = (fromString $ Text.unpack name, fromString $ Text.unpack value) + + customHeaderReq :: Text -> Text -> Request + customHeaderReq name value = + emptyReq + { path = ["api", "response", "header", name, value] + } + + -- response errors + + checkErrors :: Spec + checkErrors = + describe "custom errors" $ do + it "error has the same type as result" $ + shouldBadReq (customErrorReq ["error1"]) + it "error has different type" $ + shouldBadReq (customErrorReq ["error2", "0"]) + it "no error on positive input" $ + shouldReq @Int (customErrorReq ["error2", "1"]) (Just 1) + where + shouldBadReq req = + fmap (maybe False isBadReq) (serverFun req) `shouldReturn` True + + isBadReq resp = + resp.status == badRequest400 + && parseResp @Text resp == Just badRequestError + + customErrorReq :: [Text] -> Request + customErrorReq args = + emptyReq + { path = ["api", "response"] <> args + }