{-# LANGUAGE CPP, GADTs, OverloadedStrings #-}

module Network.Wreq.Internal
    (
      defaults
    , defaultManagerSettings
    , emptyMethodWith
    , foldResponseBody
    , ignoreResponse
    , readResponse
    , request
    , prepareGet
    , preparePost
    , runRead
    , runReadHistory
    , prepareHead
    , runIgnore
    , prepareOptions
    , preparePut
    , prepareDelete
    , prepareMethod
    , preparePayloadMethod
    ) where

import Control.Applicative ((<$>))
import Control.Arrow ((***))
import Control.Lens ((&), (.~), (%~))
import Control.Monad ((>=>))
import Data.Monoid ((<>))
import Data.Text.Encoding (encodeUtf8)
import Data.Version (showVersion)
import Network.HTTP.Client (BodyReader, HistoriedResponse(..))
import Network.HTTP.Client.Internal (Proxy(..), Request, Response(..), addProxy)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.Wreq.Internal.Lens (setHeader)
import Network.Wreq.Internal.Types (Mgr, Req(..), Run, RunHistory)
import Network.Wreq.Types (Auth(..), Options(..), Postable(..), Putable(..))
import Prelude hiding (head)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as Char8
import qualified Data.ByteString.Lazy as L
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wreq.Internal.Lens as Lens
import qualified Network.Wreq.Internal.AWS as AWS (signRequest)
import qualified Network.Wreq.Internal.OAuth1 as OAuth1 (signRequest)
import qualified Network.Wreq.Lens as Lens hiding (checkResponse)

-- This mess allows this module to continue to load during interactive
-- development in ghci :-(
#if defined(VERSION_base)
import Paths_wreq (version)
#else
import Data.Version (Version(..))
version :: Version
version = Version [0] ["wip"]
#endif

defaultManagerSettings :: HTTP.ManagerSettings
defaultManagerSettings = tlsManagerSettings

defaults :: Options
defaults = Options {
    manager     = Left defaultManagerSettings
  , proxy       = Nothing
  , auth        = Nothing
  , headers     = [("User-Agent", userAgent)]
  , params      = []
  , redirects   = 10
  , cookies     = Just (HTTP.createCookieJar [])
  , checkResponse = Nothing
  }
  where userAgent = "haskell wreq-" <> Char8.pack (showVersion version)

setRedirects :: Options -> Request -> Request
setRedirects opts req
  | redirects opts == HTTP.redirectCount req = req
  | otherwise = req { HTTP.redirectCount = redirects opts }

emptyMethodWith :: HTTP.Method -> Options -> String -> IO (Response ())
emptyMethodWith method opts url =
  request (return . (Lens.method .~ method)) opts url ignoreResponse

ignoreResponse :: Response BodyReader -> IO (Response ())
ignoreResponse resp = (Lens.responseBody .~ ()) <$> readResponse resp

readResponse :: Response BodyReader -> IO (Response L.ByteString)
readResponse resp = do
  chunks <- HTTP.brConsume (HTTP.responseBody resp)
  return resp { responseBody = L.fromChunks chunks }

readHistoriedResponse :: HistoriedResponse BodyReader -> IO (HistoriedResponse L.ByteString)
readHistoriedResponse resp = do
  let finalResp = hrFinalResponse resp
  chunks <- HTTP.brConsume (HTTP.responseBody finalResp)
  return resp { hrFinalResponse = finalResp { responseBody = L.fromChunks chunks } }

foldResponseBody :: (a -> S.ByteString -> IO a) -> a
                 -> Response BodyReader -> IO a
foldResponseBody f z0 resp = go z0
  where go z = do
          bs <- HTTP.brRead (HTTP.responseBody resp)
          if S.null bs
            then return z
            else f z bs >>= go

request :: (Request -> IO Request) -> Options -> String
        -> (Response BodyReader -> IO a) -> IO a
request modify opts url act = run (manager opts) act =<< prepare modify opts url

run :: Mgr -> (Response BodyReader -> IO a) -> Request -> IO a
run emgr act req = either (HTTP.newManager >=> go) go emgr
  where go mgr = HTTP.withResponse req mgr act

runHistory :: Mgr -> (HistoriedResponse BodyReader -> IO a) -> Request -> IO a
runHistory emgr act req = either (HTTP.newManager >=> go) go emgr
  where go mgr = HTTP.withResponseHistory req mgr act

prepare :: (Request -> IO Request) -> Options -> String -> IO Request
prepare modify opts url = do
  signRequest =<< modify =<< frob <$> HTTP.parseUrlThrow url
  where
    frob req = req & Lens.requestHeaders %~ (headers opts ++)
                   & setQuery opts
                   & setAuth opts
                   & setProxy opts
                   & setCheckResponse opts
                   & setRedirects opts
                   & Lens.cookieJar .~ cookies opts
    signRequest :: Request -> IO Request
    signRequest = maybe return f $ auth opts
      where
        f (AWSAuth versn key secret _) = AWS.signRequest versn key secret
        f (OAuth1 consumerToken consumerSecret token secret) = OAuth1.signRequest consumerToken consumerSecret token secret
        f _ = return


setQuery :: Options -> Request -> Request
setQuery opts =
  case params opts of
    [] -> id
    ps -> Lens.queryString %~ \qs ->
          let n = S.length qs in
          qs <> (if n > 1 then "&" else "") <> HTTP.renderSimpleQuery (n==0)
          (map (encodeUtf8 *** encodeUtf8) ps)

setAuth :: Options -> Request -> Request
setAuth = maybe id f . auth
  where
    f (BasicAuth user pass) = HTTP.applyBasicAuth user pass
    f (OAuth2Bearer token)  = setHeader "Authorization" ("Bearer " <> token)
    f (OAuth2Token token)   = setHeader "Authorization" ("token " <> token)
    -- for AWS request signature implementation, see Internal/AWS
    f (AWSAuth _ _ _ mSessionToken) =
      maybe id (setHeader "X-Amz-Security-Token") mSessionToken
    f (OAuth1 _ _ _ _)      = id

setProxy :: Options -> Request -> Request
setProxy = maybe id f . proxy
  where f (Proxy host port) = addProxy host port

setCheckResponse :: Options -> Request -> Request
setCheckResponse = maybe id f . checkResponse
  where f cs = ( & Lens.checkResponse .~ cs)

prepareGet :: Options -> String -> IO Req
prepareGet opts url = Req (manager opts) <$> prepare return opts url

runRead :: Run L.ByteString
runRead (Req mgr req) = run mgr readResponse req

runReadHistory :: RunHistory L.ByteString
runReadHistory (Req mgr req) = runHistory mgr readHistoriedResponse req

preparePost :: Postable a => Options -> String -> a -> IO Req
preparePost opts url payload = Req (manager opts) <$>
  prepare (postPayload payload . (Lens.method .~ HTTP.methodPost)) opts url

prepareMethod :: HTTP.Method -> Options -> String -> IO Req
prepareMethod method opts url = Req (manager opts) <$>
  prepare (return . (Lens.method .~ method)) opts url

preparePayloadMethod :: Postable a => HTTP.Method -> Options -> String -> a
                        -> IO Req
preparePayloadMethod method opts url payload = Req (manager opts) <$>
  prepare (postPayload payload . (Lens.method .~ method)) opts url

prepareHead :: Options -> String -> IO Req
prepareHead = prepareMethod HTTP.methodHead

runIgnore :: Run ()
runIgnore (Req mgr req) = run mgr ignoreResponse req

prepareOptions :: Options -> String -> IO Req
prepareOptions = prepareMethod HTTP.methodOptions

preparePut :: Putable a => Options -> String -> a -> IO Req
preparePut opts url payload = Req (manager opts) <$>
  prepare (putPayload payload . (Lens.method .~ HTTP.methodPut)) opts url

prepareDelete :: Options -> String -> IO Req
prepareDelete = prepareMethod HTTP.methodDelete