diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,6 @@ +v0.4.0.0 +* ExceptionResponse now holds the actual exception, rather than its text representation. BREAKING CHANGE. + v0.3.0.0 * Replaced Volkov records with (micro)lenses. BREAKING CHANGE. * Implemented a (naive) mechanism to work around nginx rate limiting. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -25,7 +25,7 @@ ErrorResponse err -> error $ "BitX error received: \"" ++ unpack (err ^. BitX.error) ++ "\"" ExceptionResponse ex -> - error $ "Exception was thrown: \"" ++ unpack ex ++ "\"" + error $ "Exception was thrown: \"" ++ show ex ++ "\"" UnparseableResponse resp -> error $ "Bad HTTP response; HTTP status code was: \"" ++ (show . statusCode . responseStatus $ resp) ++ "\"" ``` diff --git a/bitx-bitcoin.cabal b/bitx-bitcoin.cabal --- a/bitx-bitcoin.cabal +++ b/bitx-bitcoin.cabal @@ -1,5 +1,5 @@ name: bitx-bitcoin -version: 0.3.0.0 +version: 0.4.0.0 synopsis: A Haskell library for working with the BitX bitcoin exchange. description: @@ -59,12 +59,12 @@ Network.Bitcoin.BitX.Types.Internal build-depends: base >=4.5 && <5, - aeson >= 0.8.0.0, + aeson >= 0.8.0.1, text, time, http-conduit >= 2.0.0, - bytestring >= 0.10.0.0, - network >= 2.0, + bytestring, + network, split >= 0.2.0.0, scientific, microlens, @@ -94,7 +94,7 @@ main-is: Spec.hs default-language: Haskell2010 - build-depends: base == 4.*, + build-depends: base, bitx-bitcoin, hspec == 2.*, aeson, @@ -108,4 +108,3 @@ Network.Bitcoin.BitX.Spec.Specs.PostSpec Network.Bitcoin.BitX.Spec.Specs.JsonSpec Network.Bitcoin.BitX.Spec.Specs.LensSpec - diff --git a/src/Network/Bitcoin/BitX.hs b/src/Network/Bitcoin/BitX.hs --- a/src/Network/Bitcoin/BitX.hs +++ b/src/Network/Bitcoin/BitX.hs @@ -38,3 +38,5 @@ import Network.Bitcoin.BitX.Private.Withdrawal import Network.Bitcoin.BitX.Types.Internal import Network.Bitcoin.BitX.Response + +{-# ANN module ("HLint: ignore Use import/export shortcut" :: String) #-} diff --git a/src/Network/Bitcoin/BitX/Internal.hs b/src/Network/Bitcoin/BitX/Internal.hs --- a/src/Network/Bitcoin/BitX/Internal.hs +++ b/src/Network/Bitcoin/BitX/Internal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, DataKinds, CPP #-} +{-# LANGUAGE OverloadedStrings, DataKinds, CPP #-} module Network.Bitcoin.BitX.Internal ( @@ -23,7 +23,6 @@ import Data.Maybe (fromJust) import Network (withSocketsDo) import qualified Data.Text.Encoding as Txt -import qualified Data.Text as Txt import Network.Bitcoin.BitX.Response import Control.Applicative ((<|>)) import Lens.Micro ((^.)) @@ -46,39 +45,39 @@ authConnect :: BitXAuth -> Request -> IO (Either NetCon.HttpException (Response BL.ByteString)) authConnect auth req = do manager <- globalManager - try . (flip NetCon.httpLbs) manager . NetCon.applyBasicAuth userID userSecret $ req + try . flip NetCon.httpLbs manager . NetCon.applyBasicAuth userID userSecret $ req where - userID = Txt.encodeUtf8 $ (auth ^. Types.id) - userSecret = Txt.encodeUtf8 $ (auth ^. Types.secret) + userID = Txt.encodeUtf8 (auth ^. Types.id) + userSecret = Txt.encodeUtf8 (auth ^. Types.secret) -simpleBitXGetAuth_ :: BitXAesRecordConvert rec aes => BitXAuth -> String -> IO (BitXAPIResponse rec) -simpleBitXGetAuth_ auth verb = withSocketsDo $ do +simpleBitXGetAuth_ :: BitXAesRecordConvert recd aes => BitXAuth -> String -> IO (BitXAPIResponse recd) +simpleBitXGetAuth_ auth verb = withSocketsDo $ rateLimit (authConnect auth . fromJust . NetCon.parseUrl $ (bitXAPIRoot ++ verb)) consumeResponseIO -simpleBitXPOSTAuth_ :: (BitXAesRecordConvert rec aes, POSTEncodeable inprec) => BitXAuth -> inprec - -> String -> IO (BitXAPIResponse rec) -simpleBitXPOSTAuth_ auth encrec verb = withSocketsDo $ do +simpleBitXPOSTAuth_ :: (BitXAesRecordConvert recd aes, POSTEncodeable inprec) => BitXAuth -> inprec + -> String -> IO (BitXAPIResponse recd) +simpleBitXPOSTAuth_ auth encrec verb = withSocketsDo $ rateLimit (authConnect auth . NetCon.urlEncodedBody (postEncode encrec) . fromJust . NetCon.parseUrl $ (bitXAPIRoot ++ verb)) consumeResponseIO -simpleBitXMETHAuth_ :: BitXAesRecordConvert rec aes => BitXAuth -> BS.ByteString - -> String -> IO (BitXAPIResponse rec) -simpleBitXMETHAuth_ auth meth verb = withSocketsDo $ do +simpleBitXMETHAuth_ :: BitXAesRecordConvert recd aes => BitXAuth -> BS.ByteString + -> String -> IO (BitXAPIResponse recd) +simpleBitXMETHAuth_ auth meth verb = withSocketsDo $ rateLimit - (authConnect auth (fromJust (NetCon.parseUrl $ (bitXAPIRoot ++ verb))) { method = meth }) + (authConnect auth (fromJust (NetCon.parseUrl (bitXAPIRoot ++ verb))) { method = meth }) consumeResponseIO -simpleBitXGet_ :: BitXAesRecordConvert rec aes => String -> IO (BitXAPIResponse rec) +simpleBitXGet_ :: BitXAesRecordConvert recd aes => String -> IO (BitXAPIResponse recd) simpleBitXGet_ verb = withSocketsDo $ do manager <- globalManager rateLimit - (try . (flip NetCon.httpLbs) manager . fromJust . NetCon.parseUrl $ (bitXAPIRoot ++ verb)) + (try . flip NetCon.httpLbs manager . fromJust . NetCon.parseUrl $ (bitXAPIRoot ++ verb)) consumeResponseIO rateLimit :: IO (Either NetCon.HttpException c) -> (Either NetCon.HttpException c -> IO d) -> IO d @@ -86,24 +85,25 @@ where go del = do resp <- act1 - if isRateLimited resp then + if isRateLimited resp then do + putStrLn ("Rate limited: " ++ show del) if del > maxLimit then act2 resp else do threadDelay del go (incDelay del) else act2 resp - maxLimit = (30 * 1000 * 1000) -- 30 seconds probably means something else is wrong... + maxLimit = 5 * 1000 * 1000 -- 5 seconds probably means something else is wrong... incDelay = round . (* (1.5 :: Double)) . fromIntegral -consumeResponseIO :: BitXAesRecordConvert rec aes => Either NetCon.HttpException (NetCon.Response BL.ByteString) - -> IO (BitXAPIResponse rec) +consumeResponseIO :: BitXAesRecordConvert recd aes => Either NetCon.HttpException (NetCon.Response BL.ByteString) + -> IO (BitXAPIResponse recd) consumeResponseIO resp = return $ case resp of - Left ex -> ExceptionResponse . Txt.pack . show $ ex + Left ex -> ExceptionResponse ex Right k -> bitXErrorOrPayload k -bitXErrorOrPayload :: BitXAesRecordConvert rec aes => Response BL.ByteString -> BitXAPIResponse rec +bitXErrorOrPayload :: BitXAesRecordConvert recd aes => Response BL.ByteString -> BitXAPIResponse recd bitXErrorOrPayload resp = fromJust $ ErrorResponse . aesToRec <$> Aeson.decode body -- is it a BitX error? <|> ValidResponse . aesToRec <$> Aeson.decode body diff --git a/src/Network/Bitcoin/BitX/Private.hs b/src/Network/Bitcoin/BitX/Private.hs --- a/src/Network/Bitcoin/BitX/Private.hs +++ b/src/Network/Bitcoin/BitX/Private.hs @@ -80,6 +80,8 @@ import Network.Bitcoin.BitX.Private.Quote import Network.Bitcoin.BitX.Private.Withdrawal +{-# ANN module ("HLint: ignore Use import/export shortcut" :: String) #-} + {- | Create an additional account for the specified currency Note that the 'id' field of the second parameter can be left blank. The call will return an `Account` diff --git a/src/Network/Bitcoin/BitX/Private/Quote.hs b/src/Network/Bitcoin/BitX/Private/Quote.hs --- a/src/Network/Bitcoin/BitX/Private/Quote.hs +++ b/src/Network/Bitcoin/BitX/Private/Quote.hs @@ -95,4 +95,3 @@ discardQuote :: BitXAuth -> Text -> IO (BitXAPIResponse OrderQuote) discardQuote auth qid = simpleBitXMETHAuth_ auth "DELETE" $ "quotes/" ++ Txt.unpack qid - diff --git a/src/Network/Bitcoin/BitX/Public.hs b/src/Network/Bitcoin/BitX/Public.hs --- a/src/Network/Bitcoin/BitX/Public.hs +++ b/src/Network/Bitcoin/BitX/Public.hs @@ -30,7 +30,7 @@ -- ErrorResponse err -> -- error $ "BitX error received: \\"" ++ unpack (err ^. BitX.error) ++ "\\"" -- ExceptionResponse ex -> --- error $ "Exception was thrown: \\"" ++ unpack ex ++ "\\"" +-- error $ "Exception was thrown: \\"" ++ show ex ++ "\\"" -- UnparseableResponse resp -> -- error $ "Bad HTTP response; HTTP status code was: \\"" ++ (show . statusCode . responseStatus $ resp) ++ "\\"" -- @ @@ -71,4 +71,3 @@ getTrades :: CcyPair -> IO (BitXAPIResponse [Trade]) getTrades cyp = simpleBitXGet_ $ "trades?pair=" ++ show cyp - diff --git a/src/Network/Bitcoin/BitX/Response.hs b/src/Network/Bitcoin/BitX/Response.hs --- a/src/Network/Bitcoin/BitX/Response.hs +++ b/src/Network/Bitcoin/BitX/Response.hs @@ -19,21 +19,18 @@ BitXAPIResponse(..) ) where -import Network.HTTP.Conduit (Response(..)) +import Network.HTTP.Conduit (Response(..), HttpException) import Data.ByteString.Lazy (ByteString) import Network.Bitcoin.BitX.Types -import Data.Text (Text) -- | This retun type enumerates all possible failure modes. -data BitXAPIResponse rec = - ExceptionResponse Text -- ^ Some exception occured while making the call to BitX, and this was - -- the exception text. +data BitXAPIResponse recd = + ExceptionResponse HttpException -- ^ Some exception occured while making the call to BitX. | ErrorResponse BitXError -- ^ BitX returned an error record instead of returning the data we -- were expecting. - | ValidResponse rec -- ^ We received the data type we were expecting. + | ValidResponse recd -- ^ We received the data type we were expecting. | UnparseableResponse (Response ByteString) -- ^ BitX retuned data which couldn't be parsed, -- such as some text which was probably not JSON format. -deriving instance Show rec => Show (BitXAPIResponse rec) -deriving instance Eq rec => Eq (BitXAPIResponse rec) +deriving instance Show recd => Show (BitXAPIResponse recd) diff --git a/src/Network/Bitcoin/BitX/Types/Internal.hs b/src/Network/Bitcoin/BitX/Types/Internal.hs --- a/src/Network/Bitcoin/BitX/Types/Internal.hs +++ b/src/Network/Bitcoin/BitX/Types/Internal.hs @@ -31,17 +31,19 @@ import Data.Coerce #endif +{-# ANN module ("HLint: ignore Use camelCase" :: String) #-} + timestampParse_ :: Integer -> UTCTime timestampParse_ = posixSecondsToUTCTime . realToFrac . ( / 1000) . (fromIntegral :: Integer -> Scientific) -class (FromJSON aes) => BitXAesRecordConvert rec aes | rec -> aes where - aesToRec :: aes -> rec +class (FromJSON aes) => BitXAesRecordConvert recd aes | recd -> aes where + aesToRec :: aes -> recd -class POSTEncodeable rec where - postEncode :: rec -> [(ByteString, ByteString)] +class POSTEncodeable recd where + postEncode :: recd -> [(ByteString, ByteString)] showableToBytestring_ :: (Show a) => a -> ByteString @@ -171,8 +173,8 @@ instance BitXAesRecordConvert Types.Order Order_ where aesToRec (Order_ {..}) = - Types.Order {orderVolume = (qsToScientific order'volume), - orderPrice = (qsToScientific order'price)} + Types.Order {orderVolume = qsToScientific order'volume, + orderPrice = qsToScientific order'price} -------------------------------------------- Orderbook type ---------------------------------------- @@ -190,9 +192,9 @@ instance BitXAesRecordConvert Types.Orderbook Orderbook_ where aesToRec (Orderbook_ {..}) = - Types.Orderbook {orderbookTimestamp = (tsmsToUTCTime orderbook'timestamp), - orderbookBids = (map aesToRec orderbook'bids), - orderbookAsks = (map aesToRec orderbook'asks)} + Types.Orderbook {orderbookTimestamp = tsmsToUTCTime orderbook'timestamp, + orderbookBids = map aesToRec orderbook'bids, + orderbookAsks = map aesToRec orderbook'asks} -------------------------------------------- Trade type -------------------------------------------- @@ -207,9 +209,9 @@ instance BitXAesRecordConvert Types.Trade Trade_ where aesToRec (Trade_ {..}) = - Types.Trade { tradeTimestamp = (tsmsToUTCTime trade'timestamp), - tradeVolume = (qsToScientific trade'volume), - tradePrice = (qsToScientific trade'price) } + Types.Trade { tradeTimestamp = tsmsToUTCTime trade'timestamp, + tradeVolume = qsToScientific trade'volume, + tradePrice = qsToScientific trade'price } ----------------------------------------- PublicTrades type ---------------------------------------- diff --git a/test/Network/Bitcoin/BitX/Spec/Common.hs b/test/Network/Bitcoin/BitX/Spec/Common.hs --- a/test/Network/Bitcoin/BitX/Spec/Common.hs +++ b/test/Network/Bitcoin/BitX/Spec/Common.hs @@ -8,5 +8,5 @@ import Network.Bitcoin.BitX (BitXAesRecordConvert(..)) import Data.ByteString.Lazy (ByteString) -recordAesCheck :: (BitXAesRecordConvert rec aes, Show rec, Eq rec) => ByteString -> rec -> Expectation -recordAesCheck aesTxt recd = (fmap aesToRec $ decode aesTxt) `shouldBe` Just recd +recordAesCheck :: (BitXAesRecordConvert recd aes, Show recd, Eq recd) => ByteString -> recd -> Expectation +recordAesCheck aesTxt recd = fmap aesToRec (decode aesTxt) `shouldBe` Just recd diff --git a/test/Network/Bitcoin/BitX/Spec/Specs/LensSpec.hs b/test/Network/Bitcoin/BitX/Spec/Specs/LensSpec.hs --- a/test/Network/Bitcoin/BitX/Spec/Specs/LensSpec.hs +++ b/test/Network/Bitcoin/BitX/Spec/Specs/LensSpec.hs @@ -11,6 +11,8 @@ import Network.Bitcoin.BitX.Types import Data.Time.Clock.POSIX +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + spec :: Spec spec = describe "Lens functionality test" $ diff --git a/test/Network/Bitcoin/BitX/Spec/Specs/NetSpec.hs b/test/Network/Bitcoin/BitX/Spec/Specs/NetSpec.hs --- a/test/Network/Bitcoin/BitX/Spec/Specs/NetSpec.hs +++ b/test/Network/Bitcoin/BitX/Spec/Specs/NetSpec.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, QuasiQuotes, DataKinds, TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings, DataKinds #-} module Network.Bitcoin.BitX.Spec.Specs.NetSpec ( @@ -12,20 +12,20 @@ import Network.Bitcoin.BitX.Response spec :: Spec -spec = do +spec = describe "Public BitX connectivity" $ do - it "getTicker connects to BitX and works" $ do + it "getTicker connects to BitX and works" $ connectsAndParsesOkay $ getTicker XBTZAR - it "getTickers connects to BitX and works" $ do - connectsAndParsesOkay $ getTickers - it "getOrderBook connects to BitX and works" $ do + it "getTickers connects to BitX and works" $ + connectsAndParsesOkay getTickers + it "getOrderBook connects to BitX and works" $ connectsAndParsesOkay $ getOrderBook XBTZAR - it "getTrades connects to BitX and works" $ do + it "getTrades connects to BitX and works" $ connectsAndParsesOkay $ getTrades XBTKES -connectsAndParsesOkay :: IO (BitXAPIResponse rec) -> Bool +connectsAndParsesOkay :: IO (BitXAPIResponse recd) -> Bool connectsAndParsesOkay = isValidResponse . unsafePerformIO -isValidResponse :: BitXAPIResponse rec -> Bool +isValidResponse :: BitXAPIResponse recd -> Bool isValidResponse (ValidResponse _) = True isValidResponse _ = False