blockchain/bc.icl

   1 module bc
   2
   3 import Crypto.Hash.SHA1
   4 import Data.Func
   5 import Data.Integer, Data.Integer.GenJSON
   6 import Data.List
   7 import Math.Random
   8 import StdEnv
   9 import System.Process
  10 import System.Time
  11 import Text
  12 import iTasks
  13 import iTasks.Extensions.DateTime
  14
  15 NONCESIZE :== 2
  16
  17 :: HashFun       :== String -> String
  18 :: ValidationFun :== String -> Bool
  19 :: Block           = {nonce :: !Int, prevHash :: !String, data :: !String, hash :: !String}
  20 :: BlockChain    :== [Block]
  21 :: Settings        = {difficulty :: Int, workers :: [Int]}
  22
  23 derive class iTask Settings, Block
  24
  25 Start w = doTasks main w
  26
  27 mine :: !HashFun !ValidationFun !String !String !Int -> Block
  28 mine hfun pred prev data seed
  29 # (nonce, hash) = hd $ filter (pred o snd) $ map hash $ genRandInt seed
  30 = {nonce=nonce,prevHash=prev,data=data,hash=hash}
  31 where
  32         hash i = (i, hfun $ data +++ prev +++ toString i)
  33
  34 dataShare :: SimpleSDSLens [String]
  35 dataShare = sharedStore "data" []
  36
  37 chainShare :: SimpleSDSLens [Block]
  38 chainShare = sharedStore "chain" []
  39
  40 messageShare :: SimpleSDSLens [String]
  41 messageShare = sharedStore "messages" []
  42
  43 settingsShare :: SimpleSDSLens Settings
  44 settingsShare = sharedStore "settings" {difficulty=4, workers=[8000,8001,8002]}
  45
  46 main = (parallel
  47                         [(Embedded, \_->chainViewer <<@ Title "Chain")
  48                         ,(Embedded, \_->minerTask <<@ Title "Pool" @! ())
  49                         ,(Embedded, \_->updateSharedInformation [] settingsShare <<@ Title "Settings" @! ())
  50                         ] [] <<@ ArrangeWithTabs False)
  51         >>* [OnAction (Action "Shutdown") $ always $ shutDown 0]
  52 where
  53         chainViewer :: Task ()
  54         chainViewer
  55                 =   (addData <<@ heightAttr (ExactSize 80))
  56                 -|| (viewSharedInformation [] chainShare <<@ Label "Chain")
  57         where
  58                 addData = (enterInformation [] <<@ Label "Add data")
  59                         >>? \x->upd (\q->q ++ [x]) dataShare
  60                         >-| addData
  61
  62         minerTask :: Task ()
  63         minerTask
  64                 = get applicationOptions
  65                 >>- \opts->wait (not o isEmpty) dataShare
  66                 >>- \[data:_]->upd (\[_:qs]->qs) dataShare
  67                 >-| get settingsShare
  68                 >>- \sett->get chainShare @ maybe "" (\b->b.hash) o listToMaybe
  69                 >>- \prevhash->anyTask
  70                         [  mineTask i opts.appPath port sett.difficulty data prevhash
  71                         \\ port <- sett.workers & i <- [0..]]
  72                 >>- \block->upd (\chain->[block:chain]) chainShare
  73                 >-| minerTask
  74         where
  75                 mineTask :: Int String Int Int String String -> Task Block
  76                 mineTask num appPath port difficulty data prevHash =
  77                         Title ("Worker " +++ toString num) @>> ApplyLayout (toPanel False) @>>
  78                                 withShared [] \stdin->
  79                                 withShared ([], []) \stdout->
  80                                         workerproc stdin stdout ||- workerTask (mapRead fst stdout)
  81                 where
  82                         workerproc = externalProcess {tv_sec=0,tv_nsec=100000000} appPath ["--distributed", toString port, "--distributedChild"] Nothing 9 (Just defaultPtyOptions)
  83                         workerTask stdout
  84                                 =   wait (any (startsWith "SDS server listening on ") o split "\n" o concat) stdout
  85                                 >-| asyncTask "localhost" port
  86                                         (get randomInt >>- return o mine sha1 (startsWith (createArray difficulty '0')) prevHash data)