--
-- Licensed to the Apache Software Foundation (ASF) under one
-- or more contributor license agreements. See the NOTICE file
-- distributed with this work for additional information
-- regarding copyright ownership. The ASF licenses this file
-- to you under the Apache License, Version 2.0 (the
-- "License"); you may not use this file except in compliance
-- with the License. You may obtain a copy of the License at
--
--   http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing,
-- software distributed under the License is distributed on an
-- "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
-- KIND, either express or implied. See the License for the
-- specific language governing permissions and limitations
-- under the License.
--

module Thrift.Transport.HttpClient
    ( module Thrift.Transport
    , HttpClient (..)
    , openHttpClient
    ) where

import Thrift.Transport
import Network.URI
import Network.HTTP hiding (port, host)
import Network.TCP

import Control.Monad (liftM)
import Data.Maybe (fromJust)
import Data.Monoid (mappend, mempty)
import Control.Exception (throw)
import Control.Concurrent.MVar
import qualified Data.Binary.Builder as B
import qualified Data.ByteString.Lazy.Char8 as LBS


-- | 'HttpClient', or THttpClient implements the Thrift Transport
-- | Layer over http or https.
data HttpClient =
    HttpClient {
      hstream :: HandleStream LBS.ByteString,
      uri :: URI,
      writeBuffer :: WriteBuffer,
      readBuffer :: ReadBuffer
    }

uriAuth = fromJust . uriAuthority
host = uriRegName . uriAuth

port :: URI -> Int
port uri =
    if portStr == mempty then
        httpPort
    else
        read portStr
    where
      portStr = dropWhile (== ':') $ uriPort $ uriAuth uri
      httpPort = 80

-- | Use 'openHttpClient' to create an HttpClient connected to @uri@
openHttpClient :: URI -> IO HttpClient
openHttpClient uri = do
  stream <- openTCPConnection (host uri) (port uri)
  wbuf <- newWriteBuffer
  rbuf <- newReadBuffer
  return $ HttpClient stream uri wbuf rbuf

instance Transport HttpClient where

    tClose  = close . hstream

    tRead hclient n = readBuf (readBuffer hclient) n

    tWrite hclient = writeBuf (writeBuffer hclient)

    tFlush hclient = do
      body <- flushBuf $ writeBuffer hclient
      let request = Request {
                      rqURI = uri hclient,
                      rqHeaders = [
                       mkHeader HdrContentType "application/x-thrift",
                       mkHeader HdrContentLength $  show $ LBS.length body],
                      rqMethod = POST,
                      rqBody = body
                    }

      res <- sendHTTP (hstream hclient) request
      case res of
        Right res -> do
            fillBuf (readBuffer hclient) (rspBody res)
        Left _ -> do
            throw $ TransportExn "THttpConnection: HTTP failure from server" TE_UNKNOWN
      return ()

    tIsOpen _ = return True
-- Mini IO buffers

type WriteBuffer = MVar (B.Builder)

newWriteBuffer :: IO WriteBuffer
newWriteBuffer = newMVar mempty

writeBuf :: WriteBuffer -> LBS.ByteString -> IO ()
writeBuf w s = modifyMVar_ w $ return . (\builder ->
                 builder `mappend` (B.fromLazyByteString s))

flushBuf :: WriteBuffer -> IO (LBS.ByteString)
flushBuf w = B.toLazyByteString `liftM` swapMVar w mempty


type ReadBuffer = MVar (LBS.ByteString)

newReadBuffer :: IO ReadBuffer
newReadBuffer = newMVar mempty

fillBuf :: ReadBuffer -> LBS.ByteString -> IO ()
fillBuf r s = swapMVar r s >> return ()

readBuf :: ReadBuffer -> Int -> IO (LBS.ByteString)
readBuf r n = modifyMVar r $ return . flipPair . LBS.splitAt (fromIntegral n)
    where flipPair (a, b) = (b, a)