Current paramters table parser

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

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)
+

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)
 

src/QuoteSource/DataImport.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ExistentialQuantification #-}
 
 module QuoteSource.DataImport
 (
@@ -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 == 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"

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
+  

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 }
+

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
 

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: {}