tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

DigestByte.hs (3494B)

      1 {-# LANGUAGE ScopedTypeVariables #-}
      2 module Main where
      3 import Runtime
      4 import Wire
      5 import qualified Data.ByteString as B
      6 import qualified Data.Text as T
      7 import qualified Data.Vector as V
      8 import qualified Data.Map.Strict as M
      9 import Control.Exception
     10 import Control.Monad
     11 import System.Environment
     12 -- Independent bounded recognizer and historical arbitrary-tree arithmetic.
     13 -- The byte guard is not allowed to silently redefine malformed naturals.
     14 canonical :: T -> Int -> Bool
     15 canonical Leaf _=True
     16 canonical (Stem _) _=False
     17 canonical (Fork bit rest) depth
     18  | depth==0=False
     19  | rest==Leaf=bit==Stem Leaf
     20  | otherwise=(bit==Leaf || bit==Stem Leaf) && canonical rest (depth-1)
     21 predRef :: T -> T
     22 predRef Leaf=Leaf
     23 predRef x@(Stem _)=x
     24 predRef(Fork bit rest)=if bit/=Leaf then if rest/=Leaf then Fork Leaf rest else Leaf else Fork(Stem Leaf)(predRef rest)
     25 lte :: T -> Integer -> Bool
     26 lte Leaf _=True
     27 lte _ 0=False
     28 lte value n=lte(predRef value)(n-1)
     29 lt :: T -> Integer -> Bool
     30 lt value n=lte value n && value/=ofNumber n
     31 hex :: T -> Bool
     32 hex value=(not(lt value 48) && lte value 57)||(not(lt value 97)&&lte value 102)
     33 small :: Int -> [T]
     34 small 0=[Leaf]
     35 small n=Leaf:[Stem x|x<-small(n-1)]++[Fork x y|x<-small(n-1),y<-small(n-1)]
     36 truth True=Stem Leaf
     37 truth False=Leaf
     38 observe x=(evaluate x >>= \v->evaluate(if v==Leaf then "false" else if v==Stem Leaf then "true" else "bad")) `catch` \(_::ErrorCall)->pure "demanded-poison"
     39 main=do
     40  [file]<-getArgs
     41  bundle<-B.readFile file >>= either fail pure.decodeBundle
     42  either fail pure(verifyBundle bundle)
     43  let nodes=reconstructBundleTerms(bundleNodes bundle);workers=M.fromList[(T.unpack(exportName e),nodes V.!fromIntegral(exportRoot e))|e<-manifestExports(bundleManifest bundle)]
     44      call name value=apply(workers M.!name)value
     45  do
     46   let values=map ofNumber[0..1024]++small 3++[foldr Fork x(replicate n b)|n<-[0..10],b<-[Leaf,Stem Leaf,Fork Leaf Leaf,Stem(Stem Leaf)],x<-small 2]
     47   do
     48    forM_ values $ \v->do
     49     unless(call "sourceObjectCanonicalByte" v==truth(canonical v 8))(fail "canonical mismatch")
     50     unless(call "sourceObjectHashByte?" v==truth(hex v))(fail "legacy hash-byte mismatch")
     51     unless(call "sourceObjectHashValid" (ofList(replicate 63(ofNumber 48)++[v]))==truth(hex v))
     52       (fail "complete digest mismatch")
     53    forM_ [0..255] $ \n->unless(call "sourceObjectHashByte?" (ofNumber n)==truth(n>=48 && n<=57 || n>=97 && n<=102))(fail "ASCII mismatch")
     54    let bad=error "poison";poisons=[Stem bad,Fork bad Leaf,Fork(Stem bad)Leaf,Fork Leaf(Stem bad),Fork(Fork Leaf Leaf)bad,foldr Fork (Fork bad bad)(replicate 8 Leaf)]
     55    forM_ poisons $ \v->do
     56     got<-observe(call "sourceObjectCanonicalByte" v);wanted<-observe(truth(canonical v 8));unless(got==wanted)(fail "canonical demand mismatch")
     57    forM_ [0,1,63,64,65] $ \n->do
     58     let good=ofList(replicate n(ofNumber 48));bad=ofList(replicate n(ofNumber 71))
     59     unless(call "sourceObjectHashValid" good==truth(n==64))(fail "hash length mismatch")
     60     unless(call "sourceObjectHashValid" bad==Leaf)(fail "invalid hash accepted")
     61    forM_ [0,1,63,65] $ \n->do
     62     got<-observe(call "sourceObjectHashValid" (ofList(replicate n(error "ignored byte"))));unless(got=="false")(fail "length rejection forced bytes")
     63    rejected<-observe(call "sourceObjectHashValid" (ofList(ofNumber 71:replicate 63(error "unused byte"))))
     64    unless(rejected=="false")(fail "invalid byte forced suffix payloads")
     65   print(length values,"byte and complete-digest cases; ASCII, length and poison controls passed")