{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | See <https://hackage.haskell.org/package/symantic-http-demo symantic-http-demo>
-- for an example of how to use this module.
module Symantic.HTTP.Client where

import Control.Applicative (Applicative(..){-, Alternative(..)-})
import Control.Monad (Monad(..), unless)
import Control.Monad.Trans.Class (MonadTrans(..))
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (null, for_, toList)
import Data.Function (($), (.), id, on)
import Data.Functor (Functor(..), (<$>))
import Data.Kind (Constraint)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..), String)
import Data.Traversable (sequence)
import Data.Tuple (fst)
import GHC.Exts (fromList)
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.Base64 as BS64
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Lazy as BSL
import qualified Data.IORef as IO
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Sequence as Seq
import qualified Data.Text.Encoding as Text
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 qualified Web.HttpApiData as Web

import Symantic.HTTP.API
import Symantic.HTTP.URI
import Symantic.HTTP.MIME

-- * Type 'Client'
-- | (@'Client' a k@) is a recipe to produce a 'ClientRequest'
-- from returned ('callers') (one per number of alternative routes)
-- separated by (':!:').
--
-- 'Client' is analogous to a printf using the API as a format customized for HTTP routing.
newtype Client callers k
 =      Client
 {    unClient :: (ClientModifier -> k) -> callers
 }

-- | @'client' callers@ returns the 'ClientRequest'
-- builders from the given API.
client :: Client callers ClientRequest -> callers
client (Client callers) = callers ($ ini)
	where
	ini = ClientRequest
	 {    clientReq_httpVersion = HTTP.http11
	 ,    clientReq_method      = HTTP.methodGet
	 ,    clientReq_path        = ""
	 ,    clientReq_queryString = Seq.empty
	 ,    clientReq_accept      = Seq.empty
	 ,    clientReq_headers     = Seq.empty
	 ,    clientReq_body        = Nothing
	 }

-- ** Type 'ClientModifier'
type ClientModifier = ClientRequest -> ClientRequest

instance Cat Client where
	Client x <.> Client y = Client $ \k ->
		x $ \fx -> y $ \fy -> k $ fy . fx
instance Alt Client where
	Client x <!> Client y = Client $ \k ->
		x k :!: y k
	{-
	type AltMerge Client = (:!:)
	Client x <!> Client y = Client $ \k ->
		x (\cm -> let n:!:_ = k cm in n) :!:
		y (\cm -> let _:!:n = k cm in n)
	-}
	-- try = id -- FIXME: see what to do
instance Pro Client where
	dimap _a2b b2a r = Client $ \k -> unClient r k . b2a

instance HTTP_Path Client where
	type PathConstraint Client a = Web.ToHttpApiData a
	segment s = Client $ \k -> k $ \req ->
		req{ clientReq_path = clientReq_path req <> "/" <> Web.toEncodedUrlPiece s }
	capture' _n = Client $ \k a -> k $ \req ->
		req{ clientReq_path = clientReq_path req <> "/" <> Web.toEncodedUrlPiece a }
	captureAll = Client $ \k ss -> k $ \req ->
		req{ clientReq_path =
			List.foldl' (\acc s -> acc <> "/" <> Web.toEncodedUrlPiece s) "" $
			Web.toUrlPiece <$> ss
		 }
instance HTTP_Header Client where
	header n = Client $ \k v -> k $ \req ->
		req{ clientReq_headers = clientReq_headers req Seq.|> (n, Web.toHeader v) }
instance HTTP_Raw Client where
	type RawConstraint Client = ()
	type RawArgs Client = HTTP.Method -> Proxy ('[]::[*]) -> Proxy ClientResponse -> ClientRequest
	type Raw Client = ClientRequest
	raw = Client $ \k meth Proxy Proxy -> k $ \req ->
		req{ clientReq_method = meth }
instance HTTP_BasicAuth Client where
	type BasicAuthConstraint Client a = ()
	type BasicAuthArgs Client a k = BasicAuthUser -> BasicAuthPass -> k
	basicAuth' realm = Client $ \k user pass -> k $ \req ->
		req{ clientReq_headers =
			let user_pass = Text.encodeUtf8 $ user<>":"<>pass in
			clientReq_headers req Seq.|>
			 ( HTTP.hAuthorization
			 , Web.toHeader $ "Basic " <> BS64.encode user_pass
			 )
		 }
instance HTTP_Query Client where
	type QueryConstraint Client a = Web.ToHttpApiData a
	queryParams' n = Client $ \k vs -> k $ \req ->
		req{ clientReq_queryString =
			clientReq_queryString req <>
			fromList ((\v -> (n, Just $ Text.encodeUtf8 $ Web.toQueryParam v)) <$> vs) }
instance HTTP_Version Client where
	version v = Client $ \k -> k $ \req ->
		req{clientReq_httpVersion = v}

-- ** Type 'ClientBodyArg'
newtype ClientBodyArg (ts::[*]) a = ClientBodyArg a
instance HTTP_Body Client where
	type BodyConstraint Client a ts = MimeTypes ts (MimeEncodable a)
	type BodyArg Client a ts = ClientBodyArg ts a
	body' ::
	 forall a ts k repr.
	 BodyConstraint repr a ts =>
	 repr ~ Client =>
	 repr (BodyArg repr a ts -> k) k
	body'= Client $ \k (ClientBodyArg a) -> k $ \req ->
		req{clientReq_body =
			case NonEmpty.head (mimeTypes @ts) :: MimeType (MimeEncodable a) of
			 MimeType (mt::Proxy t) ->
				Just
				 ( Client.RequestBodyLBS $ mimeEncode mt a
				 , mediaType @t )
		 }

-- ** Type 'ClientBodyStreamArg'
newtype ClientBodyStreamArg framing (ts::[*]) as = ClientBodyStreamArg as
instance HTTP_BodyStream Client where
	type BodyStreamConstraint Client as ts framing =
	 ( FramingEncode framing as
	 , MimeTypes ts (MimeEncodable (FramingYield as))
	 )
	type BodyStreamArg Client as ts framing = ClientBodyStreamArg framing ts as
	bodyStream' ::
	 forall as ts framing k repr.
	 BodyStreamConstraint repr as ts framing =>
	 repr ~ Client =>
	 repr (BodyStreamArg repr as ts framing -> k) k
	bodyStream'= Client $ \k (ClientBodyStreamArg as) -> k $ \req ->
		req{clientReq_body =
			case NonEmpty.head (mimeTypes @ts) :: MimeType (MimeEncodable (FramingYield as)) of
			 MimeType (mt::Proxy t) ->
				Just $ (, mediaType @t) $
					Client.RequestBodyStreamChunked $ \write -> do
						let enc = framingEncode (Proxy @framing) (mimeEncode mt)
						ini <- enc as
						ioref <- IO.newIORef ini
						let go curr =
							case curr of
							 Left _end -> return ""
							 Right (bsl, next)
							  | BSL.null bsl -> enc next >>= go
								-- NOTE: skip all null 'ByteString' because it would end the stream.
							  | otherwise -> enc next >>= \n -> do
								IO.writeIORef ioref n
								return $ BSL.toStrict bsl
								-- NOTE: strictify the 'bsl' 'ByteString'
								-- instead of iterating on its chunks,
								-- in order to diminish the number of 'Client.connectionWrite'.
						write $ IO.readIORef ioref >>= go
		 }

instance HTTP_Response Client where
	type ResponseConstraint Client a ts = MimeTypes ts (MimeDecodable a)
	type ResponseArgs Client a ts = Proxy ts -> Proxy a -> ClientRequest
	type Response Client = ClientRequest
	response ::
	 forall a ts repr.
	 ResponseConstraint repr a ts =>
	 repr ~ Client =>
	 HTTP.Method ->
	 repr (ResponseArgs repr a ts)
	      (Response repr)
	response meth = Client $ \k Proxy Proxy -> k $ \req ->
		req
		 { clientReq_method = meth
		 , clientReq_accept =
			clientReq_accept req <>
			fromList (toList $ mediaTypes @ts @(MimeDecodable a))
		 }

instance HTTP_ResponseStream Client where
	type ResponseStreamConstraint Client as ts framing =
		MimeTypes ts (MimeDecodable (FramingYield as))
	type ResponseStreamArgs Client as ts framing =
		Proxy framing ->
		Proxy ts ->
		Proxy as ->
		ClientRequest
	type ResponseStream Client = ClientRequest
	
	responseStream ::
	 forall as ts framing repr.
	 ResponseStreamConstraint repr as ts framing =>
	 repr ~ Client =>
	 HTTP.Method ->
	 repr (ResponseStreamArgs repr as ts framing)
	      (ResponseStream repr)
	responseStream meth = Client $ \k Proxy Proxy Proxy -> k $ \req ->
		req
		 { clientReq_method = meth
		 , clientReq_accept =
			clientReq_accept req <>
			fromList (toList $ mediaTypes @ts @(MimeDecodable (FramingYield as)))
		 }

instance Web.ToHttpApiData BS.ByteString where
	toUrlPiece = Web.toUrlPiece . Text.decodeUtf8
	toHeader = id

-- * Type 'ClientConn'
-- | A monadic connection from a client to a server.
-- It is specialized in 'ClientConnection' and 'ClientConnectionStream'.
--
-- NOTE: no 'Monad' transformer is put within this newtype
-- to let @monad-classes@ handle all the |lift|ing.
newtype ClientConn m a
 =      ClientConn
 {    unClientConn :: m a
 } deriving (Functor, Applicative, Monad)
-- | All supported effects are handled by nested 'Monad's.
type instance MC.CanDo (ClientConn m) eff = 'False
instance MonadTrans ClientConn where
	lift = ClientConn

-- ** 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 String ClientResponse
     -- | The content-type of the response is not supported
 |   ClientError_UnsupportedContentType BS.ByteString ClientResponse
     -- | There was a connection error, and no response was received
 |   ClientError_ConnectionError Client.HttpException
     -- | 'ClientConn' 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
 {   clientReq_httpVersion :: HTTP.HttpVersion
 ,   clientReq_method      :: HTTP.Method
 ,   clientReq_path        :: BSB.Builder
 ,   clientReq_queryString :: Seq.Seq HTTP.QueryItem
 ,   clientReq_accept      :: Seq.Seq Media.MediaType
 ,   clientReq_headers     :: Seq.Seq HTTP.Header
 ,   clientReq_body        :: Maybe (Client.RequestBody, Media.MediaType)
 }
instance Show ClientRequest where
	show _ = "ClientRequest"

clientRequest :: URI -> ClientRequest -> Client.Request
clientRequest baseURI req =
	Client.defaultRequest
	 { Client.method         = clientReq_method 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 (clientReq_path req)
	 , Client.queryString    = HTTP.renderQuery True . toList $ clientReq_queryString 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 $ clientReq_headers req
	
	acceptHeader | null hs   = []
	             | otherwise = [("Accept", Media.renderHeader hs)]
		where
		hs = toList $ clientReq_accept req
	
	(requestBody, contentTypeHeader) =
		case clientReq_body req of
		 Nothing -> (Client.RequestBodyBS "", [])
		 Just (b, mt) -> (b, [(HTTP.hContentType, Media.renderHeader mt)])

-- ** Type 'ClientConnection'
type ClientConnection
 =   ClientConn (R.ReaderT ClientEnv (E.ExceptT ClientError IO))

{-
-- | Try clients in order, last error is preserved.
instance Alternative ClientConnection where
	empty = MC.throw $ ClientError_EmptyClient
	x <|> y = ClientConn $ do
		env <- MC.ask
		MC.exec @IO (E.runExceptT $ R.runReaderT (unClientConn x) env) >>= \case
		 Right xa -> return xa
		 Left _err -> unClientConn y
-}

runClient ::
 ClientConnectionConstraint a ts =>
 ClientConnectionClass a ts =>
 ClientEnv ->
 (Proxy ts -> Proxy a -> ClientRequest) ->
 IO (Either ClientError a)
runClient env =
	E.runExceptT .
	(`R.runReaderT` env) .
	unClientConn .
	clientConnection

-- ** Class 'ClientConnectionClass'
-- | 'clientConnection' is different when 'ts' is empty:
-- no 'mimeDecode' is performed.
-- This is used by the 'raw' combinator.
class ClientConnectionClass a (ts::[*]) where
	type ClientConnectionConstraint a ts :: Constraint
	clientConnection ::
	 ClientConnectionConstraint a ts =>
	 (Proxy ts -> Proxy a -> ClientRequest) ->
	 ClientConnection a
instance ClientConnectionClass ClientResponse '[] where
	type ClientConnectionConstraint ClientResponse '[] = ()
	clientConnection req = do
		clientRes <- doClientRequest $ req
		 (Proxy::Proxy '[])
		 (Proxy::Proxy ClientResponse)
		return clientRes
instance ClientConnectionClass a (t ': ts) where
	type ClientConnectionConstraint a (t ': ts) =
	 MimeTypes (t ': ts) (MimeDecodable a)
	clientConnection req = do
		clientRes <- doClientRequest $ req (Proxy::Proxy (t ': ts)) (Proxy::Proxy a)
		let mtRes =
			fromMaybe "application/octet-stream" $
			List.lookup "Content-Type" $
			Client.responseHeaders clientRes
		case matchContent @(t ': ts) @(MimeDecodable a) mtRes of
		 Nothing -> MC.throw $ ClientError_UnsupportedContentType mtRes clientRes
		 Just (MimeType mt) ->
			case mimeDecode mt $ Client.responseBody clientRes of
			 Left err -> MC.throw $ ClientError_DecodeFailure err clientRes
			 Right a -> return a

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 ->
			MC.exec @IO $ 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 <-
		MC.exec @IO $ catchClientConnectionError $
		Client.httpLbs req clientEnv_manager
	case lrRes of
		Left err -> MC.throw err
		Right res -> do
			for_ clientEnv_cookieJar $ \cj ->
				MC.exec @IO $ do
					now <- Time.getCurrentTime
					STM.atomically $ STM.modifyTVar' cj (fst . Client.updateCookieJar res req now)
			let code = HTTP.statusCode $ Client.responseStatus res
			unless (code >= 200 && code < 300) $
				MC.throw $ ClientError_FailureResponse res
			return res

catchClientConnectionError :: IO a -> IO (Either ClientError a)
catchClientConnectionError ma =
	Exn.catch (Right <$> ma) $ \err ->
		return $ Left $ ClientError_ConnectionError err

-- *** Type 'ClientResponse'
type ClientResponse
 =   Client.Response BSL.ByteString

-- ** Type 'ClientConnectionStream'
type ClientConnectionStream
 =   ClientConn (R.ReaderT ClientEnv (Codensity (E.ExceptT ClientError IO)))

runClientStream ::
 FramingDecode framing as =>
 MC.MonadExec IO (FramingMonad as) =>
 MimeTypes ts (MimeDecodable (FramingYield as)) =>
 ClientEnv ->
 (Proxy framing -> Proxy ts -> Proxy as -> ClientRequest) ->
 (as -> IO b) -> IO (Either ClientError b)
runClientStream env req k =
	E.runExceptT $
	(`runCodensity` lift . k) $
	(`R.runReaderT` env) $
	unClientConn $
	clientConnectionStream req

clientConnectionStream ::
 forall as ts framing.
 FramingDecode framing as =>
 MC.MonadExec IO (FramingMonad as) =>
 MimeTypes ts (MimeDecodable (FramingYield as)) =>
 (Proxy framing -> Proxy ts -> Proxy as -> ClientRequest) ->
 ClientConnectionStream as
clientConnectionStream req = do
	doClientRequestStream (Proxy::Proxy ts) (req Proxy Proxy Proxy) $ \(MimeType mt) clientRes ->
		return $
			framingDecode (Proxy @framing) (mimeDecode mt) $
				MC.exec @IO $ Client.responseBody clientRes

doClientRequestStream ::
 forall (ts::[*]) as.
 MimeTypes ts (MimeDecodable (FramingYield as)) =>
 Proxy ts ->
 ClientRequest ->
 ( MimeType (MimeDecodable (FramingYield as)) ->
   Client.Response Client.BodyReader ->
   E.ExceptT ClientError IO as ) ->
 ClientConnectionStream as
doClientRequestStream Proxy clientReq k = do
	ClientEnv{..} <- MC.ask
	let req = clientRequest clientEnv_baseURI $ clientReq
	ClientConn $ lift $ Codensity $ \k' ->
		E.ExceptT $ Client.withResponse req clientEnv_manager $ \res ->
			E.runExceptT $ do{-E.ExceptT ClientError IO-}
				-- Check status
				let code = HTTP.statusCode $ Client.responseStatus res
				unless (code >= 200 && code < 300) $ do
					err <- MC.exec @IO $ sequence $ (BSL.fromChunks <$>) . Client.brConsume <$> res
					E.throwE $ ClientError_FailureResponse err
				-- Check Content-Type header
				let contentTypeH =
					fromMaybe "application/octet-stream" $
					List.lookup "Content-Type" $
					Client.responseHeaders res
				case matchContent @ts @(MimeDecodable (FramingYield as)) contentTypeH of
				 Nothing -> do
					err <- MC.exec @IO $ sequence $ (BSL.fromChunks <$>) . Client.brConsume <$> res
					E.throwE $ ClientError_UnsupportedContentType contentTypeH err
				 Just ct -> k ct res >>= k'

-- *** Type 'Codensity'
-- | Copy from the @kan-extensions@ package to avoid the dependencies.
newtype Codensity m a
 =      Codensity
 {   runCodensity :: forall b. (a -> m b) -> m b }
type instance MC.CanDo (Codensity m) (MC.EffExec eff) = 'False
instance Functor (Codensity k) where
	fmap f (Codensity m) = Codensity (\k -> m (k .f))
	{-# INLINE fmap #-}
instance Applicative (Codensity f) where
	pure x = Codensity (\k -> k x)
	{-# INLINE pure #-}
	Codensity f <*> Codensity g = Codensity (\bfr -> f (\ab -> g (bfr . ab)))
	{-# INLINE (<*>) #-}
instance Monad (Codensity f) where
	return = pure
	{-# INLINE return #-}
	m >>= k = Codensity (\c -> runCodensity m (\a -> runCodensity (k a) c))
	{-# INLINE (>>=) #-}
instance MonadTrans Codensity where
	lift m = Codensity (m >>=)
	{-# INLINE lift #-}