packages feed

mig 0.1.0.3 → 0.2.0.0

raw patch · 36 files changed

+3515/−1763 lines, 36 filesdep +extradep +filepathdep +hspecdep −blaze-markupdep −waidep −warpsetup-changed

Dependencies added: extra, filepath, hspec, http-media, insert-ordered-containers, lens, lrucache, mig, openapi3, safe, transformers

Dependencies removed: blaze-markup, wai, warp

Files

− CHANGELOG.md 
@@ -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
README.md view
@@ -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.
− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
mig.cabal view
@@ -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 <https://github.com/anton-k/mig#readme>-                .-                * examples directory for more fun servers: at <https://github.com/anton-k/mig/tree/main/examples/mig-example-apps#readme>-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 <https://anton-k.github.io/mig/>+                    .+                    * examples directory for more servers: at <https://github.com/anton-k/mig/tree/main/examples/mig-example-apps#readme>+                    .+                    * reference for the main functions: <https://anton-k.github.io/mig/09-reference.html>+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
− src/Mig.hs 
@@ -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 }
− src/Mig/Common.hs 
@@ -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
+ src/Mig/Core.hs view
@@ -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 <https://anton-k.github.io/mig/>++* examples directory for more servers: at <https://github.com/anton-k/mig/tree/main/examples/mig-example-apps#readme>++* reference for the main functions: <https://anton-k.github.io/mig/09-reference.html>+-}+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
+ src/Mig/Core/Api.hs view
@@ -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))
+ src/Mig/Core/Api/NormalForm/TreeApi.hs view
@@ -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)
+ src/Mig/Core/Class.hs view
@@ -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
+ src/Mig/Core/Class/MediaType.hs view
@@ -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
+ src/Mig/Core/Class/Monad.hs view
@@ -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
+ src/Mig/Core/Class/Plugin.hs view
@@ -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))
+ src/Mig/Core/Class/Response.hs view
@@ -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
+ src/Mig/Core/Class/Route.hs view
@@ -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))
+ src/Mig/Core/Class/Server.hs view
@@ -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
+ src/Mig/Core/OpenApi.hs view
@@ -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 <> "`"
+ src/Mig/Core/Server.hs view
@@ -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)
+ src/Mig/Core/Server/Cache.hs view
@@ -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
+ src/Mig/Core/ServerFun.hs view
@@ -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)
+ src/Mig/Core/Types.hs view
@@ -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
+ src/Mig/Core/Types/Http.hs view
@@ -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
+ src/Mig/Core/Types/Info.hs view
@@ -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))
+ src/Mig/Core/Types/Route.hs view
@@ -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
− src/Mig/Html.hs 
@@ -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)
− src/Mig/Html/IO.hs 
@@ -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)
− src/Mig/Internal/Types.hs 
@@ -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-    }-
− src/Mig/Json.hs 
@@ -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)
− src/Mig/Json/IO.hs 
@@ -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)
+ test/Spec.hs view
@@ -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
+ test/Test/Api.hs view
@@ -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")+                 ]
+ test/Test/Server.hs view
@@ -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
+ test/Test/Server/Common.hs view
@@ -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
+ test/Test/Server/Counter.hs view
@@ -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"]}
+ test/Test/Server/Hello.hs view
@@ -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"]}
+ test/Test/Server/RouteArgs.hs view
@@ -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+        }