module Network.Haskoin.Wallet.Client.Commands
( cmdStart
, cmdStop
, cmdNewAcc
, cmdAddKey
, cmdSetGap
, cmdAccount
, cmdRenameAcc
, cmdAccounts
, cmdList
, cmdPubKeys
, cmdUnused
, cmdLabel
, cmdTxs
, cmdAddrTxs
, cmdKeyIndex
, cmdGenAddrs
, cmdSend
, cmdSendMany
, cmdImport
, cmdSign
, cmdBalance
, cmdGetTx
, cmdGetOffline
, cmdSignOffline
, cmdRescan
, cmdDecodeTx
, cmdVersion
, cmdStatus
, cmdBlockInfo
, cmdMonitor
, cmdSync
, cmdKeyPair
, cmdDeleteTx
, cmdPending
, cmdDead
)
where

import           Control.Applicative             ((<|>))
import           Control.Concurrent.Async.Lifted (async, wait)
import           Control.Monad                   (forM_, forever, liftM2,
                                                  unless, when)
import qualified Control.Monad.Reader            as R (ReaderT, ask, asks)
import           Control.Monad.Trans             (liftIO)
import           Data.Aeson                      (FromJSON, ToJSON, Value (..),
                                                  decode, eitherDecode, object,
                                                  toJSON, (.=))
import qualified Data.Aeson                      as Aeson (encode)
import qualified Data.ByteString.Char8           as B8 (hPutStrLn, putStrLn,
                                                        unwords)
import           Data.String                     (fromString)
import           Data.List                       (intercalate, intersperse)
import           Data.Maybe                      (fromMaybe, isJust, isNothing,
                                                  listToMaybe, maybeToList)
import           Data.Monoid                     ((<>))
import           Data.Restricted                 (rvalue)
import           Data.Serialize                  (encode)
import           Data.String.Conversions         (cs)
import           Data.Text                       (Text, pack, splitOn, unpack)
import           Data.Word                       (Word32, Word64)
import qualified Data.Yaml                       as YAML (encode)
import qualified Data.Time.Format                as Time
import           Network.Haskoin.Block
import           Network.Haskoin.Constants
import           Network.Haskoin.Crypto
import           Network.Haskoin.Node.STM
import           Network.Haskoin.Script
import           Network.Haskoin.Transaction
import           Network.Haskoin.Util
import           Network.Haskoin.Wallet.Server
import           Network.Haskoin.Wallet.Settings
import           Network.Haskoin.Wallet.Types
import qualified Network.Haskoin.Wallet.Client.PrettyJson as JSON
import qualified System.Console.Haskeline        as Haskeline
import           System.IO                       (stderr)
import           System.ZMQ4                     (KeyFormat (..), Req (..),
                                                  Socket, SocketType, Sub (..),
                                                  connect, curveKeyPair,
                                                  receive, receiveMulti,
                                                  restrict, send,
                                                  setCurvePublicKey,
                                                  setCurveSecretKey,
                                                  setCurveServerKey, setLinger,
                                                  subscribe, withContext,
                                                  withSocket)
import           Text.Read                       (readMaybe)

type Handler = R.ReaderT Config IO

defaultDeriv :: HardPath
defaultDeriv = Deriv :| 0

-- hw start [config] [--detach]
cmdStart :: Handler ()
cmdStart = do
    cfg <- R.ask
    liftIO $ runSPVServer cfg

-- hw stop [config]
cmdStop :: Handler ()
cmdStop = do
    resE <- sendZmq StopServerR
    handleResponse (resE :: Either String (WalletResponse (Maybe ()))) (const $ return ())
    liftIO $ putStrLn "Process stopped"

getSigningKeys :: String
               -> Handler (Maybe XPrvKey)
getSigningKeys name = do
    derivM <- R.asks configPath
    kM <- masterKey
    case kM of
        Just _ -> return Nothing
        Nothing -> do
            keyOrMnemonic <-
                liftIO . Haskeline.runInputT
                    Haskeline.defaultSettings $
                    Haskeline.getPassword (Just '*')
                    "Mnemonic or private extended key: "
            case keyOrMnemonic of
                Just ms -> return $ go (cs ms) derivM
                Nothing -> error "No action due to EOF"
  where
    masterKey = do
        resE <- sendZmq $ GetAccountR $ pack name
        case resE of
            Right (ResponseValid (Just acc)) ->
                return $ jsonAccountMaster acc
            Right (ResponseError e) -> error $ cs e
            Left e -> error e
            _ -> error "You find yourself in a strange place"
    go "" _ = error "Need key to sign"
    go str derivM = case xPrvImport str of
        Just k -> case derivM of
            Just d -> Just $ derivePath d k
            Nothing -> Just k
        Nothing -> case mnemonicToSeed "" str of
            Right s -> Just (makeXPrvKey s)
            Left _ -> error "Could not parse key"

checkExists :: String -> Handler Bool
checkExists name = do
     resE <- sendZmq $ GetAccountR $ pack name
     case (resE :: Either String (WalletResponse JsonAccount)) of
         Right (ResponseValid _) -> return True
         Right (ResponseError  _) -> return False
         Left e -> error e

