{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

module API.Btce (
    -- * Feed
    feed
    -- * Trading Proxies
    , session
    , BtceSession
    , send
    , cancelOrders
    )
    where

---------------------------------------------------------------------------------------------------
import Pipes 
---------------------------------------------------------------------------------------------------
import Control.Monad ( (>=>), forM_, mzero, liftM, unless)
---------------------------------------------------------------------------------------------------
import Debug.Trace
import Data.Char ( isDigit )
import Data.List ( isPrefixOf )
import Data.IORef
import Data.Aeson ( (.:) )
import Codec.Digest.SHA ( hmac, Length( SHA512 ) )
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy.Char8 as LC
import qualified Blaze.ByteString.Builder as Builder
import qualified Data.Aeson as A
import Data.BtcExchanges
---------------------------------------------------------------------------------------------------
import Network.Http.Client hiding (put, get)
import Network.HTTP.Base ( urlEncodeVars )
---------------------------------------------------------------------------------------------------
import OpenSSL (withOpenSSL)
---------------------------------------------------------------------------------------------------
import qualified System.IO.Streams as Streams
{-import qualified System.IO.Streams.Debug as D-}
---------------------------------------------------------------------------------------------------
import qualified Data.Btce as B
---------------------------------------------------------------------------------------------------
import API.BtcExchanges.Internal
import qualified Numeric

feed :: CurrencyPair -> Producer BC.ByteString IO ()
feed c = httpFeed "btc-e.com" 443 (BC.pack $ "/api/2/" ++ show c ++ "/depth") 1

newtype BtceSession = BtceSession (B.BtceKey, B.BtceSecret, IORef Int)

newtype JSONResponse = W { unwrap :: Either B.BtceError B.BtceResponse }
instance A.FromJSON JSONResponse where
    parseJSON (A.Object v) = do
        s <- v .: "success" 
        if s == (0 :: Int)
           then liftM (W . Left)  $ v .: "error" 
           else liftM (W . Right) $ v .: "return"
    parseJSON _ = mzero

session :: B.BtceKey -> B.BtceSecret -> IO BtceSession
session k s = do
       n <- newIORef 0

       let sess = BtceSession (k, s, n)

       -- get next nonce parameter and store it in btce session:
       --  send dummy request with nonce == 0 then server will reply with an
       --  error message and next expected nonce value.
       err <-  send sess B.GetInfo
       unless (isRight' err) $
          let nextN = fromLeft' extract err
           in maybe (fail $ "can not extract nonce from " ++ fromLeft' Prelude.id err) (writeIORef n) nextN

       return sess

       where
         -- try to extract the next expected nonce parameter from servers error
         -- message.
         extract :: String -> Maybe Int
         extract = go
            where
              go [] = Nothing
              go e' = let expect = "on key:" in
                      if expect `isPrefixOf` e' 
                    then Just $ read $ takeWhile isDigit $ drop (length expect) e'
                    else go $ tail e'

         isRight' (Left _)  = False
         isRight' (Right _) = True

         fromLeft' f (Left a)  = f a
         fromLeft' _ (Right _) = fail "fromLeft' on a right value"

send :: BtceSession -> B.BtceRequest -> IO (Either B.BtceError B.BtceResponse)
send s req = let 
            BtceSession (key, secret, nonce) = s

            encodeAndSign' :: Int -> B.BtceRequest -> (BC.ByteString, BC.ByteString)
            encodeAndSign' n r = 
                let b  = urlEncodeVars $ ("nonce", show n) : encode' r
                    s' = BC.pack secret
                in (BC.pack b, hmac SHA512 s' $ BC.pack b)

               where 

                encode' B.GetInfo          = newReq "getInfo"     []
                encode' (B.CancelOrder o)  = newReq "CancelOrder" [("order_id", show o)]
                encode' (B.Trade pa t p v) = newReq "Trade"       [pair pa, ttype t, rate p, amount v]
                encode' (B.GetActiveOrders pa) = newReq "ActiveOrders" $ maybe [] (aSingle.pair) pa

                newReq t ps = ("method", t) : ps
                aSingle x   = [x]
                pair pa   = ("pair", show pa)
                ttype t   = ("type", show t)
                rate p    = ("rate", showFloat' p)
                amount v  = ("amount", showFloat' v)

                showFloat' f = Numeric.showFFloat Nothing (normalize f) ""
                normalize f = (fromInteger . round $ f * (10^8)) / (10.0^8)

#if MIN_VERSION_base(4,6,0)
#else
            -- |Strict version of 'modifyIORef'
            modifyIORef' :: IORef a -> (a -> a) -> IO ()
            modifyIORef' ref f = do
                x <- readIORef ref
                let x' = f x
                x' `seq` writeIORef ref x'

            -- |/O(1)/ Convert a strict 'ByteString' into a lazy 'ByteString'.
            fromStrict :: BC.ByteString -> LC.ByteString
            fromStrict bs | S.null bs = Empty
                          | otherwise = Chunk bs Empty
#endif

        in 
        withOpenSSL $ do 
           let btceDomain = "btc-e.com"
               btcePort   = 443 

           ctx <- baselineContextSSL
           c <- openConnectionSSL ctx btceDomain btcePort

           -- get the next nonce parameter
           n <- modifyIORef' nonce (+ 1) >> readIORef nonce

           let (b, sign) = encodeAndSign' n req
              
           req' <- buildRequest $ do
              http POST "/tapi"
              setContentType "application/x-www-form-urlencoded"
              setHeader "Key" $ BC.pack key
              setHeader "Sign" sign

           trace (show b) $ sendRequest c req' (Streams.write (Just $ Builder.fromByteString b))
           m <- receiveResponse c (\_ i -> Streams.read i)

           let extractResponse m' = unwrap =<< A.eitherDecode (LC.fromStrict m')
           return $ maybe (Left "no response") extractResponse m

cancelOrders :: BtceSession -> IO ()
cancelOrders s = do
    let send' r = fmap (either ignoreNoOrders id) $ send s r
        orderID (B.BtceBookEntry o _ _ _ _ _ _) = o

    (B.ActiveOrders os) <- send' $ B.GetActiveOrders Nothing
    forM_ (map orderID os) $ send s . B.CancelOrder >=> ignoreErrs

    where
        ignoreErrs _ = return ()
        anError e    = error $ "Request to Btce failed. Reason: " ++ show e
        ignoreNoOrders e = if e == "no orders" then B.ActiveOrders [] else anError e
