mig-extra (empty) → 0.1.0.0

raw patch · 14 files changed

+901/−0 lines, 14 filesdep +aesondep +basedep +blaze-htmlsetup-changed

Dependencies added: aeson, base, blaze-html, bytestring, case-insensitive, containers, data-default, exceptions, extra, http-api-data, http-media, http-types, mig, mig-client, openapi3, template-haskell, text, time, transformers, yaml

Files

• LICENSE +30/−0
• README.md +3/−0
• Setup.hs +3/−0
• mig-extra.cabal +73/−0
• src/Mig/Extra/Derive.hs +224/−0
• src/Mig/Extra/Plugin/Auth.hs +24/−0
• src/Mig/Extra/Plugin/Exception.hs +24/−0
• src/Mig/Extra/Plugin/Trace.hs +193/−0
• src/Mig/Extra/Server/Common.hs +133/−0
• src/Mig/Extra/Server/Html.hs +42/−0
• src/Mig/Extra/Server/Html/IO.hs +33/−0
• src/Mig/Extra/Server/IO.hs +32/−0
• src/Mig/Extra/Server/Json.hs +78/−0
• src/Mig/Extra/Server/Json/IO.hs +9/−0

@@ -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.

@@ -0,0 +1,3 @@+# mig-extra++Extra utils for core functionality of the mig library.

@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain

@@ -0,0 +1,73 @@+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-extra+version:            0.1.0.0+synopsis:           Extra utils for Mig core library+description:        Extra utils for mig server library+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++source-repository head+  type: git+  location: https://github.com/anton-k/mig++library+  exposed-modules:+      Mig.Extra.Derive+      Mig.Extra.Plugin.Auth+      Mig.Extra.Plugin.Exception+      Mig.Extra.Plugin.Trace+      Mig.Extra.Server.Common+      Mig.Extra.Server.Html+      Mig.Extra.Server.Html.IO+      Mig.Extra.Server.IO+      Mig.Extra.Server.Json+      Mig.Extra.Server.Json.IO+  other-modules:+      Paths_mig_extra+  hs-source-dirs:+      src+  default-extensions:+      DerivingStrategies+      TypeFamilies+      DataKinds+      OverloadedRecordDot+      OverloadedStrings+      DuplicateRecordFields+      LambdaCase+  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+    , bytestring+    , case-insensitive+    , containers+    , data-default+    , exceptions+    , extra+    , http-api-data+    , http-media+    , http-types+    , mig >=0.2+    , mig-client+    , openapi3+    , template-haskell+    , text+    , time+    , transformers+    , yaml+  default-language: GHC2021

