{-# 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 (StrictByteString)
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'
  { Req' -> Vector (String, String)
queryParams :: Vector (String, String)
  , Req' -> Vector (String, String)
headers :: Vector (String, String)
  , Req' -> Maybe Value
jsonBody :: Maybe Value
  , Req' -> Bool
inspectRequest :: Bool
  , Req' -> Bool
dryRun :: Bool
  }
  deriving stock (Req' -> Req' -> Bool
(Req' -> Req' -> Bool) -> (Req' -> Req' -> Bool) -> Eq Req'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Req' -> Req' -> Bool
== :: Req' -> Req' -> Bool
$c/= :: Req' -> Req' -> Bool
/= :: Req' -> Req' -> Bool
Eq, Eq Req'
Eq Req' =>
(Req' -> Req' -> Ordering)
-> (Req' -> Req' -> Bool)
-> (Req' -> Req' -> Bool)
-> (Req' -> Req' -> Bool)
-> (Req' -> Req' -> Bool)
-> (Req' -> Req' -> Req')
-> (Req' -> Req' -> Req')
-> Ord Req'
Req' -> Req' -> Bool
Req' -> Req' -> Ordering
Req' -> Req' -> Req'
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Req' -> Req' -> Ordering
compare :: Req' -> Req' -> Ordering
$c< :: Req' -> Req' -> Bool
< :: Req' -> Req' -> Bool
$c<= :: Req' -> Req' -> Bool
<= :: Req' -> Req' -> Bool
$c> :: Req' -> Req' -> Bool
> :: Req' -> Req' -> Bool
$c>= :: Req' -> Req' -> Bool
>= :: Req' -> Req' -> Bool
$cmax :: Req' -> Req' -> Req'
max :: Req' -> Req' -> Req'
$cmin :: Req' -> Req' -> Req'
min :: Req' -> Req' -> Req'
Ord, Int -> Req' -> ShowS
[Req'] -> ShowS
Req' -> String
(Int -> Req' -> ShowS)
-> (Req' -> String) -> ([Req'] -> ShowS) -> Show Req'
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Req' -> ShowS
showsPrec :: Int -> Req' -> ShowS
$cshow :: Req' -> String
show :: Req' -> String
$cshowList :: [Req'] -> ShowS
showList :: [Req'] -> ShowS
Show, (forall x. Req' -> Rep Req' x)
-> (forall x. Rep Req' x -> Req') -> Generic Req'
forall x. Rep Req' x -> Req'
forall x. Req' -> Rep Req' x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Req' -> Rep Req' x
from :: forall x. Req' -> Rep Req' x
$cto :: forall x. Rep Req' x -> Req'
to :: forall x. Rep Req' x -> Req'
Generic)

defaultReq' :: Req'
defaultReq' :: Req'
defaultReq' = MkReq' {queryParams :: Vector (String, String)
queryParams = Vector (String, String)
forall a. Monoid a => a
mempty, headers :: Vector (String, String)
headers = Vector (String, String)
forall a. Monoid a => a
mempty, jsonBody :: Maybe Value
jsonBody = Maybe Value
forall a. Maybe a
Nothing, inspectRequest :: Bool
inspectRequest = Bool
False, dryRun :: Bool
dryRun = Bool
False}

-- | The type of request modifications.
--   The most important features of this type are the 'Monoid', 'Semigroup' and 'IsList' instances.
newtype Req = MkReq {Req -> Req' -> Req'
appReq :: Req' -> Req'}
  deriving
    ( NonEmpty Req -> Req
Req -> Req -> Req
(Req -> Req -> Req)
-> (NonEmpty Req -> Req)
-> (forall b. Integral b => b -> Req -> Req)
-> Semigroup Req
forall b. Integral b => b -> Req -> Req
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Req -> Req -> Req
<> :: Req -> Req -> Req
$csconcat :: NonEmpty Req -> Req
sconcat :: NonEmpty Req -> Req
$cstimes :: forall b. Integral b => b -> Req -> Req
stimes :: forall b. Integral b => b -> Req -> Req
Semigroup
      -- ^ combining to 'Req's composes the extensions to the request
    , Semigroup Req
Req
Semigroup Req =>
Req -> (Req -> Req -> Req) -> ([Req] -> Req) -> Monoid Req
[Req] -> Req
Req -> Req -> Req
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Req
mempty :: Req
$cmappend :: Req -> Req -> Req
mappend :: Req -> Req -> Req
$cmconcat :: [Req] -> Req
mconcat :: [Req] -> Req
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 :: Req -> [Item Req]
toList = Req -> [Item Req]
Req -> [Req]
forall a. a -> [a]
List.singleton
  fromList :: [Item Req] -> Req
fromList = [Item Req] -> Req
[Req] -> Req
forall a. Monoid a => [a] -> a
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_ :: forall (m :: * -> *).
MonadIO m =>
String -> Req -> m LazyByteString
get_ = ByteString -> String -> Req -> m LazyByteString
forall (m :: * -> *).
MonadIO m =>
ByteString -> String -> Req -> m LazyByteString
httpWithManager ByteString
"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_ :: forall (m :: * -> *).
MonadIO m =>
String -> Req -> m LazyByteString
head_ = ByteString -> String -> Req -> m LazyByteString
forall (m :: * -> *).
MonadIO m =>
ByteString -> String -> Req -> m LazyByteString
httpWithManager ByteString
"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_ :: forall (m :: * -> *).
MonadIO m =>
String -> Req -> m LazyByteString
delete_ = ByteString -> String -> Req -> m LazyByteString
forall (m :: * -> *).
MonadIO m =>
ByteString -> String -> Req -> m LazyByteString
httpWithManager ByteString
"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_ :: forall (m :: * -> *).
MonadIO m =>
String -> Req -> m LazyByteString
put_ = ByteString -> String -> Req -> m LazyByteString
forall (m :: * -> *).
MonadIO m =>
ByteString -> String -> Req -> m LazyByteString
httpWithManager ByteString
"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_ :: forall (m :: * -> *).
MonadIO m =>
String -> Req -> m LazyByteString
post_ = ByteString -> String -> Req -> m LazyByteString
forall (m :: * -> *).
MonadIO m =>
ByteString -> String -> Req -> m LazyByteString
httpWithManager ByteString
"POST"

buildRequestFromReq :: StrictByteString -> String -> Req' -> IO Request
buildRequestFromReq :: ByteString -> String -> Req' -> IO Request
buildRequestFromReq ByteString
method String
url Req'
req = do
  Request
r <-
    [(ByteString, Maybe ByteString)] -> Request -> Request
setQueryString (((String, String) -> [(ByteString, Maybe ByteString)])
-> Vector (String, String) -> [(ByteString, Maybe ByteString)]
forall m a. Monoid m => (a -> m) -> Vector a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(String
s, String
s') -> [(String -> ByteString
BS8.pack String
s, ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (String -> ByteString
BS8.pack String
s'))]) Req'
req.queryParams)
      (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\Request
r -> Request
r {requestBody = RequestBodyLBS $ Aeson.encode req.jsonBody})
      (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\Request
r -> Request
r {method = method})
      (Request -> Request) -> IO Request -> IO Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url
  let err :: String -> IO ()
err = Handle -> String -> IO ()
hPutStrLn Handle
stderr
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Req'
req.inspectRequest do
    String -> IO ()
err String
"request parameters"
    String -> IO ()
err (Req' -> String
forall a. Show a => a -> String
show Req'
req)
    String -> IO ()
err String
"the resulting request"
    String -> IO ()
err (Request -> String
forall a. Show a => a -> String
show Request
r)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Req'
req.dryRun do
    String -> IO ()
err String
"dryrun, exiting"
    IO ()
forall a. IO a
exitFailure
  Request -> IO Request
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
r

httpWithManager :: MonadIO m => StrictByteString -> String -> Req -> m LazyByteString
httpWithManager :: forall (m :: * -> *).
MonadIO m =>
ByteString -> String -> Req -> m LazyByteString
httpWithManager ByteString
method String
url Req
req = IO LazyByteString -> m LazyByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
  Request
r <- ByteString -> String -> Req' -> IO Request
buildRequestFromReq ByteString
method String
url (Req' -> IO Request) -> Req' -> IO Request
forall a b. (a -> b) -> a -> b
$ Req
req.appReq Req'
defaultReq'
  Manager
manager <- ManagerSettings -> IO Manager
newManager if Request
r.secure then ManagerSettings
tlsManagerSettings else ManagerSettings
defaultManagerSettings
  Response LazyByteString -> LazyByteString
forall body. Response body -> body
responseBody (Response LazyByteString -> LazyByteString)
-> IO (Response LazyByteString) -> IO LazyByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Manager -> IO (Response LazyByteString)
httpLbs Request
r Manager
manager

-- | 'q_' like "query"
q_
  :: String
  -- ^ the name of the query param
  -> String
  -- ^ the value of the query param
  -> Req
q_ :: String -> String -> Req
q_ String
k String
v = (Req' -> Req') -> Req
MkReq \Req'
req -> 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_ :: String -> String -> Req
h_ String
k String
v = (Req' -> Req') -> Req
MkReq \Req'
req -> 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_ :: Value -> Req
v_ Value
val = (Req' -> Req') -> Req
MkReq \Req'
req -> 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_ :: forall a. ToJSON a => a -> Req
j_ = Value -> Req
v_ (Value -> Req) -> (a -> Value) -> a -> Req
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON

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

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