{-# 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.Maybe (Maybe(..), maybe, fromMaybe)
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import Data.Text (Text)
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 as Text
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 arguments 'requests' (one per number of alternative routes)
-- separated by (':!:').
--
-- 'Client' is analogous to a printf using a format customized for HTTP routing.
newtype Client requests k
 =      Client
 {    unClient :: (ClientModifier -> k) -> requests
 }

-- | @'client' requests@ returns the 'ClientRequest'
-- builders from the given API.
client :: Client requests ClientRequest -> requests
client (Client requests) = requests ($ 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_BasicAuth Client where
        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 m = Client $ \k Proxy Proxy -> k $ \req ->
                req
                 { clientReq_method = m
                 , 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 m = Client $ \k Proxy Proxy Proxy -> k $ \req ->
                req
                 { clientReq_method = m
                 , 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 Text 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 ::
 MimeTypes ts (MimeDecodable a) =>
 ClientEnv ->
 (Proxy ts -> Proxy a -> ClientRequest) ->
 IO (Either ClientError a)
runClient env =
        E.runExceptT .
        (`R.runReaderT` env) .
        unClientConn .
        clientConnection

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)
        let mtRes =
                fromMaybe "application/octet-stream" $
                List.lookup "Content-Type" $
                Client.responseHeaders clientRes
        case matchContent @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 (Text.pack err) clientRes
                 Right val -> return val

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