@@ -0,0 +1,224 @@+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Derive standard HTTP-classes+module Mig.Extra.Derive (+  deriveParam,+  deriveNewtypeParam,+  deriveBody,+  deriveParamBody,+  deriveNewtypeBody,+  deriveNewtypeParamBody,+  deriveHttp,+  deriveNewtypeHttp,+  deriveNewtypeForm,+  deriveForm,+  mapDerive,++  -- * useful with derive-topdown library+  paramClasses,+  bodyClasses,+  paramBodyClasses,+  httpClasses,+) where++import Data.Aeson (FromJSON, ToJSON)+import Data.OpenApi (ToParamSchema, ToSchema)+import GHC.Generics (Generic)+import Language.Haskell.TH+import Web.FormUrlEncoded (FromForm, ToForm)+import Web.HttpApiData (FromHttpApiData, ToHttpApiData)++paramClasses :: [Name]+paramClasses = [''Show, ''Eq, ''Ord, ''Generic, ''ToJSON, ''FromJSON, ''ToParamSchema, ''ToHttpApiData, ''FromHttpApiData]++bodyClasses :: [Name]+bodyClasses = [''Show, ''Eq, ''Ord, ''Generic, ''ToJSON, ''FromJSON, ''ToSchema, ''ToHttpApiData, ''FromHttpApiData]++paramBodyClasses :: [Name]+paramBodyClasses = [''Show, ''Eq, ''Ord, ''Generic, ''ToJSON, ''FromJSON, ''ToParamSchema, ''ToSchema, ''ToHttpApiData, ''FromHttpApiData]++httpClasses :: [Name]+httpClasses = [''Show, ''Eq, ''Ord, ''Generic, ''ToJSON, ''FromJSON, ''ToParamSchema, ''ToSchema, ''ToHttpApiData, ''FromHttpApiData]++mapDerive :: (Name -> Q [Dec]) -> [Name] -> Q [Dec]+mapDerive f types = fmap concat (mapM f types)++-- | Derives standard WEB-classes for a newtype suitable for request parameter+deriveNewtypeParam :: Name -> Q [Dec]+deriveNewtypeParam typeName = do+  let typeCon = conT typeName+  [d|+    deriving newtype instance Show $(typeCon)++    deriving newtype instance Eq $(typeCon)++    deriving newtype instance Ord $(typeCon)++    deriving newtype instance ToJSON $(typeCon)++    deriving newtype instance FromJSON $(typeCon)++    deriving newtype instance ToParamSchema $(typeCon)++    deriving newtype instance ToHttpApiData $(typeCon)++    deriving newtype instance FromHttpApiData $(typeCon)+    |]++-- | Derives standard WEB-classes for a type suitable for request parameter+deriveParam :: Name -> Q [Dec]+deriveParam typeName = do+  let typeCon = conT typeName+  [d|+    deriving stock instance Show $(typeCon)++    deriving stock instance Eq $(typeCon)++    deriving stock instance Ord $(typeCon)++    deriving instance Generic $(typeCon)++    deriving anyclass instance ToJSON $(typeCon)++    deriving anyclass instance FromJSON $(typeCon)++    deriving anyclass instance ToParamSchema $(typeCon)++    deriving anyclass instance ToHttpApiData $(typeCon)++    deriving anyclass instance FromHttpApiData $(typeCon)+    |]++-- | Derives standard WEB-classes for a newtype suitable for request body or response+deriveNewtypeBody :: Name -> Q [Dec]+deriveNewtypeBody typeName = do+  let typeCon = conT typeName+  [d|+    deriving newtype instance Show $(typeCon)++    deriving newtype instance Eq $(typeCon)++    deriving newtype instance Ord $(typeCon)++    deriving newtype instance ToJSON $(typeCon)++    deriving newtype instance FromJSON $(typeCon)++    deriving newtype instance ToSchema $(typeCon)+    |]++-- | Derives standard WEB-classes for a type suitable for request body or response+deriveBody :: Name -> Q [Dec]+deriveBody typeName = do+  let typeCon = conT typeName+  [d|+    deriving instance Show $(typeCon)++    deriving instance Eq $(typeCon)++    deriving instance Ord $(typeCon)++    deriving instance Generic $(typeCon)++    deriving instance ToJSON $(typeCon)++    deriving instance FromJSON $(typeCon)++    deriving instance ToSchema $(typeCon)+    |]++-- | Derives standard WEB-classes for a newtype suitable for request form+deriveNewtypeForm :: Name -> Q [Dec]+deriveNewtypeForm typeName = do+  let typeCon = conT typeName+  [d|+    deriving newtype instance Show $(typeCon)++    deriving newtype instance Eq $(typeCon)++    deriving newtype instance Ord $(typeCon)++    deriving newtype instance ToForm $(typeCon)++    deriving newtype instance FromForm $(typeCon)++    deriving newtype instance ToSchema $(typeCon)+    |]++-- | Derives standard WEB-classes for a type suitable for request form+deriveForm :: Name -> Q [Dec]+deriveForm typeName = do+  let typeCon = conT typeName+  [d|+    deriving instance Show $(typeCon)++    deriving instance Eq $(typeCon)++    deriving instance Ord $(typeCon)++    deriving instance Generic $(typeCon)++    deriving instance FromForm $(typeCon)++    deriving instance ToForm $(typeCon)++    deriving instance ToSchema $(typeCon)+    |]++deriveNewtypeHttp :: Name -> Q [Dec]+deriveNewtypeHttp = deriveNewtypeParamBody++deriveHttp :: Name -> Q [Dec]+deriveHttp = deriveParamBody++-- | Derives standard WEB-classes for a newtype which is both body and param+deriveNewtypeParamBody :: Name -> Q [Dec]+deriveNewtypeParamBody typeName = do+  let typeCon = conT typeName+  [d|+    deriving newtype instance Show $(typeCon)++    deriving newtype instance Eq $(typeCon)++    deriving newtype instance Ord $(typeCon)++    deriving newtype instance ToJSON $(typeCon)++    deriving newtype instance FromJSON $(typeCon)++    deriving newtype instance ToSchema $(typeCon)++    deriving newtype instance ToParamSchema $(typeCon)++    deriving newtype instance ToHttpApiData $(typeCon)++    deriving newtype instance FromHttpApiData $(typeCon)+    |]++-- | Derives standard WEB-classes for a type which is both body and param+deriveParamBody :: Name -> Q [Dec]+deriveParamBody typeName = do+  let typeCon = conT typeName+  [d|+    deriving stock instance Show $(typeCon)++    deriving stock instance Eq $(typeCon)++    deriving stock instance Ord $(typeCon)++    deriving stock instance Generic $(typeCon)++    deriving anyclass instance ToJSON $(typeCon)++    deriving anyclass instance FromJSON $(typeCon)++    deriving anyclass instance ToSchema $(typeCon)++    deriving anyclass instance ToParamSchema $(typeCon)++    deriving anyclass instance ToHttpApiData $(typeCon)++    deriving anyclass instance FromHttpApiData $(typeCon)+    |]

