module Network.Haskoin.Wallet.Accounts
(
initWallet
, accounts
, newAccount
, renameAccount
, addAccountKeys
, getAccount
, isMultisigAccount
, isReadAccount
, isCompleteAccount
, getAddress
, addressesAll
, addresses
, addressList
, unusedAddresses
, lookupByPubKey
, addressCount
, setAddrLabel
, addressPrvKey
, useAddress
, generateAddrs
, setAccountGap
, firstAddrTime
, getPathRedeem
, getPathPubKey
, getBloomFilter
, subSelectAddrCount
) where
import Control.Applicative ((<|>))
import Control.Monad (unless, void, when)
import Control.Monad.Trans (MonadIO, liftIO)
import Control.Monad.Base (MonadBase)
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.Trans.Resource (MonadResource)
import Control.Exception (throw)
import Data.Text (Text, unpack)
import Data.Maybe (mapMaybe, listToMaybe, isJust, isNothing)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import Data.List (nub)
import Data.Word (Word32)
import Data.String.Conversions (cs)
import Data.Serialize (encode)
import qualified Database.Persist as P (updateWhere, update , (=.))
import Database.Esqueleto
( Value(..), SqlExpr
, select, from, where_, val, sub_select, countRows, count, unValue
, orderBy, limit, asc, desc, offset, get, countDistinct
, max_, case_, when_, then_, else_
, (^.), (==.), (&&.), (>.), (-.), (<.)
, SqlPersistT, Entity(..)
, insertUnique, insert_
)
import Network.Haskoin.Crypto
import Network.Haskoin.Block
import Network.Haskoin.Script
import Network.Haskoin.Node
import Network.Haskoin.Util
import Network.Haskoin.Constants
import Network.Haskoin.Node.HeaderTree
import Network.Haskoin.Wallet.Types
import Network.Haskoin.Wallet.Model
initWallet :: MonadIO m => Double -> SqlPersistT m ()
initWallet fpRate = do
prevConfigRes <- select $ from $ \c -> return $ count $ c ^. WalletStateId
let cnt = maybe 0 unValue $ listToMaybe prevConfigRes
when (cnt == (0 :: Int)) $ do
time <- liftIO getCurrentTime
let bloom = bloomCreate (filterLen 0) fpRate 0 BloomUpdateNone
insert_ WalletState
{ walletStateHeight = 0
, walletStateBlock = headerHash genesisHeader
, walletStateBloomFilter = bloom
, walletStateBloomElems = 0
, walletStateBloomFp = fpRate
, walletStateVersion = 1
, walletStateCreated = time
}
accounts :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> ListRequest -> SqlPersistT m ([Account], Word32)
accounts ListRequest{..} = do
cntRes <- select $ from $ \acc ->
return $ countDistinct $ acc ^. AccountId
let cnt = maybe 0 unValue $ listToMaybe cntRes
when (listOffset > 0 && listOffset >= cnt) $ throw $ WalletException
"Offset beyond end of data set"
res <- fmap (map entityVal) $ select $ from $ \acc -> do
limitOffset listLimit listOffset
return acc
return (res, cnt)
initGap :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> Entity Account -> SqlPersistT m ()
initGap accE = do
void $ createAddrs accE AddressExternal 20
void $ createAddrs accE AddressInternal 20
newAccount :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> NewAccount
-> SqlPersistT m (Entity Account, Maybe Mnemonic)
newAccount NewAccount{..} = do
unless (validAccountType newAccountType) $
throwM $ WalletException "Invalid account type"
let gen = isNothing newAccountMnemonic &&
isNothing newAccountMaster &&
null newAccountKeys
(mnemonicM, masterM, keys) <- if gen
then do
when (isJust newAccountMaster || isJust newAccountMnemonic) $
throwM $ WalletException
"Master key or mnemonic not allowed for generate"
ent <- liftIO $ getEntropy 16
let ms = fromRight $ toMnemonic ent
root = makeXPrvKey $ fromRight $ mnemonicToSeed "" ms
master = case newAccountDeriv of
Nothing -> root
Just d -> derivePath d root
keys = deriveXPubKey master : newAccountKeys
return (Just ms, Just master, keys)
else case newAccountMnemonic of
Just ms -> do
when (isJust newAccountMaster) $ throwM $ WalletException
"Cannot provide both master key and mnemonic"
root <- case mnemonicToSeed "" (cs ms) of
Right s -> return $ makeXPrvKey s
Left _ -> throwM $ WalletException
"Mnemonic sentence invalid"
let master = case newAccountDeriv of
Nothing -> root
Just d -> derivePath d root
keys = deriveXPubKey master : newAccountKeys
return (Nothing, Just master, keys)
Nothing -> case newAccountMaster of
Just master -> do
let keys = deriveXPubKey master : newAccountKeys
return (Nothing, newAccountMaster, keys)
Nothing -> return (Nothing, newAccountMaster, newAccountKeys)
now <- liftIO getCurrentTime
let acc = Account
{ accountName = newAccountName
, accountType = newAccountType
, accountMaster = if newAccountReadOnly
then Nothing
else masterM
, accountDerivation = newAccountDeriv
, accountKeys = nub keys
, accountGap = 0
, accountCreated = now
}
unless (isValidAccKeys acc) $
throwM $ WalletException "Invalid account keys"
let canSetGap = isCompleteAccount acc
newAcc = acc{ accountGap = if canSetGap then 10 else 0 }
insertUnique newAcc >>= \resM -> case resM of
Just ai -> do
let accE = Entity ai newAcc
when canSetGap $ initGap accE
return (accE, mnemonicM)
Nothing -> throwM $ WalletException "Account already exists"
renameAccount :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> Entity Account
-> AccountName
-> SqlPersistT m Account
renameAccount (Entity ai acc) name = do
P.update ai [ AccountName P.=. name ]
return $ acc{ accountName = name }
addAccountKeys :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> Entity Account
-> [XPubKey]
-> SqlPersistT m Account
addAccountKeys (Entity ai acc) keys
| isCompleteAccount acc = throwM $
WalletException "The account is already complete"
| null keys || not (isValidAccKeys accKeys) = throwM $
WalletException "Invalid account keys"
| otherwise = do
let canSetGap = isCompleteAccount accKeys
updGap = [ AccountGap P.=. 10 | canSetGap]
newAcc = accKeys{ accountGap = if canSetGap then 10 else 0 }
P.update ai $ (AccountKeys P.=. newKeys) : updGap
when canSetGap $ initGap $ Entity ai newAcc
return newAcc
where
newKeys = accountKeys acc ++ keys
accKeys = acc{ accountKeys = newKeys }
isValidAccKeys :: Account -> Bool
isValidAccKeys Account{..} = testMaster && case accountType of
AccountRegular -> length accountKeys == 1
AccountMultisig _ n -> goMultisig n
where
goMultisig n =
length accountKeys == length (nub accountKeys) &&
length accountKeys <= n && not (null accountKeys)
testMaster = case accountMaster of
Just m -> deriveXPubKey m `elem` accountKeys
Nothing -> True
getAccount :: (MonadIO m, MonadThrow m) => AccountName
-> SqlPersistT m (Entity Account)
getAccount accountName = do
as <- select $ from $ \a -> do
where_ $ a ^. AccountName ==. val accountName
return a
case as of
(accEnt:_) -> return accEnt
_ -> throwM $ WalletException $ unwords
[ "Account", unpack accountName, "does not exist" ]
getAddress :: (MonadIO m, MonadThrow m)
=> Entity Account
-> AddressType
-> KeyIndex
-> SqlPersistT m (Entity WalletAddr)
getAddress accE@(Entity ai _) addrType index = do
res <- select $ from $ \x -> do
where_ ( x ^. WalletAddrAccount ==. val ai
&&. x ^. WalletAddrType ==. val addrType
&&. x ^. WalletAddrIndex ==. val index
&&. x ^. WalletAddrIndex <. subSelectAddrCount accE addrType
)
limit 1
return x
case res of
(addrE:_) -> return addrE
_ -> throwM $ WalletException $ unwords
[ "Invalid address index", show index ]
addressesAll :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> SqlPersistT m [WalletAddr]
addressesAll = fmap (map entityVal) $ select $ from return
addresses :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> Entity Account
-> AddressType
-> SqlPersistT m [WalletAddr]
addresses accE@(Entity ai _) addrType = fmap (map entityVal) $
select $ from $ \x -> do
where_ ( x ^. WalletAddrAccount ==. val ai
&&. x ^. WalletAddrType ==. val addrType
&&. x ^. WalletAddrIndex <. subSelectAddrCount accE addrType
)
return x
addressList :: MonadIO m
=> Entity Account
-> AddressType
-> ListRequest
-> SqlPersistT m ([WalletAddr], Word32)
addressList accE@(Entity ai _) addrType ListRequest{..} = do
cnt <- addressCount accE addrType
when (listOffset > 0 && listOffset >= cnt) $ throw $ WalletException
"Offset beyond end of data set"
res <- fmap (map entityVal) $ select $ from $ \x -> do
where_ ( x ^. WalletAddrAccount ==. val ai
&&. x ^. WalletAddrType ==. val addrType
&&. x ^. WalletAddrIndex <. val cnt
)
let order = if listReverse then asc else desc
orderBy [ order (x ^. WalletAddrIndex) ]
when (listLimit > 0) $ limit $ fromIntegral listLimit
when (listOffset > 0) $ offset $ fromIntegral listOffset
return x
return (res, cnt)
addressCount :: MonadIO m
=> Entity Account
-> AddressType
-> SqlPersistT m Word32
addressCount (Entity ai acc) addrType = do
res <- select $ from $ \x -> do
where_ ( x ^. WalletAddrAccount ==. val ai
&&. x ^. WalletAddrType ==. val addrType
)
return countRows
let cnt = maybe 0 unValue $ listToMaybe res
return $ if cnt > accountGap acc then cnt - accountGap acc else 0
unusedAddresses :: MonadIO m
=> Entity Account
-> AddressType
-> ListRequest
-> SqlPersistT m ([WalletAddr], Word32)
unusedAddresses (Entity ai acc) addrType ListRequest{..} = do
cntRes <- select $ from $ \x -> do
where_ ( x ^. WalletAddrAccount ==. val ai
&&. x ^. WalletAddrType ==. val addrType
)
return countRows
let cnt = maybe 0 unValue $ listToMaybe cntRes
when (listOffset > 0 && listOffset >= gap) $ throw $ WalletException
"Offset beyond end of data set"
res <- fmap (map entityVal) $ select $ from $ \x -> do
where_ ( x ^. WalletAddrAccount ==. val ai
&&. x ^. WalletAddrType ==. val addrType
)
orderBy [ order $ x ^. WalletAddrIndex ]
limit $ fromIntegral $ lim cnt
offset $ fromIntegral $ off cnt
return x
return (res, gap)
where
gap = accountGap acc
lim' = if listLimit > 0 then listLimit else gap
off cnt | listReverse = listOffset + gap
| otherwise = cnt - 2 * gap + listOffset
lim cnt | listReverse = min lim' (gap - listOffset)
| otherwise = min lim' (cnt - off cnt - gap)
order = if listReverse then desc else asc
lookupByPubKey :: (MonadIO m, MonadThrow m)
=> Entity Account
-> PubKeyC
-> AddressType
-> SqlPersistT m [WalletAddr]
lookupByPubKey (Entity ai _) key addrType =
fmap (map entityVal) $ select $ from $ \x -> do
where_ ( x ^. WalletAddrAccount ==. val ai
&&. x ^. WalletAddrType ==. val addrType
&&. x ^. WalletAddrKey ==. val (Just key)
)
return x
setAddrLabel :: (MonadIO m, MonadThrow m)
=> Entity Account
-> KeyIndex
-> AddressType
-> Text
-> SqlPersistT m WalletAddr
setAddrLabel accE i addrType label = do
Entity addrI addr <- getAddress accE addrType i
P.update addrI [ WalletAddrLabel P.=. label ]
return $ addr{ walletAddrLabel = label }
addressPrvKey :: (MonadIO m, MonadThrow m)
=> Entity Account
-> Maybe XPrvKey
-> KeyIndex
-> AddressType
-> SqlPersistT m PrvKeyC
addressPrvKey accE@(Entity ai acc) masterM index addrType = do
ret <- select $ from $ \x -> do
where_ ( x ^. WalletAddrAccount ==. val ai
&&. x ^. WalletAddrType ==. val addrType
&&. x ^. WalletAddrIndex ==. val index
&&. x ^. WalletAddrIndex <. subSelectAddrCount accE addrType
)
return $ x ^. WalletAddrIndex
case ret of
(Value idx:_) -> do
accKey <- case accountMaster acc <|> masterM of
Just key -> return key
Nothing -> throwM $ WalletException "Could not get private key"
let addrKey =
prvSubKey (prvSubKey accKey (addrTypeIndex addrType)) idx
return $ xPrvKey addrKey
_ -> throwM $ WalletException "Invalid address"
createAddrs :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> Entity Account
-> AddressType
-> Word32
-> SqlPersistT m [WalletAddr]
createAddrs (Entity ai acc) addrType n
| n == 0 = throwM $ WalletException $
unwords [ "Invalid value", show n ]
| not (isCompleteAccount acc) =
throwM $ WalletException $ unwords
[ "Keys are still missing from the incomplete account"
, unpack $ accountName acc
]
| otherwise = do
now <- liftIO getCurrentTime
lastRes <- select $ from $ \x -> do
where_ ( x ^. WalletAddrAccount ==. val ai
&&. x ^. WalletAddrType ==. val addrType
)
return $ max_ (x ^. WalletAddrIndex)
let nextI = case lastRes of
(Value (Just lastI):_) -> lastI + 1
_ -> 0
build (addr, keyM, rdmM, i) = WalletAddr
{ walletAddrAccount = ai
, walletAddrAddress = addr
, walletAddrIndex = i
, walletAddrType = addrType
, walletAddrLabel = ""
, walletAddrRedeem = rdmM
, walletAddrKey = keyM
, walletAddrCreated = now
}
res = map build $ take (fromIntegral n) $ deriveFrom nextI
splitInsertMany_ res
incrementFilter res
return res
where
branchType = addrTypeIndex addrType
deriveFrom = case accountType acc of
AccountMultisig m _ ->
let f (a, r, i) = (a, Nothing, Just r, i)
deriv = Deriv :/ branchType
in map f . derivePathMSAddrs (accountKeys acc) deriv m
AccountRegular -> case accountKeys acc of
(key:_) -> let f (a, k, i) = (a, Just k, Nothing, i)
in map f . derivePathAddrs key (Deriv :/ branchType)
[] -> throw $ WalletException $ unwords
[ "createAddrs: No key in regular account (corrupt database)"
, unpack $ accountName acc
]
generateAddrs :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> Entity Account
-> AddressType
-> KeyIndex
-> SqlPersistT m Int
generateAddrs accE addrType genIndex = do
cnt <- addressCount accE addrType
let toGen = fromIntegral genIndex - fromIntegral cnt + 1
if toGen > 0
then do
void $ createAddrs accE addrType $ fromIntegral toGen
return toGen
else return 0
useAddress :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> WalletAddr -> SqlPersistT m [WalletAddr]
useAddress WalletAddr{..} = do
res <- select $ from $ \x -> do
where_ ( x ^. WalletAddrAccount ==. val walletAddrAccount
&&. x ^. WalletAddrType ==. val walletAddrType
&&. x ^. WalletAddrIndex >. val walletAddrIndex
)
return countRows
case res of
(Value cnt:_) -> get walletAddrAccount >>= \accM -> case accM of
Just acc -> do
let accE = Entity walletAddrAccount acc
gap = fromIntegral (accountGap acc) :: Int
missing = 2*gap - cnt
if missing > 0
then createAddrs accE walletAddrType $ fromIntegral missing
else return []
_ -> return []
_ -> return []
setAccountGap :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> Entity Account
-> Word32
-> SqlPersistT m (Entity Account)
setAccountGap accE@(Entity ai acc) gap
| not (isCompleteAccount acc) =
throwM $ WalletException $ unwords
[ "Keys are still missing from the incomplete account"
, unpack $ accountName acc
]
| missing <= 0 = throwM $ WalletException
"The gap of an account can only be increased"
| otherwise = do
_ <- createAddrs accE AddressExternal $ fromInteger $ missing*2
_ <- createAddrs accE AddressInternal $ fromInteger $ missing*2
P.update ai [ AccountGap P.=. gap ]
return $ Entity ai acc{ accountGap = gap }
where
missing = toInteger gap - toInteger (accountGap acc)
firstAddrTime :: MonadIO m => SqlPersistT m (Maybe Timestamp)
firstAddrTime = do
res <- select $ from $ \x -> do
orderBy [ asc (x ^. WalletAddrId) ]
limit 1
return $ x ^. WalletAddrCreated
return $ case res of
(Value d:_) -> Just $ toPOSIX d
_ -> Nothing
where
toPOSIX = fromInteger . round . utcTimeToPOSIXSeconds
incrementFilter :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> [WalletAddr]
-> SqlPersistT m ()
incrementFilter addrs = do
(bloom, elems, _) <- getBloomFilter
let newElems = elems + (length addrs * 2)
if filterLen newElems > filterLen elems
then computeNewFilter
else setBloomFilter (addToFilter bloom addrs) newElems
computeNewFilter :: (MonadIO m, MonadThrow m, MonadBase IO m, MonadResource m)
=> SqlPersistT m ()
computeNewFilter = do
(_, _, fpRate) <- getBloomFilter
cntRes <- select $ from $ \x -> return $ count $ x ^. WalletAddrId
let elems = maybe 0 unValue $ listToMaybe cntRes
newBloom = bloomCreate (filterLen elems) fpRate 0 BloomUpdateNone
addrs <- addressesAll
let bloom = addToFilter newBloom addrs
setBloomFilter bloom elems
filterLen :: Int -> Int
filterLen = round . pow2 . ceiling . log2
where
pow2 x = (2 :: Double) ** fromInteger x
log2 x = logBase (2 :: Double) (fromIntegral x)
addToFilter :: BloomFilter -> [WalletAddr] -> BloomFilter
addToFilter bloom addrs =
bloom3
where
pks = mapMaybe walletAddrKey addrs
rdms = mapMaybe walletAddrRedeem addrs
f1 b a = bloomInsert b $ encode $ getAddrHash a
bloom1 = foldl f1 bloom $ map walletAddrAddress addrs
f2 b r = bloomInsert b $ encodeOutputBS r
bloom2 = foldl f2 bloom1 rdms
f3 b p = bloomInsert b $ encode p
bloom3 = foldl f3 bloom2 pks
getBloomFilter :: (MonadIO m, MonadThrow m)
=> SqlPersistT m (BloomFilter, Int, Double)
getBloomFilter = do
res <- select $ from $ \c -> do
limit 1
return ( c ^. WalletStateBloomFilter
, c ^. WalletStateBloomElems
, c ^. WalletStateBloomFp
)
case res of
((Value b, Value n, Value fp):_) -> return (b, n, fp)
_ -> throwM $
WalletException "getBloomFilter: Database not initialized"
setBloomFilter :: MonadIO m => BloomFilter -> Int -> SqlPersistT m ()
setBloomFilter bloom elems =
P.updateWhere [] [ WalletStateBloomFilter P.=. bloom
, WalletStateBloomElems P.=. elems
]
getPathRedeem :: Account -> SoftPath -> RedeemScript
getPathRedeem acc@Account{..} deriv = case accountType of
AccountMultisig m _ -> if isCompleteAccount acc
then sortMulSig $ PayMulSig pubKeys m
else throw $ WalletException $ unwords
[ "getPathRedeem: Incomplete multisig account"
, unpack accountName
]
_ -> throw $ WalletException $ unwords
[ "getPathRedeem: Account", unpack accountName
, "is not a multisig account"
]
where
f = toPubKeyG . xPubKey . derivePubPath deriv
pubKeys = map f accountKeys
getPathPubKey :: Account -> SoftPath -> PubKeyC
getPathPubKey acc@Account{..} deriv
| isMultisigAccount acc = throw $ WalletException $
unwords [ "getPathPubKey: Account", unpack accountName
, "is not a regular non-multisig account"
]
| otherwise = case accountKeys of
(key:_) -> xPubKey $ derivePubPath deriv key
_ -> throw $ WalletException $ unwords
[ "getPathPubKey: No keys are available in account"
, unpack accountName
]
subSelectAddrCount :: Entity Account
-> AddressType
-> SqlExpr (Value KeyIndex)
subSelectAddrCount (Entity ai acc) addrType =
sub_select $ from $ \x -> do
where_ ( x ^. WalletAddrAccount ==. val ai
&&. x ^. WalletAddrType ==. val addrType
)
let gap = val $ accountGap acc
return $ case_
[ when_ (countRows >. gap)
then_ (countRows -. gap)
] (else_ $ val 0)
validMultisigParams :: Int -> Int -> Bool
validMultisigParams m n = n >= 1 && n <= 15 && m >= 1 && m <= n
validAccountType :: AccountType -> Bool
validAccountType t = case t of
AccountRegular -> True
AccountMultisig m n -> validMultisigParams m n
isMultisigAccount :: Account -> Bool
isMultisigAccount acc = case accountType acc of
AccountRegular -> False
AccountMultisig{} -> True
isReadAccount :: Account -> Bool
isReadAccount = isNothing . accountMaster
isCompleteAccount :: Account -> Bool
isCompleteAccount acc = case accountType acc of
AccountRegular -> length (accountKeys acc) == 1
AccountMultisig _ n -> length (accountKeys acc) == n