module Network.MyBitcoin
( Config(..)
, mbcSpend
, mbcGetBalance
, mbcGetRates
, mbcEncryptFormData
, mbcPostProcess
) where
import Network.Curl ( withCurlDo, curlGetString, CurlOption(..) )
import System.Directory ( findExecutable )
import System.Process ( readProcessWithExitCode )
import Text.Printf ( printf )
import Data.List ( isInfixOf )
import Data.List.Split ( splitOn )
import Data.Char ( isSpace )
import Data.Version ( showVersion )
import Control.Monad ( when, unless )
import Numeric ( showFFloat )
import Network.CGI ( urlEncode )
import Paths_mybitcoin_sci ( version )
data Config
= Config
{ cfgUserName :: String
, cfgAutoKey :: String
, cfgGPGBinary :: FilePath
, cfgEnableGPG :: Bool
}
gpgVerify :: Config -> String -> IO ()
gpgVerify cfg text
= do mbExec <- findExecutable (cfgGPGBinary cfg)
gpg <- case mbExec of Nothing -> error "Can't verify mybitcoin.com response without GPG."
Just gpg -> return gpg
(code, stdout, stderr) <- readProcessWithExitCode gpg ["--verify"] text
let checkString = "Good signature from \"MyBitcoin LLC (SCI Verification Key) <nobody@mybitcoin.com>\""
unless (checkString `isInfixOf` stderr) $
error "GPG Signature failure!"
mbcCurl :: Config -> String -> [String] -> IO String
mbcCurl cfg action rawPostData
= withCurlDo $
do (code, resp) <- curlGetString url [ CurlPost True
, CurlPostFields postData
, CurlSSLVerifyPeer False
, CurlUserAgent userAgent ]
return resp
where hostname = "https://www.mybitcoin.com"
url = printf "%s/sci/%s.php" hostname action
userAgent = printf "MBC SCI Client for Haskell/%s" (showVersion version)
postData = ["username=" ++ cfgUserName cfg
,"sci_auto_key=" ++ cfgAutoKey cfg] ++ rawPostData
mbcPostProcess :: Config -> String -> IO [(String,String)]
mbcPostProcess cfg text
= do when (null text) $ error "Curl failure."
when (cfgEnableGPG cfg) $ gpgVerify cfg text
return (mbcParseResponse text)
mbcParseResponse :: String -> [(String,String)]
mbcParseResponse text
= [ (key, trim (drop 1 val)) | line <- takeWhile (not.null) $ drop 3 (lines text)
, let (key, val) = break (==':') line ]
where trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
mbcRequest :: Config -> String -> [String] -> IO [(String,String)]
mbcRequest cfg action postData
= mbcPostProcess cfg =<< mbcCurl cfg action postData
mbcGetBalance :: Config -> IO [(String, String)]
mbcGetBalance cfg
= mbcRequest cfg "auto-getbalance" []
mbcGetRates :: Config -> IO [(String, String)]
mbcGetRates cfg
= mbcRequest cfg "auto-getrates" []
mbcEncryptFormData :: Config -> String -> IO [(String, String)]
mbcEncryptFormData cfg formData
= mbcRequest cfg "auto-encryptformdata" [ "form_data=" ++ urlEncode formData ]
mbcSpend :: Config
-> String
-> Rational
-> String
-> String
-> IO [(String, String)]
mbcSpend cfg receiver amount note baggage
= mbcRequest cfg "auto-spend" [ "amount=" ++ showFFloat (Just 8) (fromRational amount) ""
, "bitcoin_addr=" ++ receiver
, "note=" ++ urlEncode note
, "baggage=" ++ urlEncode baggage ]