@@ -0,0 +1,24 @@+-- | Plugin to handle authorization. Just a sketch for now.+module Mig.Extra.Plugin.Auth (+  WithAuth (..),+  withHeaderAuth,+) where++import Control.Monad.IO.Class+import Mig.Core++-- | Authorization plugin interface+data WithAuth m token resp = WithAuth+  { isValid :: token -> m Bool+  -- ^ check that token is valid+  , authFail :: token -> m resp+  -- ^ how to respond on failure+  }++-- | Creates plugin that applies check of auth credentials which are passed as HTTP Header with name auth.+withHeaderAuth :: forall m token resp. (IsResp resp, MonadIO m) => WithAuth m token resp -> Header "auth" token -> Plugin m+withHeaderAuth env (Header token) = processResponse $ \getResp -> do+  isOk <- env.isValid token+  if isOk+    then getResp+    else Just . toResponse <$> env.authFail token

@@ -0,0 +1,24 @@+-- | Plugins to handle exceptions+module Mig.Extra.Plugin.Exception (+  handleRespError,+) where++import Control.Exception (Exception)+import Control.Monad.Catch (MonadCatch, try)+import Control.Monad.IO.Class++import Mig.Core++{-| Catches the run-time exceptions and converts them to responses.+This way of using errors is not recommended. Better use response of the type @RespOr@.+-}+handleRespError ::+  forall a b m.+  (MonadIO m, MonadCatch m, Exception a, IsResp b) =>+  (a -> m b) ->+  Plugin m+handleRespError handle = fromPluginFun $ \f -> \req -> do+  eResult <- try @m @a (f req)+  case eResult of+    Right res -> pure res+    Left err -> Just . toResponse <$> handle err

