Initial commit

bundled/Network/ONCRPC/XDR.hs

@@ -0,0 +1,13 @@
+-- | XDR: External Data Representation as described in RFC4506
+--
+-- This module should be imported qualified, e.g., as @XDR@.
+
+module Network.ONCRPC.XDR
+  ( module Network.ONCRPC.XDR.Types
+  , module Network.ONCRPC.XDR.Array
+  , module Network.ONCRPC.XDR.Serial
+  ) where
+
+import Network.ONCRPC.XDR.Types
+import Network.ONCRPC.XDR.Array
+import Network.ONCRPC.XDR.Serial

bundled/Network/ONCRPC/XDR/Array.hs

@@ -0,0 +1,264 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+
+{- | Various kinds of arrays (lists, vectors, bytestrings) with statically
+asserted length constraints encoded in their type.
+-}
+module Network.ONCRPC.XDR.Array (
+  KnownNat,
+  KnownOrdering,
+  LengthArray,
+  FixedLengthArray,
+  fixedLengthArrayLength,
+  BoundedLengthArray,
+  boundedLengthArrayBound,
+  unLengthArray,
+  unsafeLengthArray,
+  lengthArray,
+  lengthArray',
+  boundLengthArray,
+  boundLengthArrayFromList,
+  padLengthArray,
+  constLengthArray,
+  emptyFixedLengthArray,
+  emptyBoundedLengthArray,
+  expandBoundedLengthArray,
+  boundFixedLengthArray,
+  appendLengthArray,
+  fromLengthList,
+) where
+
+import Prelude hiding (drop, length, replicate, take)
+
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as BSL
+import Data.List qualified as List
+import Data.Maybe (fromJust, fromMaybe)
+import Data.Proxy (Proxy (..))
+import Data.String (IsString (..))
+import Data.Vector qualified as V
+import Data.Word (Word8)
+import GHC.Stack (HasCallStack)
+import GHC.TypeLits (KnownNat, Nat, natVal, type CmpNat, type (+))
+
+class HasLength a where
+  length :: a -> Int
+
+  -- | Equivalent to @'compare' . 'length'@ but allows more efficient
+  -- implementations
+  compareLength :: a -> Int -> Ordering
+  compareLength = compare . length
+
+class (Monoid a, HasLength a) => Array a where
+  type Elem a
+  take :: Int -> a -> a
+  replicate :: Int -> Elem a -> a
+  fromList :: [Elem a] -> a
+
+instance HasLength [a] where
+  length = List.length
+  compareLength [] n = compare 0 n
+  compareLength (_ : l) n = compareLength l (n - 1)
+instance Array [a] where
+  type Elem [a] = a
+  take = List.take
+  replicate = List.replicate
+  fromList = id
+
+instance HasLength (V.Vector a) where
+  length = V.length
+instance Array (V.Vector a) where
+  type Elem (V.Vector a) = a
+  take = V.take
+  replicate = V.replicate
+  fromList = V.fromList
+
+instance HasLength BS.ByteString where
+  length = BS.length
+instance Array BS.ByteString where
+  type Elem BS.ByteString = Word8
+  take = BS.take
+  replicate = BS.replicate
+  fromList = BS.pack
+
+instance HasLength BSL.ByteString where
+  length = fromIntegral . BSL.length
+  compareLength b n
+    | BSL.null b' = LT
+    | BSL.null (BSL.tail b') = EQ
+    | otherwise = GT
+   where
+    b' = BSL.drop (fromIntegral n - 1) b
+instance Array BSL.ByteString where
+  type Elem BSL.ByteString = Word8
+  take = BSL.take . fromIntegral
+  replicate = BSL.replicate . fromIntegral
+  fromList = BSL.pack
+
+class KnownOrdering (o :: Ordering) where
+  orderingVal :: proxy o -> Ordering
+
+instance KnownOrdering 'LT where orderingVal _ = LT
+instance KnownOrdering 'EQ where orderingVal _ = EQ
+instance KnownOrdering 'GT where orderingVal _ = GT
+
+-- | Assertion that the contained array satisfies @'compareLength' a n = o@
+newtype LengthArray (o :: Ordering) (n :: Nat) a
+  = LengthArray {unLengthArray :: a}
+  deriving (Eq, Ord, Show)
+
+instance (HasLength a) => HasLength (LengthArray o n a) where
+  length = length . unLengthArray
+  compareLength = compareLength . unLengthArray
+
+-- | Assertion that the contained array is exactly a static length
+type FixedLengthArray n a = LengthArray 'EQ n a
+
+-- | Assertion that the contained array is at most a static length (inclusive)
+type BoundedLengthArray n a = LengthArray 'LT (n + 1) a
+
+lengthArrayOrdering ::
+  forall o n a. (KnownOrdering o) => LengthArray o n a -> Ordering
+lengthArrayOrdering _ = orderingVal (Proxy :: Proxy o)
+
+lengthArrayBound :: forall o n a. (KnownNat n) => LengthArray o n a -> Int
+lengthArrayBound _ = fromInteger $ natVal (Proxy :: Proxy n)
+
+orderingOp :: Ordering -> Char
+orderingOp LT = '<'
+orderingOp EQ = '='
+orderingOp GT = '>'
+
+describeLengthArray ::
+  (KnownOrdering o, KnownNat n) => LengthArray o n a -> String
+describeLengthArray a =
+  orderingOp (lengthArrayOrdering a) : show (lengthArrayBound a)
+
+-- | Static length of a 'FixedLengthArray'
+fixedLengthArrayLength :: (KnownNat n) => LengthArray 'EQ n a -> Int
+fixedLengthArrayLength = lengthArrayBound
+
+-- | Static upper-bound (inclusive) of a 'BoundedLengthArray'
+boundedLengthArrayBound :: (KnownNat n) => LengthArray 'LT n a -> Int
+boundedLengthArrayBound = subtract 1 . lengthArrayBound
+
+{- | Unsafely create a 'LengthArray' without checking the length bound
+assertion. May cause unpredictable behavior if the bound does not hold.
+-}
+unsafeLengthArray :: a -> LengthArray o n a
+unsafeLengthArray = LengthArray
+
+checkLengthArray ::
+  (KnownOrdering o, KnownNat n, HasLength a) => LengthArray o n a -> Bool
+checkLengthArray l@(LengthArray a) =
+  compareLength a (lengthArrayBound l) == lengthArrayOrdering l
+
+{- | Safely create a 'LengthArray' out of an array if it conforms to the static
+length assertion.
+-}
+lengthArray ::
+  forall o n a.
+  (KnownOrdering o, KnownNat n, HasLength a) =>
+  a ->
+  Maybe (LengthArray o n a)
+lengthArray a
+  | checkLengthArray l = Just l
+  | otherwise = Nothing
+ where
+  l = LengthArray a :: LengthArray o n a
+
+{- | Create a 'LengthArray' or runtime error if the assertion fails:
+@fromMaybe undefined . 'lengthArray'@
+-}
+lengthArray' ::
+  forall o n a.
+  (HasCallStack, KnownOrdering o, KnownNat n, HasLength a) =>
+  a ->
+  LengthArray o n a
+lengthArray' a =
+  fromMaybe
+    (error $ "lengthArray': fails check " ++ describeLengthArray (fromJust la))
+    la
+ where
+  la = lengthArray a
+
+-- | Create a 'BoundedLengthArray' by trimming the given array if necessary.
+boundLengthArray :: (KnownNat n, Array a) => a -> LengthArray 'LT n a
+boundLengthArray a = l
+ where
+  l = LengthArray $ take (boundedLengthArrayBound l) a
+
+-- | Create a 'BoundedLengthArray' by trimming the given array if necessary.
+boundLengthArrayFromList ::
+  (KnownNat n, Array a) => [Elem a] -> LengthArray 'LT n a
+boundLengthArrayFromList a = l
+ where
+  l = LengthArray $ fromList $ take (boundedLengthArrayBound l) a
+
+{- | Create a 'FixedLengthArray' by trimming or padding (on the right)
+as necessary.
+-}
+padLengthArray :: (KnownNat n, Array a) => a -> Elem a -> LengthArray 'EQ n a
+padLengthArray a p = l
+ where
+  a' = case compareLength a n of
+    LT -> a <> replicate (n - length a) p
+    EQ -> a
+    GT -> take n a
+  n = fixedLengthArrayLength l
+  l = LengthArray a'
+
+-- | Create a 'FixedLengthArray' filled with the same value.
+constLengthArray :: (KnownNat n, Array a) => Elem a -> LengthArray 'EQ n a
+constLengthArray p = l
+ where
+  l = LengthArray $ replicate (fixedLengthArrayLength l) p
+
+instance
+  (KnownOrdering o, KnownNat n, IsString a, HasLength a) =>
+  IsString (LengthArray o n a)
+  where
+  fromString s =
+    fromMaybe
+      ( error $
+          "String "
+            ++ show s
+            ++ " fails LengthArray check "
+            ++ describeLengthArray (fromJust ls)
+      )
+      ls
+   where
+    ls = lengthArray $ fromString s
+
+-- | An empty 'FixedLengthArray'.
+emptyFixedLengthArray :: (Array a) => LengthArray 'EQ 0 a
+emptyFixedLengthArray = LengthArray mempty
+
+-- | An empty 'BoundedLengthArray'.
+emptyBoundedLengthArray :: (CmpNat 0 n ~ 'LT, Array a) => LengthArray 'LT n a
+emptyBoundedLengthArray = LengthArray mempty
+
+-- | Grow the bound of a 'BoundedLengthArray'.
+expandBoundedLengthArray ::
+  (CmpNat n m ~ 'LT) => LengthArray 'LT n a -> LengthArray 'LT m a
+expandBoundedLengthArray = LengthArray . unLengthArray
+
+-- | Convert a 'FixedLengthArray' to a 'BoundedLengthArray'.
+boundFixedLengthArray ::
+  (CmpNat n m ~ 'LT) => LengthArray 'EQ n a -> LengthArray 'LT m a
+boundFixedLengthArray = LengthArray . unLengthArray
+
+-- | Append to two 'LengthArray's.
+appendLengthArray ::
+  (Monoid a) =>
+  LengthArray o n a ->
+  LengthArray o m a ->
+  LengthArray o (n + m) a
+appendLengthArray (LengthArray a) (LengthArray b) = LengthArray $ mappend a b
+
+fromLengthList :: (Array a) => LengthArray o n [Elem a] -> LengthArray o n a
+fromLengthList = LengthArray . fromList . unLengthArray

bundled/Network/ONCRPC/XDR/Cabal.hs

@@ -0,0 +1,61 @@
+-- | Cabal utilities for XDR processing.
+module Network.ONCRPC.XDR.Cabal
+  ( ppRPCGenSuffixHandler
+  ) where
+
+import           Data.Char (toLower)
+import           Data.Coerce
+import           Data.List (intercalate, isPrefixOf)
+import           Data.Maybe (fromMaybe, mapMaybe)
+import           Distribution.PackageDescription (BuildInfo(customFieldsBI))
+import           Distribution.Verbosity (Verbosity)
+import           Distribution.Simple.LocalBuildInfo (LocalBuildInfo, ComponentLocalBuildInfo)
+import           Distribution.Simple.PreProcess (PreProcessor(..), PPSuffixHandler, Suffix(..))
+import           Distribution.Simple.Utils (info)
+import           System.FilePath ((</>), dropExtension, splitDirectories)
+
+import           Network.ONCRPC.XDR.Generate
+
+runRPCGen :: [(String, String)] -> (FilePath, FilePath) -> (FilePath, FilePath) -> Verbosity -> IO ()
+runRPCGen custom (indir, infile) (outdir, outfile) verb = do
+  info verb $ "hdrpcgen " ++ inpath ++ " with " ++ show opts
+  writeFile outpath
+    =<< generateFromFile opts inpath
+  where
+  opts = GenerateOptions
+    { generateModuleName = modname
+    , generateReidentOptions = ReidentOptions
+      { reidentUpperPrefix = fromMaybe "" $ opt "upper-prefix"
+      , reidentLowerPrefix = fromMaybe "" $ opt "lower-prefix"
+      , reidentJoinField = joinopt "field"
+      , reidentJoinProcedure = joinopt "procedure"
+      }
+    }
+  joinopt t = case (maybe False boolish $ opt $ t ++ "s-unique", opt $ "join-" ++ t) of
+    (False, j) -> Just $ fromMaybe "'" j
+    (True, Nothing) -> Nothing
+    (True, Just _) ->
+      error "x-rpcgen join and unique options are mutually exclusive"
+  boolish s = map toLower s `isPrefixOf` "true"
+  opt f = lookup f custom
+  inpath = indir </> infile
+  outpath = outdir </> outfile
+  modname = intercalate "." $ splitDirectories $ dropExtension infile
+
+ppRPCGenCustomField :: (String, String) -> Maybe (String, String)
+ppRPCGenCustomField ('x':'-':'r':'p':'c':'g':'e':'n':'-':f,v) = Just (f,v)
+ppRPCGenCustomField _ = Nothing
+
+ppRPCGen :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
+ppRPCGen bi _ _ = PreProcessor
+  { platformIndependent = True
+  , runPreProcessor = runRPCGen $ mapMaybe ppRPCGenCustomField $ customFieldsBI bi
+  , ppOrdering = undefined
+  }
+
+-- |Pre-processor for hsrpcgen.
+-- You can use it by setting @'Distribution.Simple.UserHooks' { 'Distribution.Simple.hookedPrepProcessors' = ['ppRPCGenSuffixHandler'] }@.
+-- Note that this will override the default alex @.x@ file handler.
+-- You can also specify custom cabal fields corresponding to 'ReidentOptions' and command-line flags prefixed with @x-rpcgen-@: @{upper,lower}-prefix@, @join-{field,procedure}@, and @{field,procedure}s-unique}@.
+ppRPCGenSuffixHandler :: PPSuffixHandler
+ppRPCGenSuffixHandler = (coerce "x", ppRPCGen)

bundled/Network/ONCRPC/XDR/Generate.hs

@@ -0,0 +1,306 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | Generate Haskell code from XDR descriptions as per RFC4506 and RPC extensions from RFC5531
+module Network.ONCRPC.XDR.Generate
+  ( generateFromFile
+  , generate
+  , generateModule
+  , ReidentOptions(..)
+  , GenerateOptions(..)
+  , defaultReidentOptions
+  ) where
+
+import           Control.Arrow ((***), (&&&))
+import qualified Data.ByteString.Lazy.Char8 as BSLC
+import           Data.Char (isAlpha, isUpper)
+import           Data.Maybe (fromMaybe, maybeToList)
+import qualified Language.Haskell.Exts.Build as HS
+import           Language.Haskell.Exts.Pretty (prettyPrintWithMode, PPHsMode(..), defaultMode)
+import qualified Language.Haskell.Exts.Syntax as HS
+
+import qualified Network.ONCRPC.XDR as XDR
+import           Network.ONCRPC.XDR.Specification
+import qualified Network.ONCRPC.XDR.Parse as XDR
+import           Network.ONCRPC.XDR.Reident
+
+name :: String -> HS.Name ()
+name "" = error "empty name"
+name s@(c:_)
+  | isAlpha c || c == '_' = HS.Ident () s
+  | otherwise = HS.Symbol () s
+
+infix 9 !, !.
+(!) :: String -> String -> HS.QName ()
+(!) "" = HS.UnQual () . name
+(!) m = HS.Qual () (HS.ModuleName () m) . name
+
+(!.) :: String -> String -> HS.Exp ()
+_ !. [] = error "empty qualified name"
+m !. n@(c:_)
+  | isUpper c || c == ':' = HS.Con () $ m ! n
+  | otherwise = HS.Var () $ m ! n
+
+instDecl :: HS.QName () -> String -> [HS.InstDecl ()] -> HS.Decl ()
+instDecl c t = HS.InstDecl () Nothing
+  (HS.IRule () Nothing Nothing $ HS.IHApp () (HS.IHCon () c) $ HS.TyCon () $ ""!t)
+  . Just
+
+dataDecl :: String -> [HS.ConDecl ()] -> [String] -> HS.Decl ()
+dataDecl n con derive = HS.DataDecl () (HS.DataType ()) Nothing (HS.DHead () $ HS.name n)
+  (map (HS.QualConDecl () Nothing Nothing) con)
+  [HS.Deriving () Nothing $ map (HS.IRule () Nothing Nothing . HS.IHCon () . ("Prelude"!)) derive]
+
+constantType :: HS.Type ()
+constantType = HS.TyForall ()
+  Nothing
+  ( Just $
+    HS.CxSingle () $
+    HS.TypeA () (HS.TyApp () (HS.TyCon () ("Prelude"!"Integral")) t)
+  )
+  t
+  where
+  t = HS.TyVar () $ HS.name "a"
+
+primType :: TypeSpecifier -> Maybe String
+primType TypeInt           = Just "Int"
+primType TypeUnsignedInt   = Just "UnsignedInt"
+primType TypeHyper         = Just "Hyper"
+primType TypeUnsignedHyper = Just "UnsignedHyper"
+primType TypeFloat         = Just "Float"
+primType TypeDouble        = Just "Double"
+primType TypeQuadruple     = Just "Quadruple"
+primType TypeBool          = Just "Bool"
+primType _                 = Nothing
+
+specType :: TypeSpecifier -> Maybe (HS.Type ())
+specType (TypeIdentifier t) = Just $ HS.TyCon () $ ""!t
+specType t = HS.TyCon () . (!) "XDR" <$> primType t
+
+specType' :: TypeSpecifier -> HS.Type ()
+specType' =
+  fromMaybe (error "parameter data structures are not supported") . specType
+
+lengthType :: String -> XDR.Length -> HS.Type ()
+lengthType t l = HS.TyApp () (HS.TyCon () $ "XDR"!t) $ HS.TyPromoted () $ HS.PromotedInteger () (toInteger l) (show l)
+
+descrType :: TypeDescriptor -> Maybe (HS.Type ())
+descrType (TypeSingle t) = specType t
+descrType (TypeArray t (FixedLength l))    = HS.TyApp () (lengthType "FixedArray"  l) <$> specType t
+descrType (TypeArray t (VariableLength l)) = HS.TyApp () (lengthType "Array"       l) <$> specType t
+descrType (TypeOpaque  (FixedLength l))    = Just $       lengthType "FixedOpaque" l
+descrType (TypeOpaque  (VariableLength l)) = Just $       lengthType "Opaque"      l
+descrType (TypeString  (FixedLength l))    = Just $       lengthType "FixedString" l
+descrType (TypeString  (VariableLength l)) = Just $       lengthType "String"      l
+descrType (TypeOptional t) = HS.TyApp ()        (HS.TyCon () $ "XDR"!"Optional")      <$> specType t
+
+declType' :: Declaration -> HS.Type ()
+declType' (Declaration n t) = fromMaybe (error $ "nested data structures are not supported: " ++ show n) $ descrType t
+
+strictType :: HS.Type () -> HS.Type ()
+strictType = HS.TyBang () (HS.BangedTy ()) (HS.NoUnpackPragma ())
+
+declaration :: Declaration -> [HS.FieldDecl ()]
+declaration (Declaration _ (TypeSingle (TypeStruct (StructBody dl)))) =
+  concatMap declaration dl
+declaration d@(Declaration i _) =
+  [HS.FieldDecl () [HS.name i] $ strictType $ declType' d]
+
+optionalDeclaration :: OptionalDeclaration -> [HS.FieldDecl ()]
+optionalDeclaration = foldMap declaration
+
+typeDef :: String -> HS.Decl ()
+typeDef = HS.simpleFun (HS.name "xdrType") (HS.name "_") . HS.strE
+
+fieldNames :: [HS.FieldDecl ()] -> [HS.Name ()]
+fieldNames = concatMap $ \(HS.FieldDecl _ nl _) -> nl
+
+putFields :: HS.Exp () -> [HS.FieldDecl ()] -> HS.Exp ()
+putFields _ [] = HS.app ("Control.Applicative"!."pure") (HS.Con () $ HS.Special () $ HS.UnitCon ())
+putFields x l = foldl1 (flip HS.infixApp $ HS.QVarOp () $ "Control.Applicative"!"*>")
+  $ map (HS.app ("XDR"!."xdrPut") . flip HS.app x . HS.var)
+  $ fieldNames l
+
+getFields :: HS.Exp () -> [HS.FieldDecl ()] -> HS.Exp ()
+getFields n = foldl (\c _ -> HS.infixApp c (HS.QVarOp () $ "Control.Applicative"!"<*>") $ "XDR"!."xdrGet") n . fieldNames
+
+pureCon :: String -> HS.Exp ()
+pureCon = HS.app ("Control.Applicative"!."pure") . HS.Con () . (""!)
+
+sMatch :: String -> HS.Pat () -> HS.Exp () -> HS.Match ()
+sMatch n p e = HS.Match () (HS.name n) [p] (HS.UnGuardedRhs () e) Nothing
+
+definition :: Definition -> [HS.Decl ()]
+definition (Definition n (TypeDef (TypeSingle (TypeEnum (EnumBody el))))) =
+  [ dataDecl n
+    (map (flip (HS.ConDecl ()) [] . HS.name . fst) el)
+    ["Eq", "Ord", "Enum", "Bounded", "Show"]
+  , instDecl ("XDR"!"XDR") n $ map (HS.InsDecl ())
+    [ typeDef n
+    , HS.nameBind (HS.name "xdrPut") $ "XDR"!."xdrPutEnum"
+    , HS.nameBind (HS.name "xdrGet") $ "XDR"!."xdrGetEnum"
+    ]
+  , instDecl ("XDR"!"XDREnum") n $ map (HS.InsDecl ())
+    [ HS.FunBind () $ map (\(i,v) ->
+        sMatch "xdrFromEnum" (HS.pApp (HS.name i) []) $ HS.intE $ toInteger v)
+      el
+    , HS.FunBind () $ map (\(i,v) ->
+        sMatch "xdrToEnum" (HS.intP $ toInteger v) $ HS.app ("Prelude"!."return") $ HS.Con () $ ""!i)
+      el ++
+      [ sMatch "xdrToEnum" (HS.PWildCard ()) $ HS.app ("Prelude"!."fail") $ HS.strE $ "invalid " ++ n]
+    ]
+  ]
+definition (Definition n (TypeDef (TypeSingle (TypeStruct (StructBody dl))))) =
+  [ dataDecl n
+    [HS.RecDecl () (HS.name n) hdl]
+    ["Eq", "Show"]
+  , instDecl ("XDR"!"XDR") n $ map (HS.InsDecl ())
+    [ typeDef n
+    , HS.simpleFun (HS.name "xdrPut") (HS.name "_x") $ putFields (HS.var $ HS.name "_x") hdl
+    , HS.nameBind (HS.name "xdrGet") $ getFields (pureCon n) hdl
+    ]
+  ] where
+  hdl = concatMap declaration dl
+definition (Definition n (TypeDef (TypeSingle (TypeUnion (UnionBody d@(Declaration dn _) cl o))))) =
+  [ dataDecl n
+    (map (\(_,(l,b)) ->
+      HS.RecDecl () (HS.name l) b) hcl
+    ++ maybe [] (\(l,b) -> [HS.RecDecl () (HS.name l)
+      $ HS.FieldDecl () [HS.name hom] (strictType hdt) : b])
+      ho)
+    ["Eq", "Show"]
+  , HS.TypeSig () [HS.name dn] $ HS.TyFun () (HS.TyCon () $ ""!n) hdt
+  , HS.nameBind (HS.name dn) $ "XDR"!."xdrDiscriminant"
+  , instDecl ("XDR"!"XDR") n $ map (HS.InsDecl ())
+    [ typeDef n
+    , HS.nameBind (HS.name "xdrPut") $ "XDR"!."xdrPutUnion"
+    , HS.nameBind (HS.name "xdrGet") $ "XDR"!."xdrGetUnion"
+    ]
+  , instDecl ("XDR"!"XDRUnion") n
+    [ HS.InsType () (HS.TyApp () (HS.TyCon () $ ""!"XDRDiscriminant") (HS.TyCon () $ ""!n)) hdt
+    , HS.InsDecl () $ HS.FunBind () $ map
+        (uncurry (split [] . HS.intE))
+        hcl
+      ++ maybeToList (split
+          [HS.PFieldPat () (""!hom) (HS.pvar $ HS.name "d")]
+          (HS.app ("XDR"!."xdrFromEnum") (""!."d"))
+        <$> ho)
+    , HS.InsDecl () $ HS.FunBind () $ map (\(c,(l,b)) ->
+        sMatch "xdrGetUnionArm"
+          (HS.intP c)
+          $ getFields (pureCon l) b)
+      hcl
+      ++ [sMatch "xdrGetUnionArm"
+          (HS.pvar $ HS.name "_c")
+          $ maybe
+            (HS.app ("Prelude"!."fail") $ HS.strE $ "invalid " ++ n ++ " discriminant")
+            (\(l,b) -> getFields (HS.infixApp (HS.Con () $ ""!l) (HS.QVarOp () $ "Control.Applicative"!"<$>")
+              (HS.app ("XDR"!."xdrToEnum") $ HS.var $ HS.name "_c")) b)
+            ho]
+    ]
+  ] where
+  split p c (l,b) = sMatch "xdrSplitUnion"
+    (HS.PAsPat () (HS.name "_x") $ HS.PRec () (""!l) p)
+    $ HS.tuple [c, putFields (""!."_x") b]
+  hdt = declType' d
+  hcl = map (toInteger *** arm) cl
+  hom = dn ++ "'"
+  ho = arm <$> o
+  arm = unionCaseIdentifier &&& optionalDeclaration . unionDeclaration
+definition (Definition n (TypeDef t)) =
+  [ HS.TypeDecl () (HS.DHead () $ HS.name n) $ declType' (Declaration n t)
+  ]
+definition (Definition n (Constant v)) =
+  [ HS.TypeSig () [HS.name n] constantType
+  , HS.nameBind (HS.name n) $ HS.intE v
+  ]
+definition (Definition n (Program t vl px)) =
+  [ HS.TypeSig () [HS.name n] $ HS.TyCon () $ ""!t
+  , HS.nameBind (HS.name n) $ HS.appFun (""!.t) $ map (\(Version _ vt rl vx) ->
+      HS.appFun (""!.vt) $ map (\(Procedure _ _ _ rx) ->
+          HS.appFun ("RPC"!."Procedure") $ map (HS.intE . toInteger) [px, vx, rx])
+        rl)
+      vl
+  , dataDecl t [HS.RecDecl () (HS.name t) (map (\(Version vn vt _ _) ->
+      HS.FieldDecl () [HS.name vn] $ strictType $ HS.TyCon () $ ""!vt)
+    vl)] []
+  ] ++ map (\(Version _ vt rl _) ->
+    dataDecl vt [HS.RecDecl () (HS.name vt) (map (\(Procedure rr rn ra _) ->
+      HS.FieldDecl () [HS.name rn]
+        $ strictType $ HS.TyApp () (HS.TyApp () (HS.TyCon () $ "RPC"!"Procedure")
+        $ tt $ map specType' ra)
+        $ maybe (HS.unit_tycon ()) specType' rr)
+    rl)] []
+  ) vl
+  where
+  tt [] = HS.unit_tycon ()
+  tt [a] = a
+  tt l = HS.TyTuple () HS.Boxed l
+
+hasProgramDefinition :: Specification -> Bool
+hasProgramDefinition = any isProgramDefinition where
+  isProgramDefinition (Definition _ Program{}) = True
+  isProgramDefinition _ = False
+
+specification :: String -> Specification -> HS.Module ()
+specification specName specContent =
+  HS.Module
+    ()
+    (Just $ HS.ModuleHead () (HS.ModuleName () specName) Nothing Nothing)
+    [HS.LanguagePragma () $ map HS.name ["DataKinds", "TypeFamilies"]]
+    ( [ importDecl "Prelude" Nothing
+      , importDecl "Control.Applicative" Nothing
+      , importDecl "Network.ONCRPC.XDR" $ Just $ HS.ModuleName () "XDR"
+      ]
+    ++
+      [ importDecl "Network.ONCRPC.Types" $ Just $ HS.ModuleName () "RPC"
+      | hasProgramDefinition specContent
+      ]
+    )
+    (concatMap definition specContent)
+  where
+    importDecl importModule importAs =
+      HS.ImportDecl
+      { importAnn = ()
+      , importModule = HS.ModuleName () importModule
+      , importQualified = True
+      , importSrc = False
+      , importSafe = False
+      , importPkg = Nothing
+      , importAs
+      , importSpecs = Nothing
+      }
+
+-- |Options for generating Haskell code
+data GenerateOptions = GenerateOptions
+  { generateModuleName :: String -- ^Name for the generated module
+  , generateReidentOptions :: ReidentOptions
+  }
+  deriving (Eq, Show)
+
+-- |Parse an XDR specification and generate a Haskell module, or fail on error.
+-- The 'String' argument provides a description of the input to use in parse errors.
+generateModule :: MonadFail m => GenerateOptions -> String -> BSLC.ByteString -> m (HS.Module ())
+generateModule GenerateOptions{..} n b = do
+  (d, s) <- either (fail . show) return $ XDR.parse n b
+  return $ specification generateModuleName $ reident generateReidentOptions s d
+
+-- |Parse an XDR specification and generate pretty-printed Haskell source string, or fail on error.
+-- The 'String' argument provides a description of the input to use in parse errors.
+generate :: MonadFail m => GenerateOptions -> String -> BSLC.ByteString -> m String
+generate opts n s = do
+  m <- generateModule opts n s
+  return $ "-- |Generated from " ++ n ++ " by <https://github.com/dylex/haskell-nfs/tree/master/rpc hsrpcgen>\n"
+    ++ prettyPrintWithMode defaultMode
+      { classIndent   = 2
+      , doIndent      = 2
+      , multiIfIndent = 2
+      , caseIndent    = 2
+      , letIndent     = 2
+      , whereIndent   = 2
+      , onsideIndent  = 2
+      } m
+
+-- |'generate' from a file.
+generateFromFile :: GenerateOptions -> FilePath -> IO String
+generateFromFile opts f = generate opts f =<< BSLC.readFile f

bundled/Network/ONCRPC/XDR/Opaque.hs

@@ -0,0 +1,42 @@
+-- |Marshalling values into and out of 'Network.ONCRPC.XDR.Types.Opaque' byte strings.
+-- Not really part of XDR, but convenient way to avoid many conversion functions.
+
+{-# LANGUAGE DefaultSignatures #-}
+module Network.ONCRPC.XDR.Opaque
+  ( Opaqued(..)
+  , unopacify'
+  , toOpaque
+  , toOpaque'
+  , fromOpaque
+  , fromOpaque'
+  ) where
+
+import           Data.ByteString (ByteString)
+
+import           Network.ONCRPC.XDR.Array
+import           Network.ONCRPC.XDR.Serial
+
+-- |Values that can be stored in an 'Network.ONCRPC.XDR.Types.Opaque' 'ByteString'.
+-- The default implementation allows (re-)embedding of XDR-encoded data, such as with 'RPC.Opaque_auth'.
+class Opaqued a where
+  opacify :: a -> ByteString
+  default opacify :: XDR a => a -> ByteString
+  opacify = xdrSerialize
+  unopacify :: MonadFail m => ByteString -> m a
+  default unopacify :: (XDR a, MonadFail m) => ByteString -> m a
+  unopacify = either fail return . xdrDeserialize
+
+unopacify' :: Opaqued a => ByteString -> a
+unopacify' = either error id . unopacify
+
+toOpaque :: (Opaqued a, KnownOrdering o, KnownNat n) => a -> Maybe (LengthArray o n ByteString)
+toOpaque = lengthArray . opacify
+
+toOpaque' :: (Opaqued a, KnownOrdering o, KnownNat n) => a -> LengthArray o n ByteString
+toOpaque' = lengthArray' . opacify
+
+fromOpaque :: (Opaqued a, MonadFail m) => LengthArray o n ByteString -> m a
+fromOpaque = unopacify . unLengthArray
+
+fromOpaque' :: Opaqued a => LengthArray o n ByteString -> a
+fromOpaque' = unopacify' . unLengthArray

bundled/Network/ONCRPC/XDR/Parse.hs

@@ -0,0 +1,307 @@
+-- | XDR Parser for .x files, as per RFC4506 and RPC extensions from RFC5531
+module Network.ONCRPC.XDR.Parse
+  ( Binding(..)
+  , Scope
+  , parse
+  ) where
+
+import           Control.Applicative ((<|>))
+import           Control.Arrow (second)
+import           Control.Monad (void, join, liftM2)
+import qualified Data.ByteString.Lazy as BSL
+import           Data.Char (digitToInt, isLower, isUpper, toLower, toUpper)
+import           Data.Functor.Identity (Identity)
+import qualified Data.Map as Map
+import           Data.Maybe (catMaybes, mapMaybe)
+import qualified Data.Set as Set
+import qualified Text.Parsec as P
+import           Text.Parsec ((<?>))
+import qualified Text.Parsec.Token as PT
+
+import qualified Network.ONCRPC.XDR.Types as XDR
+import           Network.ONCRPC.XDR.Specification hiding (arrayLength)
+
+data Binding = Binding
+  { bindingInitCaseConflict :: !Bool -- ^Same name as another identifier modulo first character case
+  , bindingDefinition :: !DefinitionBody
+  }
+
+type Scope = Map.Map String Binding
+type Stream = BSL.ByteString
+type Parser = P.Parsec Stream Scope
+
+tupleM :: Monad m => m a -> m b -> m (a, b)
+tupleM = liftM2 (,)
+
+baseScope :: Scope
+baseScope =
+  Map.fromList $
+    ( "bool"
+    , Binding False $ TypeDef $ TypeSingle $ TypeEnum $ EnumBody boolValues
+    )
+    : map (second (Binding False . TypeDef . TypeSingle))
+        [ ("int",       TypeInt)
+        , ("unsigned",  TypeUnsignedInt)
+        , ("hyper",     TypeHyper)
+        , ("float",     TypeFloat)
+        , ("double",    TypeDouble)
+        , ("quadruple", TypeQuadruple)
+        ]
+    ++ map (second $ Binding False . Constant . toInteger) boolValues
+
+toggleCase :: String -> String
+toggleCase (c:s)
+  | isUpper c = toLower c:s
+  | isLower c = toUpper c:s
+toggleCase s = s
+
+addScope :: Definition -> Parser ()
+addScope (Definition i b) = do
+  case b of
+    TypeDef t -> void $ resolveTypeDescriptor t
+    _ -> return ()
+  s <- P.getState
+  case Map.insertLookupWithKey (const const) i (Binding (Map.member (toggleCase i) s) b) s of
+    (Nothing, s') -> P.putState s'
+    _ -> fail $ "duplicate identifier: " ++ show i
+
+checkInt :: (MonadFail m, Integral n) => Integer -> m n
+checkInt n
+  | n == toInteger n' = return n'
+  | otherwise = fail "invalid constant"
+  where n' = fromInteger n
+
+data Value
+  = ValueIdentifier !String
+  | ValueConstant !Integer
+  deriving (Show)
+
+resolveValue :: Integral n => Value -> Parser n
+resolveValue (ValueConstant n) = checkInt n
+resolveValue (ValueIdentifier v) = do
+  s <- P.getState
+  case Map.lookup v s of
+    Just (Binding _ (Constant n)) -> checkInt n
+    _ -> fail $ "undefined constant: " ++ show v
+
+-- |Expand 'TypeSingle' 'TypeIdentifier'
+resolveTypeDescriptor :: TypeDescriptor -> Parser TypeDescriptor
+resolveTypeDescriptor (TypeSingle (TypeIdentifier i)) = do
+  s <- P.getState
+  case Map.lookup i s of
+    Just (Binding _ (TypeDef t)) -> resolveTypeDescriptor t
+    _ -> fail $ "undefined type: " ++ show i
+resolveTypeDescriptor d = return d
+
+literalLetter :: Parser Char
+literalLetter = P.alphaNum <|> P.char '_'
+
+token :: PT.GenTokenParser Stream Scope Identity
+token = PT.makeTokenParser PT.LanguageDef
+  { PT.commentStart    = "/*"
+  , PT.commentEnd      = "*/"
+  , PT.commentLine     = "//"
+  , PT.nestedComments  = False
+  , PT.identStart      = P.letter
+  , PT.identLetter     = literalLetter
+  , PT.opStart         = fail "token op"
+  , PT.opLetter        = fail "token op"
+  , PT.reservedNames   =
+    [ "bool"
+    , "case"
+    , "const"
+    , "default"
+    , "double"
+    , "quadruple"
+    , "enum"
+    , "float"
+    , "hyper"
+    , "int"
+    , "opaque"
+    , "string"
+    , "struct"
+    , "switch"
+    , "typedef"
+    , "union"
+    , "unsigned"
+    , "void"
+
+    , "program"
+    , "version"
+    ]
+  , PT.reservedOpNames = []
+  , PT.caseSensitive   = True
+  }
+
+reserved :: String -> Parser ()
+reserved = PT.reserved token
+
+identifier :: Parser String
+identifier = PT.identifier token
+
+endSemi1 :: Parser a -> Parser [a]
+endSemi1 p = p `P.endBy1` PT.semi token
+
+arrayLength, variableArrayLength :: Parser ArrayLength
+variableArrayLength =
+  VariableLength <$> PT.angles token (P.option XDR.maxLength value)
+arrayLength =
+  FixedLength    <$> PT.brackets token value
+  <|> variableArrayLength
+
+declaration :: Parser Declaration
+declaration =
+      typeDeclaration
+  <|> opaqueDeclaration
+  <|> stringDeclaration
+  where
+  typeDeclaration = do
+    t <- typeSpecifier
+    Declaration
+        <$> (PT.symbol token "*" *> identifier)
+        <*> pure (TypeOptional t)
+      <|> Declaration
+        <$> identifier
+        <*> (TypeArray t <$> arrayLength <|> return (TypeSingle t))
+  opaqueDeclaration =
+    Declaration
+      <$> (reserved "opaque" *> identifier)
+      <*> (TypeOpaque <$> arrayLength)
+  stringDeclaration =
+    Declaration
+      <$> (reserved "string" *> identifier)
+      <*> (TypeString <$> variableArrayLength)
+
+optionalDeclaration :: Parser OptionalDeclaration
+optionalDeclaration =
+      Just <$> declaration
+  <|> Nothing <$ reserved "void"
+
+constant :: Parser Integer
+constant =
+  PT.lexeme token (nat <|> P.char '-' *> (negate <$> dec)) <?> "constant"
+  where
+    nat = P.char '0' *> (P.oneOf "xX" *> number 16 P.hexDigit <|> number 8 P.octDigit <|> return 0) <|> dec
+    dec = number 10 P.digit
+    number base digit = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 <$> P.many1 digit
+
+value :: Integral n => Parser n
+value = resolveValue =<<
+      ValueConstant <$> constant
+  <|> ValueIdentifier <$> identifier
+
+typeSpecifier :: Parser TypeSpecifier
+typeSpecifier = P.choice
+  [ TypeInt        <$ reserved "int"
+  , TypeHyper      <$ reserved "hyper"
+  , reserved "unsigned" *> (
+        TypeUnsignedInt   <$ reserved "int"
+    <|> TypeUnsignedHyper <$ reserved "hyper"
+    <|> return TypeUnsignedInt)
+  , TypeFloat      <$ reserved "float"
+  , TypeDouble     <$ reserved "double"
+  , TypeQuadruple  <$ reserved "quadruple"
+  , TypeBool       <$ reserved "bool"
+  , reserved "enum"  *> (TypeEnum   <$> enumBody   <|> typeIdentifier)
+  , reserved "struct"*> (TypeStruct <$> structBody <|> typeIdentifier)
+  , reserved "union" *> (TypeUnion  <$> unionBody  <|> typeIdentifier)
+  , typeIdentifier
+  ] where
+  typeIdentifier = TypeIdentifier <$> identifier
+
+checkUnique :: (Ord k, Show k) => String -> [k] -> Parser (Set.Set k)
+checkUnique t = ui Set.empty where
+  ui m [] = return m
+  ui m (k:l)
+    | Set.member k m = fail $ "duplicate " ++ t ++ ": " ++ show k
+    | otherwise = ui (Set.insert k m) l
+
+enumBody :: Parser EnumBody
+enumBody = do
+  l <- PT.braces token $ PT.commaSep1 token $
+    tupleM identifier (PT.symbol token "=" *> value)
+  _ <- checkUnique "enum identifier" $ fst <$> l
+  _ <- checkUnique "enum value" $ snd <$> l
+  mapM_ (\(i, v) -> addScope $ Definition i $ Constant $ toInteger v) l
+  return $ EnumBody l
+
+structBody :: Parser StructBody
+structBody = do
+  l <- PT.braces token $ catMaybes <$> endSemi1 optionalDeclaration
+  _ <- checkUnique "struct member" $ declarationIdentifier <$> l
+  return $ StructBody l
+
+unionBody :: Parser UnionBody
+unionBody = do
+  reserved "switch"
+  d <- PT.parens token declaration
+  r <- resolveTypeDescriptor $ declarationType d
+  p <- case r of
+    TypeSingle TypeInt -> return value
+    TypeSingle TypeUnsignedInt -> return $ fromIntegral <$> (value :: Parser XDR.UnsignedInt)
+    TypeSingle TypeBool -> return $ valid boolValues =<< value
+    TypeSingle (TypeEnum (EnumBody v)) -> return $ valid v =<< value
+    _ -> fail "invalid discriminant declaration"
+  PT.braces token $ do
+    l <- endSemi1 (tupleM
+      (P.many1 $ reserved "case" *> tupleM (P.lookAhead $ P.many1 literalLetter) p <* PT.colon token)
+      optionalDeclaration)
+    _ <- checkUnique "union member" $ mapMaybe (fmap declarationIdentifier . snd) l
+    _ <- checkUnique "union case" $ map snd . fst =<< l
+    f <- P.optionMaybe $ UnionArm "default" <$> (reserved "default" *> PT.colon token *> optionalDeclaration <* PT.semi token)
+    return $ UnionBody d [ (c, UnionArm s b) | (cs, b) <- l, (s, c) <- cs ] f
+  where
+  valid l n
+    | any ((n ==) . snd) l = return n
+    | otherwise = fail "invalid enum value"
+
+procedure :: Parser Procedure
+procedure = Procedure
+  <$> optionalType
+  <*> identifier
+  <*> PT.parens token (catMaybes <$> PT.commaSep1 token optionalType)
+  <*> (PT.symbol token "=" *> value)
+  where
+  optionalType :: Parser (Maybe TypeSpecifier)
+  optionalType =
+        Just <$> typeSpecifier
+    <|> Nothing <$ reserved "void"
+
+programVersion :: Parser Version
+programVersion = join Version
+  <$> (reserved "version" *> identifier)
+  <*> PT.braces token (endSemi1 procedure)
+  <*> (PT.symbol token "=" *> value)
+
+def :: Parser Definition
+def = constantDef <|> typeDef <|> programDef where
+  constantDef = Definition
+    <$> (reserved "const" *> identifier)
+    <*> (PT.symbol token "=" *> (Constant <$> constant))
+  typeDef =
+        reserved "typedef" *> (declDef <$> declaration)
+    <|> Definition <$> (reserved "enum"   *> identifier) <*> (TypeDef . TypeSingle . TypeEnum   <$> enumBody)
+    <|> Definition <$> (reserved "struct" *> identifier) <*> (TypeDef . TypeSingle . TypeStruct <$> structBody)
+    <|> Definition <$> (reserved "union"  *> identifier) <*> (TypeDef . TypeSingle . TypeUnion  <$> unionBody)
+  declDef (Declaration i t) = Definition i $ TypeDef t
+  programDef = do
+    reserved "program"
+    i <- identifier
+    Definition i <$> (Program i
+      <$> PT.braces token (endSemi1 programVersion)
+      <*> (PT.symbol token "=" *> value))
+
+definition :: Parser Definition
+definition = do
+  d <- def
+  addScope d
+  return d
+
+specification :: Parser Specification
+specification = endSemi1 definition
+
+file :: Parser (Specification, Scope)
+file = PT.whiteSpace token *> tupleM specification P.getState <* P.eof
+
+parse :: String -> BSL.ByteString -> Either P.ParseError (Specification, Scope)
+parse = P.runParser file baseScope

bundled/Network/ONCRPC/XDR/Reident.hs

@@ -0,0 +1,108 @@
+-- |Convert XDR identifiers to Haskell identifiers.
+-- Rules to convert identifiers in a 'Specification' to follow Haskell's lexical rules and ensure uniqueness for Haskell's scoping.
+{-# LANGUAGE RecordWildCards #-}
+module Network.ONCRPC.XDR.Reident
+  ( ReidentOptions(..)
+  , defaultReidentOptions
+  , reident
+  ) where
+
+import           Control.Arrow (first, second)
+import           Data.Char (isLower, isUpper, toLower, toUpper)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import           Network.ONCRPC.XDR.Specification
+import qualified Network.ONCRPC.XDR.Parse as XDR
+
+-- |How to generate Haskell identifiers from XDR in order to confirm to Haskell's lexical rules and ensure uniqueness.
+data ReidentOptions = ReidentOptions
+  { reidentUpperPrefix, reidentLowerPrefix :: String -- ^Prefix to use to make an identifier a different case if necessary, e.g. @\"_\"@ for lower-case, or @\"XDR_\"@ for upper case (default empty: just changes the first character, possibly resulting in names like @\"nFS_NULL\"@)
+  , reidentJoinField, reidentJoinProcedure :: Maybe String -- ^Prefix fields with their type name (or program, version name) and this string (necessary for most XDR files), or @Nothing@ to use only the field name (or procedure name), which assumes uniqueness across the file (e.g., if you wrote the file yourself, though often safe for procedures only) (default @Just \"\'\"@)
+  }
+  deriving (Eq, Show)
+
+defaultReidentOptions :: ReidentOptions
+defaultReidentOptions = ReidentOptions
+  { reidentUpperPrefix = ""
+  , reidentLowerPrefix = ""
+  , reidentJoinField = Just "'"
+  , reidentJoinProcedure = Just "'"
+  }
+
+data ReidentOps = ReidentOps
+  { reidentUpper, reidentLower :: String -> String
+  , reidentField, reidentProcedure :: String -> String -> String
+  , reidentUnique :: String -> String
+  }
+
+reidentOps :: ReidentOptions -> XDR.Scope -> ReidentOps
+reidentOps ReidentOptions{..} scope = ReidentOps
+  { reidentUpper = toUpperPrefix reidentUpperPrefix
+  , reidentLower = toLowerPrefix reidentLowerPrefix
+  , reidentField = joinField reidentJoinField
+  , reidentProcedure = joinField reidentJoinProcedure
+  , reidentUnique = unique
+  } where
+  toUpperPrefix _ "" = error "empty upper prefix"
+  toUpperPrefix p s@(h:t)
+    | isUpper h = s
+    | null p = toUpper h : t
+    | otherwise = p ++ s
+  toLowerPrefix _ "" = error "empty lower prefix"
+  toLowerPrefix p s@(h:t)
+    | isLower h = s
+    | null p = toLower h : t
+    | otherwise = p ++ s
+  joinField (Just c) p n = p ++ c ++ n
+  joinField Nothing _ n = n
+  unique n
+    | Set.member n dups = n ++ "'"
+    | otherwise = n
+  dups = Map.keysSet $ Map.filter XDR.bindingInitCaseConflict scope
+
+declaration :: ReidentOps -> String -> Declaration -> Declaration
+declaration ops n (Declaration m t) = Declaration (reidentLower ops nm) (typeDescriptor ops nm t) where
+  nm = reidentField ops n m
+
+typeSpecifier :: ReidentOps -> String -> TypeSpecifier -> TypeSpecifier
+typeSpecifier ops _ (TypeEnum (EnumBody el)) = TypeEnum $
+  EnumBody $ map (first $ reidentUnique ops) el
+typeSpecifier ops n (TypeStruct (StructBody dl)) = TypeStruct $
+  StructBody $ map (declaration ops n) dl
+typeSpecifier ops n (TypeUnion (UnionBody d cl o)) = TypeUnion $
+  UnionBody (decl d) (map (second arm) cl) (arm <$> o) where
+  arm (UnionArm l m) = UnionArm (con l) (decl <$> m)
+  con l = reidentUpper ops $ n ++ '\'' : l
+  decl = declaration ops n
+typeSpecifier ops _ (TypeIdentifier i) = TypeIdentifier $
+  reidentUpper ops $ reidentUnique ops i
+typeSpecifier _ _ t = t
+
+typeDescriptor :: ReidentOps -> String -> TypeDescriptor -> TypeDescriptor
+typeDescriptor ops n (TypeSingle t) = TypeSingle (typeSpecifier ops n t)
+typeDescriptor ops n (TypeArray t l) = TypeArray (typeSpecifier ops n t) l
+typeDescriptor ops n (TypeOptional t) = TypeOptional (typeSpecifier ops n t)
+typeDescriptor _ _ t = t
+
+procedure :: ReidentOps -> String -> Procedure -> Procedure
+procedure ops n (Procedure r m al x) = Procedure (ts <$> r) (reidentLower ops nm) (ts <$> al) x where
+  nm = reidentProcedure ops n m
+  ts = typeSpecifier ops nm
+
+version :: ReidentOps -> String -> Version -> Version
+version ops n (Version m t pl x) = Version (reidentLower ops nm) (reidentUpper ops nt) (map (procedure ops nm) pl) x where
+  nm = reidentProcedure ops n m
+  nt = reidentProcedure ops n t
+
+makeDefinition :: ReidentOps -> String -> DefinitionBody -> Definition
+makeDefinition ops n (TypeDef d) = Definition (reidentUpper ops n) $ TypeDef $ typeDescriptor ops n d
+makeDefinition ops n (Program t vl x) = Definition (reidentLower ops n) $ Program (reidentUpper ops t) (map (version ops n) vl) x
+makeDefinition ops n b@(Constant _) = Definition (reidentLower ops n) b
+
+definition :: ReidentOps -> Definition -> Definition
+definition ops (Definition n d) = makeDefinition ops (reidentUnique ops n) d
+
+reident :: ReidentOptions -> XDR.Scope -> Specification -> Specification
+reident o = map . definition . reidentOps o
+

bundled/Network/ONCRPC/XDR/Serial.hs

@@ -0,0 +1,291 @@
+{-# OPTIONS -Wno-orphans #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+
+-- | XDR Serialization
+module Network.ONCRPC.XDR.Serial (
+  XDR (..),
+  XDREnum (..),
+  xdrToEnum',
+  xdrPutEnum,
+  xdrGetEnum,
+  XDRUnion (..),
+  xdrDiscriminant,
+  xdrPutUnion,
+  xdrGetUnion,
+  xdrSerialize,
+  xdrSerializeLazy,
+  xdrDeserialize,
+  xdrDeserializeLazy,
+) where
+
+import Control.Monad (guard, replicateM, unless)
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as BSL
+import Data.Maybe (fromJust, listToMaybe)
+import Data.Proxy (Proxy (Proxy))
+import Data.Serialize (Get, Put)
+import Data.Serialize qualified as Serialize
+import Data.Vector (Vector)
+import Data.Vector qualified as Vector
+import GHC.TypeLits (natVal)
+import Network.ONCRPC.XDR.Types qualified as XDR
+
+import Network.ONCRPC.XDR.Array
+
+instance MonadFail (Either String) where
+  fail = Left
+
+-- | An XDR type that can be (de)serialized.
+class XDR a where
+  -- | XDR identifier/type descriptor; argument value is ignored.
+  xdrType :: a -> String
+
+  xdrPut :: a -> Put
+
+  xdrGet :: Get a
+
+instance XDR XDR.Int where
+  xdrType _ = "int"
+  xdrPut = Serialize.putInt32be
+  xdrGet = Serialize.getInt32be
+
+instance XDR XDR.UnsignedInt where
+  xdrType _ = "unsigned int"
+  xdrPut = Serialize.putWord32be
+  xdrGet = Serialize.getWord32be
+
+instance XDR XDR.Hyper where
+  xdrType _ = "hyper"
+  xdrPut = Serialize.putInt64be
+  xdrGet = Serialize.getInt64be
+
+instance XDR XDR.UnsignedHyper where
+  xdrType _ = "unsigned hyper"
+  xdrPut = Serialize.putWord64be
+  xdrGet = Serialize.getWord64be
+
+instance XDR XDR.Float where
+  xdrType _ = "float"
+  xdrPut = Serialize.putFloat32be
+  xdrGet = Serialize.getFloat32be
+
+instance XDR XDR.Double where
+  xdrType _ = "double"
+  xdrPut = Serialize.putFloat64be
+  xdrGet = Serialize.getFloat64be
+
+instance XDR XDR.Bool where
+  xdrType _ = "bool"
+  xdrPut = xdrPutEnum
+  xdrGet = xdrGetEnum
+
+{- | An XDR type defined with \"enum\".
+ Note that the 'XDREnum' 'XDR.Int' value is not (necessarily) the same as the 'Enum' 'Int' value.
+ The 'Enum' instance is derived automatically to allow 'succ', etc. to work usefully in Haskell, whereas the 'XDREnum' reflects the XDR-defined values.
+-}
+class (XDR a, Enum a) => XDREnum a where
+  xdrFromEnum :: a -> XDR.Int
+  xdrToEnum :: (MonadFail m) => XDR.Int -> m a
+
+instance XDREnum XDR.Int where
+  xdrFromEnum = id
+  xdrToEnum = pure
+
+instance XDREnum XDR.UnsignedInt where
+  xdrFromEnum = fromIntegral
+  xdrToEnum = pure . fromIntegral
+
+-- | Version of 'xdrToEnum' that fails at runtime for invalid values: @fromMaybe undefined . 'xdrToEnum'@.
+xdrToEnum' :: (XDREnum a) => XDR.Int -> a
+xdrToEnum' = either error id . xdrToEnum
+
+-- | Default implementation of 'xdrPut' for 'XDREnum'.
+xdrPutEnum :: (XDREnum a) => a -> Put
+xdrPutEnum = Serialize.put . xdrFromEnum
+
+-- | Default implementation of 'xdrGet' for 'XDREnum'.
+xdrGetEnum :: (XDREnum a) => Get a
+xdrGetEnum = xdrToEnum =<< Serialize.get
+
+instance XDREnum XDR.Bool where
+  xdrFromEnum False = 0
+  xdrFromEnum True = 1
+  xdrToEnum 0 = pure False
+  xdrToEnum 1 = pure True
+  xdrToEnum _ = fail "invalid bool"
+
+-- | An XDR type defined with \"union\"
+class (XDR a, XDREnum (XDRDiscriminant a)) => XDRUnion a where
+  type XDRDiscriminant a
+
+  -- | Split a union into its discriminant and body generator.
+  xdrSplitUnion :: a -> (XDR.Int, Put)
+
+  -- | Get the body of a union based on its discriminant.
+  xdrGetUnionArm :: XDR.Int -> Get a
+
+xdrDiscriminant :: (XDRUnion a) => a -> XDRDiscriminant a
+xdrDiscriminant = xdrToEnum' . fst . xdrSplitUnion
+
+-- | Default implementation of 'xdrPut' for 'XDRUnion'.
+xdrPutUnion :: (XDRUnion a) => a -> Put
+xdrPutUnion = uncurry ((>>) . xdrPut) . xdrSplitUnion
+
+-- | Default implementation of 'xdrGet' for 'XDRUnion'.
+xdrGetUnion :: (XDRUnion a) => Get a
+xdrGetUnion = xdrGet >>= xdrGetUnionArm
+
+instance (XDR a) => XDR (XDR.Optional a) where
+  xdrType = ('*' :) . xdrType . fromJust
+  xdrPut = xdrPutUnion
+  xdrGet = xdrGetUnion
+
+instance (XDR a) => XDRUnion (XDR.Optional a) where
+  type XDRDiscriminant (XDR.Optional a) = XDR.Bool
+  xdrSplitUnion Nothing = (0, pure ())
+  xdrSplitUnion (Just a) = (1, xdrPut a)
+  xdrGetUnionArm 0 = pure Nothing
+  xdrGetUnionArm 1 = Just <$> xdrGet
+  xdrGetUnionArm d = fail $ "xdrGetUnion: invalid discriminant for " ++ xdrType (undefined :: XDR.Optional a) ++ ": " ++ show d
+
+xdrPutPad :: XDR.Length -> Put
+xdrPutPad n = case n `mod` 4 of
+  0 -> pure ()
+  1 -> Serialize.putWord16host 0 >> Serialize.putWord8 0
+  2 -> Serialize.putWord16host 0
+  _ {- must be 3 -} -> Serialize.putWord8 0
+
+xdrGetPad :: XDR.Length -> Get ()
+xdrGetPad n = case n `mod` 4 of
+  0 -> pure ()
+  1 -> do
+    0 <- Serialize.getWord16host
+    0 <- Serialize.getWord8
+    pure ()
+  2 -> do
+    0 <- Serialize.getWord16host
+    pure ()
+  _ {- must be 3 -} -> do
+    0 <- Serialize.getWord8
+    pure ()
+
+bsLength :: BS.ByteString -> XDR.Length
+bsLength = fromIntegral . BS.length
+
+xdrPutByteString :: XDR.Length -> BS.ByteString -> Put
+xdrPutByteString l b = do
+  unless (bsLength b == l) $ error "xdrPutByteString: incorrect length"
+  Serialize.putByteString b
+  xdrPutPad l
+
+xdrGetByteString :: XDR.Length -> Get BS.ByteString
+xdrGetByteString l = do
+  b <- Serialize.getByteString $ fromIntegral l
+  xdrGetPad l
+  pure b
+
+fixedLength :: forall n a. (KnownNat n) => LengthArray 'EQ n a -> String -> String
+fixedLength a = (++ ('[' : show (fixedLengthArrayLength a) ++ "]"))
+
+variableLength :: forall n a. (KnownNat n) => LengthArray 'LT n a -> String -> String
+variableLength a
+  | n == XDR.maxLength = (++ "<>")
+  | otherwise = (++ ('<' : show n ++ ">"))
+ where
+  n = fromIntegral $ boundedLengthArrayBound a
+
+xdrGetBoundedArray :: forall n a. (KnownNat n) => (XDR.Length -> Get a) -> Get (LengthArray 'LT n a)
+xdrGetBoundedArray g = do
+  l <- xdrGet
+  guard $ l <= fromIntegral (boundedLengthArrayBound (undefined :: LengthArray 'LT n a))
+  unsafeLengthArray <$> g l
+
+instance (KnownNat n, XDR a) => XDR (LengthArray 'EQ n [a]) where
+  xdrType la =
+    fixedLength la $ xdrType $ fromJust $ listToMaybe $ unLengthArray la
+  xdrPut la = mapM_ xdrPut a where a = unLengthArray la
+  xdrGet =
+    unsafeLengthArray <$> replicateM (fromInteger $ natVal $ Proxy @n) xdrGet
+
+instance (KnownNat n, XDR a) => XDR (LengthArray 'LT n [a]) where
+  xdrType la =
+    variableLength la $ xdrType $ fromJust $ listToMaybe $ unLengthArray la
+  xdrPut la = do
+    xdrPut (fromIntegral (length a) :: XDR.Length)
+    mapM_ xdrPut a
+   where
+    a = unLengthArray la
+  xdrGet = xdrGetBoundedArray $ \l -> replicateM (fromIntegral l) xdrGet
+
+instance (KnownNat n, XDR a) => XDR (LengthArray 'EQ n (Vector a)) where
+  xdrType la = fixedLength la $ xdrType $ Vector.head $ unLengthArray la
+  xdrPut la = mapM_ xdrPut a where a = unLengthArray la
+  xdrGet =
+    unsafeLengthArray
+      <$> Vector.replicateM (fromInteger $ natVal $ Proxy @n) xdrGet
+
+instance (KnownNat n, XDR a) => XDR (LengthArray 'LT n (Vector a)) where
+  xdrType la = variableLength la $ xdrType $ Vector.head $ unLengthArray la
+  xdrPut la = do
+    xdrPut (fromIntegral (length a) :: XDR.Length)
+    mapM_ xdrPut a
+   where
+    a = unLengthArray la
+  xdrGet = xdrGetBoundedArray $ \l -> Vector.replicateM (fromIntegral l) xdrGet
+
+instance (KnownNat n) => XDR (LengthArray 'EQ n BS.ByteString) where
+  xdrType o = fixedLength o "opaque"
+  xdrPut o =
+    xdrPutByteString (fromInteger $ natVal $ Proxy @n) $ unLengthArray o
+  xdrGet =
+    unsafeLengthArray <$> xdrGetByteString (fromInteger $ natVal $ Proxy @n)
+
+instance (KnownNat n) => XDR (LengthArray 'LT n BS.ByteString) where
+  xdrType o = variableLength o "opaque"
+  xdrPut o = do
+    xdrPut l
+    xdrPutByteString l b
+   where
+    l = bsLength b
+    b = unLengthArray o
+  xdrGet = xdrGetBoundedArray xdrGetByteString
+
+instance XDR () where
+  xdrType () = "void"
+  xdrPut () = pure ()
+  xdrGet = pure ()
+
+instance (XDR a, XDR b) => XDR (a, b) where
+  xdrType (a, b) = xdrType a ++ '+' : xdrType b
+  xdrPut (a, b) = xdrPut a >> xdrPut b
+  xdrGet = (,) <$> xdrGet <*> xdrGet
+
+instance (XDR a, XDR b, XDR c) => XDR (a, b, c) where
+  xdrType (a, b, c) = xdrType a ++ '+' : xdrType b ++ '+' : xdrType c
+  xdrPut (a, b, c) = xdrPut a >> xdrPut b >> xdrPut c
+  xdrGet = (,,) <$> xdrGet <*> xdrGet <*> xdrGet
+
+instance (XDR a, XDR b, XDR c, XDR d) => XDR (a, b, c, d) where
+  xdrType (a, b, c, d) = xdrType a ++ '+' : xdrType b ++ '+' : xdrType c ++ '+' : xdrType d
+  xdrPut (a, b, c, d) = xdrPut a >> xdrPut b >> xdrPut c >> xdrPut d
+  xdrGet = (,,,) <$> xdrGet <*> xdrGet <*> xdrGet <*> xdrGet
+
+xdrSerialize :: (XDR a) => a -> BS.ByteString
+xdrSerialize = Serialize.runPut . xdrPut
+
+xdrSerializeLazy :: (XDR a) => a -> BSL.ByteString
+xdrSerializeLazy = Serialize.runPutLazy . xdrPut
+
+-- | @"S.runGet' 'xdrGet'@
+xdrDeserialize :: (XDR a) => BS.ByteString -> Either String a
+xdrDeserialize = Serialize.runGet xdrGet
+
+-- | @"S.runGetLazy' 'xdrGet'@
+xdrDeserializeLazy :: (XDR a) => BSL.ByteString -> Either String a
+xdrDeserializeLazy = Serialize.runGetLazy xdrGet

bundled/Network/ONCRPC/XDR/Specification.hs

@@ -0,0 +1,111 @@
+-- |XDR specification, as per RFC4506 and RPC extensions from RFC5531
+
+module Network.ONCRPC.XDR.Specification
+  where
+
+import qualified Network.ONCRPC.XDR.Types as XDR
+import           Data.Word (Word32)
+
+type ProgNum = Word32
+type VersNum = Word32
+type ProcNum = Word32
+
+data ArrayLength
+  = FixedLength    { arrayLength :: !XDR.Length }
+  | VariableLength { arrayLength :: !XDR.Length -- ^defaulted to maxLength
+    }
+
+data TypeDescriptor
+  = TypeSingle
+    { descriptorType :: !TypeSpecifier
+    }
+  | TypeArray 
+    { descriptorType :: !TypeSpecifier
+    , descriptorLength :: !ArrayLength
+    }
+  | TypeOpaque
+    { descriptorLength :: !ArrayLength
+    }
+  | TypeString
+    { descriptorLength :: !ArrayLength -- ^only 'VariableArray'
+    }
+  | TypeOptional
+    { descriptorType :: !TypeSpecifier
+    }
+
+data TypeSpecifier
+  = TypeInt
+  | TypeUnsignedInt
+  | TypeHyper
+  | TypeUnsignedHyper
+  | TypeFloat
+  | TypeDouble
+  | TypeQuadruple
+  | TypeBool
+  | TypeEnum !EnumBody
+  | TypeStruct !StructBody
+  | TypeUnion !UnionBody
+  | TypeIdentifier !String
+
+-- |Non-void declaration
+data Declaration = Declaration
+  { declarationIdentifier :: !String
+  , declarationType :: TypeDescriptor
+  }
+
+-- |'Declaration' or void
+type OptionalDeclaration = Maybe Declaration
+
+type EnumValues = [(String, XDR.Int)]
+
+newtype EnumBody = EnumBody
+  { enumValues :: EnumValues
+  }
+
+boolValues :: EnumValues
+boolValues = [("FALSE", 0), ("TRUE", 1)]
+
+newtype StructBody = StructBody
+  { structMembers :: [Declaration] -- ^with voids elided
+  }
+
+data UnionArm = UnionArm
+  { unionCaseIdentifier :: String -- ^The literal string found after "case", for labeling
+  , unionDeclaration :: OptionalDeclaration
+  }
+
+data UnionBody = UnionBody
+  { unionDiscriminant :: !Declaration
+  , unionCases :: [(XDR.Int, UnionArm)]
+  , unionDefault :: Maybe UnionArm
+  }
+
+data Procedure = Procedure
+  { procedureRes :: Maybe TypeSpecifier
+  , procedureIdentifier :: !String
+  , procedureArgs :: [TypeSpecifier]
+  , procedureNumber :: !ProcNum
+  }
+
+data Version = Version
+  { versionIdentifier :: !String
+  , versionTypeIdentifier :: !String
+  , versionProcedures :: [Procedure]
+  , versionNumber :: !VersNum
+  }
+
+data DefinitionBody
+  = TypeDef TypeDescriptor
+  | Constant Integer
+  | Program
+    { programTypeIdentifier :: !String
+    , programVersions :: [Version]
+    , programNumber :: !ProgNum
+    }
+
+data Definition = Definition
+  { definitionIdentifier :: !String
+  , definitionBody :: !DefinitionBody
+  }
+
+type Specification = [Definition]

bundled/Network/ONCRPC/XDR/Types.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+
+-- | XDR Types.
+-- The 'Quadruple' type is not supported as there is no reasonable Haskell equivalent.
+--
+-- This module should be imported qualified, e.g., as @XDR@.
+module Network.ONCRPC.XDR.Types
+  ( Int
+  , UnsignedInt
+  , Hyper
+  , UnsignedHyper
+  , Float
+  , Double
+  , Bool
+  , FixedArray
+  , Array
+  , FixedOpaque
+  , Opaque
+  , FixedString
+  , String
+  , Optional
+
+  , Length
+  , maxLength
+  )
+  where
+
+import Prelude hiding (Int, String)
+
+import           Data.ByteString (ByteString)
+import           Data.Int (Int32, Int64)
+import           Data.Vector (Vector)
+import           Data.Word (Word32, Word64)
+
+import           Network.ONCRPC.XDR.Array
+
+type Int            = Int32
+type UnsignedInt    = Word32
+type Hyper          = Int64
+type UnsignedHyper  = Word64
+type FixedArray n a =   FixedLengthArray n (Vector a)
+type      Array n a = BoundedLengthArray n (Vector a)
+type FixedOpaque n  =   FixedLengthArray n ByteString
+type      Opaque n  = BoundedLengthArray n ByteString
+type FixedString n  =   FixedLengthArray n ByteString
+type      String n  = BoundedLengthArray n ByteString
+type Optional a     = Maybe a
+
+-- |Not a real XDR type, but used for length headers
+type Length = UnsignedInt
+
+maxLength :: Length
+maxLength = maxBound

bundled/Network/Stellar/Asset.hs

@@ -0,0 +1,43 @@
+module Network.Stellar.Asset
+  ( Asset(..)
+  , toXdrAsset
+  , toXdrAsset'
+  )
+where
+
+import           Control.Monad ((<=<))
+import qualified Data.Text as T
+import           Data.Text.Encoding (encodeUtf8)
+import           Network.ONCRPC.XDR
+import           Network.Stellar.Keypair
+import qualified Network.Stellar.TransactionXdr as X
+
+data Asset = AssetNative
+           | AssetAlphaNum4 { assetCode :: T.Text, assetIssuer :: T.Text }
+           | AssetAlphaNum12 { assetCode :: T.Text, assetIssuer :: T.Text }
+
+toXdrAsset :: Asset -> Maybe X.Asset
+toXdrAsset AssetNative = Just X.Asset'ASSET_TYPE_NATIVE
+toXdrAsset (AssetAlphaNum4 code issuer) =
+  X.Asset'ASSET_TYPE_CREDIT_ALPHANUM4
+  <$> (X.AlphaNum4 <$> lengthArray (encodeUtf8 code) <*> toXdrAccount issuer)
+toXdrAsset (AssetAlphaNum12 code issuer) =
+  X.Asset'ASSET_TYPE_CREDIT_ALPHANUM12
+  <$> (X.AlphaNum12 <$> lengthArray (encodeUtf8 code) <*> toXdrAccount issuer)
+
+toXdrAsset' :: Asset -> X.Asset
+toXdrAsset' AssetNative = X.Asset'ASSET_TYPE_NATIVE
+toXdrAsset' (AssetAlphaNum4 code issuer) =
+  X.Asset'ASSET_TYPE_CREDIT_ALPHANUM4 $
+  X.AlphaNum4 (lengthArray' $ encodeUtf8 code) (toXdrAccount' issuer)
+toXdrAsset' (AssetAlphaNum12 code issuer) =
+  X.Asset'ASSET_TYPE_CREDIT_ALPHANUM12 $
+  X.AlphaNum12 (lengthArray' $ encodeUtf8 code) (toXdrAccount' issuer)
+
+toXdrAccount :: T.Text -> Maybe X.AccountID
+toXdrAccount =
+  fmap X.PublicKey'PUBLIC_KEY_TYPE_ED25519 . lengthArray <=< decodePublic
+
+toXdrAccount' :: T.Text -> X.AccountID
+toXdrAccount' =
+  X.PublicKey'PUBLIC_KEY_TYPE_ED25519 . lengthArray' . decodePublic'

bundled/Network/Stellar/Builder.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE DataKinds #-}
+
+module Network.Stellar.Builder
+    ( TransactionBuilder(..)
+    , transactionBuilder
+    , addOperation
+    , setTimeBounds
+    , buildWithFee
+    , build
+    , toEnvelope
+    , viewAccount
+    )
+where
+
+import qualified Crypto.Sign.Ed25519 as C
+import           Data.Maybe (fromMaybe)
+import           Data.Word (Word64)
+
+import           Network.ONCRPC.XDR.Array (boundLengthArrayFromList,
+                                           emptyBoundedLengthArray,
+                                           lengthArray', unLengthArray)
+import           Network.Stellar.TransactionXdr
+
+baseFee :: Uint32
+baseFee = 100
+
+data TransactionBuilder = TransactionBuilder
+                    { tbSourceAccount  :: C.PublicKey
+                    , tbSequenceNumber :: SequenceNumber
+                    , tbTimeBounds     :: Maybe TimeBounds
+                    , tbMemo           :: Maybe Memo
+                    , tbOperations     :: [Operation]
+                    }
+
+viewAccount :: AccountID -> C.PublicKey
+viewAccount (PublicKey'PUBLIC_KEY_TYPE_ED25519 key) =
+    C.PublicKey $ unLengthArray key
+
+transactionBuilder :: C.PublicKey -> SequenceNumber -> TransactionBuilder
+transactionBuilder acc seqNum = TransactionBuilder acc seqNum Nothing Nothing []
+
+addOperation :: TransactionBuilder -> Operation -> TransactionBuilder
+addOperation tb op = tb{ tbOperations = tbOperations tb ++ [op] }
+
+setTimeBounds :: TransactionBuilder -> Word64 -> Word64 -> TransactionBuilder
+setTimeBounds tb mintime maxtime = tb{ tbTimeBounds = Just $ TimeBounds mintime maxtime }
+
+buildWithFee :: Uint32 -> TransactionBuilder -> TransactionV0
+buildWithFee fee (TransactionBuilder acc seqNum bounds memo ops) =
+    TransactionV0
+        (buildAccount acc)
+        (fee * fromIntegral (length ops))
+        seqNum
+        bounds
+        mm
+        (boundLengthArrayFromList ops)
+        0
+  where
+    mm = fromMaybe Memo'MEMO_NONE memo
+    buildAccount (C.PublicKey key) = lengthArray' key
+
+build :: TransactionBuilder -> TransactionV0
+build = buildWithFee baseFee
+
+toEnvelope :: TransactionV0 -> TransactionEnvelope
+toEnvelope tx =
+    TransactionEnvelope'ENVELOPE_TYPE_TX_V0 $
+    TransactionV0Envelope tx emptyBoundedLengthArray

bundled/Network/Stellar/Horizon.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+
+module Network.Stellar.Horizon
+    ( HorizonServer
+    , publicHorizon
+    , testHorizon
+    , httpServer
+    , httpsServer
+    )
+where
+
+import Data.Text
+import Network.HTTP.Req (Url, Scheme(..), http, https)
+
+type HorizonServer (scheme :: Scheme) = Url scheme
+
+publicHorizon :: HorizonServer 'Https
+publicHorizon = httpsServer "horizon.stellar.org"
+
+testHorizon :: HorizonServer 'Https
+testHorizon = httpsServer "horizon-testnet.stellar.org"
+
+httpServer :: Text -> HorizonServer 'Http
+httpServer = http
+
+httpsServer :: Text -> HorizonServer 'Https
+httpsServer = https

bundled/Network/Stellar/Keypair.hs

@@ -0,0 +1,125 @@
+module Network.Stellar.Keypair
+    ( KeyPair(..)
+    , PublicKey(..)
+    , EncodingVersion(..)
+    , fromPrivateKey
+    , fromPrivateKey'
+    , signatureHint
+    , encodePublic
+    , encodePublicKey
+    , decodePublic
+    , decodePublicKey
+    , decodePublic'
+    , decodePublicKey'
+    , encodePrivate
+    , decodePrivate
+    , decodePrivate'
+    , encodeKey
+    )where
+
+import           Control.Monad (guard)
+import           Crypto.Random (getSystemDRG, randomBytesGenerate)
+import           Crypto.Sign.Ed25519
+import           Data.Bits
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import           Data.ByteString.Base32 (decodeBase32, encodeBase32)
+import           Data.Maybe (fromJust, fromMaybe)
+import           Data.Text (Text)
+import qualified Data.Text as Text
+import           Data.Text.Encoding (encodeUtf8)
+import           Data.Word (Word16, Word8)
+import           GHC.Stack (HasCallStack)
+
+data KeyPair = KeyPair
+    { kpPublicKey   :: PublicKey
+    , kpPrivateKey  :: SecretKey
+    , kpSeed        :: ByteString
+    }
+
+instance Show KeyPair where
+    show (KeyPair public _ seed) =
+        "KeyPair {" ++ Text.unpack (encodePublic $ unPublicKey public) ++ ", "
+        ++ Text.unpack (encodePrivate seed) ++ "}"
+
+fromSeed :: ByteString -> KeyPair
+fromSeed seed = KeyPair public private seed
+    where (public, private) = fromJust $ createKeypairFromSeed_ seed
+
+fromPrivateKey :: Text -> Maybe KeyPair
+fromPrivateKey = fmap fromSeed . decodePrivate
+
+fromPrivateKey' :: HasCallStack => Text -> KeyPair
+fromPrivateKey' = fromSeed . decodePrivate'
+
+signatureHint :: KeyPair -> ByteString
+signatureHint = BS.drop 28 . unPublicKey . kpPublicKey
+
+
+encodePublic :: ByteString -> Text
+encodePublic = encodeKey EncodingAccount
+
+encodePublicKey :: PublicKey -> Text
+encodePublicKey = encodePublic . unPublicKey
+
+encodePrivate :: ByteString -> Text
+encodePrivate = encodeKey EncodingSeed
+
+decodePublic :: Text -> Maybe ByteString
+decodePublic = decodeKey EncodingAccount
+
+decodePublicKey :: Text -> Maybe PublicKey
+decodePublicKey = fmap PublicKey . decodeKey EncodingAccount
+
+decodePublic' :: Text -> ByteString
+decodePublic' = decodeKey' EncodingAccount
+
+decodePublicKey' :: Text -> PublicKey
+decodePublicKey' = PublicKey . decodePublic'
+
+decodePrivate :: Text -> Maybe ByteString
+decodePrivate = decodeKey EncodingSeed
+
+decodePrivate' :: HasCallStack => Text -> ByteString
+decodePrivate' = decodeKey' EncodingSeed
+
+decodeKey :: EncodingVersion -> Text -> Maybe ByteString
+decodeKey version key = do
+    keyBlob <- either (const Nothing) Just $ decodeBase32 $ encodeUtf8 key
+    let (payload, checksum) = BS.splitAt (BS.length keyBlob - 2) keyBlob
+    (versionByte, keyData) <- BS.uncons payload
+    let versionCheck = versionByte == versionByteName version
+        checksumCheck = crc16XmodemLE payload == checksum
+    guard (versionCheck && checksumCheck)
+    pure keyData
+
+decodeKey' :: HasCallStack => EncodingVersion -> Text -> ByteString
+decodeKey' version key =
+    fromMaybe (error $ "Decoding key failed " ++ Text.unpack key) $
+    decodeKey version key
+
+data EncodingVersion = EncodingAccount | EncodingSeed | EncodingPreAuthTx | EncodingSha256Hash
+
+versionByteName :: EncodingVersion -> Word8
+versionByteName EncodingAccount    = 48
+versionByteName EncodingSeed       = 144
+versionByteName EncodingPreAuthTx  = 152
+versionByteName EncodingSha256Hash = 184
+
+encodeKey :: EncodingVersion -> ByteString -> Text
+encodeKey version key = encodeBase32 $ payload <> checksum
+    where
+        versionByte = versionByteName version
+        payload = versionByte `BS.cons` key
+        checksum = crc16XmodemLE payload
+
+crc16XmodemLE :: ByteString -> ByteString
+crc16XmodemLE bs = BS.pack [fromIntegral $ checksum .&. 0xFF, fromIntegral $ checksum `shiftR` 8]
+    where checksum = BS.foldl crcRound 0 bs
+
+crcRound :: Word16 -> Word8 -> Word16
+crcRound crc byte = crc2
+    where
+        code = (crc `shiftR` 8) `xor` fromIntegral byte
+        code2 = code `xor` (code `shiftR` 4)
+        crc2 = (crc `shiftL` 8) `xor` code2 `xor` (code2 `shiftL` 5) `xor` (code2 `shiftL` 12)

bundled/Network/Stellar/Network.hs

@@ -0,0 +1,25 @@
+module Network.Stellar.Network
+  ( Network
+  , publicNetwork
+  , testNetwork
+  )
+where
+
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as LB
+import Data.Digest.Pure.SHA (sha256, bytestringDigest)
+
+type Network = B.ByteString
+
+hashPassphrase :: String -> Network
+hashPassphrase = LB.toStrict . bytestringDigest . sha256 . LB.fromStrict . B.pack
+
+publicPassphrase :: String
+publicPassphrase = "Public Global Stellar Network ; September 2015"
+publicNetwork :: Network
+publicNetwork = hashPassphrase publicPassphrase
+
+testPassphrase :: String
+testPassphrase = "Test SDF Network ; September 2015"
+testNetwork :: Network
+testNetwork = hashPassphrase testPassphrase

bundled/Network/Stellar/Operation.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE DataKinds #-}
+
+module Network.Stellar.Operation
+    ( makeCreateAccountOperation
+    , makePaymentOperation
+    , makeNativePaymentOperation
+    , makeChangeTrustOperation
+    , makeAllowTrustOperation
+    , makeAccountMergeOperation
+    , makeInflationOperation
+    , makeManageDataOperation
+    )
+where
+
+-- import qualified Crypto.Sign.Ed25519 as C
+-- import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
+-- import qualified Data.Word (Word8)
+import           Network.Stellar.TransactionXdr
+import qualified Network.ONCRPC.XDR as XDR
+
+makeOperationGeneric2
+    :: (a -> OperationBody) -> (c -> b -> a) -> c -> b -> Operation
+makeOperationGeneric2 opBodyCons opCons a1 =
+    Operation Nothing . opBodyCons . opCons a1
+
+makeOperationGeneric3
+    :: (a -> OperationBody) -> (d -> c -> b -> a) -> d -> c -> b -> Operation
+makeOperationGeneric3 opBodyCons opCons a1 a2 =
+    Operation Nothing . opBodyCons . opCons a1 a2
+
+makeAssetIdentifier
+    :: (XDR.FixedOpaque 4 -> a) -> (XDR.FixedOpaque 12 -> a) -> String -> a
+makeAssetIdentifier shortCons longCons assetname
+    | length assetname <= 4 =
+        shortCons $ XDR.padLengthArray (BC.pack assetname) 0
+    | length assetname <= 12 =
+        longCons $ XDR.padLengthArray (BC.pack assetname) 0
+    | otherwise =
+        error $ "Name of asset " ++ assetname ++ " is too long."
+
+
+makeCreateAccountOperation :: AccountID -> Int64 -> Operation
+makeCreateAccountOperation destination amount = Operation Nothing $ OperationBody'CREATE_ACCOUNT $ CreateAccountOp destination amount
+
+makePaymentOperation :: MuxedAccount -> Asset -> Int64 -> Operation
+makePaymentOperation = makeOperationGeneric3 OperationBody'PAYMENT PaymentOp
+
+makeNativePaymentOperation :: MuxedAccount -> Int64 -> Operation
+makeNativePaymentOperation destination =
+    makePaymentOperation destination Asset'ASSET_TYPE_NATIVE
+
+makeChangeTrustOperation :: Asset -> Int64 -> Operation
+makeChangeTrustOperation = makeOperationGeneric2 OperationBody'CHANGE_TRUST ChangeTrustOp
+
+makeAllowTrustOperation :: AccountID -> String -> Bool -> Operation
+makeAllowTrustOperation trustor asset =
+    makeOperationGeneric3 OperationBody'ALLOW_TRUST AllowTrustOp trustor
+        (makeAssetIdentifier
+            AllowTrustOpAsset'ASSET_TYPE_CREDIT_ALPHANUM4
+            AllowTrustOpAsset'ASSET_TYPE_CREDIT_ALPHANUM12
+            asset)
+
+makeAccountMergeOperation :: MuxedAccount -> Operation
+makeAccountMergeOperation = Operation Nothing . OperationBody'ACCOUNT_MERGE
+
+makeInflationOperation :: Operation
+makeInflationOperation = Operation Nothing OperationBody'INFLATION
+
+makeManageDataOperation :: String -> Maybe String -> Operation
+makeManageDataOperation name value =
+    makeOperationGeneric2 OperationBody'MANAGE_DATA ManageDataOp (XDR.boundLengthArray $ BC.pack name) ((XDR.boundLengthArray.BC.pack) `fmap` value)

bundled/Network/Stellar/Query.hs

@@ -0,0 +1,213 @@
+{-# OPTIONS -Wno-orphans #-} -- MonandHttp IO
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+
+module Network.Stellar.Query where
+
+import Prelude hiding (lookup)
+
+import           Control.Exception (throwIO)
+import qualified Crypto.Sign.Ed25519 as C
+import           Data.Aeson (Value(Object, String), FromJSON)
+import           Data.Aeson.KeyMap (lookup)
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.Text as T
+import           Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import           Data.Word (Word64)
+import           Network.HTTP.Req
+import qualified Network.ONCRPC.XDR as XDR
+import           Network.Stellar.Asset
+import           Network.Stellar.Horizon
+import           Network.Stellar.Keypair
+import qualified Network.Stellar.TransactionXdr as TX
+
+instance MonadHttp IO where
+    handleHttpException = throwIO
+
+query :: (FromJSON a) => HorizonServer scheme -> [T.Text] -> IO a
+query server pathSegments = queryWithParams server pathSegments []
+
+queryWithParams :: (FromJSON a) => HorizonServer scheme -> [T.Text] -> [(T.Text, T.Text)] -> IO a
+queryWithParams server pathSegments params = do
+    response <- req GET (foldl (/:) server pathSegments) NoReqBody jsonResponse $ foldMap (uncurry (=:)) params
+    return $ responseBody response
+
+postWithBody :: (FromJSON a) => HorizonServer scheme -> [T.Text] -> (T.Text, T.Text) -> IO a
+postWithBody server pathSegments (q,value) = do
+    response <- req POST (foldl (/:) server pathSegments) (ReqBodyUrlEnc $ q =: value) jsonResponse mempty
+    return $ responseBody response
+
+getSequenceNumber :: HorizonServer scheme -> C.PublicKey -> IO TX.SequenceNumber
+getSequenceNumber server acc = do
+    response <- query server ["accounts", encodePublic $ C.unPublicKey acc]
+    case response of
+        Object hm ->
+            case lookup "sequence" hm of
+                Just (String s) ->
+                    pure $ fromIntegral (read $ T.unpack s :: Integer)
+                Just x -> fail $ "Value is not a number " ++ show x
+                Nothing -> fail "No sequence in account"
+        _ -> fail $ "Sequence number response is not an object " ++ show response
+
+submitTransaction :: HorizonServer scheme -> TX.TransactionEnvelope -> IO TX.TransactionResult
+submitTransaction server tx = do
+    response <-
+        postWithBody
+            server
+            ["transactions"]
+            ("tx", decodeUtf8 $ B64.encode $ XDR.xdrSerialize tx)
+    case response of
+        Object hm ->
+            case lookup "result_xdr" hm of
+                Just (String t) ->
+                    either fail pure $
+                    XDR.xdrDeserialize =<< B64.decode (encodeUtf8 t)
+                Just x -> fail $ "Value is not a string " ++ show x
+                Nothing -> fail "No result_xdr in transaction"
+        _ -> fail $ "Transaction response is not an object " ++ show response
+
+type HorizonQuery = ([T.Text], [(T.Text, T.Text)])
+runQuery :: HorizonServer scheme -> HorizonQuery -> IO Value
+runQuery server (pathSegments, params) = queryWithParams server pathSegments params
+
+
+-- data CallBuilder (baseSegment :: [T.Text] -> [T.Text]) = CallBuilder { otherPathSegments :: [T.Text] }
+-- instance Monoid (CallBuilder baseSegment) where
+--     mempty =
+-- newtype EffectsCallBuilder = CallBuilder (++["effects"]) deriving Monoid
+
+-- buildQuery :: CallBuilder baseSegment -> T.Text
+-- buildQuery ()
+
+
+-- Queries related to accounts
+
+getAccount :: C.PublicKey -> HorizonQuery
+getAccount account =
+    (["accounts", encodePublic $ C.unPublicKey account], [])
+
+getAccountData :: C.PublicKey -> T.Text -> HorizonQuery
+getAccountData account key =
+    (["accounts", encodePublic $ C.unPublicKey account, "data", key], [])
+
+getAccountX :: T.Text -> C.PublicKey -> [(T.Text, T.Text)] -> HorizonQuery
+getAccountX x account params =
+    (["accounts", encodePublic $ C.unPublicKey account, x], params)
+
+getAccountEffects :: C.PublicKey -> [(T.Text, T.Text)] -> HorizonQuery
+getAccountEffects = getAccountX "effects"
+
+getAccountOffers :: C.PublicKey -> [(T.Text, T.Text)] -> HorizonQuery
+getAccountOffers = getAccountX "offers"
+
+getAccountOperations :: C.PublicKey -> [(T.Text, T.Text)] -> HorizonQuery
+getAccountOperations = getAccountX "operations"
+
+getAccountPayments :: C.PublicKey -> [(T.Text, T.Text)] -> HorizonQuery
+getAccountPayments = getAccountX "payments"
+
+getAccountTransactions :: C.PublicKey -> [(T.Text, T.Text)] -> HorizonQuery
+getAccountTransactions = getAccountX "transactions"
+
+-- optional parameters: asset_code, asset_issuer
+getAssets :: [(T.Text, T.Text)] -> HorizonQuery
+getAssets params =
+    (["assets"], params)
+
+getEffects :: [(T.Text, T.Text)] -> HorizonQuery
+getEffects params =
+    (["effects"], params)
+
+-- Queries related to ledgers
+
+getAllLedgers :: [(T.Text, T.Text)] -> HorizonQuery
+getAllLedgers params = (["ledgers"], params)
+
+getLedger :: T.Text -> HorizonQuery
+getLedger ledgerId = (["ledgers", ledgerId], [])
+
+getLedgerX :: T.Text -> T.Text -> [(T.Text, T.Text)] -> HorizonQuery
+getLedgerX x ledger params = (["ledgers", ledger, x], params)
+
+getLedgerEffects :: T.Text -> [(T.Text, T.Text)] -> HorizonQuery
+getLedgerEffects = getLedgerX "effects"
+
+getLedgerOperations :: T.Text -> [(T.Text, T.Text)] -> HorizonQuery
+getLedgerOperations = getLedgerX "operations"
+
+getLedgerPayments :: T.Text -> [(T.Text, T.Text)] -> HorizonQuery
+getLedgerPayments = getLedgerX "payments"
+
+getLedgerTransactions :: T.Text -> [(T.Text, T.Text)] -> HorizonQuery
+getLedgerTransactions = getLedgerX "transactions"
+
+-- Queries related to operations
+
+getAllOperations :: [(T.Text, T.Text)] -> HorizonQuery
+getAllOperations params = (["operations"], params)
+
+getOperation :: T.Text -> HorizonQuery
+getOperation op = (["operations", op], [])
+
+getOperationEffects :: T.Text -> [(T.Text, T.Text)] -> HorizonQuery
+getOperationEffects op params = (["operations", op, "effects"], params)
+
+-- Queries related to transactions
+
+getAllTransactions :: [(T.Text, T.Text)] -> HorizonQuery
+getAllTransactions params = (["transactions"], params)
+
+getTransaction :: T.Text -> HorizonQuery
+getTransaction tx = (["transactions", tx], [])
+
+getTransactionX :: T.Text -> T.Text -> [(T.Text, T.Text)] -> HorizonQuery
+getTransactionX x tx params = (["transactions", tx, x], params)
+
+getTransactionEffects :: T.Text -> [(T.Text, T.Text)] -> HorizonQuery
+getTransactionEffects = getTransactionX "effects"
+
+getTransactionOperations :: T.Text -> [(T.Text, T.Text)] -> HorizonQuery
+getTransactionOperations = getTransactionX "operations"
+
+getTransactionPayments :: T.Text -> [(T.Text, T.Text)] -> HorizonQuery
+getTransactionPayments = getTransactionX "payments"
+
+
+-- Queries related to trading
+
+assetToParams :: T.Text -> Asset -> [(T.Text, T.Text)]
+assetToParams prefix AssetNative = [(prefix `T.append` "_asset_type", "native")]
+assetToParams prefix (AssetAlphaNum4 assetcode issuer) =
+  [(prefix `T.append` "_asset_type", "credit_alphanum4"), (prefix `T.append` "_asset_code", assetcode), (prefix `T.append` "_asset_issuer", issuer)]
+assetToParams prefix (AssetAlphaNum12 assetcode issuer) =
+  [(prefix `T.append` "_asset_type", "credit_alphanum12"), (prefix `T.append` "_asset_code", assetcode), (prefix `T.append` "_asset_issuer", issuer)]
+
+getOrderBook :: Asset -> Asset -> HorizonQuery
+getOrderBook selling buying =
+    ( ["order_book"]
+    , assetToParams "selling" selling ++ assetToParams "buying" buying
+    )
+
+getPaymentPaths :: C.PublicKey -> C.PublicKey -> Asset -> Word64 -> HorizonQuery
+getPaymentPaths sourceAccount destAccount asset amount =
+    ( ["paths"]
+    , ("source_account", encodePublic $ C.unPublicKey sourceAccount)
+        : ("destination_account", encodePublic $ C.unPublicKey destAccount)
+        : ("destination_amount", T.pack $ show amount)
+        : assetToParams "destination" asset
+    )
+
+getTradeAggregations :: Asset -> Asset -> Word64 -> Word64 -> Word64 -> [(T.Text, T.Text)] -> HorizonQuery
+getTradeAggregations base counter start end resolution params =
+  (["trade_aggregations"],
+    assetToParams "base" base
+    ++ assetToParams "counter" counter
+    ++ ("start_time", T.pack $ show start)
+    : ("end_time", T.pack $ show end)
+    : ("resolution", T.pack $ show resolution)
+    : params)
+
+getTrades :: Maybe Asset -> Maybe Asset -> Maybe T.Text -> [(T.Text, T.Text)] -> HorizonQuery
+getTrades base counter offerId params =
+  (["trades"], concat [maybe [] (assetToParams "base") base, maybe [] (assetToParams "counter") counter, maybe [] (\x -> [("offer_id", x)]) offerId, params])

bundled/Network/Stellar/Signature.hs

@@ -0,0 +1,134 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Network.Stellar.Signature
+    ( signBlob
+    , verifyBlob
+    , verifyBlobWithKP
+    , signTx
+    , verifyTx
+    , transactionHash
+    )
+where
+
+import qualified Crypto.Sign.Ed25519 as C
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as LB
+import           Data.Digest.Pure.SHA (bytestringDigest, sha256)
+import qualified Data.Vector as Vector
+
+import           Network.ONCRPC.XDR (xdrSerialize)
+import qualified Network.ONCRPC.XDR as XDR
+import           Network.ONCRPC.XDR.Array (boundLengthArray, lengthArray',
+                                           unLengthArray, unsafeLengthArray)
+import           Network.Stellar.Keypair
+import           Network.Stellar.Network
+import           Network.Stellar.TransactionXdr
+
+signBlob :: KeyPair -> ByteString -> ByteString
+signBlob KeyPair{kpPrivateKey} = C.unSignature . C.dsign kpPrivateKey
+
+verifyBlob
+    :: C.PublicKey
+    -> ByteString -- ^ message
+    -> ByteString -- ^ signature
+    -> Bool
+verifyBlob publicKey message = C.dverify publicKey message . C.Signature
+
+verifyBlobWithKP
+    :: KeyPair
+    -> ByteString -- ^ message
+    -> ByteString -- ^ signature
+    -> Bool
+verifyBlobWithKP KeyPair{kpPublicKey} message =
+    C.dverify kpPublicKey message . C.Signature
+
+data SignError = TooManySignatures
+    deriving Show
+
+takeEnd :: Int -> ByteString -> ByteString
+takeEnd n bs = B.drop (B.length bs - n) bs
+
+accountXdrFromEd :: C.PublicKey -> AccountID
+accountXdrFromEd (C.PublicKey key) =
+    PublicKey'PUBLIC_KEY_TYPE_ED25519 $ lengthArray' key
+
+keyToHint :: KeyPair -> SignatureHint
+keyToHint KeyPair{kpPublicKey} =
+    lengthArray' $ takeEnd 4 $ xdrSerialize $ accountXdrFromEd kpPublicKey
+
+signTx
+    :: Network
+    -> TransactionEnvelope
+    -> [KeyPair]
+    -> Either SignError TransactionEnvelope
+signTx nId envelope newKeys =
+    case envelope of
+        TransactionEnvelope'ENVELOPE_TYPE_TX_V0
+                (TransactionV0Envelope tx signatures) ->
+            TransactionEnvelope'ENVELOPE_TYPE_TX_V0 . TransactionV0Envelope tx
+            <$> appendSignatures signatures
+        TransactionEnvelope'ENVELOPE_TYPE_TX
+                (TransactionV1Envelope tx signatures) ->
+            TransactionEnvelope'ENVELOPE_TYPE_TX . TransactionV1Envelope tx
+            <$> appendSignatures signatures
+        TransactionEnvelope'ENVELOPE_TYPE_TX_FEE_BUMP
+                (FeeBumpTransactionEnvelope tx signatures) ->
+            TransactionEnvelope'ENVELOPE_TYPE_TX_FEE_BUMP
+                . FeeBumpTransactionEnvelope tx
+            <$> appendSignatures signatures
+  where
+    signature :: KeyPair -> Signature
+    signature KeyPair{kpPrivateKey} =
+        boundLengthArray $
+        C.unSignature $ C.dsign kpPrivateKey $ transactionHash nId envelope
+
+    appendSignatures
+        :: XDR.Array 20 DecoratedSignature
+        -> Either SignError (XDR.Array 20 DecoratedSignature)
+    appendSignatures oldSignatures
+        | Vector.length oldSignatures' + length newKeys <= 20 =
+            Right $
+            unsafeLengthArray $
+                oldSignatures'
+                <> Vector.fromList
+                    [ DecoratedSignature (keyToHint key) (signature key)
+                    | key <- newKeys
+                    ]
+        | otherwise = Left TooManySignatures
+      where
+        oldSignatures' = unLengthArray oldSignatures
+
+transactionHash :: Network -> TransactionEnvelope -> ByteString
+transactionHash nId = \case
+    TransactionEnvelope'ENVELOPE_TYPE_TX_V0 (TransactionV0Envelope tx _) ->
+        go  (   xdrSerialize ENVELOPE_TYPE_TX
+            <>  xdrSerialize PUBLIC_KEY_TYPE_ED25519
+            )
+            tx
+    TransactionEnvelope'ENVELOPE_TYPE_TX (TransactionV1Envelope tx _) ->
+        go (xdrSerialize ENVELOPE_TYPE_TX) tx
+    TransactionEnvelope'ENVELOPE_TYPE_TX_FEE_BUMP
+            (FeeBumpTransactionEnvelope tx _) ->
+        go (xdrSerialize ENVELOPE_TYPE_TX_FEE_BUMP) tx
+  where
+    go prefix tx =
+        LB.toStrict $
+        bytestringDigest $
+        sha256 $
+        LB.fromStrict $
+        B.concat [nId, prefix, xdrSerialize tx]
+
+verifyTx
+    :: Network
+    -> TransactionEnvelope
+    -> C.PublicKey
+    -> DecoratedSignature
+    -> Bool
+verifyTx nId envelope publicKey (DecoratedSignature _ signature) =
+    C.dverify
+        publicKey
+        (transactionHash nId envelope)
+        (C.Signature $ unLengthArray signature)