{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.Ethereum.Contract.TH
(
abi
, abiFrom
) where
import Control.Applicative ((<|>))
import Control.Monad (replicateM, (<=<))
import qualified Data.Aeson as Aeson (encode)
import Data.ByteArray (convert)
import qualified Data.Char as Char
import Data.Default (Default (..))
import Data.List (group, sort, uncons)
import Data.Monoid ((<>))
import Data.Tagged (Tagged)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import Data.Tuple.OneTuple (only)
import Generics.SOP (Generic)
import qualified GHC.Generics as GHC (Generic)
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Lens.Micro ((^?))
import Lens.Micro.Aeson (key, _JSON, _String)
import Data.Solidity.Abi (AbiGet, AbiPut, AbiType (..))
import Data.Solidity.Event (IndexedEvent (..))
import Data.Solidity.Prim (Address, Bytes, BytesN, IntN,
ListN, UIntN)
import Data.String.Extra (toLowerFirst, toUpperFirst)
import Language.Solidity.Abi (ContractAbi (..),
Declaration (..),
EventArg (..),
FunctionArg (..),
SolidityType (..), eventId,
methodId, parseSolidityFunctionArgType, parseSolidityEventArgType)
import Network.Ethereum.Account.Class (Account (..))
import Network.Ethereum.Api.Types (DefaultBlock (..),
Filter (..), TxReceipt)
import qualified Network.Ethereum.Contract as Contract (Contract (..))
import Network.Ethereum.Contract.Method (Method (..))
import Network.JsonRpc.TinyClient (JsonRpc)
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 =
instanceD (cxt []) (appT insType (conT name))
dataD' :: Name -> ConQ -> [Name] -> DecQ
dataD' name rec' derive =
dataD (cxt []) name [] Nothing [rec'] [derivClause Nothing (conT <$> derive)]
funD' :: Name -> [PatQ] -> ExpQ -> DecQ
funD' name p f = funD name [clause p (normalB f) []]
toHSType :: SolidityType -> TypeQ
toHSType s = case s of
SolidityBool -> conT ''Bool
SolidityAddress -> conT ''Address
SolidityUint n -> appT (conT ''UIntN) (numLit n)
SolidityInt n -> appT (conT ''IntN) (numLit n)
SolidityString -> conT ''Text
SolidityBytesN n -> appT (conT ''BytesN) (numLit n)
SolidityBytes -> conT ''Bytes
SolidityTuple n as -> foldl ( \b a -> appT b $ toHSType a ) ( tupleT n ) as
SolidityVector ns a -> expandVector ns a
SolidityArray a -> appT listT $ toHSType a
where
numLit n = litT (numTyLit $ toInteger n)
expandVector :: [Int] -> SolidityType -> TypeQ
expandVector ns a = case uncons ns of
Just (n, rest) ->
if null rest
then conT ''ListN `appT` numLit n `appT` toHSType a
else conT ''ListN `appT` numLit n `appT` expandVector rest a
_ -> error $ "Impossible Nothing branch in `expandVector`: " ++ show ns ++ " " ++ show a
typeFuncQ :: FunctionArg -> TypeQ
typeFuncQ t = case parseSolidityFunctionArgType t of
Left e -> error $ "Unable to parse solidity type: " ++ show e
Right ty -> toHSType ty
typeEventQ :: EventArg -> TypeQ
typeEventQ t = case parseSolidityEventArgType t of
Left e -> error $ "Unable to parse solidity type: " ++ show e
Right ty -> toHSType ty
funBangType :: FunctionArg -> BangTypeQ
funBangType fa =
bangType (bang sourceNoUnpack sourceStrict) (typeFuncQ fa)
funWrapper :: Bool
-> Name
-> Name
-> [FunctionArg]
-> Maybe [FunctionArg]
-> DecsQ
funWrapper c name dname args result = do
vars <- replicateM (length args) (newName "t")
a <- varT <$> newName "a"
t <- varT <$> newName "t"
m <- varT <$> newName "m"
let params = appsE $ conE dname : fmap varE vars
inputT = fmap typeFuncQ args
outputT = case result of
Nothing -> [t|$t $m ()|]
Just [x] -> [t|$t $m $(typeFuncQ x)|]
Just xs -> let outs = fmap typeFuncQ xs
in [t|$t $m $(foldl appT (tupleT (length xs)) outs)|]
sequence [
sigD name $ [t|
(JsonRpc $m, Account $a $t, Functor ($t $m)) =>
$(arrowing $ inputT ++ [if c then outputT else [t|$t $m TxReceipt|]])
|]
, if c
then funD' name (varP <$> vars) $ case result of
Just [_] -> [|only <$> call $(params)|]
_ -> [|call $(params)|]
else funD' name (varP <$> vars) $ [|send $(params)|]
]
where
arrowing [] = error "Impossible branch call"
arrowing [x] = x
arrowing (x : xs) = [t|$x -> $(arrowing xs)|]
mkDecl :: Declaration -> DecsQ
mkDecl ev@(DEvent uncheckedName inputs anonymous) = sequence
[ dataD' indexedName (normalC indexedName (map (toBang <=< tag) indexedArgs)) derivingD
, instanceD' indexedName (conT ''Generic) []
, instanceD' indexedName (conT ''AbiType) [funD' 'isDynamic [] [|const False|]]
, instanceD' indexedName (conT ''AbiGet) []
, dataD' nonIndexedName (normalC nonIndexedName (map (toBang <=< tag) nonIndexedArgs)) derivingD
, instanceD' nonIndexedName (conT ''Generic) []
, instanceD' nonIndexedName (conT ''AbiType) [funD' 'isDynamic [] [|const False|]]
, instanceD' nonIndexedName (conT ''AbiGet) []
, dataD' allName (recC allName (map (\(n, a) -> (\(b,t) -> return (n,b,t)) <=< toBang <=< typeEventQ $ a) allArgs)) derivingD
, instanceD' allName (conT ''Generic) []
, instanceD (cxt [])
(pure $ ConT ''IndexedEvent `AppT` ConT indexedName `AppT` ConT nonIndexedName `AppT` ConT allName)
[funD' 'isAnonymous [] [|const anonymous|]]
, instanceD (cxt [])
(pure $ ConT ''Default `AppT` (ConT ''Filter `AppT` ConT allName))
[funD' 'def [] [|Filter Nothing Latest Latest $ Just topics|] ]
]
where
name = if Char.toLower (T.head uncheckedName) == Char.toUpper (T.head uncheckedName) then "EvT" <> uncheckedName else uncheckedName
topics = [Just (T.unpack $ eventId ev)] <> replicate (length indexedArgs) Nothing
toBang ty = bangType (bang sourceNoUnpack sourceStrict) (return ty)
tag (n, ty) = AppT (AppT (ConT ''Tagged) (LitT $ NumTyLit n)) <$> typeEventQ ty
labeledArgs = zip [1..] inputs
indexedArgs = map (\(n, ea) -> (n, ea)) . filter (eveArgIndexed . snd) $ labeledArgs
indexedName = mkName $ toUpperFirst (T.unpack name) <> "Indexed"
nonIndexedArgs = map (\(n, ea) -> (n, ea)) . filter (not . eveArgIndexed . snd) $ labeledArgs
nonIndexedName = mkName $ toUpperFirst (T.unpack name) <> "NonIndexed"
allArgs :: [(Name, EventArg)]
allArgs = makeArgs name $ map (\i -> (eveArgName i, i)) inputs
allName = mkName $ toUpperFirst (T.unpack name)
derivingD = [''Show, ''Eq, ''Ord, ''GHC.Generic]
mkDecl fun@(DFunction name constant inputs outputs) = (++)
<$> funWrapper constant fnName dataName inputs outputs
<*> sequence
[ dataD' dataName (normalC dataName bangInput) derivingD
, instanceD' dataName (conT ''Generic) []
, instanceD' dataName (conT ''AbiType)
[funD' 'isDynamic [] [|const False|]]
, instanceD' dataName (conT ''AbiPut) []
, instanceD' dataName (conT ''AbiGet) []
, instanceD' dataName (conT ''Method)
[funD' 'selector [] [|const mIdent|]]
]
where mIdent = T.unpack (methodId $ fun {funName = T.replace "'" "" name})
dataName = mkName (toUpperFirst (T.unpack $ T.dropWhile (== '_') name <> "Data"))
fnName = mkName (toLowerFirst (T.unpack name))
bangInput = fmap funBangType inputs
derivingD = [''Show, ''Eq, ''Ord, ''GHC.Generic]
mkDecl _ = return []
mkContractDecl :: Text -> Text -> Text -> Declaration -> DecsQ
mkContractDecl name a b (DConstructor inputs) = sequence
[ dataD' dataName (normalC dataName bangInput) derivingD
, instanceD' dataName (conT ''Generic) []
, instanceD' dataName (conT ''AbiType)
[funD' 'isDynamic [] [|const False|]]
, instanceD' dataName (conT ''AbiPut) []
, instanceD' dataName (conT ''Method)
[funD' 'selector [] [|convert . Contract.bytecode|]]
, instanceD' dataName (conT ''Contract.Contract)
[ funD' 'Contract.abi [] [|const abiString|]
, funD' 'Contract.bytecode [] [|const bytecodeString|]
]
]
where abiString = T.unpack a
bytecodeString = T.unpack b
dataName = mkName (toUpperFirst (T.unpack $ name <> "Contract"))
bangInput = fmap funBangType inputs
derivingD = [''Show, ''Eq, ''Ord, ''GHC.Generic]
mkContractDecl _ _ _ _ = return []
makeArgs :: Text -> [(Text, EventArg)] -> [(Name, EventArg)]
makeArgs prefix ns = go 1 ns
where
prefixStr = toLowerFirst . T.unpack $ prefix
go :: Int -> [(Text, EventArg)] -> [(Name, EventArg)]
go _ [] = []
go i ((h, ty) : tail')
| T.null h = (mkName $ prefixStr ++ show i, ty) : go (i + 1) tail'
| otherwise = (mkName . (++ "_") . (++) prefixStr . toUpperFirst . T.unpack $ h, ty) : go (i + 1) tail'
escape :: [Declaration] -> [Declaration]
escape = escapeEqualNames . fmap escapeReservedNames
escapeEqualNames :: [Declaration] -> [Declaration]
escapeEqualNames = concatMap go . group . sort
where go [] = []
go (x : xs) = x : zipWith appendToName xs hats
hats = [T.replicate n "'" | n <- [1..]]
appendToName d@(DFunction n _ _ _) a = d { funName = n <> a }
appendToName d@(DEvent n _ _) a = d { eveName = n <> a }
appendToName d _ = d
escapeReservedNames :: Declaration -> Declaration
escapeReservedNames d@(DFunction n _ _ _)
| isKeyword n = d { funName = n <> "'" }
| otherwise = d
escapeReservedNames d = d
isKeyword :: Text -> Bool
isKeyword = flip elem [ "as", "case", "of", "class"
, "data", "family", "instance"
, "default", "deriving", "do"
, "forall", "foreign", "hiding"
, "if", "then", "else", "import"
, "infix", "infixl", "infixr"
, "let", "in", "mdo", "module"
, "newtype", "proc", "qualified"
, "rec", "type", "where"
]
constructorSpec :: String -> Maybe (Text, Text, Text, Declaration)
constructorSpec str = do
name <- str ^? key "contractName" . _String
abiValue <- str ^? key "abi"
bytecode <- str ^? key "bytecode" . _String
decl <- filter isContructor . unAbi <$> str ^? key "abi" . _JSON
return (name, jsonEncode abiValue, bytecode, toConstructor decl)
where
jsonEncode = LT.toStrict . LT.decodeUtf8 . Aeson.encode
isContructor (DConstructor _) = True
isContructor _ = False
toConstructor [] = DConstructor []
toConstructor [a] = a
toConstructor _ = error "Broken ABI: more that one constructor"
quoteAbiDec :: String -> DecsQ
quoteAbiDec str =
case str ^? _JSON <|> str ^? key "abi" . _JSON <|> str ^? key "compilerOutput" . key "abi" . _JSON of
Nothing -> fail "Unable to decode contract ABI"
Just (ContractAbi decs) -> do
funEvDecs <- concat <$> mapM mkDecl (escape decs)
case constructorSpec str of
Nothing -> return funEvDecs
Just (a, b, c, d) -> (funEvDecs ++) <$> mkContractDecl a b c d
quoteAbiExp :: String -> ExpQ
quoteAbiExp str =
case str ^? _JSON <|> str ^? key "abi" . _JSON of
Nothing -> fail "Unable to decode contract ABI"
Just a@(ContractAbi _) -> stringE (show a)