[commit] r3016 - cpu/x86/pc/olpc

[repository service]

Author: wmb
Date: Thu Jun 21 02:03:09 2012
New Revision: 3016
URL: http://tracker.coreboot.org/trac/openfirmware/changeset/3016

Log:
OLPC - checked in oatstime.fth - a script that can be signed and
used to set the Real Time Clock on secure machines.

Added:
   cpu/x86/pc/olpc/oatstime.fth

Added: cpu/x86/pc/olpc/oatstime.fth
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ cpu/x86/pc/olpc/oatstime.fth	Thu Jun 21 02:03:09 2012	(r3016)
@@ -0,0 +1,392 @@
+\ OLPC boot script to set the XO system time from an OATS server
+\ This can be signed and booted on secure machines to fix their clocks
+
+\ Set this to the name or IP address of the deployment's OATS server
+: server$  " 192.168.200.57"  ;  \ DNS name or IP address
+
+\ Replace this key with a deployment-specific one
+create oats-pubkey
+ " "(30 82 01 0a 02 82 01 01 00 cf 2c 9a 49 81 a9 dd)" $,
+ " "(0e 39 e6 02 dc 9a 77 2e 9e cb 24 0c 1d 94 ec d3)" $,
+ " "(e9 0a 86 58 fb c4 a1 f7 dd 06 d4 87 03 c3 04 8f)" $,
+ " "(43 25 a9 27 62 9b 58 71 e2 39 f6 d5 55 35 37 d4)" $,
+ " "(23 14 2a 10 fa b7 2f ad 4c d1 5c 9f c8 87 10 25)" $,
+ " "(28 fd 72 b1 c6 87 8e 55 bd 77 a8 a4 84 d6 4a 41)" $,
+ " "(7d 36 f2 7b 8e c3 67 3f d8 78 a5 69 10 86 b8 48)" $,
+ " "(08 17 74 f9 7a 17 e3 9e c6 8a 41 bc 21 b8 1f 9d)" $,
+ " "(02 e3 82 31 96 28 b8 92 b4 2b c0 10 c6 c5 8d d5)" $,
+ " "(1b 2b 4b e1 cd 3d 21 76 1d 83 0a 65 88 ce 49 ad)" $,
+ " "(8f 85 40 7a 16 d7 99 24 6b 72 5c f9 eb af b8 f9)" $,
+ " "(d5 3d ed 90 5f 95 b0 51 8a b3 ed 16 8a 07 2a 89)" $,
+ " "(ae 7f da 04 c8 14 01 86 04 ce 33 a6 3f 39 ce 79)" $,
+ " "(bf af d4 81 e3 c6 1f 57 06 25 4f 3f 24 f7 28 38)" $,
+ " "(6d 8b 34 5e fe da 86 cd 0f 9a 17 99 a7 c6 b2 57)" $,
+ " "(ab 76 47 54 cb 11 a4 47 e0 9c 5e fa f1 2c 59 68)" $,
+ " "(26 73 1e 7b 20 e8 9c 89 ab 02 03 01 00 01)" $,
+here oats-pubkey - constant oats-pubkey-len
+
+\ Canonical JSON parser
+
+\ Look at the next character in the JSON stream, leaving it in the stream
+: json-look  ( rem$ -- rem$ char )
+   dup 0<= abort" Unexpected end of CJSON data"
+   over c@
+;
+
+\ Discard the next character in the JSON stream
+: json-skip  ( rem$ -- rem$' )  ( over c@ emit )  1 /string  ;
+
+\ Get the next character from the JSON stream
+: json-get  ( rem$ -- rem$' char )  json-look  >r  json-skip  r>  ;
+
+\ Get the next JSON character and abort if is not the expected one
+: json-expect  ( rem$ char -- rem$' )
+   >r  json-get  r> <>  abort" Unexpected character in CJSON stream"
+;
+
+\ True if there is another object element
+: json-element?  ( rem$ -- rem$' flag )
+   json-look  case
+      [char] ]  of  false  endof
+      [char] ,  of  json-skip  true   endof
+      ( default )  true swap
+   endcase
+;
+
+: json-[  ( rem$ -- rem$' )  [char] [ json-expect  ;  \ Expect [ - start of array
+: json-]  ( rem$ -- rem$' )  [char] ] json-expect  ;  \ Expect ] - end of array
+: json-,  ( rem$ -- rem$' )  [char] , json-expect  ;  \ Expect , - another array element
+
+\ Collect digits to form a nonnegative number
+: json-digits  ( rem$ -- rem$' n )
+   0  begin
+      >r
+      json-look  dup [char] 0  [char] 9  between  if
+         [char] 0 -  r> d# 10 *  +  >r
+         json-skip
+      else
+         drop  r>  exit
+      then
+      r>
+   again
+;
+
+\ Collect a (possibly negative) number
+: json-number  ( rem$ -- rem$' n )
+   json-look  [char] -  =  if
+      json-skip  json-digits  negate
+   else
+      json-digits
+   then
+;
+
+: cjson-copy-escaped  ( adr len dest-adr -- dest$ )
+   0  2swap   bounds ?do         ( dest-adr dest-len )
+      i c@  dup [char] \ =  if   ( dest-adr dest-len char )
+         drop                    ( dest-adr dest-len )
+      else                       ( dest-adr dest-len char )
+         2 pick 2 pick +  c!     ( dest-adr dest-len )
+         1+                      ( dest-adr dest-len' )
+      then                       ( dest-adr dest-len )
+   loop                          ( dest-adr dest-len )
+;
+
+\ Collect a string.  Escape sequences are left in place - not converted -
+\ to avoid the need for memory allocation.  Use cjson-copy-escaped if
+\ you need to process escapes.
+: json-"  ( rem$ -- rem$' $ )
+   [char] " json-expect  ( rem$ )
+   over 0                ( rem$ $ )
+   begin                 ( rem$ $ )
+      2>r
+      json-look     ( rem$ char r: $ )
+      case
+         [char] "  of          ( rem$ )
+	    json-skip     ( rem$' )
+            2r> exit
+         endof
+         [char] \  of          ( rem$ )
+            json-skip
+            json-get
+            2r> 1+ 2>r
+         endof
+         ( default )  >r  json-skip  r>
+      endcase
+      2r> 1+
+   again
+;
+
+: json-{  ( rem$ -- rem$' )  [char] { json-expect  ;  \ Expect { - start of object
+: json-}  ( rem$ -- rem$' )  [char] } json-expect  ;  \ Expect } - end of object
+: json-:  ( rem$ -- rem$' )  [char] : json-expect  ;  \ Expect : - object value
+
+\ True if there is another object pair
+: json-pair?  ( rem$ -- rem$ flag )
+   json-look  case
+      [char] }  of  false   endof
+      [char] ,  of  json-skip  true   endof
+      ( default )  true swap
+   endcase
+;
+
+\ Expect a literal string - implementation factor
+: json$  ( rem$ $ -- rem$' )  bounds  ?do  i c@ json-expect  loop  ;   
+
+: json-true   ( rem$ -- rem$' )  " true"  json$  ;  \ Expect literal 'true'
+: json-false  ( rem$ -- rem$' )  " false" json$  ;  \ Expect literal 'false'
+: json-null   ( rem$ -- rem$' )  " null"  json$  ;  \ Expect literal 'null'
+
+\ Parse and discard a value - useful for skipping the value portion of uninteresting pairs
+\ Forward referenced because arrays can contain values and values can be arrays
+defer discard-json-value
+
+\ Parse and discard an array - factor of discard-json-value
+: discard-json-array   ( rem$ -- rem$' )
+   json-[                        ( rem$' )
+   begin  json-element?  while   ( rem$' )
+      discard-json-value         ( rem$' )
+   repeat                        ( rem$' )
+   json-]                        ( rem$' )
+;
+
+\ Parse and discard an object - factor of discard-json-value
+: discard-json-object  ( -- )
+   json-{                        ( rem$' )
+   begin  json-pair?  while       ( rem$' )
+      json-" 2drop               ( rem$' )
+      json-:                     ( rem$' )
+      discard-json-value         ( rem$' )
+   repeat                        ( rem$' )
+   json-}                        ( rem$' )
+;
+
+\ Helper function used with Forth case statement to match a range of values
+: range  ( selector low high -- selector n )
+   2>r dup 2r> between  if  dup  else  dup invert  then   ( selector n )
+;
+
+\ Final implementation of the forward-referenced "discard-json-value"
+: (discard-json-value)  ( rem$ -- rem$' )
+   json-look  case
+      [char] " of  json-"  2drop        endof
+      [char] t of  json-true            endof
+      [char] f of  json-false           endof
+      [char] n of  json-null            endof
+      [char] [ of  discard-json-array   endof
+      [char] { of  discard-json-object  endof
+      [char] - of  json-number drop     endof
+      [char] 0 [char] 9 range  of  json-number  endof
+      ( default )
+      true abort" Invalid first character in JSON value"
+   endcase
+;
+' (discard-json-value) to discard-json-value
+
+\ End of generic canonical JSON code
+
+\ Expect an envelope of the given name and version, leaving the CJSON
+\ stream remainder at the enveloped contents
+: envelope(  ( rem$ name$ version -- rem$' )
+   >r  2>r                               ( rem$ r: version name$ )
+   json-[                                ( rem$' r: version name$ )
+   json-"                                ( rem$' $ r: version name$ )
+   2r> $= 0=  abort" Wrong envelope"     ( rem$' r: version )
+   json-,
+   json-number                           ( rem$' n r: version )
+   r> <> abort" Wrong envelope version"  ( rem$' )
+   json-,                                ( rem$ )
+   \ remainder starts with the envelope data
+;
+
+\ Expect the end of an envelope
+: )envelope  ( rem$ -- rem$' )  json-]  ;
+
+
+d# 256 buffer: nonce-data
+: save-nonce  ( rem$ -- rem$' )
+   json-"                            ( rem$' value$ )
+   d# 255 min  nonce-data 1+  cjson-copy-escaped  ( rem$ $ )
+   nonce-data c!  drop               ( rem$ )
+;
+
+d# 32 buffer: time-data
+: save-time  ( rem$ -- rem$' )
+   json-"                            ( rem$' value$ )
+   d# 31 min  time-data 1+ cjson-copy-escaped    ( rem$ $ )
+   time-data c!  drop                            ( rem$ )
+;
+
+: decode-oats-key  ( rem$ name$ -- rem$' )
+   json-"                  ( rem$ name$ )
+   2dup " nonce" $=  if    ( rem$ name$ )
+      2drop                ( rem$ )
+      json-:               ( rem$' )
+      save-nonce           ( rem$' )
+      exit                 ( -- rem$ )
+   then                    ( rem$ name$ )
+   2dup  " time" $=  if    ( rem$ name$ )
+      2drop                ( rem$ )
+      json-:               ( rem$' )
+      save-time            ( rem$' )
+      exit                 ( -- rem$ )
+   then                    ( rem$ name$ )
+   2drop                   ( rem$ )
+   json-:                  ( rem$' )
+   discard-json-value      ( rem$' )
+;
+: decode-oats-data  ( rem$ -- rem$' )
+   " oatc-resp" 1 envelope(    ( rem$' )
+
+   \ Enveloped data is an object { "nonce":value, "time":value, ... }
+   json-{                      ( rem$' )
+   begin  json-pair?  while    ( rem$' )
+      decode-oats-key          ( rem$' )
+   repeat                      ( rem$ )
+   json-}                      ( rem$' )
+
+   )envelope                   ( rem$' )
+;
+
+0 0 2value the-signature$
+: decode-oats-credential   ( rem$ -- rem$' )
+   " sig" 1 envelope(           ( rem$' )
+
+   \ Enveloped data is an array of signatures - [ "sig01 ...", ... ]
+   json-[                       ( rem$' )
+   begin  json-element?  while  ( rem$' )
+      json-"                    ( rem$ sig$ )
+      to the-signature$         ( rem$' )
+   repeat                       ( rem$ )
+   json-]                       ( rem$' )
+
+   )envelope                    ( rem$' )
+;
+
+: decode-oats-response  ( rem$ -- rem$' )
+   " oatc-signed-resp" 1 envelope(  ( rem$' )
+   \ Enveloped data is a 2-element array - [data,credential]
+
+   json-[                           ( rem$' )
+   over >r                          ( rem$  r: data-adr )
+   decode-oats-data                 ( rem$' r: data-adr )
+   r> 2 pick over - to signed-data$ ( rem$' )
+   json-,                           ( rem$' )
+   decode-oats-credential           ( rem$' )
+   json-]                           ( rem$' )
+
+   )envelope                        ( rem$' )
+;
+
+0 [if] \ Example request
+POST /antitheft/1/ HTTP/1.1
+Host: antitheft.laptop.org
+Content-Type: application/x-www-form-urlencoded  
+Content-Length: 43
+
+serialnum=SHC12900018&version=1&nonce=12345678
+[then]
+
+0 [if] \ Example response
+["oatc-signed-resp",1,[["oatc-resp",1,{"nonce":"12345678
+","time":"20120619T144129Z"}],["sig",1,["sig01: sha256 b257ab764754cb11a447e09c5efaf12c596826731e7b20e89c89ab0203010001 8200ecb1b71df1119fceba00e8cca7b29b6e2870c7ab6224ca49e8a4a57b295edc733646ec5ae36767a403ebd43217185a46bb6d41c32f2d7ce4c33de6c4718a5e87e28349e9f72be719d6fcea35a37a3b68afc3b8a42d58333e7c6e78e1bb6f87dd106dce69dc191e1598514b63645f17a77be36128601950146c87b8702ba3474fc2289a589e38929f532cae683d6094171f7afa2c1765592216bdaa6c975916810b61db83a4a6f0a1b17f3f69559d45aebf64bb1c324fda2e97a044840556bfa688097ae77823447b07cdd5fce2f96bf990b11d7e6c409df2c42272d33805fb6fcdaa0ffd4d1b1ebeef44f458f1201fb484a43b4d10932862a3eba0b021e5
+"]]]]
+[then]
+
+0 value http-ih
+: $call-http http-ih $call-method ;
+dev /http
+\needs flush-writes  : flush-writes  " flush-writes" $call-parent  ;
+\needs connect       : connect       " connect" $call-parent  ;
+dend
+: http-write  " tcp-write" $call-http  ;
+: http-write-line   ( adr len -- )  http-write  " "r"n" http-write  ;
+: http-read-line  ( -- adr len )  " get-line" $call-http  ;
+   
+: oats-send  ( msg$ -- )
+   server$ " set-server" $call-http
+   d# 80 " connect" $call-http  0=  abort" Can't connect to server"
+   " POST /antitheft/1/ HTTP/1.1" http-write-line
+   " Host: antitheft.laptop.org" http-write-line
+   " Content-Type: application/x-www-form-urlencoded" http-write-line
+   dup " Content-Length: %d" sprintf http-write-line         ( msg$ )
+   " " http-write-line                                       ( msg$ )
+   http-write
+   " flush-writes" $call-http
+;
+0 value the-nonce
+: oats-msg$  ( -- msg$ )
+   random-long abs  dup to the-nonce   ( nonce )
+   " SN" find-tag 0= abort" Machine has no serial number" ?-null  ( nonce sn$ )
+   " serialnum=%s&version=1&nonce=%d" sprintf
+;
+h# 10000 buffer: oats-buf
+: tread  
+   oats-buf h# 10000 " wait-read" $call-http  dup  0>  if  oats-buf swap list  else  drop  then
+;
+: open-http  http-ih 0=  if  " http:" open-dev to http-ih  then  ;
+: close-http  http-ih  if  http-ih close-dev  0 to http-ih  then  ;
+
+: decimal-number  ( $ -- n )
+   push-decimal  $number abort" Bad number"  pop-base
+;
+
+: (parse-time)  ( $ -- s m h d m y )
+   d# 20 d# 20 numfield  >r                  ( rem$  r: century )
+   d# 12 d# 40 numfield  r> d# 100 * +  >r   ( rem$  r: y )
+   d#  1 d# 12 numfield  >r                  ( rem$  r: y m )
+   d#  1 d# 31 numfield  >r                  ( rem$  r: y m d )
+
+   1 cut$  " T" $= 0= abort" Expecting T in time"
+   d#  0 d# 24 numfield  >r                  ( rem$  r: y m d h )
+   d#  0 d# 59 numfield  >r                  ( rem$  r: y m d h m )
+   d#  0 d# 59 numfield  >r                  ( rem$  r: y m d h m s )
+
+   1 cut$  " Z" $= 0= abort" Expecting T in time"  ( rem$  r: y m d h m s )
+   0<> abort" Junk after time"  drop             ( r: y m d h m s )
+   r> r> r> r> r> r>
+;
+: parse-time  ( $ -- s m h d m y )
+   push-decimal ['] (parse-time) catch pop-base throw
+;
+: verify-oats  ( rem$ -- )
+   dup  if  ." Extra stuff after OATS response: " list cr  else  2drop  then  ( )
+
+   nonce-data count decimal-number the-nonce <> abort" Nonce mismatch"
+   
+   oats-pubkey-len to pubkeylen
+   oats-pubkey oats-pubkey-len to pubkey$
+   " sha256" to exp-hashname$
+   the-signature$  begin  dup  while    ( rem$ )
+      newline left-parse-string         ( rem$ line$ )
+      this-sig-line-good? 0= abort" Bad signature"
+   repeat                               ( rem$ )
+   2drop
+;
+
+: time-from-oats
+   load-crypto abort" Crypto load failed"
+   open-http
+   oats-msg$ ?save-string oats-send
+   " check-header" ['] $call-http catch  if
+      ." Bad HTTP header" cr
+      close-http
+      abort
+   then
+   " image-size" $call-http                 ( len )
+
+   oats-buf over " wait-read" $call-http    ( len actual )
+   close-http                               ( len actual )
+
+   2dup <> if                               ( len actual )
+      ." Wrong HTTP content length - Expected " swap .d ." got " .d cr
+      abort
+   then                                     ( len actual )
+
+   nip  oats-buf swap decode-oats-response  ( adr len )
+   verify-oats
+
+   time-data count  parse-time " set-time" clock-node @ $call-method
+
+   cr  ." Set clock to " .clock
+;
+time-from-oats