Internal.hs

{-# LANGUAGE StrictData #-}

module Network.HTTP.Barf.Internal
  ( -- * exported
    Req (..)
  , get_
  , head_
  , post_
  , put_
  , delete_
  , q_
  , h_
  , j_
  , v_
  , inspectRequest_
  , dryRun_

    -- * internal
  , httpWithManager
  , buildRequestFromReq
  , Req' (..)
  , defaultReq'
  )
where

import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Aeson (Value)
import Data.Aeson qualified as Aeson
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy (LazyByteString)
import Data.List qualified as List
import Data.Monoid (Endo (..))
import Data.Vector (Vector)
import Data.Vector qualified as V
import GHC.Generics (Generic)
import GHC.IsList (IsList (Item, fromList, toList))
import Network.HTTP.Client
import Network.HTTP.Client.TLS (tlsManagerSettings)
import System.Exit (exitFailure)
import System.IO (hPutStrLn, stderr)

-- | a data type representing an http request
data Req' = MkReq'
  { queryParams :: Vector (String, String)
  , headers :: Vector (String, String)
  , jsonBody :: Maybe Value
  , inspectRequest :: Bool
  , dryRun :: Bool
  }
  deriving stock (Eq, Ord, Show, Generic)

defaultReq' :: Req'
defaultReq' = MkReq' {queryParams = mempty, headers = mempty, jsonBody = Nothing, inspectRequest = False, dryRun = False}

-- | The type of request modifications.
--   The most important features of this type are the 'Monoid', 'Semigroup' and 'IsList' instances.
newtype Req = MkReq {appReq :: Req' -> Req'}
  deriving
    ( Semigroup
      -- ^ combining to 'Req's composes the extensions to the request
    , Monoid
      -- ^ the empty 'Req' does nothing to the "base" request
    )
    via Endo Req'

-- | An 'IsList' instance for 'Req' makes it easy to combine multiple 'Req's monoidally by passing them in list syntax.
-- The idea is that it composes all of the request extensions in the list it gets passed
--
-- Even though @'toList' = 'List.singleton'@, this instance does adhere to the laws of the 'IsList' type class
instance IsList Req where
  type Item Req = Req

  toList = List.singleton
  fromList = mconcat

-- | creates a @GET@ request, use it like
--
-- @'get_' "http://localhost:8080" []@
get_
  :: MonadIO m
  => String
  -- ^ the url to connect to
  -> Req
  -- ^ the modifier(s) to the request
  -> m LazyByteString
get_ = httpWithManager "GET"

-- | creates a @HEAD@ request, use it like
--
-- @'head_' "http://localhost:8080" []@
head_
  :: MonadIO m
  => String
  -- ^ the url to connect to
  -> Req
  -- ^ the modifier(s) to the request
  -> m LazyByteString
head_ = httpWithManager "HEAD"

-- | creates a @DELETE@ request, use it like
--
-- @'delete_' "http://localhost:8080" []@
delete_
  :: MonadIO m
  => String
  -- ^ the url to connect to
  -> Req
  -- ^ the modifier(s) to the request
  -> m LazyByteString
delete_ = httpWithManager "DELETE"

-- | creates a @PUT@ request, use it like
--
-- @'put_' "http://localhost:8080" []@
put_
  :: MonadIO m
  => String
  -- ^ the url to connect to
  -> Req
  -- ^ the modifier(s) to the request
  -> m LazyByteString
put_ = httpWithManager "PUT"

-- | creates a @POST@ request, use it like
--
-- @'post_' "http://localhost:8080" []@
post_
  :: MonadIO m
  => String
  -- ^ the url to connect to
  -> Req
  -- ^ the modifier(s) to the request
  -> m LazyByteString
post_ = httpWithManager "POST"

buildRequestFromReq :: String -> String -> Req' -> IO Request
buildRequestFromReq method url req = do
  r <-
    setQueryString (foldMap (\(s, s') -> [(BS8.pack s, Just (BS8.pack s'))]) req.queryParams)
      . (\r -> r {requestBody = RequestBodyLBS $ Aeson.encode req.jsonBody})
      . (\r -> r {method = BS8.pack method})
      <$> parseRequest url
  let err = hPutStrLn stderr
  when req.inspectRequest do
    err "request parameters"
    err (show req)
    err "the resulting request"
    err (show r)
  when req.dryRun do
    err "dryrun, exiting"
    exitFailure
  pure r

httpWithManager :: MonadIO m => String -> String -> Req -> m LazyByteString
httpWithManager method url req = liftIO do
  r <- buildRequestFromReq method url $ req.appReq defaultReq'
  manager <- newManager if r.secure then tlsManagerSettings else defaultManagerSettings
  responseBody <$> httpLbs r manager

-- | 'q_' like "query"
q_
  :: String
  -- ^ the name of the query param
  -> String
  -- ^ the value of the query param
  -> Req
q_ k v = MkReq \req -> req {queryParams = (k, v) `V.cons` req.queryParams}

-- | 'h_' like "header"
h_
  :: String
  -- ^ the name of the header
  -> String
  -- ^ the value of the header
  -> Req
h_ k v = MkReq \req -> req {headers = (k, v) `V.cons` req.headers}

-- | 'v_' like "value"
--
-- this is a convenience helper for using @'j_'@ specialised to 'Value'. It is useful
-- if you just want to quickly build a json body for your request.
--
-- if the json body is already set, it /will be overwritten/
v_
  :: Value
  -- ^ the value of the json body
  -> Req
v_ val = MkReq \req -> req {jsonBody = Just val}

-- | 'j_' like "json"
--
-- if the json body is already set, it /will be overwritten/
j_
  :: Aeson.ToJSON a
  => a
  -- ^ the value of the json body
  -> Req
j_ = v_ . Aeson.toJSON

-- | print the request before dispatching, useful for debugging
inspectRequest_ :: Req
inspectRequest_ = MkReq \req -> req {inspectRequest = True}

-- | when set, do not execute the request
dryRun_ :: Req
dryRun_ = MkReq \req -> req {dryRun = True}