{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Symantic.HTTP.Client.Connection where

import Control.Applicative (Applicative(..), Alternative(..))
import Control.Monad (Monad(..), unless)
import Control.Monad.Trans.Class (MonadTrans(..))
import Data.Bool
import Data.Default.Class (Default(..))
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (null, for_, toList)
import Data.Function (($), (.), on)
import Data.Functor (Functor, (<$>))
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq)
import Data.String (IsString(..))
import Data.Text (Text)
import Data.Tuple (fst)
import System.IO (IO)
import Text.Read (readMaybe)
import Text.Show (Show(..))
import qualified Control.Concurrent.STM as STM
import qualified Control.Exception as Exn
import qualified Control.Monad.Classes as MC
import qualified Control.Monad.Trans.Except as E
import qualified Control.Monad.Trans.Reader as R
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Lazy as BSL
import qualified Data.List as List
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import qualified Data.Time.Clock as Time
import qualified Network.HTTP.Client as Client
import qualified Network.HTTP.Media as Media
import qualified Network.HTTP.Types as HTTP
import qualified Network.URI as URI

import Symantic.HTTP.Utils
import Symantic.HTTP.MIME
import Symantic.HTTP.URI

-- * Type 'ClientConnection'
-- [ A monadic connection for a client query a server.
newtype ClientConnection a = ClientConnection { unClientConnection ::
	R.ReaderT ClientEnv
	          (E.ExceptT ClientError IO)
	          a
 } deriving (Functor, Applicative, Monad)
type instance MC.CanDo ClientConnection (MC.EffReader ClientEnv)   = 'True
type instance MC.CanDo ClientConnection (MC.EffExcept ClientError) = 'True
type instance MC.CanDo ClientConnection (MC.EffExec   IO)          = 'True
instance MC.MonadExceptN 'MC.Zero ClientError ClientConnection where
	throwN px = ClientConnection . lift . MC.throwN px
instance MC.MonadReaderN 'MC.Zero ClientEnv ClientConnection where
	askN px = ClientConnection $ MC.askN px
instance MC.MonadExecN 'MC.Zero IO ClientConnection where
	execN _px = ClientConnection . lift . lift

-- | Try clients in order, last error is preserved.
instance Alternative ClientConnection where
	empty = MC.throw $ ClientError_EmptyClient
	x <|> y = ClientConnection $ do
		env <- MC.ask
		liftIO (runClientConnection env x) >>= \case
		 Right xa -> return xa
		 Left _err -> unClientConnection y

clientConnection ::
 forall a ts.
 MimeTypes ts (MimeDecodable a) =>
 (Proxy ts -> Proxy a -> ClientRequest) ->
 ClientConnection a
clientConnection req = do
	clientRes <- doClientRequest $ req (Proxy::Proxy ts) (Proxy::Proxy a)
	clientResMimeDecode (Proxy::Proxy ts) clientRes

runClientConnection :: ClientEnv -> ClientConnection a -> IO (Either ClientError a)
runClientConnection env (ClientConnection c) = E.runExceptT $ R.runReaderT c env

runClientRequest :: ClientEnv -> ClientRequest -> IO (Either ClientError ClientResponse)
runClientRequest env = runClientConnection env . doClientRequest

-- ** Type 'ClientEnv'
data ClientEnv
 =   ClientEnv
 {   clientEnv_manager   :: Client.Manager
 ,   clientEnv_baseURI   :: URI
 ,   clientEnv_cookieJar :: Maybe (STM.TVar Client.CookieJar)
 }
clientEnv :: Client.Manager -> URI -> ClientEnv
clientEnv clientEnv_manager clientEnv_baseURI =
	ClientEnv
	 { clientEnv_cookieJar = Nothing
	 , ..
	 }

-- ** Type 'ClientError'
data ClientError
     -- | The server returned an error response
 =   ClientError_FailureResponse ClientResponse
     -- | The body could not be decoded at the expected type
 |   ClientError_DecodeFailure Text ClientResponse
     -- | The content-type of the response is not supported
 |   ClientError_UnsupportedContentType BS.ByteString ClientResponse
 {-
     -- | The content-type header is invalid
 |   ClientError_InvalidContentTypeHeader ClientResponse
 -}
     -- | There was a connection error, and no response was received
 |   ClientError_ClientConnectionectionError Client.HttpException
     -- | 'ClientConnection' is 'empty'
 |   ClientError_EmptyClient
 deriving (Eq, Show{-, Generic, Typeable-})
instance Exn.Exception ClientError
instance Eq Client.HttpException where
	(==) = (==) `on` show

-- * Type 'ClientRequest'
data ClientRequest
 =   ClientRequest
 {   clientReqHttpVersion :: HTTP.HttpVersion
 ,   clientReqMethod      :: HTTP.Method
 ,   clientReqPath        :: BSB.Builder
 ,   clientReqQueryString :: Seq HTTP.QueryItem
 ,   clientReqAccept      :: Seq Media.MediaType
 ,   clientReqHeaders     :: Seq HTTP.Header
 ,   clientReqBody        :: Maybe (Client.RequestBody, Media.MediaType)
 }
instance Default ClientRequest where
	def = ClientRequest
	 {    clientReqHttpVersion = HTTP.http11
	 ,    clientReqMethod      = HTTP.methodGet
	 ,    clientReqPath        = ""
	 ,    clientReqQueryString = Seq.empty
	 ,    clientReqAccept      = Seq.empty
	 ,    clientReqHeaders     = Seq.empty
	 ,    clientReqBody        = Nothing
	 }
instance Show ClientRequest where
	show _ = "ClientRequest"

clientRequest :: URI -> ClientRequest -> Client.Request
clientRequest baseURI req =
	Client.defaultRequest
	 { Client.method         = clientReqMethod req
	 , Client.host           = maybe "" (fromString . URI.uriRegName) $ URI.uriAuthority baseURI
	 , Client.port           = case URI.uriPort <$> URI.uriAuthority baseURI of
	                            Just (':':p) | Just port <- readMaybe p -> port
	                            _ -> 0
	 , Client.path           = BSL.toStrict $ fromString (URI.uriPath baseURI) <> BSB.toLazyByteString (clientReqPath req)
	 , Client.queryString    = HTTP.renderQuery True . toList $ clientReqQueryString req
	 , Client.requestHeaders = acceptHeader <> contentTypeHeader <> headers
	 , Client.requestBody
	 , Client.secure         = URI.uriScheme baseURI == "https"
	 }
	where
	headers = List.filter (\(h, _) -> h/="Accept" && h/="Content-Type") $
		toList $ clientReqHeaders req
	
	acceptHeader | null hs   = []
	             | otherwise = [("Accept", Media.renderHeader hs)]
		where
		hs = toList $ clientReqAccept req
	
	(requestBody, contentTypeHeader) =
		case clientReqBody req of
		 Nothing          -> (Client.RequestBodyLBS "", [])
		 Just (body, typ) -> (body, [(HTTP.hContentType, Media.renderHeader typ)])

setClientRequestBodyLBS :: BSL.ByteString -> MediaType -> ClientRequest -> ClientRequest
setClientRequestBodyLBS body mt req = req{ clientReqBody =
	Just (Client.RequestBodyLBS body, mt) }

setClientRequestBody :: Client.RequestBody -> MediaType -> ClientRequest -> ClientRequest
setClientRequestBody body mt req = req{ clientReqBody = Just (body, mt) }

-- ** Type 'ClientResponse'
type ClientResponse
 =   ClientResponseWithBody BSL.ByteString
data ClientResponseWithBody a
 =   ClientResponse
 {   clientResStatus      :: HTTP.Status
 ,   clientResHeaders     :: Seq HTTP.Header
 ,   clientResHttpVersion :: HTTP.HttpVersion
 ,   clientResBody        :: a
 } deriving (Eq, Show, Functor)

clientResponse :: Client.Response a -> ClientResponseWithBody a
clientResponse res =
	ClientResponse
	 { clientResStatus      = Client.responseStatus res
	 , clientResBody        = Client.responseBody res
	 , clientResHeaders     = Seq.fromList $ Client.responseHeaders res
	 , clientResHttpVersion = Client.responseVersion res
	 }

doClientRequest :: ClientRequest -> ClientConnection ClientResponse
doClientRequest clientReq = do
	ClientEnv{..} <- MC.ask
	req <-
		let req = clientRequest clientEnv_baseURI clientReq in
		case clientEnv_cookieJar of
		 Nothing -> pure req
		 Just cj ->
			liftIO $ do
				now <- Time.getCurrentTime
				STM.atomically $ do
					oldCookieJar <- STM.readTVar cj
					let (newRequest, newCookieJar) =
						Client.insertCookiesIntoRequest req oldCookieJar now
					STM.writeTVar cj newCookieJar
					pure newRequest
	lrRes <-
		liftIO $ catchClientConnectionectionError $
		Client.httpLbs req clientEnv_manager
	case lrRes of
		Left err -> MC.throw err
		Right res -> do
			for_ clientEnv_cookieJar $ \cj ->
				liftIO $ do
					now <- Time.getCurrentTime
					STM.atomically $ STM.modifyTVar' cj (fst . Client.updateCookieJar res req now)
			let status    = HTTP.statusCode $ Client.responseStatus res
			    clientRes = clientResponse res
			unless (status >= 200 && status < 300) $
				MC.throw $ ClientError_FailureResponse clientRes
			return clientRes

catchClientConnectionectionError :: IO a -> IO (Either ClientError a)
catchClientConnectionectionError action =
	Exn.catch (Right <$> action) $ \err ->
		return $ Left $ ClientError_ClientConnectionectionError err

-- ** Type 'ClientResponseStreaming'
newtype ClientResponseStreaming
 =      ClientResponseStreaming
 { runClientResponseStreaming ::
	forall a.
	(ClientResponseWithBody (IO BS.ByteString) -> IO a) ->
	IO a
 }

doClientRequestStreaming :: ClientRequest -> ClientConnection ClientResponseStreaming
doClientRequestStreaming clientReq = do
	ClientEnv{..} <- MC.ask
	let req = clientRequest clientEnv_baseURI clientReq
	return $ ClientResponseStreaming $ \k ->
		Client.withResponse req clientEnv_manager $ \res -> do
			let status = HTTP.statusCode $ Client.responseStatus res
			unless (status >= 200 && status < 300) $ do
				responseBody <- BSL.fromChunks <$> Client.brConsume (Client.responseBody res)
				Exn.throw $ ClientError_FailureResponse $ clientResponse res{Client.responseBody}
			k $ clientResponse res

clientResMimeDecode ::
 forall ts m a.
 MimeTypes ts (MimeDecodable a) =>
 MC.MonadExcept ClientError m =>
 Proxy ts -> ClientResponse -> m a
clientResMimeDecode Proxy clientRes = do
	let mtRes =
		fromMaybe "application/octet-stream" $
		List.lookup "Content-Type" $ toList $ clientResHeaders clientRes
	case matchContent @ts @(MimeDecodable a) mtRes of
	 Nothing -> MC.throw $ ClientError_UnsupportedContentType mtRes clientRes
	 Just (MimeType mt) ->
		case mimeDecode mt $ clientResBody clientRes of
		 Left  err -> MC.throw $ ClientError_DecodeFailure (T.pack err) clientRes
		 Right val -> return val