├── .gitignore ├── GenerateFIX.hs ├── LICENSE ├── README.md ├── alphaheavy-quickfix.cabal ├── cbits ├── QuickFIXThunks.cpp └── QuickFIXThunks.h ├── spec └── IB.xml └── src └── AlphaHeavy ├── FIX.hs ├── FIX └── FIX42 │ ├── Factory.hs │ └── Types.hs ├── QuickFIX.hs └── QuickFIX ├── Foreign.hs ├── GReceive.hs ├── GSend.hs ├── GetMessageField.hs ├── SetMessageField.hs └── Types.hs /.gitignore: -------------------------------------------------------------------------------- 1 | # vim related 2 | *.swo 3 | *.swp 4 | *~ 5 | 6 | # GHC build goo 7 | dist/ 8 | docs/ 9 | out/ 10 | *.dump-* 11 | *.hi 12 | *.hi-boot 13 | *.lo 14 | *.o 15 | *.o-boot 16 | *.p_hi 17 | *.p_o 18 | 19 | # GHC profiling files 20 | .hpc/ 21 | *.hcr 22 | *.hp 23 | *.prof 24 | 25 | # GHC stub files 26 | *_stub.c 27 | *_stub.h 28 | 29 | # OSX symbol packages 30 | *.dSYM/ 31 | 32 | #OS X 33 | .DS_Store 34 | -------------------------------------------------------------------------------- /GenerateFIX.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 3 | 4 | module Main (main) where 5 | 6 | import Control.Applicative 7 | import Control.Monad 8 | import Data.Char (toLower) 9 | import Data.Map (Map) 10 | import Data.List (intercalate, partition, stripPrefix, sortBy) 11 | import qualified Data.Map as Map 12 | import Data.Maybe 13 | import Debug.Trace (trace) 14 | import Text.XML.Expat.Proc 15 | import Text.XML.Expat.Tree hiding (QName) 16 | import qualified Data.ByteString as B 17 | import Language.Haskell.Exts 18 | import System.Environment (getArgs) 19 | 20 | type Required = Bool 21 | 22 | data FIXType 23 | = FIXAmount 24 | | FIXBoolean 25 | | FIXChar 26 | | FIXCountry 27 | | FIXCurrency 28 | | FIXData 29 | | FIXDayOfMonth 30 | | FIXExchange 31 | | FIXFloat 32 | | FIXGroup String 33 | | FIXInt 34 | | FIXLength 35 | | FIXLocalMktDate 36 | | FIXMonthYear 37 | | FIXMultiValueString 38 | | FIXNumInGroup 39 | | FIXPercentage 40 | | FIXPrice 41 | | FIXPriceOffset 42 | | FIXQuantity 43 | | FIXString 44 | | FIXUTCDate 45 | | FIXUTCDateOnly 46 | | FIXUTCTimeOnly 47 | | FIXUTCTimeStamp 48 | | FIXEnum String FIXType [(ValueEnum, Description)] 49 | deriving (Show,Eq) 50 | 51 | instance Read FIXType where 52 | readsPrec _ s = case map toLower s of 53 | " char" -> [(FIXChar, "")] 54 | "amt" -> [(FIXAmount, "")] 55 | "boolean" -> [(FIXBoolean, "")] 56 | "char" -> [(FIXChar, "")] 57 | "country" -> [(FIXCountry, "")] 58 | "currency" -> [(FIXCurrency, "")] 59 | "data" -> [(FIXData, "")] 60 | "dayofmonth" -> [(FIXDayOfMonth, "")] 61 | "exchange" -> [(FIXExchange, "")] 62 | "float" -> [(FIXFloat, "")] 63 | "int" -> [(FIXInt, "")] 64 | "length" -> [(FIXLength, "")] 65 | "localmktdate" -> [(FIXLocalMktDate, "")] 66 | "monthyear" -> [(FIXMonthYear, "")] 67 | "multiplevaluestring" -> [(FIXMultiValueString, "")] 68 | "numingroup" -> [(FIXNumInGroup, "")] 69 | "percentage" -> [(FIXPercentage, "")] 70 | "price" -> [(FIXPrice, "")] 71 | "priceoffset" -> [(FIXPriceOffset, "")] 72 | "qty" -> [(FIXQuantity, "")] 73 | "quantity" -> [(FIXQuantity, "")] 74 | "seqnum" -> [(FIXInt, "")] 75 | "string" -> [(FIXString, "")] 76 | "utcdate" -> [(FIXUTCDate, "")] 77 | "utcdateonly" -> [(FIXUTCDateOnly, "")] 78 | "utctimeonly" -> [(FIXUTCTimeOnly, "")] 79 | "utctimestamp" -> [(FIXUTCTimeStamp, "")] 80 | x -> trace ("unhandled: "++x) undefined 81 | 82 | data ValueEnum 83 | = ValueChar Char 84 | | ValueBool Bool 85 | | ValueString String 86 | | ValueInt Int 87 | deriving (Read,Show,Eq) 88 | 89 | type Description = String 90 | 91 | data Field 92 | = Field {fieldID :: Int, fieldName :: String, requiredField :: Required, fieldType :: FIXType} 93 | | Group {fieldID :: Int, fieldName :: String, requiredField :: Required, fields :: [(Field, Required)]} 94 | deriving (Eq,Show) 95 | 96 | isEnumField :: Field -> Bool 97 | isEnumField Field{fieldType = FIXEnum{}} = True 98 | isEnumField _ = False 99 | 100 | fieldTyQName (field@Field{}, _) 101 | | isEnumField field = Qual (ModuleName "AlphaHeavy.FIX") $ Ident "Enumeration" 102 | | otherwise = Qual (ModuleName "AlphaHeavy.FIX") $ Ident "Field" 103 | fieldTyQName (field@Group{}, _) = Qual (ModuleName "AlphaHeavy.FIX") $ Ident "Group" 104 | 105 | data Message = Message 106 | { messageType :: Char 107 | , messageName :: String 108 | , messageCategory :: String 109 | , messageFields :: [(Field, Required)] 110 | } deriving (Show) 111 | 112 | data Header = Header [(Field, Required)] deriving (Show) 113 | data Trailer = Trailer [(Field, Required)] deriving (Show) 114 | data Components = Components deriving (Show) 115 | 116 | type Messages = [Message] 117 | type Fields = [Field] 118 | 119 | data FIX = FIX Header Messages Trailer Components Fields deriving (Show) 120 | 121 | parseReqdField :: (String -> Field) -> Node String String -> (Field, Required) 122 | parseReqdField fieldMap (Element "field" attr _) = (field, reqd') 123 | where Just name = lookup "name" attr 124 | Just reqd = lookup "required" attr 125 | reqd' = case reqd of "Y" -> True; _ -> False 126 | field = (fieldMap name) {requiredField = reqd'} 127 | 128 | parseReqdFields :: (String -> Field) -> Node String String -> [(Field, Required)] 129 | parseReqdFields fieldMap node = map p'fld fields 130 | where fields = findChildren "field" node 131 | p'fld = parseReqdField fieldMap 132 | 133 | parseHeader :: (String -> Field) -> Node String String -> Header 134 | parseHeader fieldMap header@(Element "header" _ _) = 135 | Header $ parseReqdFields fieldMap header 136 | 137 | parseTrailer :: (String -> Field) -> Node String String -> Trailer 138 | parseTrailer fieldMap trailer@(Element "trailer" _ _) = 139 | Trailer $ parseReqdFields fieldMap trailer 140 | 141 | parseFIXEnum :: FIXType -> String -> ValueEnum 142 | parseFIXEnum ty str = case ty of 143 | FIXBoolean -> case str of "Y" -> ValueBool True; "N" -> ValueBool False 144 | FIXChar -> ValueChar $ head str 145 | FIXInt -> ValueInt $ read str 146 | FIXString -> ValueString str 147 | FIXMultiValueString -> ValueString str 148 | FIXNumInGroup -> ValueInt $ read str 149 | _ -> ValueString $ "unknown: (" ++ show ty ++ ") " ++ show str 150 | 151 | parseField :: Node String String -> Field 152 | parseField node@(Element "field" attr _) = Field num name False (ty' children) 153 | where Just num = liftM read $ lookup "number" attr 154 | Just name = lookup "name" attr 155 | Just ty = liftM read $ lookup "type" attr 156 | children = findChildren "value" node 157 | ty' [] = ty 158 | ty' _ = FIXEnum name ty values 159 | values = map typedVals $ findChildren "value" node 160 | typedVals (Element "value" attr2 _) = (parseFIXEnum ty enum, description) 161 | where Just enum = lookup "enum" attr2 162 | Just description = lookup "description" attr2 163 | 164 | parseGroup :: (String -> Field) -> String -> Node String String -> (Field, Required) 165 | parseGroup fieldMap msgName node@(Element "group" attr _) = (group, reqd') 166 | where group = Group fieldID groupName reqd' fields 167 | fields = parseReqdFields fieldMap node 168 | Field{fieldID} = fieldMap name 169 | Just name = lookup "name" attr 170 | name' = case stripPrefix "No" name of Just str -> str; _ -> name 171 | groupName = msgName ++ name' 172 | Just reqd = lookup "required" attr 173 | reqd' = case reqd of "Y" -> True; _ -> False 174 | 175 | parseGroups :: (String -> Field) -> String -> Node String String -> [(Field, Required)] 176 | parseGroups fieldMap msgName node = map (parseGroup fieldMap msgName) groups 177 | where groups = findChildren "group" node 178 | 179 | parseMessage :: (String -> Field) -> Node String String -> Maybe Message 180 | parseMessage fieldMap msg@(Element "message" attr _) = fmap (\ ty' -> Message ty' name cat merged) ty 181 | where ty = case lookup "msgtype" attr of 182 | Just [val] -> Just val 183 | Just val -> trace ("unsupported multichar message type: "++name) Nothing 184 | Nothing -> trace ("malformed record: "++show msg) Nothing 185 | Just name = lookup "name" attr 186 | Just cat = lookup "msgcat" attr 187 | fields = sortBy fieldSort $ parseReqdFields fieldMap msg 188 | groups = parseGroups fieldMap name msg 189 | merged = fields ++ groups 190 | fieldSort (_, True) (_, False) = LT 191 | fieldSort (_, False) (_, True) = GT 192 | fieldSort (f1, _) (f2, _) = compare (fieldQName f1 True) (fieldQName f2 True) 193 | 194 | parseFIXDocument :: Node String String -> FIX 195 | parseFIXDocument root@(Element "fix" _ _) = FIX header messages' trailer components fields' 196 | where Just header = liftM (parseHeader fieldLookup) $ findChild "header" root 197 | Just trailer = liftM (parseTrailer fieldLookup) $ findChild "trailer" root 198 | Just messages = findChild "messages" root 199 | messages' = catMaybes $ map (parseMessage fieldLookup) $ findChildren "message" messages 200 | components = Components 201 | Just fields = findChild "fields" root 202 | fields' = map parseField $ findChildren "field" fields 203 | fieldMap = Map.fromList $ map fieldMapVal fields' 204 | fieldMapVal f = (fieldName f, f) 205 | fieldLookup name 206 | | Just val <- Map.lookup name fieldMap = val 207 | | otherwise = error $ "Missing field for " ++ name 208 | 209 | typeNat :: Int -> QName 210 | typeNat = UnQual . Ident . show 211 | 212 | strongFIXTyCon :: Field -> Type 213 | strongFIXTyCon f@Field{fieldID, requiredField} = 214 | let fieldTy = foldl1 TyApp [TyCon fieldQN, TyCon (typeNat fieldID), TyCon (strongFIXQName f)] 215 | fieldQN 216 | | isEnumField f = Qual (ModuleName "AlphaHeavy.FIX") $ Ident "Enumeration" 217 | | otherwise = Qual (ModuleName "AlphaHeavy.FIX") $ Ident "Field" 218 | optField 219 | | requiredField = id 220 | | otherwise = TyApp (TyCon (Qual (ModuleName "Prelude") (Ident "Maybe"))) 221 | in optField fieldTy 222 | 223 | strongFIXTyCon Group{fieldID, fieldName} = 224 | let fieldQN = Qual (ModuleName "AlphaHeavy.FIX") $ Ident "Group" 225 | in foldl1 TyApp [TyCon fieldQN, TyCon (typeNat fieldID), TyCon (UnQual (Ident fieldName))] 226 | 227 | strongFIXQName :: Field -> QName 228 | strongFIXQName = UnQual . Ident . ty 229 | where ty field = case fieldType field of 230 | FIXGroup str -> str 231 | -- FIXEnum name FIXMultiValueString _ -> "[" ++ name ++ "]" 232 | FIXEnum name _ _ -> name 233 | FIXPrice -> "Price" 234 | FIXQuantity -> "Quantity" 235 | _ -> fieldName field 236 | 237 | weakFIXTyCon :: FIXType -> Type 238 | weakFIXTyCon = TyCon . UnQual . baseFIXName 239 | 240 | isPrimitiveTy :: FIXType -> Bool 241 | isPrimitiveTy tyEnum = case tyEnum of 242 | FIXGroup _ -> False 243 | FIXEnum _ _ _ -> False 244 | _ -> True 245 | 246 | baseFIXName :: FIXType -> Name 247 | baseFIXName tyEnum = Ident $ case tyEnum of 248 | FIXAmount -> "Decimal" 249 | FIXBoolean -> "Bool" 250 | FIXChar -> "Char" 251 | FIXCountry -> "String" 252 | FIXCurrency -> "Currency" 253 | FIXData -> "Data.ByteString.ByteString" 254 | FIXDayOfMonth -> "DayOfMonth" 255 | FIXEnum name _ _ -> name 256 | FIXExchange -> "Exchange" 257 | FIXFloat -> "Double" 258 | FIXGroup str -> str 259 | FIXInt -> "Int" 260 | FIXLength -> "Int" 261 | FIXLocalMktDate -> "MarketLocalTime" 262 | FIXMonthYear -> "MonthYear" 263 | FIXMultiValueString -> "String" 264 | FIXNumInGroup -> "Int" 265 | FIXPercentage -> "Double" 266 | FIXPrice -> "Price" 267 | FIXPriceOffset -> "Decimal" 268 | FIXQuantity -> "Quantity" 269 | FIXString -> "String" 270 | FIXUTCDate -> "UTCDate" 271 | FIXUTCDateOnly -> "UTCDate" 272 | FIXUTCTimeOnly -> "UTCTime" 273 | FIXUTCTimeStamp -> "UTCTimeStamp" 274 | x -> trace ("undefined: "++show x) undefined 275 | 276 | camel :: String -> String 277 | camel (x:xs) = toLower x:xs 278 | camel [] = [] 279 | 280 | maybeFIXTyCon :: Field -> Type 281 | maybeFIXTyCon fty = (strongFIXTyCon fty) 282 | 283 | {-unbangedMaybeFIXTyCon :: Field -> BangType 284 | unbangedMaybeFIXTyCon = BangedTy . maybeFIXTyCon-} 285 | 286 | fieldType' :: (Field, Required) -> (Name, Type) 287 | fieldType' field = case field of 288 | (f@Field{}, required) -> (name, ty required f) 289 | ((Group _ groupName _ _), _) -> (name, grp $ FIXGroup groupName) 290 | where grp fty = TyList $ weakFIXTyCon fty 291 | ty True fty = TyCon $ strongFIXQName fty 292 | ty False fty = maybeFIXTyCon fty 293 | name = uncurry fieldQName field 294 | 295 | fieldQName :: Field -> Required -> Name 296 | fieldQName field required = Ident qname 297 | where name = fieldName field 298 | qname = if required 299 | then camel name 300 | else "opt" ++ name 301 | 302 | recordDecl :: Message -> ConDecl 303 | recordDecl (Message _ name _ fields) = ConDecl ident args 304 | where ident = Ident name 305 | args = map x fields 306 | grp fty = strongFIXTyCon fty 307 | ty True fty = strongFIXTyCon fty 308 | ty False fty = maybeFIXTyCon fty 309 | x (g@Group{}, _) = grp g 310 | x (f@Field{}, reqd)= ty reqd f 311 | 312 | generateMessageConDecl :: Message -> QualConDecl 313 | generateMessageConDecl msg = QualConDecl srcLoc tyVarBind context ctor 314 | where tyVarBind = [] 315 | context = [] 316 | ctor = recordDecl msg 317 | 318 | generateMessageDecl :: Message -> Decl 319 | generateMessageDecl msg@(Message _ name _ _) = decl where 320 | decl = DataDecl srcLoc DataType context name' tyVarBind decls derived 321 | decls = [generateMessageConDecl msg] 322 | name' = Ident name 323 | context = [] 324 | tyVarBind = [] 325 | derived = map ((\v -> (v, [])) . UnQual . Ident) ["Generic","Show","Eq"] 326 | 327 | generateLensInstDecl :: Message -> [Decl] 328 | generateLensInstDecl msg@(Message _ name _ fields) = decls where 329 | decls = concatMap decl fields 330 | context = [] 331 | className (Field{fieldName}, reqd) = UnQual (Ident (fieldName ++ (if reqd then "Lens" else "MaybeLens"))) 332 | lensName (Field{fieldName}, True) = Ident (camel fieldName) 333 | lensName (Field{fieldName}, False) = Ident ("opt" ++ fieldName) 334 | -- className (Group{fieldName}, _) = UnQual (Ident (fieldName ++ "Lens")) 335 | decl field@(Field{}, _) = [InstDecl srcLoc context (className field) [TyCon (UnQual (Ident name))] [InsDecl (FunBind [lens field])]] 336 | decl (Group{}, _) = [] 337 | lens field = Match srcLoc (lensName field) [] Nothing (rhs field) (binds field) 338 | unqual = Var . UnQual . Ident 339 | rhs _ = UnGuardedRhs (foldl1 App [Var (Qual (ModuleName "Control.Lens") (Ident "lens")), unqual "g", unqual "s"]) 340 | binds field = BDecls [FunBind (getter field), FunBind [setter field]] 341 | getter field@(_, True) = [getterReqMatch field] 342 | getter field@(_, False) = [getterReqMatch field, getterOptMatch field] 343 | getterReqMatch field = Match srcLoc (Ident "g") [getterLhs field] Nothing (UnGuardedRhs (getterRhs field)) (BDecls []) 344 | getterOptMatch field = Match srcLoc (Ident "g") [PWildCard] Nothing (UnGuardedRhs (Con (UnQual (Ident ("Nothing"))))) (BDecls []) 345 | getterLhs field = PApp (UnQual (Ident name)) (fieldGetter field) 346 | fieldGetter field@(_, True) = map (\ x -> if x /= field then PWildCard else (PApp (fieldTyQName field) [PVar (Ident "x")])) fields 347 | fieldGetter field@(_, False) = map (\ x -> if x /= field then PWildCard else (PApp (UnQual (Ident "Just")) [PApp (fieldTyQName field) [PVar (Ident "x")]])) fields 348 | getterRhs field@(_, True) = Var (UnQual (Ident ("x"))) 349 | getterRhs field@(_, False) = App (Con (UnQual (Ident ("Just")))) (Var (UnQual (Ident ("x")))) 350 | 351 | setter field = Match srcLoc (Ident "s") [setterLhsFields field, setterLhs field] Nothing (UnGuardedRhs (setterRhs field)) (BDecls []) 352 | setterLhs field = PApp (UnQual (Ident "val")) [] 353 | setterLhsFields field@(f, _) = PApp (UnQual . Ident $ name) $ zipWith (\ x y -> if x == field then PWildCard else PVar . Ident $ ("_x" ++ show y)) fields [1..] 354 | reqVal field = foldr1 App [Con (fieldTyQName field), Var . UnQual . Ident $ "val"] 355 | -- optVal field = App (Con . UnQual . Ident $ "fmap") (reqVal field) 356 | optVal field = foldl1 App [Var (UnQual (Ident "fmap")), Con (fieldTyQName field), Var . UnQual . Ident $ "val"] 357 | setterRhsFields field@(f, True) = foldl1 App ((Con . UnQual . Ident $ name):zipWith (\ x y -> if x == field then reqVal field else Var . UnQual . Ident $ ("_x" ++ show y)) fields [1..]) 358 | setterRhsFields field@(f, False) = foldl1 App ((Con . UnQual . Ident $ name):zipWith (\ x y -> if x == field then optVal field else Var . UnQual . Ident $ ("_x" ++ show y)) fields [1..]) 359 | -- setterRhs field@(_, True) = setterRhsFields field 360 | -- setterRhs field@(_, False) = App (Con . UnQual . Ident $ "Just") (setterRhsFields field) 361 | setterRhs field = setterRhsFields field 362 | 363 | srcLoc :: SrcLoc 364 | srcLoc = SrcLoc {srcFilename = "foo.hs", srcLine = 1, srcColumn = 1} 365 | 366 | generateMessagesDecl :: Messages -> [Decl] 367 | generateMessagesDecl msgs = concatMap decls msgs where 368 | decls f = generateMessageDecl f : generateLensInstDecl f 369 | 370 | groupDecl :: Field -> ConDecl 371 | groupDecl (Group _ name _ fields) = ConDecl ident args 372 | where ident = Ident name 373 | args = map x fields 374 | ty = BangedTy . strongFIXTyCon 375 | grp = BangedTy . weakFIXTyCon 376 | groupPrefix fieldName = camel name ++ fieldName 377 | x (f@Field{fieldName}, _) = ty f 378 | x (Group{fieldName}, _) = grp $ FIXGroup fieldName 379 | 380 | generateGroups :: Messages -> [Decl] 381 | generateGroups msgs = map (\ (name, group) -> DataDecl srcLoc DataType context name tyVarBind [group] derived) groups 382 | where fields = concat [map fst fieldList | Message _ _ _ fieldList <- msgs] 383 | groups = [(Ident fieldName, decl $ groupDecl group) | group@Group{fieldName} <- fields] 384 | decl = QualConDecl srcLoc tyVarBind context 385 | context = [] 386 | tyVarBind = [] 387 | derived = map ((\v -> (v, [])) . UnQual . Ident) ["Generic","Show","Eq"] 388 | 389 | generateFieldEnum' :: Field -> [Decl] 390 | generateFieldEnum' field = [generateFieldEnum field, generateFieldTag field] 391 | 392 | generateFieldEnum :: Field -> Decl 393 | generateFieldEnum (Field _ name _ (FIXEnum _ ty enums)) = DataDecl srcLoc DataType context (Ident name) tyVarBind decls derived 394 | where decls = map decl enums ++ unspecified 395 | decl enum = QualConDecl srcLoc tyVarBind context $ ConDecl ctorName [] 396 | where ctorName = Ident $ name ++ "_" ++ snd enum 397 | unspecified = [] 398 | context = [] 399 | tyVarBind = [] 400 | derived = map ((\v -> (v, [])) . UnQual . Ident) ["Read","Show","Eq"] 401 | 402 | valueEnumToPat :: ValueEnum -> Pat 403 | valueEnumToPat ve = case ve of 404 | ValueChar char -> PLit $ Char char 405 | ValueBool bool -> PApp (UnQual . Ident $ show bool) [] 406 | ValueString str -> PLit $ String str 407 | ValueInt int -> PLit . Int $ fromIntegral int 408 | 409 | valueEnumToLit :: ValueEnum -> Exp 410 | valueEnumToLit ve = case ve of 411 | ValueChar char -> Lit $ Char char 412 | ValueBool bool -> Con (UnQual . Ident $ show bool) 413 | ValueString str -> Lit $ String str 414 | ValueInt int -> Lit . Int $ fromIntegral int 415 | 416 | {- 417 | instance FieldTag ExecType where 418 | type FieldTagRep ExecType = Char 419 | toFieldTagRep :: a -> FieldTagRep a 420 | fromFieldTagRep :: FieldTagRep a -> Maybe a 421 | -} 422 | 423 | generateFieldTag :: Field -> Decl 424 | generateFieldTag (Field _ name _ (FIXEnum _ ty enums)) = decl where 425 | decl = InstDecl srcLoc context className [tyCon] decls 426 | tyCon = TyCon . UnQual $ Ident name 427 | context = [] 428 | className = Qual (ModuleName "AlphaHeavy.FIX") (Ident "FieldTag") 429 | decls = [repDecl, InsDecl toDecl, InsDecl fromDecl] 430 | repDecl = InsType srcLoc (TyApp (TyCon (UnQual (Ident "FieldTagRep"))) tyCon) (TyCon (UnQual (baseFIXName ty))) 431 | toDecl = FunBind $ map toMatch enums 432 | toMatch (e, d) = Match srcLoc (Ident "toFieldTagRep") [PApp (enumDesc d) []] Nothing (UnGuardedRhs (valueEnumToLit e)) (BDecls []) 433 | fromMatch (e, d) = Match srcLoc (Ident "fromFieldTagRep") [valueEnumToPat e] Nothing (UnGuardedRhs (App (Con (UnQual (Ident "Just"))) (Con (enumDesc d)))) (BDecls []) 434 | noMatch 435 | | FIXBoolean <- ty = [] 436 | | otherwise = [Match srcLoc (Ident "fromFieldTagRep") [PWildCard] Nothing (UnGuardedRhs (Con (UnQual (Ident "Nothing")))) (BDecls [])] 437 | fromDecl = FunBind $ map fromMatch enums ++ noMatch 438 | enumDesc d = UnQual . Ident $ name ++ "_" ++ d 439 | 440 | newImport :: String -> Bool -> ImportDecl 441 | newImport mod qualified = ImportDecl{ 442 | importLoc = srcLoc, 443 | importModule = ModuleName mod, 444 | importQualified = qualified, 445 | importSrc = False, 446 | importPkg = Nothing, 447 | importAs = Nothing, 448 | importSpecs = Nothing} 449 | 450 | qualifiedImport :: String -> ImportDecl 451 | qualifiedImport mod = newImport mod True 452 | 453 | unqualifiedImport :: String -> ImportDecl 454 | unqualifiedImport mod = newImport mod False 455 | 456 | generateNewTypeDecl :: Field -> [Decl] 457 | generateNewTypeDecl field = case (fieldType field) of 458 | FIXPrice -> [] 459 | FIXQuantity -> [] 460 | _ -> [newTypeDecl] 461 | where newTypeDecl = DataDecl srcLoc NewType context name tyVarBind decls derived 462 | decls = [QualConDecl srcLoc tyVarBind context (ConDecl name [BangedTy baseTyCon])] 463 | name = Ident $ fieldName field 464 | context = [] 465 | tyVarBind = [] 466 | baseTyCon = TyCon $ UnQual $ baseFIXName $ fieldType field 467 | derived = map ((\v -> (v, [])) . UnQual . Ident) (defTyCls ++ baseTyCls) 468 | defTyCls = ["Generic","Show","Eq"] 469 | intTyCls = ["Num","Ord","Real","Enum","Integral"] 470 | decTyCls = ["Num","Ord","Real"] 471 | baseTyCls = case fieldType field of 472 | FIXInt -> intTyCls 473 | FIXAmount -> decTyCls 474 | FIXQuantity -> decTyCls 475 | FIXFloat -> ["Enum","Floating","Fractional","Num","Ord","Real","RealFloat","RealFrac"] 476 | FIXPrice -> decTyCls 477 | FIXString -> ["Ord"] 478 | _ -> [] 479 | 480 | generateLensClassDecls :: [Field] -> [Decl] 481 | generateLensClassDecls fields = regular ++ optional where 482 | regular = map generateLensClassDecl fields 483 | optional = map generateMaybeLensClassDecl fields 484 | 485 | generateLensClassDecl :: Field -> Decl 486 | generateLensClassDecl field@Field{fieldName} = decl where 487 | decl = ClassDecl srcLoc context (Ident (fieldName ++ "Lens")) [varA] [] [lens] 488 | lens = ClsDecl $ TypeSig srcLoc [Ident (camel fieldName)] lensTy 489 | lensArr = TyCon (Qual (ModuleName "Control.Lens") (Ident "Lens'")) 490 | lensTy = foldl1 TyApp [lensArr, tyVarA, TyCon (strongFIXQName field)] -- UnQual (Ident fieldName))] 491 | varA = UnkindedVar (Ident "a") 492 | tyVarA = TyVar (Ident "a") 493 | context = [] 494 | 495 | generateMaybeLensClassDecl :: Field -> Decl 496 | generateMaybeLensClassDecl field@Field{fieldName} = decl where 497 | decl = ClassDecl srcLoc context (Ident (fieldName ++ "MaybeLens")) [varA] [] [lens] 498 | lens = ClsDecl $ TypeSig srcLoc [Ident ("opt" ++ fieldName)] lensTy 499 | lensArr = TyCon $ Qual (ModuleName "Control.Lens") (Ident "Lens'") 500 | lensTy = foldl1 TyApp [lensArr, tyVarA, TyApp (TyCon (UnQual (Ident "Maybe"))) (TyCon (strongFIXQName field))] -- UnQual (Ident fieldName))] 501 | varA = UnkindedVar (Ident "a") 502 | tyVarA = TyVar (Ident "a") 503 | context = [] 504 | 505 | generateMessageModule :: FIX -> String -> Module 506 | generateMessageModule (FIX _ messages _ _ fields) version = Module srcLoc modName pragmas warningText exports imports decls 507 | where modName = ModuleName $ "AlphaHeavy.FIX.FIX" ++ version ++ ".Types" 508 | pragmas = [LanguagePragma srcLoc $ Ident <$> ["DeriveGeneric", "DataKinds", "GeneralizedNewtypeDeriving", "TypeFamilies", "TypeOperators"]] 509 | warningText = Nothing 510 | exports = Nothing 511 | imports = [ qualifiedImport "Data.ByteString", qualifiedImport "Control.Lens" 512 | , unqualifiedImport "GHC.Generics", unqualifiedImport "AlphaHeavy.FIX"] 513 | groups = generateGroups messages 514 | fieldEnums = [i | i@(Field _ _ _ (FIXEnum _ _ (_:_))) <- fields] 515 | fields' = concatMap generateFieldEnum' fieldEnums 516 | decls = messagesDecl ++ groups ++ fields' ++ newTypes ++ lensDecl 517 | ignoreNames n = not (n `elem` ["Price", "Currency"]) 518 | newTypes = concat [generateNewTypeDecl f | f@Field{fieldName, fieldType} <- fields, isPrimitiveTy fieldType, ignoreNames fieldName] 519 | messagesDecl = generateMessagesDecl messages 520 | lensDecl = generateLensClassDecls fields 521 | 522 | generateMessageCtorDecl :: Message -> [Decl] 523 | generateMessageCtorDecl (Message _ msgName _ fields) = [TypeSig srcLoc [name] sig, FunBind [match]] 524 | where match = Match srcLoc name fieldVars Nothing msgCase binds 525 | sig = foldr1 TyFun $ requiredFieldTys ++ [unqMsgTy] 526 | unqTy = TyCon . UnQual . Ident 527 | unqMsgTy = unqTy msgName 528 | requiredFieldTys = map (snd . fieldType') required 529 | (required, _) = partition snd fields 530 | name = Ident $ camel msgName 531 | binds = BDecls [] 532 | msgCase = UnGuardedRhs $ foldl1 App (Var (UnQual (Ident msgName)):updates) 533 | fieldVars = map (PVar . fieldName) required 534 | update f@(_, True) = App (Con (fieldTyQName f)) (Var (fieldNameQ f)) 535 | -- requiredUpdates = map (requiredUpdate . fieldNameQ) required 536 | update (Group{}, False) = App (Con (UnQual (Ident "Group"))) (Con $ UnQual $ Ident "[]") 537 | update (Field{}, False) = (Con $ UnQual $ Ident "Nothing") 538 | updates = map update fields 539 | fieldName = fst . fieldType' 540 | fieldNameQ = UnQual . fieldName 541 | 542 | generateMessageFactories :: FIX -> String -> Module 543 | generateMessageFactories (FIX _ messages _ _ _) version = Module srcLoc modName pragmas warningText exports imports decls 544 | where modName = ModuleName $ "AlphaHeavy.FIX.FIX" ++ version ++ ".Factory" 545 | pragmas = [LanguagePragma srcLoc [Ident "MultiParamTypeClasses", Ident "FlexibleInstances"]] 546 | warningText = Nothing 547 | exports = Nothing 548 | imports = [ qualifiedImport "Data.ByteString" 549 | , unqualifiedImport "AlphaHeavy.FIX" 550 | , unqualifiedImport $ "AlphaHeavy.FIX.FIX" ++ version ++ ".Types" 551 | ] 552 | decls = concatMap generateMessageCtorDecl messages 553 | 554 | main :: IO () 555 | main = do 556 | args <- getArgs 557 | if length args /= 2 558 | then do putStrLn "Usage: GenerateFix FixPath Version" 559 | return () 560 | else do let path = args !! 0 561 | version = args !! 1 562 | source <- B.readFile path 563 | let Right root = parse' (defaultParseOptions :: ParseOptions String String) source 564 | tree = parseFIXDocument root 565 | types = generateMessageModule tree version 566 | factories = generateMessageFactories tree version 567 | ppr = prettyPrintStyleMode style defaultMode 568 | 569 | putStrLn (ppr types) 570 | writeFile ("./src/AlphaHeavy/FIX/FIX" ++ version ++ "/Types.hs") $ ppr types 571 | writeFile ("./src/AlphaHeavy/FIX/FIX" ++ version ++ "/Factory.hs") $ ppr factories 572 | return () 573 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Alpha Heavy Industries 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | - Redistributions of source code must retain the above copyright notice, 8 | this list of conditions and the following disclaimer. 9 | - Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | - Neither the names of the copyright owners nor the names of the 13 | contributors may be used to endorse or promote products derived 14 | from this software without specific prior written permission. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | A toolkit for building strongly-typed FIX messages and sending/receiving them with the QuickFIX C++ engine. 2 | -------------------------------------------------------------------------------- /alphaheavy-quickfix.cabal: -------------------------------------------------------------------------------- 1 | Name: alphaheavy-quickfix 2 | Version: 0.1 3 | License: BSD3 4 | License-File: LICENSE 5 | Build-type: Simple 6 | 7 | Cabal-version: >= 1.10 8 | 9 | Library 10 | Default-Language: Haskell2010 11 | Build-depends: base >= 4.7, 12 | bytestring >= 0.9, 13 | conduit > 1.0, 14 | containers, 15 | Decimal, 16 | mtl, 17 | old-locale, 18 | lens, 19 | resourcet, 20 | stm, 21 | time 22 | 23 | Exposed-modules: AlphaHeavy.FIX 24 | AlphaHeavy.FIX.FIX42.Factory 25 | AlphaHeavy.FIX.FIX42.Types 26 | AlphaHeavy.QuickFIX 27 | 28 | Other-modules: AlphaHeavy.QuickFIX.Foreign 29 | AlphaHeavy.QuickFIX.GReceive 30 | AlphaHeavy.QuickFIX.GSend 31 | AlphaHeavy.QuickFIX.GetMessageField 32 | AlphaHeavy.QuickFIX.SetMessageField 33 | AlphaHeavy.QuickFIX.Types 34 | 35 | HS-Source-Dirs: src 36 | 37 | GHC-Options: -Wall 38 | CC-Options: -O2 -ggdb 39 | 40 | C-Sources: cbits/QuickFIXThunks.cpp 41 | 42 | Includes: quickfix/index.h 43 | Extra-Libraries: quickfix, stdc++ 44 | -------------------------------------------------------------------------------- /cbits/QuickFIXThunks.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include "AlphaHeavy/QuickFIX/Foreign_stub.h" 12 | 13 | class ApplicationThunk : 14 | public FIX::Application 15 | { 16 | public: 17 | ApplicationThunk(HsStablePtr app) 18 | : _app(app) 19 | { 20 | } 21 | 22 | virtual void onCreate(const FIX::SessionID& sess) 23 | { 24 | applicationOnCreate(_app, reinterpret_cast(&sess)); 25 | } 26 | 27 | virtual void onLogon(const FIX::SessionID& sess) 28 | { 29 | applicationOnLogon(_app, reinterpret_cast(&sess)); 30 | } 31 | 32 | virtual void onLogout(const FIX::SessionID& sess) 33 | { 34 | applicationOnLogout(_app, reinterpret_cast(&sess)); 35 | } 36 | 37 | virtual void toAdmin(FIX::Message& msg, const FIX::SessionID& sess) 38 | { 39 | applicationToAdmin(_app, reinterpret_cast(&sess), &msg); 40 | } 41 | 42 | virtual void toApp(FIX::Message& msg, const FIX::SessionID& sess) 43 | throw (FIX::DoNotSend) 44 | { 45 | applicationToApp(_app, reinterpret_cast(&sess), &msg); 46 | } 47 | 48 | virtual void fromAdmin(const FIX::Message& msg, const FIX::SessionID& sess) 49 | throw (FIX::FieldNotFound, FIX::IncorrectDataFormat, FIX::IncorrectTagValue, FIX::RejectLogon) 50 | { 51 | applicationFromAdmin(_app, reinterpret_cast(&sess), const_cast(&msg)); 52 | } 53 | 54 | virtual void fromApp(const FIX::Message& msg, const FIX::SessionID& sess) 55 | throw (FIX::FieldNotFound, FIX::IncorrectDataFormat, FIX::IncorrectTagValue, FIX::UnsupportedMessageType) 56 | { 57 | applicationFromApp(_app, reinterpret_cast(&sess), const_cast(&msg)); 58 | } 59 | 60 | private: 61 | HsStablePtr _app; 62 | }; 63 | 64 | extern "C" 65 | HsChar getMessageType(const FIX::Message& msg) 66 | { 67 | FIX::MsgType msgType; 68 | msg.getHeader().getField(msgType); 69 | return msgType.getValue()[0]; 70 | } 71 | 72 | extern "C" 73 | HsBool getBoolField(const FIX::Message& msg, int fieldId) 74 | { 75 | FIX::BoolField field(fieldId); 76 | msg.getField(field); 77 | return field.getValue(); 78 | } 79 | 80 | extern "C" 81 | HsChar getCharField(const FIX::Message& msg, int fieldId) 82 | { 83 | FIX::CharField field(fieldId); 84 | msg.getField(field); 85 | return field.getValue(); 86 | } 87 | 88 | extern "C" 89 | HsDouble getDoubleField(const FIX::Message& msg, int fieldId) 90 | { 91 | FIX::DoubleField field(fieldId); 92 | msg.getField(field); 93 | return field.getValue(); 94 | } 95 | 96 | extern "C" 97 | HsInt32 getIntField(const FIX::Message& msg, int fieldId) 98 | { 99 | FIX::IntField field(fieldId); 100 | msg.getField(field); 101 | return field.getValue(); 102 | } 103 | 104 | extern "C" 105 | void getStringField(const FIX::Message& msg, int fieldId, void (*cont)(const char*)) 106 | { 107 | FIX::StringField field(fieldId); 108 | msg.getField(field); 109 | cont(field.getValue().c_str()); 110 | } 111 | 112 | extern "C" 113 | HsBool isFieldSet(const FIX::Message& msg, int fieldId) 114 | { 115 | return msg.isSetField(fieldId); 116 | } 117 | 118 | extern "C" 119 | char* decodeMessageWith( 120 | const char* messageStr, 121 | void (*cont)(FIX::Message&)) 122 | { 123 | try 124 | { 125 | const std::string& str(messageStr); 126 | FIX::Message msg(str, false); 127 | cont(msg); 128 | return NULL; 129 | } 130 | catch (const std::exception& e) 131 | { 132 | return strdup(e.what()); 133 | } 134 | } 135 | 136 | extern "C" 137 | char* sendMessageWith( 138 | const char* senderCompStr, 139 | const char* targetCompStr, 140 | HsChar msgTypeChar, 141 | void (*cont)(FIX::Message&)) 142 | { 143 | try 144 | { 145 | const char msgTypeStr[2] = { msgTypeChar, '\0' }; 146 | FIX::MsgType msgtype(msgTypeStr); 147 | FIX42::Message msg(msgtype); 148 | cont(msg); 149 | 150 | const FIX::SenderCompID senderCompID(senderCompStr); 151 | const FIX::TargetCompID targetCompID(targetCompStr); 152 | 153 | FIX::Session::sendToTarget(msg, senderCompID, targetCompID); 154 | return NULL; 155 | } 156 | catch (const std::exception& e) 157 | { 158 | return strdup(e.what()); 159 | } 160 | } 161 | 162 | extern "C" 163 | void setBoolField(FIX::Message& msg, int fieldId, HsBool value) 164 | { 165 | FIX::BoolField field(fieldId, value); 166 | msg.setField(field); 167 | } 168 | 169 | extern "C" 170 | void setCharField(FIX::Message& msg, int fieldId, HsChar value) 171 | { 172 | FIX::CharField field(fieldId, value); 173 | msg.setField(field); 174 | } 175 | 176 | extern "C" 177 | void setDoubleField(FIX::Message& msg, int fieldId, HsDouble value) 178 | { 179 | FIX::DoubleField field(fieldId, value); 180 | msg.setField(field); 181 | } 182 | 183 | extern "C" 184 | void setIntField(FIX::Message& msg, int fieldId, HsInt32 value) 185 | { 186 | FIX::IntField field(fieldId, value); 187 | msg.setField(field); 188 | } 189 | 190 | extern "C" 191 | void setStringField(FIX::Message& msg, int fieldId, const char* value) 192 | { 193 | FIX::StringField field(fieldId, value); 194 | msg.setField(field); 195 | } 196 | 197 | template 198 | char* runSocketApp(HsStablePtr app, const char* configPath) 199 | { 200 | try 201 | { 202 | const std::string configPathStr(configPath); 203 | FIX::SessionSettings settings(configPathStr); 204 | ApplicationThunk thunk(app); 205 | FIX::FileStoreFactory storeFactory(settings); 206 | // FIX::ScreenLogFactory logFactory(settings); 207 | FIX::FileLogFactory logFactory(settings); 208 | T initiator(thunk, storeFactory, settings, logFactory); 209 | initiator.start(); 210 | applicationBlock(app); 211 | initiator.stop(); 212 | return NULL; 213 | } 214 | catch (const std::exception& e) 215 | { 216 | return strdup(e.what()); 217 | } 218 | } 219 | 220 | extern "C" 221 | char* runApplication(HsStablePtr app, const char* configPath) 222 | { 223 | return runSocketApp(app, configPath); 224 | } 225 | 226 | extern "C" 227 | char* runAcceptor(HsStablePtr app, const char* configPath) 228 | { 229 | return runSocketApp(app, configPath); 230 | } 231 | 232 | extern "C" 233 | char* sessionLogon(const FIX::SessionID& sid) 234 | { 235 | FIX::Session* session = FIX::Session::lookupSession(sid); 236 | if (session == NULL) 237 | { 238 | char* res; 239 | asprintf(&res, "Logon for session %s failed", sid.toStringFrozen().c_str()); 240 | return res; 241 | } 242 | 243 | session->logon(); 244 | return NULL; 245 | } 246 | 247 | extern "C" 248 | char* sessionLogout(const FIX::SessionID& sid, const char* reason) 249 | { 250 | FIX::Session* session = FIX::Session::lookupSession(sid); 251 | if (session == NULL) 252 | { 253 | char* res; 254 | asprintf(&res, "Logout for session %s failed", sid.toStringFrozen().c_str()); 255 | return res; 256 | } 257 | 258 | session->logout(reason ? reason : ""); 259 | return NULL; 260 | } 261 | 262 | extern "C" 263 | char* sessionDisconnect(const FIX::SessionID& sid) 264 | { 265 | FIX::Session* session = FIX::Session::lookupSession(sid); 266 | if (session == NULL) 267 | { 268 | char* res; 269 | asprintf(&res, "Disconnect for session %s failed", sid.toStringFrozen().c_str()); 270 | return res; 271 | } 272 | 273 | session->disconnect(); 274 | return NULL; 275 | } 276 | 277 | extern "C" 278 | char* sessionString(const FIX::SessionID& sid) 279 | { 280 | strdup(sid.toStringFrozen().c_str()); 281 | } 282 | -------------------------------------------------------------------------------- /cbits/QuickFIXThunks.h: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | extern "C" 5 | { 6 | FIX::Application* newApplication(HsPtr app); 7 | void deleteApplication(FIX::Application* app); 8 | } 9 | 10 | -------------------------------------------------------------------------------- /spec/IB.xml: -------------------------------------------------------------------------------- 1 | 2 |
3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 |
16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | 174 | 175 | 176 | 177 | 178 | 179 | 180 | 181 | 182 | 183 | 184 | 185 | 186 | 187 | 188 | 189 | 190 | 191 | 192 | 193 | 194 | 195 | 196 | 197 | 198 | 199 | 200 | 201 | 202 | 203 | 204 | 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | 213 | 214 | 215 | 216 | 217 | 218 | 219 | 220 | 221 | 222 | 223 | 224 | 225 | 226 | 227 | 228 | 229 | 230 | 231 | 232 | 233 | 234 | 235 | 236 | 237 | 238 | 239 | 240 | 241 | 242 | 243 | 244 | 245 | 246 | 247 | 248 | 249 | 250 | 251 | 252 | 253 | 254 | 255 | 256 | 257 | 258 | 259 | 260 | 261 | 262 | 263 | 264 | 265 | 266 | 267 | 268 | 269 | 270 | 271 | 272 | 273 | 274 | 275 | 276 | 277 | 278 | 279 | 280 | 281 | 282 | 283 | 284 | 285 | 286 | 287 | 288 | 289 | 290 | 291 | 292 | 293 | 294 | 295 | 296 | 297 | 298 | 299 | 300 | 301 | 302 | 303 | 304 | 305 | 306 | 307 | 308 | 309 | 310 | 311 | 312 | 313 | 314 | 315 | 316 | 317 | 318 | 319 | 320 | 321 | 322 | 323 | 324 | 325 | 326 | 327 | 328 | 329 | 330 | 331 | 332 | 333 | 334 | 335 | 336 | 337 | 338 | 339 | 340 | 341 | 342 | 343 | 344 | 345 | 346 | 347 | 348 | 349 | 350 | 351 | 352 | 353 | 354 | 355 | 356 | 357 | 358 | 359 | 360 | 361 | 362 | 363 | 364 | 365 | 366 | 367 | 368 | 369 | 370 | 371 | 372 | 373 | 374 | 375 | 376 | 377 | 378 | 379 | 380 | 381 | 382 | 383 | 384 | 385 | 386 | 387 | 388 | 389 | 390 | 391 | 392 | 393 | 394 | 395 | 396 | 397 | 398 | 399 | 400 | 401 | 402 | 403 | 404 | 405 | 406 | 407 | 408 | 409 | 410 | 411 | 412 | 413 | 414 | 415 | 416 | 417 | 418 | 419 | 420 | 421 | 422 | 423 | 424 | 425 | 426 | 427 | 428 | 429 | -------------------------------------------------------------------------------- /src/AlphaHeavy/FIX.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE KindSignatures #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | 9 | module AlphaHeavy.FIX ( 10 | Currency, 11 | DayOfMonth, 12 | Decimal, 13 | Enumeration(..), 14 | Exchange(..), 15 | FIXException(..), 16 | Field(..), 17 | FieldTag(..), 18 | Group(..), 19 | MarketLocalTime, 20 | Message(..), 21 | MessageDirection(..), 22 | MonthYear, 23 | Price(..), 24 | Quantity(..), 25 | AlphaHeavy.FIX.UTCDate, 26 | AlphaHeavy.FIX.UTCTime, 27 | UTCTimeStamp, 28 | ) where 29 | 30 | import Control.Exception (Exception) 31 | import Data.Decimal (Decimal) 32 | import Data.Typeable (Typeable) 33 | import GHC.Generics (Generic) 34 | import GHC.TypeLits (Nat) 35 | 36 | newtype Enumeration (n :: Nat) a = Enumeration a 37 | deriving (Generic, Eq, Show) 38 | 39 | newtype Field (n :: Nat) a = Field a 40 | deriving (Generic, Eq, Show) 41 | 42 | newtype Group (n :: Nat) a = Group [a] 43 | deriving (Generic, Eq, Show) 44 | 45 | newtype Message (n :: Nat) (dir :: MessageDirection) a = Message a 46 | deriving (Generic, Eq, Show) 47 | 48 | newtype Price = Price Decimal 49 | deriving (Generic, Num, Ord, Eq, Fractional, Real, RealFrac, Read, Show) 50 | 51 | newtype Quantity = Quantity Decimal 52 | deriving (Generic, Num, Ord, Eq, Fractional, Real, RealFrac, Read, Show) 53 | 54 | class FieldTag a where 55 | type FieldTagRep a :: * 56 | toFieldTagRep :: a -> FieldTagRep a 57 | fromFieldTagRep :: FieldTagRep a -> Maybe a 58 | 59 | data MessageDirection 60 | = RequestDirection 61 | | ResponseDirection 62 | deriving (Show) 63 | 64 | data Exchange 65 | = Exchange_NASDAQ 66 | | Exchange_NYSE 67 | | Exchange_SMART 68 | | Exchange_OTHER String 69 | -- | Exchange_DirectEdge 70 | -- | Exchange_BATS 71 | deriving (Eq, Show) 72 | 73 | type MonthYear = Int 74 | type DayOfMonth = Int 75 | type Currency = String 76 | type MarketLocalTime = Int 77 | type UTCTimeStamp = UTCTime 78 | type UTCDate = Int 79 | type UTCTime = Int 80 | 81 | data FIXException 82 | = DoNotSend String 83 | | FieldConvertError String 84 | | FieldNotFound {-# UNPACK #-} !Int String 85 | | IncorrectDataFormat {-# UNPACK #-} !Int String 86 | | IncorrectTagValue {-# UNPACK #-} !Int String 87 | | RejectLogon String 88 | | RequiredTagMissing {-# UNPACK #-} !Int String 89 | | UnsupportedMessageType String 90 | deriving (Show, Typeable) 91 | 92 | instance Exception FIXException 93 | -------------------------------------------------------------------------------- /src/AlphaHeavy/FIX/FIX42/Factory.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} 2 | module AlphaHeavy.FIX.FIX42.Factory where 3 | import qualified Data.ByteString 4 | import AlphaHeavy.FIX 5 | import AlphaHeavy.FIX.FIX42.Types 6 | 7 | logon :: EncryptMethod -> HeartBtInt -> Logon 8 | logon encryptMethod heartBtInt 9 | = Logon (AlphaHeavy.FIX.Enumeration encryptMethod) 10 | (AlphaHeavy.FIX.Field heartBtInt) 11 | Nothing 12 | 13 | heartbeat :: Heartbeat 14 | heartbeat = Heartbeat Nothing 15 | 16 | testRequest :: TestReqID -> TestRequest 17 | testRequest testReqID 18 | = TestRequest (AlphaHeavy.FIX.Field testReqID) 19 | 20 | resendRequest :: BeginSeqNo -> EndSeqNo -> ResendRequest 21 | resendRequest beginSeqNo endSeqNo 22 | = ResendRequest (AlphaHeavy.FIX.Field beginSeqNo) 23 | (AlphaHeavy.FIX.Field endSeqNo) 24 | 25 | sequenceReset :: NewSeqNo -> SequenceReset 26 | sequenceReset newSeqNo 27 | = SequenceReset (AlphaHeavy.FIX.Field newSeqNo) Nothing 28 | 29 | reject :: RefSeqNum -> Reject 30 | reject refSeqNum = Reject (AlphaHeavy.FIX.Field refSeqNum) Nothing 31 | 32 | logout :: Logout 33 | logout = Logout Nothing 34 | 35 | newOrderSingle :: 36 | ClOrdID -> 37 | CustomerOrFirm -> 38 | ExDestination -> 39 | HandlInst -> 40 | LocateReqd -> 41 | MPID -> OrdType -> Quantity -> Side -> Symbol -> NewOrderSingle 42 | newOrderSingle clOrdID customerOrFirm exDestination handlInst 43 | locateReqd mPID ordType orderQty side symbol 44 | = NewOrderSingle (AlphaHeavy.FIX.Field clOrdID) 45 | (AlphaHeavy.FIX.Enumeration customerOrFirm) 46 | (AlphaHeavy.FIX.Field exDestination) 47 | (AlphaHeavy.FIX.Enumeration handlInst) 48 | (AlphaHeavy.FIX.Enumeration locateReqd) 49 | (AlphaHeavy.FIX.Field mPID) 50 | (AlphaHeavy.FIX.Enumeration ordType) 51 | (AlphaHeavy.FIX.Field orderQty) 52 | (AlphaHeavy.FIX.Enumeration side) 53 | (AlphaHeavy.FIX.Field symbol) 54 | Nothing 55 | Nothing 56 | Nothing 57 | Nothing 58 | Nothing 59 | Nothing 60 | Nothing 61 | Nothing 62 | Nothing 63 | Nothing 64 | Nothing 65 | Nothing 66 | Nothing 67 | Nothing 68 | Nothing 69 | Nothing 70 | Nothing 71 | Nothing 72 | Nothing 73 | Nothing 74 | Nothing 75 | Nothing 76 | Nothing 77 | Nothing 78 | Nothing 79 | Nothing 80 | 81 | executionReport :: 82 | Price -> 83 | Quantity -> 84 | ExecID -> 85 | ExecTransType -> 86 | ExecType -> 87 | Price -> 88 | Quantity -> 89 | Quantity -> 90 | OrdStatus -> 91 | OrderID -> Quantity -> Side -> Symbol -> ExecutionReport 92 | executionReport avgPx cumQty execID execTransType execType lastPx 93 | lastShares leavesQty ordStatus orderID orderQty side symbol 94 | = ExecutionReport (AlphaHeavy.FIX.Field avgPx) 95 | (AlphaHeavy.FIX.Field cumQty) 96 | (AlphaHeavy.FIX.Field execID) 97 | (AlphaHeavy.FIX.Enumeration execTransType) 98 | (AlphaHeavy.FIX.Enumeration execType) 99 | (AlphaHeavy.FIX.Field lastPx) 100 | (AlphaHeavy.FIX.Field lastShares) 101 | (AlphaHeavy.FIX.Field leavesQty) 102 | (AlphaHeavy.FIX.Enumeration ordStatus) 103 | (AlphaHeavy.FIX.Field orderID) 104 | (AlphaHeavy.FIX.Field orderQty) 105 | (AlphaHeavy.FIX.Enumeration side) 106 | (AlphaHeavy.FIX.Field symbol) 107 | Nothing 108 | Nothing 109 | Nothing 110 | Nothing 111 | Nothing 112 | Nothing 113 | Nothing 114 | Nothing 115 | Nothing 116 | Nothing 117 | Nothing 118 | Nothing 119 | Nothing 120 | Nothing 121 | Nothing 122 | Nothing 123 | Nothing 124 | Nothing 125 | Nothing 126 | Nothing 127 | Nothing 128 | Nothing 129 | Nothing 130 | Nothing 131 | Nothing 132 | Nothing 133 | Nothing 134 | Nothing 135 | Nothing 136 | Nothing 137 | 138 | orderCancelReplaceRequest :: 139 | ClOrdID -> 140 | HandlInst -> 141 | OrdType -> 142 | Quantity -> 143 | OrigClOrdID -> Side -> Symbol -> OrderCancelReplaceRequest 144 | orderCancelReplaceRequest clOrdID handlInst ordType orderQty 145 | origClOrdID side symbol 146 | = OrderCancelReplaceRequest (AlphaHeavy.FIX.Field clOrdID) 147 | (AlphaHeavy.FIX.Enumeration handlInst) 148 | (AlphaHeavy.FIX.Enumeration ordType) 149 | (AlphaHeavy.FIX.Field orderQty) 150 | (AlphaHeavy.FIX.Field origClOrdID) 151 | (AlphaHeavy.FIX.Enumeration side) 152 | (AlphaHeavy.FIX.Field symbol) 153 | Nothing 154 | Nothing 155 | Nothing 156 | Nothing 157 | Nothing 158 | Nothing 159 | Nothing 160 | Nothing 161 | Nothing 162 | Nothing 163 | Nothing 164 | Nothing 165 | Nothing 166 | 167 | orderCancelRequest :: 168 | ClOrdID -> 169 | Quantity -> OrigClOrdID -> Side -> Symbol -> OrderCancelRequest 170 | orderCancelRequest clOrdID orderQty origClOrdID side symbol 171 | = OrderCancelRequest (AlphaHeavy.FIX.Field clOrdID) 172 | (AlphaHeavy.FIX.Field orderQty) 173 | (AlphaHeavy.FIX.Field origClOrdID) 174 | (AlphaHeavy.FIX.Enumeration side) 175 | (AlphaHeavy.FIX.Field symbol) 176 | Nothing 177 | Nothing 178 | Nothing 179 | 180 | orderCancelReject :: 181 | ClOrdID -> 182 | CxlRejResponseTo -> OrderID -> OrigClOrdID -> OrderCancelReject 183 | orderCancelReject clOrdID cxlRejResponseTo orderID origClOrdID 184 | = OrderCancelReject (AlphaHeavy.FIX.Field clOrdID) 185 | (AlphaHeavy.FIX.Enumeration cxlRejResponseTo) 186 | (AlphaHeavy.FIX.Field orderID) 187 | (AlphaHeavy.FIX.Field origClOrdID) 188 | Nothing 189 | Nothing 190 | 191 | orderStatusRequest :: ClOrdID -> OrderStatusRequest 192 | orderStatusRequest clOrdID 193 | = OrderStatusRequest (AlphaHeavy.FIX.Field clOrdID) 194 | 195 | news :: DailyNewID -> Headline -> Urgency -> News 196 | news dailyNewID headline urgency 197 | = News (AlphaHeavy.FIX.Field dailyNewID) 198 | (AlphaHeavy.FIX.Field headline) 199 | (AlphaHeavy.FIX.Enumeration urgency) 200 | Nothing -------------------------------------------------------------------------------- /src/AlphaHeavy/QuickFIX.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE ImpredicativeTypes #-} 4 | {-# LANGUAGE NamedFieldPuns #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | 8 | module AlphaHeavy.QuickFIX 9 | ( QuickFIX 10 | , QuickFIXException 11 | , SessionID 12 | , SessionState(..) 13 | , createAcceptor 14 | , createInitiator 15 | , sendMessage 16 | , sendMessage' 17 | , decodeMessage 18 | 19 | -- * Session Management 20 | , sessionStates 21 | , AlphaHeavy.QuickFIX.sessionLogon 22 | , AlphaHeavy.QuickFIX.sessionLogout 23 | , AlphaHeavy.QuickFIX.sessionDisconnect 24 | ) where 25 | 26 | import Control.Applicative 27 | import Control.Concurrent (forkIO, forkOS) 28 | import Control.Concurrent.STM 29 | import Control.Exception (catch, finally, throwIO) 30 | import Control.Monad (unless) 31 | import Control.Monad.Trans 32 | import Control.Monad.Trans.Resource 33 | import Data.Map (Map) 34 | import qualified Data.Map as Map 35 | import Foreign.C.String (CString, peekCString, withCString) 36 | import Foreign.Marshal (free) 37 | import Foreign.Ptr (nullPtr) 38 | import Foreign.StablePtr 39 | import GHC.Generics 40 | 41 | import Data.Conduit 42 | import qualified Data.Conduit.List as Cl 43 | 44 | import AlphaHeavy.QuickFIX.Foreign as Foreign 45 | import AlphaHeavy.QuickFIX.GReceive 46 | import AlphaHeavy.QuickFIX.GSend 47 | import AlphaHeavy.QuickFIX.Types 48 | 49 | type QuickFIX = ConduitApp 50 | 51 | createAcceptor 52 | :: (Generic a, GSendMessage (Rep a), GRecvMessage (Rep a), MonadResource m) 53 | => FilePath 54 | -> String 55 | -> String 56 | -> m (QuickFIX, Source m a, Sink a m ()) 57 | createAcceptor = createQuickFIXEngine runAcceptor 58 | 59 | createInitiator 60 | :: (Generic a, GSendMessage (Rep a), GRecvMessage (Rep a), MonadResource m) 61 | => FilePath 62 | -> String 63 | -> String 64 | -> m (QuickFIX, Source m a, Sink a m ()) 65 | createInitiator = createQuickFIXEngine runApplication 66 | 67 | createQuickFIXEngine 68 | :: (Generic a, GSendMessage (Rep a), GRecvMessage (Rep a), MonadResource m) 69 | => (StablePtr ConduitApp -> CString -> IO CString) 70 | -> FilePath 71 | -> String 72 | -> String 73 | -> m (QuickFIX, Source m a, Sink a m ()) 74 | createQuickFIXEngine createFunction configPath sender target = do 75 | app@ConduitApp{..} <- liftIO . atomically $ do 76 | recv <- newEmptyTMVar 77 | halt <- newEmptyTMVar 78 | mgmt <- newTChan 79 | status <- newTVar EngineStopped 80 | sessions <- newTVar Map.empty 81 | return $ ConduitApp recv halt mgmt status sessions 82 | 83 | let initEngine = do 84 | ptr <- newStablePtr app 85 | _ <- forkOS $ do 86 | atomically $ writeTVar conduitAppStatus EngineRunning 87 | res <- withCString configPath (createFunction ptr) 88 | atomically $ writeTVar conduitAppStatus EngineStopped 89 | unless (res == nullPtr) $ do 90 | str <- peekCString res 91 | free res 92 | throwIO $! QuickFIXException str 93 | 94 | return ptr 95 | 96 | waitForShutdown = do 97 | -- signal shutdown 98 | ifRunning $ putTMVar conduitAppHalt () 99 | 100 | -- wait for exit 101 | ifRunning retry 102 | 103 | haltEngine ptr = 104 | finally 105 | waitForShutdown 106 | (freeStablePtr ptr) 107 | 108 | ifRunning f = 109 | atomically $ do 110 | st <- readTVar conduitAppStatus 111 | case st of 112 | EngineStopped -> return () 113 | EngineRunning -> f 114 | 115 | (releaseKey, _) <- allocate 116 | (initEngine >>= \ ptr -> putStrLn "engine init complete" >> return ptr) 117 | (\ ptr -> haltEngine ptr >> putStrLn "engine halted") 118 | 119 | _ <- liftIO . forkIO $ managementLoop conduitAppMgmt conduitAppStatus 120 | 121 | return (app, sourceQuickFIX app, sinkQuickFIX releaseKey conduitAppSessions sender target) 122 | 123 | sourceQuickFIX 124 | :: (Generic a, GRecvMessage (Rep a), MonadIO m) 125 | => ConduitApp 126 | -> Source m a 127 | sourceQuickFIX ConduitApp{conduitAppRecv, conduitAppStatus} = step where 128 | step = do 129 | mval <- liftIO . atomically $ do 130 | mval <- Right <$> takeTMVar conduitAppRecv <|> Left <$> readTVar conduitAppStatus 131 | case mval of 132 | Left EngineRunning -> retry 133 | _ -> return mval 134 | 135 | case mval of 136 | Right (val, future) -> do 137 | -- the QuickFIX callbacks don't know the correct type, so we need to do 138 | -- the parsing with the GRecvMessage constraint in scope. The QuickFIX engine 139 | -- needs any parse related exceptions returned synchronously... this is 140 | -- done by passing a future for the exception along with the message pointer 141 | mmsg <- liftIO $ catch 142 | (receiveMessage val >>= \ !msg -> future Nothing >> return (Just msg)) 143 | (\ ex -> future (Just ex) >> return Nothing) 144 | case mmsg of 145 | Just msg -> yield msg 146 | Nothing -> return () 147 | step 148 | 149 | -- this should always be Left EngineStopped 150 | Left _ -> return () 151 | 152 | sinkQuickFIX 153 | :: (Generic a, GSendMessage (Rep a), MonadResource m) 154 | => ReleaseKey 155 | -> TVar (Map k SessionState) 156 | -> String 157 | -> String 158 | -> Sink a m () 159 | sinkQuickFIX releaseKey sessions sender target = do 160 | liftIO . atomically $ do 161 | sv <- readTVar sessions 162 | unless (or [True | SessionOpen <- Map.elems sv]) retry 163 | 164 | r <- Cl.mapM_ (liftIO . sendMessage sender target) 165 | lift $ release releaseKey 166 | return r 167 | 168 | managementLoop 169 | :: TChan EngineManagement 170 | -> TVar EngineState 171 | -> IO () 172 | managementLoop mgmt state = do 173 | let block = do 174 | state' <- readTVar state 175 | case state' of 176 | EngineRunning -> retry 177 | EngineStopped -> return $ Left () 178 | 179 | next <- atomically $ Right <$> readTChan mgmt <|> block 180 | 181 | case next of 182 | Left _ -> return () 183 | Right cmd -> do 184 | res <- case cmd of 185 | SessionLogon sess -> 186 | Foreign.sessionLogon sess 187 | 188 | SessionLogout sess reason -> 189 | withCString reason $ \ c'reason -> 190 | Foreign.sessionLogout sess c'reason 191 | 192 | SessionDisconnect sess -> 193 | Foreign.sessionDisconnect sess 194 | 195 | throwIfNotNull res 196 | 197 | managementLoop mgmt state 198 | 199 | sessionStates 200 | :: QuickFIX 201 | -> STM (Map SessionID SessionState) 202 | sessionStates = 203 | readTVar . conduitAppSessions 204 | 205 | sessionLogon 206 | :: QuickFIX 207 | -> SessionID 208 | -> STM () 209 | sessionLogon app = 210 | writeTChan (conduitAppMgmt app) . SessionLogon 211 | 212 | sessionLogout 213 | :: QuickFIX 214 | -> SessionID 215 | -> String 216 | -> STM () 217 | sessionLogout app sess = 218 | writeTChan (conduitAppMgmt app) . SessionLogout sess 219 | 220 | sessionDisconnect 221 | :: QuickFIX 222 | -> SessionID 223 | -> STM () 224 | sessionDisconnect app = 225 | writeTChan (conduitAppMgmt app) . SessionDisconnect 226 | -------------------------------------------------------------------------------- /src/AlphaHeavy/QuickFIX/Foreign.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | 3 | module AlphaHeavy.QuickFIX.Foreign where 4 | 5 | import Control.Concurrent.MVar 6 | import Control.Concurrent.STM 7 | import Control.Exception (bracket, throwIO) 8 | import Control.Monad (unless) 9 | import qualified Data.ByteString as B 10 | import qualified Data.Map as Map 11 | import Data.Int 12 | import Foreign.C.String 13 | import Foreign.Marshal.Alloc (free) 14 | import Foreign.Ptr 15 | import Foreign.StablePtr 16 | 17 | import AlphaHeavy.FIX as FIX 18 | import AlphaHeavy.QuickFIX.Types 19 | 20 | {- 21 | import System.IO.Unsafe (unsafePerformIO) 22 | 23 | instance Show SessionID where 24 | show sess = unsafePerformIO $ do 25 | str <- sessionString sess 26 | if str == nullPtr 27 | then return "" 28 | else do 29 | str' <- peekCString str 30 | free str 31 | return str' 32 | -} 33 | 34 | throwIfNotNull :: CString -> IO () 35 | throwIfNotNull str = 36 | unless (str == nullPtr) $ do 37 | str' <- peekCString str 38 | free str 39 | throwIO $! QuickFIXException str' 40 | 41 | sendMessageWithWrapper 42 | :: String 43 | -> String 44 | -> Char 45 | -> (QuickFIXMessagePtr -> IO ()) 46 | -> IO () 47 | sendMessageWithWrapper senderCompID targetCompID msgType fun = 48 | let body ptr = 49 | withCString senderCompID $ \ senderCompStr -> 50 | withCString targetCompID $ \ targetCompStr -> do 51 | res <- AlphaHeavy.QuickFIX.Foreign.sendMessageWith senderCompStr targetCompStr msgType ptr 52 | throwIfNotNull res 53 | 54 | in bracket 55 | (mkMessageCallback fun) 56 | freeHaskellFunPtr 57 | body 58 | 59 | decodeMessageWithWrapper 60 | :: B.ByteString 61 | -> (QuickFIXMessagePtr -> IO ()) 62 | -> IO () 63 | decodeMessageWithWrapper msg fun = 64 | let body ptr = 65 | B.useAsCString msg $ \ msgStr -> do 66 | res <- AlphaHeavy.QuickFIX.Foreign.decodeMessageWith msgStr ptr 67 | throwIfNotNull res 68 | 69 | in bracket 70 | (mkMessageCallback fun) 71 | freeHaskellFunPtr 72 | body 73 | 74 | setStringFieldWrapper 75 | :: QuickFIXMessagePtr 76 | -> Int32 77 | -> String 78 | -> IO () 79 | setStringFieldWrapper msg fieldId str = 80 | withCString str (AlphaHeavy.QuickFIX.Foreign.setStringField msg fieldId) 81 | 82 | getStringFieldCPS 83 | :: QuickFIXMessagePtr 84 | -> Int32 85 | -> IO String 86 | getStringFieldCPS msg fieldId = do 87 | mv <- newEmptyMVar 88 | let callback str = peekCAString str >>= putMVar mv 89 | bracket 90 | (mkStringCallback callback) 91 | freeHaskellFunPtr 92 | (AlphaHeavy.QuickFIX.Foreign.getStringField msg fieldId) 93 | takeMVar mv 94 | 95 | foreign import ccall safe "QuickFIXThunks.h" 96 | runApplication :: StablePtr ConduitApp -> CString -> IO CString 97 | 98 | foreign import ccall safe "QuickFIXThunks.h" 99 | runAcceptor :: StablePtr ConduitApp -> CString -> IO CString 100 | 101 | foreign import ccall "wrapper" 102 | mkStringCallback :: (CString -> IO ()) -> IO (FunPtr (CString -> IO ())) 103 | 104 | foreign import ccall "wrapper" 105 | mkMessageCallback :: (QuickFIXMessagePtr -> IO ()) -> IO (FunPtr (QuickFIXMessagePtr -> IO ())) 106 | 107 | foreign import ccall "QuickFIXThunks.h" 108 | sendMessageWith :: CString -> CString -> Char -> FunPtr (QuickFIXMessagePtr -> IO ()) -> IO CString 109 | 110 | foreign import ccall "QuickFIXThunks.h" 111 | decodeMessageWith :: CString -> FunPtr (QuickFIXMessagePtr -> IO ()) -> IO CString 112 | 113 | foreign import ccall "QuickFIXThunks.h" 114 | setBoolField :: QuickFIXMessagePtr -> Int32 -> Bool -> IO () 115 | 116 | foreign import ccall "QuickFIXThunks.h" 117 | setCharField :: QuickFIXMessagePtr -> Int32 -> Char -> IO () 118 | 119 | foreign import ccall "QuickFIXThunks.h" 120 | setDoubleField :: QuickFIXMessagePtr -> Int32 -> Double -> IO () 121 | 122 | foreign import ccall "QuickFIXThunks.h" 123 | setIntField :: QuickFIXMessagePtr -> Int32 -> Int32 -> IO () 124 | 125 | foreign import ccall "QuickFIXThunks.h" 126 | setStringField :: QuickFIXMessagePtr -> Int32 -> CString -> IO () 127 | 128 | foreign import ccall "QuickFIXThunks.h" 129 | isFieldSet :: QuickFIXMessagePtr -> Int32 -> IO Bool 130 | 131 | foreign import ccall "QuickFIXThunks.h" 132 | getBoolField :: QuickFIXMessagePtr -> Int32 -> IO Bool 133 | 134 | foreign import ccall "QuickFIXThunks.h" 135 | getCharField :: QuickFIXMessagePtr -> Int32 -> IO Char 136 | 137 | foreign import ccall "QuickFIXThunks.h" 138 | getDoubleField :: QuickFIXMessagePtr -> Int32 -> IO Double 139 | 140 | foreign import ccall "QuickFIXThunks.h" 141 | getIntField :: QuickFIXMessagePtr -> Int32 -> IO Int32 142 | 143 | foreign import ccall "QuickFIXThunks.h" 144 | getStringField :: QuickFIXMessagePtr -> Int32 -> FunPtr (CString -> IO ()) -> IO () 145 | 146 | foreign import ccall "QuickFIXThunks.h" 147 | getMessageType :: QuickFIXMessagePtr -> IO Char 148 | 149 | foreign import ccall "QuickFIXThunks.h" 150 | sessionLogon :: SessionID -> IO CString 151 | 152 | foreign import ccall "QuickFIXThunks.h" 153 | sessionLogout :: SessionID -> CString -> IO CString 154 | 155 | foreign import ccall "QuickFIXThunks.h" 156 | sessionDisconnect :: SessionID -> IO CString 157 | 158 | foreign import ccall "QuickFIXThunks.h" 159 | sessionString :: SessionID -> IO CString 160 | 161 | foreign export ccall applicationBlock :: StablePtr ConduitApp -> IO () 162 | applicationBlock :: StablePtr ConduitApp -> IO () 163 | applicationBlock ptr = do 164 | ConduitApp{conduitAppHalt} <- deRefStablePtr ptr 165 | 166 | atomically $ takeTMVar conduitAppHalt 167 | 168 | foreign export ccall applicationOnCreate :: StablePtr ConduitApp -> SessionID -> IO (Ptr FIXException) 169 | applicationOnCreate :: StablePtr ConduitApp -> SessionID -> IO (Ptr FIXException) 170 | applicationOnCreate ptr sess = do 171 | ConduitApp{conduitAppSessions} <- deRefStablePtr ptr 172 | 173 | atomically . modifyTVar' conduitAppSessions $ Map.insert sess SessionClosed 174 | 175 | return nullPtr 176 | 177 | foreign export ccall applicationOnLogon :: StablePtr ConduitApp -> SessionID -> IO (Ptr FIXException) 178 | applicationOnLogon :: StablePtr ConduitApp -> SessionID -> IO (Ptr FIXException) 179 | applicationOnLogon ptr sess = do 180 | ConduitApp{conduitAppSessions} <- deRefStablePtr ptr 181 | 182 | atomically . modifyTVar' conduitAppSessions $ Map.insert sess SessionOpen 183 | 184 | return nullPtr 185 | 186 | foreign export ccall applicationOnLogout :: StablePtr ConduitApp -> SessionID -> IO (Ptr FIXException) 187 | applicationOnLogout :: StablePtr ConduitApp -> SessionID -> IO (Ptr FIXException) 188 | applicationOnLogout ptr sess = do 189 | ConduitApp{conduitAppSessions} <- deRefStablePtr ptr 190 | 191 | atomically . modifyTVar' conduitAppSessions $ Map.insert sess SessionClosed 192 | 193 | return nullPtr 194 | 195 | foreign export ccall applicationToAdmin :: StablePtr ConduitApp -> SessionID -> QuickFIXMessagePtr -> IO (Ptr FIXException) 196 | applicationToAdmin :: StablePtr ConduitApp -> SessionID -> QuickFIXMessagePtr -> IO (Ptr FIXException) 197 | applicationToAdmin _ptr _sess _msg = return nullPtr 198 | 199 | foreign export ccall applicationToApp :: StablePtr ConduitApp -> SessionID -> QuickFIXMessagePtr -> IO (Ptr FIXException) 200 | applicationToApp :: StablePtr ConduitApp -> SessionID -> QuickFIXMessagePtr -> IO (Ptr FIXException) 201 | applicationToApp _ptr _sess _msg = return nullPtr 202 | 203 | foreign export ccall applicationFromAdmin :: StablePtr ConduitApp -> SessionID -> QuickFIXMessagePtr -> IO (Ptr FIXException) 204 | applicationFromAdmin :: StablePtr ConduitApp -> SessionID -> QuickFIXMessagePtr -> IO (Ptr FIXException) 205 | applicationFromAdmin _ptr _sess _msg = return nullPtr 206 | 207 | foreign export ccall applicationFromApp :: StablePtr ConduitApp -> SessionID -> QuickFIXMessagePtr -> IO (Ptr FIXException) 208 | applicationFromApp :: StablePtr ConduitApp -> SessionID -> QuickFIXMessagePtr -> IO (Ptr FIXException) 209 | applicationFromApp ptr _sess msg = do 210 | ConduitApp{conduitAppRecv} <- deRefStablePtr ptr 211 | 212 | mv <- newEmptyMVar 213 | 214 | atomically $ putTMVar conduitAppRecv (msg, putMVar mv) 215 | 216 | -- wait for 'sourceQuickFIX' to parse the message 217 | mval <- takeMVar mv 218 | case mval of 219 | Nothing -> return nullPtr 220 | -- if it failed go ahead and let QuickFIX know 221 | Just val -> fail $ "Allocate exception pointer for: " ++ show val 222 | -------------------------------------------------------------------------------- /src/AlphaHeavy/QuickFIX/GReceive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module AlphaHeavy.QuickFIX.GReceive where 9 | 10 | import Control.Applicative 11 | import Control.Concurrent.MVar 12 | import Control.Monad -- (forM_) 13 | import Control.Exception (SomeException, catch, throwIO) 14 | import qualified Data.ByteString as B 15 | import Data.Char (chr) 16 | import Data.Proxy (Proxy (..)) 17 | import GHC.Generics 18 | import GHC.TypeLits (KnownNat, natVal) 19 | 20 | import AlphaHeavy.FIX as FIX 21 | import AlphaHeavy.QuickFIX.Foreign 22 | import AlphaHeavy.QuickFIX.Types 23 | import AlphaHeavy.QuickFIX.GetMessageField 24 | 25 | receiveMessage 26 | :: (Generic a, GRecvMessage (Rep a)) 27 | => QuickFIXMessagePtr 28 | -> IO a 29 | receiveMessage ptr = do 30 | msgId <- getMessageType ptr 31 | mmsg <- fmap to <$> gRecvMessage ptr msgId 32 | case mmsg of 33 | Just msg -> return $! msg 34 | Nothing -> throwIO . UnsupportedMessageType $ [msgId] 35 | 36 | decodeMessage 37 | :: (Generic a, GRecvMessage (Rep a)) 38 | => B.ByteString 39 | -> IO a 40 | decodeMessage msgBS = do 41 | mv <- newEmptyMVar 42 | decodeMessageWithWrapper msgBS $ \ msgPtr -> do 43 | msg <- receiveMessage msgPtr 44 | putMVar mv msg 45 | mmsg <- tryTakeMVar mv 46 | case mmsg of 47 | Just msg -> return $! msg 48 | -- receiveMessage should throw an exception on failure 49 | Nothing -> fail "decodeMessage/tryTakeMVar returned Nothing" 50 | 51 | -- | 52 | -- Entry point, we're looking for 'Message' constructors with the message id 53 | -- and sending direction encoded as type parameters 54 | class GRecvMessage (f :: * -> *) where 55 | gRecvMessage :: QuickFIXMessagePtr -> Char -> IO (Maybe (f a)) 56 | 57 | instance GRecvMessage f => GRecvMessage (M1 i c f) where 58 | gRecvMessage ptr msgId = fmap M1 <$> gRecvMessage ptr msgId 59 | 60 | instance (GRecvMessage a, GRecvMessage b) => GRecvMessage (a :+: b) where 61 | gRecvMessage ptr msgId = do 62 | ma <- gRecvMessage ptr msgId 63 | case ma of 64 | Just a -> return $! Just (L1 a) 65 | Nothing -> do 66 | mb <- gRecvMessage ptr msgId 67 | return $! case mb of 68 | Just b -> Just (R1 b) 69 | Nothing -> Nothing 70 | 71 | instance (GRecvMessage a, GRecvMessage b) => GRecvMessage (a :*: b) where 72 | gRecvMessage ptr msgId = do 73 | ma <- gRecvMessage ptr msgId 74 | mb <- gRecvMessage ptr msgId 75 | return $! case (ma, mb) of 76 | (Just a, Just b) -> Just (a :*: b) 77 | _ -> Nothing 78 | 79 | instance (Generic a, GGetMessageFields (Rep a), KnownNat n) => GRecvMessage (K1 c (Message n dir a)) where 80 | gRecvMessage ptr msgId 81 | | msgId == msgId' = 82 | Just . K1 . Message . to <$> gGetMessageFields ptr 83 | | otherwise = return Nothing 84 | where msgId' = chr . fromIntegral $ natVal (Proxy :: Proxy n) 85 | 86 | -- | 87 | -- Message field iteration. Find each 'Field' within the message and its 88 | -- associated field id 89 | class GGetMessageFields (f :: * -> *) where 90 | gGetMessageFields :: QuickFIXMessagePtr -> IO (f a) 91 | 92 | instance GGetMessageFields f => GGetMessageFields (M1 i c f) where 93 | gGetMessageFields msg = M1 <$> gGetMessageFields msg 94 | 95 | instance (FieldTag a, GetMessageField (FieldTagRep a), KnownNat n, Show (FieldTagRep a)) => GGetMessageFields (K1 c (Maybe (Enumeration n a))) where 96 | gGetMessageFields msg = do 97 | let fieldId = fromIntegral $ natVal (Proxy :: Proxy n) 98 | isSet <- isFieldSet msg (fromIntegral fieldId) 99 | if isSet 100 | then do 101 | rawValue <- getMessageField msg fieldId 102 | case fromFieldTagRep rawValue of 103 | Just val -> return $! K1 . Just . Enumeration $ val 104 | Nothing -> throwIO . IncorrectTagValue fieldId $ show rawValue 105 | else return $! K1 Nothing 106 | 107 | instance (FieldTag a, GetMessageField (FieldTagRep a), KnownNat n, Show (FieldTagRep a)) => GGetMessageFields (K1 c (Enumeration n a)) where 108 | gGetMessageFields msg = do 109 | let fieldId = fromIntegral $ natVal (Proxy :: Proxy n) 110 | isSet <- isFieldSet msg (fromIntegral fieldId) 111 | unless isSet . throwIO . FieldNotFound fieldId $ "Missing required field: " ++ show fieldId 112 | rawValue <- getMessageField msg fieldId 113 | case fromFieldTagRep rawValue of 114 | Just val -> return $! K1 . Enumeration $ val 115 | Nothing -> throwIO . IncorrectTagValue fieldId $ show rawValue 116 | 117 | instance (Generic a, GGetMessageField (Rep a), KnownNat n) => GGetMessageFields (K1 c (Maybe (Field n a))) where 118 | gGetMessageFields msg = do 119 | let fieldId = fromIntegral $ natVal (Proxy :: Proxy n) 120 | isSet <- isFieldSet msg (fromIntegral fieldId) 121 | if isSet 122 | then K1 . Just . Field . to <$> gGetMessageField msg fieldId 123 | else return $! K1 Nothing 124 | 125 | instance (Generic a, GGetMessageField (Rep a), KnownNat n) => GGetMessageFields (K1 c (Field n a)) where 126 | gGetMessageFields msg = do 127 | let fieldId = fromIntegral $ natVal (Proxy :: Proxy n) 128 | isSet <- isFieldSet msg (fromIntegral fieldId) 129 | unless isSet . throwIO . FieldNotFound fieldId $ "Missing required field: " ++ show fieldId 130 | K1 . Field . to <$> gGetMessageField msg fieldId 131 | 132 | instance (Generic a, GGetMessageFields (Rep a), KnownNat n) => GGetMessageFields (K1 c (Group n a)) where 133 | gGetMessageFields _ = do 134 | let fieldId = natVal (Proxy :: Proxy n) 135 | putStrLn $ "TODO: properly implement groups: " ++ show fieldId 136 | -- forM_ xs $ gGetMessageFields msg . from 137 | return $! K1 (Group []) 138 | 139 | instance GGetMessageFields U1 where 140 | gGetMessageFields _ = return U1 141 | 142 | instance (GGetMessageFields a, GGetMessageFields b) => GGetMessageFields (a :*: b) where 143 | gGetMessageFields msg = do 144 | a <- gGetMessageFields msg 145 | b <- gGetMessageFields msg 146 | return $! (a :*: b) 147 | 148 | instance (GGetMessageFields a, GGetMessageFields b) => GGetMessageFields (a :+: b) where 149 | gGetMessageFields msg = 150 | catch 151 | (L1 <$> gGetMessageFields msg) 152 | (\ (_ :: SomeException) -> R1 <$> gGetMessageFields msg) 153 | 154 | -- | 155 | -- Now that we have the field id, set the value on the message 156 | class GGetMessageField f where 157 | gGetMessageField :: QuickFIXMessagePtr -> Int -> IO (f a) 158 | 159 | instance GGetMessageField f => GGetMessageField (M1 i c f) where 160 | gGetMessageField msg fid = 161 | M1 <$> gGetMessageField msg fid 162 | 163 | instance (GGetMessageField a, GGetMessageField b) => GGetMessageField (a :*: b) where 164 | gGetMessageField msg fid = do 165 | a <- gGetMessageField msg fid 166 | b <- gGetMessageField msg fid 167 | return $! (a :*: b) 168 | 169 | instance (GGetMessageField a, GGetMessageField b) => GGetMessageField (a :+: b) where 170 | gGetMessageField msg fid = 171 | catch 172 | (L1 <$> gGetMessageField msg fid) 173 | (\ (_ :: SomeException) -> R1 <$> gGetMessageField msg fid) 174 | 175 | instance GetMessageField a => GGetMessageField (K1 i a) where 176 | gGetMessageField msg fid = 177 | K1 <$> getMessageField msg fid 178 | 179 | instance GGetMessageField U1 where 180 | gGetMessageField _ _ = return U1 181 | -------------------------------------------------------------------------------- /src/AlphaHeavy/QuickFIX/GSend.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module AlphaHeavy.QuickFIX.GSend where 9 | 10 | import Control.Monad (forM_) 11 | import Data.Char (chr) 12 | import Data.Proxy (Proxy(..)) 13 | import GHC.Generics 14 | import GHC.TypeLits (KnownNat, natVal) 15 | 16 | import AlphaHeavy.FIX as FIX 17 | import AlphaHeavy.QuickFIX.Foreign 18 | import AlphaHeavy.QuickFIX.Types 19 | import AlphaHeavy.QuickFIX.SetMessageField 20 | 21 | sendMessage 22 | :: (Generic a, GSendMessage (Rep a)) 23 | => String 24 | -> String 25 | -> a 26 | -> IO () 27 | sendMessage sender target = gSendMessage sender target . from 28 | 29 | sendMessage' 30 | :: forall a dir n . (Generic a, GSetMessageFields (Rep a), KnownNat n) 31 | => String 32 | -> String 33 | -> Message n dir a 34 | -> IO () 35 | sendMessage' senderCompID targetCompID (FIX.Message msg) = do 36 | let msgId = chr . fromIntegral $ natVal (Proxy :: Proxy n) 37 | sendMessageWithWrapper senderCompID targetCompID msgId $ \ h -> 38 | gSetMessageFields h (from msg) 39 | 40 | -- | 41 | -- Entry point, we're looking for 'Message' constructors with the message id 42 | -- and sending direction encoded as type parameters 43 | class GSendMessage (f :: * -> *) where 44 | gSendMessage :: String -> String -> f a -> IO () 45 | 46 | instance GSendMessage f => GSendMessage (M1 i c f) where 47 | gSendMessage sender target = gSendMessage sender target . unM1 48 | 49 | instance (GSendMessage a, GSendMessage b) => GSendMessage (a :+: b) where 50 | gSendMessage sender target (L1 x) = gSendMessage sender target x 51 | gSendMessage sender target (R1 x) = gSendMessage sender target x 52 | 53 | instance (GSendMessage a, GSendMessage b) => GSendMessage (a :*: b) where 54 | gSendMessage sender target (x :*: y) = do 55 | gSendMessage sender target x 56 | gSendMessage sender target y 57 | 58 | instance (Generic a, GSetMessageFields (Rep a), KnownNat n) => GSendMessage (K1 c (Message n dir a)) where 59 | gSendMessage sender target = sendMessage' sender target . unK1 60 | 61 | -- | 62 | -- Message field iteration. Find each 'Field' within the message and its 63 | -- associated field id 64 | class GSetMessageFields (f :: * -> *) where 65 | gSetMessageFields :: QuickFIXMessagePtr -> f a -> IO () 66 | 67 | instance GSetMessageFields f => GSetMessageFields (M1 i c f) where 68 | gSetMessageFields msg = gSetMessageFields msg . unM1 69 | 70 | instance (FieldTag a, KnownNat n, SetMessageField (FieldTagRep a)) => GSetMessageFields (K1 c (Enumeration n a)) where 71 | gSetMessageFields msg (K1 (Enumeration val)) = do 72 | let fieldId = fromIntegral $ natVal (Proxy :: Proxy n) 73 | setMessageField msg fieldId (toFieldTagRep val) 74 | 75 | instance (FieldTag a, KnownNat n, SetMessageField (FieldTagRep a)) => GSetMessageFields (K1 c (Maybe (Enumeration n a))) where 76 | gSetMessageFields msg (K1 (Just (Enumeration val))) = do 77 | let fieldId = fromIntegral $ natVal (Proxy :: Proxy n) 78 | setMessageField msg fieldId (toFieldTagRep val) 79 | 80 | gSetMessageFields _ (K1 Nothing) = 81 | return () 82 | 83 | instance (Generic a, GSetMessageField (Rep a), KnownNat n) => GSetMessageFields (K1 c (Maybe (Field n a))) where 84 | gSetMessageFields msg (K1 (Just (Field val))) = do 85 | let fieldId = fromIntegral $ natVal (Proxy :: Proxy n) 86 | gSetMessageField msg fieldId (from val) 87 | 88 | gSetMessageFields _ (K1 Nothing) = 89 | return () 90 | 91 | instance (Generic a, GSetMessageField (Rep a), KnownNat n) => GSetMessageFields (K1 c (Field n a)) where 92 | gSetMessageFields msg (K1 (Field val)) = do 93 | let fieldId = fromIntegral $ natVal (Proxy :: Proxy n) 94 | gSetMessageField msg fieldId (from val) 95 | 96 | instance (Generic a, GSetMessageFields (Rep a), KnownNat n) => GSetMessageFields (K1 c (Group n a)) where 97 | gSetMessageFields msg (K1 (Group xs@(_:_))) = do 98 | let fieldId = natVal (Proxy :: Proxy n) 99 | putStrLn $ "TODO: properly implement groups: " ++ show fieldId 100 | forM_ xs $ gSetMessageFields msg . from 101 | 102 | gSetMessageFields _ (K1 (Group [])) = 103 | return () 104 | 105 | instance GSetMessageFields U1 where 106 | gSetMessageFields _ _ = return () 107 | 108 | instance (GSetMessageFields a, GSetMessageFields b) => GSetMessageFields (a :*: b) where 109 | gSetMessageFields msg (x :*: y) = do 110 | gSetMessageFields msg x 111 | gSetMessageFields msg y 112 | 113 | instance (GSetMessageFields a, GSetMessageFields b) => GSetMessageFields (a :+: b) where 114 | gSetMessageFields msg (L1 x) = gSetMessageFields msg x 115 | gSetMessageFields msg (R1 x) = gSetMessageFields msg x 116 | 117 | -- | 118 | -- Now that we have the field id, set the value on the message 119 | class GSetMessageField f where 120 | gSetMessageField :: QuickFIXMessagePtr -> Int -> f a -> IO () 121 | 122 | instance GSetMessageField f => GSetMessageField (M1 i c f) where 123 | gSetMessageField msg fid = gSetMessageField msg fid . unM1 124 | 125 | instance (GSetMessageField a, GSetMessageField b) => GSetMessageField (a :*: b) where 126 | gSetMessageField msg fid (a :*: b) = do 127 | gSetMessageField msg fid a 128 | gSetMessageField msg fid b 129 | 130 | instance (GSetMessageField a, GSetMessageField b) => GSetMessageField (a :+: b) where 131 | gSetMessageField msg fid (L1 x) = gSetMessageField msg fid x 132 | gSetMessageField msg fid (R1 x) = gSetMessageField msg fid x 133 | 134 | instance SetMessageField a => GSetMessageField (K1 i a) where 135 | gSetMessageField msg fid = 136 | setMessageField msg fid . unK1 137 | 138 | instance GSetMessageField U1 where 139 | gSetMessageField _ _ _ = return () 140 | -------------------------------------------------------------------------------- /src/AlphaHeavy/QuickFIX/GetMessageField.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | 5 | module AlphaHeavy.QuickFIX.GetMessageField where 6 | 7 | import Control.Applicative 8 | import Control.Exception (throwIO) 9 | import Data.ByteString (ByteString) 10 | import Data.Int 11 | import Data.Time 12 | import GHC.Generics 13 | 14 | import AlphaHeavy.FIX as FIX 15 | import AlphaHeavy.QuickFIX.Foreign 16 | import AlphaHeavy.QuickFIX.Types 17 | 18 | class GetMessageField a where 19 | getMessageField :: QuickFIXMessagePtr -> Int -> IO a 20 | 21 | instance GetMessageField Bool where 22 | getMessageField msg fid = 23 | getBoolField msg (fromIntegral fid) 24 | 25 | instance GetMessageField Char where 26 | getMessageField msg fid = 27 | getCharField msg (fromIntegral fid) 28 | 29 | instance GetMessageField Int where 30 | getMessageField msg fid = 31 | fromIntegral <$> getIntField msg (fromIntegral fid) 32 | 33 | instance GetMessageField Int32 where 34 | getMessageField msg fid = 35 | getIntField msg (fromIntegral fid) 36 | 37 | instance GetMessageField Int64 where 38 | getMessageField msg fid = 39 | fromIntegral <$> getIntField msg (fromIntegral fid) 40 | 41 | instance GetMessageField Float where 42 | getMessageField msg fid = 43 | realToFrac <$> getDoubleField msg (fromIntegral fid) 44 | 45 | instance GetMessageField Double where 46 | getMessageField msg fid = 47 | getDoubleField msg (fromIntegral fid) 48 | 49 | instance GetMessageField String where 50 | getMessageField msg fid = 51 | getStringFieldCPS msg (fromIntegral fid) 52 | 53 | instance GetMessageField ByteString where 54 | getMessageField = error "no bytestring support yet" 55 | 56 | instance GetMessageField Data.Time.UTCTime where 57 | getMessageField msg fid = do 58 | txt <- getMessageField msg fid 59 | case parseTime defaultTimeLocale "%Y%m%d-%H:%M:%S" txt of 60 | Just val -> return $! val 61 | Nothing -> throwIO . IncorrectTagValue fid $ txt 62 | 63 | instance GetMessageField Decimal where 64 | getMessageField msg fid = 65 | read <$> getMessageField msg fid 66 | 67 | instance GetMessageField Exchange where 68 | getMessageField msg fid = do 69 | val <- getMessageField msg fid 70 | return $! case val of 71 | "O" -> Exchange_NASDAQ 72 | "N" -> Exchange_NYSE 73 | "SMART" -> Exchange_SMART 74 | _ -> Exchange_OTHER val 75 | 76 | instance GetMessageField (U1 x) where 77 | getMessageField _ _ = 78 | return U1 79 | -------------------------------------------------------------------------------- /src/AlphaHeavy/QuickFIX/SetMessageField.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TypeSynonymInstances #-} 3 | 4 | module AlphaHeavy.QuickFIX.SetMessageField where 5 | 6 | import Data.ByteString (ByteString) 7 | import Data.Int 8 | import GHC.Generics 9 | import Data.Time (UTCTime, defaultTimeLocale, formatTime) 10 | 11 | import AlphaHeavy.FIX as FIX 12 | import AlphaHeavy.QuickFIX.Foreign 13 | import AlphaHeavy.QuickFIX.Types 14 | 15 | class SetMessageField a where 16 | setMessageField :: QuickFIXMessagePtr -> Int -> a -> IO () 17 | 18 | instance SetMessageField Bool where 19 | setMessageField msg = 20 | setBoolField msg . fromIntegral 21 | 22 | instance SetMessageField Char where 23 | setMessageField msg = 24 | setCharField msg . fromIntegral 25 | 26 | instance SetMessageField Int where 27 | setMessageField msg fid = 28 | setIntField msg (fromIntegral fid) . fromIntegral 29 | 30 | instance SetMessageField Int32 where 31 | setMessageField msg = 32 | setIntField msg . fromIntegral 33 | 34 | instance SetMessageField Int64 where 35 | setMessageField msg fid = 36 | setIntField msg (fromIntegral fid) . fromIntegral 37 | 38 | instance SetMessageField Float where 39 | setMessageField msg fid = 40 | setDoubleField msg (fromIntegral fid) . realToFrac 41 | 42 | instance SetMessageField Double where 43 | setMessageField msg = 44 | setDoubleField msg . fromIntegral 45 | 46 | instance SetMessageField String where 47 | setMessageField msg = 48 | setStringFieldWrapper msg . fromIntegral 49 | 50 | instance SetMessageField ByteString where 51 | setMessageField = error "no bytestring support yet" 52 | 53 | instance SetMessageField Data.Time.UTCTime where 54 | setMessageField msg fid val = 55 | let -- Not everyone seems to like milliseconds so we'll leave those out for now 56 | val' = formatTime defaultTimeLocale "%0Y%m%d-%H:%M:%S" val 57 | 58 | in setMessageField msg fid (val' :: String) 59 | 60 | instance SetMessageField Decimal where 61 | setMessageField msg fid = 62 | setMessageField msg fid . show 63 | 64 | instance SetMessageField Exchange where 65 | setMessageField msg fid ex = 66 | setMessageField msg fid $! case ex of 67 | Exchange_NASDAQ -> "O" 68 | Exchange_NYSE -> "N" 69 | Exchange_SMART -> "SMART" 70 | Exchange_OTHER s -> s 71 | 72 | instance SetMessageField (U1 x) where 73 | setMessageField _ _ _ = 74 | return () 75 | -------------------------------------------------------------------------------- /src/AlphaHeavy/QuickFIX/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | module AlphaHeavy.QuickFIX.Types where 4 | 5 | import Control.Exception (Exception) 6 | import Control.Concurrent.STM 7 | import Data.Map (Map) 8 | import Data.Typeable (Typeable) 9 | import Foreign.Ptr (Ptr) 10 | 11 | import AlphaHeavy.FIX (FIXException) 12 | 13 | data EngineState 14 | = EngineStopped 15 | | EngineRunning 16 | 17 | data SessionState 18 | = SessionOpen 19 | | SessionClosed 20 | deriving Show 21 | 22 | data EngineManagement 23 | = SessionLogon SessionID 24 | | SessionLogout SessionID String 25 | | SessionDisconnect SessionID 26 | 27 | data ConduitApp = ConduitApp 28 | { conduitAppRecv :: TMVar (QuickFIXMessagePtr, Maybe FIXException -> IO ()) 29 | , conduitAppHalt :: TMVar () 30 | , conduitAppMgmt :: TChan EngineManagement 31 | , conduitAppStatus :: TVar EngineState 32 | , conduitAppSessions :: TVar (Map SessionID SessionState) 33 | } 34 | 35 | data QuickFIXMessage 36 | type QuickFIXMessagePtr = Ptr QuickFIXMessage 37 | 38 | newtype SessionID = Ptr Int deriving (Eq, Ord) 39 | 40 | data QuickFIXException = QuickFIXException String 41 | deriving (Show, Typeable) 42 | 43 | instance Exception QuickFIXException 44 | --------------------------------------------------------------------------------