getKey :: Handler (Maybe Mnemonic, Maybe XPrvKey, Maybe HardPath, Maybe XPubKey)
getKey = do
    derivM <- R.asks configPath
    i <- liftIO . Haskeline.runInputT Haskeline.defaultSettings $
        Haskeline.getPassword (Just '*')
            "Type mnemonic, extended key or leave empty to generate: "
    case i of
        Just s -> go (cs s) derivM
        Nothing -> error "No action due to EOF"
  where
    go "" derivM = return
        ( Nothing
        , Nothing
        , derivM <|> Just defaultDeriv
        , Nothing
        )
    go str' derivM = case xPrvImport str' of
        Just k -> return
            ( Nothing
            , Just $ maybe k (`derivePath` k) derivM
            , derivM
            , Nothing
            )
        Nothing -> case xPubImport str' of
            Just p -> return
                ( Nothing
                , Nothing
                , derivM
                , Just p
                )
            Nothing -> return
                ( Just $ cs str'
                , Nothing
                , derivM <|> Just defaultDeriv
                , Nothing
                )

-- First argument: is account read-only?
cmdNewAcc :: Bool -> String -> [String] -> Handler ()
cmdNewAcc r name ls = do
    _ <- return $! typ
    e <- checkExists name
    when e $ error "Account exists"
    (mnemonicM, masterM, derivM, keyM) <- getKey
    let newAcc = NewAccount
            { newAccountName     = pack name
            , newAccountType     = typ
            , newAccountMnemonic = cs <$> mnemonicM
            , newAccountMaster   = masterM
            , newAccountDeriv    = derivM
            , newAccountKeys     = maybeToList keyM
            , newAccountReadOnly = r
            }
    resE <- sendZmq $ PostAccountsR newAcc
    handleResponse resE $ liftIO . putStr . printAccount
  where
    typ = case ls of
        [] -> AccountRegular
        [mS, nS] -> fromMaybe (error "Account information incorrect") $ do
            m <- readMaybe mS
            n <- readMaybe nS
            return $ AccountMultisig m n
        _ -> error "Number of parametres incorrect"

cmdAddKey :: String -> Handler ()
cmdAddKey name = do
    e <- checkExists name
    unless e $ error "Account does not exist"
    (mnemonicM, masterM, derivM, pubM) <- getKey
    let key = case mnemonicM of
            Just ms -> case mnemonicToSeed "" (cs ms) of
                Right s -> deriveXPubKey $
                    derivePath (fromMaybe defaultDeriv derivM) $
                    makeXPrvKey s
                Left _ -> error "Could not decode mnemonic sentence"
            Nothing -> case masterM of
                Just m -> deriveXPubKey $ maybe m (`derivePath` m) derivM
                Nothing -> fromMaybe (error "No keys provided") pubM
    resE <- sendZmq (PostAccountKeysR (pack name) [key])
    handleResponse resE $ liftIO . putStr . printAccount

cmdSetGap :: String -> String -> Handler ()
cmdSetGap name gap = do
    resE <- sendZmq (PostAccountGapR (pack name) setGap)
    handleResponse resE $ liftIO . putStr . printAccount
  where
    setGap = SetAccountGap $ read gap

cmdAccount :: String -> Handler ()
cmdAccount name = do
    resE <- sendZmq (GetAccountR $ pack name)
    handleResponse resE $ liftIO . putStr . printAccount

cmdAccounts :: [String] -> Handler ()
cmdAccounts ls = do
    let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe
    listAction page GetAccountsR $ \ts -> do
        let xs = map (liftIO . putStr . printAccount) ts
        sequence_ $ intersperse (liftIO $ putStrLn "-") xs

cmdRenameAcc :: String -> String -> Handler ()
cmdRenameAcc oldName newName = do
    resE <- sendZmq $ PostAccountRenameR (pack oldName) (pack newName)
    handleResponse resE $ liftIO . putStr . printAccount

listAction :: (FromJSON a, ToJSON a)
            => Word32
            -> (ListRequest -> WalletRequest)
            -> ([a] -> Handler ())
            -> Handler ()
listAction page requestBuilder action = do
    c <- R.asks configCount
    r <- R.asks configReversePaging
    case c of
        0 -> do
            let listReq = ListRequest 0 0 r
            resE <- sendZmq (requestBuilder listReq)
            handleResponse resE $ \(ListResult a _) -> action a
        _ -> do
            when (page < 1) $ error "Page cannot be less than 1"
            let listReq = ListRequest ((page - 1) * c) c r
            resE <- sendZmq (requestBuilder listReq)
            handleResponse resE $ \(ListResult a m) -> case m of
                0 -> liftIO . putStrLn $ "No elements"
                _ -> do
                    liftIO . putStrLn $
                        "Page " ++ show page ++ " of " ++ show (pages m c) ++
                        " (" ++ show m ++ " elements)"
                    action a
  where
    pages m c | m `mod` c == 0 = m `div` c
              | otherwise = m `div` c + 1

listJsonAddrs :: (JsonAddr -> String)
              -> String
              -> [String]
              -> Handler ()
listJsonAddrs showFunc name ls = do
    t <- R.asks configAddrType
    m <- R.asks configMinConf
    o <- R.asks configOffline
    let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe
        f = GetAddressesR (pack name) t m o
    listAction page f $ \as -> forM_ as (liftIO . putStrLn . showFunc)

cmdList :: String -> [String] -> Handler ()
cmdList = listJsonAddrs printAddress

cmdPubKeys :: String -> [String] -> Handler ()
cmdPubKeys = listJsonAddrs printPubKey

cmdUnused :: String -> [String] -> Handler ()
cmdUnused name ls = do
    t <- R.asks configAddrType
    let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe
        f = GetAddressesUnusedR (pack name) t
    listAction page f $ \as -> forM_ (as :: [JsonAddr]) $
        liftIO . putStrLn . printAddress

cmdLabel :: String -> String -> String -> Handler ()
cmdLabel name iStr label = do
    t <- R.asks configAddrType
    resE <- sendZmq (PutAddressR (pack name) i t addrLabel)
    handleResponse resE $ liftIO . putStrLn . printAddress
  where
    i         = read iStr
    addrLabel = AddressLabel $ pack label

cmdTxs :: String -> [String] -> Handler ()
cmdTxs name ls = do
    let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe
    r <- R.asks configReversePaging
    listAction page (GetTxsR (pack name)) $ \ts -> do
        let xs = map (liftIO . putStr . printTx Nothing) ts
            xs' = if r then xs else reverse xs
        sequence_ $ intersperse (liftIO $ putStrLn "-") xs'

cmdPending :: String -> [String] -> Handler ()
cmdPending name ls = do
    let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe
    r <- R.asks configReversePaging
    listAction page (GetPendingR (pack name)) $ \ts -> do
        let xs = map (liftIO . putStr . printTx Nothing) ts
            xs' = if r then xs else reverse xs
        sequence_ $ intersperse (liftIO $ putStrLn "-") xs'

cmdDead :: String -> [String] -> Handler ()
cmdDead name ls = do
    let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe
    r <- R.asks configReversePaging
    listAction page (GetDeadR (pack name)) $ \ts -> do
        let xs = map (liftIO . putStr . printTx Nothing) ts
            xs' = if r then xs else reverse xs
        sequence_ $ intersperse (liftIO $ putStrLn "-") xs'

cmdAddrTxs :: String -> String -> [String] -> Handler ()
cmdAddrTxs name i ls = do
    t <- R.asks configAddrType
    m <- R.asks configMinConf
    o <- R.asks configOffline
    r <- R.asks configReversePaging
    let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe
        f = GetAddrTxsR (pack name) index t
    resE <- sendZmq (GetAddressR (pack name) index t m o)
    handleResponse resE $ \JsonAddr{..} -> listAction page f $ \ts -> do
        let xs = map (liftIO . putStr . printTx (Just jsonAddrAddress)) ts
            xs' = if r then xs else reverse xs
        sequence_ $ intersperse (liftIO $ putStrLn "-") xs'
  where
    index = fromMaybe (error "Could not read index") $ readMaybe i

cmdKeyIndex :: String -> String -> Handler ()
cmdKeyIndex name k = do
    t <- R.asks configAddrType
    resE <- sendZmq $ GetIndexR (pack name) (fromString k) t
    handleResponse resE $ \res -> case res of
        []  -> liftIO $ putStrLn "No matching pubkeys found"
        lst -> liftIO $ putStrLn $ unlines $    -- Two or more pubkeys with the same index is extremely improbable. But let's print it out if it happens.
            map (\adr -> showLine (jsonAddrIndex adr, jsonAddrKey adr)) lst
  where
    showLine :: (KeyIndex, Maybe PubKeyC) -> String
    showLine (idx,k') = unwords [ show (idx :: KeyIndex), ":", showPubKey k' ]
    showPubKey = maybe "<no pubkey available>" (jsonStr2Str . toJSON)
    jsonStr2Str (String t) = cs t
    jsonStr2Str _          = ""

cmdGenAddrs :: String -> String -> Handler ()
cmdGenAddrs name i = do
    t <- R.asks configAddrType
    let req = PostAddressesR (pack name) index t
    resE <- sendZmq req
    handleResponse resE $ \cnt -> liftIO . putStrLn $
        unwords [ "Generated", show (cnt :: Int), "addresses" ]
  where
    index = read i

cmdSend :: String -> String -> String -> Handler ()
cmdSend name addrStr amntStr = cmdSendMany name [addrStr ++ ":" ++ amntStr]