@@ -0,0 +1,193 @@+{-| Debug utils for server. Simple logger for HTTP requests and responses+Also we can use real logging functions with ***By versions of the logger functions.+Simple variants are only for local testing. It prints to stdout+with no ordering of the concurrent prints.++It can be useful for fast setup of debug for your application. Example of the usage:++> applyPlugin (logHttp V2) server+-}+module Mig.Extra.Plugin.Trace (+  logReq,+  logResp,+  logReqBy,+  logRespBy,+  logHttp,+  logHttpBy,+  ppReq,+  Verbosity (..),+) where++import Control.Monad+import Control.Monad.IO.Class+import Data.Aeson ((.=))+import Data.Aeson qualified as Json+import Data.Aeson.Key qualified as Json+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as B+import Data.ByteString.Lazy.Char8 qualified as BL+import Data.CaseInsensitive (CI)+import Data.CaseInsensitive qualified as CI+import Data.Map.Strict qualified as Map+import Data.String+import Data.Text (Text)+import Data.Text.Encoding qualified as Text+import Data.Time+import Data.Yaml qualified as Yaml+import Network.HTTP.Media.RenderHeader (renderHeader)+import Network.HTTP.Types.Status (Status (..))+import System.Time.Extra++import Mig.Core++-- | Verbosity level of echo prints+data Verbosity+  = -- | prints nothing+    V0+  | -- | prints time, path query, essential headers+    V1+  | -- | prints V1 + body+    V2+  | -- | prints V2 + all headers+    V3+  deriving (Eq, Ord, Show)++ifLevel :: Verbosity -> Verbosity -> [a] -> [a]+ifLevel current level vals+  | level <= current = vals+  | otherwise = []++-------------------------------------------------------------------------------------+-- through++-- | Logging of requests and responses+logHttp :: (MonadIO m) => Verbosity -> Plugin m+logHttp verbosity = logResp verbosity <> logReq verbosity++-- | Logging of requests and responses with custom logger+logHttpBy :: (MonadIO m) => (Json.Value -> m ()) -> Verbosity -> Plugin m+logHttpBy printer verbosity = logRespBy printer verbosity <> logReqBy printer verbosity++-------------------------------------------------------------------------------------+-- request++-- | Logs requests+logReq :: (MonadIO m) => Verbosity -> Plugin m+logReq = logReqBy defaultPrinter++-- | Logs requests with custom logger+logReqBy :: (MonadIO m) => (Json.Value -> m ()) -> Verbosity -> Plugin m+logReqBy printer verbosity = toPlugin $ \(RawRequest req) -> prependServerAction $ do+  when (verbosity > V0) $ do+    reqTrace <- liftIO $ do+      eBody <- req.readBody+      now <- getCurrentTime+      pure $ ppReq verbosity (Just now) eBody req+    printer reqTrace++-- | Pretty prints the request+ppReq :: Verbosity -> Maybe UTCTime -> Either Text BL.ByteString -> Request -> Json.Value+ppReq verbosity now body req =+  Json.object $+    concat $+      [ ifLevel verbosity V1 $+          mconcat+            [ maybe [] (pure . ("time" .=)) now+            ,+              [ "type" .= ("http-request" :: Text)+              , "path" .= toFullPath req+              , "method" .= Text.decodeUtf8 (renderHeader req.method)+              ]+            ]+      , ifLevel+          verbosity+          V2+          [ "body" .= fromBody body+          ]+      , ["headers" .= fromHeaders req.headers]+      ]+  where+    fromHeaders headers = Json.object $ fmap go $ onVerbosity $ (Map.toList headers)+      where+        go (name, val) =+          headerName name .= Text.decodeUtf8 val++        onVerbosity+          | verbosity < V3 = filter ((\name -> name == "Accept" || name == "Content-Type") . fst)+          | otherwise = id++    fromBody :: Either Text BL.ByteString -> Json.Value+    fromBody+      | isJsonReq = either Json.String jsonBody+      | otherwise = Json.String . either id (Text.decodeUtf8 . BL.toStrict)++    isJsonReq = Map.lookup "Content-Type" req.headers == Just "application/json"++-------------------------------------------------------------------------------------+-- response++-- | Logs response+logResp :: (MonadIO m) => Verbosity -> Plugin m+logResp = logRespBy defaultPrinter++-- | Logs response with custom logger+logRespBy :: forall m. (MonadIO m) => (Json.Value -> m ()) -> Verbosity -> Plugin m+logRespBy printer verbosity = toPlugin go+  where+    go :: PluginFun m+    go = \f -> \req -> do+      (dur, resp) <- duration (f req)+      when (verbosity > V0) $ do+        now <- liftIO getCurrentTime+        mapM_ (printer . ppResp verbosity now dur req) resp+      pure resp++-- | Pretty prints the response+ppResp :: Verbosity -> UTCTime -> Seconds -> Request -> Response -> Json.Value+ppResp verbosity now dur req resp =+  Json.object $+    concat+      [ ifLevel+          verbosity+          V1+          [ "time" .= now+          , "duration" .= dur+          , "type" .= ("http-response" :: Text)+          , "path" .= toFullPath req+          , "status" .= resp.status.statusCode+          , "method" .= Text.decodeUtf8 (renderHeader req.method)+          ]+      , ifLevel+          verbosity+          V2+          ["body" .= fromBody resp.body]+      , ["headers" .= fromHeaders resp.headers]+      ]+  where+    fromHeaders headers = Json.object $ fmap go $ headers+      where+        go (name, val) = headerName name .= Text.decodeUtf8 val++    fromBody = \case+      RawResp mediaType bs | mediaType == "application/json" -> jsonBody bs+      RawResp _ bs -> Json.String $ Text.decodeUtf8 (BL.toStrict bs)+      FileResp file -> Json.object ["file" .= file]+      StreamResp -> Json.object ["stream" .= ()]++-------------------------------------------------------------------------------------+-- utils++-- | Default printer+defaultPrinter :: (MonadIO m) => Json.Value -> m ()+defaultPrinter =+  liftIO . B.putStrLn . Yaml.encode . addLogPrefix++addLogPrefix :: Json.Value -> Json.Value+addLogPrefix val = Json.object ["log" .= val]++headerName :: CI ByteString -> Json.Key+headerName name = Json.fromText (Text.decodeUtf8 $ CI.foldedCase name)++jsonBody :: BL.ByteString -> Json.Value+jsonBody =+  either fromString id . Json.eitherDecode

