Skip to content

Instantly share code, notes, and snippets.

@HirotoShioi
Last active April 23, 2018 12:30
Show Gist options
  • Save HirotoShioi/e759aa5b89cd53959a7387d039a40179 to your computer and use it in GitHub Desktop.
Save HirotoShioi/e759aa5b89cd53959a7387d039a40179 to your computer and use it in GitHub Desktop.
モナド変換子 (その3: 課題の解答) ref: https://qiita.com/HirotoShioi/items/6faaf8babb23bb2f3485
newtype App a = App (StateT UTXOs (ExcepT String Identity) a)
deriving (Functor,
, Applicative,
, Monad,
, MonadState UTXOs
, MonadError String)
runApp :: App () -> UTXOs -> Either String UTXOs
runApp (App a) utxo = runIdentity (runExceptT (execStateT a utxo))
processInputs :: Id -> [Input] -> App Int
processInputs = undefined
processOutputs :: Id -> [Output] -> App Int
processOUtputs = undefined
processTransaction :: Transaction -> App ()
processTransaction Transaction{..} = do
inputValue <- processInputs tId tInput --1
outputValue <- processOutputs tId tOutput --2
when (inputValue < outputValue) $
throwError $ "Infuccient amount, tId: " <> show tId
<> "\n Input is less than output by: "
<> show (outputValue - inputValue) --3
processTransactions :: [Transaction] -> App ()
processTransactions = mapM_ processTransaction
processInputs :: Id -> [Input] -> App Int
processInputs tid inputs = sum <$> mapM (processInput tid) inputs
processInput :: Id -> Input -> App Int
processInput tid input = do
utxos <- get
case M.lookup input utxos of -- 検証処理
Nothing -> throwError $ "Invalid input at: " <> show tid
Just Output{..} -> do
modify $ M.delete input -- UTXOの更新
return oValue -- 未使用アウトプットの金額を返す
processOutputs :: Id -> [Output] -> App Int
processOutputs tid outputs = sum <$> zipWithM (processOutput tid) [0..] outputs
processOutput :: Id -> Index -> Output -> App Int
processOutput tid i output@Output{..} = do
modify $ M.insert (Input tid i) output -- UTXOの更新
return oValue -- アウトプットの金額を返す
prettyPrint :: Either String UTXOs -> IO ()
prettyPrint (Left e) = putStrLn $ "Warning: " <> e
prettyPrint (Right utxo) = putStrLn $ M.foldrWithKey
(\k v acc -> show k <> " " <> show v <> "\n" <> acc ) "" utxo
λ: prettyPrint $ runApp (processTransactions [transaction1, transaction2]) utxos
Input {iPrevious = 1, iIndex = 0} Output {oValue = 2000, oAddress = "Lars"}
Input {iPrevious = 2, iIndex = 0} Output {oValue = 5000, oAddress = "Charles"}
Input {iPrevious = 2, iIndex = 1} Output {oValue = 5000, oAddress = "Jeremy"}
Input {iPrevious = 2, iIndex = 2} Output {oValue = 1000, oAddress = "Hiroto"}
{-# LANGUAGE RecordWildCards #-}
module Transaction (
processTransactions
) where
import Control.Monad.Except
import Control.Monad.State
import qualified Data.Map as M
import App
import Types
import Data.Semigroup ((<>))
-- Process transaction
processTransaction :: Transaction -> App ()
processTransaction Transaction{..} = do
inputValue <- processInputs tId tInput
outputValue <- processOutputs tId tOutput
when (inputValue < outputValue) $
throwError $ "Infuccient amount, tId: " <> show tId
<> "\n Input is less than output by: " <> show (outputValue - inputValue)
-- Process list of tranactions
processTransactions :: [Transaction] -> App ()
processTransactions = mapM_ processTransaction
-- Process list of inputs
processInputs :: Id -> [Input] -> App Int
processInputs tid inputs = sum <$> mapM (processInput tid) inputs
-- Process inputs i.e. check it is valid, update utxos, and return unspent value
processInput :: Id -> Input -> App Int
processInput tid input = do
utxos <- get
case M.lookup input utxos of -- Check if the input is valid
Nothing -> throwError $ "Invalid input at: " <> show tid
Just Output{..} -> do
modify $ M.delete input -- Delete the input from utxos
return oValue -- Return output value
-- Process list of outputs
processOutputs :: Id -> [Output] -> App Int
processOutputs tid outputs = sum <$> zipWithM (processOutput tid) [0..] outputs
-- Process outputs i.e. Update utxos accordingly then return output value
processOutput :: Id -> Index -> Output -> App Int
processOutput tid i output@Output{..} = do
modify $ M.insert (Input tid i) output -- Update utxos accordingly
return oValue -- Return a value
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment