ib-api-0.1.0.1: src/IB/Client/Request.hs
{-# LANGUAGE NamedFieldPuns #-}
module IB.Client.Request
(
-- * Types
Request(..)
-- * Functions
, request
, wFlush
, write
, appNull
, show'
, debugWrite
) where
import Control.Concurrent.MVar
import Control.Exception
import Control.Monad (when, unless)
import Text.Printf
import qualified System.IO as S
import qualified Data.ByteString.Char8 as B
import Data.Maybe
import IB.Client.Exception
import IB.Client.Nums
import IB.Client.Types
data ReqHeader =
ReqHeader
{ rqh_msgId :: Int
, rqh_proVer :: Int
, rqh_errId :: Int
, rqh_errMsg :: String
, rqh_minVer :: Maybe Int
, rqh_exAuth :: Maybe Bool
}
defReqHeader = ReqHeader 1 1 no_valid_id "" Nothing Nothing
(<++>) :: B.ByteString -> B.ByteString -> B.ByteString
a <++> b = a `B.append` nullch `B.append` b
debugWrite :: IBServer -> String -> IO ()
debugWrite s msg =
when (s_debug s) $ putStrLn msg
write :: IBServer -> B.ByteString -> IO ()
write s msg = do
debugWrite s $ "<< " ++ B.unpack msg
B.hPutStr h msg
where h = fromJust $ s_sock s
writeLst :: IBServer -> [B.ByteString] -> IO ()
writeLst s bsl =
do let outbs = (B.intercalate nullch bsl) `B.append` nullch
debugWrite s $ "<< " ++ B.unpack outbs
B.hPutStr h outbs
where h = fromJust $ s_sock s
wFlush :: IBServer -> IO ()
wFlush s = S.hFlush h
where h = fromJust $ s_sock s
show' :: Show a => a -> B.ByteString
show' = B.pack . show
nullch :: B.ByteString
nullch = B.pack "\0"
appNull :: B.ByteString -> B.ByteString
appNull bin = bin `B.append` nullch
encodeDbl :: Double -> B.ByteString
encodeDbl val = B.pack (printf "%.2f" val)
encodeIntMax :: Int -> B.ByteString
encodeIntMax val
| val == int32max = B.pack ""
| otherwise = show' val
encodeDblMax :: Double -> B.ByteString
encodeDblMax val
| val == dblMaximum = B.pack ""
| otherwise = encodeDbl val
encodeExecutionFilter :: ExecutionFilter -> B.ByteString
encodeExecutionFilter exf = appNull (show' ( exf_clientId exf)
<++> B.pack (exf_acctCode exf)
<++> B.pack ( exf_time exf)
<++> B.pack ( exf_symbol exf)
<++> B.pack ( exf_secType exf)
<++> B.pack ( exf_exchange exf)
<++> B.pack ( exf_side exf ))
encodeSubscription :: ScannerSubscription -> B.ByteString
encodeSubscription subs = appNull $ encodeIntMax ( ssb_numberOfRows subs)
<++> B.pack ( ssb_instrument subs)
<++> B.pack ( ssb_locationCode subs)
<++> B.pack ( ssb_scanCode subs)
<++> encodeDblMax ( ssb_abovePrice subs)
<++> encodeDblMax ( ssb_belowPrice subs)
<++> encodeIntMax ( ssb_aboveVolume subs)
<++> encodeDblMax ( ssb_marketCapAbove subs)
<++> encodeDblMax ( ssb_marketCapBelow subs)
<++> B.pack ( ssb_moodyRatingAbove subs)
<++> B.pack ( ssb_moodyRatingBelow subs)
<++> B.pack ( ssb_spRatingAbove subs)
<++> B.pack ( ssb_spRatingBelow subs)
<++> B.pack ( ssb_maturityDateAbove subs)
<++> B.pack ( ssb_maturityDateBelow subs)
<++> encodeDblMax ( ssb_couponRateAbove subs)
<++> encodeDblMax ( ssb_couponRateBelow subs)
<++> encodeIntMax ( ssb_excludeConvertible subs)
<++> encodeIntMax ( ssb_averageOptionVolumeAbove subs)
<++> B.pack ( ssb_scannerSettingPairs subs)
<++> B.pack ( ssb_stockTypeFilter subs)
encodeTagValue :: TagValue -> B.ByteString
encodeTagValue tv = B.pack $ tv_tag tv ++ "=" ++ tv_value tv ++ ";"
encodeTagValueList :: [TagValue] -> B.ByteString
encodeTagValueList tvl = B.concat $ map encodeTagValue tvl
encodeUnderComp :: UnderComp -> B.ByteString
encodeUnderComp uc = appNull $ show' 1 <++> show' ( uc_conId uc )
<++> show' ( uc_price uc)
encodeComboLeg :: ComboLeg -> B.ByteString
encodeComboLeg cl = appNull $ show' ( cl_conId cl)
<++> show' ( cl_ratio cl )
<++> B.pack ( cl_action cl )
<++> B.pack ( cl_exchange cl)
encodeComboLegList :: [ComboLeg] -> B.ByteString
encodeComboLegList cll = appNull $ show' ( length cll) <++> B.concat ( map encodeComboLeg cll )
encodeContract :: IBServer -> Contract -> Bool -> IO B.ByteString
encodeContract s con pexch =
do let serv_ver = s_version s
bs | serv_ver >= min_server_ver_trading_class = show' $ ct_conId con
| otherwise = B.empty
out = bs <++> B.pack ( ct_symbol con)
<++> B.pack ( ct_secType con)
<++> B.pack ( ct_expiry con)
<++> show' ( ct_strike con)
<++> B.pack ( ct_right con)
<++> B.pack ( ct_multiplier con)
<++> B.pack ( ct_exchange con)
out' | pexch = out <++> B.pack ( ct_primaryExchange con )
| otherwise = out
out'' = out' <++> B.pack ( ct_currency con)
<++> B.pack ( ct_localSymbol con)
if serv_ver >= min_server_ver_trading_class
then return $ appNull $ out'' <++> B.pack ( ct_tradingClass con)
else return $ appNull out''
getHeaderCon :: IBServer -> ReqHeader -> Contract -> IO B.ByteString
getHeaderCon s rqh con =
do let hndle = s_sock s
connected = s_connected s
serv_ver = s_version s
mExtraAuth = s_extraAuth s
case () of
_ | not connected -> throwIO $ IBExc (rqh_errId rqh) NotConnected ""
| (rqh_minVer rqh) /= Nothing ->
when ((serv_ver < fromJust (rqh_minVer rqh)) && not ( null ( ct_tradingClass con)) || ct_conId con > 0)
$ throwIO $ IBExc (rqh_errId rqh) UpdateTWS (rqh_errMsg rqh)
| otherwise -> return ()
return $ appNull $ show' ( rqh_msgId rqh) <++> show' ( rqh_proVer rqh)
getHeader :: IBServer -> ReqHeader -> IO B.ByteString
getHeader s rqh =
do let hndle = s_sock s
connected = s_connected s
serv_ver = s_version s
mExtraAuth = s_extraAuth s
case () of
_ | not connected -> throwIO $ IBExc (rqh_errId rqh) NotConnected ""
| (rqh_minVer rqh) /= Nothing -> when (serv_ver < fromJust (rqh_minVer rqh)) $ throwIO $ IBExc (rqh_errId rqh) UpdateTWS (rqh_errMsg rqh)
| (rqh_exAuth rqh) /= Nothing -> unless mExtraAuth $ throwIO $ IBExc no_valid_id UpdateTWS " Intent to authenticate needs to be expressed during initial connect request."
| otherwise -> return ()
return $ show' ( rqh_msgId rqh) <++> show' ( rqh_proVer rqh)
request :: IBServer -> Request -> IO ()
request s inp @ (MktDataReq { }) =
do let hndle = s_sock s
connected = s_connected s
serv_ver = s_version s
mExtraAuth = s_extraAuth s
ct = mdr_contract inp
tickerId = rqp_tickerId inp
version = 11
case () of
_ | not connected -> throwIO $ IBExc tickerId NotConnected ""
| serv_ver < min_server_ver_under_comp && (ct_underComp ct /= undefined) -> throwIO $ IBExc tickerId UpdateTWS " It does not support fundamental data requests."
| serv_ver < min_server_ver_req_mkt_data_conid && (ct_conId ct > 0) -> throwIO $ IBExc tickerId UpdateTWS " It does not support conId parameter."
| serv_ver < min_server_ver_trading_class && not ( null (ct_tradingClass ct)) -> throwIO $ IBExc tickerId UpdateTWS " It does not support tradingClass parameter in reqMktData."
| otherwise -> return ()
let bs = show' (reqToId inp)
<++> show' version
<++> show' tickerId
conbs | serv_ver >= min_server_ver_req_mkt_data_conid = show' $ ct_conId ct
| otherwise = B.empty
bs' = bs <++> conbs
<++> B.pack ( ct_symbol ct )
<++> B.pack ( ct_secType ct)
<++> B.pack ( ct_expiry ct)
<++> show' ( ct_strike ct)
<++> B.pack ( ct_right ct)
<++> B.pack ( ct_multiplier ct )
<++> B.pack ( ct_exchange ct)
<++> B.pack ( ct_primaryExchange ct)
<++> B.pack ( ct_currency ct)
<++> B.pack ( ct_localSymbol ct)
tclass | serv_ver >= min_server_ver_trading_class = (show' $ ct_tradingClass ct )
| otherwise = B.empty
clist | compare (ct_secType ct) "BAG" == EQ = encodeComboLegList (ct_comboLegsList ct)
| otherwise = B.empty
ucomp | serv_ver >= min_server_ver_under_comp && ct_underComp ct /= undefined = encodeUnderComp (ct_underComp ct)
| otherwise = show' 0
bs'' = bs'
<++> tclass
<++> clist
<++> ucomp
<++> B.pack ( mdr_genericTicks inp )
<++> show' ( fromBool ( mdr_snapshot inp))
if serv_ver >= min_server_ver_linking
then write s $ appNull $ bs'' <++> encodeTagValueList ( mdr_mktDataOptions inp)
else write s $ appNull bs''
wFlush s
request s rq @ (CancelMktData { rqp_tickerId = tid }) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_proVer = 2
, rqh_errId = tid
}
write s $ appNull $ hdr <++> show' tid
wFlush s
request s rq @ (PlaceOrder { rqp_orderId = oid }) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_proVer = 2
, rqh_errId = oid
}
write s $ appNull $ hdr <++> show' oid
wFlush s
-- TODO PlaceOrder Complete
request s rq @ (CancelOrder oid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_errId = oid
}
write s $ appNull $ hdr <++> show' oid
wFlush s
request s rq @ OpenOrdersReq = do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq }
write s hdr
wFlush s
request s rq @ (AccountUpdatesReq {aur_subscribe = subscribe, aur_acctCode = acctCode}) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_proVer = 2
}
write s $ appNull $ show' ( fromBool subscribe) <++> B.pack acctCode
wFlush s
request s rq @ (ExecutionsReq req_id exc_filt) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_proVer = 3
}
let serv_ver = s_version s
reqbs | serv_ver >= min_server_ver_execution_data_chain = show' req_id
| otherwise = B.empty
write s $ appNull $ hdr <++> reqbs <++> encodeExecutionFilter exc_filt
wFlush s
request s rq @ (IdsReq numIds) = do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq, rqh_errId = numIds }
write s $ appNull $ hdr <++> show' numIds
wFlush s
--TODO
--request s rq @ (ContractDetailsReq req_id contract) =
request s rq @ (MktDepthReq { rqp_tickerId = tid
, mkr_contract = con
, mkr_numRows = numRows
, mkr_mktDepthOptions = mkDepthOpts
}) =
do let serv_ver = s_version s
hdr <- getHeaderCon s defReqHeader { rqh_msgId = reqToId rq
, rqh_proVer = 5
, rqh_minVer = Just min_server_ver_trading_class
, rqh_errId = tid
, rqh_errMsg = " It does not support conId and tradingClass parameters in reqMktDepth."
} con
con' <- encodeContract s con False
write s $ appNull $ hdr <++> show' tid <++> con' <++> show' numRows
when (serv_ver >= min_server_ver_linking) $
write s $ appNull $ encodeTagValueList mkDepthOpts
wFlush s
request s rq @ (CancelMktDepth tid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq,
rqh_errId = tid}
write s $ appNull $ hdr <++> show' tid
wFlush s
request s rq @ (NewsBulletinsReq allMsgs) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq}
write s $ appNull $ hdr <++> show' ( fromBool allMsgs)
wFlush s
request s rq @ CancelNewsBulletins =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq }
write s $ appNull hdr
request s rq @ (SetServerLogLevel llvl) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq }
write s $ appNull $ hdr <++> show' llvl
wFlush s
request s rq @ (AutoOpenOrdersReq autoBind) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq }
write s $ appNull $ hdr <++> show' (fromBool autoBind)
wFlush s
request s rq @ AllOpenOrdersReq =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq }
write s $ appNull hdr
wFlush s
request s rq @ ManagedAcctsReq =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq }
write s $ appNull hdr
wFlush s
request s rq @ (FAReq fad) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq}
write s $ appNull $ hdr <++> show' ( fromEnum' fad)
request s rq @ (FAReplaceReq fad cxml) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq}
write s $ appNull $ hdr <++> show' (fromEnum' fad) <++> B.pack cxml
wFlush s
request s rq @ (HistoricalDataReq {rqp_tickerId = tid
, hdr_contract = con
, hdr_endDataTime = edt
, hdr_durationStr = durStr
, hdr_whatToShow = whatToShow
, hdr_formatDate = formatDate
, hdr_chartOptions = chartOptions
, hdr_useRTH = useRTH
, hdr_barSizeSetting = barSizeSetting
}) =
do let serv_ver = s_version s
hdr <- getHeaderCon s defReqHeader { rqh_msgId = reqToId rq
, rqh_proVer = 6
, rqh_errId = tid
, rqh_minVer = Just min_server_ver_trading_class
, rqh_errMsg = " It does not support conId and tradingClass parameters in reqHistoricalData."
} con
con' <- encodeContract s con True
write s $ appNull $ (hdr <++> show' tid)
<++> con'
<++> show' ( fromBool $ ct_includeExpired con )
<++> B.pack edt
<++> B.pack barSizeSetting
<++> B.pack durStr
<++> show' useRTH
<++> B.pack whatToShow
<++> show' formatDate
when (compare (ct_secType con) "BAG" == EQ) $
write s $ appNull $ encodeComboLegList (ct_comboLegsList con)
when (serv_ver >= min_server_ver_linking) $
write s $ appNull $ encodeTagValueList chartOptions
wFlush s
request s rq @ (ExerciseOptionsReq { rqp_tickerId = tid
, eor_contract = con
, eor_exerciseAction = exerciseAction
, eor_exerciseQuantity = exerciseQty
, eor_account = account
, eor_override = override
}) =
do let serv_ver = s_version s
hdr <- getHeaderCon s defReqHeader { rqh_msgId = reqToId rq
, rqh_proVer = 2
, rqh_errId = tid
, rqh_minVer = Just min_server_ver_trading_class
, rqh_errMsg = " It does not support conId and tradingClass parameters in reqHistoricalData."
} con
con' <- encodeContract s con False
write s $ appNull $ hdr <++> show' tid
<++> con'
<++> show' exerciseAction
<++> show' exerciseQty
<++> B.pack account
<++> show' override
wFlush s
request s rq @ (ScannerSubscriptionReq { rqp_tickerId = tid
, ssr_subscription = subs
, ssr_subscriptionOptions = subsOpts
}) =
do let serv_ver = s_version s
hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_proVer = 4
, rqh_errId = tid
}
write s $ appNull $ show' tid <++> encodeSubscription subs
when (serv_ver >= min_server_ver_linking) $
write s $ appNull $ encodeTagValueList subsOpts
wFlush s
request s rq @ (CancelScannerSubscription tid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_errId = tid
}
write s $ appNull $ hdr <++> show' tid
wFlush s
-- TODO: verify correctness
request s rq @ ScannerParametersReq =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq }
write s $ appNull hdr
wFlush s
request s rq @ (CancelHistoricalData tid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_errId = tid
}
write s $ appNull $ hdr <++> show' tid
wFlush s
request s rq @ CurrentTimeReq =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq }
write s $ appNull hdr
wFlush s
-- TODO needs dev
--
request s rq @ (RealTimeBarsReq {}) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq }
write s $ appNull hdr
wFlush s
request s rq @ (CancelRealTimeBars tid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_errId = tid }
write s $ appNull $ hdr <++> show' tid
wFlush s
request s rq @ (CancelFundamentalData tid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_errId = tid
, rqh_minVer = Just min_server_ver_fundamental_data
, rqh_errMsg = " It does not support fundamental data requests."
}
write s $ appNull $ hdr <++> show' tid
wFlush s
--TODO
--request s rq @ (CalcOptionPriceReq {}) =
request s rq @ (CancelCalcImpliedVolatility tid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_errId = tid
, rqh_minVer = Just min_server_ver_cancel_calc_implied_volat
, rqh_errMsg = " It does not support calculate implied volatility cancellation."
}
write s $ appNull $ hdr <++> show' tid
wFlush s
request s rq @ (CancelCalcOptionPrice tid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_errId = tid
, rqh_minVer = Just min_server_ver_cancel_calc_option_price
, rqh_errMsg = " It does not support calculate option price cancellation."
}
write s $ appNull $ hdr <++> show' tid
wFlush s
request s rq @ GlobalCancelReq =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_errMsg = " It does not support globalCancel requests."
, rqh_minVer = Just min_server_ver_req_global_cancel
}
write s $ appNull hdr
wFlush s
request s rq @ (MarketDataTypeReq tid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq}
write s $ appNull $ hdr <++> show' tid
wFlush s
request s rq @ PositionsReq =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq}
write s $ appNull hdr
wFlush s
--TODO
--request s rq @ (AccountSummaryReq {}) =
request s rq @ (CancelAccountSummary req_id) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_minVer = Just min_server_ver_account_summary
, rqh_errMsg = " It does not support account summary cancellation."
}
write s $ appNull hdr
wFlush s
request s rq @ CancelPositions =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_errMsg = " It does not support positions cancellation."
, rqh_minVer = Just min_server_ver_positions
}
write s $ appNull hdr
wFlush s
request s rq @ (VerifyReq apiName apiVersion) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_minVer = Just min_server_ver_linking
, rqh_errMsg = " It does not support verification message sending."
, rqh_exAuth = Just True
}
write s $ appNull $ hdr <++> B.pack apiName <++> B.pack apiVersion
wFlush s
request s rq @ (VerifyMessage apiData) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_minVer = Just min_server_ver_linking
, rqh_errMsg = " It does not support verification message sending."
}
write s $ appNull $ hdr <++> B.pack apiData
wFlush s
request s rq @ (QueryDisplayGroups rid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_minVer = Just min_server_ver_linking
, rqh_errMsg = " It does not support queryDisplayGroups request."
}
write s $ appNull $ hdr <++> show' rid
wFlush s
request s rq @ (SubscribeToGroupEvents reqId gid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_minVer = Just min_server_ver_linking
, rqh_errMsg = " It does not support subscribeToGroupEvents request."
}
write s $ appNull $ hdr <++> show' reqId
<++> show' gid
wFlush s
request s rq @ (UpdateDisplayGroup reqId contractInfo) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_minVer = Just min_server_ver_linking
, rqh_errMsg = " It does not support updateDisplayGroup request."
}
write s $ appNull $ hdr <++> show' reqId
<++> B.pack contractInfo
wFlush s
request s rq @ (UnsubscribeFromGroupEvents reqId) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_minVer = Just min_server_ver_linking
, rqh_errMsg = " It does not support unsubscribeFromGroupEvents request."
}
write s $ appNull $ hdr <++> show' reqId
wFlush s
request s rq @ StartApi =
do let clientId = s_clientId s
hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq }
write s $ appNull $ hdr <++> show' clientId
wFlush s