{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Servant.Bitcoind (
    -- * Bitcoind api endpoint DSL
    C,
    CX,
    F,
    I,
    O,

    -- * Types related to defaulting
    EmptyString,
    EmptyList,
    DefFalse,
    DefTrue,
    DefZero,

    -- * Types related to the client
    BitcoindClient,
    BitcoindEndpoint,
    BitcoindException (..),

    -- * Client generation mechanism
    HasBitcoindClient (..),
    Rewrite (..),

    -- * Utility functions
    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 (..),
 )

-- | Exceptions resulting from interacting with bitcoind
data BitcoindException
    = -- | The error message returned by bitcoind on failure
      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

-- | A client returning @Either BitcoindException r@
data C r

-- | A client returning @Either BitcoindException ()@
data CX

-- | An argument with a fixed value
data F x r

-- | An optional argument
data O r

-- | An ordinary argument
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)

{- | Bitcoind uses JSON arrays to serialize parameters.  This typeclass
 describes a generic rewriting system, but we apply it here to transform
 clients of the form @BasicAuthData -> [Value] -> ClientM Value@ into curried
 functions with endpoint specific arguments.
-}
class Rewrite a where
    type RewriteFrom a :: *
    type RewriteTo a :: *
    rewriteRpc :: p a -> RewriteFrom a -> RewriteTo a

-- | Handle endpoints which do not have an expected return value
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"

-- | Endpoints which simply return a value
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"

-- | Add a normal argument
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)

-- | Add an optional argument
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)

-- | Add a fixed argument
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

-- | Helper function for decoding POSIX timestamps
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

-- | Convert BTC to Satoshis
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)

-- | Read a serializable from a hex string
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