Initial commit of OpenSPARC T2 architecture model.

[OpenSPARC-T2-SAM] / obp / obp / arch / sun4v / keystore.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: keystore.fth
\ 
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\ 
\  - Do no alter or remove copyright notices
\ 
\  - Redistribution and use of this software in source and binary forms, with 
\    or without modification, are permitted provided that the following 
\    conditions are met: 
\ 
\  - Redistribution of source code must retain the above copyright notice, 
\    this list of conditions and the following disclaimer.
\ 
\  - Redistribution in binary form must reproduce the above copyright notice,
\    this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution. 
\ 
\    Neither the name of Sun Microsystems, Inc. or the names of contributors 
\ may be used to endorse or promote products derived from this software 
\ without specific prior written permission. 
\ 
\     This software is provided "AS IS," without a warranty of any kind. 
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, 
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A 
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN 
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR 
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR 
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN 
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR 
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE 
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, 
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF 
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\ 
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ any nuclear facility. 
\ 
\ ========== Copyright Header End ============================================
id: @(#)keystore.fth 1.4 07/04/10
purpose: 
copyright: Copyright 2007 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.

\ FWARC 2006/523

vocabulary keystore
also keystore definitions

headerless

1 		value key-major
0 		value key-minor
h# 4f42504b4559 value key-svc-handle	\ OBPKEY

\ Keystore Data Message
struct
   /l	field >key-cmd
constant /key-hdr

\ Keystore Data Response
struct
   /l   field >key-response
constant /key-response

\ Keystore Updates Response
struct
   /l   field >key-updates-response
   /l   field >key-updates-size
constant /key-updates-hdr

/key-hdr /key-response + constant /key-response-pkt

d# 1024 constant MAX-VAR-SIZE
MAX-VAR-SIZE /key-hdr + buffer: key-buf

also domain-services
MAX-DS-PAYLOAD constant MAX-UPDATES-SIZE \ that OBP can currently handle
previous

0 value keystore-updates-buf		\ allocated on the fly for MD updates
0 value keystore-backup?	\ Differentiate between the two services

: key-cmd!  	   	( cmd pkt -- )  	>key-cmd l!  ;
: key-cmd@  	   	( pkt -- cmd )  	>key-cmd l@  ;
: >key-payload     	( pkt -- payload-adr )  /key-hdr +  ;
: key-response@  	( pkt -- response )  	>key-payload >key-response l@ ;
: >key-updates-payload	( pkt -- payload-adr )
   >key-payload /key-updates-hdr +
;
: keystore-updates-size@ ( pkt -- size )  /key-hdr + >key-updates-size l@ ; 


\ message types
0 	constant KEYSTORE-SET-REQ
1	constant KEYSTORE-DELETE-REQ
2	constant KEYSTORE-SET-RESP
3	constant KEYSTORE-DELETE-RESP

4	constant KEYSTORE-UPDATES-REQ
5	constant KEYSTORE-UPDATES-RESP

\ Response Result Codes
0	constant KEYSTORE-SUCCESS
1	constant KEYSTORE-NO-SPACE
2	constant KEYSTORE-INVALID-KEY
3	constant KEYSTORE-INVALID-VAL
4	constant KEYSTORE-NOT-PRESENT

\ To coordinate handoffs between Solaris and OBP the state of the 
\ domain-service channel is stored away.  If OBP needs to use the channel
\ after it has been closed it will attempt to re-register its needed service
0 constant KEY-CLOSED
1 constant KEY-OPEN
2 constant KEY-ERROR

KEY-CLOSED value key-service-state

\ Domain-service interfaces
\ Send buffer on the given service channel
: send-ds-data  ( buf len svc-handle -- error? )
   [ also domain-services ] send-ds-data [ previous ]
;

\ Receive a packet of at most len from the given service channel
: receive-ds-data  ( buf len svc-handle -- len' 0 | error )
   [ also domain-services ] receive-ds-data [ previous ]
;

\ Attempt to register $svc-id with svc-handle.  Returns error/ack/nack
: register-domain-service ( maj min svc-han $svc-id -- maj/min ack? 0 | -1 )
   [ also domain-services ] register-domain-service [ previous ]
;

\ Unregister the domain service negotiated on svc-handle
: unregister-domain-service  ( svc-handle -- error? )
   [ also domain-services ] unregister-domain-service [ previous ]
;
also ldc

\ service IDs with Null Character embedded
: $keystore  		( -- $ )  " keystore"(00)"  ;
: $keystore-backup	( -- $ )  " keystore-backup"(00)"  ;

\ Both init-primary-service and init-secondary-service can be changed
\ to begin/while loops with multiple calls to reigster-domain-service
\ however right now we only support 1.0 so if we get a nack that's it.
: init-primary-service  ( -- error? )    
   key-major key-minor key-svc-handle $keystore
   register-domain-service ?dup 0= if 			( maj/min ack? )
      nip 0=						( nack? )
   then
   dup 0= if  0 to keystore-backup?  then
;

: init-secondary-service  ( -- error? )  
   key-major key-minor key-svc-handle $keystore-backup
   register-domain-service ?dup 0= if 			( maj/min ack? )
      nip 0=						( nack? )
   then
   dup 0= if  -1 to keystore-backup?  then
;

\ Attempt to Register one of the two keystore services
: key-init  ( -- error? )
   init-primary-service dup if			( error? )
      drop init-secondary-service		( error? )
   then						( error? )
   dup if
      KEY-CLOSED to key-service-state
   else
      KEY-OPEN to key-service-state
   then
;

\ Unregister the keystore service
: key-close  ( -- )
   key-service-state KEY-OPEN <> if exit then		(  )
   key-svc-handle unregister-domain-service ?dup if	(  )
      \ If LDC is not up then it has been reset, treat this as closed LDC
      \ which can be re-opened for later operations.
      LDC-NOTUP = if					(  )
         KEY-CLOSED to key-service-state		(  )
      else						(  )
         KEY-ERROR to key-service-state			(  )
      then						(  )
   else							(  )
      KEY-CLOSED to key-service-state			(  )
   then							(  )
   key-svc-handle 1+ to key-svc-handle	\ new handle in case of re-register
;

\ Bring up the keystore channel unless it is in the ERROR state
: check-key-channel-state  ( -- error? )
   key-service-state case
      KEY-OPEN 		of	 0	endof
      KEY-CLOSED	of key-init	endof
      KEY-ERROR		of 	-1	endof
   endcase
;

\ Store string as a null-terminated string and return pointer past the
\ terminating null character.
: $cstrput ( str len dest-adr -- end-adr )
   swap  2dup ca+ >r  move  0 r@ c!  r> ca1+
;

d# 1024 buffer: str-buf

\ " foo" " bar" becomes " foo"(00)"bar"(00)"
: cat-with-nulls ( str len str2 len2 -- str' len' )
   dup 3 pick + >r
   str-buf $cstrput $cstrput drop
   str-buf r> 2+
;

\ add trailing 0
: to-cstr  ( buf len -- buf' len' )
   tuck str-buf $cstrput drop		( len )
   str-buf swap 1+			( buf len' )
;

\ Wrap set data in a keystore packet to be sent to the domain services layer
: assemble-set-pkt  ( $data $name -- pkt len )
   cat-with-nulls tuck key-buf			( $payload pkt )
   KEYSTORE-SET-REQ over key-cmd!		( payload-len $payload pkt )
   >key-payload swap move			( payload-len )
   key-buf swap /key-hdr +			( pkt len )
;

\ Wrap unset data to be sent to the domain services layer
: assemble-unset-pkt  ( $name -- pkt len )
   to-cstr tuck key-buf				( name-len $name pkt )
   KEYSTORE-DELETE-REQ over key-cmd!		( name-len $name pkt )
   >key-payload swap move			( name-len )
   key-buf swap /key-hdr +			( pkt len )
;

\ Request any updates from the SP since it last created an MD
: assemble-updates-req-pkt  ( -- pkt len )
   keystore-updates-buf			( pkt )
   KEYSTORE-UPDATES-REQ over key-cmd!	( pkt )
   /key-hdr				( pkt len )
;

: key-response?  ( cmd -- key-response? )
   dup KEYSTORE-DELETE-RESP = swap KEYSTORE-SET-RESP = or
;

: key-updates-response?  ( cmd -- ldv-updates-response? )
   KEYSTORE-UPDATES-RESP =
;

\ Wait for keystore response request
: wait-for-key-response  ( -- error )
   key-buf						( buf )
   begin
      dup /key-response-pkt key-svc-handle 		( buf buf len handle )
      receive-ds-data ?dup if				( buf len' | buf error )
         dup LDC-NOTUP  if
	    cmn-warn[ " Waiting for key response but LDC is Not Up!" ]cmn-end
	    \ Mark the service closed so that it can be opened again
            KEY-CLOSED to key-service-state		(  )
         then						( buf error )
         nip exit					( error )
      else						( buf len )
         /key-response-pkt <> if			( buf )
            cmn-warn[ 
	       " No Keystore response from Domain Service Providor "
	    ]cmn-end
            drop -1 exit				( -1 )
         then						( buf )
      then
      dup key-cmd@ key-response?			( buf response? )
   until

   key-response@ case
      KEYSTORE-SUCCESS 	of  0 				endof
      KEYSTORE-NO-SPACE 	of  " No Space"		endof
      KEYSTORE-INVALID-KEY	of  " Invalid Key Name" endof
      KEYSTORE-INVALID-VAL	of  " Invalid Value"	endof
      KEYSTORE-NOT-PRESENT	of  " Key not Present" 	endof
      0 swap
   endcase
   dup if
      cmn-warn[ ]cmn-end -1
   then
;

\ The updates response could be large.  The domain-service interface layer
\ should be updated to handle variable length packets until it is, we default
\ to the current max size of an OBP domain-service packet (8K)
: wait-for-updates-response  ( -- error )
  keystore-updates-buf					( buf )
   begin
      dup MAX-UPDATES-SIZE key-svc-handle		( buf buf len handle )
      receive-ds-data ?dup if				( buf len' | buf error )
         dup LDC-NOTUP = if				( buf error )
	    cmn-warn[
	       " Waiting for Keystore Response but LDC is Not Up!"
	    ]cmn-end
	    \ Mark the service closed so that it can be opened again
            KEY-CLOSED to key-service-state		(  )
         then						( buf error )
         nip exit					( error )
      else						( buf len )
         0= if						( buf )
            drop -1 exit				( -1 )
         then						( buf )
      then
      dup key-cmd@ key-updates-response?		( buf response? )
   until						( buf )
   keystore-updates-size@ MAX-UPDATES-SIZE > dup if
      cmn-warn[ " Keystore error - Updates MD too large " ]cmn-end
   then
;


headers

: keystore-set  ( $data $name --  )
   check-key-channel-state if  
      cmn-warn[ " Unable to store Security key" ]cmn-end
      2drop 2drop exit
   then
   assemble-set-pkt			( pkt len )
   key-svc-handle send-ds-data ?dup if	(   | status )
      LDC-NOTUP = if 		( )
         cmn-warn[ " Sending Keystore Set request but LDC is Not Up!" ]cmn-end
	 \ Mark the service closed so that it can be opened again
         KEY-CLOSED to key-service-state	(  )
      else
         key-close				( )
      then
      cmn-warn[ " Keystore Set request failed!" ]cmn-end
      exit				( )
   then					( )
   wait-for-key-response if
      cmn-warn[ " Unable to store security key" ]cmn-end
   then
   key-close
;

: keystore-delete  ( $name -- )
   check-key-channel-state if  
      cmn-warn[ " Unable to Delete Security key" ]cmn-end
      2drop exit
   then
   assemble-unset-pkt			( buf len )
   key-svc-handle send-ds-data ?dup if	(  | status )
      LDC-NOTUP = if 		( )
         cmn-warn[ " Sending Keystore Delete request but LDC is Not Up!" ]cmn-end
         \ Mark the service closed so that it can be opened again
         KEY-CLOSED to key-service-state	(  )
      else
         key-close				( )
      then
      cmn-warn[ " Keystore Delete request failed!" ]cmn-end
      exit				( )
   then					( )
   wait-for-key-response if
      cmn-warn[ " Unable to Delete security key" ]cmn-end
   then
   key-close
;

\ Get the next string property in MD node
: get-next-str-prop  ( node prop -- ent|0 )
   begin				( node prop )
       over swap md-next-prop dup	( node prop,prop|0,0 )
   while
      dup md-prop-type ascii s = if	( node prop )
         nip exit			( prop )
      then				( node prop )
   repeat
   nip					( 0 )
;

\ Load security keys from the "keystore" MD node.  We do this before
\ initializing the domain service to avoid redundant keystore-set calls
: get-keystore  ( -- )
   0 " keystore" md-find-node ?dup 0= if  exit  then
   0						( node 0 )
   begin
      over swap get-next-str-prop ?dup		( [ node prop prop ] | [ node 0 ] )
   while
      dup md-decode-prop drop			( node prop $data )
      2 pick md-prop-name			( node prop $data $name )
      2swap convert-key drop			( node prop $name data,len )
      (set-security-key) drop			( node prop )
   repeat
   drop
;

\ Load keystore updates from a mini MD
\ 1. Set keys as they appear under the keystore node
\ 2. If the entry name is the reserved word "_delete"... delete the given
\    in the property data field
: update-keystore  (  -- )
   keystore-updates-buf >key-updates-payload md-set-working-md
   0 " keystore" md-find-node ?dup if
      0					( node 0 )
      begin
	 over swap get-next-str-prop ?dup ( [ node prop prop ] | [ node 0 ] )
      while
	 dup md-decode-prop drop	( node prop $data )
	 2 pick md-prop-name		( node prop $data $name )
	 2dup " _delete" $= if		( node prop $data $name )
	    \ len 0 key = delete
	    drop 0 (set-security-key)	( node prop error? )
	    drop			( node prop )
	 else
	    2swap convert-key drop	( node prop $name data,len )
	    (set-security-key) drop	( node prop )
	 then				( node prop )
       repeat
       drop				(  )
    then
    0 md-set-working-md			\ This Line is VERY IMPORTANT
;

\ Request a "mini'MD" from the SP that contains any changes to the
\ keystore MD node since it last created a guest MD
: get-keystore-updates  ( -- )
   check-key-channel-state if
      exit
   then
   \ Only meaningful when talking to the SP
   keystore-backup? if
      MAX-UPDATES-SIZE alloc-mem to keystore-updates-buf
      assemble-updates-req-pkt		( pkt len )
      key-svc-handle send-ds-data ?dup if  (  | status )
         LDC-NOTUP = if 		( )
	    cmn-warn[
	       " Sending Keystore Update request but LDC is Not Up!"
	    ]cmn-end
	    \ Mark the service closed so that it can be opened again
            KEY-CLOSED to key-service-state	( )
         else
            key-close				( )
         then
	 cmn-warn[ " Error sending Keystore Updates request" ]cmn-end
	 keystore-updates-buf MAX-UPDATES-SIZE free-mem
	 exit				(  )
      then				(  )
      wait-for-updates-response 0= if	(  )
	 update-keystore		(  )
      then				(  )
      keystore-updates-buf MAX-UPDATES-SIZE free-mem
   then					(  )
   key-close				(  )
;

previous		\ ldc

headerless

stand-init: Security Key Domain Service Init
   get-keystore
   get-keystore-updates
   ['] keystore-set    is key-set
   ['] keystore-delete is key-delete
;

previous definitions