{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Servant.Bitcoind (
C,
CX,
F,
I,
O,
EmptyString,
EmptyList,
DefFalse,
DefTrue,
DefZero,
BitcoindClient,
BitcoindEndpoint,
BitcoindException (..),
HasBitcoindClient (..),
Rewrite (..),
utcTime,
toSatoshis,
decodeFromHex,
HexEncoded (..),
) where
import Control.Exception (Exception)
import Control.Monad ((>=>))
import Control.Monad.Trans.Except (ExceptT (..))
import Control.Monad.Trans.Reader (ReaderT (..))
import Data.Aeson (
FromJSON (..),
ToJSON (..),
Value,
withText,
)
import qualified Data.Aeson.Types as Ae
import Data.Bifunctor (first)
import Data.Proxy (Proxy (..))
import Data.Scientific (Scientific)
import Data.Serialize (Serialize, decode)
import Data.Text (Text)
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Word (Word32, Word64)
import GHC.TypeLits (KnownSymbol, Symbol)
import Haskoin.Util (decodeHex)
import Servant.API ((:<|>) (..), (:>))
import Servant.API.BasicAuth (BasicAuth, BasicAuthData)
import Servant.Client (ClientError, ClientM, client)
import Servant.Client.JsonRpc (
JsonRpc,
JsonRpcErr (..),
JsonRpcResponse (..),
)
data BitcoindException
=
RpcException String
| ClientException ClientError
| DecodingError String
deriving (Int -> BitcoindException -> ShowS
[BitcoindException] -> ShowS
BitcoindException -> String
(Int -> BitcoindException -> ShowS)
-> (BitcoindException -> String)
-> ([BitcoindException] -> ShowS)
-> Show BitcoindException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BitcoindException] -> ShowS
$cshowList :: [BitcoindException] -> ShowS
show :: BitcoindException -> String
$cshow :: BitcoindException -> String
showsPrec :: Int -> BitcoindException -> ShowS
$cshowsPrec :: Int -> BitcoindException -> ShowS
Show)
instance Exception BitcoindException
data BitcoindEndpoint (m :: Symbol) a
data C r
data CX
data F x r
data O r
data I r
class HasDefault x a where
getDefault :: p x -> a
data EmptyString
instance HasDefault EmptyString Text where getDefault :: p EmptyString -> Text
getDefault _ = ""
data DefFalse
instance HasDefault DefFalse Bool where getDefault :: p DefFalse -> Bool
getDefault _ = Bool
False
data DefTrue
instance HasDefault DefTrue Bool where getDefault :: p DefTrue -> Bool
getDefault _ = Bool
True
data EmptyList
instance HasDefault EmptyList [a] where getDefault :: p EmptyList -> [a]
getDefault _ = []
data DefZero
instance Num a => HasDefault DefZero a where getDefault :: p DefZero -> a
getDefault _ = 0
class HasBitcoindClient x where
type TheBitcoindClient x :: *
toBitcoindClient :: p x -> TheBitcoindClient x
instance
(Rewrite a, RewriteFrom a ~ NakedClient, KnownSymbol m) =>
HasBitcoindClient (BitcoindEndpoint m a)
where
type TheBitcoindClient (BitcoindEndpoint m a) = RewriteTo a
toBitcoindClient :: p (BitcoindEndpoint m a)
-> TheBitcoindClient (BitcoindEndpoint m a)
toBitcoindClient _ =
Proxy a -> RewriteFrom a -> RewriteTo a
forall a (p :: * -> *).
Rewrite a =>
p a -> RewriteFrom a -> RewriteTo a
rewriteRpc (Proxy a
forall k (t :: k). Proxy t
Proxy @a)
(NakedClient -> RewriteTo a)
-> (Proxy (BitcoindRpc m) -> NakedClient)
-> Proxy (BitcoindRpc m)
-> RewriteTo a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy (BitcoindRpc m) -> NakedClient
forall api.
HasClient ClientM api =>
Proxy api -> Client ClientM api
client
(Proxy (BitcoindRpc m) -> TheBitcoindClient (BitcoindEndpoint m a))
-> Proxy (BitcoindRpc m)
-> TheBitcoindClient (BitcoindEndpoint m a)
forall a b. (a -> b) -> a -> b
$ Proxy (BitcoindRpc m)
forall k (t :: k). Proxy t
Proxy @(BitcoindRpc m)
instance
(HasBitcoindClient x, HasBitcoindClient y) =>
HasBitcoindClient (x :<|> y)
where
type TheBitcoindClient (x :<|> y) = TheBitcoindClient x :<|> TheBitcoindClient y
toBitcoindClient :: p (x :<|> y) -> TheBitcoindClient (x :<|> y)
toBitcoindClient _ = Proxy x -> TheBitcoindClient x
forall x (p :: * -> *).
HasBitcoindClient x =>
p x -> TheBitcoindClient x
toBitcoindClient (Proxy x
forall k (t :: k). Proxy t
Proxy @x) TheBitcoindClient x
-> TheBitcoindClient y
-> TheBitcoindClient x :<|> TheBitcoindClient y
forall a b. a -> b -> a :<|> b
:<|> Proxy y -> TheBitcoindClient y
forall x (p :: * -> *).
HasBitcoindClient x =>
p x -> TheBitcoindClient x
toBitcoindClient (Proxy y
forall k (t :: k). Proxy t
Proxy @y)
type BitcoindRpc m = BasicAuth "bitcoind" () :> JsonRpc m [Value] String Value
type BitcoindClient r = ReaderT BasicAuthData (ExceptT BitcoindException ClientM) r
type NakedClient =
BasicAuthData ->
[Value] ->
ClientM (JsonRpcResponse String Value)
class Rewrite a where
type RewriteFrom a :: *
type RewriteTo a :: *
rewriteRpc :: p a -> RewriteFrom a -> RewriteTo a
instance Rewrite CX where
type RewriteFrom CX = NakedClient
type RewriteTo CX = BitcoindClient ()
rewriteRpc :: p CX -> RewriteFrom CX -> RewriteTo CX
rewriteRpc _ f :: RewriteFrom CX
f = (BasicAuthData -> ExceptT BitcoindException ClientM ())
-> RewriteTo CX
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((BasicAuthData -> ExceptT BitcoindException ClientM ())
-> RewriteTo CX)
-> (BasicAuthData -> ExceptT BitcoindException ClientM ())
-> RewriteTo CX
forall a b. (a -> b) -> a -> b
$ ClientM (Either BitcoindException ())
-> ExceptT BitcoindException ClientM ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ClientM (Either BitcoindException ())
-> ExceptT BitcoindException ClientM ())
-> (BasicAuthData -> ClientM (Either BitcoindException ()))
-> BasicAuthData
-> ExceptT BitcoindException ClientM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (JsonRpcResponse String Value -> Either BitcoindException ())
-> ClientM (JsonRpcResponse String Value)
-> ClientM (Either BitcoindException ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JsonRpcResponse String Value -> Either BitcoindException ()
forall e r. JsonRpcResponse e r -> Either BitcoindException ()
repack (ClientM (JsonRpcResponse String Value)
-> ClientM (Either BitcoindException ()))
-> (BasicAuthData -> ClientM (JsonRpcResponse String Value))
-> BasicAuthData
-> ClientM (Either BitcoindException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RewriteFrom CX
NakedClient
`f` [])
where
repack :: JsonRpcResponse e r -> Either BitcoindException ()
repack = \case
Ack _ -> () -> Either BitcoindException ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Errors _ (JsonRpcErr _ e :: String
e _) -> BitcoindException -> Either BitcoindException ()
forall a b. a -> Either a b
Left (BitcoindException -> Either BitcoindException ())
-> BitcoindException -> Either BitcoindException ()
forall a b. (a -> b) -> a -> b
$ String -> BitcoindException
RpcException String
e
Result{} -> BitcoindException -> Either BitcoindException ()
forall a b. a -> Either a b
Left (BitcoindException -> Either BitcoindException ())
-> BitcoindException -> Either BitcoindException ()
forall a b. (a -> b) -> a -> b
$ String -> BitcoindException
RpcException "Expecting ack; got result"
instance FromJSON r => Rewrite (C r) where
type RewriteFrom (C r) = NakedClient
type RewriteTo (C r) = BitcoindClient r
rewriteRpc :: p (C r) -> RewriteFrom (C r) -> RewriteTo (C r)
rewriteRpc _ f :: RewriteFrom (C r)
f = (BasicAuthData -> ExceptT BitcoindException ClientM r)
-> RewriteTo (C r)
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((BasicAuthData -> ExceptT BitcoindException ClientM r)
-> RewriteTo (C r))
-> (BasicAuthData -> ExceptT BitcoindException ClientM r)
-> RewriteTo (C r)
forall a b. (a -> b) -> a -> b
$ ClientM (Either BitcoindException r)
-> ExceptT BitcoindException ClientM r
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ClientM (Either BitcoindException r)
-> ExceptT BitcoindException ClientM r)
-> (BasicAuthData -> ClientM (Either BitcoindException r))
-> BasicAuthData
-> ExceptT BitcoindException ClientM r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (JsonRpcResponse String Value -> Either BitcoindException r)
-> ClientM (JsonRpcResponse String Value)
-> ClientM (Either BitcoindException r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JsonRpcResponse String Value -> Either BitcoindException r
forall e. JsonRpcResponse e Value -> Either BitcoindException r
repack (ClientM (JsonRpcResponse String Value)
-> ClientM (Either BitcoindException r))
-> (BasicAuthData -> ClientM (JsonRpcResponse String Value))
-> BasicAuthData
-> ClientM (Either BitcoindException r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RewriteFrom (C r)
NakedClient
`f` [])
where
repack :: JsonRpcResponse e Value -> Either BitcoindException r
repack = \case
Result _ x :: Value
x -> (String -> BitcoindException)
-> Either String r -> Either BitcoindException r
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> BitcoindException
DecodingError (Either String r -> Either BitcoindException r)
-> Either String r -> Either BitcoindException r
forall a b. (a -> b) -> a -> b
$ (Value -> Parser r) -> Value -> Either String r
forall a b. (a -> Parser b) -> a -> Either String b
Ae.parseEither Value -> Parser r
forall a. FromJSON a => Value -> Parser a
parseJSON Value
x
Errors _ (JsonRpcErr _ e :: String
e _) -> BitcoindException -> Either BitcoindException r
forall a b. a -> Either a b
Left (BitcoindException -> Either BitcoindException r)
-> BitcoindException -> Either BitcoindException r
forall a b. (a -> b) -> a -> b
$ String -> BitcoindException
RpcException String
e
Ack{} -> BitcoindException -> Either BitcoindException r
forall a b. a -> Either a b
Left (BitcoindException -> Either BitcoindException r)
-> BitcoindException -> Either BitcoindException r
forall a b. (a -> b) -> a -> b
$ String -> BitcoindException
RpcException "Expecting result; got ack"
instance
(RewriteFrom b ~ NakedClient, Rewrite b, ToJSON a) =>
Rewrite (I a -> b)
where
type RewriteFrom (I a -> b) = NakedClient
type RewriteTo (I a -> b) = a -> RewriteTo b
rewriteRpc :: p (I a -> b) -> RewriteFrom (I a -> b) -> RewriteTo (I a -> b)
rewriteRpc _ f :: RewriteFrom (I a -> b)
f x :: a
x = Proxy b -> RewriteFrom b -> RewriteTo b
forall a (p :: * -> *).
Rewrite a =>
p a -> RewriteFrom a -> RewriteTo a
rewriteRpc (Proxy b
forall k (t :: k). Proxy t
Proxy @b) (RewriteFrom b -> RewriteTo b) -> RewriteFrom b -> RewriteTo b
forall a b. (a -> b) -> a -> b
$ \auth :: BasicAuthData
auth args :: [Value]
args -> RewriteFrom (I a -> b)
NakedClient
f BasicAuthData
auth (a -> Value
forall a. ToJSON a => a -> Value
toJSON a
x Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [Value]
args)
instance
(RewriteFrom b ~ NakedClient, Rewrite b, ToJSON a) =>
Rewrite (O a -> b)
where
type RewriteFrom (O a -> b) = NakedClient
type RewriteTo (O a -> b) = Maybe a -> RewriteTo b
rewriteRpc :: p (O a -> b) -> RewriteFrom (O a -> b) -> RewriteTo (O a -> b)
rewriteRpc _ f :: RewriteFrom (O a -> b)
f x :: Maybe a
x = Proxy b -> RewriteFrom b -> RewriteTo b
forall a (p :: * -> *).
Rewrite a =>
p a -> RewriteFrom a -> RewriteTo a
rewriteRpc (Proxy b
forall k (t :: k). Proxy t
Proxy @b) (RewriteFrom b -> RewriteTo b) -> RewriteFrom b -> RewriteTo b
forall a b. (a -> b) -> a -> b
$ \auth :: BasicAuthData
auth args :: [Value]
args -> RewriteFrom (O a -> b)
NakedClient
f BasicAuthData
auth ((a -> Value
forall a. ToJSON a => a -> Value
toJSON (a -> Value) -> Maybe a -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
x) Maybe Value -> [Value] -> [Value]
forall a. Maybe a -> [a] -> [a]
`maybeCons` [Value]
args)
instance
(RewriteFrom b ~ NakedClient, Rewrite b, ToJSON a, HasDefault x a) =>
Rewrite (F x a -> b)
where
type RewriteFrom (F x a -> b) = NakedClient
type RewriteTo (F x a -> b) = RewriteTo b
rewriteRpc :: p (F x a -> b)
-> RewriteFrom (F x a -> b) -> RewriteTo (F x a -> b)
rewriteRpc _ f :: RewriteFrom (F x a -> b)
f = Proxy b -> RewriteFrom b -> RewriteTo b
forall a (p :: * -> *).
Rewrite a =>
p a -> RewriteFrom a -> RewriteTo a
rewriteRpc (Proxy b
forall k (t :: k). Proxy t
Proxy @b) RewriteFrom b
NakedClient
f'
where
f' :: NakedClient
f' auth :: BasicAuthData
auth args :: [Value]
args = RewriteFrom (F x a -> b)
NakedClient
f BasicAuthData
auth ([Value] -> ClientM (JsonRpcResponse String Value))
-> [Value] -> ClientM (JsonRpcResponse String Value)
forall a b. (a -> b) -> a -> b
$ Value
fixedVal Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [Value]
args
fixedVal :: Value
fixedVal = ToJSON a => a -> Value
forall a. ToJSON a => a -> Value
toJSON @a (a -> Value) -> (Proxy x -> a) -> Proxy x -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy x -> a
forall x a (p :: * -> *). HasDefault x a => p x -> a
getDefault (Proxy x -> Value) -> Proxy x -> Value
forall a b. (a -> b) -> a -> b
$ Proxy x
forall k (t :: k). Proxy t
Proxy @x
instance (Rewrite a, Rewrite b) => Rewrite (a :<|> b) where
type RewriteFrom (a :<|> b) = RewriteFrom a :<|> RewriteFrom b
type RewriteTo (a :<|> b) = RewriteTo a :<|> RewriteTo b
rewriteRpc :: p (a :<|> b) -> RewriteFrom (a :<|> b) -> RewriteTo (a :<|> b)
rewriteRpc _ (x :<|> y) = Proxy a -> RewriteFrom a -> RewriteTo a
forall a (p :: * -> *).
Rewrite a =>
p a -> RewriteFrom a -> RewriteTo a
rewriteRpc (Proxy a
forall k (t :: k). Proxy t
Proxy @a) RewriteFrom a
x RewriteTo a -> RewriteTo b -> RewriteTo a :<|> RewriteTo b
forall a b. a -> b -> a :<|> b
:<|> Proxy b -> RewriteFrom b -> RewriteTo b
forall a (p :: * -> *).
Rewrite a =>
p a -> RewriteFrom a -> RewriteTo a
rewriteRpc (Proxy b
forall k (t :: k). Proxy t
Proxy @b) RewriteFrom b
y
maybeCons :: Maybe a -> [a] -> [a]
maybeCons :: Maybe a -> [a] -> [a]
maybeCons mx :: Maybe a
mx xs :: [a]
xs = [a] -> (a -> [a]) -> Maybe a -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [a]
xs (a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs) Maybe a
mx
utcTime :: Word64 -> UTCTime
utcTime :: Word64 -> UTCTime
utcTime = POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime)
-> (Word64 -> POSIXTime) -> Word64 -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral
toSatoshis :: Scientific -> Word32
toSatoshis :: Scientific -> Word32
toSatoshis = Scientific -> Word32
forall a b. (RealFrac a, Integral b) => a -> b
floor (Scientific -> Word32)
-> (Scientific -> Scientific) -> Scientific -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
* 100_000_000)
decodeFromHex :: Serialize a => Text -> Either String a
decodeFromHex :: Text -> Either String a
decodeFromHex = Either String ByteString
-> (ByteString -> Either String ByteString)
-> Maybe ByteString
-> Either String ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String ByteString
forall a b. a -> Either a b
Left "Invalid hex") ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Maybe ByteString -> Either String ByteString)
-> (Text -> Maybe ByteString) -> Text -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe ByteString
decodeHex (Text -> Either String ByteString)
-> (ByteString -> Either String a) -> Text -> Either String a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ByteString -> Either String a
forall a. Serialize a => ByteString -> Either String a
decode
newtype HexEncoded a = HexEncoded {HexEncoded a -> a
unHexEncoded :: a} deriving (HexEncoded a -> HexEncoded a -> Bool
(HexEncoded a -> HexEncoded a -> Bool)
-> (HexEncoded a -> HexEncoded a -> Bool) -> Eq (HexEncoded a)
forall a. Eq a => HexEncoded a -> HexEncoded a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HexEncoded a -> HexEncoded a -> Bool
$c/= :: forall a. Eq a => HexEncoded a -> HexEncoded a -> Bool
== :: HexEncoded a -> HexEncoded a -> Bool
$c== :: forall a. Eq a => HexEncoded a -> HexEncoded a -> Bool
Eq, Int -> HexEncoded a -> ShowS
[HexEncoded a] -> ShowS
HexEncoded a -> String
(Int -> HexEncoded a -> ShowS)
-> (HexEncoded a -> String)
-> ([HexEncoded a] -> ShowS)
-> Show (HexEncoded a)
forall a. Show a => Int -> HexEncoded a -> ShowS
forall a. Show a => [HexEncoded a] -> ShowS
forall a. Show a => HexEncoded a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HexEncoded a] -> ShowS
$cshowList :: forall a. Show a => [HexEncoded a] -> ShowS
show :: HexEncoded a -> String
$cshow :: forall a. Show a => HexEncoded a -> String
showsPrec :: Int -> HexEncoded a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> HexEncoded a -> ShowS
Show)
instance Serialize a => FromJSON (HexEncoded a) where
parseJSON :: Value -> Parser (HexEncoded a)
parseJSON = String
-> (Text -> Parser (HexEncoded a))
-> Value
-> Parser (HexEncoded a)
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText "HexEncoded" ((Text -> Parser (HexEncoded a)) -> Value -> Parser (HexEncoded a))
-> (Text -> Parser (HexEncoded a))
-> Value
-> Parser (HexEncoded a)
forall a b. (a -> b) -> a -> b
$ (String -> Parser (HexEncoded a))
-> (a -> Parser (HexEncoded a))
-> Either String a
-> Parser (HexEncoded a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser (HexEncoded a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (HexEncoded a -> Parser (HexEncoded a)
forall (m :: * -> *) a. Monad m => a -> m a
return (HexEncoded a -> Parser (HexEncoded a))
-> (a -> HexEncoded a) -> a -> Parser (HexEncoded a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> HexEncoded a
forall a. a -> HexEncoded a
HexEncoded) (Either String a -> Parser (HexEncoded a))
-> (Text -> Either String a) -> Text -> Parser (HexEncoded a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String a
forall a. Serialize a => Text -> Either String a
decodeFromHex