Skip to content

Instantly share code, notes, and snippets.

@taktoa

taktoa/BittrexAPI.hs

Created January 21, 2018 18:31
Show Gist options
  • Save taktoa/5748e211a95f150e030326a1b606f451 to your computer and use it in GitHub Desktop.
Save taktoa/5748e211a95f150e030326a1b606f451 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
BittrexAPI.hs
--------------------------------------------------------------------------------
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
module BittrexAPI where
--------------------------------------------------------------------------------
import Data.Aeson ((.:), (.=))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import qualified Data.Aeson.BetterErrors as AesonBE
import Data.Scientific (Scientific)
import Data.Int
import Data.Word
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import qualified Data.UUID as UUID
--------------------------------------------------------------------------------
import Control.Monad.Catch
import qualified Control.Monad.Reader.Class as MonadReader
--------------------------------------------------------------------------------
import Servant ((:<|>) ((:<|>)), (:>))
import qualified Servant as S
import qualified Servant.Client as S
import qualified Servant.Docs as S
import qualified Servant.Server as S
import qualified Servant.Server.Internal as S.Internal
import qualified Network.Wai as WAI
--------------------------------------------------------------------------------
import qualified Composite as Comp
import qualified Composite.Aeson as Comp
import Composite.Record
(pattern (:*:), (:->), Rec (RNil), Record)
--------------------------------------------------------------------------------
import Control.DeepSeq (NFData)
import Data.Binary (Binary)
import Data.Data (Data)
import Data.Hashable (Hashable)
import Foreign.Storable (Storable)
import GHC.Generics (Generic)
import System.Random (Random)
import Data.Kind (Constraint, Type)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import GHC.TypeLits
(ErrorMessage ((:$$:), (:<>:), ShowType, Text), TypeError)
import Data.Proxy (Proxy (Proxy))
--------------------------------------------------------------------------------
import Data.Maybe
import Data.Monoid
import Data.Foldable (asum)
import Flow
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- SERVANT API TYPES -----------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
getMarkets :: S.ClientM (Response (Vector Market))
getCurrencies :: S.ClientM (Response (Vector Currency))
getTicker :: Req MarketName
-> S.ClientM (Response Ticker)
getMarketSummaries :: S.ClientM (Response (Vector MarketSummary))
getMarketSummary :: Req MarketName
-> S.ClientM (Response (List1 MarketSummary))
getOrderBook :: Req MarketName
-> Req OrderBookType
-> S.ClientM (Response OrderBook)
getMarketHistory :: Req MarketName
-> S.ClientM (Response (Vector Trade))
buyLimit :: Req APIKey
-> Req MarketName
-> Req Quantity
-> Req Quantity
-> S.ClientM (Response OrderUUID)
sellLimit :: Req APIKey
-> Req MarketName
-> Req Quantity
-> Req Quantity
-> S.ClientM (Response OrderUUID)
cancel :: Req APIKey
-> Req UUID
-> S.ClientM (Response Null)
getOpenOrders :: Req APIKey
-> Opt MarketName
-> S.ClientM (Response (Vector OpenOrder))
getBalances :: Req APIKey
-> S.ClientM (Response (Vector Balance))
getBalance :: Req APIKey
-> Req SCurrencyName
-> S.ClientM (Response Balance)
getDepositAddress :: Req APIKey
-> Req SCurrencyName
-> S.ClientM (Response DepositAddress)
withdraw :: Req APIKey
-> Req SCurrencyName
-> Req Quantity
-> Req Text
-> Opt Text
-> S.ClientM (Response WithdrawalUUID)
getOrder :: Req APIKey
-> Req UUID
-> S.ClientM (Response OrderDetail)
getOrderHistory :: Req APIKey
-> Opt MarketName
-> S.ClientM (Response ClosedOrder)
getWithdrawalHistory :: Req APIKey
-> Opt SCurrencyName
-> S.ClientM (Response (Vector Withdrawal))
getDepositHistory :: Req APIKey
-> Opt SCurrencyName
-> S.ClientM (Response (Vector Deposit))
( ( getMarkets
:<|> getCurrencies
:<|> getTicker
:<|> getMarketSummaries
:<|> getMarketSummary
:<|> getOrderBook
:<|> getMarketHistory
)
:<|> ( buyLimit
:<|> sellLimit
:<|> cancel
:<|> getOpenOrders
)
:<|> ( getBalances
:<|> getBalance
:<|> getDepositAddress
:<|> withdraw
:<|> getOrder
:<|> getOrderHistory
:<|> getWithdrawalHistory
:<|> getDepositHistory
)
) = S.client (Proxy @API)
type Req a = a
type Opt a = Maybe a
--------------------------------------------------------------------------------
type API
= ( ("public" :> PublicAPI)
:<|> ("market" :> MarketAPI)
:<|> ("account" :> AccountAPI)
)
type PublicAPI
= ( ("getmarkets"
:> BGet (Vector Market))
:<|> ("getcurrencies"
:> BGet (Vector Currency))
:<|> ("getticker"
:> ReqQP "market" MarketName
:> BGet Ticker)
:<|> ("getmarketsummaries"
:> BGet (Vector MarketSummary))
:<|> ("getmarketsummary"
:> ReqQP "market" MarketName
:> BGet (List1 MarketSummary))
:<|> ("getorderbook"
:> ReqQP "market" MarketName
:> ReqQP "type" OrderBookType
:> BGet OrderBook)
:<|> ("getmarkethistory"
:> ReqQP "market" MarketName
:> BGet (Vector Trade))
)
type MarketAPI
= ( ("buylimit"
:> WithAPIKey
:> ReqQP "market" MarketName
:> ReqQP "quantity" Quantity
:> ReqQP "rate" Quantity
:> BGet OrderUUID)
:<|> ("selllimit"
:> WithAPIKey
:> ReqQP "market" MarketName
:> ReqQP "quantity" Quantity
:> ReqQP "rate" Quantity
:> BGet OrderUUID)
:<|> ("cancel"
:> WithAPIKey
:> ReqQP "uuid" UUID
:> BGet Null)
:<|> ("getopenorders"
:> WithAPIKey
:> OptQP "market" MarketName
:> BGet (Vector OpenOrder))
)
type AccountAPI
= ( ("getbalances"
:> WithAPIKey
:> BGet (Vector Balance))
:<|> ("getbalance"
:> WithAPIKey
:> ReqQP "currency" SCurrencyName
:> BGet Balance)
:<|> ("getdepositaddress"
:> WithAPIKey
:> ReqQP "currency" SCurrencyName
:> BGet DepositAddress)
:<|> ("withdraw"
:> WithAPIKey
:> ReqQP "currency" SCurrencyName
:> ReqQP "quantity" Quantity
:> ReqQP "address" Text -- FIXME
:> OptQP "paymentid" Text -- FIXME
:> BGet WithdrawalUUID)
:<|> ("getorder"
:> WithAPIKey
:> ReqQP "uuid" UUID
:> BGet OrderDetail)
:<|> ("getorderhistory"
:> WithAPIKey
:> OptQP "market" MarketName
:> BGet ClosedOrder)
:<|> ("getwithdrawalhistory"
:> WithAPIKey
:> OptQP "currency" SCurrencyName
:> BGet (Vector Withdrawal))
:<|> ("getdeposithistory"
:> WithAPIKey
:> OptQP "currency" SCurrencyName
:> BGet (Vector Deposit))
)
--------------------------------------------------------------------------------
type BGet t = S.Get '[JSONBE] (Response t)
type OptQP param ty = S.QueryParam param ty
type ReqQP param ty = ReqQueryParam param ty
type WithAPIKey = ReqQP "apikey" APIKey
type APIKey = Text
--------------------------------------------------------------------------------
-- Switch to https://github.com/haskell-servant/servant/pull/873
-- once it is merged and upstreamed.
-- That will give us a HasServer instance and a better HasDocs instance.
type role ReqQueryParam phantom phantom
data ReqQueryParam (sym :: Symbol) a
instance ( KnownSymbol sym, S.ToParam (S.QueryParam sym v), S.HasDocs api
) => S.HasDocs (ReqQueryParam sym v :> api) where
docsFor _ = S.docsFor (Proxy @(S.QueryParam sym v :> api))
instance ( KnownSymbol sym, S.ToHttpApiData v, S.HasClient api
) => S.HasClient (ReqQueryParam sym v :> api) where
type Client (ReqQueryParam sym v :> api) = (v -> S.Client api)
clientWithRoute _ r v
= S.clientWithRoute (Proxy @(S.QueryParam sym v :> api)) r (Just v)
instance ( KnownSymbol sym, S.ToHttpApiData v, S.HasLink api
) => S.HasLink (ReqQueryParam sym v :> api) where
type MkLink (ReqQueryParam sym v :> api) = (v -> S.MkLink api)
toLink _ l v = S.toLink (Proxy @(S.QueryParam sym v :> api)) l (Just v)
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- GENERAL API DATA TYPES ------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
data Null
= Null
deriving (Eq, Ord, Show, Read, Generic)
instance Hashable Null
instance ParseJSON Null where
parseJSON = AesonBE.asNull >> pure Null
instance Aeson.ToJSON Null where
toJSON Null = Aeson.Null
--------------------------------------------------------------------------------
data List1 t
= List1 t
deriving (Eq, Ord, Show, Read, Generic)
instance (Hashable t) => Hashable (List1 t)
instance (ParseJSON t) => ParseJSON (List1 t) where
parseJSON = do
xs <- AesonBE.eachInArray parseJSON
case xs of
[x] -> pure (List1 x)
_ -> Text.pack ("List1: wrong size of list: " <> show (length xs))
|> JSONParseError |> AesonBE.throwCustomError
instance (Aeson.ToJSON t) => Aeson.ToJSON (List1 t) where
toJSON (List1 t) = Aeson.toJSON [t]
--------------------------------------------------------------------------------
newtype UUID
= UUID { getUUID :: UUID.UUID }
deriving (Eq, Ord, Read, Show, Storable, Binary, NFData, Hashable, Random)
printUUID :: UUID -> Text
printUUID = getUUID .> UUID.toText
parseUUID :: Text -> Maybe UUID
parseUUID = UUID.fromText .> fmap UUID
instance ParseJSON UUID where
parseJSON = do
t <- AesonBE.asText
let err = Text.pack ("UUID: failed to parse: " <> show t)
|> JSONParseError |> AesonBE.throwCustomError
parseUUID t |> maybe err pure
instance Aeson.ToJSON UUID where
toJSON = printUUID .> Aeson.toJSON
instance S.ToHttpApiData UUID where
toQueryParam = printUUID
instance S.FromHttpApiData UUID where
parseQueryParam t = parseUUID t
|> maybe (Left ("error parsing UUID: " <> t)) Right
--------------------------------------------------------------------------------
-- "2014-02-13T00:00:00"
type TimeStamp = Text -- FIXME: use proper timestamp type
--------------------------------------------------------------------------------
newtype Quantity
= Quantity { fromQuantity :: Scientific }
deriving ( Eq, Ord, Num, Show, Read, Generic
, Aeson.ToJSON, Aeson.FromJSON )
instance ParseJSON Quantity where
parseJSON = Quantity <$> parseJSON
instance S.ToHttpApiData Quantity where
toQueryParam = fromQuantity .> show .> Text.pack
instance S.FromHttpApiData Quantity where
parseQueryParam t = Text.encodeUtf8 ("\"" <> t <> "\"")
|> LBS.fromStrict
|> Aeson.decode
|> fmap Quantity
|> maybe (Left ("error parsing Quantity: " <> t)) Right
--------------------------------------------------------------------------------
type Response t
= Record '[ "success" :-> Bool
, "message" :-> Text
, "result" :-> t
]
--------------------------------------------------------------------------------
type SCurrencyName = Text -- "LTC"
type LCurrencyName = Text -- "Litecoin"
--------------------------------------------------------------------------------
-- "BTC-LTC"
data MarketName
= MarketName
{ _MarketName_base :: SCurrencyName -- "BTC"
, _MarketName_market :: SCurrencyName -- "LTC"
}
deriving ()
printMarketName :: MarketName -> Text
printMarketName (MarketName b m) = b <> "-" <> m
parseMarketName :: Text -> Maybe MarketName
parseMarketName t = case Text.split (== '-') t of
[b, m] -> Just (MarketName b m)
_ -> Nothing
instance ParseJSON MarketName where
parseJSON = do
t <- AesonBE.asText
let err = Text.pack ("MarketName: failed to parse: " <> show t)
|> JSONParseError |> AesonBE.throwCustomError
parseMarketName t |> maybe err pure
instance Aeson.ToJSON MarketName where
toJSON mn = Aeson.String (printMarketName mn)
instance S.ToHttpApiData MarketName where
toQueryParam = printMarketName
instance S.FromHttpApiData MarketName where
parseQueryParam t
= parseMarketName t
|> maybe (Left ("MarketName: failed to parse: " <> t)) Right
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- PUBLIC API DATA TYPES -------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
type Market
= Record '[ "MarketCurrency" :-> SCurrencyName -- "LTC"
, "BaseCurrency" :-> SCurrencyName -- "BTC"
, "MarketCurrencyLong" :-> LCurrencyName -- "Litecoin"
, "BaseCurrencyLong" :-> LCurrencyName -- "Bitcoin"
, "MinTradeSize" :-> Quantity
, "MarketName" :-> MarketName -- "BTC-LTC"
, "IsActive" :-> Bool
, "Created" :-> TimeStamp
]
--------------------------------------------------------------------------------
type Currency
= Record '[ "Currency" :-> SCurrencyName -- "BTC"
, "CurrencyLong" :-> LCurrencyName -- "Bitcoin"
, "MinConfirmation" :-> Word64
, "TxFee" :-> Quantity -- 0.00020000
, "IsActive" :-> Bool
, "CoinType" :-> Text -- "BITCOIN"
, "BaseAddress" :-> Null -- null?
]
--------------------------------------------------------------------------------
type Ticker
= Record '[ "Bid" :-> Quantity
, "Ask" :-> Quantity
, "Last" :-> Quantity
]
--------------------------------------------------------------------------------
type MarketSummary
= Record '[ "MarketName" :-> MarketName -- "BTC-LTC"
, "High" :-> Quantity
, "Low" :-> Quantity
, "Volume" :-> Quantity
, "Last" :-> Quantity
, "BaseVolume" :-> Quantity
, "TimeStamp" :-> TimeStamp
, "Bid" :-> Quantity
, "Ask" :-> Quantity
, "OpenBuyOrders" :-> Word64
, "OpenSellOrders" :-> Word64
, "PrevDay" :-> Quantity
, "Created" :-> TimeStamp
, "DisplayMarketName" :-> Null -- null?
]
--------------------------------------------------------------------------------
type OrderBook
= Record '[ "buy" :-> Vector BuyOrder
, "sell" :-> Vector SellOrder
]
--------------------------------------------------------------------------------
type BuyOrder = Order
type SellOrder = Order
--------------------------------------------------------------------------------
data OrderBookType
= OrderBookType_buy
| OrderBookType_sell
| OrderBookType_both
printOrderBookType :: OrderBookType -> Text
printOrderBookType OrderBookType_buy = "buy"
printOrderBookType OrderBookType_sell = "sell"
printOrderBookType OrderBookType_both = "both"
parseOrderBookType :: Text -> Maybe OrderBookType
parseOrderBookType "buy" = Just OrderBookType_buy
parseOrderBookType "sell" = Just OrderBookType_sell
parseOrderBookType "both" = Just OrderBookType_both
parseOrderBookType _ = Nothing
instance ParseJSON OrderBookType where
parseJSON = do
t <- AesonBE.asText
let err = Text.pack ("OrderBookType: failed to parse: " <> show t)
|> JSONParseError |> AesonBE.throwCustomError
parseOrderBookType t |> maybe err pure
instance PrintJSON OrderBookType where
printJSON = printOrderBookType .> printJSON
instance S.ToHttpApiData OrderBookType where
toQueryParam = printOrderBookType
instance S.FromHttpApiData OrderBookType where
parseQueryParam t
= parseOrderBookType t
|> maybe (Left ("OrderBookType: failed to parse: " <> t)) Right
--------------------------------------------------------------------------------
type Order
= Record '[ "Quantity" :-> Quantity
, "Rate" :-> Quantity
]
--------------------------------------------------------------------------------
type Trade
= Record '[ "Id" :-> Word64
, "TimeStamp" :-> TimeStamp
, "Quantity" :-> Quantity
, "Price" :-> Quantity
, "Total" :-> Quantity
, "FillType" :-> FillType
, "OrderType" :-> OrderType
]
--------------------------------------------------------------------------------
data FillType
= FillType_FILL
| FillType_PARTIAL_FILL
-- FIXME: are there more options?
deriving ()
printFillType :: FillType -> Text
printFillType FillType_FILL = "FILL"
printFillType FillType_PARTIAL_FILL = "PARTIAL_FILL"
parseFillType :: Text -> Maybe FillType
parseFillType "FILL" = Just FillType_FILL
parseFillType "PARTIAL_FILL" = Just FillType_PARTIAL_FILL
parseFillType _ = Nothing
instance ParseJSON FillType where
parseJSON = do
t <- AesonBE.asText
parseFillType t
|> maybe (fail "FIXME: improve this error") pure
instance PrintJSON FillType where
printJSON = printFillType .> Aeson.toJSON
--------------------------------------------------------------------------------
data OrderType
= OrderType_BUY
| OrderType_SELL
| OrderType_LIMIT_BUY
| OrderType_LIMIT_SELL
-- FIXME: are there more options?
deriving ()
printOrderType :: OrderType -> Text
printOrderType OrderType_BUY = "BUY"
printOrderType OrderType_SELL = "SELL"
printOrderType OrderType_LIMIT_BUY = "LIMIT_BUY"
printOrderType OrderType_LIMIT_SELL = "LIMIT_SELL"
parseOrderType :: Text -> Maybe OrderType
parseOrderType "BUY" = Just OrderType_BUY
parseOrderType "SELL" = Just OrderType_SELL
parseOrderType "LIMIT_BUY" = Just OrderType_LIMIT_BUY
parseOrderType "LIMIT_SELL" = Just OrderType_LIMIT_SELL
parseOrderType _ = Nothing
instance ParseJSON OrderType where
parseJSON = do
t <- AesonBE.asText
parseOrderType t
|> maybe (fail "FIXME: better error message") pure
instance PrintJSON OrderType where
printJSON = printOrderType .> printJSON
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- MARKET API DATA TYPES -------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
type OrderUUID
= Record '[ "uuid" :-> UUID
]
--------------------------------------------------------------------------------
type OpenOrder
= Record '[ "Uuid" :-> (Maybe Aeson.Value)
, "OrderUuid" :-> UUID
, "Exchange" :-> MarketName
, "OrderType" :-> OrderType
, "Quantity" :-> Quantity
, "QuantityRemaining" :-> Quantity
, "Limit" :-> Quantity
, "CommissionPaid" :-> Quantity
, "Price" :-> Quantity
, "PricePerUnit" :-> (Maybe Aeson.Value)
, "Opened" :-> TimeStamp
, "Closed" :-> (Maybe TimeStamp)
, "CancelInitiated" :-> Bool
, "ImmediateOrCancel" :-> Bool
, "IsConditional" :-> Bool
, "Condition" :-> (Maybe Aeson.Value)
, "ConditionTarget" :-> (Maybe Aeson.Value)
]
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- ACCOUNT API DATA TYPES ------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
type Balance
= Record '[ "Currency" :-> SCurrencyName
, "Balance" :-> Quantity
, "Available" :-> Quantity
, "Pending" :-> Quantity
, "CryptoAddress" :-> Text
, "Requested" :-> Bool
, "Uuid" :-> (Maybe Aeson.Value)
]
--------------------------------------------------------------------------------
type DepositAddress
= Record '[ "Currency" :-> SCurrencyName
, "Address" :-> Text
]
--------------------------------------------------------------------------------
type WithdrawalUUID
= Record '[ "uuid" :-> UUID
]
--------------------------------------------------------------------------------
type OrderDetail
= Record '[ "AccountId" :-> (Maybe Aeson.Value)
, "OrderUuid" :-> UUID
, "Exchange" :-> MarketName
, "Type" :-> OrderType
, "Quantity" :-> Quantity
, "QuantityRemaining" :-> Quantity
, "Limit" :-> Quantity
, "Reserved" :-> Quantity
, "ReserveRemaining" :-> Quantity
, "CommissionReserved" :-> Quantity
, "CommissionReserveRemaining" :-> Quantity
, "CommissionPaid" :-> Quantity
, "Price" :-> Quantity
, "PricePerUnit" :-> (Maybe Aeson.Value)
, "Opened" :-> TimeStamp
, "Closed" :-> (Maybe TimeStamp)
, "IsOpen" :-> Bool
, "Sentinel" :-> UUID
, "CancelInitiated" :-> Bool
, "ImmediateOrCancel" :-> Bool
, "IsConditional" :-> Bool
, "Condition" :-> (Maybe Aeson.Value)
, "ConditionTarget" :-> (Maybe Aeson.Value)
]
--------------------------------------------------------------------------------
type ClosedOrder
= Record '[ "OrderUuid" :-> UUID
, "Exchange" :-> MarketName
, "TimeStamp" :-> TimeStamp
, "OrderType" :-> OrderType
, "Limit" :-> Quantity
, "Quantity" :-> Quantity
, "QuantityRemaining" :-> Quantity
, "Commission" :-> Quantity
, "Price" :-> Quantity
, "PricePerUnit" :-> (Maybe Aeson.Value)
, "IsConditional" :-> Bool
, "Condition" :-> (Maybe Aeson.Value)
, "ConditionTarget" :-> (Maybe Aeson.Value)
, "ImmediateOrCancel" :-> Bool
]
--------------------------------------------------------------------------------
type Withdrawal
= Record '[ "PaymentUuid" :-> UUID
, "Currency" :-> SCurrencyName
, "Amount" :-> Quantity
, "Address" :-> Text
, "Opened" :-> TimeStamp
, "Authorized" :-> Bool
, "PendingPayment" :-> Bool
, "TxCost" :-> Quantity
, "TxId" :-> (Maybe Text)
, "Canceled" :-> Bool
, "InvalidAddress" :-> Bool
]
--------------------------------------------------------------------------------
type Deposit
= Record '[ "PaymentUuid" :-> UUID
, "Currency" :-> SCurrencyName
, "Amount" :-> Quantity
, "Address" :-> Text
, "Opened" :-> TimeStamp
, "Authorized" :-> Bool
, "PendingPayment" :-> Bool
, "TxCost" :-> Quantity
, "TxId" :-> (Maybe Text)
, "Canceled" :-> Bool
, "InvalidAddress" :-> Bool
]
--------------------------------------------------------------------------------
instance ( Every Aeson.FromJSON u, Comp.RecordFromJson u
) => Aeson.FromJSON (Record u) where
parseJSON = undefined
instance ( Every Aeson.ToJSON u, Comp.RecordToJsonObject u
) => Aeson.ToJSON (Record u) where
toJSON = Comp.recordToJson encoder
where
encoder = undefined
--------------------------------------------------------------------------------
type family Every (c :: k -> Constraint) (xs :: [k]) :: Constraint where
Every _ '[] = ()
Every c (x : rest) = (c x, Every c rest)
type family FieldTypes (f :: [Type]) where
FieldTypes '[] = '[]
FieldTypes ((s :-> a) : rest) = a : FieldTypes rest
FieldTypes (t : rest) = TypeError
('Text "Not a field: " :<>: 'ShowType t)
--------------------------------------------------------------------------------
data JSONBE
instance S.Accept JSONBE where
contentTypes _ = S.contentTypes (Proxy @S.JSON)
instance (ParseJSON t) => S.MimeUnrender JSONBE t where
mimeUnrender = undefined
instance (PrintJSON t) => S.MimeRender JSONBE t where
mimeRender = undefined
--------------------------------------------------------------------------------
class ParseJSON t where
parseJSON :: AesonBE.Parse JSONParseError t
instance ParseJSON Aeson.Value where { parseJSON = AesonBE.asValue; }
instance ParseJSON Text where { parseJSON = AesonBE.asText; }
instance ParseJSON String where { parseJSON = AesonBE.asString; }
instance ParseJSON Scientific where { parseJSON = AesonBE.asScientific; }
instance ParseJSON Int where { parseJSON = AesonBE.asIntegral; }
instance ParseJSON Int8 where { parseJSON = AesonBE.asIntegral; }
instance ParseJSON Int16 where { parseJSON = AesonBE.asIntegral; }
instance ParseJSON Int32 where { parseJSON = AesonBE.asIntegral; }
instance ParseJSON Int64 where { parseJSON = AesonBE.asIntegral; }
instance ParseJSON Word where { parseJSON = AesonBE.asIntegral; }
instance ParseJSON Word8 where { parseJSON = AesonBE.asIntegral; }
instance ParseJSON Word16 where { parseJSON = AesonBE.asIntegral; }
instance ParseJSON Word32 where { parseJSON = AesonBE.asIntegral; }
instance ParseJSON Word64 where { parseJSON = AesonBE.asIntegral; }
instance ParseJSON Bool where { parseJSON = AesonBE.asBool; }
-- FIXME: this instance is kind of evil because it collapses nested Maybes
instance (ParseJSON t) => ParseJSON (Maybe t) where
parseJSON = AesonBE.perhaps parseJSON
instance (ParseJSON t) => ParseJSON [t] where
parseJSON = AesonBE.eachInArray parseJSON
instance (ParseJSON t) => ParseJSON (Vector t) where
parseJSON = Vector.fromList <$> parseJSON
instance ( Every ParseJSON (FieldTypes u)
) => ParseJSON (Record u) where
parseJSON = undefined
instance ( Every PrintJSON (FieldTypes u)
) => PrintJSON (Record u) where
printJSON = undefined
--------------------------------------------------------------------------------
class PrintJSON t where
printJSON :: t -> Aeson.Value
instance (Aeson.ToJSON t) => PrintJSON t where
printJSON = Aeson.toJSON
--------------------------------------------------------------------------------
data JSONParseError
= JSONParseError Text
deriving (Eq, Show, Generic)
instance Exception JSONParseError
--------------------------------------------------------------------------------
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment