1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
// You can disable this warning by using '--mlcompatibility' or '--nowarn:62
#nowarn "62" 

module Util =
    open System
    
    let iso8601 : int -> int -> int -> string =
        fun y m d -> (new DateTime(y,m,d)).ToString("o") + "Z"
    
    let byteToHex : byte -> string =
        fun b -> b.ToString("x2")
        
    let bytesToHex : byte array -> string =
        fun bytes -> bytes |> Array.fold (fun a x -> a + (byteToHex x)) ""
    
    let utf8ToBytes : string -> byte array =
        fun utf8 -> System.Text.Encoding.UTF8.GetBytes utf8
    
    let sha256' : byte array -> byte array =
        fun bytes ->
            use sha256 = System.Security.Cryptography.SHA256.Create()
            sha256.ComputeHash(buffer = bytes)
    
    (* mon@razerRamon:~$ echo -n 'foo' | sha256sum
       2c26b46b68ffc68ff99b453c1d30413413422d706483bfa0f98a5e886266e7ae  - *)
    let sha256 : string -> string =
        fun utf8 -> utf8 |> (utf8ToBytes >> sha256' >> bytesToHex)
    
    let ceilPow : uint64 -> uint64 =
        fun n ->
            let rec loop : (uint64 * int) -> uint64 = function
                | 0UL, acc -> 1 <<< acc |> uint64
                | m  , acc ->
                    let m' = m &&& 1UL
                    (m-m' >>> 1, acc+1) |> loop
            (n-1UL,0) |> loop

> 
module Util = begin
  val iso8601 : y:int -> m:int -> d:int -> string
  val byteToHex : b:byte -> string
  val bytesToHex : bytes:byte array -> string
  val utf8ToBytes : utf8:string -> byte array
  val sha256' : bytes:byte array -> byte array
  val sha256 : utf8:string -> string
  val ceilPow : n:uint64 -> uint64
end

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
module Json =
    (* http://json.org/ *)
    type value =
        | String  of string
        | Number  of float
        | Object  of (string * value) list
        | Array   of value list
        | Boolean of bool
        | Null
    with
        override json.ToString() =
            let rec print : value -> string = function
                | String  s  -> sprintf "\"%s\"" s
                | Number  n  -> sprintf "%f" n
                | Object  xs -> xs |> objectHelper
                | Array   xs -> xs |> arrayHelper
                | Boolean b  -> sprintf "%b" b
                | Null       -> "null"
            and objectHelper : (string * value) list -> string =
                function
                | [] -> "{ }"
                | xs ->
                    sprintf "{ %s }"
                      (xs
                       |> List.map (fun (name,value) ->
                            sprintf "%s: %s"
                                (String name |> print) (value |> print))
                       |> List.reduce (fun x y -> sprintf "%s, %s" x y))
            and arrayHelper : value list -> string = function
                | [] -> "[ ]"
                | xs ->
                    sprintf "[ %s ]"
                      (xs
                       |> List.map print
                       |> List.reduce (fun x y -> sprintf "%s, %s" x y))
            
            json |> print

> 
module Json = begin
  type value =
    | String of string
    | Number of float
    | Object of (string * value) list
    | Array of value list
    | Boolean of bool
    | Null
    with
      override ToString : unit -> string
    end
end

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
module Merkle =
    open Util
    
    type hash  = string
    type json  = string
    type count = uint64
    
    type tree =
        private
        | Leaf   of json option
        | Branch of (hash * count) * tree * tree
    with
        override tree.ToString() =
            let rec print : (int * tree) -> string = function
                | i, Leaf  None -> 
                    sprintf "\n%s NIL" (String.replicate i "\t")
                | i, Leaf (Some json) ->
                    sprintf "\n%s json: %s" (String.replicate i "\t") json
                | i, Branch ((h,n),left,right) ->
                    sprintf "\n%s * hash:  %s" (String.replicate i "\t") h +
                    sprintf "\n%s * count: %i" (String.replicate i "\t") n +
                    sprintf "\n%s   - left: %s"
                        (String.replicate i "\t") ((i+2,left)  |> print) +
                    sprintf "\n%s   - right: %s"
                        (String.replicate i "\t") ((i+2,right) |> print)
            (0,tree) |> print
    
    module Tree =
        let init   : json -> tree =
            fun msg ->
                let h = msg |> Util.sha256
                Branch((h, 1UL), msg |> Some |> Leaf, Leaf None)
        let insert : json -> tree -> tree =
            fun msg tree ->
                let helper : tree -> hash option = function
                    | Leaf  None        -> None
                    | Leaf (Some msg)   -> msg |> Util.sha256 |> Some
                    | Branch((h,_),_,_) -> h   |> Some
                
                let rec loop : tree -> tree  = function
                    | Leaf  None         -> msg |> Some |> Leaf
                    | Leaf (Some x) as l ->
                        let h1 = x       |> Util.sha256
                        let h2 = msg     |> Util.sha256
                        let h  = h1 + h2 |> Util.sha256
                        
                        Branch((h,2UL), l, msg |> Some |> Leaf)
                        
                    | Branch((h,n),l,r) as b ->
                        match n > 1UL && n = (n |> ceilPow) with
                            | true  ->
                                let h' = h + (msg |> Util.sha256) |> Util.sha256
                                Branch((h',n+1UL), b, msg |> Some |> Leaf)
                            | false ->
                                let rt = r  |> loop
                        
                                let lh = l  |> helper
                                let rh = rt |> helper
                        
                                let h' = (lh,rh) |> function
                                    | None   , None    -> h
                                    | Some v , None
                                    | None   , Some v  -> v
                                    | Some h1, Some h2 -> h1 + h2 |> Util.sha256
                                
                                Branch((h',n+1UL), l, rt)
                
                tree |> loop

> 
module Merkle = begin
  type hash = string
  type json = string
  type count = uint64
  type tree =
    private | Leaf of json option
            | Branch of (hash * count) * tree * tree
    with
      override ToString : unit -> string
    end
  module Tree = begin
    val init : msg:json -> tree
    val insert : msg:json -> tree:tree -> tree
  end
end

                              +------------- 6 -------------+ 
                              |                             |
                    +-------- 4 --------+         +-------- 2 --------+
                    |                   |         |                   |
               +--- 2 ---+         +--- 2 ---+   'e'                 'f'
               |         |         |         |
              'a'       'b'       'c'       'd'

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
let a,b,c,d,e =
    Json.Object[
        "name", Json.String "Bridge Cafe"
        "rating", Json.Number 4.
        "date", Util.iso8601 2014 02 20 |> Json.String
        ]
    , Json.Object[
        "name", Json.String "Prima Doner"
        "rating", Json.Number 2.
        "date", Util.iso8601 2014 04 15 |> Json.String
        ]
    , Json.Object[
        "name", Json.String "The Bull"
        "rating", Json.Number 3.
        "date", Util.iso8601 2014 06 05 |> Json.String
        ]
    , Json.Object[
        "name", Json.String "The Tall Ship"
        "rating", Json.Number 5.
        "date", Util.iso8601 2014 10 30 |> Json.String
        ]
    , Json.Object[
        "name", Json.String "Roy's Rolls"
        "rating", Json.Number 3.
        "date", Util.iso8601 2015 01 10 |> Json.String
        ]

let f =
    Json.Object[
        "name", Json.String "Prima Doner"
        "rating", Json.Number 4.
        "date", Util.iso8601 2015 02 12 |> Json.String
        ]

let mtree =
    ( Merkle.Tree.init (a |> string), [b;c;d;e] )
    ||> List.fold (fun a x -> a |> Merkle.Tree.insert (x |> string))

let mtree' =
    mtree
    |> Merkle.Tree.insert (f |> string)

> 
val e : Json.value =
  Object
    [("name", String "Roy's Rolls"); ("rating", Number 3.0);
     ("date", String "2015-01-10T00:00:00.0000000Z")]
val d : Json.value =
  Object
    [("name", String "The Tall Ship"); ("rating", Number 5.0);
     ("date", String "2014-10-30T00:00:00.0000000Z")]
val c : Json.value =
  Object
    [("name", String "The Bull"); ("rating", Number 3.0);
     ("date", String "2014-06-05T00:00:00.0000000Z")]
val b : Json.value =
  Object
    [("name", String "Prima Doner"); ("rating", Number 2.0);
     ("date", String "2014-04-15T00:00:00.0000000Z")]
val a : Json.value =
  Object
    [("name", String "Bridge Cafe"); ("rating", Number 4.0);
     ("date", String "2014-02-20T00:00:00.0000000Z")]
> 
val f : Json.value =
  Object
    [("name", String "Prima Doner"); ("rating", Number 4.0);
     ("date", String "2015-02-12T00:00:00.0000000Z")]
> 
val mtree : Merkle.tree =
  
 * hash:  dc999d3a9b252bebd171775e24668293e0ec1691f8d60331e85eed24ec6ca392
 * count: 5
   - left: 
     * hash:  1ae6f3cb6407d42c9be994971b46de89b6b5facb53e7d1a01c04a92f74264483
     * count: 4
       - left: 
         * hash:  28ee16e42affeecfc1b997487e4294f5067ced3bef2ca7c6324dcf86b7961954
         * count: 2
           - left: 
             json: { "name": "Bridge Cafe", "rating": 4.000000, "date": "2014-02-20T00:00:00.0000000Z" }
           - right: 
             json: { "name": "Prima Doner", "rating": 2.000000, "date": "2014-04-15T00:00:00.0000000Z" }
       - right: 
         * hash:  255a0ad108003e34e449159a63306a292357fd0d40f6449f148467ec2532ed0c
         * count: 2
           - left: 
             json: { "name": "The Bull", "rating": 3.000000, "date": "2014-06-05T00:00:00.0000000Z" }
           - right: 
             json: { "name": "The Tall Ship", "rating": 5.000000, "date": "2014-10-30T00:00:00.0000000Z" }
   - right: 
     json: { "name": "Roy's Rolls", "rating": 3.000000, "date": "2015-01-10T00:00:00.0000000Z" }
> 
val mtree' : Merkle.tree =
  
 * hash:  fb8b96a10235da8cc444a0ddf41bdcfef035f743e84d69b15b146c1af48c6848
 * count: 6
   - left: 
     * hash:  1ae6f3cb6407d42c9be994971b46de89b6b5facb53e7d1a01c04a92f74264483
     * count: 4
       - left: 
         * hash:  28ee16e42affeecfc1b997487e4294f5067ced3bef2ca7c6324dcf86b7961954
         * count: 2
           - left: 
             json: { "name": "Bridge Cafe", "rating": 4.000000, "date": "2014-02-20T00:00:00.0000000Z" }
           - right: 
             json: { "name": "Prima Doner", "rating": 2.000000, "date": "2014-04-15T00:00:00.0000000Z" }
       - right: 
         * hash:  255a0ad108003e34e449159a63306a292357fd0d40f6449f148467ec2532ed0c
         * count: 2
           - left: 
             json: { "name": "The Bull", "rating": 3.000000, "date": "2014-06-05T00:00:00.0000000Z" }
           - right: 
             json: { "name": "The Tall Ship", "rating": 5.000000, "date": "2014-10-30T00:00:00.0000000Z" }
   - right: 
     * hash:  dae71b4d5d4f57af9abd8cbf2a621e6d1eb110bef0ed34d0a0356e5dc766eff7
     * count: 2
       - left: 
         json: { "name": "Roy's Rolls", "rating": 3.000000, "date": "2015-01-10T00:00:00.0000000Z" }
       - right: 
         json: { "name": "Prima Doner", "rating": 4.000000, "date": "2015-02-12T00:00:00.0000000Z" }

mon@razerRamon:~$ echo -n '{ "name": "Bridge Cafe", "rating": 4.000000, "date":
"2014-02-20T00:00:00.0000000Z" }' | sha256sum
b07cd889093179c2923fa8bfc480bfa153fe74c0b7009c46b33045d1e2d5632b -

mon@razerRamon:~$ echo -n '{ "name": "Prima Doner", "rating": 2.000000, "date":
"2014-04-15T00:00:00.0000000Z" }' | sha256sum
32128e3d309816c07db4ff4c995aa692c3390b48d23f6ac7429538b57dc2c372 -

mon@razerRamon:~$ echo -n
'b07cd889093179c2923fa8bfc480bfa153fe74c0b7009c46b33045d1e2d5632b
32128e3d309816c07db4ff4c995aa692c3390b48d23f6ac7429538b57dc2c372' | sha256sum
28ee16e42affeecfc1b997487e4294f5067ced3bef2ca7c6324dcf86b7961954 -

1
2
3
4
5
6
7
8
9
10
let unitTest =
    let a' =
        a |> string
          |> Util.sha256
    let b' =
        b |> string
          |> Util.sha256

    "28ee16e42affeecfc1b997487e4294f5067ced3bef2ca7c6324dcf86b7961954"
        = ((a' + b') |> Util.sha256)

> 
val unitTest : bool = true