module IB.Client.Request
(
Request(..)
, request
, wFlush
, write
, show'
, debugWrite
) where
import Control.Concurrent.MVar
import Control.Exception
import Control.Monad (when)
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 :: Int
, rqh_exAuth :: Bool
}
defReqHeader = ReqHeader 1 1 no_valid_id "" undefined undefined
(<++>) :: B.ByteString -> B.ByteString -> B.ByteString
a <++> b = a `B.append` nullch `B.append` b `B.append` nullch
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 <++> B.pack "\0")
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"
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 = (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 = (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 = show' 1 <++> (show' $ uc_conId uc )
<++> (show' $ uc_price uc)
encodeComboLeg :: ComboLeg -> B.ByteString
encodeComboLeg cl = (show' $ cl_conId cl)
<++> (show' $ cl_ratio cl )
<++> (B.pack $ cl_action cl )
<++> (B.pack $ cl_exchange cl)
encodeComboLegList :: [ComboLeg] -> B.ByteString
encodeComboLegList cll = (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 $ out'' <++> (B.pack $ ct_tradingClass con)
else return 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 /= undefined ->
if ((serv_ver < (rqh_minVer rqh)) && ((not $ null ( ct_tradingClass con)) || (ct_conId con) > 0))
then throwIO $ IBExc (rqh_errId rqh) UpdateTWS (rqh_errMsg rqh)
else return ()
return $ (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 /= undefined -> if (serv_ver < rqh_minVer rqh) then throwIO $ IBExc (rqh_errId rqh) UpdateTWS (rqh_errMsg rqh)
else return ()
| rqh_exAuth rqh /= undefined -> if (not mExtraAuth) then throwIO $ IBExc (no_valid_id) UpdateTWS " Intent to authenticate needs to be expressed during initial connect request."
else 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 MktDataReq {}))
<++> (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 $ bs'' <++> ( encodeTagValueList $ mdr_mktDataOptions inp)
else write s 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 $ 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 $ hdr <++> show' oid
wFlush s
request s rq @ (CancelOrder oid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_errId = oid
}
write s $ 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 $ (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 $ 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 $ hdr <++> show' numIds
wFlush s
--TODO
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 = 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 $ hdr <++> (show' tid) <++> con' <++> (show' numRows)
if (serv_ver >= min_server_ver_linking)
then write s $ encodeTagValueList mkDepthOpts
else return ()
wFlush s
request s rq @ (CancelMktDepth tid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq,
rqh_errId = tid}
write s $ hdr <++> show' tid
wFlush s
request s rq @ (NewsBulletinsReq allMsgs) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq}
write s $ hdr <++> show' ( fromBool allMsgs)
wFlush s
request s rq @ (CancelNewsBulletins) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq }
write s hdr
request s rq @ (SetServerLogLevel llvl) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq }
write s $ hdr <++> show' llvl
wFlush s
request s rq @ (AutoOpenOrdersReq autoBind) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq }
write s $ hdr <++> show' (fromBool autoBind)
wFlush s
request s rq @ (AllOpenOrdersReq) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq }
write s hdr
wFlush s
request s rq @ (ManagedAcctsReq) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq }
write s hdr
wFlush s
request s rq @ (FAReq fad) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq}
write s $ hdr <++> show' ( fromEnum' fad)
request s rq @ (FAReplaceReq fad cxml) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq}
write s $ 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 = 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 $ (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)
if (compare (ct_secType con) "BAG" == EQ)
then write s $ encodeComboLegList (ct_comboLegsList con)
else return ()
if (serv_ver >= min_server_ver_linking)
then write s $ encodeTagValueList chartOptions
else return ()
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 = 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 $ 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 $ show' tid <++> encodeSubscription subs
if (serv_ver >= min_server_ver_linking)
then write s $ encodeTagValueList subsOpts
else return ()
wFlush s
request s rq @ (CancelScannerSubscription tid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_errId = tid
}
write s $ hdr <++> show' tid
wFlush s
request s rq @ (ScannerParametersReq) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq }
write s $ hdr
wFlush s
request s rq @ (CancelHistoricalData tid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_errId = tid
}
write s $ hdr <++> show' tid
wFlush s
request s rq @ (CurrentTimeReq) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq }
write s hdr
wFlush s
request s rq @ (RealTimeBarsReq {}) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq }
write s hdr
wFlush s
request s rq @ (CancelRealTimeBars tid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_errId = tid }
write s $ hdr <++> show' tid
wFlush s
request s rq @ (CancelFundamentalData tid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_errId = tid
, rqh_minVer = min_server_ver_fundamental_data
, rqh_errMsg = " It does not support fundamental data requests."
}
write s $ hdr <++> show' tid
wFlush s
--TODO
request s rq @ (CancelCalcImpliedVolatility tid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_errId = tid
, rqh_minVer = min_server_ver_cancel_calc_implied_volat
, rqh_errMsg = " It does not support calculate implied volatility cancellation."
}
write s $ hdr <++> show' tid
wFlush s
request s rq @ (CancelCalcOptionPrice tid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_errId = tid
, rqh_minVer = min_server_ver_cancel_calc_option_price
, rqh_errMsg = " It does not support calculate option price cancellation."
}
write s $ 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 = min_server_ver_req_global_cancel
}
write s $ hdr
wFlush s
request s rq @ (MarketDataTypeReq tid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq}
write s $ hdr <++> show' tid
wFlush s
request s rq @ (PositionsReq) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq}
write s $ hdr
wFlush s
--TODO
request s rq @ (CancelAccountSummary req_id) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_minVer = min_server_ver_account_summary
, rqh_errMsg = " It does not support account summary cancellation."
}
write s $ 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 = min_server_ver_positions
}
write s $ hdr
wFlush s
request s rq @ (VerifyReq apiName apiVersion) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_minVer = min_server_ver_linking
, rqh_errMsg = " It does not support verification message sending."
, rqh_exAuth = True
}
write s $ 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 = min_server_ver_linking
, rqh_errMsg = " It does not support verification message sending."
}
write s $ hdr <++> B.pack apiData
wFlush s
request s rq @ (QueryDisplayGroups rid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_minVer = min_server_ver_linking
, rqh_errMsg = " It does not support queryDisplayGroups request."
}
write s $ hdr <++> show' rid
wFlush s
request s rq @ (SubscribeToGroupEvents reqId gid) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_minVer = min_server_ver_linking
, rqh_errMsg = " It does not support subscribeToGroupEvents request."
}
write s $ hdr <++> show' reqId
<++> show' gid
wFlush s
request s rq @ (UpdateDisplayGroup reqId contractInfo) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_minVer = min_server_ver_linking
, rqh_errMsg = " It does not support updateDisplayGroup request."
}
write s $ show' reqId
<++> B.pack contractInfo
wFlush s
request s rq @ (UnsubscribeFromGroupEvents reqId) =
do hdr <- getHeader s defReqHeader { rqh_msgId = reqToId rq
, rqh_minVer = min_server_ver_linking
, rqh_errMsg = " It does not support unsubscribeFromGroupEvents request."
}
write s $ 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 $ hdr <++> show' clientId
wFlush s