cmdSendMany :: String -> [String] -> Handler ()
cmdSendMany name xs = case rcpsM of
    Just rcps -> do
        fee     <- R.asks configFee
        rcptFee <- R.asks configRcptFee
        minconf <- R.asks configMinConf
        sign    <- R.asks configSignTx
        masterM <- if sign then getSigningKeys name else return Nothing
        let action = CreateTx rcps fee minconf rcptFee sign
        resE <- sendZmq (PostTxsR (pack name) masterM action)
        handleResponse resE $ liftIO . putStr . printTx Nothing
    _ -> error "Could not parse recipient information"
  where
    g str   = map cs $ splitOn ":" (pack str)
    f [a,v] = liftM2 (,) (base58ToAddr a) (readMaybe $ cs v)
    f _     = Nothing
    rcpsM   = mapM (f . g) xs

getHexTx :: Handler Tx
getHexTx = do
    hexM <- Haskeline.runInputT Haskeline.defaultSettings $
        Haskeline.getInputLine ""
    let txM = case hexM of
            Nothing -> error "No action due to EOF"
            Just hex -> decodeToMaybe =<< decodeHex (cs hex)
    case txM of
        Just tx -> return tx
        Nothing -> error "Could not parse transaction"

cmdImport :: String -> Handler ()
cmdImport name = do
    tx <- getHexTx
    let action = ImportTx tx
    resE <- sendZmq (PostTxsR (pack name) Nothing action)
    handleResponse resE $ liftIO . putStr . printTx Nothing

cmdSign :: String -> String -> Handler ()
cmdSign name txidStr = case txidM of
    Just txid -> do
        masterM <- getSigningKeys name
        let action = SignTx txid
        resE <- sendZmq (PostTxsR (pack name) masterM action)
        handleResponse resE $ liftIO . putStr . printTx Nothing
    _ -> error "Could not parse txid"
  where
    txidM = hexToTxHash $ cs txidStr

cmdGetOffline :: String -> String -> Handler ()
cmdGetOffline name tidStr = case tidM of
    Just tid -> do
        resE <- sendZmq (GetOfflineTxR (pack name) tid)
        handleResponse resE $ \(OfflineTxData tx dat) -> do
            liftIO $ putStrLn $ unwords
                [ "Tx      :", cs $ encodeHex $ encode tx ]
            liftIO $ putStrLn $ unwords
                [ "CoinData:", cs $ encodeHex $ cs $ Aeson.encode dat ]
    _ -> error "Could not parse txid"
  where
    tidM = hexToTxHash $ cs tidStr