@@ -0,0 +1,133 @@+-- | Module for common re-exports+module Mig.Extra.Server.Common (+  -- * types+  Server (..),+  Api (..),+  Path (..),+  PathItem (..),+  Route (..),++  -- * DSL+  Json,+  AnyMedia,+  OctetStream,+  FormUrlEncoded,+  ToServer (..),+  ToRoute (..),+  MediaType,+  ToMediaType (..),+  ToRespBody (..),++  -- ** response+  IsResp (..),+  badReq,+  internalServerError,+  notImplemented,+  redirect,+  setHeader,++  -- ** methods+  Send (..),+  IsMethod (..),+  GET,+  POST,+  PUT,+  DELETE,+  PATCH,+  OPTIONS,+  HEAD,+  TRACE,++  -- ** path and query++  -- | Build API for routes with queries and captures.+  -- Use monoid to combine several routes together.+  (/.),+  Capture (..),+  Query (..),+  QueryFlag (..),+  Optional (..),+  Header (..),+  PathInfo (..),+  FullPathInfo (..),+  RawRequest (..),++  -- ** response++  -- | How to modify response and attach specific info to it++  -- ** specific cases+  staticFiles,++  -- ** Plugins+  Plugin (..),+  PluginFun,+  ToPlugin (..),+  applyPlugin,+  ($:),+  prependServerAction,+  appendServerAction,+  processResponse,++  -- ** Low-level types+  Request,+  Response,+  okResponse,+  badResponse,+  badRequest,+  ServerFun,++  -- ** Render++  -- | Render Reader-IO monad servers to IO servers.+  HasServer (..),+  fromReader,++  -- * Convertes+  ToText (..),++  -- ** Server+  mapRouteInfo,+  mapServerFun,+  mapResponse,+  atPath,+  filterPath,+  getServerPaths,+  addPathLink,++  -- ** OpenApi+  toOpenApi,+  setDescription,+  describeInputs,+  setSummary,+  module X,+) where++import Mig.Core hiding (+  Delete,+  Get,+  Head,+  Options,+  Patch,+  Post,+  Put,+  Resp,+  RespOr,+  Trace,+ )++-- common codecs and types++import Control.Monad.IO.Class as X+import Control.Monad.Trans.Class as X+import Data.Aeson as X (FromJSON (..), ToJSON (..))+import Data.Default as X+import Data.OpenApi as X (OpenApi, ToParamSchema (..), ToSchema (..))+import Data.Text as X (Text)+import GHC.Generics as X (Generic)+import Mig.Extra.Derive as X+import Network.HTTP.Types.Header as X (RequestHeaders, ResponseHeaders)+import Network.HTTP.Types.Status as X+import Text.Blaze.Html as X (Html, ToMarkup (..))+import Web.FormUrlEncoded as X+import Web.HttpApiData as X

