module Network.Ethereum.Web3.TH (
abi
, abiFrom
, Bytes
, Text
, Singleton(..)
, ABIEncoding(..)
) where
import qualified Data.Text.Lazy.Encoding as LT
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy as LT
import qualified Data.Attoparsec.Text as P
import qualified Data.Text as T
import Network.Ethereum.Web3.Address (Address)
import Network.Ethereum.Web3.Encoding.Tuple
import Network.Ethereum.Web3.Encoding
import Network.Ethereum.Web3.Internal
import Network.Ethereum.Web3.Contract
import Network.Ethereum.Web3.JsonAbi
import Network.Ethereum.Web3.Types
import Network.Ethereum.Unit
import Data.Text (Text, isPrefixOf)
import Data.List (groupBy, sortBy)
import Data.Monoid (mconcat, (<>))
import Data.ByteArray (Bytes)
import Data.Aeson
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Lib
import Language.Haskell.TH
abiFrom :: QuasiQuoter
abiFrom = quoteFile abi
abi :: QuasiQuoter
abi = QuasiQuoter
{ quoteDec = quoteAbiDec
, quoteExp = quoteAbiExp
, quotePat = undefined
, quoteType = undefined
}
instanceD' :: Name -> TypeQ -> [DecQ] -> DecQ
instanceD' name insType insDecs =
instanceD (cxt []) (appT insType (conT name)) insDecs
dataD' :: Name -> ConQ -> [Name] -> DecQ
dataD' name rec derive =
#if MIN_VERSION_template_haskell(2,12,0)
dataD (cxt []) name [] Nothing [rec] [derivClause Nothing (conT <$> derive)]
#else
dataD (cxt []) name [] Nothing [rec] $ cxt (conT <$> derive)
#endif
funD' :: Name -> [PatQ] -> ExpQ -> DecQ
funD' name p f = funD name [clause p (normalB f) []]
typeQ :: Text -> TypeQ
typeQ typ | T.any (== '[') typ = appT listT (go (T.takeWhile (/= '[') typ))
| otherwise = go typ
where go x | "string" == x = conT (mkName "Text")
| "address" == x = conT (mkName "Address")
| "bytes" == x = conT (mkName "BytesD")
| "bool" == x = conT (mkName "Bool")
| "bytes" `isPrefixOf` x = appT (conT (mkName "BytesN"))
(numLit (T.drop 5 x))
| "int" `isPrefixOf` x = conT (mkName "Integer")
| "uint" `isPrefixOf` x = conT (mkName "Integer")
| otherwise = fail ("Unknown type: " ++ T.unpack x)
numLit n = litT (numTyLit (read (T.unpack n)))
eventBangType :: EventArg -> BangTypeQ
eventBangType (EventArg _ typ _) =
bangType (bang sourceNoUnpack sourceStrict) (typeQ typ)
funBangType :: FunctionArg -> BangTypeQ
funBangType (FunctionArg _ typ) =
bangType (bang sourceNoUnpack sourceStrict) (typeQ typ)
isDynType :: Text -> Bool
isDynType "bytes" = True
isDynType "string" = True
isDynType x | T.any (== '[') x = True
| otherwise = False
eventEncodigD :: Name -> [EventArg] -> [DecQ]
eventEncodigD eventName args =
[ funD' (mkName "toDataBuilder") []
[|error "Event to data conversion isn't available!"|]
, funD' (mkName "fromDataParser") [] fromDataP ]
where
indexed = map eveArgIndexed args
newVars = sequence $ replicate (length args) (newName "t")
parseArg v = bindS (varP v) [|fromDataParser|]
parseData [] = []
parseData [v] = pure $ bindS (varP v) [|unSingleton <$> fromDataParser|]
parseData vars = pure $ bindS (tupP (varP <$> vars)) [|fromDataParser|]
fromDataP = do
vars <- zip indexed <$> newVars
let ixVars = [v | (isIndexed, v) <- vars, isIndexed]
noIxVars = [v | (isIndexed, v) <- vars, not isIndexed]
expVars = [varE v | (_, v) <- vars]
doE $ fmap parseArg ixVars
++ parseData noIxVars
++ [noBindS [|return $(appsE (conE eventName : expVars))|]]
funEncodigD :: Name -> Int -> String -> [DecQ]
funEncodigD funName paramLen ident =
[ funDtoDataB
, funD' (mkName "fromDataParser") []
[|error "Function from data conversion isn't available!"|] ]
where
newVars = sequence $ replicate paramLen (newName "t")
sVar = mkName "a"
funDtoDataB
| paramLen == 0 = funD' (mkName "toDataBuilder") [conP funName []] [|ident|]
| paramLen == 1 = funD' (mkName "toDataBuilder")
[conP funName [varP sVar]]
[|ident <> toDataBuilder (Singleton $(varE sVar))|]
| otherwise = do
vars <- newVars
funD' (mkName "toDataBuilder")
[conP funName $ fmap varP vars]
[|ident <> toDataBuilder $(tupE $ fmap varE vars)|]
eventFilterD :: String -> [DecQ]
eventFilterD topic0 = let addr = mkName "a" in
[ funD' (mkName "eventFilter") [wildP, varP addr]
[|Filter (Just $(varE addr))
(Just [Just topic0, Nothing])
Nothing
Nothing
|]
]
funWrapper :: Bool
-> Name
-> Name
-> [FunctionArg]
-> Maybe [FunctionArg]
-> Q [Dec]
funWrapper c name dname args result = do
a : b : vars <- sequence $ replicate (length args + 2) (newName "t")
let params = appsE $ (conE dname) : fmap varE vars
sequence $ case c of
True ->
[ sigD name $ arrowing $ [t|Address|] : inputT ++ [outputT]
, funD' name (varP <$> a : vars) $
case result of
Just [_] -> [|unSingleton <$> call $(varE a) Latest $(params)|]
_ -> [|call $(varE a) Latest $(params)|]
]
False ->
[ sigD name $ [t|Unit $(varT b) =>
$(arrowing $ [t|Address|] : varT b : inputT ++ [[t|Web3 TxHash|]])
|]
, funD' name (varP <$> a : b : vars) $
[|sendTx $(varE a) $(varE b) $(params)|] ]
where
arrowing [x] = x
arrowing (x : xs) = [t|$x -> $(arrowing xs)|]
inputT = fmap (typeQ . funArgType) args
outputT = case result of
Nothing -> [t|Web3 ()|]
Just [x] -> [t|Web3 $(typeQ $ funArgType x)|]
Just xs -> let outs = fmap (typeQ . funArgType) xs
in [t|Web3 $(foldl appT (tupleT (length xs)) outs)|]
mkEvent :: Declaration -> Q [Dec]
mkEvent eve@(DEvent name inputs _) = sequence $
[ dataD' eventName eventFields derivingD
, instanceD' eventName encodingT (eventEncodigD eventName inputs)
, instanceD' eventName eventT (eventFilterD (T.unpack $ eventId eve))
]
where eventName = mkName (toUpperFirst (T.unpack name))
derivingD = [mkName "Show", mkName "Eq", mkName "Ord"]
eventFields = normalC eventName (eventBangType <$> inputs)
encodingT = conT (mkName "ABIEncoding")
eventT = conT (mkName "Event")
mkFun :: Declaration -> Q [Dec]
mkFun fun@(DFunction name constant inputs outputs) = (++)
<$> funWrapper constant funName dataName inputs outputs
<*> sequence
[ dataD' dataName (normalC dataName bangInput) derivingD
, instanceD' dataName encodingT
(funEncodigD dataName (length inputs) mIdent)
, instanceD' dataName methodT [] ]
where mIdent = T.unpack (methodId $ fun{funName = T.replace "'" "" name})
dataName = mkName (toUpperFirst (T.unpack $ name <> "Data"))
funName = mkName (toLowerFirst (T.unpack name))
bangInput = fmap funBangType inputs
derivingD = [mkName "Show", mkName "Eq", mkName "Ord"]
encodingT = conT (mkName "ABIEncoding")
methodT = conT (mkName "Method")
escape :: [Declaration] -> [Declaration]
escape = concat . escapeNames . groupBy fnEq . sortBy fnCompare
where fnEq (DFunction n1 _ _ _) (DFunction n2 _ _ _) = n1 == n2
fnEq _ _ = False
fnCompare (DFunction n1 _ _ _) (DFunction n2 _ _ _) = compare n1 n2
fnCompare _ _ = GT
escapeNames :: [[Declaration]] -> [[Declaration]]
escapeNames = fmap go
where go (x : xs) = x : zipWith appendToName xs hats
hats = [T.replicate n "'" | n <- [1..]]
appendToName dfn addition = dfn { funName = funName dfn <> addition }
mkDecl :: Declaration -> Q [Dec]
mkDecl x@(DFunction{}) = mkFun x
mkDecl x@(DEvent{}) = mkEvent x
mkDecl _ = return []
quoteAbiDec :: String -> Q [Dec]
quoteAbiDec abi_string =
case decode abi_lbs of
Just (ContractABI abi) -> concat <$> mapM mkDecl (escape abi)
_ -> fail "Unable to parse ABI!"
where abi_lbs = LT.encodeUtf8 (LT.pack abi_string)
quoteAbiExp :: String -> ExpQ
quoteAbiExp abi_string = stringE $
case eitherDecode abi_lbs of
Left e -> "Error: " ++ show e
Right abi -> show (abi :: ContractABI)
where abi_lbs = LT.encodeUtf8 (LT.pack abi_string)