Initial commit

bundled/Stellar/Simple.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Stellar.Simple where
+
+-- prelude
+import Prelude hiding (id)
+import Prelude qualified
+
+-- global
+import Control.Exception (SomeException (SomeException), catchJust, throwIO)
+import Crypto.Sign.Ed25519 qualified as Ed25519
+import Data.ByteString.Base64 qualified as Base64
+import Data.Foldable (toList)
+import Data.Int (Int32, Int64)
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+import Data.Maybe (fromMaybe)
+import Data.Monoid (Endo (Endo), appEndo)
+import Data.Ratio (Ratio, denominator, numerator)
+import Data.Sequence (Seq, (|>))
+import Data.Text (Text)
+import Data.Text qualified as Text
+import Data.Text.Encoding (encodeUtf8, decodeUtf8', encodeUtf8)
+import Data.Typeable (cast)
+import Data.Word (Word32, Word8)
+import GHC.Stack (HasCallStack)
+import Text.Read (readEither, readMaybe)
+
+-- stellar-sdk
+import Network.ONCRPC.XDR (XDR, xdrSerialize)
+import Network.ONCRPC.XDR qualified as XDR
+import Network.Stellar.Keypair qualified as StellarKey
+import Network.Stellar.Network (Network, publicNetwork)
+import Network.Stellar.Signature qualified as StellarSignature
+import Network.Stellar.TransactionXdr (Uint256)
+import Network.Stellar.TransactionXdr qualified as XDR
+
+-- component
+import Stellar.Simple.Types (Asset (..), DecoratedSignature (..), Memo (..))
+
+identity :: a -> a
+identity = Prelude.id
+
+-- | Make asset from the canonical pair of code and issuer
+mkAsset :: Text -> Text -> Asset
+mkAsset code issuer = Asset{code, issuer = Just issuer}
+
+data Guess a = Already a | Guess
+    deriving (Show)
+
+signWithSecret ::
+    HasCallStack =>
+    -- | "S..." textual secret key
+    Text ->
+    XDR.TransactionEnvelope ->
+    XDR.TransactionEnvelope
+signWithSecret secret tx =
+    either (error . show) identity $
+    StellarSignature.signTx publicNetwork tx [StellarKey.fromPrivateKey' secret]
+
+xdrSerializeBase64T :: XDR a => a -> Text
+xdrSerializeBase64T = decodeUtf8Throw . Base64.encode . xdrSerialize
+
+decodeUtf8Throw = either (error . show) identity . decodeUtf8'

bundled/Stellar/Simple/Types.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Stellar.Simple.Types where
+
+-- global
+import Data.ByteString (ByteString)
+import Data.ByteString.Base64 qualified as Base64
+import Data.Scientific (Scientific)
+import Data.Text (Text)
+import Data.Text qualified as Text
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import Data.Time (UTCTime)
+import GHC.Generics (Generic)
+import Network.Stellar.TransactionXdr qualified as XDR
+
+newtype Shown a = Shown String
+    deriving newtype (Eq)
+
+instance Show (Shown a) where
+    show (Shown s) = s
+
+shown :: Show a => a -> Shown a
+shown = Shown . show
+
+data Asset = Asset{issuer :: Maybe Text, code :: Text}
+    deriving (Eq, Generic, Ord, Read, Show)
+
+-- | Representation is "XLM" or "{code}:{issuer}"
+assetToText :: Asset -> Text
+assetToText Asset{code, issuer} = code <> maybe "" (":" <>) issuer
+
+assetFromText :: Text -> Asset
+assetFromText t
+    | Text.null _issuer = Asset{code = t, issuer = Nothing}
+    | otherwise         = Asset{code, issuer = Just issuer}
+  where
+    (code, _issuer) = Text.break (== ':') t
+    issuer = Text.drop 1 _issuer
+
+data Memo = MemoNone | MemoText Text | MemoOther (Shown XDR.Memo)
+    deriving (Eq, Show)
+
+data PaymentType = DirectPayment | PathPayment
+    deriving (Generic, Read, Show)
+
+data DecoratedSignature = DecoratedSignature{hint, signature :: ByteString}
+    deriving Show