packages feed

mock-httpd (empty) → 0.0.0.0

raw patch · 6 files changed

+385/−0 lines, 6 filesdep +aesondep +asyncdep +basesetup-changed

Dependencies added: aeson, async, base, bytestring, case-insensitive, filepath, http-types, relude, text, wai, warp, yaml

Files

+ CHANGES.md view
@@ -0,0 +1,5 @@+# Release History++## [0.0.0.0] - 2020-08-06++  * Initial release
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2020 Peter J. Jones <pjones@devalot.com>+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. 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.++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.
+ Main.hs view
@@ -0,0 +1,247 @@+-- |+--+-- Copyright:+--   This file is part of the package mock-httpd. It is subject to the+--   license terms in the LICENSE file found in the top-level+--   directory of this distribution and at:+--+--     https://github.com/pjones/mock-httpd+--+--   No part of this package, including this file, may be copied,+--   modified, propagated, or distributed except according to the terms+--   contained in the LICENSE file.+--+-- License: BSD-2-Clause+module Main+  ( main,+  )+where++import qualified Control.Concurrent.Async as Async+import qualified Data.Aeson as Aeson+import qualified Data.ByteString as ByteString+import qualified Data.CaseInsensitive as CaseInsensitive+import qualified Data.Text as Text+import qualified Data.Yaml as YML+import GHC.Generics (Rep)+import qualified Network.HTTP.Types as HTTP+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp+import Relude.Extra.Map+import System.Environment (getArgs)+import System.FilePath ((</>))++-- | Listen on an HTTP port with specific settings.+--+-- @since 0.0.0.0+newtype Listen = Listen+  { listenPort :: Int+  }+  deriving stock (Generic, Show)+  deriving (Aeson.ToJSON, Aeson.FromJSON) via GenericJSON Listen++-- | Create/modify a response using various actions.+--+-- @since 0.0.0.0+data Action+  = ServeFile FilePath+  | ServeText Text+  | Location Text+  | ContentType Text+  | SetHeaders (HashMap Text Text)+  | ResponseCode Int+  | SaveBody FilePath+  deriving stock (Generic, Show)+  deriving (Aeson.ToJSON, Aeson.FromJSON) via GenericJSON Action++-- | Match a request and run associated actions to generate a+-- response.+--+-- @since 0.0.0.0+data Route = Route+  { routeMatchPath :: Maybe Text,+    routeMatchMethod :: Maybe Text,+    routeActions :: NonEmpty Action+  }+  deriving stock (Generic, Show)+  deriving (Aeson.ToJSON, Aeson.FromJSON) via GenericJSON Route++-- | Configuration.+--+-- @since 0.0.0.0+data Config = Config+  { configListen :: NonEmpty Listen,+    configDirectory :: FilePath,+    configRoutes :: NonEmpty Route+  }+  deriving stock (Generic, Show)+  deriving (Aeson.ToJSON, Aeson.FromJSON) via GenericJSON Config++-- | Type wrapper for automatic JSON deriving.+newtype GenericJSON a = GenericJSON+  {genericJSON :: a}++-- | Default JSON decoding/encoding options.+aesonOptions :: Aeson.Options+aesonOptions =+  Aeson.defaultOptions+    { Aeson.fieldLabelModifier = snakeCase >>> dropFirstWord,+      Aeson.constructorTagModifier = snakeCase,+      Aeson.allNullaryToStringTag = True,+      Aeson.omitNothingFields = True,+      Aeson.sumEncoding = Aeson.ObjectWithSingleField+    }+  where+    dropFirstWord = dropWhile (/= '_') >>> drop 1+    snakeCase = Aeson.camelTo2 '_'++instance+  ( Generic a,+    Aeson.GToJSON Aeson.Zero (Rep a),+    Aeson.GToEncoding Aeson.Zero (Rep a)+  ) =>+  Aeson.ToJSON (GenericJSON a)+  where+  toJSON = Aeson.genericToJSON aesonOptions . genericJSON+  toEncoding = Aeson.genericToEncoding aesonOptions . genericJSON++instance+  ( Generic a,+    Aeson.GFromJSON Aeson.Zero (Rep a)+  ) =>+  Aeson.FromJSON (GenericJSON a)+  where+  parseJSON = fmap GenericJSON . Aeson.genericParseJSON aesonOptions++-- | The types of responses that can be generated from an action.+--+-- @since 0.0.0.0+data Response m+  = Create Wai.Response+  | Modify (Wai.Response -> Wai.Response)+  | Effect (m ())++-- | Create a response from a request and 'Action'.+--+-- @since 0.0.0.0+respond :: MonadIO m => Config -> Wai.Request -> Action -> Response m+respond cfg req = \case+  ServeFile path ->+    let file = configDirectory cfg </> path+     in Create (Wai.responseFile HTTP.status200 mempty file Nothing)+  ServeText text ->+    Create (Wai.responseLBS HTTP.status200 mempty (encodeUtf8 text))+  Location url ->+    Modify $+      Wai.mapResponseHeaders $ \headers ->+        ("Location", encodeUtf8 url) : headers+  ContentType value ->+    Modify $+      Wai.mapResponseHeaders $ \headers ->+        ("Content-Type", encodeUtf8 value) : headers+  SetHeaders hmap ->+    Modify $+      Wai.mapResponseHeaders+        ( <>+            ( toPairs hmap+                <&> bimap+                  (encodeUtf8 >>> CaseInsensitive.mk)+                  encodeUtf8+            )+        )+  ResponseCode code ->+    Modify $+      Wai.mapResponseStatus $+        const (HTTP.mkStatus code (show code))+  SaveBody path ->+    Effect $+      liftIO $+        withFile (configDirectory cfg </> path) WriteMode $ \h ->+          let go = do+                bs <- Wai.getRequestBodyChunk req+                if ByteString.null bs+                  then pure ()+                  else ByteString.hPut h bs >> go+           in go++-- | Basic information about a request for matching routes.+--+-- @since 0.0.0.0+data Request = Request+  { requestPath :: Text,+    requestMethod :: Text+  }+  deriving stock (Generic, Show)+  deriving (Aeson.ToJSON, Aeson.FromJSON) via GenericJSON Request++-- | FIXME: Write description for toRequest+--+-- @since 0.0.0.0+toRequest :: Wai.Request -> Request+toRequest req =+  Request+    { requestPath = "/" <> Text.intercalate "/" (Wai.pathInfo req),+      requestMethod = decodeUtf8 (Wai.requestMethod req)+    }++-- | Does a 'Route' match a request?+--+-- @since 0.0.0.0+match :: Request -> Route -> Bool+match Request {..} Route {..} =+  all+    (fromMaybe True)+    [ matchPath,+      matchMethod+    ]+  where+    matchPath :: Maybe Bool+    matchPath = do+      path <- routeMatchPath+      pure (requestPath == path)+    matchMethod :: Maybe Bool+    matchMethod = do+      method <- routeMatchMethod+      pure (requestMethod == method)++-- | Start a single web server.+--+-- @since 0.0.0.0+server :: Config -> Listen -> IO ()+server cfg@Config {..} listen@Listen {..} = do+  putLBSLn (Aeson.encode listen)+  Warp.run listenPort go+  where+    go :: Wai.Application+    go req resf = do+      let req' = toRequest req+      res <- case toList configRoutes & filter (match req') of+        [] -> do+          putLBSLn (Aeson.encode (req', ResponseCode 404))+          pure (Wai.responseLBS HTTP.status404 mempty mempty)+        r : _ -> do+          putLBSLn (Aeson.encode (req', r))+          route r req+      resf res+    route :: Route -> Wai.Request -> IO Wai.Response+    route Route {..} req = do+      let actions = fmap (respond cfg req) routeActions+          response = listToMaybe [r | Create r <- toList actions]+      foldlM+        ( \res action ->+            case action of+              Create _ -> pure res -- Already handled+              Modify f -> pure (f res)+              Effect k -> k >> pure res+        )+        (fromMaybe (Wai.responseLBS HTTP.status200 mempty mempty) response)+        actions++-- | Main.+main :: IO ()+main = do+  args <- getArgs+  cfg <- case args of+    [path] -> YML.decodeFileThrow path+    _ -> die "Usage: mockhttp <configuration-file>"+  Async.mapConcurrently_ (server cfg) (configListen cfg)
+ Setup.hs view
@@ -0,0 +1,16 @@+-- |+--+-- Copyright:+--   This file is part of the package mock-httpd. It is subject to the+--   license terms in the LICENSE file found in the top-level+--   directory of this distribution and at:+--+--     https://github.com/pjones/mock-httpd+--+--   No part of this package, including this file, may be copied,+--   modified, propagated, or distributed except according to the terms+--   contained in the LICENSE file.+--+-- License: BSD-2-Clause+import Distribution.Simple+main = defaultMain
+ example.yml view
@@ -0,0 +1,21 @@+# All file system access is restricted to this directory:+directory: ./tmp++# Listen on one or more ports:+listen:+  - port: 3210++# Routes match incoming requests.  The first route that matches all of+# its "match_*" properties wins.+routes:+  - match_path: /hello+    match_method: GET++    # Actions generate/modify the response:+    actions:+      - serve_text: "Hello World!\n"+      - content_type: text/plain+      - response_code: 200+      - set_headers:+          X-Hello: "World"+          X-Cool-Code: "200"
+ mock-httpd.cabal view
@@ -0,0 +1,70 @@+cabal-version:      2.4+name:               mock-httpd+version:            0.0.0.0+synopsis:           A HTTP server for testing HTTP clients+homepage:           https://github.com/pjones/mock-httpd+bug-reports:        https://github.com/pjones/mock-httpd/issues+license:            BSD-2-Clause+license-file:       LICENSE+author:             Peter Jones <pjones@devalot.com>+maintainer:         Peter Jones <pjones@devalot.com>+copyright:          Copyright (c) 2020 Peter Jones+category:           Network+description:+  Given a configuration file describing routes and actions, @mock-httpd@+  will bind to the specified ports and respond to incoming HTTP+  requests.+  .+  The primary goal of this project is to provide a simple way to test+  shell scripts that use <https://curl.haxx.se/ curl>.++extra-source-files:+  CHANGES.md+  example.yml++common options+  default-language:   Haskell2010+  default-extensions:+    DeriveAnyClass+    DeriveGeneric+    DerivingStrategies+    DerivingVia+    FlexibleContexts+    LambdaCase+    NamedFieldPuns+    NumericUnderscores+    OverloadedStrings+    RecordWildCards+    ScopedTypeVariables+    StandaloneDeriving+    TupleSections+    UndecidableInstances++  ghc-options:+    -Wall -Wno-name-shadowing -Werror=incomplete-record-updates+    -Werror=incomplete-uni-patterns -Werror=missing-home-modules+    -Widentities -Wmissing-export-lists -Wredundant-constraints++common dependencies+  build-depends:+    , aeson             ^>=1.4+    , async             ^>=2.2+    , base              >=4.12 && <5.0+    , bytestring        ^>=0.10+    , case-insensitive  ^>=1.2+    , filepath          ^>=1.4+    , http-types        ^>=0.12+    , relude            >=0.5  && <0.8+    , text              ^>=1.2+    , wai               ^>=3.2+    , warp              ^>=3.3+    , yaml              ^>=0.11++  mixins:+    base hiding (Prelude),+    relude (Relude as Prelude, Relude.Extra.Map)++executable mock-httpd+  import:           options, dependencies+  main-is:          Main.hs+  default-language: Haskell2010