@@ -0,0 +1,42 @@+{-# LANGUAGE UndecidableInstances #-}++-- | Html servers+module Mig.Extra.Server.Html (+  -- * Http verbs+  Get,+  Post,+  Put,+  Delete,+  Patch,+  Options,+  Head,+  Trace,++  -- * Response+  Resp (..),+  RespOr,++  -- * re-exports+  Body (..),+  module X,+) where++import Mig.Core (Body (..))+import Mig.Core qualified as Core+import Mig.Extra.Server.Common as X++-- response++newtype Resp a = Resp (Core.Resp Html a)+  deriving newtype (IsResp)++type RespOr err a = Either (Resp err) (Resp a)++type Get m a = Send GET m (Resp a)+type Post m a = Send POST m (Resp a)+type Put m a = Send PUT m (Resp a)+type Delete m a = Send DELETE m (Resp a)+type Patch m a = Send PATCH m (Resp a)+type Options m a = Send OPTIONS m (Resp a)+type Head m a = Send HEAD m (Resp a)+type Trace m a = Send TRACE m (Resp a)

@@ -0,0 +1,33 @@+-- | Html IO-based servers+module Mig.Extra.Server.Html.IO (+  -- * Http verbs+  Get,+  Post,+  Put,+  Delete,+  Patch,+  Options,+  Head,+  Trace,++  -- * Response+  Resp (..),+  RespOr,++  -- * re-exports+  Body (..),+  module X,+) where++import Mig.Core (Body (..))+import Mig.Extra.Server.Common as X+import Mig.Extra.Server.Html (Resp (..), RespOr)++type Get a = Send GET IO (Resp a)+type Post a = Send POST IO (Resp a)+type Put a = Send PUT IO (Resp a)+type Delete a = Send DELETE IO (Resp a)+type Patch a = Send PATCH IO (Resp a)+type Options a = Send OPTIONS IO (Resp a)+type Head a = Send HEAD IO (Resp a)+type Trace a = Send TRACE IO (Resp a)

@@ -0,0 +1,32 @@+-- | IO-servers+module Mig.Extra.Server.IO (+  -- * Http verbs+  Get,+  Post,+  Put,+  Delete,+  Patch,+  Options,+  Head,+  Trace,++  -- * Response+  Resp (..),+  RespOr,++  -- * re-exports+  Body (..),+  module X,+) where++import Mig.Core (Body (..), Resp (..), RespOr)+import Mig.Extra.Server.Common as X++type Get a = Send GET IO a+type Post a = Send POST IO a+type Put a = Send PUT IO a+type Delete a = Send DELETE IO a+type Patch a = Send PATCH IO a+type Options a = Send OPTIONS IO a+type Head a = Send HEAD IO a+type Trace a = Send TRACE IO a

@@ -0,0 +1,78 @@+{-# LANGUAGE UndecidableInstances #-}++-- | Json servers+module Mig.Extra.Server.Json (+  -- * Http verbs+  Get,+  Post,+  Put,+  Delete,+  Patch,+  Options,+  Head,+  Trace,++  -- * Json request body+  Body (..),++  -- * Json response+  Resp,+  RespOr,++  -- * re-exports+  module X,+)+where++import Mig.Client (FromClient (..), ToClient (..))+import Mig.Core (+  Delete,+  Get,+  Head,+  Options,+  Patch,+  Post,+  Put,+  Trace,+ )+import Mig.Core qualified as Core+import Mig.Extra.Server.Common as X++-- response++newtype Resp a = Resp (Core.Resp Json a)+  deriving newtype (IsResp, Functor)++newtype RespOr err a = RespOr (Core.RespOr Json err a)+  deriving newtype (IsResp, Functor)++-- request++-- | Special case for request Body with JSON.+newtype Body a = Body a++instance (ToSchema a, FromJSON a, ToRoute b) => ToRoute (Body a -> b) where+  toRouteInfo = toRouteInfo @(Core.Body Json a -> b)++  toRouteFun f =+    (toRouteFun :: ((Core.Body Json a -> b) -> ServerFun (Core.MonadOf b)))+      (\(Core.Body a) -> f (Body a))++instance (FromJSON a, ToSchema a, ToPlugin b) => ToPlugin (Body a -> b) where+  toPluginInfo = toPluginInfo @(Core.Body Json a -> b)++  toPluginFun f =+    (toPluginFun :: ((Core.Body Json a -> b) -> PluginFun (Core.MonadOf b)))+      (\(Core.Body a) -> f (Body a))++-- client instances++instance (ToJSON a, ToClient b) => ToClient (Body a -> b) where+  toClient api = (\f -> \(Body b) -> f (Core.Body b)) $ toClient @(Core.Body Json a -> b) api+  clientArity = clientArity @(Core.Body Json a -> b)++instance (FromClient b) => FromClient (Body a -> b) where+  type ClientResult (Body a -> b) = ClientResult (Core.Body Json a -> b)+  fromClient f arg = fromClient @(Core.Body Json a -> b) (f . Body . fromBody) arg+    where+      fromBody (Core.Body a) = a

@@ -0,0 +1,9 @@+-- | Json IO-based servers+module Mig.Extra.Server.Json.IO (+  -- * re-exports+  module X,+) where++import Mig.Extra.Server.Common as X+import Mig.Extra.Server.IO as X (Delete, Get, Head, Options, Patch, Post, Put, Trace)+import Mig.Extra.Server.Json as X (Body (..), Resp, RespOr)