packages feed

mig (empty) → 0.1.0.0

raw patch · 12 files changed

+1879/−0 lines, 12 filesdep +aesondep +basedep +blaze-htmlsetup-changed

Dependencies added: aeson, base, blaze-html, blaze-markup, bytestring, containers, exceptions, http-types, mtl, random, text, wai, wai-extra, warp

Files

+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# 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
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Anton Kholomiov (c) 2023++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,369 @@+# 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".++## 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+* `Optional "name" type` - optional query parameter+* `Capture type` - capture part of the URI between slashes `/`.+* `Body type` - input JSON body+* `RawBody` - input body as raw lazy bytestring+* `RawFormData` - input of the html-form+* `FormJson` - input f html-form as Json (see examples/Html.hs)+* `Header "name"` - access header by name+* `PathInfo` - access path info relative to the server++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.++PS: this is an open question. Is it possible to create a function:++```haskell+hoistServer :: (Monad m, Monad n) => (forall a . m a -> n a) -> Server m -> Server n+```++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:++```haskell+toApplication :: MonadBaseControl m => Server m -> m Wai.Application+```++## 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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ mig.cabal view
@@ -0,0 +1,117 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name:           mig+version:        0.1.0.0+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+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/anton-k/mig++library+  exposed-modules:+      Mig+      Mig.Common+      Mig.Html+      Mig.Html.IO+      Mig.Internal.Types+      Mig.Json+      Mig.Json.IO+  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+  build-depends:+      aeson+    , base >=4.7 && <5+    , blaze-html+    , blaze-markup+    , bytestring+    , containers+    , exceptions+    , http-types+    , mtl+    , random+    , text+    , wai+    , wai-extra+    , warp+  default-language: GHC2021
+ src/Mig.hs view
@@ -0,0 +1,645 @@+{-# 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 (..)+  , RawFormData (..)+  , FormBody (..)+  , FormJson (..)+  , 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 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+import Data.Aeson.Key qualified as Json++-- | 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' :: FromText 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 = fromText =<< either (const Nothing) Just . Text.decodeUtf8' =<< mVal+  in+    act mArg++withQuery :: (Applicative m, FromText 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 = fromText =<< either (const Nothing) Just . 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 (FromText 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 (FromText 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 (FromText a, ToServer b) => ToServer (Capture a -> b) where+  type ServerMonad (Capture a -> b) = ServerMonad b+  toServer act = toWithCapture $ \txt ->+    case fromText txt of+      Just val -> toServer $ act $ Capture val+      Nothing -> toConst $ pure $ badRequest "Failed to parse capture"++-- 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++-- | Parse raw form body. It includes named form arguments and file info.+-- Note that we can not use FormBody and JSON-body at the same time.+-- They occupy the same field in the HTTP-request.+newtype RawFormData = RawFormData FormBody++instance (ToServer b, MonadIO (ServerMonad b)) => ToServer (RawFormData -> b) where+  type ServerMonad (RawFormData -> b) = ServerMonad b+  toServer act = toWithFormData $ toServer . act . RawFormData++-- | It reads form as plain JSON-object where name of the form's field becomes+-- a field of JSON-object and every value is Text.+--+-- For example if submit a form with fields: name, password, date.+-- We can read it in the data type:+--+-- > data User = User+-- >  { name :: Text+-- >  , passord :: Text+-- >  , date :: Text+-- >  }+--+-- Note that we can not use FormBody and JSON-body at the same time.+-- They occupy the same field in the HTTP-request.+newtype FormJson a = FormJson a++instance (ToServer b, MonadIO (ServerMonad b), FromJSON a) => ToServer (FormJson a -> b) where+  type ServerMonad (FormJson a -> b) = ServerMonad b+  toServer act = toWithFormData $ \formBody -> do+    case formDataToJson formBody.params of+      Right v -> toServer $ act $ FormJson v+      Left err -> toConst $+        pure $ badRequest $ "Failed to parse form data as JSON body: " <> err++formDataToJson :: FromJSON a => [(ByteString, ByteString)] -> Either Text a+formDataToJson rawPairs = do+  jsonVal <- Json.object <$> mapM toPair rawPairs+  case Json.fromJSON jsonVal of+    Json.Success result -> Right result+    Json.Error err -> Left (Text.pack $ show err)+  where+    toPair (key, val) =+      first (Text.pack . show) $+        (\k v -> (Json.fromText k, Json.String v)) <$> Text.decodeUtf8' key <*> Text.decodeUtf8' val++-- Request Headers++-- | Reads input header. Example:+--+-- > "api" /. (\(Header @"Trace-Id" traceId) -> Post @Json (handleFoo traceId))+-- >+-- > handleFoo :: Maybe ByteString -> IO FooResponse+newtype Header (sym :: Symbol) = Header (Maybe ByteString)++instance (ToServer b, KnownSymbol sym) => ToServer (Header sym -> b) where+  type ServerMonad (Header sym -> 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 view
@@ -0,0 +1,52 @@+-- | 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 (..)+  , RawFormData (..)+  , FormBody (..)+  , FormJson (..)+  , 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 (..), RawFormData (..), FormBody (..), FormJson (..), AddHeaders (..), SetStatus (..)+  , setStatus, addHeaders, HasServer (..), fromReader, ServerConfig (..), toApplication, runServer, badRequest, Error (..), withServerAction)++import Network.HTTP.Types.Status as X
+ src/Mig/Html.hs view
@@ -0,0 +1,67 @@+-- | 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++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++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++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++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++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++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 view
@@ -0,0 +1,67 @@+-- | 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++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++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++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++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++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++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 view
@@ -0,0 +1,383 @@+-- | 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+  , FormBody (..)+  -- * 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 Network.Wai.Parse qualified as Parse++-- | 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)+  , readFormBody :: IO (Either (Error Text) FormBody)+  }++data FormBody = FormBody+  { params :: [(ByteString, ByteString)]+  , files :: [(ByteString, Parse.FileInfo BL.ByteString)]+  }++-- 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) }++toConst :: Functor m => m Resp -> Server m+toConst act = Server $ const $ Just <$> act++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++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)++-- TODO: make it size limited by HTTP-body size+toWithFormData :: MonadIO m => (FormBody -> Server m) -> Server m+toWithFormData act = Server $ \req -> do+  eFormBody <- liftIO req.readFormBody+  case eFormBody of+    Right formBody -> unServer (act formBody) req+    Left err -> pure $ Just $ setRespStatus err.status (text err.body)+++-- | 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++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++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++pathHead :: Req -> Maybe (Text, Req)+pathHead req =+  case req.path of+    hd : tl -> Just (hd, req { path = tl })+    _ -> Nothing++toWithHeader :: HeaderName -> (Maybe ByteString -> Server m) -> Server m+toWithHeader name act = Server $ \req ->+  unServer (act (fmap snd $ List.find ((== name) . fst) req.headers)) req++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")]++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+    , readFormBody = getReadFormBody req+    }++getReadFormBody :: Request -> IO (Either (Error Text) FormBody)+getReadFormBody req = do+  case Parse.getRequestBodyType req of+    Nothing -> pure $ Right (FormBody [] [])+    Just reqBodyType -> do+      eResult <- try @IO @SomeException (Parse.sinkRequestBody Parse.lbsBackEnd reqBodyType (getRequestBodyChunk req))+      pure $ bimap (const toError) (uncurry FormBody) eResult+  where+    toError = Error status413 (Text.pack $ "Request is too big!")+
+ src/Mig/Json.hs view
@@ -0,0 +1,68 @@+-- | 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++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++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++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++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++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++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 view
@@ -0,0 +1,68 @@+-- | 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++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++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++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++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++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++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)