module Bitcoin.RPC.JSON where
import Data.List ( sort )
import Control.Applicative
import Text.JSON
import qualified Data.ByteString as B
import Bitcoin.Misc.OctetStream
import Bitcoin.Misc.HexString
import Bitcoin.Misc.UnixTime
import Bitcoin.Protocol.Hash
import Bitcoin.Protocol.Address
import Bitcoin.Protocol.Amount
import Bitcoin.Protocol.Base64
import Bitcoin.Protocol.Hash
import Bitcoin.Protocol.Key
import Bitcoin.Protocol.Signature
import Bitcoin.Script.Base
import Bitcoin.BlockChain.Base
type RequestId = String
data Request a = Request
{ requestMethod :: String
, requestParams :: [a]
, requestId :: RequestId
}
deriving Show
data Response = Response
{ responseResult :: JSValue
, responseError :: Maybe JSValue
, responseId :: RequestId
}
deriving Show
data Notification a = Notification
{ notifMethod :: String
, notifParams :: [a]
}
deriving Show
encodeRequest :: JSON a => Request a -> JSValue
encodeRequest (Request method params rqid) = JSObject $ toJSObject
[ ( "method" , jsString method )
, ( "params" , JSArray (map showJSON params) )
, ( "id" , jsString rqid )
]
encodeNotification :: JSON a => Notification a -> JSValue
encodeNotification (Notification method params) = JSObject $ toJSObject
[ ( "method" , jsString method )
, ( "params" , JSArray (map showJSON params) )
]
decodeResponse :: JSValue -> Maybe Response
decodeResponse jv = case jv of
JSObject obj ->
case (sort keys) of
[ "error" , "id" , "result" ] -> case lkp "id" of
JSString rqid -> Just $ Response (lkp "result") mberr rqid where
rqid = case lkp "id" of
JSString s -> fromJSString s
_ -> error "decodeResponse: request id is not a string"
mberr = case lkp "error" of
JSNull -> Nothing
err -> Just err
_ -> Nothing
_ -> Nothing
where
kvs = fromJSObject obj
keys = map fst kvs
lkp k = case lookup k kvs of
Just x -> x
Nothing -> error "decodeResponse: shouldn't happen"
_ -> Nothing
jsString :: String -> JSValue
jsString = JSString . toJSString
jsNumber :: Int -> JSValue
jsNumber i = JSRational False (fromIntegral i)
myReadJSON :: JSON a => JSValue -> Maybe a
myReadJSON js = case readJSON js of
Ok y -> Just y
Error _ -> Nothing
mbJSObject :: JSValue -> Maybe (JSObject JSValue)
mbJSObject js = case js of
JSObject obj -> Just obj
_ -> Nothing
eiShowJSON :: (JSON a, JSON b) => Either a b -> JSValue
eiShowJSON (Left x) = showJSON x
eiShowJSON (Right y) = showJSON y
instance JSON Hash256 where
showJSON hash = showJSON $ unsafeReverseHexString $ toHexStringChars hash
readJSON jsv = case (readJSON jsv :: Result String) of
Ok s | even (length s) -> case safeHexDecode (unsafeReverseHexString s) of
Just x -> Ok (fromWord8List x)
Nothing -> Error "invalid characters in hex string"
| otherwise -> Error $ "hex string of odd length"
Error s -> Error s
instance JSON UnixTimeStamp where
showJSON (UnixTimeStamp x) = showJSON x
readJSON jsv = UnixTimeStamp <$> readJSON jsv
instance JSON Address where
showJSON (Address x) = showJSON x
readJSON jsv = Address <$> readJSON jsv
instance JSON Amount where
showJSON x = showJSON (doubleAmount x)
readJSON jsv = amountFromDouble <$> readJSON jsv
newtype BS = BS { unBS :: B.ByteString }
instance JSON BS where
showJSON (BS bs) = showJSON (toHexStringChars bs)
readJSON hex = case readJSON hex of
Ok s | even (length s) -> case safeHexDecode s of
Just x -> Ok (BS (fromWord8List x))
Nothing -> Error "invalid characters in hex string"
| otherwise -> Error $ "hex string of odd length"
Error s -> Error s
instance JSON PubKey where
showJSON pubkey = showJSON $ BS (encodePubKeyNative pubkey :: B.ByteString)
readJSON jsv = case (readJSON jsv :: Result BS) of
Error err -> Error err
Ok bs -> case decodePubKey (unBS bs) of
Nothing -> Error "readJSON/PubKey: cannot decode pubkey"
Just pk -> Ok pk
instance JSON RawScript where
showJSON (RawScript bs) = showJSON (BS bs)
readJSON jsv = (RawScript . unBS) <$> readJSON jsv
instance JSON RawTx where
showJSON (RawTx bs) = showJSON (BS bs)
readJSON jsv = (RawTx . unBS) <$> readJSON jsv
instance JSON WIF where
showJSON (WIF wif) = showJSON wif
readJSON jsv = WIF <$> readJSON jsv