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

-- import Network.HTTP.Media (MediaType, matches, parseAccept, (//))
-- import Servant.API (MimeUnrender, contentTypes, mimeUnrender)
import Data.Default.Class (Default(..))
import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..), unless)
import Control.Monad.Trans.Class (MonadTrans(..))
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Proxy (Proxy(..))
import Data.Foldable (null, for_, toList, any)
import Data.Function (($), (.))
import Data.Functor (Functor)
import Data.Maybe (Maybe(..), maybe)
import Data.Ord (Ord(..))
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 Language.Symantic.HTTP.Media
import Language.Symantic.HTTP.Mime
import Language.Symantic.HTTP.API
import Language.Symantic.HTTP.URI

-- * Type 'Client'
newtype Client a = Client { unClient :: R.ReaderT ClientEnv (E.ExceptT ClientError IO) a }
 deriving (Functor, Applicative, Monad)

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

type instance MC.CanDo Client (MC.EffReader ClientEnv)   = 'True
type instance MC.CanDo Client (MC.EffExcept ClientError) = 'True
type instance MC.CanDo Client (MC.EffExec   IO)          = 'True
instance MC.MonadExceptN 'MC.Zero ClientError Client where
	throwN px = Client . lift . MC.throwN px
instance MC.MonadReaderN 'MC.Zero ClientEnv Client where
	askN px = Client $ MC.askN px
instance MC.MonadExecN 'MC.Zero IO Client where
	execN _px = Client . lift . lift

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

-- ** 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 MediaType ClientResponse
  -- | The content-type header is invalid
  | ClientError_InvalidContentTypeHeader ClientResponse
  -- | There was a connection error, and no response was received
  | ClientError_ConnectionError Text
  deriving (Eq, Show{-, Generic, Typeable-})
instance Exn.Exception ClientError

-- * 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
	 }

clientRequest :: URI -> ClientRequest -> Client.Request
clientRequest uri req =
	Client.defaultRequest
	 { Client.method         = clientReqMethod req
	 , Client.host           = maybe "" (fromString . URI.uriRegName) $ URI.uriAuthority uri
	 , Client.port           = case URI.uriPort <$> URI.uriAuthority uri of
	                            Just (':':p) | Just port <- readMaybe p -> port
	                            _ -> 0
	 , Client.path           = BSL.toStrict $ fromString (URI.uriPath uri) <> BSB.toLazyByteString (clientReqPath req)
	 , Client.queryString    = HTTP.renderQuery True . toList $ clientReqQueryString req
	 , Client.requestHeaders = acceptHeader <> contentTypeHeader <> headers
	 , Client.requestBody
	 , Client.secure         = URI.uriScheme uri == "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)])

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

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

runClientRequest :: ClientRequest -> Client ClientResponse
runClientRequest clientReq = do
	ClientEnv{..} <- MC.ask
	let req = clientRequest clientEnv_uri clientReq
	request <- case clientEnv_cookieJar of
		Nothing -> pure req
		Just cj -> MC.exec $ 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 $ catchConnectionError $ Client.httpLbs request clientEnv_manager
	case lrRes of
		Left err -> MC.throw err
		Right res -> do
			for_ clientEnv_cookieJar $ \cj -> MC.exec $ do
				now <- Time.getCurrentTime
				STM.atomically $ STM.modifyTVar' cj (fst . Client.updateCookieJar res request now)
			let status_code = HTTP.statusCode $ Client.responseStatus res
			    ourResponse = clientResponse res
			unless (status_code >= 200 && status_code < 300) $
				MC.throw $ ClientError_FailureResponse ourResponse
			return ourResponse

catchConnectionError :: IO a -> IO (Either ClientError a)
catchConnectionError action =
	Exn.catch (Right <$> action) $ \err ->
		pure . Left . ClientError_ConnectionError .
		T.pack $ show (err :: Client.HttpException)

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

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




getContentType ::
 MC.MonadExcept ClientError m =>
 ClientResponse -> m MediaType
getContentType clientRes =
	case List.lookup "Content-Type" $ toList $ clientResHeaders clientRes of
	 Nothing -> return $ "application"Media.//"octet-stream"
	 Just mt ->
		case Media.parseAccept mt of
		 Nothing -> MC.throw $ ClientError_InvalidContentTypeHeader clientRes
		 Just mt' -> return mt'

mimeUnrenderResponse ::
 MimeUnrender mt a =>
 MC.MonadExcept ClientError m =>
 -- RunClient m =>
 ClientResponse -> Proxy mt -> m a
mimeUnrenderResponse clientRes mt = do
	mtRes <- getContentType clientRes
	unless (any (Media.matches mtRes) $ mediaTypes mt) $
		MC.throw $ ClientError_UnsupportedContentType mtRes clientRes
	case mimeUnrender mt $ clientResBody clientRes of
	 Left  err -> MC.throw $ ClientError_DecodeFailure (T.pack err) clientRes
	 Right val -> return val