Module implements Betfair Exchange API.

It uses free monad library Polysemy.

Below is an example program, that looks up next horse race, waits for it to go live, get closed, and then prints the winner of the race.

It uses:

• Betting API
• Heartbeat API
• Exchange Stream API

{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE OverloadedLabels    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}

module Main where

import           BfHaskell.DSL.Betting
import           BfHaskell.DSL.Heartbeat
import           BfHaskell.DSL.Login
import           BfHaskell.DSL.Streaming
import           BfHaskell.StreamingAPI.Model
import           Control.Lens
import           Control.Monad                (forM_, forever, when)
import           Control.Monad.IO.Class       (liftIO)
import qualified Data.Map                     as M
import           Data.Text                    (Text)
import qualified Data.Text                    as T
import           Data.Time                    (addUTCTime, getCurrentTime)
import           Polysemy
import           Polysemy.Async
import           Polysemy.Error
import           Polysemy.Output
import           Polysemy.Resource
import           Polysemy.State

type FullMarketDetails = (MarketId, JsonMarketCatalogue)

data AppState = Initial
              | HasRaceInFuture FullMarketDetails
              | RaceInPlay FullMarketDetails


-- | Finds next horse race going in-play
findNextRace :: Members '[Embed IO, BettingHandler] r
             => Text   -- ^ Event type id
             -> Sem r (Maybe JsonMarketCatalogue)
findNextRace eventTypeId = do
    currentTime <- liftIO getCurrentTime

    let dateUntil = addUTCTime (60 * 60 * 24 * 5) currentTime
        marketFilter = createMarketFilter eventTypeId
                                          (Just currentTime)
                                          (Just dateUntil)
                                          Nothing -- No competition specified
    JsonResponseListMarketCatalogue markets <- listMarkets marketFilter
    return $ markets ^? folded
                -- Only race in future
                . filteredBy (to _jmcatMarketStartTime . _Just . filtered (>currentTime))
                -- Only races going in play with type ODDS
                . filteredBy (to _jmcatDescription . _Just . filtered validMarketDescription)

  where
    validMarketDescription description =
        _jmdTurnInPlayEnabled description && _jmdBettingType description == ODDS

-- | Updates state according to market changes
processMarketUpdate :: Members '[Embed IO, StreamingHandler, BettingHandler, State AppState, Error String] r
                    => [MarketId]
                    -> M.Map MarketId MarketDetails
                    -> Sem r ()
processMarketUpdate marketIds cache = do
    state <- get
    case state of
        Initial -> return ()
                                                                                                                                                                                                                                                                                                                    [36/244]
        -- We are waiting for upcoming race to go live.
        -- If it went live, transition to next state: RaceInPlay
        HasRaceInFuture (marketId, market) ->
            -- Find actual market details from cache
            forM_ (M.lookup marketId cache) $ md -> do
                let inPlay = mdMarketDefinition . _Just . to marketDefinitionInPlay
                                                . _Just . only True
                -- Act only if there are changes on expected marketId
                when (elem marketId marketIds && has inPlay md) $ do
                    liftIO $ putStrLn $ T.unpack $ "Race in play: " <> _jmcatMarketName market
                    put $ RaceInPlay (marketId, market)

        -- Game is in play. Waiting for game to be closed
        -- Next state: HasRaceInFuture
        RaceInPlay (marketId, market) ->
            case M.lookup marketId cache of
                Just md -> do
                    let winner = md ^? mdMarketDefinition . _Just . to marketDefinitionRunners
                                    . _Just . folded
                                    . filteredBy (to runnerDefinitionStatus . _Just . only EStatus2WINNER)
                    forM_ winner $ rd -> do
                        forM_ (findRunnerName market $ runnerDefinitionId rd) $ winnerName ->
                            liftIO $ putStrLn $ T.unpack $ "Race winner: " <> winnerName

                        subsribeToNextGame

                -- Market already removed from cache. Move on to next race
                Nothing -> do
                    liftIO $ putStrLn $ T.unpack $ "Race is closed: " <> _jmcatMarketName market
                    subsribeToNextGame
  where
    -- | Find runner name in market catalogue
    findRunnerName market (Just runnerId) =
        market ^? to _jmcatRunners . _Just . folded
                . filteredBy (to _jrcSelectionId . only runnerId)
                . to _jrcRunnerName
    findRunnerName _ _ = Nothing

-- | Finds next race and subscribes to it
subsribeToNextGame :: Members '[Embed IO, StreamingHandler, BettingHandler, State AppState, Error String] r
                   => Sem r ()
subsribeToNextGame = do
    let eventTypeId = "7" -- Horse racing
    nextGame <- findNextRace eventTypeId
    case nextGame of
      Just market -> do
          forM_ (_jmcatMarketStartTime market) $ t ->
              liftIO $ putStrLn $ "Next race: '" <> T.unpack (_jmcatMarketName market)
                                <> "', starting at: " <> show t

          let marketId = _jmcatMarketId market
          -- Subscribe to market stream
          subscribeToMarkets $ mkMarketListFilter [marketId]
          -- Update state
          put $ HasRaceInFuture (marketId, market)
      Nothing -> throw "Failed to find next game"

-- | Stream message processing loop
followHorseRacing :: Members '[Embed IO, StreamingHandler, BettingHandler, State AppState, Error String] r
                  => Sem r ()
followHorseRacing = forever $ do
    msg <- getNextStreamMessage
    case msg of
      SMConnectionStateChanged SMCSConnected -> do
          liftIO $ putStrLn "Connected, gathering initial data..."
          subsribeToNextGame

      -- Match non empty list. Empty list means heartbeat message was received
      SMMarketUpdate marketIds@(_:_) ->
          getMarketCache >>= processMarketUpdate marketIds

      _ -> return ()

fetchLoginCredentials :: Members [Embed IO, Error String] r => Sem r LoginCredentials
fetchLoginCredentials =
    newLoginCredentials "John"                     -- Username
                        "Pass123"                  -- Password
                        "J7$q*cFQ[dxvCMJj"           -- App key
                        "public.pem"                 -- Public certificate
                        "private.pem"                -- Private key
                        (fromInteger $ 4 * 60 * 60)  -- Token timeout - 4 hours

main :: IO ()
main = do
    credsResult <- runM . runError $ fetchLoginCredentials
    case credsResult of
      Left err -> print err
      Right creds -> do
        res <- runFinal
             . embedToFinal
             . asyncToIOFinal
             . resourceToIOFinal
             . errorToIOFinal
             . ignoreOutput
             . evalState Initial
             . runLoginHandler creds Nothing
             . runStreamingHandler defaultStreamingConnectionInfo
             . runBettingHandler defaultBettingUrl Nothing
             . runHeartbeatHandler defaultHeartbeatUrl Nothing 60
             $ followHorseRacing
        either print (const $ pure ()) res

http://github.com/martinserts/bf-haskell