diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,5 @@ +# Release History + +## [0.0.0.0] - 2020-08-06 + + * Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2020 Peter J. Jones +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. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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 " + Async.mapConcurrently_ (server cfg) (configListen cfg) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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 diff --git a/example.yml b/example.yml new file mode 100644 --- /dev/null +++ b/example.yml @@ -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" diff --git a/mock-httpd.cabal b/mock-httpd.cabal new file mode 100644 --- /dev/null +++ b/mock-httpd.cabal @@ -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 +maintainer: Peter Jones +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 . + +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