module Network.Betfair
(
Credentials(..)
, HasCredentials(..)
, openBetfair
, closeBetfair
, Betfair()
, request
, Network.Betfair.Internal.Request()
, module Network.Betfair.Types )
where
import Control.Applicative
import Control.Concurrent
import Control.Lens hiding ( (.=) )
import Control.Monad.Catch
import Control.Monad.State.Strict
import Data.Aeson
import Data.ByteString ( ByteString )
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as BL
import qualified Data.ByteString.Lazy as BL
import Data.IORef
import Data.Monoid
import Data.Proxy
import Data.Text ( Text )
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Typeable
import Network.Betfair.Internal
import Network.Betfair.Types
import Network.HTTP.Client.OpenSSL
import OpenSSL.Session
import Pipes hiding ( Proxy )
import Pipes.HTTP as PH hiding ( Proxy )
import System.Mem.Weak
data Credentials = Credentials {
_username :: Text
, _password :: Text
, _certificatePrivateKeyFile :: FilePath
, _certificateCertificateFile :: FilePath
, _apiKey :: Text }
deriving ( Eq, Ord, Show, Read, Typeable )
makeClassy ''Credentials
data Work = Work !Url !JsonRPCQuery !(MVar (Either SomeException BL.ByteString))
deriving ( Eq, Typeable )
data JsonRPCQuery = JsonRPCQuery
{ params :: !Value
, methodName :: !Text }
deriving ( Eq, Show, Typeable )
newtype JsonRPC a = JsonRPC (Either APIException a)
data BetfairHandle = BetfairHandle
{ _betfairThread :: !ThreadId
, _workChannel :: !(MVar Work) }
makeClassy ''BetfairHandle
instance FromJSON a => FromJSON (JsonRPC a) where
parseJSON (Object v) = JsonRPC <$>
msum [ Right <$> v .: "result"
, do err <- v .: "error"
dt <- err .: "data"
exc <- dt .: "APINGException"
details <- exc .: "errorDetails"
code <- exc .: "errorCode"
return $ Left $ APIException details code ]
parseJSON _ = empty
instance ToJSON JsonRPCQuery where
toJSON (JsonRPCQuery {..}) =
object [ "jsonrpc" .= ("2.0" :: Text)
, "method" .= methodName
, "id" .= (1 :: Int)
, "params" .= params ]
newtype Betfair = Betfair (MVar (Maybe BetfairHandle))
deriving ( Eq, Typeable )
openBetfair :: MonadIO m => Credentials -> m Betfair
openBetfair credentials = liftIO $ mask_ $ do
semaphore <- newEmptyMVar
work_mvar <- newEmptyMVar
weak_mvar_mvar <- newEmptyMVar
bftid <- forkIOWithUnmask $ \unmask ->
flip catch (\CloseBetfair -> return ()) $ do
withOpenSSL $ do
weak_mvar <- takeMVar weak_mvar_mvar
finally
(unmask $ betfairConnection credentials semaphore work_mvar)
(deRefWeak weak_mvar >>= \case
Nothing -> return ()
Just mvar -> modifyMVar_ mvar $ \_ -> return Nothing)
let handle = BetfairHandle { _betfairThread = bftid
, _workChannel = work_mvar }
mvar <- newEmptyMVar
weak_mvar <- mkWeakMVar mvar $ closeBetfairHandle handle
putMVar weak_mvar_mvar weak_mvar
flip onException (killThread bftid) $
takeMVar semaphore >>= \case
Left err -> throwM err
Right _ -> do putMVar mvar (Just handle)
return $ Betfair mvar
withBetfair :: Betfair -> (BetfairHandle -> IO a) -> IO a
withBetfair (Betfair mvar) action = withMVar mvar $ \case
Nothing -> throwM BetfairIsClosed
Just bhandle -> action bhandle
work :: (FromJSON a) => Betfair -> Url -> JsonRPCQuery -> IO a
work bf url query = withBetfair bf $ \handle -> do
result <- newEmptyMVar
putMVar (_workChannel handle) $ Work url query result
takeMVar result >>= \case
Left exc -> throwM exc
Right result -> case decode result of
Nothing -> throwM $ ParsingFailure $ "Betfair behaved in unexpected way. Received raw string: " <> (T.pack $ show result)
Just (JsonRPC (Left exc)) -> throwM exc
Just (JsonRPC (Right x)) -> return x
betfairConnection :: Credentials
-> MVar (Either SomeException ())
-> MVar Work
-> IO ()
betfairConnection ~credentials@(Credentials{..}) semaphore work_mvar =
flip catch (\(e :: SomeException) -> putMVar semaphore (Left e)) $ do
ssl_context <- context
contextSetPrivateKeyFile ssl_context _certificatePrivateKeyFile
contextSetCertificateFile ssl_context _certificateCertificateFile
withManager (opensslManagerSettings $ return ssl_context) $ \m -> do
session_key <- obtainSessionKey credentials m
putMVar semaphore (Right ())
mask $ \restore -> do
keep_alive_tid <- forkIO $ restore $ forever $ do
replicateM_ (3600*10) $
threadDelay 1000000
keepAlive session_key credentials m
finally (restore $ workLoop session_key credentials m work_mvar)
(killThread keep_alive_tid)
workLoop :: SessionKey -> Credentials -> Manager -> MVar Work -> IO ()
workLoop session_key credentials m work_mvar = forever $ do
work <- takeMVar work_mvar
case work of
Work url sending result_mvar -> do
flip onException (tryPutMVar result_mvar $ Left $
toException BetfairIsClosed) $ do
workRateLimit
request <- betfairRequest session_key credentials sending url
withHTTP request m $ \response -> do
body <- readBodyLimited 50000000 response
putMVar result_mvar (Right body)
betfairRequest :: SessionKey
-> Credentials
-> JsonRPCQuery
-> Url
-> IO PH.Request
betfairRequest session_key (Credentials{..}) query url = do
req <- parseUrl url
return $ req { method = "POST"
, requestBody = RequestBodyBS $ BL.toStrict $ encode query
, requestHeaders = requestHeaders req <>
[ ("X-Application", T.encodeUtf8 _apiKey)
, ("X-Authentication", T.encodeUtf8 session_key)
, ("content-type", "application/json") ] }
keepAlive :: SessionKey -> Credentials -> Manager -> IO ()
keepAlive session_key (Credentials{..}) m = do
req' <- parseUrl "https://identitysso.betfair.com/api/keepAlive"
let req = req' { requestHeaders = requestHeaders req' <>
[ ("Accept", "application/json")
, ("X-Application", T.encodeUtf8 _apiKey)
, ("X-Authentication", T.encodeUtf8 session_key) ] }
withHTTP req m $ \response -> do
_ <- readBodyLimited 100000 response
return ()
obtainSessionKey :: Credentials
-> Manager
-> IO SessionKey
obtainSessionKey (Credentials{..}) m = do
req' <- parseUrl "https://identitysso.betfair.com/api/certlogin"
let req = urlEncodedBody [("username", T.encodeUtf8 _username)
,("password", T.encodeUtf8 _password)] $
req' { requestHeaders = requestHeaders req' <>
[ ("X-Application", T.encodeUtf8 _apiKey) ] }
withHTTP req m $ \response -> do
b <- readBodyLimited 1000000 response
case decode b of
Nothing -> throwM $ ParsingFailure "session key"
Just login_response -> case login_response of
LoginFailed reason -> throwM $ LoginFailure reason
LoginSuccessful session_key -> return session_key
readBodyLimited :: Int
-> Response (Producer ByteString IO ())
-> IO BL.ByteString
readBodyLimited max_bytes response = do
accumRef <- newIORef mempty
runEffect $ responseBody response >-> accumulator accumRef 0
BL.toLazyByteString <$> readIORef accumRef
where
accumulator accumRef builder_length = do
block <- await
accum <- liftIO $ readIORef accumRef
when (B.length block + builder_length > max_bytes) $
liftIO $ throwM TooMuchHTTPData
liftIO $ writeIORef accumRef (accum <> BL.byteString block)
accumulator accumRef (builder_length + B.length block)
data BetfairException
= TooMuchHTTPData
| ParsingFailure Text
| LoginFailure Text
| BetfairIsClosed
deriving ( Eq, Ord, Show, Read, Typeable )
instance Exception BetfairException
data CloseBetfair = CloseBetfair
deriving ( Eq, Ord, Show, Read, Typeable, Enum )
instance Exception CloseBetfair
closeBetfair :: MonadIO m => Betfair -> m ()
closeBetfair (Betfair mvar) = liftIO $ modifyMVar_ mvar $ \case
Nothing -> return Nothing
Just handle -> closeBetfairHandle handle >> return Nothing
closeBetfairHandle :: BetfairHandle -> IO ()
closeBetfairHandle (_betfairThread -> tid) = throwTo tid CloseBetfair
request :: forall a b m. (MonadIO m, Network.Betfair.Internal.Request a b)
=> a -> Betfair -> m b
request req bf = liftIO $
work bf (requestUrl (Proxy :: Proxy a))
(JsonRPCQuery { methodName = requestMethod (Proxy :: Proxy a)
, params = toJSON req })