diff --git a/quik-connector.cabal b/quik-connector.cabal index 1784780..443f56a 100644 --- a/quik-connector.cabal +++ b/quik-connector.cabal @@ -18,13 +18,26 @@ library exposed-modules: Lib , QuoteSource.DDE , QuoteSource.DataImport + ghc-options: -Wincomplete-patterns build-depends: base >= 4.7 && < 5 , Win32 , gtk , binary + , data-binary-ieee754 , bytestring + , text + , Decimal + , time + , vector + , containers + , mtl + , datetime default-language: Haskell2010 extra-libraries: "user32" + other-modules: QuoteSource.XlParser + , QuoteSource.TableParser + , QuoteSource.TableParsers.AllParamsTableParser + , Data.ATrade executable quik-connector-exe hs-source-dirs: app diff --git a/src/Data/ATrade.hs b/src/Data/ATrade.hs new file mode 100644 index 0000000..2263628 --- /dev/null +++ b/src/Data/ATrade.hs @@ -0,0 +1,55 @@ + +module Data.ATrade ( + Tick(..), + DataType(..) +) where + +import Data.Decimal +import Data.Time.Clock + +data DataType = Unknown + | Price + | OpenInterest + | BestBid + | BestOffer + | Depth + | TheoryPrice + | Volatility + | TotalSupply + | TotalDemand + deriving (Show, Eq) + +instance Enum DataType where + fromEnum x + | x == Price = 1 + | x == OpenInterest = 3 + | x == BestBid = 4 + | x == BestOffer = 5 + | x == Depth = 6 + | x == TheoryPrice = 7 + | x == Volatility = 8 + | x == TotalSupply = 9 + | x == TotalDemand = 10 + | x == Unknown = -1 + | otherwise = -1 + + toEnum x + | x == 1 = Price + | x == 3 = OpenInterest + | x == 4 = BestBid + | x == 5 = BestOffer + | x == 6 = Depth + | x == 7 = TheoryPrice + | x == 8 = Volatility + | x == 9 = TotalSupply + | x == 10 = TotalDemand + | otherwise = Unknown + +data Tick = Tick { + security :: String, + datatype :: DataType, + timestamp :: UTCTime, + value :: Decimal, + volume :: Integer +} deriving (Show, Eq) + diff --git a/src/QuoteSource/DDE.hs b/src/QuoteSource/DDE.hs index a268ce4..c76d31d 100644 --- a/src/QuoteSource/DDE.hs +++ b/src/QuoteSource/DDE.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ForeignFunctionInterface, CPP #-} module QuoteSource.DDE ( initializeDde, @@ -11,9 +11,20 @@ module QuoteSource.DDE ( ddeXtypPoke, ddeCpWinAnsi, queryString, - nullDdeState + nullDdeState, + accessData, + unaccessData, + withDdeData ) where +#if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +#elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +#else +# error Unknown mingw32 arch +#endif + import Control.Applicative import Control.Exception import Control.Monad @@ -49,34 +60,34 @@ ddeCpWinAnsi = 1004 instance Exception DdeException -foreign import ccall unsafe "windows.h DdeInitializeW" +foreign import WINDOWS_CCONV unsafe "windows.h DdeInitializeW" ddeInitialize :: LPDWORD -> FunPtr DdeCallback -> DWORD -> DWORD -> IO CUInt -foreign import ccall unsafe "windows.h DdeUninitialize" +foreign import WINDOWS_CCONV unsafe "windows.h DdeUninitialize" ddeUninitialize :: DWORD -> IO BOOL -foreign import ccall unsafe "windows.h DdeCreateStringHandleW" +foreign import WINDOWS_CCONV unsafe "windows.h DdeCreateStringHandleW" ddeCreateStringHandle :: DWORD -> LPSTR -> CInt -> IO HANDLE -foreign import ccall unsafe "windows.h DdeFreeStringHandleW" +foreign import WINDOWS_CCONV unsafe "windows.h DdeFreeStringHandleW" ddeFreeStringHandle :: DWORD -> LPSTR -> IO HANDLE -foreign import ccall unsafe "windows.h DdeNameService" +foreign import WINDOWS_CCONV unsafe "windows.h DdeNameService" ddeNameService :: DWORD -> HANDLE -> HANDLE -> CInt -> IO HANDLE -foreign import ccall unsafe "windows.h DdeCmpStringHandles" +foreign import WINDOWS_CCONV unsafe "windows.h DdeCmpStringHandles" ddeCmpStringHandles :: HANDLE -> HANDLE -> IO CInt -foreign import ccall unsafe "windows.h DdeQueryStringW" +foreign import WINDOWS_CCONV unsafe "windows.h DdeQueryStringW" ddeQueryString :: DWORD -> HANDLE -> CString -> DWORD -> CInt -> IO DWORD -foreign import ccall unsafe "windows.h DdeAccessData" +foreign import WINDOWS_CCONV unsafe "windows.h DdeAccessData" ddeAccessData :: HANDLE -> LPDWORD -> IO (Ptr CUChar) -foreign import ccall unsafe "windows.h DdeUnaccessData" +foreign import WINDOWS_CCONV unsafe "windows.h DdeUnaccessData" ddeUnaccessData :: HANDLE -> IO () -foreign import ccall "wrapper" +foreign import WINDOWS_CCONV "wrapper" mkCallbackPtr :: DdeCallback -> IO (FunPtr DdeCallback) data DdeState = DdeState { @@ -124,6 +135,11 @@ accessData :: HANDLE -> IO ByteString accessData handle = alloca (\dataSizePtr -> do dataPtr <- ddeAccessData handle dataSizePtr dataSize <- peek dataSizePtr - pack . (map (toEnum . fromEnum)) <$> peekArray (fromEnum dataSize) dataPtr) + pack . map (toEnum . fromEnum) <$> peekArray (fromEnum dataSize) dataPtr) + +unaccessData :: HANDLE -> IO () +unaccessData = ddeUnaccessData +withDdeData :: HANDLE -> (ByteString -> IO a) -> IO a +withDdeData handle = bracket (accessData handle) (\_ -> unaccessData handle) diff --git a/src/QuoteSource/DataImport.hs b/src/QuoteSource/DataImport.hs index 7bb9a8a..6fbceec 100644 --- a/src/QuoteSource/DataImport.hs +++ b/src/QuoteSource/DataImport.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE ExistentialQuantification #-} -module QuoteSource.DataImport +module QuoteSource.DataImport ( initDataImportServer, ServerState @@ -14,22 +15,33 @@ import Foreign.C.String import QuoteSource.DDE import QuoteSource.XlParser +import QuoteSource.TableParser +import QuoteSource.TableParsers.AllParamsTableParser import Data.IORef import Text.Printf -import Data.Binary +import Data.Binary.Get +import Data.Time.Clock +import Control.Monad.State.Strict +import qualified Data.ByteString.Lazy as BL + +data TableParserInstance = forall a . TableParser a => MkTableParser a +instance TableParser TableParserInstance where + parseXlTable = parseXlTable + getTableId (MkTableParser a) = getTableId a + giveTimestampHint (MkTableParser a) t = MkTableParser (giveTimestampHint a t) + data ServerState = ServerState { dde :: DdeState, - appName :: String + appName :: String, + parser :: TableParserInstance } ddeCallback :: IORef ServerState -> CUInt -> CUInt -> HANDLE -> HANDLE -> HANDLE -> HANDLE -> LPDWORD -> LPDWORD -> IO HANDLE ddeCallback state msgType format hConv hsz1 hsz2 hData dwData1 dwData2 - | msgType == ddeXtypConnect = handleConnect state hsz1 hsz2 + | msgType == ddeXtypConnect = handleConnect state hsz1 hsz2 | msgType == ddeXtypPoke = handlePoke state hsz1 hData - | otherwise = do - putStrLn $ printf "msgtype: %08x" $ toInteger msgType - return nullHANDLE + | otherwise = return nullHANDLE where handleConnect state hsz1 hsz2 = do myAppName <- appName <$> readIORef state @@ -48,10 +60,22 @@ ddeCallback state msgType format hConv hsz1 hsz2 hData dwData1 dwData2 maybeTopic <- queryString myDdeState 256 hsz1 case maybeTopic of Nothing -> return ddeResultFalse + Just topic -> withDdeData hData (\xlData -> case runGetOrFail xlParser $ BL.fromStrict xlData of + Left (_, _, errmsg) -> return ddeResultFalse + Right (_, _, table) -> do + myParser <- parser <$> readIORef state + when (topic == getTableId myParser) $ do + timeHint <- getCurrentTime + modifyIORef state (\s -> s { parser = giveTimestampHint (parser s) timeHint }) + (MkTableParser myParser) <- parser <$> readIORef state + let (ticks, newState) = runState (parseXlTable table) myParser + modifyIORef state (\s -> s { parser = MkTableParser newState }) + return ddeResultAck) + initDataImportServer :: String -> IO (IORef ServerState) initDataImportServer applicationName = do - s <- newIORef ServerState { appName = applicationName, dde = nullDdeState } + s <- newIORef ServerState { appName = applicationName, dde = nullDdeState, parser = MkTableParser $ mkAllParamsTableParser "allparams" } d <- initializeDde applicationName "default" (ddeCallback s) modifyIORef s (\state -> state {dde = d}) putStrLn "DataImportServer initialized" diff --git a/src/QuoteSource/TableParser.hs b/src/QuoteSource/TableParser.hs index 224ea3b..d55b371 100644 --- a/src/QuoteSource/TableParser.hs +++ b/src/QuoteSource/TableParser.hs @@ -1,4 +1,15 @@ module QuoteSource.TableParser ( + TableParser(..) ) where +import QuoteSource.XlParser +import Data.ATrade +import Control.Monad.State.Strict +import Data.Time.Clock + +class TableParser a where + parseXlTable :: (Int, Int, [XlData]) -> State a [Tick] + giveTimestampHint :: a -> UTCTime -> a + getTableId :: a -> String + diff --git a/src/QuoteSource/TableParsers/AllParamsTableParser.hs b/src/QuoteSource/TableParsers/AllParamsTableParser.hs new file mode 100644 index 0000000..fa3f7ff --- /dev/null +++ b/src/QuoteSource/TableParsers/AllParamsTableParser.hs @@ -0,0 +1,178 @@ + +module QuoteSource.TableParsers.AllParamsTableParser ( + AllParamsTableParser, + mkAllParamsTableParser +) where + +import qualified Data.Map.Lazy as M +import QuoteSource.TableParser +import Data.ATrade +import QuoteSource.XlParser +import Data.Tuple +import Data.Decimal +import Control.Monad.State.Strict +import Data.Time.Clock +import Data.Maybe +import Data.DateTime + +data TableColumn = CUnknown + | CTicker + | CClassCode + | CPrice + | CBestBid + | CBestAsk + | CTotalSupply + | CTotalDemand + | COpenInterest + | CVolume + deriving (Eq, Show, Ord) + +columnCodes = M.fromList [ + ("CLASS_CODE", CClassCode), + ("CODE", CTicker), + ("bid", CBestBid), + ("offer", CBestAsk), + ("last", CPrice), + ("numcontracts", COpenInterest), + ("biddepth", CTotalDemand), + ("offerdepth", CTotalSupply), + ("voltoday", CVolume)] + +columnToDataType :: TableColumn -> DataType +columnToDataType x + | x == CPrice = Price + | x == CBestBid = BestBid + | x == CBestAsk = BestOffer + | x == CTotalSupply = TotalSupply + | x == CTotalDemand = TotalDemand + | x == COpenInterest = OpenInterest + | otherwise = Unknown + + +type TableSchema = M.Map TableColumn Int + +data AllParamsTableParser = AllParamsTableParser { + schema :: Maybe TableSchema, + tableId :: String, + volumes :: M.Map String Integer, + timestampHint :: UTCTime +} + +mkAllParamsTableParser id = AllParamsTableParser { + schema = Nothing, + tableId = id, + volumes = M.empty, + timestampHint = startOfTime } + +securityName :: String -> String -> String +securityName classCode ticker = classCode ++ ('#' : ticker) + +parseSchema (width, height, cells) = M.fromList . zipWith (curry swap) [0..] $ map parseSchemaItem . take width $ cells + where + parseSchemaItem cell = case cell of + XlString s -> M.findWithDefault CUnknown s columnCodes + _ -> CUnknown + +safeAt :: [a] -> Int -> Maybe a +safeAt list index = if index < 0 || index >= length list + then Nothing + else Just $ list !! index + +parseWithSchema :: TableSchema -> (Int, Int, [XlData]) -> State AllParamsTableParser [Tick] +parseWithSchema sch (width, height, cells) = do + ticks <- mapM parseRow $ groupByN width $ cells + return $ concat ticks + where + parseRow :: [XlData] -> State AllParamsTableParser [Tick] + parseRow row = case (getClassCode row, getTicker row) of + (Just classCode, Just ticker) -> do + maybeticks <- mapM (\f -> f row classCode ticker) parsers + return $ catMaybes maybeticks + _ -> return [] + + parsers :: [[XlData] -> String -> String -> State AllParamsTableParser (Maybe Tick)] + parsers = parsePrice : map parseValue [CBestBid, CBestAsk, COpenInterest, CTotalDemand, CTotalSupply] + + parseValue :: TableColumn -> [XlData] -> String -> String -> State AllParamsTableParser (Maybe Tick) + parseValue columnType row classCode ticker = case M.lookup columnType sch of + Nothing -> return Nothing + Just index -> case row `safeAt` index of + Just (XlDouble value) -> do + ts <- gets timestampHint + return $ Just Tick { + security = securityName classCode ticker, + datatype = columnToDataType columnType, + timestamp = ts, + value = realFracToDecimal 10 value, + volume = 0 } + _ -> return Nothing + + parsePrice :: [XlData] -> String -> String -> State AllParamsTableParser (Maybe Tick) + parsePrice row classCode ticker = case M.lookup CPrice sch of + Nothing -> return Nothing + Just index -> case row `safeAt` index of + Just (XlDouble value) -> do + tickVolume <- calculateTickVolume row $ securityName classCode ticker + if tickVolume > 0 + then do + ts <- gets timestampHint + return $ Just Tick { + security = securityName classCode ticker, + datatype = Price, + timestamp = ts, + value = realFracToDecimal 10 value, + volume = tickVolume} + else + return Nothing + _ -> return Nothing + + calculateTickVolume :: [XlData] -> String -> State AllParamsTableParser Integer + calculateTickVolume row secname = case M.lookup CVolume sch of + Nothing -> return 1 + Just index -> case row `safeAt` index of + Just (XlDouble volume) -> do + oldVolumes <- gets volumes + let intVolume = round volume + case M.lookup secname oldVolumes of + Nothing -> do + modify (\s -> s { volumes = M.insert secname intVolume oldVolumes } ) + return 1 + Just oldVolume -> do + modify (\s -> s { volumes = M.insert secname intVolume oldVolumes } ) + return $ if intVolume > oldVolume + then intVolume - oldVolume + else if intVolume < oldVolume + then 1 + else 0 + _ -> return 0 + + groupByN :: Int -> [a] -> [[a]] + groupByN n l = case l of + [] -> [] + _ -> take n l : groupByN n (drop n l) + + getStringField :: TableColumn -> [XlData] -> Maybe String + getStringField columnType row = case M.lookup columnType sch of + Nothing -> Nothing + Just index -> case row `safeAt` index of + Just (XlString s) -> Just s + _ -> Nothing + + getClassCode :: [XlData] -> Maybe String + getClassCode = getStringField CClassCode + + getTicker :: [XlData] -> Maybe String + getTicker = getStringField CTicker + +instance TableParser AllParamsTableParser where + parseXlTable table = do + mySchema <- gets schema + case mySchema of + Just sch -> parseWithSchema sch table + Nothing -> do + modify (\s -> s { schema = Just $ parseSchema table }) + parseWithSchema (parseSchema table) table + + getTableId = tableId + giveTimestampHint tp hint = tp { timestampHint = hint } + diff --git a/src/QuoteSource/XlParser.hs b/src/QuoteSource/XlParser.hs index 7f025b0..c51a713 100644 --- a/src/QuoteSource/XlParser.hs +++ b/src/QuoteSource/XlParser.hs @@ -7,9 +7,15 @@ module QuoteSource.XlParser ( import Control.Applicative import Control.Monad import Data.Binary.Get -import Data.ByteString +import Data.Binary.IEEE754 +import Data.ByteString hiding (concat, unpack) +import Data.List as L +import Data.Word +import Data.Text as T hiding (concat) +import Data.Text.Encoding data XlData = XlInt Int | XlDouble Double | XlString String | XlEmpty + deriving (Eq, Show) data XlPosition = XlPosition { width :: Int, height :: Int, xPos :: Int, yPos :: Int } @@ -20,20 +26,61 @@ btBlank = 5 btInt = 6 btSkip = 7 -incrementPosition :: XlPosition -> Maybe XlPosition -incrementPosition pos = do - if 1 + xPos pos < width pos - then Just pos { xPos = 1 + xPos pos } - else if 1 + yPos pos < height pos - then Just pos { xPos = 0, yPos = 1 + yPos pos } - else Nothing - xlParser :: Get (Int, Int, [XlData]) xlParser = do datatype <- getWord16le when (datatype /= btTable) $ fail "First entry should be table" blocksize <- fromEnum <$> getWord16le when (blocksize /= 4) $ fail "Table entry should have size 4" - return (0, 0, []) + height <- getWord16le + width <- getWord16le + table <- parseTable + return (fromEnum width, fromEnum height, table) + where + parseTable :: Get [XlData] + parseTable = concat <$> parseTable' + + parseTable' :: Get [[XlData]] + parseTable' = do + eof <- isEmpty + if eof + then return [] + else do + cells <- parseEntry + rest <- parseTable' + return $ cells : rest + + parseEntry :: Get [XlData] + parseEntry = do + datatype <- getWord16le + blocksize <- fromEnum <$> getWord16le + parseEntry' datatype blocksize + + parseEntry' :: Word16 -> Int -> Get [XlData] + parseEntry' datatype blocksize + | datatype == btFloat = parseFloats blocksize + | datatype == btString = parseStrings blocksize + | datatype == btBlank = parseBlanks blocksize + | otherwise = fail $ "Unknown field type: " ++ show datatype + + parseFloats blocksize = do + float <- getFloat64le + if blocksize - 8 <= 0 + then return [XlDouble float] + else do + rest <- parseFloats (blocksize - 8) + return $ XlDouble float : rest + + parseStrings blocksize = do + length <- fromEnum <$> getWord8 + s <- unpack . decodeUtf8 <$> getByteString length + if length + 1 >= blocksize + then return [XlString s] + else do + rest <- parseStrings (blocksize - length - 1) + return $ XlString s : rest + parseBlanks blocksize = do + fields <- fromEnum <$> getWord16le + return $ L.replicate fields XlEmpty diff --git a/stack.yaml b/stack.yaml index 7c0743d..7f5354b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -39,7 +39,7 @@ packages: - '.' # Dependency packages to be pulled from upstream that are not in the resolver # (e.g., acme-missiles-0.3) -extra-deps: [ "fltkhs-0.4.0.9"] +extra-deps: [ "datetime-0.3.1"] # Override default flag values for local packages and extra-deps flags: {}