-- |
--
-- 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)