cmdSignOffline :: String -> String -> String -> Handler ()
cmdSignOffline name txStr datStr = case (txM, datM) of
    (Just tx, Just dat) -> do
        masterM <- getSigningKeys name
        resE <- sendZmq (PostOfflineTxR (pack name) masterM tx dat)
        handleResponse resE $ \(TxCompleteRes tx' c) -> do
            liftIO $ putStrLn $ unwords
                [ "Tx      :", cs $ encodeHex $ encode tx' ]
            liftIO $ putStrLn $ unwords
                [ "Complete:", if c then "Yes" else "No" ]
    _ -> error "Could not decode input data"
  where
    datM = decode . cs =<< decodeHex (cs datStr)
    txM  = decodeToMaybe =<< decodeHex (cs txStr)

cmdBalance :: String -> Handler ()
cmdBalance name = do
    m <- R.asks configMinConf
    o <- R.asks configOffline
    resE <- sendZmq (GetBalanceR (pack name) m o)
    handleResponse resE $ \bal ->
        liftIO $ putStrLn $ unwords [ "Balance:", show (bal :: Word64) ]

cmdGetTx :: String -> String -> Handler ()
cmdGetTx name tidStr = case tidM of
    Just tid -> do
        resE <- sendZmq (GetTxR (pack name) tid)
        handleResponse resE $ liftIO . putStr . printTx Nothing
    _ -> error "Could not parse txid"
  where
    tidM = hexToTxHash $ cs tidStr

cmdRescan :: [String] -> Handler ()
cmdRescan timeLs = do
    let timeM = case timeLs of
            [] -> Nothing
            str:_ -> case readMaybe str of
                Nothing -> error "Could not decode time"
                Just t -> Just t
    resE <- sendZmq (PostNodeR $ NodeActionRescan timeM)
    handleResponse resE $ \(RescanRes ts) ->
        liftIO $ putStrLn $ unwords [ "Timestamp:", show ts]

cmdDeleteTx :: String -> Handler ()
cmdDeleteTx tidStr = case tidM of
    Just tid -> do
        resE <- sendZmq (DeleteTxIdR tid)
        handleResponse resE $ \() -> return ()
    Nothing -> error "Could not parse txid"
  where
    tidM = hexToTxHash $ cs tidStr

cmdMonitor :: [String] -> Handler ()
cmdMonitor ls = do
    cfg@Config{..} <- R.ask
    -- TODO: I can do this in the same thread without ^C twice (see sendZmq)
    liftIO $ withContext $ \ctx -> withSocket ctx Sub $ \sock -> do
        setLinger (restrict (0 :: Int)) sock
        setupAuth cfg sock
        connect sock configConnectNotif
        subscribe sock "[block]"
        forM_ ls $ \name -> subscribe sock $ "{" <> cs name <> "}"
        forever $ do
            [_,m] <- receiveMulti sock
            handleNotif configFormat $ eitherDecode $ cs m

cmdSync :: String -> String -> [String] -> Handler ()
cmdSync acc block ls = do
    let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe
        f = case length block of
            64 -> GetSyncR (cs acc) $
                fromMaybe (error "Could not decode block id") $
                hexToBlockHash $ cs block
            _  -> GetSyncHeightR (cs acc) $
                fromMaybe (error "Could not decode block height") $
                readMaybe block
    r <- R.asks configReversePaging
    listAction page f $ \blocks -> do
        let blocks' = if r then reverse blocks else blocks
        forM_ (blocks' :: [JsonSyncBlock]) $ liftIO . putStrLn . printSyncBlock

cmdDecodeTx :: Handler ()
cmdDecodeTx = do
    tx <- getHexTx
    format <- R.asks configFormat
    liftIO $ formatStr $ cs $ case format of
        OutputJSON -> cs $ jsn tx
        _          -> YAML.encode $ val tx
  where
    val = encodeTxJSON
    jsn = JSON.encodePretty . val

cmdVersion :: Handler ()
cmdVersion = liftIO $ do
    putStrLn $ unwords [ "network   :", cs networkName ]
    putStrLn $ unwords [ "user-agent:", cs haskoinUserAgent ]

cmdStatus :: Handler ()
cmdStatus = do
    v <- R.asks configVerbose
    resE <- sendZmq (PostNodeR NodeActionStatus)
    handleResponse resE $ mapM_ (liftIO . putStrLn) . printNodeStatus v

cmdKeyPair :: Handler ()
cmdKeyPair = do
    (pub, sec) <- curveKeyPair
    liftIO $ do
        B8.putStrLn $ B8.unwords [ "public :", rvalue pub ]
        B8.putStrLn $ B8.unwords [ "private:", rvalue sec ]

cmdBlockInfo :: [String] -> Handler ()
cmdBlockInfo headers = do
    -- Show best block if no arguments are provided
    hashL <- if null headers then
            -- Fetch best block hash from status msg, and return as list
            (: []) . parseRes <$> sendZmq (PostNodeR NodeActionStatus)
        else
            return (map fromString headers)
    sendZmq (GetBlockInfoR hashL) >>=
        \resE -> handleResponse resE (liftIO . printResults)
  where
    printResults :: [BlockInfo] -> IO ()
    printResults = mapM_ $ putStrLn . unlines . printBlockInfo
    parseRes :: Either String (WalletResponse NodeStatus) -> BlockHash
    parseRes = nodeStatusBestHeader . fromMaybe
        (error "No response to NodeActionStatus msg") . parseResponse


{- Helpers -}

handleNotif :: OutputFormat -> Either String Notif -> IO ()
handleNotif _   (Left e) = error e
handleNotif fmt (Right notif) = case fmt of
    OutputJSON -> formatStr $ cs $
        JSON.encodePretty notif
    OutputYAML -> do
        putStrLn "---"
        formatStr $ cs $ YAML.encode notif
        putStrLn "..."
    OutputNormal ->
        putStrLn $ printNotif notif

parseResponse
    :: Either String (WalletResponse a)
    -> Maybe a
parseResponse resE = case resE of
    Right (ResponseValid resM) -> resM
    Right (ResponseError err)  -> error $ unpack err
    Left err                   -> error err

handleResponse
    :: (FromJSON a, ToJSON a)
    => Either String (WalletResponse a)
    -> (a -> Handler ())
    -> Handler ()
handleResponse resE handle = case parseResponse resE of
    Just a  -> formatOutput a =<< R.asks configFormat
    Nothing -> return ()
  where
    formatOutput a format = case format of
        OutputJSON   -> liftIO . formatStr $ cs $
            JSON.encodePretty a
        OutputYAML   -> liftIO . formatStr $ cs $ YAML.encode a
        OutputNormal -> handle a

sendZmq :: (FromJSON a, ToJSON a)
        => WalletRequest
        -> Handler (Either String (WalletResponse a))
sendZmq req = do
    cfg <- R.ask
    let msg = cs $ Aeson.encode req
    when (configVerbose cfg) $ liftIO $
        B8.hPutStrLn stderr $ "Outgoing JSON: " `mappend` msg
    -- TODO: If I do this in the same thread I have to ^C twice to exit
    a <- async $ liftIO $ withContext $ \ctx ->
        withSocket ctx Req $ \sock -> do
            setLinger (restrict (0 :: Int)) sock
            setupAuth cfg sock
            connect sock (configConnect cfg)
            send sock [] (cs $ Aeson.encode req)
            eitherDecode . cs <$> receive sock
    wait a

setupAuth :: (SocketType t)
          => Config
          -> Socket t
          -> IO ()
setupAuth cfg sock = do
    let clientKeyM    = configClientKey    cfg
        clientKeyPubM = configClientKeyPub cfg
        serverKeyPubM = configServerKeyPub cfg
    forM_ clientKeyM $ \clientKey -> do
        let serverKeyPub = fromMaybe
              (error "Server public key not provided")
              serverKeyPubM
            clientKeyPub = fromMaybe
              (error "Client public key not provided")
              clientKeyPubM
        setCurveServerKey TextFormat serverKeyPub sock
        setCurvePublicKey TextFormat clientKeyPub sock
        setCurveSecretKey TextFormat clientKey sock

formatStr :: String -> IO ()
formatStr str = forM_ (lines str) putStrLn

encodeTxJSON :: Tx -> Value
encodeTxJSON tx = object
    [ "txid"     .= (cs $ txHashToHex (txHash tx) :: Text)
    , "version"  .= txVersion tx
    , "inputs"   .= map encodeTxInJSON (txIn tx)
    , "outputs"  .= map encodeTxOutJSON (txOut tx)
    , "locktime" .= txLockTime tx
    ]

encodeTxInJSON :: TxIn -> Value
encodeTxInJSON (TxIn o s i) = object $
    [ "outpoint"   .= encodeOutPointJSON o
    , "sequence"   .= i
    , "raw-script" .= (cs $ encodeHex s :: Text)
    , "script"     .= encodeScriptJSON sp
    ] ++ decoded
  where
    sp = fromMaybe (Script []) $ decodeToMaybe s
    decoded = either (const []) f $ decodeInputBS s
    f inp = ["decoded-script" .= encodeScriptInputJSON inp]

encodeTxOutJSON :: TxOut -> Value
encodeTxOutJSON (TxOut v s) = object $
    [ "value"      .= v
    , "raw-script" .= (cs $ encodeHex s :: Text)
    , "script"     .= encodeScriptJSON sp
    ] ++ decoded
  where
    sp = fromMaybe (Script []) $ decodeToMaybe s
    decoded = either (const [])
                 (\out -> ["decoded-script" .= encodeScriptOutputJSON out])
                 (decodeOutputBS s)

encodeOutPointJSON :: OutPoint -> Value
encodeOutPointJSON (OutPoint h i) = object
    [ "txid" .= (cs $ txHashToHex h :: Text)
    , "pos"  .= i
    ]

encodeScriptJSON :: Script -> Value
encodeScriptJSON (Script ops) =
    toJSON $ map f ops
  where
    f (OP_PUSHDATA bs _) = String $ pack $ unwords
        ["OP_PUSHDATA", cs $ encodeHex bs]
    f x = String $ pack $ show x

encodeScriptInputJSON :: ScriptInput -> Value
encodeScriptInputJSON si = case si of
    RegularInput (SpendPK s) -> object
        [ "spendpubkey" .= object [ "sig" .= encodeSigJSON s ] ]
    RegularInput (SpendPKHash s p) -> object
        [ "spendpubkeyhash" .= object
            [ "sig"            .= encodeSigJSON s
            , "pubkey"         .= (cs $ encodeHex (encode p) :: Text)
            , "sender-address" .= (cs $ addrToBase58 (pubKeyAddr p) :: Text)
            ]
        ]
    RegularInput (SpendMulSig sigs) -> object
        [ "spendmulsig" .= object [ "sigs" .= map encodeSigJSON sigs ] ]
    ScriptHashInput s r -> object
        [ "spendscripthash" .= object
            [ "scriptinput" .= encodeScriptInputJSON (RegularInput s)
            , "redeem" .= encodeScriptOutputJSON r
            , "raw-redeem" .= (cs $ encodeHex (encodeOutputBS r) :: Text)
            , "sender-address" .= (cs $ addrToBase58 (scriptAddr r) :: Text)
            ]
        ]

encodeScriptOutputJSON :: ScriptOutput -> Value
encodeScriptOutputJSON so = case so of
    PayPK p -> object
        [ "pay2pubkey" .= object
          [ "pubkey" .= (cs $ encodeHex (encode p) :: Text) ]
        ]
    PayPKHash a -> object
        [ "pay2pubkeyhash" .= object
            [ "address-base64" .=
              (cs $ encodeHex (encode $ getAddrHash a) :: Text)
            , "address-base58" .= (cs $ addrToBase58 a :: Text)
            ]
        ]
    PayMulSig ks r -> object
        [ "pay2mulsig" .= object
            [ "required-keys" .= r
            , "pubkeys"       .= (map (cs . encodeHex . encode) ks :: [Text])
            ]
        ]
    PayScriptHash a -> object
        [ "pay2scripthash" .= object
            [ "address-base64" .= (cs $ encodeHex $ encode $ getAddrHash a :: Text)
            , "address-base58" .= (cs (addrToBase58 a) :: Text)
            ]
        ]
    DataCarrier bs -> object
        [ "op_return" .= object
            [ "data" .= (cs $ encodeHex bs :: Text)
            ]
        ]

encodeSigJSON :: TxSignature -> Value
encodeSigJSON ts@(TxSignature _ sh) = object
    [ "raw-sig" .= (cs $ encodeHex (encodeSig ts) :: Text)
    , "sighash" .= encodeSigHashJSON sh
    ]

encodeSigHashJSON :: SigHash -> Value
encodeSigHashJSON sh = case sh of
    SigAll acp -> object
        [ "type" .= String "SigAll"
        , "acp"  .= acp
        ]
    SigNone acp -> object
        [ "type" .= String "SigNone"
        , "acp"  .= acp
        ]
    SigSingle acp -> object
        [ "type" .= String "SigSingle"
        , "acp"  .= acp
        ]
    SigUnknown acp v -> object
        [ "type"  .= String "SigUnknown"
        , "acp"   .= acp
        , "value" .= v
        ]

{- Print utilities -}

printAccount :: JsonAccount -> String
printAccount JsonAccount{..} = unlines $
    [ "Account : " ++ unpack jsonAccountName
    , "Type    : " ++ showType
    , "Gap     : " ++ show jsonAccountGap
    ]
    ++
    [ "Deriv   : " ++ pathToStr d
    | d <- maybeToList jsonAccountDerivation
    ]
    ++
    [ "Mnemonic: " ++ cs ms
    | ms <- maybeToList jsonAccountMnemonic
    ]
    ++
    concat [ printKeys | not (null jsonAccountKeys) ]
  where
    printKeys =
        ("Keys    : " ++ cs (xPubExport (head jsonAccountKeys))) :
        map (("          " ++) . cs . xPubExport) (tail jsonAccountKeys)
    showType = case jsonAccountType of
        AccountRegular -> if isNothing jsonAccountMaster
                              then "Read-Only" else "Regular"
        AccountMultisig m n -> unwords
            [ if isNothing jsonAccountMaster
                 then "Read-Only Multisig" else "Multisig"
            , show m, "of", show n
            ]

printAddress :: JsonAddr -> String
printAddress JsonAddr{..} = unwords $
    [ show jsonAddrIndex, ":", cs (addrToBase58 jsonAddrAddress) ]
    ++
    [ "(" ++ unpack jsonAddrLabel ++ ")" | not (null $ unpack jsonAddrLabel) ]
    ++ concat
    [ [ "[Received: "    ++ show (balanceInfoInBalance  bal) ++ "]"
      , "[Coins: "       ++ show (balanceInfoCoins      bal) ++ "]"
      , "[Spent Coins: " ++ show (balanceInfoSpentCoins bal) ++ "]"
      ]
    | isJust jsonAddrBalance && balanceInfoCoins bal > 0
    ]
  where
    bal = fromMaybe (error "Could not get address balance") jsonAddrBalance

printPubKey :: JsonAddr -> String
printPubKey JsonAddr{..} = unwords $
    [ show jsonAddrIndex, ":", showPubKey jsonAddrKey ]
    ++
    [ "(" ++ unpack jsonAddrLabel ++ ")" | not (null $ unpack jsonAddrLabel) ]
  where
    showPubKey = maybe "<no pubkey available>" (jsonStr2Str . toJSON)
    jsonStr2Str (String t) = cs t
    jsonStr2Str _          = ""     -- It totally is a String though

printNotif :: Notif -> String
printNotif (NotifTx   tx) = printTx Nothing tx
printNotif (NotifBlock b) = printBlock b

printTx :: Maybe Address -> JsonTx -> String
printTx aM tx@JsonTx{..} = unlines $
    [ "Id         : " ++ cs (txHashToHex jsonTxHash) ]
    ++
    [ "Value      : " ++ printTxType jsonTxType ++ " " ++ show jsonTxValue ]
    ++
    [ "Confidence : " ++ printTxConfidence tx ]
    ++ concat
    [ printAddrInfos "Inputs     : " jsonTxInputs
    | not (null jsonTxInputs)
    ]
    ++ concat
    [ printAddrInfos "Outputs    : " jsonTxOutputs
    | not (null jsonTxOutputs)
    ]
    ++ concat
    [ printAddrInfos "Change     : " jsonTxChange
    | not (null jsonTxChange)
    ]
  where
    printAddrInfos header xs =
        (header ++ f (head xs)) :
        map (("             " ++) . f) (tail xs)
    f (AddressInfo addr valM local) = unwords $
        cs (addrToBase58 addr) :
        [ show v | v <- maybeToList valM ]
        ++
        [ "<-" | maybe local (== addr) aM ]

printTxConfidence :: JsonTx -> String
printTxConfidence JsonTx{..} = case jsonTxConfidence of
    TxBuilding -> "Building" ++ confirmations
    TxPending  -> "Pending" ++ confirmations
    TxDead     -> "Dead" ++ confirmations
    TxOffline  -> "Offline"
  where
    confirmations = case jsonTxConfirmations of
        Just conf -> " (Confirmations: " ++ show conf ++ ")"
        _         -> ""

printTxType :: TxType -> String
printTxType t = case t of
    TxIncoming -> "Incoming"
    TxOutgoing -> "Outgoing"
    TxSelf     -> "Self"

printBlock :: JsonBlock -> String
printBlock JsonBlock{..} = unlines
    [ "Block Hash      : " ++ cs (blockHashToHex jsonBlockHash)
    , "Block Height    : " ++ show jsonBlockHeight
    , "Previous block  : " ++ cs (blockHashToHex jsonBlockPrev)
    ]

printSyncBlock :: JsonSyncBlock -> String
printSyncBlock JsonSyncBlock{..} = unlines
    [ "Block Hash      : " ++ cs (blockHashToHex jsonSyncBlockHash)
    , "Block Height    : " ++ show jsonSyncBlockHeight
    , "Previous block  : " ++ cs (blockHashToHex jsonSyncBlockPrev)
    , "Transactions    : " ++ show (length jsonSyncBlockTxs)
    ]

printNodeStatus :: Bool -> NodeStatus -> [String]
printNodeStatus verbose NodeStatus{..} =
    [ "Network Height    : " ++ show nodeStatusNetworkHeight
    , "Best Header       : " ++ cs (blockHashToHex nodeStatusBestHeader)
    , "Best Header Height: " ++ show nodeStatusBestHeaderHeight
    , "Best Block        : " ++ cs (blockHashToHex nodeStatusBestBlock)
    , "Best Block Height : " ++ show nodeStatusBestBlockHeight
    , "Bloom Filter Size : " ++ show nodeStatusBloomSize
    ] ++
    [ "Header Peer       : " ++ show h
    | h <- maybeToList nodeStatusHeaderPeer, verbose
    ] ++
    [ "Merkle Peer       : " ++ show m
    | m <- maybeToList nodeStatusMerklePeer, verbose
    ] ++
    [ "Pending Headers   : " ++ show nodeStatusHaveHeaders | verbose ] ++
    [ "Pending Tickles   : " ++ show nodeStatusHaveTickles | verbose ] ++
    [ "Pending Txs       : " ++ show nodeStatusHaveTxs | verbose ] ++
    [ "Pending GetData   : " ++ show (map txHashToHex nodeStatusGetData)
    | verbose
    ] ++
    [ "Pending Rescan    : " ++ show r
    | r <- maybeToList nodeStatusRescan, verbose
    ] ++
    [ "Synced Mempool    : " ++ show nodeStatusMempool | verbose ] ++
    [ "HeaderSync Lock   : " ++ show nodeStatusSyncLock | verbose ] ++
    [ "Peers: " ] ++
    intercalate ["-"] (map (printPeerStatus verbose) nodeStatusPeers)

printPeerStatus :: Bool -> PeerStatus -> [String]
printPeerStatus verbose PeerStatus{..} =
    [ "  Peer Id  : " ++ show peerStatusPeerId
    , "  Peer Host: " ++ peerHostString peerStatusHost
    , "  Connected: " ++ if peerStatusConnected then "yes" else "no"
    , "  Height   : " ++ show peerStatusHeight
    ] ++
    [ "  Protocol : " ++ show p | p <- maybeToList peerStatusProtocol
    ] ++
    [ "  UserAgent: " ++ ua | ua <- maybeToList peerStatusUserAgent
    ] ++
    [ "  Avg Ping : " ++ p | p <- maybeToList peerStatusPing
    ] ++
    [ "  DoS Score: " ++ show d | d <- maybeToList peerStatusDoSScore
    ] ++
    [ "  Merkles  : " ++ show peerStatusHaveMerkles | verbose ] ++
    [ "  Messages : " ++ show peerStatusHaveMessage | verbose ] ++
    [ "  Nonces   : " ++ show peerStatusPingNonces | verbose ] ++
    [ "  Reconnect: " ++ show t
    | t <- maybeToList peerStatusReconnectTimer, verbose
    ] ++
    [ "  Logs     : " | verbose ] ++
    [ "    - " ++ msg | msg <- fromMaybe [] peerStatusLog, verbose]

printBlockInfo :: BlockInfo -> [String]
printBlockInfo BlockInfo{..} =
    [ "Block Height     : " ++ show blockInfoHeight
    , "Block Hash       : " ++ cs (blockHashToHex blockInfoHash)
    , "Block Timestamp  : " ++ formatUTCTime blockInfoTimestamp
    , "Previous Block   : " ++ cs (blockHashToHex blockInfoPrevBlock)
    , "Merkle Root      : " ++ cs blockInfoMerkleRoot
    , "Block Version    : " ++ "0x" ++ cs (encodeHex versionData)
    , "Block Difficulty : " ++ show (blockDiff blockInfoBits)
    , "Chain Work       : " ++ show blockInfoChainWork
    ]
  where
    blockDiff :: Word32 -> Double
    blockDiff target = getTarget (blockBits genesisHeader) / getTarget target
    getTarget   = fromIntegral . decodeCompact
    versionData = integerToBS (fromIntegral blockInfoVersion)
    formatUTCTime = Time.formatTime Time.defaultTimeLocale
        "%Y-%m-%d %H:%M:%S (UTC)"