hivex/tools/visualizer.ml

   1 (* Windows Registry reverse-engineering tool.
   2  * Copyright (C) 2010 Red Hat Inc.
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation; either version 2 of the License, or
   7  * (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License along
  15  * with this program; if not, write to the Free Software Foundation, Inc.,
  16  * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  17  *
  18  * For existing information on the registry format, please refer
  19  * to the following documents.  Note they are both incomplete
  20  * and inaccurate in some respects.
  21  *
  22  * http://www.sentinelchicken.com/data/TheWindowsNTRegistryFileFormat.pdf
  23  * http://pogostick.net/~pnh/ntpasswd/WinReg.txt
  24  *)
  25
  26 open Bitstring
  27 open ExtString
  28 open Printf
  29 open Visualizer_utils
  30 open Visualizer_NT_time
  31
  32 let () =
  33   if Array.length Sys.argv <> 2 then (
  34     eprintf "Error: missing argument.
  35 Usage: %s hivefile > out
  36 where
  37   'hivefile' is the input hive file from a Windows machine
  38   'out' is an output file where we will write all the keys,
  39     values etc for extended debugging purposes.
  40 Errors, inconsistencies and unexpected fields in the hive file
  41 are written to stderr.
  42 " Sys.executable_name;
  43     exit 1
  44   )
  45
  46 let filename = Sys.argv.(1)
  47 let basename = Filename.basename filename
  48
  49 (* Load the file. *)
  50 let bits = bitstring_of_file filename
  51
  52 (* Split into header + data at the 4KB boundary. *)
  53 let header, data = takebits (4096 * 8) bits, dropbits (4096 * 8) bits
  54
  55 (* Define a persistent pattern which matches the header fields.  By
  56  * using persistent patterns, we can reuse them later in the
  57  * program.
  58  *)
  59 let bitmatch header_fields =
  60   { "regf" : 4*8 : string;
  61     seq1 : 4*8 : littleendian;
  62     seq2 : 4*8 : littleendian;
  63     last_modified : 64
  64       : littleendian, bind (nt_to_time_t last_modified);
  65     major : 4*8 : littleendian;
  66     minor : 4*8 : littleendian;
  67
  68     (* "Type".  Contains 0. *)
  69     unknown1 : 4*8 : littleendian;
  70
  71     (* "Format".  Contains 1. *)
  72     unknown2 : 4*8 : littleendian;
  73
  74     root_key : 4*8
  75       : littleendian, bind (get_offset root_key);
  76     end_pages : 4*8
  77       : littleendian, bind (get_offset end_pages);
  78
  79     (* "Cluster".  Contains 1. *)
  80     unknown3 : 4*8 : littleendian;
  81
  82     filename : 64*8 : string;
  83
  84     (* All three GUIDs here confirmed in Windows 7 registries.  In
  85      * Windows <= 2003 these GUID fields seem to contain junk.
  86      *
  87      * If you write zeroes to the GUID fields, load and unload in Win7
  88      * REGEDIT, then Windows 7 writes some random GUIDs.
  89      *
  90      * Also (on Win7) unknownguid1 == unknownguid2.  unknownguid3 is
  91      * different.
  92      *)
  93     unknownguid1 : 16*8 : bitstring;
  94     unknownguid2 : 16*8 : bitstring;
  95
  96     (* Wrote zero to unknown4, loaded and unloaded it in Win7 REGEDIT,
  97      * and it still contained zero.  In existing registries it seems to
  98      * contain random junk.
  99      *)
 100     unknown4 : 4*8 : littleendian;
 101     unknownguid3 : 16*8 : bitstring;
 102
 103     (* If you write zero to unknown5, load and unload it in REGEDIT,
 104      * Windows 7 puts the string "rmtm" here.  Existing registries also
 105      * seen containing this string.  However on older Windows it can
 106      * be all zeroes.
 107      *)
 108     unknown5 : 4*8 : string;
 109
 110     (* This seems to contain junk from other parts of the registry.  I
 111      * wrote zeroes here, loaded and unloaded it in Win7 REGEDIT, and
 112      * it still contained zeroes.
 113      *)
 114     unknown6 : 340*8 : bitstring;
 115     csum : 4*8
 116       : littleendian, save_offset_to (crc_offset),
 117     check (assert (crc_offset = 0x1fc * 8); true);
 118     unknown7 : (0x1000-0x200)*8 : bitstring }
 119
 120 let fprintf_header chan bits =
 121   bitmatch bits with
 122   | { :header_fields } ->
 123       fprintf chan
 124         "HD %6ld %6ld %s %ld.%ld %08lx %08lx %s %s %08lx %s %s %s %08lx %s %s %s %08lx %s\n"
 125         seq1 seq2 (print_time last_modified) major minor
 126         unknown1 unknown2
 127         (print_offset root_key) (print_offset end_pages)
 128         unknown3 (print_utf16 filename)
 129         (print_guid unknownguid1) (print_guid unknownguid2)
 130         unknown4 (print_guid unknownguid3) unknown5
 131         (print_bitstring unknown6)
 132         csum (print_bitstring unknown7)
 133
 134 (* Parse the header and check it. *)
 135 let root_key, end_pages =
 136   bitmatch header with
 137   |  { :header_fields } ->
 138        fprintf_header stdout header;
 139
 140        if major <> 1_l then
 141          eprintf "HD hive file major <> 1 (major.minor = %ld.%ld)\n"
 142            major minor;
 143        if seq1 <> seq2 then
 144          eprintf "HD hive file sequence numbers should match (%ld <> %ld)\n"
 145            seq1 seq2;
 146        if unknown1 <> 0_l then
 147          eprintf "HD unknown1 field <> 0 (%08lx)\n" unknown1;
 148        if unknown2 <> 1_l then
 149          eprintf "HD unknown2 field <> 1 (%08lx)\n" unknown2;
 150        if unknown3 <> 1_l then
 151          eprintf "HD unknown3 field <> 1 (%08lx)\n" unknown3;
 152        if not (equals unknownguid1 unknownguid2) then
 153          eprintf "HD unknownguid1 <> unknownguid2 (%s, %s)\n"
 154            (print_guid unknownguid1) (print_guid unknownguid2);
 155        (* We think this is junk.
 156        if unknown4 <> 0_l then
 157          eprintf "HD unknown4 field <> 0 (%08lx)\n" unknown4;
 158        *)
 159        if unknown5 <> "rmtm" && unknown5 <> "\000\000\000\000" then
 160          eprintf "HD unknown5 field <> \"rmtm\" & <> zeroes (%s)\n" unknown5;
 161        (* We think this is junk.
 162        if not (is_zero_bitstring unknown6) then
 163          eprintf "HD unknown6 area is not zero (%s)\n"
 164            (print_bitstring unknown6);
 165        *)
 166        if not (is_zero_bitstring unknown7) then
 167          eprintf "HD unknown7 area is not zero (%s)\n"
 168            (print_bitstring unknown7);
 169
 170        root_key, end_pages
 171   | {_} ->
 172       failwithf "%s: this doesn't look like a registry hive file\n" basename
 173
 174 (* Define persistent patterns to match page and block fields. *)
 175 let bitmatch page_fields =
 176   { "hbin" : 4*8 : string;
 177     page_offset : 4*8
 178       : littleendian, bind (get_offset page_offset);
 179     page_size : 4*8
 180       : littleendian, check (Int32.rem page_size 4096_l = 0_l),
 181         bind (Int32.to_int page_size);
 182
 183     (* In the first hbin in the file these fields contain something.
 184      * In subsequent hbins these fields are all zero.
 185      *
 186      * From existing hives (first hbin only):
 187      *
 188      * unknown1     unknown2                               unknown5
 189      * 00 00 00 00  00 00 00 00  9C 77 3B 02  6A 7D CA 01  00 00 00 00
 190      * 00 00 00 00  00 00 00 00  50 3A 15 07  B5 9B CA 01  00 00 00 00
 191      * 00 00 00 00  00 00 00 00  57 86 90 D4  9A 58 CA 01  00 00 00 00
 192      * 00 00 00 00  00 00 00 00  52 3F 90 9D  CF 7C CA 01  00 00 00 00
 193      * 00 00 00 00  00 00 00 00  E8 86 C1 17  BD 06 CA 01  00 00 00 00
 194      * 00 00 00 00  00 00 00 00  4A 77 CE 7A  CF 7C CA 01  00 00 00 00
 195      * 00 00 00 00  00 00 00 00  E4 EA 23 FF  69 7D CA 01  00 00 00 00
 196      * 00 00 00 00  00 00 00 00  50 13 BA 8D  A2 9A CA 01  00 00 00 00
 197      * 00 00 00 00  00 00 00 00  0E 07 93 13  BD 06 CA 01  00 00 00 00
 198      * 00 00 00 00  00 00 00 00  9D 55 D0 B3  99 58 CA 01  00 00 00 00
 199      * 00 00 00 00  00 00 00 00  46 AC FF 8B  CF 7C CA 01  00 00 00 00
 200      * 00 00 00 00  00 00 00 00  80 29 2D 02  6A 7D CA 01  00 00 00 00
 201      * 00 00 00 00  00 00 00 00  90 8D 36 07  B5 9B CA 01  00 00 00 00
 202      * 00 00 00 00  00 00 00 00  5C 9B 8B B8  6A 06 CA 01  00 00 00 00
 203      * 00 00 00 00  00 00 00 00  85 9F BB 99  9A 58 CA 01  00 00 00 00
 204      * 00 00 00 00  00 00 00 00  BE 3D 21 02  6A 7D CA 01  00 00 00 00
 205      * 00 00 00 00  00 00 00 00  70 53 09 07  B5 9B CA 01  00 00 00 00
 206      * 00 00 00 00  00 00 00 00  5B 62 42 B6  9A 58 CA 01  00 00 00 00
 207      * 01 00 00 00  00 00 00 00  B2 46 9B 9E  CF 7C CA 01  00 00 00 00
 208      * 01 00 00 00  00 00 00 00  CA 88 EE 1A  BD 06 CA 01  00 00 00 00
 209      *
 210      * From the above we worked out that fields 3 and 4 are an NT
 211      * timestamp, which seems to be "last modified" (when REGEDIT
 212      * unloads a hive it updates this timestamp even if nothing
 213      * has been changed).
 214      *)
 215     unknown1 : 4*8 : littleendian;  (* usually zero, occasionally 1 *)
 216     unknown2 : 4*8 : littleendian;  (* always zero? *)
 217     last_modified : 64
 218       : littleendian,
 219         bind (if page_offset = 0 then nt_to_time_t last_modified
 220               else (
 221                 assert (last_modified = 0_L);
 222                 0.
 223               )
 224              );
 225     (* The "B.D." document said this field contains the page size, but
 226      * this is not true.  This misinformation has been copied to the
 227      * sentinelchicken documentation too.
 228      *)
 229     unknown5 : 4*8 : littleendian;  (* always zero? *)
 230
 231     (* Now the blocks in this page follow. *)
 232     blocks : (page_size - 32) * 8 : bitstring;
 233
 234     rest : -1 : bitstring }
 235
 236 let fprintf_page chan bits =
 237   bitmatch bits with
 238   | { :page_fields } ->
 239       fprintf chan "HB %s %08x %08lx %08lx %s %08lx\n"
 240         (print_offset page_offset)
 241         page_size unknown1 unknown2
 242         (if page_offset = 0 then print_time last_modified
 243          else string_of_float last_modified) unknown5
 244
 245 let bitmatch block_fields =
 246   { seg_len : 4*8
 247       : littleendian, bind (Int32.to_int seg_len);
 248     block_data : (abs seg_len - 4) * 8 : bitstring;
 249     rest : -1 : bitstring }
 250
 251 let fprintf_block chan block_offset bits =
 252   bitmatch bits with
 253   | { :block_fields } ->
 254       fprintf chan "BL %s %s %d\n"
 255         (print_offset block_offset)
 256         (if seg_len < 0 then "used" else "free")
 257         (if seg_len < 0 then -seg_len else seg_len)
 258
 259 (* Iterate over the pages and blocks.  In the process we will examine
 260  * each page (hbin) header.  Also we will build block_list which is a
 261  * list of (block offset, length, used flag, data).
 262  *)
 263 let block_list = ref []
 264 let () =
 265   let rec loop_over_pages data data_offset =
 266     if data_offset < end_pages then (
 267       bitmatch data with
 268       | { rest : -1 : bitstring } when bitstring_length rest = 0 -> ()
 269
 270       | { :page_fields } ->
 271           fprintf_page stdout data;
 272
 273           assert (page_offset = data_offset);
 274
 275           if data_offset = 0 then (     (* first hbin only *)
 276             if unknown1 <> 0_l then
 277               eprintf "HB %s unknown1 field <> 0 (%08lx)\n"
 278                 (print_offset page_offset) unknown1;
 279             if unknown2 <> 0_l then
 280               eprintf "HB %s unknown2 field <> 0 (%08lx)\n"
 281                 (print_offset page_offset) unknown2;
 282             if unknown5 <> 0_l then
 283               eprintf "HB %s unknown5 field <> 0 (%08lx)\n"
 284                 (print_offset page_offset) unknown5
 285           ) else (                      (* subsequent hbins *)
 286             if unknown1 <> 0_l || unknown2 <> 0_l || unknown5 <> 0_l then
 287                 eprintf "HB %s unknown fields <> 0 (%08lx %08lx %08lx)\n"
 288                   (print_offset page_offset)
 289                   unknown1 unknown2 unknown5;
 290             if last_modified <> 0. then
 291                 eprintf "HB %s last_modified <> 0. (%g)\n"
 292                   (print_offset page_offset) last_modified
 293           );
 294
 295           (* Loop over the blocks in this page. *)
 296           loop_over_blocks blocks (data_offset + 32);
 297
 298           (* Loop over rest of the pages. *)
 299           loop_over_pages rest (data_offset + page_size)
 300
 301       | {_} ->
 302           failwithf "%s: invalid hbin at offset %s\n"
 303             basename (print_offset data_offset)
 304     ) else (
 305       (* Reached the end of the official hbins in this file, BUT the
 306        * file can be larger than this and might contain stuff.  What
 307        * does it contain after the hbins?  We think just junk, but
 308        * we're not sure.
 309        *)
 310       if not (is_zero_bitstring data) then (
 311         eprintf "Junk in file after end of pages:\n";
 312         let rec loop data data_offset =
 313           bitmatch data with
 314           | { rest : -1 : bitstring } when bitstring_length rest = 0 -> ()
 315           | { :page_fields } ->
 316               eprintf "\tjunk hbin %s 0x%08x\n"
 317                 (print_offset data_offset) page_size;
 318               loop rest (data_offset + page_size);
 319           | { _ } ->
 320               eprintf "\tother junk %s %s\n"
 321                 (print_offset data_offset) (print_bitstring data)
 322         in
 323         loop data data_offset
 324       )
 325     )
 326   and loop_over_blocks blocks block_offset =
 327     bitmatch blocks with
 328     | { rest : -1 : bitstring } when bitstring_length rest = 0 -> ()
 329
 330     | { :block_fields } ->
 331         assert (block_offset mod 8 = 0);
 332
 333         fprintf_block stdout block_offset blocks;
 334
 335         let used, seg_len =
 336           if seg_len < 0 then true, -seg_len else false, seg_len in
 337
 338         let block = block_offset, (seg_len, used, block_data) in
 339         block_list := block :: !block_list;
 340
 341         (* Loop over the rest of the blocks in this page. *)
 342         loop_over_blocks rest (block_offset + seg_len)
 343
 344     | {_} ->
 345         failwithf "%s: invalid block near offset %s\n"
 346           basename (print_offset block_offset)
 347   in
 348   loop_over_pages data 0
 349
 350 (* Turn the block_list into a map so we can quickly look up a block
 351  * from its offset.
 352  *)
 353 let block_list = !block_list
 354 let block_map =
 355   List.fold_left (
 356     fun map (block_offset, block) -> IntMap.add block_offset block map
 357   ) IntMap.empty block_list
 358 let lookup fn offset =
 359   try
 360     let (_, used, _) as block = IntMap.find offset block_map in
 361     if not used then
 362       failwithf "%s: %s: lookup: free block %s referenced from hive tree"
 363         basename fn (print_offset offset);
 364     block
 365   with Not_found ->
 366     failwithf "%s: %s: lookup: unknown block %s referenced from hive tree"
 367       basename fn (print_offset offset)
 368
 369 (* Use this to mark blocks that we've visited.  If the hive contains
 370  * no unreferenced blocks, then by the end this should just contain
 371  * free blocks.
 372  *)
 373 let mark_visited, is_not_visited, unvisited_blocks =
 374   let v = ref block_map in
 375   let mark_visited offset = v := IntMap.remove offset !v
 376   and is_not_visited offset = IntMap.mem offset !v
 377   and unvisited_blocks () = !v in
 378   mark_visited, is_not_visited, unvisited_blocks
 379
 380 (* Define persistent patterns to match nk-records, vk-records and
 381  * sk-records, which are the record types that we especially want to
 382  * analyze later.  Other blocks types (eg. value lists, lf-records)
 383  * have no "spare space" so everything is known about them and we don't
 384  * store these.
 385  *)
 386 let bitmatch nk_fields =
 387   { "nk" : 2*8 : string;
 388     (* Flags stored in the file as a little endian word, hence the
 389      * unusual ordering:
 390      *)
 391     virtmirrored : 1;
 392     predefinedhandle : 1; keynameascii : 1; symlinkkey : 1;
 393     cannotbedeleted : 1; isroot : 1; ismountpoint : 1; isvolatile : 1;
 394     unknownflag8000 : 1; unknownflag4000 : 1;
 395     unknownflag2000 : 1; unknownflag1000 : 1;
 396     unknownflag0800 : 1; unknownflag0400 : 1;
 397     virtualstore : 1; virttarget : 1;
 398     timestamp : 64 : littleendian, bind (nt_to_time_t timestamp);
 399     unknown1 : 4*8 : littleendian;
 400     parent : 4*8 : littleendian, bind (get_offset parent);
 401     nr_subkeys : 4*8 : littleendian, bind (Int32.to_int nr_subkeys);
 402     nr_subkeys_vol : 4*8;
 403     subkeys : 4*8 : littleendian, bind (get_offset subkeys);
 404     subkeys_vol : 4*8;
 405     nr_values : 4*8 : littleendian, bind (Int32.to_int nr_values);
 406     vallist : 4*8 : littleendian, bind (get_offset vallist);
 407     sk : 4*8 : littleendian, bind (get_offset sk);
 408     classname : 4*8 : littleendian, bind (get_offset classname);
 409     (* sentinelchicken.com says this is a single 32 bit field
 410      * containing maximum number of bytes in a subkey name, however
 411      * that does not seem to be correct.  We think it is two 16 bit
 412      * fields, the first being the maximum number of bytes in the
 413      * UTF16-LE encoded version of the subkey names, (since subkey
 414      * names are usually ASCII, that would be max length of names * 2).
 415      * This is a historical maximum, so it can be greater than the
 416      * current maximum name field.
 417      *
 418      * The second field is often non-zero, but the purpose is unknown.
 419      * In the hives we examined it had values 0, 1, 0x20, 0x21, 0xa0,
 420      * 0xa1, 0xe1, suggesting some sort of flags.
 421      *)
 422     max_subkey_name_len : 2*8 : littleendian;
 423     unknown2 : 2*8 : littleendian;
 424     (* sentinelchicken.com says: maximum subkey CLASSNAME length,
 425      * however that does not seem to be correct.  In hives I looked
 426      * at, it has value 0, 0xc, 0x10, 0x18, 0x1a, 0x28.
 427      *)
 428     unknown3 : 4*8 : littleendian;
 429     (* sentinelchicken.com says: maximum number of bytes in a value
 430      * name, however that does not seem to be correct.  We think it is
 431      * the maximum number of bytes in the UTF16-LE encoded version of
 432      * the value names (since value names are usually ASCII, that would
 433      * be max length of names * 2).  This is a historical maximum, so
 434      * it can be greater than the current maximum name field.
 435      *)
 436     max_vk_name_len : 4*8 : littleendian, bind (Int32.to_int max_vk_name_len);
 437     (* sentinelchicken.com says: maximum value data size, and this
 438      * agrees with my observations.  It is the largest data size (not
 439      * seg_len, but vk.data_len) for any value in this key.  We think
 440      * that this field is a historical max, so eg if a maximally sized
 441      * value is deleted then this field is not reduced.  Certainly
 442      * max_vk_data_len >= the measured maximum in all the hives that we
 443      * have observed.
 444      *)
 445     max_vk_data_len : 4*8 : littleendian, bind (Int32.to_int max_vk_data_len);
 446     unknown6 : 4*8 : littleendian;
 447     name_len : 2*8 : littleendian;
 448     classname_len : 2*8 : littleendian;
 449     name : name_len * 8 : string }
 450
 451 let fprintf_nk chan nk =
 452   let (_, _, bits) = lookup "fprintf_nk" nk in
 453   bitmatch bits with
 454   | { :nk_fields } ->
 455       fprintf chan
 456         "NK %s %s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s %s %08lx %s %d %ld %s %08lx %d %s %s %s %d %04x %08lx %d %d %08lx %d %d %s\n"
 457         (print_offset nk)
 458         (if unknownflag8000 then "8" else ".")
 459         (if unknownflag4000 then "4" else ".")
 460         (if unknownflag2000 then "2" else ".")
 461         (if unknownflag1000 then "1" else ".")
 462         (if unknownflag0800 then "8" else ".")
 463         (if unknownflag0400 then "4" else ".")
 464         (if virtualstore then "s" else ".")
 465         (if virttarget then "t" else ".")
 466         (if virtmirrored then "m" else ".")
 467         (if predefinedhandle then "P" else ".")
 468         (if keynameascii then "A" else ".")
 469         (if symlinkkey then "S" else ".")
 470         (if cannotbedeleted then "N" else ".")
 471         (if isroot then "R" else ".")
 472         (if ismountpoint then "M" else ".")
 473         (if isvolatile then "V" else ".")
 474         (print_time timestamp)
 475         unknown1 (print_offset parent) nr_subkeys nr_subkeys_vol
 476         (print_offset subkeys) subkeys_vol
 477         nr_values (print_offset vallist)
 478         (print_offset sk) (print_offset classname)
 479         max_subkey_name_len unknown2 unknown3
 480         max_vk_name_len max_vk_data_len unknown6
 481         name_len classname_len name
 482
 483 type data_t = Inline of bitstring | Offset of int
 484 let bitmatch vk_fields =
 485   { "vk" : 2*8 : string;
 486     name_len : 2*8 : littleendian;
 487     (* No one documents the important fact that data_len can have the
 488      * top bit set (randomly or is it meaningful?).  The length can
 489      * also be 0 (or 0x80000000) if the data type is NONE.
 490      *)
 491     data_len : 4*8
 492       : littleendian, bind (
 493         let data_len = Int32.logand data_len 0x7fff_ffff_l in
 494         Int32.to_int data_len
 495       );
 496     (* Inline data if len <= 4, offset otherwise.
 497      *
 498      * The data itself depends on the type field.
 499      *
 500      * For REG_SZ type, the data always seems to be NUL-terminated, which
 501      * means because these strings are often UTF-16LE, that the string will
 502      * end with \0\0 bytes.  The termination bytes are included in data_len.
 503      *
 504      * For REG_MULTI_SZ, see
 505      * http://blogs.msdn.com/oldnewthing/archive/2009/10/08/9904646.aspx
 506      *)
 507     data : 4*8
 508       : bitstring, bind (
 509         if data_len <= 4 then
 510           Inline (takebits (data_len*8) data)
 511         else (
 512           let offset =
 513             bitmatch data with { offset : 4*8 : littleendian } -> offset in
 514           let offset = get_offset offset in
 515           Offset offset
 516         )
 517       );
 518     t : 4*8 : littleendian, bind (Int32.to_int t);
 519     (* Flags, stored as a little-endian word: *)
 520     unknown1 : 7;
 521     nameisascii : 1;  (* Clear for default [zero-length] name, always set
 522                        * otherwise in registries that we found.  Perhaps this
 523                        * is really "nameisdefault" flag?
 524                        *)
 525     unknown2 : 8;
 526     (* Unknown field, usually contains something. *)
 527     unknown3 : 2*8 : littleendian;
 528     name : name_len * 8 : string }
 529
 530 let fprintf_vk chan vk =
 531   let (_, _, bits) = lookup "fprintf_vk" vk in
 532   bitmatch bits with
 533   | { :vk_fields } ->
 534       let real_data =
 535         match data with
 536         | Inline data -> data
 537         | Offset offset ->
 538             let (_, _, bits) = lookup "fprintf_vk (data)" offset in
 539             bits in
 540       fprintf chan "VK %s %s %d %s%s %s %08x %s %08x %08x\n"
 541         (print_offset vk)
 542         name data_len
 543         (match data with
 544          | Inline _ -> ""
 545          | Offset offset -> "["^print_offset offset^"]")
 546         (print_bitstring real_data)
 547         (print_vk_type t)
 548         unknown1 (if nameisascii then "A" else "L")
 549         unknown2 unknown3
 550
 551 let bitmatch sk_fields =
 552   { "sk" : 2*8 : string;
 553     unknown1 : 2*8 : littleendian;
 554     sk_next : 4*8 : littleendian, bind (get_offset sk_next);
 555     sk_prev : 4*8 : littleendian, bind (get_offset sk_prev);
 556     refcount : 4*8 : littleendian, bind (Int32.to_int refcount);
 557     sec_len : 4*8 : littleendian, bind (Int32.to_int sec_len);
 558     sec_desc : sec_len * 8 : bitstring }
 559
 560 let fprintf_sk chan sk =
 561   let (_, _, bits) = lookup "fprintf_sk" sk in
 562   bitmatch bits with
 563   | { :sk_fields } ->
 564       fprintf chan "SK %s %04x %s %s %d %d\n"
 565         (print_offset sk) unknown1
 566         (print_offset sk_next) (print_offset sk_prev)
 567         refcount sec_len
 568         (* print_bitstring sec_desc -- suppress this *)
 569
 570 (* Store lists of records we encounter (lists of offsets). *)
 571 let nk_records = ref []
 572 and vk_records = ref []
 573 and sk_records = ref []
 574
 575 (* Functions to visit each block, starting at the root.  Each block
 576  * that we visit is printed.
 577  *)
 578 let rec visit_nk ?(nk_is_root = false) nk =
 579   let (_, _, bits) = lookup "visit_nk" nk in
 580   mark_visited nk;
 581   (bitmatch bits with
 582    | { :nk_fields } ->
 583        fprintf_nk stdout nk;
 584
 585        nk_records := nk :: !nk_records;
 586
 587        (* Check the isroot flag is only set on the root node. *)
 588        assert (isroot = nk_is_root);
 589
 590        if unknownflag8000 then
 591          eprintf "NK %s unknownflag8000 is set\n" (print_offset nk);
 592        if unknownflag4000 then
 593          eprintf "NK %s unknownflag4000 is set\n" (print_offset nk);
 594        if unknownflag2000 then
 595          eprintf "NK %s unknownflag2000 is set\n" (print_offset nk);
 596        if unknownflag1000 then
 597          eprintf "NK %s unknownflag1000 is set\n" (print_offset nk);
 598        if unknownflag0800 then
 599          eprintf "NK %s unknownflag0800 is set\n" (print_offset nk);
 600        if unknownflag0400 then
 601          eprintf "NK %s unknownflag0400 is set\n" (print_offset nk);
 602        if unknown1 <> 0_l then
 603          eprintf "NK %s unknown1 <> 0 (%08lx)\n" (print_offset nk) unknown1;
 604        if unknown2 <> 0 then
 605          eprintf "NK %s unknown2 <> 0 (%04x)\n" (print_offset nk) unknown2;
 606        if unknown3 <> 0_l then
 607          eprintf "NK %s unknown3 <> 0 (%08lx)\n" (print_offset nk) unknown3;
 608        if unknown6 <> 0_l then
 609          eprintf "NK %s unknown6 <> 0 (%08lx)\n" (print_offset nk) unknown6;
 610
 611        (* -- common, assume it's not an error
 612        if classname = -1 then
 613          eprintf "NK %s has no classname\n" (print_offset nk);
 614        if classname_len = 0 then
 615          eprintf "NK %s has zero-length classname\n" (print_offset nk);
 616        *)
 617        if sk = -1 then
 618          eprintf "NK %s has no sk-record\n" (print_offset nk);
 619        if name_len = 0 then
 620          eprintf "NK %s has zero-length name\n" (print_offset nk);
 621
 622        (* Visit the values first at this node. *)
 623        let max_data_len, max_name_len =
 624          if vallist <> -1 then
 625            visit_vallist nr_values vallist
 626          else
 627            0, 0 in
 628
 629        if max_vk_data_len < max_data_len then
 630          eprintf "NK %s nk.max_vk_data_len (%d) < actual max data_len (%d)\n"
 631            (print_offset nk) max_vk_data_len max_data_len;
 632
 633        if max_vk_name_len < max_name_len * 2 then
 634          eprintf "NK %s nk.max_vk_name_len (%d) < actual max name_len * 2 (%d)\n"
 635            (print_offset nk) max_vk_name_len (max_name_len * 2);
 636
 637        (* Visit the subkeys of this node. *)
 638        if subkeys <> -1 then (
 639          let counted, max_name_len = visit_subkeys subkeys in
 640
 641          if counted <> nr_subkeys then
 642            failwithf "%s: incorrect count of subkeys (%d, counted %d) in subkey list at %s\n"
 643              basename nr_subkeys counted (print_offset subkeys);
 644
 645          if max_subkey_name_len < max_name_len * 2 then
 646            eprintf "NK %s nk.max_subkey_name_len (%d) < actual max name_len * 2 (%d)\n"
 647              (print_offset nk) max_subkey_name_len (max_name_len * 2);
 648        );
 649
 650        (* Visit the sk-record and classname. *)
 651        if sk <> -1 then
 652          visit_sk sk;
 653        if classname <> -1 then
 654          visit_classname classname classname_len;
 655
 656    | {_} ->
 657        failwithf "%s: invalid nk block at offset %s\n"
 658          basename (print_offset nk)
 659   )
 660
 661 and visit_vallist nr_values vallist =
 662   let (seg_len, _, bits) = lookup "visit_vallist" vallist in
 663   mark_visited vallist;
 664   printf "VL %s %d %d\n" (print_offset vallist) nr_values seg_len;
 665   visit_values_in_vallist nr_values vallist bits
 666
 667 and visit_values_in_vallist nr_values vallist bits =
 668   if nr_values > 0 then (
 669     bitmatch bits with
 670     | { rest : -1 : bitstring } when bitstring_length rest = 0 ->
 671         assert (nr_values = 0);
 672         0, 0
 673
 674     | { value : 4*8 : littleendian, bind (get_offset value);
 675         rest : -1 : bitstring } ->
 676         let data_len, name_len = visit_vk value in
 677         let max_data_len, max_name_len =
 678           visit_values_in_vallist (nr_values-1) vallist rest in
 679         max max_data_len data_len, max max_name_len name_len
 680
 681     | {_} ->
 682         failwithf "%s: invalid offset in value list at %s\n"
 683           basename (print_offset vallist)
 684   ) else 0, 0
 685
 686 and visit_vk vk =
 687   let (_, _, bits) = lookup "visit_vk" vk in
 688   mark_visited vk;
 689
 690   (bitmatch bits with
 691    | { :vk_fields } ->
 692        fprintf_vk stdout vk;
 693
 694        if unknown1 <> 0 then
 695          eprintf "VK %s unknown1 flags set (%02x)\n"
 696            (print_offset vk) unknown1;
 697        if unknown2 <> 0 then
 698          eprintf "VK %s unknown2 flags set (%02x)\n"
 699            (print_offset vk) unknown2;
 700        if unknown3 <> 0 then
 701          eprintf "VK %s unknown3 flags set (%04x)\n"
 702            (print_offset vk) unknown3;
 703
 704        (* Note this is common for default [ie. zero-length] key names. *)
 705        if not nameisascii && name_len > 0 then
 706          eprintf "VK %s has non-ASCII name flag set (name is %s)\n"
 707            (print_offset vk) (print_binary_string name);
 708
 709        vk_records := vk :: !vk_records;
 710        (match data with
 711         | Inline data -> ()
 712         | Offset offset ->
 713             let _ = lookup "visit_vk (data)" offset in
 714             mark_visited offset
 715        );
 716
 717        data_len, name_len
 718
 719    | {_} ->
 720        failwithf "%s: invalid vk block at offset %s\n"
 721          basename (print_offset vk)
 722   )
 723
 724 (* Visits subkeys, recursing through intermediate lf/lh/ri structures,
 725  * and returns the number of subkeys actually seen.
 726  *)
 727 and visit_subkeys subkeys =
 728   let (_, _, bits) = lookup "visit_subkeys" subkeys in
 729   mark_visited subkeys;
 730   (bitmatch bits with
 731    | { ("lf"|"lh") : 2*8 : string;
 732        len : 2*8 : littleendian; (* number of subkeys of this node *)
 733        rest : len*8*8 : bitstring } ->
 734        printf "LF %s %d\n" (print_offset subkeys) len;
 735        visit_subkeys_in_lf_list subkeys len rest
 736
 737    | { "ri" : 2*8 : string;
 738        len : 2*8 : littleendian;
 739        rest : len*4*8 : bitstring } ->
 740        printf "RI %s %d\n" (print_offset subkeys) len;
 741        visit_subkeys_in_ri_list subkeys len rest
 742
 743    (* In theory you can have an li-record here, but we've never
 744     * seen one.
 745     *)
 746
 747    | { "nk" : 2*8 : string } ->
 748        visit_nk subkeys;
 749        let name_len = name_len_of_nk subkeys in
 750        1, name_len
 751
 752    | {_} ->
 753        failwithf "%s: invalid subkey node found at %s\n"
 754          basename (print_offset subkeys)
 755   )
 756
 757 and visit_subkeys_in_lf_list subkeys_top len bits =
 758   if len > 0 then (
 759     bitmatch bits with
 760     | { rest : -1 : bitstring } when bitstring_length rest = 0 ->
 761         assert (len = 0);
 762         0, 0
 763
 764     | { offset : 4*8 : littleendian, bind (get_offset offset);
 765         _ (* hash *) : 4*8 : bitstring;
 766         rest : -1 : bitstring } ->
 767         let c1, name_len1 = visit_subkeys offset in
 768         let c2, name_len2 = visit_subkeys_in_lf_list subkeys_top (len-1) rest in
 769         c1 + c2, max name_len1 name_len2
 770
 771     | {_} ->
 772         failwithf "%s: invalid subkey in lf/lh list at %s\n"
 773           basename (print_offset subkeys_top)
 774   ) else 0, 0
 775
 776 and visit_subkeys_in_ri_list subkeys_top len bits =
 777   if len > 0 then (
 778     bitmatch bits with
 779     | { rest : -1 : bitstring } when bitstring_length rest = 0 ->
 780         assert (len = 0);
 781         0, 0
 782
 783     | { offset : 4*8 : littleendian, bind (get_offset offset);
 784         rest : -1 : bitstring } ->
 785         let c1, name_len1 = visit_subkeys offset in
 786         let c2, name_len2 = visit_subkeys_in_ri_list subkeys_top (len-1) rest in
 787         c1 + c2, max name_len1 name_len2
 788
 789     | {_} ->
 790         failwithf "%s: invalid subkey in ri list at %s\n"
 791           basename (print_offset subkeys_top)
 792   ) else 0, 0
 793
 794 and name_len_of_nk nk =
 795   let (_, _, bits) = lookup "name_len_of_nk" nk in
 796   bitmatch bits with
 797   | { :nk_fields } -> name_len
 798
 799 and visit_sk sk =
 800   let (_, _, bits) = lookup "visit_sk" sk in
 801   if is_not_visited sk then (
 802     mark_visited sk;
 803     (bitmatch bits with
 804      | { :sk_fields } ->
 805          fprintf_sk stdout sk;
 806
 807          if unknown1 <> 0 then
 808            eprintf "SK %s unknown1 <> 0 (%04x)\n" (print_offset sk) unknown1;
 809
 810          sk_records := sk :: !sk_records
 811
 812      | {_} ->
 813          failwithf "%s: invalid sk-record at %s\n"
 814            basename (print_offset sk)
 815     )
 816   )
 817
 818 and visit_classname classname classname_len =
 819   let (seg_len, _, bits) = lookup "visit_classname" classname in
 820   mark_visited classname;
 821   assert (seg_len >= classname_len);
 822   printf "CL %s %s\n" (print_offset classname) (print_bitstring bits)
 823
 824 let () =
 825   visit_nk ~nk_is_root:true root_key
 826
 827 (* These are immutable now. *)
 828 let nk_records = !nk_records
 829 let vk_records = !vk_records
 830 let sk_records = !sk_records
 831
 832 (* So we can rapidly tell what is an nk/vk/sk offset. *)
 833 let nk_set =
 834   List.fold_left (fun set offs -> IntSet.add offs set) IntSet.empty nk_records
 835 let vk_set =
 836   List.fold_left (fun set offs -> IntSet.add offs set) IntSet.empty vk_records
 837 let sk_set =
 838   List.fold_left (fun set offs -> IntSet.add offs set) IntSet.empty sk_records
 839
 840 (* Now after visiting all the blocks, are there any used blocks which
 841  * are unvisited?  If there are any then that would indicate either (a)
 842  * that the hive contains unreferenced blocks, or (b) that there are
 843  * referenced blocks that we did not visit because we don't have a full
 844  * understanding of the hive format.
 845  *
 846  * Windows 7 registries often contain a few of these -- not clear
 847  * how serious they are, but don't fail here.
 848  *)
 849 let () =
 850   let unvisited = unvisited_blocks () in
 851   IntMap.iter (
 852     fun offset block ->
 853       match block with
 854       | (_, false, _) -> () (* ignore unused blocks *)
 855       | (seg_len, true, _) ->
 856           eprintf "used block %s (length %d) is not referenced\n"
 857             (print_offset offset) seg_len
 858   ) unvisited
 859
 860 (* Check the SKs are:
 861  * (a) linked into a single circular list through the sk_prev/sk_next
 862  * pointers
 863  * (b) refcounts are correct
 864  *)
 865 let () =
 866   if List.length sk_records > 0 then (
 867     let sk0 = List.hd sk_records in (* start at any arbitrary sk *)
 868     (* This loop follows the chain of sk pointers until we arrive
 869      * back at the original, checking prev/next are consistent.
 870      *)
 871     let rec loop visited prevsk sk =
 872       if sk <> sk0 then (
 873         if not (IntSet.mem sk sk_set) then
 874           eprintf "SK %s not an sk-record (faulty sk_next somewhere)\n"
 875             (print_offset sk)
 876         else (
 877           let _, _, bits = lookup "loop sk circular list" sk in
 878           bitmatch bits with
 879           | { :sk_fields } ->
 880               if sk_prev <> prevsk then
 881                 eprintf "SK %s sk_prev != previous sk (%s, %s)\n"
 882                   (print_offset sk)
 883                   (print_offset sk_prev) (print_offset prevsk);
 884               if IntSet.mem sk visited then
 885                 eprintf "SK %s already visited (bad circular list)\n"
 886                   (print_offset sk);
 887               let visited = IntSet.add sk visited in
 888               loop visited sk sk_next
 889         )
 890       )
 891     in
 892     let _, _, bits = lookup "start sk circular list" sk0 in
 893     (bitmatch bits with
 894      | { :sk_fields } ->
 895          loop IntSet.empty sk_prev sk0
 896     );
 897
 898     (* For every nk-record, if it references an sk-record count that,
 899      * then check this matches the refcounts in the sk-records
 900      * themselves.
 901      *)
 902     let refcounts = Counter.create () in
 903     List.iter (
 904       fun nk ->
 905         let _, _, bits = lookup "sk refcounter (nk)" nk in
 906         (bitmatch bits with
 907          | { :nk_fields } ->
 908              Counter.incr refcounts sk
 909         )
 910     ) nk_records;
 911
 912     List.iter (
 913       fun sk ->
 914         let _, _, bits = lookup "sk refcounter (sk)" sk in
 915         (bitmatch bits with
 916          | { :sk_fields } ->
 917              let actual = Counter.get refcounts sk in
 918              if actual <> refcount then
 919                eprintf "SK %s incorrect refcount (actual %d, in file %d)\n"
 920                  (print_offset sk) actual refcount
 921         )
 922     ) sk_records
 923   )