packages feed

minion (empty) → 0.1.0.0

raw patch · 50 files changed

+3037/−0 lines, 50 filesdep +aesondep +basedep +base64-bytestring

Dependencies added: aeson, base, base64-bytestring, binary, bytestring, case-insensitive, containers, exceptions, filepath, http-api-data, http-media, http-types, minion, string-conversions, text, transformers, wai, warp

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2024 ++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,45 @@+# Minion++Minion is Haskell library for developing web applications. It stands between [Scotty](https://hackage.haskell.org/package/scotty) and [Servant](https://hackage.haskell.org/package/servant-server)  ++|                  | Scotty | Minion | Servant |+| ---------------- | ------ | ------ | ------- |+| As simple as ABC | Yes    | No     | No      |+| At term level    | Yes    | Yes    | No      |+| Typesafe         | No     | Yes    | Yes     |+| Introspectable   | No     | Yes    | Yes     |+| Generated client | No     | No     | Yes     |++  +Since Minion defines servers at the term level, it's easier to start and without excess verbosity.++```haskell+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+module Main where++import Web.Minion+import Network.Wai.Handler.Warp qualified as Warp++main :: IO ()+main = Warp.run 9001 app++app :: ApplicationM IO+app = serve api ++api :: Router Void IO+api = "api" /> +    [ "about" /> handlePlainText @String GET (pure "Hello-World Minion server")+    , "hello" /> capture @String "name" +              .> handlePlainText @String GET (\name -> pure $ "Hello, " <> name <> "!")+    ]+```++Documentation and examples can be found on [Hackage](https://hackage.haskell.org/package/minion)  ++Minion ecosystem also contains following libraries:+* [minion-conduit](https://hackage.haskell.org/package/minion-conduit) +* [minion-htmx](https://hackage.haskell.org/package/minion-htmx) +* [minion-jwt](https://hackage.haskell.org/package/minion-jwt) +* [minion-wai-extra](https://hackage.haskell.org/package/minion-wai-extra) +* [minion-openapi3](https://hackage.haskell.org/package/minion-openapi3)
+ app/BasicAuth.hs view
@@ -0,0 +1,9 @@+module Main where++import Network.Wai.Handler.Warp qualified as Warp+import Web.Minion.Examples.BasicAuth qualified++main :: IO ()+main = do+  app <- Web.Minion.Examples.BasicAuth.app+  Warp.run 9001 app
+ app/ComplexResponse.hs view
@@ -0,0 +1,9 @@+module Main where++import Network.Wai.Handler.Warp qualified as Warp++import Web.Minion.Examples.ComplexResponse qualified++main :: IO ()+main = do+  Warp.run 9001 Web.Minion.Examples.ComplexResponse.app
+ app/HelloWorld.hs view
@@ -0,0 +1,7 @@+module Main where++import Network.Wai.Handler.Warp qualified as Warp+import Web.Minion.Examples.HelloWorld qualified++main :: IO ()+main = Warp.run 9001 Web.Minion.Examples.HelloWorld.app
+ app/Introspection.hs view
@@ -0,0 +1,6 @@+module Main where++import Web.Minion.Examples.Introspection qualified++main :: IO ()+main = Web.Minion.Examples.Introspection.app
+ app/Json.hs view
@@ -0,0 +1,7 @@+module Main where++import Network.Wai.Handler.Warp qualified as Warp+import Web.Minion.Examples.Json++main :: IO ()+main = Warp.run 9001 Web.Minion.Examples.Json.app
+ app/Static.hs view
@@ -0,0 +1,7 @@+module Main where++import Network.Wai.Handler.Warp qualified as Warp+import Web.Minion.Examples.Static qualified++main :: IO ()+main = Warp.run 9001 Web.Minion.Examples.Static.app
+ minion.cabal view
@@ -0,0 +1,186 @@+cabal-version:      3.0+name:               minion+version:            0.1.0.0+license:            MIT+license-file:       LICENSE+category:           Web+synopsis:           A Haskell introspectable web router+maintainer:         goosedb@yandex.ru+build-type:         Simple+extra-source-files: README.md++common common+  ghc-options:        -Wall+  default-extensions:+    AllowAmbiguousTypes+    BlockArguments+    ConstraintKinds+    DataKinds+    DefaultSignatures+    DeriveAnyClass+    DeriveGeneric+    DerivingStrategies+    DerivingStrategies+    DuplicateRecordFields+    DuplicateRecordFields+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    ImportQualifiedPost+    LambdaCase+    MultiParamTypeClasses+    NamedFieldPuns+    OverloadedLists+    OverloadedRecordDot+    OverloadedRecordDot+    OverloadedStrings+    PolyKinds+    RankNTypes+    RecordWildCards+    RoleAnnotations+    ScopedTypeVariables+    TypeApplications+    TypeFamilies+    TypeOperators+    UndecidableInstances+    ViewPatterns++library+  import:           common+  exposed-modules:+    Web.Minion+    Web.Minion.Args+    Web.Minion.Args.Internal+    Web.Minion.Auth+    Web.Minion.Auth.Basic+    Web.Minion.Error+    Web.Minion.Examples.BasicAuth+    Web.Minion.Examples.ComplexResponse+    Web.Minion.Examples.HelloWorld+    Web.Minion.Examples.Introspection+    Web.Minion.Examples.Json+    Web.Minion.Examples.Static+    Web.Minion.Introspect+    Web.Minion.Json+    Web.Minion.Media+    Web.Minion.Media.FormUrlEncoded+    Web.Minion.Media.Json+    Web.Minion.Media.PlainText+    Web.Minion.Raw+    Web.Minion.Request+    Web.Minion.Request.Body+    Web.Minion.Request.Body.FormUrlEncoded+    Web.Minion.Request.Body.Json+    Web.Minion.Request.Body.PlainText+    Web.Minion.Request.Body.Raw+    Web.Minion.Request.Header+    Web.Minion.Request.Header.Internal+    Web.Minion.Request.Method+    Web.Minion.Request.Query+    Web.Minion.Request.Query.Internal+    Web.Minion.Request.Url+    Web.Minion.Response+    Web.Minion.Response.Body+    Web.Minion.Response.Body.Json+    Web.Minion.Response.Body.PlainText+    Web.Minion.Response.Header+    Web.Minion.Response.Status+    Web.Minion.Response.Union+    Web.Minion.Router+    Web.Minion.Router.Internal+    Web.Minion.Static++  build-depends:+    , aeson+    , base >= 4.16 && < 5+    , base64-bytestring+    , binary+    , bytestring+    , case-insensitive+    , containers+    , exceptions+    , filepath+    , http-api-data+    , http-media+    , http-types+    , string-conversions+    , text+    , transformers+    , wai++  hs-source-dirs:   src+  default-language: Haskell2010++executable minion-introspection-example+  import:           common+  main-is:          Introspection.hs+  build-depends:+    , base+    , minion+    , warp++  hs-source-dirs:   app+  default-language: Haskell2010+  ghc-options:      -threaded++executable minion-static-example+  import:           common+  main-is:          Static.hs+  build-depends:+    , base+    , minion+    , warp++  hs-source-dirs:   app+  default-language: Haskell2010+  ghc-options:      -threaded++executable minion-basic-auth-example+  import:           common+  main-is:          BasicAuth.hs+  build-depends:+    , base+    , minion+    , warp++  hs-source-dirs:   app+  default-language: Haskell2010+  ghc-options:      -threaded++executable minion-complex-response-example+  import:           common+  main-is:          ComplexResponse.hs+  build-depends:+    , base+    , minion+    , warp++  hs-source-dirs:   app+  default-language: Haskell2010+  ghc-options:      -threaded++executable minion-json-example+  import:           common+  main-is:          Json.hs+  build-depends:+    , base+    , minion+    , warp++  hs-source-dirs:   app+  default-language: Haskell2010+  ghc-options:      -threaded++executable minion-hello-world-example+  import:           common+  main-is:          HelloWorld.hs+  build-depends:+    , base+    , minion+    , warp++  hs-source-dirs:   app+  default-language: Haskell2010+  ghc-options:      -threaded
+ src/Web/Minion.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE PartialTypeSignatures #-}++module Web.Minion (+  -- * Minion+  Router',+  Router,+  MakeError,++  -- * Combinators+  ValueCombinator,+  Combinator,+  alt,+  (/>),+  (.>),+  (!>),+  hideIntrospection,+  description,++  -- ** Header+  module Web.Minion.Request.Header,++  -- ** Query params+  module Web.Minion.Request.Query,++  -- ** URL+  module Web.Minion.Request.Url,++  -- ** Request+  ReqBody (..),+  reqBody,+  reqPlainText,+  reqFormUrlEncoded,+  reqJson,+  LazyBytes (..),+  lazyBytesBody,+  Chunks (..),+  chunksBody,++  -- ** Response+  NoBody (..),+  ToResponse (..),+  CanRespond (..),++  -- ** Handler+  handle,+  handleJson,+  handlePlainText,+  RespBody (..),+  handleBody,+  module Web.Minion.Request.Method,++  -- ** Middleware+  MiddlewareM,+  middleware,++  -- ** Server+  ApplicationM,+  MinionSettings (..),+  serve,+  serveWithSettings,+  defaultMinionSettings,+  defaultErrorBuilders,++  -- ** Exceptions+  NoMatch (..),+  SomethingWentWrong (..),+  ServerError (..),++  -- ** Args+  module Web.Minion.Args,++  -- ** Auth+  module Web.Minion.Auth,++  -- ** Reexports+  Void,+  Exc.MonadCatch (..),+  Exc.MonadThrow (..),+) where++import Control.Monad ((>=>))+import Control.Monad.Catch qualified as Exc+import Control.Monad.IO.Class qualified as IO+import Data.Binary.Builder qualified as Bytes.Builder+import Data.Text qualified as Text+import Data.Void (Void)+import Network.HTTP.Types qualified as Http+import Network.Wai qualified as Http+import Network.Wai qualified as Wai+import Web.Minion.Args+import Web.Minion.Args.Internal+import Web.Minion.Auth+import Web.Minion.Error (+  ErrorBuilders (..),+  NoMatch (..),+  ServerError (..),+  SomethingWentWrong (..),+ )++import Web.Minion.Introspect qualified as I+import Web.Minion.Json (handleJson, reqJson)+import Web.Minion.Raw+import Web.Minion.Request.Body (ReqBody (..), reqBody)+import Web.Minion.Request.Body.FormUrlEncoded+import Web.Minion.Request.Body.PlainText+import Web.Minion.Request.Body.Raw+import Web.Minion.Request.Header+import Web.Minion.Request.Method+import Web.Minion.Request.Query+import Web.Minion.Request.Url+import Web.Minion.Response+import Web.Minion.Response.Body (RespBody (RespBody), handleBody)+import Web.Minion.Response.Body.PlainText (handlePlainText)+import Web.Minion.Router.Internal++-- | Use it if you don't care about value captured by previous combinator+{-# INLINE (!>) #-}+(!>) ::+  (Router' i (ts :+ x) r -> Router' i ts r) ->+  -- | .+  Router' i (ts :+ Hide x) r ->+  Router' i ts r+a !> b = a .> MapArgs (\case (x :#! as) -> Hide x :#! as) .> b++-- | Use it after 'Combinator'+{-# INLINE (/>) #-}+(/>) ::+  (Router' i ts r -> Router' i ts r) ->+  -- | .+  Router' i ts r ->+  Router' i ts r+(/>) = id++-- | Use it after 'ValueCombinator' and 'MapArgs'+{-# INLINE (.>) #-}+(.>) ::+  (Router' i ts' r -> Router' i ts r) ->+  -- | .+  Router' i ts' r ->+  Router' i ts r+(.>) = id++infixr 0 .>++infixr 0 />++infixr 0 !>++{- | Could be omitted with `OverloadedLists`++@+{\-# LANGUAGE OverloadedLists #-\}+"foo" '/>'+  [ "bar" '/>' ...+  , "baz" '/>' ...+  ]+@++@+{\-# LANGUAGE NoOverloadedLists #-\}+"foo" '/>' 'alt'+  [ "bar" '/>' ...+  , "baz" '/>' ...+  ]+@+-}+{-# INLINE alt #-}+alt :: [Router' i ts r] -> Router' i ts r+alt = Alt++{- | Handles request with specified HTTP method++@+... '/>' 'handle' \@MyResponse GET someEndpoint+@+-}+{-# INLINE handle #-}+handle ::+  forall o m ts i st.+  ( HandleArgs ts st m+  , ToResponse m o+  , CanRespond o+  , I.Introspection i I.Response o+  ) =>+  -- | .+  Http.Method ->+  (DelayedArgs st ~> m o) ->+  Router' i ts m+handle method f = Handle @o method (apply f)++-- | Add description for route+description :: (I.Introspection i I.Description a) => a -> Combinator i ts m+description = Description++hideIntrospection :: Router' i ts m -> Router' i' ts m+hideIntrospection = HideIntrospection++{- | Injects middleware++@+... '/>' 'middleware' Wai.realIp '/>' ...+@+-}+middleware :: MiddlewareM m -> Combinator i ts m+middleware = Middleware++data MinionSettings m = MinionSettings+  { notFound :: m Wai.Response+  , httpError :: ServerError -> m Wai.Response+  , errorBuilders :: ErrorBuilders+  }++{-# INLINE serve #-}+serve :: (IO.MonadIO m, Exc.MonadCatch m) => Router' i Void m -> ApplicationM m+serve = serveWithSettings defaultMinionSettings++defaultMinionSettings :: (IO.MonadIO m, Exc.MonadCatch m) => MinionSettings m+defaultMinionSettings =+  MinionSettings+    { notFound = pure (Wai.responseBuilder Http.status404 [] mempty)+    , httpError = \ServerError{..} -> pure $ Wai.responseBuilder code headers (Bytes.Builder.fromLazyByteString body)+    , errorBuilders = defaultErrorBuilders+    }++defaultErrorBuilders :: ErrorBuilders+defaultErrorBuilders =+  ErrorBuilders+    { headerErrorBuilder = defaultBuilder+    , queryParamsErrorBuilder = defaultBuilder+    , captureErrorBuilder = defaultBuilder+    , bodyErrorBuilder = defaultBuilder+    }+ where+  defaultBuilder _ status = ServerError status []++-- | The same as 'serve' but allows to configure exceptions handlers+{-# INLINE serveWithSettings #-}+serveWithSettings :: (IO.MonadIO m, Exc.MonadCatch m) => MinionSettings m -> Router' i Void m -> ApplicationM m+serveWithSettings MinionSettings{..} router req resp =+  Exc.catches @[]+    (route errorBuilders (RoutingState (filter (not . Text.null) $ Http.pathInfo req)) RHNil router req resp)+    [ Exc.Handler \NoMatch -> notFound >>= IO.liftIO . resp+    , Exc.Handler $ httpError >=> IO.liftIO . resp+    ]
+ src/Web/Minion/Args.hs view
@@ -0,0 +1,23 @@+module Web.Minion.Args (+  Lenient,+  Strict,+  Required,+  Optional,+  IsLenient (..),+  IsRequired (..),+  WithReq (..),+  WithHeader (..),+  WithPiece (..),+  WithPieces (..),+  WithQueryParam (..),+  Hide (..),+  DelayedArgs,+  type (~>),+  HandleArgs,+  HList (..),+  RHList (..),+  (:+),+  GetByType (..),+) where++import Web.Minion.Args.Internal
+ src/Web/Minion/Args/Internal.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}++module Web.Minion.Args.Internal where++import Data.Functor (($>))+import Data.Kind (Type)+import Data.Void (Void)+import Web.Minion.Request (IsRequest (..))++data (a :: Type) :+ (b :: Type)++infixl 9 :++data HList ts where+  HNil :: HList '[]+  (:#) :: t -> HList ts -> HList (t ': ts)++-- | Reversed HList+data RHList ts where+  RHNil :: RHList Void+  (:#!) :: t -> RHList ts -> RHList (ts :+ t)++type family MapElem ts t t' where+  MapElem (ts :+ t) t t' = ts :+ t'+  MapElem (ts :+ x) t t' = MapElem ts t t' :+ x+  MapElem Void t t' = Void++infixr 1 :#+infixr 1 :#!++deriving instance Show (RHList Void)+deriving instance (Show (RHList as), Show a) => Show (RHList (as :+ a))++deriving instance Show (HList '[])+deriving instance (Show (HList as), Show a) => Show (HList (a ': as))++type family RevToList ts where+  RevToList Void = '[]+  RevToList (as :+ a) = a ': RevToList as++class RHListToHList (ts :: Type) where+  type HListTypes ts :: [Type]+  revHListToList :: RHList ts -> HList (HListTypes ts)++instance RHListToHList Void where+  type HListTypes Void = '[]+  revHListToList _ = HNil++instance (RHListToHList as) => RHListToHList (as :+ a) where+  type HListTypes (as :+ a) = a ': HListTypes as+  revHListToList (a :#! as) = a :# revHListToList as++class GetByType t ts where+  getByType :: HList ts -> t++instance (GetByType t ts) => GetByType t (x ': ts) where+  getByType (_ :# as) = getByType @t @ts as++instance {-# OVERLAPPING #-} GetByType t (t ': ts) where+  getByType (a :# _) = a++class Reverse' (l1 :: [Type]) (l2 :: [Type]) (l3 :: [Type]) | l1 l2 -> l3 where+  reverse' :: HList l1 -> HList l2 -> HList l3++instance Reverse' '[] l2 l2 where+  reverse' _ l = l++instance (Reverse' l (x ': l') z) => Reverse' (x ': l) l' z where+  reverse' (x :# l) l' = reverse' l (x :# l')++class Reverse xs sx | xs -> sx, sx -> xs where+  reverseHList :: HList xs -> HList sx++instance+  ( Reverse' xs '[] sx+  , Reverse' sx '[] xs+  ) =>+  Reverse xs sx+  where+  reverseHList l = reverse' l HNil++data Lenient e+data Strict++data Required+data Optional++class IsRequired a where+  isRequired :: Bool++instance IsRequired Required where+  isRequired = True++instance IsRequired Optional where+  isRequired = False++class IsLenient a where+  isLenient :: Bool++instance IsLenient (Lenient a) where+  isLenient = True++instance IsLenient Strict where+  isLenient = False++type family Arg presence parsing a where+  Arg Required (Lenient e) a = (Either e a)+  Arg Required Strict a = a+  Arg Optional (Lenient e) a = (Maybe (Either e a))+  Arg Optional Strict a = (Maybe a)++newtype WithHeader presence parsing m a = WithHeader (m (Arg presence parsing a))+newtype WithQueryParam presence parsing m a = WithQueryParam (m (Arg presence parsing a))+newtype WithPiece a = WithPiece a+newtype WithPieces a = WithPieces [a]+newtype WithReq m r = WithReq (m r)+newtype Hide a = Hide a++class Hidden m a where+  runHidden :: Hide a -> m ()++instance (Monad m) => Hidden m (WithHeader a b m a) where+  runHidden (Hide (WithHeader a)) = a $> ()++instance (Monad m) => Hidden m (WithQueryParam a b m a) where+  runHidden (Hide (WithQueryParam a)) = a $> ()++instance (Monad m) => Hidden m (WithPiece a) where+  runHidden (Hide (WithPiece _)) = pure ()++instance (Monad m) => Hidden m (WithPieces a) where+  runHidden (Hide (WithPieces _)) = pure ()++instance (Monad m) => Hidden m (WithReq m a) where+  runHidden (Hide (WithReq a)) = a $> ()++instance (Hidden m a) => Hidden m (Hide a) where+  runHidden (Hide a) = runHidden a++class FunArgs (ts :: [Type]) where+  type ts ~> r :: Type++  apply :: (ts ~> r) -> HList ts -> r++type HandleArgs ts st m =+  ( FunArgs (DelayedArgs st)+  , RHListToHList ts+  , Reverse (HListTypes ts) st+  , RunDelayed st m+  , Monad m+  )++instance FunArgs '[] where+  type '[] ~> r = r+  {-# INLINE apply #-}+  apply a _ = a++instance (FunArgs as) => FunArgs (a ': as) where+  type (a ': as) ~> r = a -> as ~> r+  {-# INLINE apply #-}+  apply a (x :# xs) = apply (a x) xs++class (Monad m) => RunDelayed ts m where+  type DelayedArgs ts :: [Type]+  runDelayed :: HList ts -> m (HList (DelayedArgs ts))++instance (Monad m) => RunDelayed '[] m where+  type DelayedArgs '[] = '[]+  {-# INLINE runDelayed #-}+  runDelayed HNil = pure HNil++instance (RunDelayed as m) => RunDelayed (WithHeader required lenient m a ': as) m where+  type DelayedArgs (WithHeader required lenient m a ': as) = Arg required lenient a ': DelayedArgs as+  {-# INLINE runDelayed #-}+  runDelayed (WithHeader hIO :# as) = do+    h <- hIO+    rest <- runDelayed as+    pure $ h :# rest++instance (RunDelayed as m, IsRequest r) => RunDelayed (WithReq m r ': as) m where+  type DelayedArgs (WithReq m r ': as) = RequestValue r ': DelayedArgs as+  {-# INLINE runDelayed #-}+  runDelayed (WithReq hIO :# as) = do+    h <- hIO+    rest <- runDelayed as+    pure $ getRequestValue h :# rest++instance (RunDelayed as m) => RunDelayed (WithQueryParam required lenient m a ': as) m where+  type DelayedArgs (WithQueryParam required lenient m a ': as) = Arg required lenient a ': DelayedArgs as+  {-# INLINE runDelayed #-}+  runDelayed (WithQueryParam a :# as) = do+    a' <- a+    rest <- runDelayed as+    pure $ a' :# rest++instance (RunDelayed as m) => RunDelayed (WithPiece a ': as) m where+  type DelayedArgs (WithPiece a ': as) = a ': DelayedArgs as+  {-# INLINE runDelayed #-}+  runDelayed (WithPiece a :# as) = do+    rest <- runDelayed as+    pure $ a :# rest++instance (RunDelayed as m) => RunDelayed (WithPieces a ': as) m where+  type DelayedArgs (WithPieces a ': as) = [a] ': DelayedArgs as+  {-# INLINE runDelayed #-}+  runDelayed (WithPieces a :# as) = do+    rest <- runDelayed as+    pure $ a :# rest++instance (RunDelayed as m, Hidden m a) => RunDelayed (Hide a ': as) m where+  type DelayedArgs (Hide a ': as) = DelayedArgs as+  {-# INLINE runDelayed #-}+  runDelayed (a :# as) = runHidden a >> runDelayed as
+ src/Web/Minion/Auth.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DeriveFunctor #-}++module Web.Minion.Auth where++import Data.Kind (Type)+import Data.Void (Void, absurd)+import Network.Wai qualified as Wai+import Web.Minion.Args (GetByType (getByType), HList, WithReq)+import Web.Minion.Error+import Web.Minion.Introspect qualified as I+import Web.Minion.Request+import Web.Minion.Router++newtype Auth (auths :: [Type]) a = Auth a++instance IsRequest (Auth auths a) where+  type RequestValue (Auth auths a) = a+  getRequestValue (Auth a) = a++data AuthResult a+  = Indefinite+  | BadAuth+  | Authenticated a+  deriving (Functor)++class UnwindAuth (ctx :: [Type]) (auths :: [Type]) m a where+  unwindAuth :: [HList ctx -> ErrorBuilder -> Wai.Request -> m (AuthResult a)]++class IsAuth (auth :: Type) m a where+  type Settings auth m a :: Type+  toAuth :: Settings auth m a -> ErrorBuilder -> Wai.Request -> m (AuthResult a)++instance+  ( IsAuth auth m a+  , UnwindAuth ctx auths m a+  , GetByType (Settings auth m a) ctx+  ) =>+  UnwindAuth ctx (auth ': auths) m a+  where+  {-# INLINE unwindAuth #-}+  unwindAuth = (toAuth @auth . getByType) : (unwindAuth @ctx @auths)++instance UnwindAuth ctx '[] m a where+  {-# INLINE unwindAuth #-}+  unwindAuth = []++{-# INLINE auth #-}+auth ::+  forall auths a m ctx ts i.+  (I.Introspection i I.Request (Auth auths a)) =>+  (UnwindAuth ctx auths m a) =>+  (MonadThrow m) =>+  -- | Context with auths settings+  m (HList ctx) ->+  -- |  Handle non-Authenticated.+  (MakeError -> AuthResult Void -> m Void) ->+  ValueCombinator i (WithReq m (Auth auths a)) ts m+auth ctxm cont = Request \errorBuilder req -> do+  ctx <- ctxm+  let auths = unwindAuth @ctx @auths @m @a+      {-# INLINE go #-}+      go [] = pure Indefinite+      go (a : as) =+        a ctx errorBuilder req >>= \case+          Indefinite -> go as+          r -> pure r+  go auths+    >>= fmap Auth . \case+      Authenticated a -> pure a+      BadAuth -> absurd <$> cont (errorBuilder req) BadAuth+      Indefinite -> absurd <$> cont (errorBuilder req) BadAuth
+ src/Web/Minion/Auth/Basic.hs view
@@ -0,0 +1,52 @@+module Web.Minion.Auth.Basic where++import Control.Monad.Trans.Maybe (MaybeT (..))+import Data.ByteString qualified as Bytes+import Data.ByteString.Base64 qualified as Bytes.Base64+import Data.Function ((&))+import Data.String (IsString (..))+import Data.String.Conversions (ConvertibleStrings (convertString))+import Network.HTTP.Types.Header qualified as Http+import Network.Wai qualified as Wai+import Web.Minion++newtype BasicAuthSettings m a = BasicAuthSettings+  { check :: MakeError -> BasicAuth -> m (AuthResult a)+  }++data BasicAuth = BasicAuth+  { username :: Username+  , password :: Password+  }+  deriving (Eq, Ord)++newtype Username = Username {rawUsername :: Bytes.ByteString}+  deriving (Eq, Ord)++instance IsString Username where+  fromString = Username . convertString++instance IsString Password where+  fromString = Password . convertString++newtype Password = Password {rawPassword :: Bytes.ByteString}+  deriving (Eq, Ord)++data Basic++instance (Monad m) => IsAuth Basic m a where+  type Settings Basic m a = BasicAuthSettings m a+  toAuth BasicAuthSettings{..} buildError req = do+    mbBasicAuth <- runMaybeT do+      authHeader <- Wai.requestHeaders req & lookup Http.hAuthorization & hoistMaybe+      base64 <- Bytes.stripPrefix "Basic " authHeader & hoistMaybe+      let decoded = base64 & Bytes.Base64.decodeLenient+      -- 58 is ':'+      [Username -> username, Password -> password] <- Bytes.split 58 decoded & pure & hoistMaybe+      pure BasicAuth{..}+    maybe+      do pure Indefinite+      do check (buildError req)+      do mbBasicAuth+   where+    hoistMaybe = MaybeT . pure
+ src/Web/Minion/Error.hs view
@@ -0,0 +1,230 @@+module Web.Minion.Error (MonadThrow (..), module Web.Minion.Error) where++import Control.Exception+import Control.Monad.Catch (MonadThrow (..))+import Data.ByteString qualified as Bytes+import Data.ByteString.Lazy qualified as Bytes.Lazy+import Network.HTTP.Types qualified as Http+import Network.Wai qualified as Wai++data NoMatch = NoMatch+  deriving (Show, Exception)++type ErrorBuilder = Wai.Request -> Http.Status -> Bytes.Lazy.ByteString -> ServerError++type TextToError = Bytes.Lazy.ByteString -> ServerError++data SomethingWentWrong = SomethingWentWrong+  deriving (Show, Exception)++data ErrorBuilders = ErrorBuilders+  { headerErrorBuilder :: ErrorBuilder+  , queryParamsErrorBuilder :: ErrorBuilder+  , captureErrorBuilder :: ErrorBuilder+  , bodyErrorBuilder :: ErrorBuilder+  }++data ServerError = ServerError+  { code :: Http.Status+  , headers :: [Http.Header]+  , body :: Bytes.Lazy.ByteString+  }+  deriving (Show, Exception)++codeOf :: ServerError -> Http.Status+codeOf ServerError{..} = code++redirect :: (MonadThrow m) => Bytes.ByteString -> m a+redirect url = throwM $ found{headers = [("Location", url)]}++err300 :: ServerError+err300 = ServerError Http.status300 [] mempty++err301 :: ServerError+err301 = ServerError Http.status301 [] mempty++err302 :: ServerError+err302 = ServerError Http.status302 [] mempty++err303 :: ServerError+err303 = ServerError Http.status303 [] mempty++err304 :: ServerError+err304 = ServerError Http.status304 [] mempty++err305 :: ServerError+err305 = ServerError Http.status305 [] mempty++err307 :: ServerError+err307 = ServerError Http.status307 [] mempty++err400 :: ServerError+err400 = ServerError Http.status400 [] mempty++err401 :: ServerError+err401 = ServerError Http.status401 [] mempty++err402 :: ServerError+err402 = ServerError Http.status402 [] mempty++err403 :: ServerError+err403 = ServerError Http.status403 [] mempty++err404 :: ServerError+err404 = ServerError Http.status404 [] mempty++err405 :: ServerError+err405 = ServerError Http.status405 [] mempty++err406 :: ServerError+err406 = ServerError Http.status406 [] mempty++err407 :: ServerError+err407 = ServerError Http.status407 [] mempty++err409 :: ServerError+err409 = ServerError Http.status409 [] mempty++err410 :: ServerError+err410 = ServerError Http.status410 [] mempty++err411 :: ServerError+err411 = ServerError Http.status411 [] mempty++err412 :: ServerError+err412 = ServerError Http.status412 [] mempty++err413 :: ServerError+err413 = ServerError Http.status413 [] mempty++err414 :: ServerError+err414 = ServerError Http.status414 [] mempty++err415 :: ServerError+err415 = ServerError Http.status415 [] mempty++err416 :: ServerError+err416 = ServerError Http.status416 [] mempty++err417 :: ServerError+err417 = ServerError Http.status417 [] mempty++err418 :: ServerError+err418 = ServerError Http.status418 [] mempty++err422 :: ServerError+err422 = ServerError Http.status422 [] mempty++err500 :: ServerError+err500 = ServerError Http.status500 [] mempty++err501 :: ServerError+err501 = ServerError Http.status501 [] mempty++err502 :: ServerError+err502 = ServerError Http.status502 [] mempty++err503 :: ServerError+err503 = ServerError Http.status503 [] mempty++err504 :: ServerError+err504 = ServerError Http.status504 [] mempty++err505 :: ServerError+err505 = ServerError Http.status505 [] mempty++multipleChoices :: ServerError+multipleChoices = err300++movedPermanently :: ServerError+movedPermanently = err301++found :: ServerError+found = err302++seeOther :: ServerError+seeOther = err303++notModified :: ServerError+notModified = err304++useProxy :: ServerError+useProxy = err305++temporaryRedirect :: ServerError+temporaryRedirect = err307++badRequest :: ServerError+badRequest = err400++unauthorized :: ServerError+unauthorized = err401++paymentRequired :: ServerError+paymentRequired = err402++forbidden :: ServerError+forbidden = err403++notFound :: ServerError+notFound = err404++methodNotAllowed :: ServerError+methodNotAllowed = err405++notAcceptable :: ServerError+notAcceptable = err406++proxyAuthenticationRequired :: ServerError+proxyAuthenticationRequired = err407++conflict :: ServerError+conflict = err409++gone :: ServerError+gone = err410++lengthRequired :: ServerError+lengthRequired = err411++preconditionFailed :: ServerError+preconditionFailed = err412++requestEntityTooLarge :: ServerError+requestEntityTooLarge = err413++requestURITooLong :: ServerError+requestURITooLong = err414++unsupportedMediaType :: ServerError+unsupportedMediaType = err415++requestedRangeNotSatisfiable :: ServerError+requestedRangeNotSatisfiable = err416++expectationFailed :: ServerError+expectationFailed = err417++teapot :: ServerError+teapot = err418++unprocessableEntity :: ServerError+unprocessableEntity = err422++internalServerError :: ServerError+internalServerError = err500++notImplemented :: ServerError+notImplemented = err501++badGateway :: ServerError+badGateway = err502++serviceUnavailable :: ServerError+serviceUnavailable = err503++gatewayTimeout :: ServerError+gatewayTimeout = err504++httpVersionNotSupported :: ServerError+httpVersionNotSupported = err505
+ src/Web/Minion/Examples/BasicAuth.hs view
@@ -0,0 +1,47 @@+module Web.Minion.Examples.BasicAuth (app) where++import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Reader (ReaderT (..), ask)+import Data.IORef (IORef, newIORef, readIORef)+import Data.List (elemIndex)+import Web.Minion+import Web.Minion.Auth.Basic+import Web.Minion.Error (codeOf, unauthorized)++type Env = IORef [BasicAuth]+type M = ReaderT Env IO++app :: IO (ApplicationM IO)+app = do+  users <-+    newIORef+      [ BasicAuth "alice" "123"+      , BasicAuth "bob" "312"+      , BasicAuth "admin" "admin"+      ]+  pure $ \req resp -> runReaderT (serve api req resp) users++api :: Router Void M+api = "api" /> "auth" /> "basic" /> myAuth .> handle @NoBody GET endpoint+ where+  endpoint (UserId userId) = liftIO do+    putStrLn $ "Called " <> show userId+    pure NoBody++newtype UserId = UserId Int++basicAuthSettings :: HList '[BasicAuthSettings M UserId]+basicAuthSettings =+  BasicAuthSettings+    { check = \_ ba -> do+        usersRef <- ask+        users <- liftIO $ readIORef usersRef+        pure $ maybe BadAuth (Authenticated . UserId) $ elemIndex ba users+    }+    :# HNil++myAuth :: ValueCombinator Void (WithReq M (Auth '[Basic] UserId)) ts M+myAuth = auth @'[Basic] @UserId (pure basicAuthSettings) \makeError -> \case+  _ -> do+    liftIO $ putStrLn "Unauthozied!"+    throwM $ makeError (codeOf unauthorized) mempty
+ src/Web/Minion/Examples/ComplexResponse.hs view
@@ -0,0 +1,28 @@+module Web.Minion.Examples.ComplexResponse (app) where++import Data.Unique (hashUnique, newUnique)+import Web.Minion+import Web.Minion.Json (Json)+import Web.Minion.Response.Header+import Web.Minion.Response.Status+import Web.Minion.Response.Union++app :: ApplicationM IO+app = serve api++api :: Router Void IO+api = "api" /> "complex" /> handle GET endpoint++endpoint ::+  IO+    ( Union+        [ RespBody '[Json] Int+        , WithStatus SeeOther (AddHeaders '[AddHeader "Location" RawHeaderValue] NoBody)+        ]+    )+endpoint = do+  a <- (== 0) . (`mod` 2) . hashUnique <$> newUnique+  let respJson = RespBody @'[Json] @Int 1+      redirectHeader = AddHeader @"Location" (RawHeaderValue "https://google.com")+      respSeeOther = WithStatus @SeeOther (AddHeaders (redirectHeader :# HNil) NoBody)+  pure if a then inject respJson else inject respSeeOther
+ src/Web/Minion/Examples/HelloWorld.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}++module Web.Minion.Examples.HelloWorld (app) where++import Web.Minion++app :: ApplicationM IO+app = serve @IO api++api :: Router Void IO+api =+  "api"+    /> [ "about" /> handlePlainText @String GET (pure "Hello-World Minion server")+       , "hello" /> capture @String "name" .> handlePlainText @String GET (\name -> pure $ "Hello, " <> name <> "!")+       ]
+ src/Web/Minion/Examples/Introspection.hs view
@@ -0,0 +1,178 @@+module Web.Minion.Examples.Introspection (app) where++import Data.CaseInsensitive qualified as CI+import Data.List (nub)+import Data.Maybe (catMaybes)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text.Encoding+import Data.Text.IO qualified+import GHC.Generics (Generic)+import Network.HTTP.Media+import Web.Minion+import Web.Minion.Auth.Basic+import Web.Minion.Introspect qualified as I+import Web.Minion.Media+import Web.Minion.Router++{-+GET api/post/:postId | Post api; Get post by ID+  Basic auth required+  Response: application/json++POST api/post/:postId | Post api; Create or update post+  Basic auth required+  Request body: text/plain+  Response: application/json++GET api/comments | Comments api; Get comments for post+  Query params: postId!, size?, page?+  Basic auth required+  Response: application/json++POST api/comments/:commentId | Comments api; Create or update comment+  Basic auth required+  Request body: text/plain+  Response: application/json++GET api/images/:pathToImage.. | Images api+  Basic auth required+  Response: raw bytes+-}+app :: IO ()+app = Data.Text.IO.putStrLn $ prettyApi api++prettyApi :: Router' Pretty Void m -> Text+prettyApi = Text.unlines . map prettyInfoToText . go+ where+  prependPath txt PrettyInfo{..} = PrettyInfo{path = txt : path, ..}+  addQueryParam qn isReq PrettyInfo{..} = PrettyInfo{queryParams = (Text.Encoding.decodeUtf8 qn, isReq) : queryParams, ..}+  addDescription txt PrettyInfo{..} = PrettyInfo{descriptions = txt : descriptions, ..}+  addHeader hn isReq PrettyInfo{..} = PrettyInfo{headers = (Text.Encoding.decodeUtf8 (CI.original hn), isReq) : headers, ..}+  addRequest req PrettyInfo{..} = PrettyInfo{request = req : request, ..}++  go :: Router' Pretty a m -> [PrettyInfo]+  go = \case+    Piece txt cont -> map (prependPath txt) (go cont)+    Capture _ txt cont -> map (prependPath (":" <> txt)) (go cont)+    Captures _ txt cont -> map (prependPath (":" <> txt <> "..")) (go cont)+    QueryParam @_ @presence qn _ cont -> map+      do addQueryParam qn (isRequired @presence)+      do go cont+    Description d cont -> map (addDescription (prettyDescription d)) (go cont)+    Middleware _ cont -> go cont+    Header @_ @presence hn _ cont -> map+      do addHeader hn (isRequired @presence)+      do go cont+    Request @r _ cont -> map (addRequest (prettyBody @r)) (go cont)+    Alt alts -> concatMap go alts+    Handle @o method _ -> [PrettyInfo [] [] [] [] (prettyBody @o) (Text.Encoding.decodeUtf8 method) []]+    MapArgs _ cont -> go cont+    HideIntrospection _ -> []++api :: Router' Pretty Void IO+api = "api" /> myAuth .> ["post" /> postApi, "comments" /> commentsApi, "images" /> imagesApi]+ where+  imagesApi = description "Images api" /> captures @String "pathToImage" .> handle @Chunks GET undefined+  postApi =+    description "Post api"+      /> capture @PostId "postId"+      .> [ description "Get post by ID" /> handleJson @Text GET undefined+         , description "Create or update post"+            /> reqPlainText @Text+            .> handleJson @() POST undefined+         ]+  commentsApi =+    description "Comments api"+      /> [+           [ queryParam' @PostId "postId"+              .> queryParam @Size "size"+              .> queryParam @Page "page"+              .> description "Get comments for post"+              /> handleJson @[Text] GET undefined+           , capture @CommentId "commentId"+              .> description "Create or update comment"+              /> reqPlainText @Text+              .> handleJson @() POST undefined+           ]+         ]+  myAuth =+    auth @'[Basic] @UserId+      (pure $ (undefined :: BasicAuthSettings IO UserId) :# HNil)+      undefined++data Pretty++type instance I.Introspection Pretty I.QueryParam = I.AbsolutelyNothing+type instance I.Introspection Pretty I.Capture = I.AbsolutelyNothing+type instance I.Introspection Pretty I.Captures = I.AbsolutelyNothing+type instance I.Introspection Pretty I.Header = I.AbsolutelyNothing+type instance I.Introspection Pretty I.Request = PrettyBody+type instance I.Introspection Pretty I.Response = PrettyBody+type instance I.Introspection Pretty I.Description = PrettyDescription++class PrettyBody a where+  prettyBody :: Text++class PrettyDescription a where+  prettyDescription :: a -> Text++instance (a ~ Text) => PrettyDescription a where+  prettyDescription = id++instance (AllContentTypes cts) => PrettyBody (ReqBody cts a) where+  prettyBody = "Request body: " <> Text.intercalate " or " (mediaTypes @cts)++instance PrettyBody Chunks where+  prettyBody = "Response: raw bytes"++instance PrettyBody (Auth '[Basic] a) where+  prettyBody = "Basic auth required"++instance (AllContentTypes cts) => PrettyBody (RespBody cts a) where+  prettyBody = "Response: " <> Text.intercalate " or " (mediaTypes @cts)++mediaTypes :: forall cts. (AllContentTypes cts) => [Text]+mediaTypes =+  nub+    . map+      do \a -> Text.Encoding.decodeUtf8 $ CI.original (mainType a) <> "/" <> CI.original (subType a)+    $ allContentTypes @cts++type PostId = Int+type UserId = Int+type CommentId = Int+type Size = Int+type Page = Int++data PrettyInfo = PrettyInfo+  { path :: [Text]+  , headers :: [(Text, Bool)]+  , queryParams :: [(Text, Bool)]+  , request :: [Text]+  , response :: Text+  , method :: Text+  , descriptions :: [Text]+  }+  deriving (Generic)++ifNotNull :: [x] -> ([x] -> a) -> Maybe a+ifNotNull [] _ = Nothing+ifNotNull list f = Just $ f list++reqOpt :: (Text, Bool) -> Text+reqOpt (a, r) = a <> if r then "!" else "?"++prettyInfoToText :: PrettyInfo -> Text+prettyInfoToText PrettyInfo{..} =+  Text.unlines $+    method <> " " <> Text.intercalate "/" path <> maybe "" (" | " <>) (ifNotNull descriptions (Text.intercalate "; "))+      : map+        ("  " <>)+        ( catMaybes+            [ ("Query params: " <>) <$> ifNotNull queryParams (Text.intercalate ", " . map reqOpt)+            , ("Headers: " <>) <$> ifNotNull headers (Text.intercalate ", " . map reqOpt)+            ]+            <> request+            <> [response]+        )
+ src/Web/Minion/Examples/Json.hs view
@@ -0,0 +1,40 @@+module Web.Minion.Examples.Json (app) where++import Data.Aeson (FromJSON (..), ToJSON (..), object, (.=))+import GHC.Generics+import Web.Minion++app :: ApplicationM IO+app = serve api++data FooRequest = FooRequest+  { foo :: Int+  , bar :: Int+  }+  deriving (Generic, FromJSON)++data Response a = Success a | Failure Error++instance (ToJSON a) => ToJSON (Response a) where+  toJSON (Success a) = object ["success" .= a]+  toJSON (Failure a) = object ["failure" .= a]++data Error = Error+  { code :: String+  , message :: String+  }+  deriving (Generic, ToJSON)++data FooResponse = FooResponse+  { baz :: Int+  , qux :: Int+  }+  deriving (Generic, ToJSON)++api :: Router Void IO+api = "api" /> "json" /> reqJson @FooRequest .> handleJson @(Response FooResponse) POST endpoint+ where+  endpoint FooRequest{..} = pure do+    if foo + bar < 0+      then Failure (Error "you_died" "That's life")+      else Success (FooResponse bar foo)
+ src/Web/Minion/Examples/Static.hs view
@@ -0,0 +1,15 @@+module Web.Minion.Examples.Static (app) where++import Web.Minion+import Web.Minion.Static++app :: ApplicationM IO+app = serve api++api :: Router Void IO+api = "api" /> "static" /> staticFiles defaultExtsMap files+ where+  files =+    [ ("folder/data.json", "{ \"key\": 1 }")+    , ("another/folder/data.csv", "a;b;c\n1;2;3")+    ]
+ src/Web/Minion/Introspect.hs view
@@ -0,0 +1,25 @@+module Web.Minion.Introspect where++import Data.Kind+import Data.Void (Void)++data Introspected+  = QueryParam+  | Capture+  | Captures+  | Header+  | Request+  | Response+  | Description++type family Introspection i (t :: Introspected) :: Type -> Constraint++type instance Introspection Void QueryParam = AbsolutelyNothing+type instance Introspection Void Capture = AbsolutelyNothing+type instance Introspection Void Captures = AbsolutelyNothing+type instance Introspection Void Header = AbsolutelyNothing+type instance Introspection Void Request = AbsolutelyNothing+type instance Introspection Void Response = AbsolutelyNothing++class AbsolutelyNothing a+instance AbsolutelyNothing a
+ src/Web/Minion/Json.hs view
@@ -0,0 +1,9 @@+module Web.Minion.Json (+  handleJson,+  reqJson,+  Json,+) where++import Web.Minion.Media.Json+import Web.Minion.Request.Body.Json+import Web.Minion.Response.Body.Json
+ src/Web/Minion/Media.hs view
@@ -0,0 +1,16 @@+module Web.Minion.Media (ContentType (..), AllContentTypes (..)) where++import Data.List.NonEmpty qualified as Nel+import Network.HTTP.Media qualified as Http++class ContentType a where+  media :: Nel.NonEmpty Http.MediaType++class AllContentTypes cts where+  allContentTypes :: [Http.MediaType]++instance (ContentType ct, AllContentTypes cts) => AllContentTypes (ct ': cts) where+  allContentTypes = Nel.toList (media @ct) <> allContentTypes @cts++instance AllContentTypes '[] where+  allContentTypes = mempty
+ src/Web/Minion/Media/FormUrlEncoded.hs view
@@ -0,0 +1,10 @@+module Web.Minion.Media.FormUrlEncoded where++import Data.List.NonEmpty qualified as Nel+import Network.HTTP.Media qualified as Http+import Web.Minion.Media++data FormUrlEncoded++instance ContentType FormUrlEncoded where+  media = "application" Http.// "x-www-form-urlencoded" Nel.:| []
+ src/Web/Minion/Media/Json.hs view
@@ -0,0 +1,31 @@+module Web.Minion.Media.Json where++import Data.Aeson (FromJSON, ToJSON, eitherDecode)+import Data.Aeson qualified as Aeson+import Data.Bifunctor (Bifunctor (..))+import Data.ByteString.Builder qualified as Bytes.Builder+import Data.List.NonEmpty qualified as Nel+import Data.Text qualified as Text+import Network.HTTP.Media qualified as Http+import Network.HTTP.Types qualified as Http+import Network.Wai qualified as Wai+import Web.Minion.Media+import Web.Minion.Request.Body+import Web.Minion.Response.Body (Encode (encode))++data Json++instance ContentType Json where+  media =+    "application" Http.// "json" Http./: ("charset", "utf-8")+      Nel.:| ["application" Http.// "json"]++instance (FromJSON a) => Decode Json a where+  decode = first Text.pack . eitherDecode++instance (ToJSON a) => Encode Json a where+  encode a =+    Wai.responseBuilder+      Http.status200+      [(Http.hContentType, Http.renderHeader $ Nel.head $ media @Json)]+      (Bytes.Builder.lazyByteString $ Aeson.encode a)
+ src/Web/Minion/Media/PlainText.hs view
@@ -0,0 +1,10 @@+module Web.Minion.Media.PlainText where++import Data.List.NonEmpty qualified as Nel+import Network.HTTP.Media qualified as Http+import Web.Minion.Media++data PlainText++instance ContentType PlainText where+  media = "text" Http.// "plain" Http./: ("charset", "utf-8") Nel.:| []
+ src/Web/Minion/Raw.hs view
@@ -0,0 +1,17 @@+module Web.Minion.Raw where++import Data.ByteString qualified as Bytes+import Data.ByteString.Lazy qualified as Bytes.Lazy+import Web.Minion.Request++newtype LazyBytes = LazyBytes Bytes.Lazy.ByteString++newtype Chunks = Chunks (IO Bytes.ByteString)++instance IsRequest LazyBytes where+  type RequestValue LazyBytes = Bytes.Lazy.ByteString+  getRequestValue (LazyBytes a) = a++instance IsRequest Chunks where+  type RequestValue Chunks = IO Bytes.ByteString+  getRequestValue (Chunks a) = a
+ src/Web/Minion/Request.hs view
@@ -0,0 +1,5 @@+module Web.Minion.Request where++class IsRequest r where+  type RequestValue r+  getRequestValue :: r -> RequestValue r
+ src/Web/Minion/Request/Body.hs view
@@ -0,0 +1,89 @@+module Web.Minion.Request.Body where++import Control.Monad ((>=>))+import Control.Monad.Catch+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.IO.Class qualified as IO+import Data.ByteString qualified as Bytes+import Data.ByteString.Lazy qualified as Bytes.Lazy+import Data.List.NonEmpty qualified as Nel+import Data.Text qualified as Text+import Data.Text.Lazy qualified as Text.Lazy+import Data.Text.Lazy.Encoding qualified as Text.Encode.Lazy+import GHC.Base (Type)+import Network.HTTP.Media qualified as Http+import Network.HTTP.Types qualified as Http+import Network.Wai qualified as Wai+import Web.FormUrlEncoded (FromForm)+import Web.FormUrlEncoded qualified as Http+import Web.Minion.Args (WithReq)+import Web.Minion.Introspect qualified as I+import Web.Minion.Media+import Web.Minion.Media.FormUrlEncoded+import Web.Minion.Media.PlainText (PlainText)++import Web.Minion.Request+import Web.Minion.Router++newtype ReqBody (cts :: [Type]) a = ReqBody a++instance IsRequest (ReqBody cts a) where+  type RequestValue (ReqBody cts a) = a+  getRequestValue (ReqBody a) = a++class DecodeBody cts a where+  decodeBody ::+    (MonadIO m, MonadThrow m) =>+    MakeError ->+    -- | Content-Type header value+    Bytes.ByteString ->+    -- | Request body+    IO Bytes.Lazy.ByteString ->+    m (ReqBody cts a)++instance DecodeBody '[] a where+  decodeBody makeError _ _ = throwM $ makeError Http.status415 "Unsupported Content-Type"++instance (ContentType ct, Decode ct a, DecodeBody cts a) => DecodeBody (ct ': cts) a where+  decodeBody makeError contentType body+    | Just _ <- Http.matchAccept (Nel.toList $ media @ct) contentType =+        liftIO body+          >>= either+            (const $ throwM $ makeError Http.status400 "Failed to parse body")+            (pure . ReqBody)+            . decode @ct @a+    | otherwise = do+        ReqBody a :: ReqBody cts a <- decodeBody makeError contentType body+        pure $ ReqBody a++class Decode ct a where+  decode :: Bytes.Lazy.ByteString -> Either Text.Text a++instance Decode PlainText Text.Text where+  decode = Right . Text.Lazy.toStrict . Text.Encode.Lazy.decodeUtf8++instance Decode PlainText Text.Lazy.Text where+  decode = Right . Text.Encode.Lazy.decodeUtf8++instance Decode PlainText String where+  decode = fmap Text.Lazy.unpack . decode @PlainText++instance (FromForm a) => Decode FormUrlEncoded a where+  decode = Http.urlDecodeForm >=> Http.fromForm++{- | Extracts request body with specified Content-Type++@+... '/>' 'reqBody' \@'[PlainText] \@MyRequest+@+-}+reqBody ::+  forall cts r m i ts.+  (I.Introspection i I.Request (ReqBody cts r)) =>+  (IO.MonadIO m, MonadThrow m) =>+  (DecodeBody cts r) =>+  -- | .+  ValueCombinator i (WithReq m (ReqBody cts r)) ts m+reqBody = Request \makeError req -> case lookup Http.hContentType $ Wai.requestHeaders req of+  Nothing -> throwM $ makeError req Http.status415 "Unsupported Content-Type"+  Just ct -> decodeBody @cts @r (makeError req) ct (Wai.lazyRequestBody req)
+ src/Web/Minion/Request/Body/FormUrlEncoded.hs view
@@ -0,0 +1,18 @@+module Web.Minion.Request.Body.FormUrlEncoded where++import Control.Monad.Catch (MonadThrow)+import Control.Monad.IO.Class (MonadIO)+import Web.Minion.Args+import Web.Minion.Introspect qualified as I+import Web.Minion.Media.FormUrlEncoded+import Web.Minion.Request.Body+import Web.Minion.Router (ValueCombinator)++reqFormUrlEncoded ::+  forall r m i ts.+  (I.Introspection i I.Request (ReqBody '[FormUrlEncoded] r)) =>+  (MonadIO m, MonadThrow m) =>+  (Decode FormUrlEncoded r) =>+  -- | .+  ValueCombinator i (WithReq m (ReqBody '[FormUrlEncoded] r)) ts m+reqFormUrlEncoded = reqBody
+ src/Web/Minion/Request/Body/Json.hs view
@@ -0,0 +1,28 @@+module Web.Minion.Request.Body.Json where++import Control.Monad.Catch (MonadThrow)+import Control.Monad.IO.Class (MonadIO)+import Data.Aeson (FromJSON)+import Web.Minion.Args (WithReq)+import Web.Minion.Introspect qualified as I+import Web.Minion.Media.Json (Json)+import Web.Minion.Request.Body (+  ReqBody,+  reqBody,+ )+import Web.Minion.Router (ValueCombinator)++{- | Extracts JSON from request++@+... '/>' 'reqJson' @MyType '.>' ...+@+-}+reqJson ::+  forall r m i ts.+  (I.Introspection i I.Request (ReqBody '[Json] r)) =>+  (FromJSON r) =>+  (MonadIO m, MonadThrow m) =>+  -- | .+  ValueCombinator i (WithReq m (ReqBody '[Json] r)) ts m+reqJson = reqBody
+ src/Web/Minion/Request/Body/PlainText.hs view
@@ -0,0 +1,18 @@+module Web.Minion.Request.Body.PlainText where++import Control.Monad.Catch (MonadThrow)+import Control.Monad.IO.Class (MonadIO)+import Web.Minion.Args+import Web.Minion.Introspect qualified as I+import Web.Minion.Media.PlainText+import Web.Minion.Request.Body+import Web.Minion.Router (ValueCombinator)++reqPlainText ::+  forall r m i ts.+  (I.Introspection i I.Request (ReqBody '[PlainText] r)) =>+  (MonadIO m, MonadThrow m) =>+  (Decode PlainText r) =>+  -- | .+  ValueCombinator i (WithReq m (ReqBody '[PlainText] r)) ts m+reqPlainText = reqBody
+ src/Web/Minion/Request/Body/Raw.hs view
@@ -0,0 +1,24 @@+module Web.Minion.Request.Body.Raw where++import Control.Monad.IO.Class+import Network.Wai qualified as Wai+import Web.Minion.Args+import Web.Minion.Introspect qualified as I+import Web.Minion.Raw+import Web.Minion.Router++lazyBytesBody ::+  forall m i ts.+  (I.Introspection i I.Request LazyBytes) =>+  (MonadIO m) =>+  -- | .+  ValueCombinator i (WithReq m LazyBytes) ts m+lazyBytesBody = Request \_ req -> liftIO $ LazyBytes <$> Wai.lazyRequestBody req++chunksBody ::+  forall m i ts.+  (I.Introspection i I.Request Chunks) =>+  (MonadIO m) =>+  -- | .+  ValueCombinator i (WithReq m Chunks) ts m+chunksBody = Request \_ req -> pure $ Chunks $ Wai.getRequestBodyChunk req
+ src/Web/Minion/Request/Header.hs view
@@ -0,0 +1,61 @@+module Web.Minion.Request.Header where++import Control.Monad.Catch (MonadThrow (..))+import Data.ByteString qualified as Bytes+import Data.List.NonEmpty (NonEmpty, nonEmpty)+import Data.String.Conversions (ConvertibleStrings (..))+import Network.HTTP.Types qualified as Http+import Web.Minion.Args.Internal+import Web.Minion.Introspect qualified as I+import Web.Minion.Request.Header.Internal+import Web.Minion.Router.Internal++{-# INLINE header' #-}+header' ::+  (I.Introspection i I.Header a, MonadThrow m) =>+  -- | .+  Http.HeaderName ->+  (MakeError -> NonEmpty Bytes.ByteString -> m a) ->+  ValueCombinator i (WithHeader Required Strict m a) ts m+header' hn f =+  Header+    hn+    \makeError ->+      maybe+        (throwM . makeError Http.status400 . convertString $ headerNotFoundError hn)+        (f makeError)+        . nonEmpty++{-# INLINE headerLenient' #-}+headerLenient' ::+  (I.Introspection i I.Header a, MonadThrow m) =>+  -- | .+  Http.HeaderName ->+  (MakeError -> NonEmpty Bytes.ByteString -> m (Either e a)) ->+  ValueCombinator i (WithHeader Required (Lenient e) m a) ts m+headerLenient' hn f =+  Header+    hn+    \makeError ->+      maybe+        (throwM . makeError Http.status400 . convertString $ headerNotFoundError hn)+        (f makeError)+        . nonEmpty++{-# INLINE headerLenient #-}+headerLenient ::+  (I.Introspection i I.Header a) =>+  -- | .+  Http.HeaderName ->+  (MakeError -> [Bytes.ByteString] -> m (Maybe (Either e a))) ->+  ValueCombinator i (WithHeader Optional (Lenient e) m a) ts m+headerLenient = Header++{-# INLINE header #-}+header ::+  (I.Introspection i I.Header a) =>+  -- | .+  Http.HeaderName ->+  (MakeError -> [Bytes.ByteString] -> m (Maybe a)) ->+  ValueCombinator i (WithHeader Optional Strict m a) ts m+header = Header
+ src/Web/Minion/Request/Header/Internal.hs view
@@ -0,0 +1,12 @@+module Web.Minion.Request.Header.Internal where++import Data.ByteString+import Data.CaseInsensitive qualified as CI+import Data.Text (Text)+import Data.Text.Encoding qualified as Text.Encode++headerNotFoundError :: CI.CI ByteString -> Text+headerNotFoundError hn = "Header not found: " <> headerToText hn++headerToText :: CI.CI ByteString -> Text+headerToText (Text.Encode.decodeUtf8 . CI.original -> txtHeader) = txtHeader
+ src/Web/Minion/Request/Method.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE PatternSynonyms #-}++module Web.Minion.Request.Method where++import Network.HTTP.Types qualified as Http++pattern GET :: Http.Method+pattern GET = "GET"++pattern POST :: Http.Method+pattern POST = "POST"++pattern PUT :: Http.Method+pattern PUT = "PUT"++pattern PATCH :: Http.Method+pattern PATCH = "PATCH"++pattern HEAD :: Http.Method+pattern HEAD = "HEAD"++pattern DELETE :: Http.Method+pattern DELETE = "DELETE"++pattern OPTIONS :: Http.Method+pattern OPTIONS = "OPTIONS"++pattern TRACE :: Http.Method+pattern TRACE = "TRACE"++pattern CONNECT :: Http.Method+pattern CONNECT = "CONNECT"
+ src/Web/Minion/Request/Query.hs view
@@ -0,0 +1,166 @@+module Web.Minion.Request.Query (+  QueryForm (..),+  QueryFlag (..),+  QueryParamName,+  queryParamsForm,+  queryFlag,+  queryFlag',+  queryParam,+  queryParam',+  queryParamLenient,+  queryParamLenient',+) where++import Control.Monad (join, (>=>))+import Control.Monad.Catch (MonadThrow (throwM))+import Data.ByteString qualified as Bytes+import Data.ByteString.Lazy qualified as Bytes.Lazy+import Data.String.Conversions (ConvertibleStrings (convertString))+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text.Encode+import Network.HTTP.Types qualified as Http+import Network.Wai qualified as Http+import Web.FormUrlEncoded (FromForm)+import Web.FormUrlEncoded qualified as Http+import Web.HttpApiData (FromHttpApiData)+import Web.Minion.Args.Internal+import Web.Minion.Introspect qualified as I+import Web.Minion.Request+import Web.Minion.Request.Query.Internal+import Web.Minion.Router.Internal++type QueryParamName = Text.Text++{- | Tries to get query param++@+'queryParam'' "foo" pure '/>' ...+@+-}+{-# INLINE queryParam' #-}+queryParam' ::+  forall a m i ts.+  (FromHttpApiData a, I.Introspection i I.QueryParam a, MonadThrow m) =>+  -- | .+  QueryParamName ->+  ValueCombinator i (WithQueryParam Required Strict m a) ts m+queryParam' qn = QueryParam (Text.Encode.encodeUtf8 qn) \makeError ->+  let badReq err = throwM $ makeError Http.status400 $ err qn+   in maybe+        do badReq queryParamKeyNotFoundError+        do+          maybe+            (badReq queryParamValueNotFoundError)+            (either throwM pure . decodeQueryParamOrServerError makeError)++{- | Tries to get query param++@+'queryParam' "foo" pure '/>' ...+@+-}+{-# INLINE queryParam #-}+queryParam ::+  forall a m i ts.+  (FromHttpApiData a, I.Introspection i I.QueryParam a, MonadThrow m) =>+  -- | .+  QueryParamName ->+  ValueCombinator i (WithQueryParam Optional Strict m a) ts m+queryParam qn = QueryParam (Text.Encode.encodeUtf8 qn) \makeError ->+  maybe+    (pure Nothing)+    (fmap Just . either throwM pure . decodeQueryParamOrServerError @a makeError)+    . join++{- | Tries to get query param++@+'queryParam' "foo" pure '/>' ...+@+-}+{-# INLINE queryParamLenient #-}+queryParamLenient ::+  forall a m i ts.+  (FromHttpApiData a, I.Introspection i I.QueryParam a, Monad m) =>+  -- | .+  QueryParamName ->+  ValueCombinator i (WithQueryParam Optional (Lenient Text) m a) ts m+queryParamLenient qn = QueryParam (Text.Encode.encodeUtf8 qn) \_ ->+  maybe+    (pure Nothing)+    (pure . Just . decodeQueryParam)+    . join++{- | Tries to get query param++@+'queryParam' "foo" pure '/>' ...+@+-}+{-# INLINE queryParamLenient' #-}+queryParamLenient' ::+  forall a m i ts.+  (FromHttpApiData a, I.Introspection i I.QueryParam a, MonadThrow m) =>+  -- | .+  QueryParamName ->+  ValueCombinator i (WithQueryParam Required (Lenient Text) m a) ts m+queryParamLenient' qn = QueryParam (Text.Encode.encodeUtf8 qn) \makeError ->+  let badReq err = throwM $ makeError Http.status400 $ err qn+   in maybe+        (badReq queryParamKeyNotFoundError)+        (maybe (badReq queryParamValueNotFoundError) $ pure . decodeQueryParam)++{- | Extracts query string to `Form`++@+... '/>' 'queryParamsForm' \@MyForm '.>' ...+@+-}+{-# INLINE queryParamsForm #-}+queryParamsForm ::+  forall r m i ts.+  (I.Introspection i I.Request (QueryForm r), MonadThrow m, FromForm r) =>+  -- | .+  ValueCombinator i (WithReq m (QueryForm r)) ts m+queryParamsForm = Request \makeError req ->+  either (throwM . makeError req Http.status400 . convertString) (pure . QueryForm)+    . (Http.urlDecodeForm >=> Http.fromForm)+    . Bytes.Lazy.fromStrict+    . Http.rawQueryString+    $ req++newtype QueryFlag = QueryFlag Bool++{-# INLINE queryFlag' #-}+queryFlag' ::+  forall m i ts.+  (I.Introspection i I.QueryParam QueryFlag, MonadThrow m) =>+  -- | .+  QueryParamName ->+  ValueCombinator i (WithQueryParam Required Strict m QueryFlag) ts m+queryFlag' qn = QueryParam (Text.Encode.encodeUtf8 qn) \makeError ->+  maybe+    (throwM $ makeError Http.status400 $ queryParamKeyNotFoundError qn)+    (maybe (pure (QueryFlag True)) $ pure . parseQueryFlag)++{-# INLINE queryFlag #-}+queryFlag ::+  forall m i ts.+  (I.Introspection i I.QueryParam QueryFlag, Monad m) =>+  -- | .+  QueryParamName ->+  ValueCombinator i (WithQueryParam Optional Strict m QueryFlag) ts m+queryFlag qn = QueryParam (Text.Encode.encodeUtf8 qn) \_ ->+  maybe+    (pure Nothing)+    (fmap Just . maybe (pure (QueryFlag True)) (pure . parseQueryFlag))++parseQueryFlag :: Bytes.ByteString -> QueryFlag+parseQueryFlag = QueryFlag . flip (elem @[]) ["1", "true", ""]++newtype QueryForm a = QueryForm a++instance IsRequest (QueryForm a) where+  type RequestValue (QueryForm a) = a+  getRequestValue (QueryForm a) = a
+ src/Web/Minion/Request/Query/Internal.hs view
@@ -0,0 +1,26 @@+module Web.Minion.Request.Query.Internal where++import Data.Bifunctor (Bifunctor (..))+import Data.ByteString++import Data.Text (Text)++import Data.ByteString.Lazy qualified as Bytes.Lazy+import Data.String.Conversions (ConvertibleStrings (..))+import Data.Text.Encoding qualified as Text.Encoding+import Network.HTTP.Types qualified as Http+import Web.HttpApiData (FromHttpApiData (parseQueryParam))+import Web.Minion.Error (ServerError (..))+import Web.Minion.Router.Internal (MakeError)++queryParamKeyNotFoundError :: Text -> Bytes.Lazy.ByteString+queryParamKeyNotFoundError qn = convertString $ "Query param not found: " <> qn++queryParamValueNotFoundError :: Text -> Bytes.Lazy.ByteString+queryParamValueNotFoundError qn = convertString $ "Query param value not found: " <> qn++decodeQueryParam :: (FromHttpApiData a) => ByteString -> Either Text a+decodeQueryParam = parseQueryParam . Text.Encoding.decodeUtf8++decodeQueryParamOrServerError :: (FromHttpApiData a) => MakeError -> ByteString -> Either ServerError a+decodeQueryParamOrServerError makeError = first (makeError Http.status400 . convertString) . decodeQueryParam
+ src/Web/Minion/Request/Url.hs view
@@ -0,0 +1,76 @@+module Web.Minion.Request.Url (capture, captures, piece) where++import Control.Monad.Catch (MonadThrow (throwM))+import Data.Bifunctor (Bifunctor (..))+import Data.String (IsString (..))+import Data.String.Conversions (ConvertibleStrings (..))+import Data.Text (Text)+import Network.HTTP.Types qualified as Http+import Web.HttpApiData (FromHttpApiData (parseUrlPiece), parseUrlPieces)+import Web.Minion.Args.Internal+import Web.Minion.Introspect qualified as I+import Web.Minion.Router.Internal++{- | Captures one piece of path++@+'capture' \@Text '.>' ...+@+-}+{-# INLINE capture #-}+capture ::+  forall b m i ts.+  (FromHttpApiData b, I.Introspection i I.Capture b, MonadThrow m) =>+  -- } .+  Text ->+  ValueCombinator i (WithPiece b) ts m+capture =+  Capture @b+    ( \makeError ->+        either throwM pure+          . first (makeError Http.status400 . convertString)+          . parseUrlPiece+    )++{- | Captures the rest of path++@+'captures' \@Text '.>' ...+@+-}+{-# INLINE captures #-}+captures ::+  forall b m i ts.+  (FromHttpApiData b, I.Introspection i I.Captures b, MonadThrow m) =>+  -- | .+  Text ->+  ValueCombinator i (WithPieces b) ts m+captures =+  Captures @b+    \makeError ->+      either throwM pure+        . first (makeError Http.status400 . convertString)+        . parseUrlPieces++{- | Could be omitted with `OverloadedStrings`++@+{\-# LANGUAGE OverloadedStrings #-\}+"bar" '/>' ...+@++@+{\-# LANGUAGE NoOverloadedStrings #-\}+'piece' "bar" '/>' ...+@++Also splits piece with /, so++@+piece "foo\/bar\/bar" == piece "foo" '/>' piece "bar" '/>' piece "baz"+"foo\/bar\/baz" == "foo" '/>' "bar" '/>' "baz"+@+-}+{-# INLINE piece #-}+piece :: String -> Combinator i ts m+piece = fromString
+ src/Web/Minion/Response.hs view
@@ -0,0 +1,62 @@+module Web.Minion.Response (CanRespond (..), ToResponse (..), NoBody (..), IsResponse) where++import Data.ByteString qualified as Bytes+import Data.ByteString.Builder qualified as Bytes.Builder+import Data.Function (fix)+import Data.Maybe (isJust)+import Network.HTTP.Media+import Network.HTTP.Types+import Network.HTTP.Types qualified as Http+import Network.Wai qualified as Http+import Network.Wai qualified as Wai+import Web.Minion.Raw++type IsResponse m o = (CanRespond o, ToResponse m o)++class CanRespond o where+  canRespond ::+    -- | Accept header values+    [Bytes.ByteString] ->+    Bool++class ToResponse m r where+  toResponse :: [Bytes.ByteString] -> r -> m Http.Response++data NoBody = NoBody++instance CanRespond NoBody where+  canRespond _ = True++instance (Monad m) => ToResponse m NoBody where+  toResponse _ _ = pure (Http.responseBuilder Http.status200 [] mempty)++applicationOctetStream :: MediaType+applicationOctetStream = "application" // "octet-stream"++instance CanRespond Chunks where+  canRespond [] = True+  canRespond l = any (isJust . matchAccept [applicationOctetStream]) l++instance CanRespond LazyBytes where+  canRespond [] = True+  canRespond l = any (isJust . matchAccept [applicationOctetStream]) l++instance (Applicative m) => ToResponse m Chunks where+  toResponse _ (Chunks chunks) = pure $ Wai.responseStream+    status200+    []+    \write flush -> do+      flush+      fix \continue -> do+        ch <- chunks+        if Bytes.null ch+          then pure ()+          else write (Bytes.Builder.byteString ch) >> flush >> continue++instance (Applicative m) => ToResponse m LazyBytes where+  toResponse _ (LazyBytes bytes) =+    pure $+      Wai.responseBuilder+        status200+        []+        (Bytes.Builder.lazyByteString bytes)
+ src/Web/Minion/Response/Body.hs view
@@ -0,0 +1,111 @@+module Web.Minion.Response.Body (+  module Web.Minion.Response,+  RespBody (..),+  EncodeBody (..),+  Encode (..),+  handleBody,+) where++import Control.Exception qualified as Exc+import Control.Exception.Base (throw)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.IO.Class qualified as IO+import Data.ByteString qualified as Bytes+import Data.ByteString.Builder qualified as Bytes.Builder+import Data.ByteString.Lazy qualified as Bytes.Lazy+import Data.List.NonEmpty qualified as Nel+import Data.Maybe (isJust)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text.Encode+import Data.Text.Lazy qualified as Text.Lazy+import Data.Text.Lazy.Encoding qualified as Text.Lazy.Encode+import Network.HTTP.Media qualified as Http+import Network.HTTP.Types qualified as Http+import Network.Wai qualified as Wai+import Web.Minion.Args+import Web.Minion.Error+import Web.Minion.Introspect qualified as I+import Web.Minion.Media+import Web.Minion.Media.PlainText (PlainText)+import Web.Minion.Response+import Web.Minion.Router.Internal++newtype RespBody cts a = RespBody a++instance (AllContentTypes cts) => CanRespond (RespBody cts a) where+  canRespond [] = True+  canRespond l = any (isJust . Http.matchAccept (allContentTypes @cts)) l++instance (MonadIO m) => ToResponse m (RespBody '[] a) where+  toResponse _ (RespBody _) = IO.liftIO $ Exc.throwIO SomethingWentWrong++instance (EncodeBody (ct ': cts) a, Encode ct a, MonadIO m, ContentType ct) => ToResponse m (RespBody (ct ': cts) a) where+  toResponse [] (RespBody a) = pure $ encode @ct a+  toResponse (ct : _) (RespBody a) = pure $ encodeBody @(ct ': cts) ct a++class EncodeBody cts a where+  encodeBody :: Bytes.ByteString -> a -> Wai.Response++instance EncodeBody '[] a where+  encodeBody _ _ = throw SomethingWentWrong++instance (ContentType ct, Encode ct a, EncodeBody cts a) => EncodeBody (ct ': cts) a where+  encodeBody ct a+    | Just _ <- Http.matchAccept (Nel.toList $ media @ct) ct = encode @ct a+    | otherwise = encodeBody @cts ct a++class Encode ct a where+  encode :: a -> Wai.Response++plainTextHeader :: (Http.HeaderName, Bytes.ByteString)+plainTextHeader = (Http.hContentType, Http.renderHeader $ Nel.head $ media @PlainText)++instance Encode PlainText Text.Text where+  encode a =+    Wai.responseBuilder+      Http.status200+      [plainTextHeader]+      ( Bytes.Builder.lazyByteString+          . Bytes.Lazy.fromStrict+          . Text.Encode.encodeUtf8+          $ a+      )++instance Encode PlainText Text.Lazy.Text where+  encode a =+    Wai.responseBuilder+      Http.status200+      [plainTextHeader]+      ( Bytes.Builder.lazyByteString+          . Text.Lazy.Encode.encodeUtf8+          $ a+      )++instance Encode PlainText String where+  encode a =+    Wai.responseBuilder+      Http.status200+      [plainTextHeader]+      ( Bytes.Builder.lazyByteString+          . Text.Lazy.Encode.encodeUtf8+          . Text.Lazy.pack+          $ a+      )++{- | Handles request with specified HTTP method and responds with specified Content-Type++@+... '/>' 'handleBody' GET \@'[PlainText] \@MyResponse someEndpoint+@+-}+{-# INLINE handleBody #-}+handleBody ::+  forall cts o m ts i st.+  (HandleArgs ts st m) =>+  (IsResponse m (RespBody cts o)) =>+  (I.Introspection i I.Response (RespBody cts o)) =>+  -- | .+  Http.Method ->+  (DelayedArgs st ~> m o) ->+  Router' i ts m+handleBody method = makeHandle @(RespBody cts) @o method RespBody
+ src/Web/Minion/Response/Body/Json.hs view
@@ -0,0 +1,25 @@+module Web.Minion.Response.Body.Json where++import Control.Monad.IO.Class (MonadIO)+import Data.Aeson (ToJSON)+import Network.HTTP.Types qualified as Http+import Web.Minion.Args (DelayedArgs, HandleArgs, type (~>))+import Web.Minion.Introspect qualified as I+import Web.Minion.Media.Json (Json)+import Web.Minion.Response.Body (RespBody, handleBody)+import Web.Minion.Router (+  Router',+ )++{-# INLINE handleJson #-}+handleJson ::+  forall o m ts i st.+  (HandleArgs ts st m) =>+  (ToJSON o) =>+  (MonadIO m) =>+  (I.Introspection i I.Response (RespBody '[Json] o)) =>+  -- | .+  Http.Method ->+  (DelayedArgs st ~> m o) ->+  Router' i ts m+handleJson = handleBody @'[Json] @o @m @ts
+ src/Web/Minion/Response/Body/PlainText.hs view
@@ -0,0 +1,23 @@+module Web.Minion.Response.Body.PlainText where++import Network.HTTP.Types qualified as Http+import Web.Minion.Args (DelayedArgs, HandleArgs, type (~>))+import Web.Minion.Introspect qualified as I+import Web.Minion.Media.PlainText+import Web.Minion.Response (ToResponse)+import Web.Minion.Response.Body (RespBody, handleBody)+import Web.Minion.Router (+  Router',+ )++{-# INLINE handlePlainText #-}+handlePlainText ::+  forall o m ts i st.+  (HandleArgs ts st m) =>+  (ToResponse m (RespBody '[PlainText] o)) =>+  (I.Introspection i I.Response (RespBody '[PlainText] o)) =>+  -- | .+  Http.Method ->+  (DelayedArgs st ~> m o) ->+  Router' i ts m+handlePlainText = handleBody @'[PlainText] @o @m @ts
+ src/Web/Minion/Response/Header.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DeriveFunctor #-}+{-# HLINT ignore "Avoid lambda" #-}+{-# LANGUAGE InstanceSigs #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++module Web.Minion.Response.Header where++import Data.ByteString qualified as Bytes+import Data.CaseInsensitive qualified as CI+import Data.Coerce (coerce)+import Data.Proxy (Proxy (..))+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text.Encode+import GHC.TypeLits (KnownSymbol, symbolVal)+import Network.HTTP.Types qualified as Http+import Network.Wai qualified as Wai+import Web.HttpApiData (ToHttpApiData (..))+import Web.Minion.Args.Internal+import Web.Minion.Response (CanRespond (..), ToResponse (..))++newtype AddHeader name a = AddHeader a+  deriving (Functor)++newtype RawHeaderValue = RawHeaderValue Bytes.ByteString++instance ToHttpApiData RawHeaderValue where+  {-# INLINE toUrlPiece #-}+  toUrlPiece = coerce Text.Encode.decodeUtf8+  {-# INLINE toHeader #-}+  toHeader = coerce++data AddHeaders hs a = AddHeaders+  { headers :: HList hs+  , body :: a+  }+  deriving (Functor)++instance (CanRespond a) => CanRespond (AddHeaders hs a) where+  {-# INLINE canRespond #-}+  canRespond = canRespond @a++instance (ToResponse m a, UnwindHeaders hs, Monad m) => ToResponse m (AddHeaders hs a) where+  {-# INLINE toResponse #-}+  toResponse accept AddHeaders{..} =+    Wai.mapResponseHeaders (unwindHeaders @hs headers <>) <$> toResponse accept body++class UnwindHeaders hs where+  unwindHeaders :: HList hs -> [Http.Header]++instance UnwindHeaders '[] where+  {-# INLINE unwindHeaders #-}+  unwindHeaders :: HList '[] -> [Http.Header]+  unwindHeaders _ = []++instance (UnwindHeaders hs, KnownSymbol name, ToHttpApiData typ) => UnwindHeaders (AddHeader name typ ': hs) where+  {-# INLINE unwindHeaders #-}+  unwindHeaders (AddHeader val :# hs) =+    (CI.mk $ Text.Encode.encodeUtf8 $ Text.pack $ symbolVal (Proxy @name), toHeader @typ val)+      : unwindHeaders @hs hs
+ src/Web/Minion/Response/Status.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE DeriveFunctor #-}++module Web.Minion.Response.Status where++import Network.HTTP.Types+import Network.HTTP.Types qualified as Http+import Network.Wai qualified as Wai+import Web.Minion++newtype WithStatus status a = WithStatus+  {body :: a}+  deriving (Functor)++instance (ToResponse m a, Monad m, IsStatus status) => ToResponse m (WithStatus status a) where+  toResponse accept WithStatus{..} =+    Wai.mapResponseStatus (const $ status @status)+      <$> toResponse accept body++instance (CanRespond a) => CanRespond (WithStatus status a) where+  canRespond = canRespond @a++class IsStatus status where+  status :: Http.Status++data Continue++instance IsStatus Continue where+  status = status100++data SwitchingProtocols+instance IsStatus SwitchingProtocols where+  status = status101++data OK+instance IsStatus OK where+  status = status200++data Created+instance IsStatus Created where+  status = status201++data Accepted+instance IsStatus Accepted where+  status = status202++data NonAuthoritativeInformation+instance IsStatus NonAuthoritativeInformation where+  status = status203++data NoContent+instance IsStatus NoContent where+  status = status204++data ResetContent+instance IsStatus ResetContent where+  status = status205++data PartialContent+instance IsStatus PartialContent where+  status = status206++data MultipleChoices+instance IsStatus MultipleChoices where+  status = status300++data MovedPermanently+instance IsStatus MovedPermanently where+  status = status301++data Found+instance IsStatus Found where+  status = status302++data SeeOther+instance IsStatus SeeOther where+  status = status303++data NotModified+instance IsStatus NotModified where+  status = status304++data UseProxy+instance IsStatus UseProxy where+  status = status305++data TemporaryRedirect+instance IsStatus TemporaryRedirect where+  status = status307++data PermanentRedirect+instance IsStatus PermanentRedirect where+  status = status308++data BadRequest+instance IsStatus BadRequest where+  status = status400++data Unauthorized+instance IsStatus Unauthorized where+  status = status401++data PaymentRequired+instance IsStatus PaymentRequired where+  status = status402++data Forbidden+instance IsStatus Forbidden where+  status = status403++data NotFound+instance IsStatus NotFound where+  status = status404++data MethodNotAllowed+instance IsStatus MethodNotAllowed where+  status = status405++data NotAcceptable+instance IsStatus NotAcceptable where+  status = status406++data ProxyAuthenticationRequired+instance IsStatus ProxyAuthenticationRequired where+  status = status407++data RequestTimeout+instance IsStatus RequestTimeout where+  status = status408++data Conflict+instance IsStatus Conflict where+  status = status409++data Gone+instance IsStatus Gone where+  status = status410++data LengthRequired+instance IsStatus LengthRequired where+  status = status411++data PreconditionFailed+instance IsStatus PreconditionFailed where+  status = status412++data PayloadTooLarge+instance IsStatus PayloadTooLarge where+  status = status413++data URITooLong+instance IsStatus URITooLong where+  status = status414++data UnsupportedMediaType+instance IsStatus UnsupportedMediaType where+  status = status415++data RangeNotSatisfiable+instance IsStatus RangeNotSatisfiable where+  status = status416++data ExpectationFailed+instance IsStatus ExpectationFailed where+  status = status417++data ImATeapot+instance IsStatus ImATeapot where+  status = status418++data UnprocessableEntity+instance IsStatus UnprocessableEntity where+  status = status422++data PreconditionRequired+instance IsStatus PreconditionRequired where+  status = status428++data TooManyRequests+instance IsStatus TooManyRequests where+  status = status429++data RequestHeaderFieldsTooLarge+instance IsStatus RequestHeaderFieldsTooLarge where+  status = status431++data InternalServerError+instance IsStatus InternalServerError where+  status = status500++data NotImplemented+instance IsStatus NotImplemented where+  status = status501++data BadGateway+instance IsStatus BadGateway where+  status = status502++data ServiceUnavailable+instance IsStatus ServiceUnavailable where+  status = status503++data GatewayTimeout+instance IsStatus GatewayTimeout where+  status = status504++data HTTPVersionNotSupported+instance IsStatus HTTPVersionNotSupported where+  status = status505++data NetworkAuthenticationRequired+instance IsStatus NetworkAuthenticationRequired where+  status = status511
+ src/Web/Minion/Response/Union.hs view
@@ -0,0 +1,31 @@+module Web.Minion.Response.Union where++import Data.Kind+import Web.Minion++data Union (as :: [Type]) where+  This :: !a -> Union (a ': as)+  That :: !(Union as) -> Union (a ': as)++class Inject a as where+  inject :: a -> Union as++instance Inject a (a ': as) where+  inject = This++instance {-# OVERLAPPABLE #-} (Inject a as) => Inject a (x ': as) where+  inject = That . inject++instance (CanRespond a, CanRespond (Union as)) => CanRespond (Union (a ': as)) where+  canRespond h = canRespond @a h && canRespond @(Union as) h++instance CanRespond (Union '[]) where+  canRespond _ = True++instance (ToResponse m a, Monad m, ToResponse m (Union as)) => ToResponse m (Union (a ': as)) where+  toResponse accept = \case+    This a -> toResponse accept a+    That as -> toResponse accept as++instance (Monad m) => ToResponse m (Union '[]) where+  toResponse _ = error "impossible"
+ src/Web/Minion/Router.hs view
@@ -0,0 +1,3 @@+module Web.Minion.Router (Router, Router' (..), Combinator, ValueCombinator, MakeError) where++import Web.Minion.Router.Internal
+ src/Web/Minion/Router/Internal.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE PartialTypeSignatures #-}++module Web.Minion.Router.Internal where++import Control.Monad ((>=>))+import Control.Monad.IO.Class qualified as IO+import Data.ByteString (ByteString)+import Data.String (IsString (..))+import Data.Text (Text)+import GHC.Exts (IsList (..))+import Network.HTTP.Types qualified as Http+import Network.Wai qualified as Http+import Network.Wai qualified as Wai++import Control.Exception qualified as IOExc+import Control.Monad.Catch qualified as Exc+import Data.ByteString.Lazy qualified as Bytes.Lazy+import Data.Kind (Type)+import Data.Void (Void)+import Web.Minion.Args.Internal (+  Arg,+  FunArgs (apply, type (~>)),+  HList,+  HandleArgs,+  IsLenient,+  IsRequired,+  RHList ((:#!)),+  RHListToHList (revHListToList),+  Reverse (reverseHList),+  RunDelayed (DelayedArgs, runDelayed),+  WithHeader (..),+  WithPiece (..),+  WithPieces (..),+  WithQueryParam (..),+  WithReq (..),+  type (:+),+ )+import Web.Minion.Error (+  ErrorBuilder,+  ErrorBuilders (..),+  NoMatch (..),+  ServerError,+ )+import Web.Minion.Introspect qualified as I+import Web.Minion.Request (IsRequest)+import Web.Minion.Response (CanRespond (..), ToResponse (..))++-- | If you don't care about introspection+type Router = Router' Void++type MiddlewareM m = ApplicationM m -> ApplicationM m++type MakeError = Http.Status -> Bytes.Lazy.ByteString -> ServerError++type ValueCombinator i v ts m = Router' i (ts :+ v) m -> Router' i ts m+type Combinator i ts m = Router' i ts m -> Router' i ts m++data Router' i (ts :: Type) m where+  Piece ::+    -- | .+    Text ->+    Router' i ts m ->+    Router' i ts m+  QueryParam ::+    forall a presence parsing m ts i.+    (I.Introspection i I.QueryParam a, IsRequired presence, IsLenient parsing) =>+    -- | Query param name+    ByteString ->+    -- | Parse query param+    -- Outer Maybe -- is there key+    -- Inner Maybe -- is there value+    (MakeError -> Maybe (Maybe ByteString) -> m (Arg presence parsing a)) ->+    Router' i (ts :+ WithQueryParam presence parsing m a) m ->+    Router' i ts m+  Captures ::+    forall a ts m i.+    (I.Introspection i I.Captures a) =>+    -- | Parse pieces+    (MakeError -> [Text] -> m [a]) ->+    -- | Placeholder+    Text ->+    Router' i (ts :+ WithPieces a) m ->+    Router' i ts m+  Capture ::+    forall a ts m i.+    (I.Introspection i I.Capture a) =>+    -- | Parse piece+    (MakeError -> Text -> m a) ->+    -- | Placeholder+    Text ->+    Router' i (ts :+ WithPiece a) m ->+    Router' i ts m+  Middleware ::+    MiddlewareM m ->+    Router' i ts m ->+    Router' i ts m+  Header ::+    forall a presence parsing m ts i.+    (I.Introspection i I.Header a, IsRequired presence, IsLenient parsing) =>+    Http.HeaderName ->+    -- | Parse header+    (MakeError -> [ByteString] -> m (Arg presence parsing a)) ->+    Router' i (ts :+ WithHeader presence parsing m a) m ->+    Router' i ts m+  Request ::+    forall r m i ts.+    (I.Introspection i I.Request r, IsRequest r) =>+    -- | .+    (ErrorBuilder -> Wai.Request -> m r) ->+    Router' i (ts :+ WithReq m r) m ->+    Router' i ts m+  Alt ::+    -- | Sub routes+    [Router' i ts m] ->+    Router' i ts m+  -- -- | Additional constraints provider with `request` and `response` can be useful for introspection+  Handle ::+    forall o m ts i st.+    ( HandleArgs ts st m+    , ToResponse m o+    , CanRespond o+    , I.Introspection i I.Response o+    ) =>+    -- | Handled HTTP method+    Http.Method ->+    (HList (DelayedArgs st) -> m o) ->+    Router' i ts m+  Description ::+    (I.Introspection i I.Description desc) =>+    -- | .+    desc ->+    Router' i ts m ->+    Router' i ts m+  MapArgs ::+    forall m ts ts' i.+    (RHList ts -> RHList ts') ->+    Router' i ts' m ->+    Router' i ts m+  HideIntrospection ::+    forall i' i ts m.+    Router' i ts m ->+    Router' i' ts m++{-# INLINE route #-}+route ::+  forall m ts i.+  (IO.MonadIO m, Exc.MonadCatch m) =>+  ErrorBuilders ->+  RoutingState ->+  RHList ts ->+  Router' i ts m ->+  ApplicationM m+route builders state args (Alt routes) = \req resp -> goThrough $ map (\r -> route builders state args r req resp) routes+route builders state args (Middleware mw r) = mw (route builders state args r)+route builders state args (MapArgs f r) = route builders state (f args) r+route builders state args (Description _ r) = route builders state args r+route builders state args (HideIntrospection r) = route builders state args r+route _ RoutingState{..} args (Handle @o method f) = routeHandle path args method f+route builders@ErrorBuilders{..} state args (Request @f get r) = \req resp -> do+  route builders state (WithReq (get bodyErrorBuilder req) :#! args) r req resp+route builders@ErrorBuilders{..} state args (Header @a @presence @parsing headerName get r) = \req ->+  let header = lookupHeader req headerName+      withHeader = WithHeader (get (headerErrorBuilder req) header) :#! args+   in route builders state withHeader r req+route builders@ErrorBuilders{..} state args (QueryParam @a @presence @parsing queryParamName parse r) = \req ->+  let mbQueryParamVal = lookup queryParamName $ Http.queryString req+      withQueryParam = WithQueryParam (parse (queryParamsErrorBuilder req) mbQueryParamVal) :#! args+   in route builders state withQueryParam r req+route builders RoutingState{..} args (Piece txt r) = case path of+  (t : ts) | txt == t -> route builders RoutingState{path = ts, ..} args r+  _ -> \_ _ -> throwMIO NoMatch+route builders@ErrorBuilders{..} RoutingState{..} args (Captures parse _ r) = \req resp -> do+  parsed <- parse (captureErrorBuilder req) path+  route builders RoutingState{path = [], ..} (WithPieces parsed :#! args) r req resp+route builders@ErrorBuilders{..} RoutingState{..} args (Capture parse _ r) = \req resp -> case path of+  (t : ts) -> do+    v <- parse (captureErrorBuilder req) t+    route builders RoutingState{path = ts, ..} (WithPiece v :#! args) r req resp+  _ -> throwMIO NoMatch++{-# INLINE routeHandle #-}+routeHandle ::+  forall m o ts st.+  (IO.MonadIO m, ToResponse m o, CanRespond o, HandleArgs ts st m) =>+  [Text] ->+  RHList ts ->+  Http.Method ->+  (HList (DelayedArgs st) -> m o) ->+  ApplicationM m+routeHandle path args method f req resp = do+  checkHandler req path method+  let acceptHeader = lookupHeader req Http.hAccept+  if canRespond @o acceptHeader+    then do+      args' <- runDelayed (reverseHList (revHListToList args))+      f args' >>= (toResponse @m @o acceptHeader >=> IO.liftIO . resp)+    else IO.liftIO $ resp $ Wai.responseBuilder Http.status406 [] mempty++{-# INLINE goThrough #-}+goThrough :: (IO.MonadIO m, Exc.MonadCatch m) => [m b] -> m b+goThrough (a : as) =+  Exc.try @_ @NoMatch a >>= \case+    Left NoMatch -> goThrough as+    Right x -> pure x+goThrough [] = throwMIO NoMatch++{-# INLINE throwMIO #-}+throwMIO :: (Exc.Exception e, IO.MonadIO m) => e -> m a+throwMIO = IO.liftIO . IOExc.throwIO++{-# INLINE checkHandler #-}+checkHandler :: (IO.MonadIO f) => Wai.Request -> [Text] -> Http.Method -> f ()+checkHandler req path method+  | method == Http.requestMethod req+  , null path || path == [mempty] =+      pure ()+  | otherwise = throwMIO NoMatch++{-# INLINE lookupHeader #-}+lookupHeader :: Wai.Request -> Http.HeaderName -> [ByteString]+lookupHeader req hn = map snd . filter ((hn ==) . fst) $ Http.requestHeaders req++instance IsList (Router' i ts r) where+  type Item (Router' i ts r) = Router' i ts r+  fromList = Alt+  toList a = [a]++instance Semigroup (Router' i ts r) where+  a <> b = [a, b]++instance Monoid (Router' i ts r) where+  mempty = []++instance IsString (Combinator i ts m) where+  {-# INLINE fromString #-}+  fromString = smartPiece++{-# INLINE smartPiece #-}+smartPiece :: String -> Combinator i ts m+smartPiece (break (== '/') -> (a, as)) cont =+  if null as+    then Piece (fromString a) cont+    else Piece (fromString a) (smartPiece (drop 1 as) cont)++newtype RoutingState = RoutingState {path :: [Text]}++-- | 'Wai.Application' lifted to `m`+type ApplicationM m =+  Wai.Request ->+  ( Wai.Response ->+    IO Wai.ResponseReceived+  ) ->+  m Wai.ResponseReceived++{-# INLINE makeHandle #-}+makeHandle ::+  forall f o m ts i st.+  ( HandleArgs ts st m+  , ToResponse m (f o)+  , CanRespond (f o)+  , I.Introspection i I.Response (f o)+  ) =>+  Http.Method ->+  (o -> f o) ->+  (DelayedArgs st ~> m o) ->+  Router' i ts m+makeHandle method packResponse f =+  Handle @(f o) method (fmap packResponse . apply f)
+ src/Web/Minion/Static.hs view
@@ -0,0 +1,115 @@+module Web.Minion.Static (StaticFileResponse, staticFiles, defaultExtsMap) where++import Data.ByteString qualified as Bytes+import Data.ByteString.Lazy qualified as Bytes.Lazy+import Data.Map.Strict qualified as Map+import Data.Void+import Network.HTTP.Media+import System.FilePath (takeExtension)+import Web.Minion+import Web.Minion.Introspect qualified as I+import Web.Minion.Response.Header qualified as Header++type StaticFileResponse = Header.AddHeaders '[Header.AddHeader "Content-Type" Header.RawHeaderValue] LazyBytes++{-# INLINE staticFiles #-}+staticFiles ::+  (Monad m, I.Introspection i I.Response StaticFileResponse) =>+  -- | Use 'defaultExtsMap'+  Map.Map String MediaType ->+  [(FilePath, Bytes.ByteString)] ->+  Router' i Void m+staticFiles extsMap = foldMap \(path, content) ->+  let contentType = getContentType extsMap (takeExtension path)+   in piece path /> handle GET do+        pure $+          Header.AddHeaders+            { headers = Header.AddHeader @"Content-Type" (Header.RawHeaderValue contentType) :# HNil+            , body = LazyBytes $ Bytes.Lazy.fromStrict content+            }++getContentType :: (RenderHeader a) => Map.Map String a -> FilePath -> Bytes.ByteString+getContentType extsMap path = maybe "application/octet-stream" renderHeader $ Map.lookup (takeExtension path) extsMap++defaultExtsMap :: Map.Map String MediaType+defaultExtsMap =+  Map.fromList+    [ ".aac" ~> "audio/aac"+    , ".abw" ~> "application/x-abiword"+    , ".arc" ~> "application/x-freearc"+    , ".avif" ~> "image/avif"+    , ".avi" ~> "video/x-msvideo"+    , ".azw" ~> "application/vnd.amazon.ebook"+    , ".bin" ~> "application/octet-stream"+    , ".bmp" ~> "image/bmp"+    , ".bz" ~> "application/x-bzip"+    , ".bz2" ~> "application/x-bzip2"+    , ".cda" ~> "application/x-cdf"+    , ".csh" ~> "application/x-csh"+    , ".css" ~> "text/css"+    , ".csv" ~> "text/csv"+    , ".doc" ~> "application/msword"+    , ".docx" ~> "application/vnd.openxmlformats-officedocument.wordprocessingml.document"+    , ".eot" ~> "application/vnd.ms-fontobject"+    , ".epub" ~> "application/epub+zip"+    , ".gz" ~> "application/gzip"+    , ".gif" ~> "image/gif"+    , ".htm" ~> "text/html"+    , ".ico" ~> "image/vnd.microsoft.icon"+    , ".ics" ~> "text/calendar"+    , ".jar" ~> "application/java-archive"+    , ".jpeg" ~> "image/jpeg"+    , ".jpg" ~> "image/jpeg"+    , ".js" ~> "text/javascript"+    , ".json" ~> "application/json"+    , ".jsonld" ~> "application/ld+json"+    , ".mid" ~> "audio/midi"+    , ".midi" ~> "audio/midi"+    , ".mjs" ~> "text/javascript"+    , ".mp3" ~> "audio/mpeg"+    , ".mp4" ~> "video/mp4"+    , ".mpeg" ~> "video/mpeg"+    , ".mpkg" ~> "application/vnd.apple.installer+xml"+    , ".odp" ~> "application/vnd.oasis.opendocument.presentation"+    , ".ods" ~> "application/vnd.oasis.opendocument.spreadsheet"+    , ".odt" ~> "application/vnd.oasis.opendocument.text"+    , ".oga" ~> "audio/ogg"+    , ".ogv" ~> "video/ogg"+    , ".ogx" ~> "application/ogg"+    , ".opus" ~> "audio/opus"+    , ".otf" ~> "font/otf"+    , ".png" ~> "image/png"+    , ".pdf" ~> "application/pdf"+    , ".php" ~> "application/x-httpd-php"+    , ".ppt" ~> "application/vnd.ms-powerpoint"+    , ".pptx" ~> "application/vnd.openxmlformats-officedocument.presentationml.presentation"+    , ".rar" ~> "application/vnd.rar"+    , ".rtf" ~> "application/rtf"+    , ".sh" ~> "application/x-sh"+    , ".svg" ~> "image/svg+xml"+    , ".tar" ~> "application/x-tar"+    , ".tif" ~> "image/tiff"+    , ".tiff" ~> "image/tiff"+    , ".ts" ~> "video/mp2t"+    , ".ttf" ~> "font/ttf"+    , ".txt" ~> "text/plain"+    , ".vsd" ~> "application/vnd.visio"+    , ".wav" ~> "audio/wav"+    , ".weba" ~> "audio/webm"+    , ".webm" ~> "video/webm"+    , ".webp" ~> "image/webp"+    , ".woff" ~> "font/woff"+    , ".woff2" ~> "font/woff2"+    , ".xhtml" ~> "application/xhtml+xml"+    , ".xls" ~> "application/vnd.ms-excel"+    , ".xlsx" ~> "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"+    , ".xml" ~> "application/xml"+    , ".xul" ~> "application/vnd.mozilla.xul+xml"+    , ".zip" ~> "application/zip"+    , ".3gp" ~> "video/3gpp"+    , ".3g2" ~> "video/3gpp2"+    , ".7z" ~> "application/x-7z-compressed"+    ]+ where+  (~>) :: String -> MediaType -> (String, MediaType)+  (~>) = (,)