;; @module amazon 
;; @description Functions for the Amazon-AWS EC2, S3 REST API
;; @version 0.01 - initial development release
;; @version 0.02 - added EC2 API
;; @version 0.03 - clean-up documentation and amazon:url-encode
;; @author Lutz Mueller 2007, Martin Quiroga 2007
;;
;; <h2>Requirements</h2>
;; As a minimum newLISP version 9.2.8 is required for this module.
;; <br><br>
;; The module depends on crypto.lsp, which implements HMAC 
;; RFC-2104 authentication and itself depends on the C library 'libcrypto'.
;; <br><br>
;; For a descripion of the Amazon Web Services (AWS) REST APIs implemented
;; see: @link http://developer.amazonwebservices.com/ http://developer.amazonwebservices.com/
;;
;; <h2>Usage</h2>
;; Call the 'amazon:set-AWS-credentials' function once after loading this module, then use
;; any of the other functions.
;; 
;; Almost all functions allow for an optional timeout parameter in milliseconds. When no 
;; timeout is given all functions assume 30 seconds timeout.
;;
;; The functions return either a header or a SXML list on success, or 'nil' on failure.
;; On failure the variable 'amazon:error' contains the text of the last error occured.
;;

(load (append (env "NEWLISPDIR") "/modules/crypto.lsp"))

(context 'amazon)

(define AWS-account-no)
(define AWS-access-key)
(define AWS-secret-key)

(define result) ; the last return from a REST call

(define AWS-ec2-version "2007-08-29")
(define AWS-ec2-url "https://ec2.amazonaws.com/")


;; @syntax (amazon:set-AWS-credentials <acount> <access-key> <secret-key>)
;; @param <account> The acount number to set.
;; @param <access-key> The AWS access-key-id to set.
;; @param <secret-key> The AWS secret access-key-id to set.
;; @return Returns 'true'
;;
;; The EC2 account number AWS-access-key and AWS secret-key credentials should be called 
;; first, before calling any other function in the Amazon interface.
;;
;; @example
;; (amazon:set-AWS-credentials 
;;     "123456789012"  ; EC2 account number (not used by S3)
;;     "01234ABCDE56789GHIK" ; access key 
;;     "01ab23cd45EF56789+WXYZ987+abcdeLKJH789zz" ; secret access key
;; )
;;

(define (amazon:set-AWS-credentials account access-key secret-key)
	(if (!= 12 (length account)) (throw-error "wrong format in Amazon account number"))
	(if (!= 20 (length access-key)) (throw-error "wrong format in Amazon access key number"))
	(if (!= 40 (length secret-key)) (throw-error "wrong format in Amazon secret key number"))
	(set 'AWS-account-no account)
	(set 'AWS-access-key access-key)
	(set 'AWS-secret-key secret-key)
	true
)

;; @syntax (amazon:create-bucket <str-bucket-name> [<int-timeout>])
;; @param <str-bucket-name> The name of the bucket i.e.: 'my-bucket'
;; @param <int-timeout> The number of milliseconds to wait.
;; @return Returns header information or 'nil' on failure.
;;
;; Creates an Amazon S3 bucket.
;;
;; @example
;; (amazon:create-bucket "my-bucket")
;; (amazon:create-bucket "my-bucket" 20000)

;; The first statement reates 'my-bucket' with a default timeout of 30 seconds.
;; On the second statement carries 20 second timeout limit.

(define (amazon:create-bucket bucket-name (timeout 30000), sign-str date-stamp)
	(set 'date-stamp (amazon:date))
	(set 'sign-str (append "PUT\n\ntext/html\n" date-stamp "\n" "/" bucket-name))
	(set 'result (put-url 
		;(append "http://s3.amazonaws.com") 
		(append "http://s3.amazonaws.com" "/" bucket-name) 
		"" ; empty payload
		"list"
		timeout
		(append  ; add date and Authorization info to the string
			"Content-type: text/html\r\n"
			"Date: " date-stamp "\r\n"
			"Authorization: " (authorization sign-str) "\r\n"
		)
	))
	(if (empty? (result 1)) 
		(result 0)
		(begin
			(set 'amazon:error (result 1))
			nil)
	)
)

;; @syntax (amazon:delete-bucket <str-bucket-name> [<int-timeout>])
;; @param <str-bucket-name> The name of the bucket i.e.: 'my-bucket'
;; @param <int-timeout> The number of milliseconds to wait.
;; @return Returns amzon header string or 'nil' on failure.
;;
;; Deletes an Amazon S3 bucket. Deleting a non-existing bucket will
;; fail with 'nil'.
;;
;; @example
;; (amazon:delete-bucket "my-bucket")

;; Deletes 'my-bucket'.

(define (amazon:delete-bucket bucket-name (timeout 30000), sign-str date-stamp)
	(set 'date-stamp (amazon:date))
	(set 'sign-str (append "DELETE\n\n\n" date-stamp "\n" "/" bucket-name))
	(set 'result (delete-url 
		(append "http://s3.amazonaws.com" "/" bucket-name) 
		"list"
		timeout
		(append  ; add date and Authorizatio info to the string
			"Date: " date-stamp "\r\n"
			"Authorization: " (authorization sign-str) "\r\n"
		)
	))
	(if (empty? (result 1)) 
		(result 0)
		(begin
			(set 'amazon:error (result 1))
			nil)
	)
)

;; @syntax (amazon:list-all-buckets [<int-timeout>])
;; @param <int-timeout> The number of milliseconds to wait.
;; @return Returns Amazon REST S3 SXML results or 'nil' on failure.
;;
;; Lists all the S3 buckets for the account, for which credentials
;; were given.
;;
;; @example
;; (amazon:list-all-buckets) 

;; Lists all buckets.
			
(define (amazon:list-all-buckets (timeout 30000) , date-stamp str-sign)
	(set 'date-stamp (amazon:date))
	(set 'str-sign (append "GET\n\n\n" date-stamp "\n" "/" ))
	(set 'result (get-url "http://s3.amazonaws.com" 
		timeout 
		(append  ; add date and Authorization info to the string
			"Date: " date-stamp "\r\n"
			"Authorization: " (authorization str-sign) "\r\n"
		)
	))
	(if (not (starts-with result "ERR:"))
		(begin
			(xml-type-tags nil nil nil nil)
			(xml-parse result 31))
		(begin
			(set 'amazon:error result)
			nil)
	)
)


;; @syntax (amazon:list-bucket <str-bucket-name> [<str-query> [<int-timeout>]])
;; @param <str-bucket-name> The name of the bucket, i.e. 'my-bucket'
;; @param <str-query> The optional query string which by default is assumed to be the empty string.
;; @param <int-timeout> The number of milliseconds to wait.
;; @return Returns Amazon REST S3 SXML results or 'nil' on failure.
;;
;; Lists the contents of a bucket. Optionally a query string can be given
;; to list only a subset of buckets. The query string must be URL encoded 
;; and has the usual form of key-value pairs separated by a '&' sign, 
;; i.e. 'prefix=photos&marker=puppies' etc.
;;
;; @example
;; (amazon:list-bucket "my-bucket")
;;
;; (amazon:list-bucket "my-bucket" "prefix=photos" 10000)

;; In the first statement All objects in 'my-bucket' are listed (the query string is empty). 
;; The second statement lists all objects in 'photos' and allows a timeout of 10 seconds.

			
(define (amazon:list-bucket bucket-name (query "") (timeout 30000) , date-stamp str-sign url)
	(set 'date-stamp (amazon:date))
	(set 'str-sign (append "GET\n\n\n" date-stamp "\n" "/" bucket-name "/"))
	(set 'url (append "http://" bucket-name ".s3.amazonaws.com"))
	(if (!= "" query)
		(set 'url (append url "/?" query)))
	(set 'result (get-url url
		timeout
		(append  ; add date and Authorization info to the string
			"Date: " date-stamp "\r\n"
			"Authorization: " (authorization str-sign) "\r\n"
		)
	))
	(if (not (starts-with result "ERR:"))
		(begin
			(xml-type-tags nil nil nil nil)
			(xml-parse result 31))
		(begin
			(set 'amazon:error result)
			nil)
	)
)

;; @syntax (amazon:put-bucket-object <str-bucket-name> <str-object-name> <str-content-type> <buff-pay-load> [<int-timeout>])
;; @param <str-bucket-name> The name of the bucket, i.e. 'my-bucket'.
;; @param <str-object-name> The name of the object, i.e. 'foo'.
;; @param <str-content-type> The content-type of the data, i.e. 'text/html'.
;; @param <buff-pay-load> The data of the object in a string buffer.
;; @param <int-timeout> The number of milliseconds to wait.
;;
;; Puts an object into a bucket. An exisiting object will get overwritten.
;; @example
;; (amazon:put-bucket-object "my-bucket" "puppy.jpg" "image/jpeg" (read-file "puppy.jpg") )
;;

;; Note that <str-object-name> can contains sub directory like prefixes separated by a forward slash:
;; @example
;; (amazon:put-bucket-object "my-bucket" "category/TheThing" "text/html" "The content" )
;; 

;; The statement reads a file 'puppy.jpg' and uploads it to 'my-bucket'. In the second
;; example a sub directory 'category' will automatically be created.


(define (amazon:put-bucket-object bucket-name object-name content-type pay-load (timeout 30000) , 
				date-stamp str-sign)
	(set 'date-stamp (amazon:date))
	(set 'str-sign (append "PUT\n\n" content-type "\n" date-stamp "\n" "/" bucket-name "/" object-name))

	(set 'result (put-url (append "http://" bucket-name ".s3.amazonaws.com/" object-name)
		pay-load
		"list"
		timeout
		(append  ; add date and Authorization info to the string
			"Content-type: " content-type "\r\n"
			"Date: " date-stamp "\r\n"
			"Authorization: " (authorization str-sign) "\r\n"
		)
	))
	(if (empty? (result 1)) 
		(result 0)
		(begin
			(set 'amazon:error (result 1))
			nil)
	)

)


;; @syntax (amazon:get-bucket-object <str-bucket-name> <str-object-name> [<int-timeout>])
;; @param <str-bucket-name> The name of the bucket, i.e. 'my-bucket'.
;; @param <str-object-name> The name of the object, i.e. 'foo'.
;; @param <int-timeout> The number of milliseconds to wait.
;;
;; Gets an object from a bucket.
;;
;; @example
;; (amazon:get-bucket-object "my-bucket" "puppy.jpg")

;; Downloads 'puppy.jpg'.

;; Note that <str-object-name> can contain sub directory like prefixes, separated by a forward slash:
;; @example
;; (amazon:get-bucket-object "my-bucket" "category/TheThing") =&gt; "The content"
;; 

(define (amazon:get-bucket-object bucket-name object-name (timeout 30000) , date-stamp str-sign)
	(set 'date-stamp (amazon:date))
	(set 'str-sign (append "GET\n\n\n" date-stamp "\n" "/" bucket-name "/" object-name))
	(set 'result (get-url (append "http://" bucket-name ".s3.amazonaws.com/" object-name)
		timeout
		(append  ; add date and Authorization info to the string
			"Date: " date-stamp "\r\n"
			"Authorization: " (authorization str-sign) "\r\n"
		)
	))
	(if (not (starts-with result "ERR:"))
		result
		(begin
			(set 'amazon:error result)
			nil)
	)
)


;; @syntax (amazon:delete-bucket-object <str-bucket-name> <str-object-name> [<int-timeout>])
;; @param <str-bucket-name> The name of the bucket, i.e. 'my-bucket'.
;; @param <str-object-name> The name of the object to be deleted, i.e. 'foo'.
;; @param <int-timeout> The number of milliseconds to wait.
;;
;; Deletes an object from a bucket. Note that deleting with a non-exisiting <str-object-name>
;; will not result in error, but a wrong <str-bucket-name> will result in error.
;;
;; @example
;; (amazon:delete-bucket-object "my-bucket" "puppy.jpg")

;; Deletes the file "puppy.jpg".

;; Note that <str-object-name> can contain sub directory like prefixes separated by a forward slash:
;; @example
;; (amazon:delete-bucket-object "my-bucket" "category/TheThing") 
;; 

(define (amazon:delete-bucket-object bucket-name object-name (timeout 30000) , date-stamp str-sign)
	(set 'date-stamp (amazon:date))
	(set 'str-sign (append "DELETE\n\n\n" date-stamp "\n" "/" bucket-name "/" object-name))
	(set 'result (delete-url (append "http://s3.amazonaws.com/" bucket-name "/"  object-name)
		"list"
		timeout
		(append  ; add date and Authorization info to the string
			"Date: " date-stamp "\r\n"
			"Authorization: " (authorization str-sign) "\r\n"
		)
	))
	(if (empty? (result 1)) 
		(result 0)
		(begin
			(set 'amazon:error (result 1))
			nil)
	)
)


;; @syntax (amazon:ec2-query <list-query-parameters>)
;; @param <list-query-parameters> Is an assoc-list of string key and value pairs corresponding to EC2 Actions and their respective parameters.
;; @return Returns an SXML list corresponding to the return XML of the query, or nil on failure.
;;
;; The full Amazon EC2 API documentation can be found here:
;; @link http://docs.amazonwebservices.com/AWSEC2/2007-08-29/DeveloperGuide/ EC2_Developer_Guide
;;
;; This API implementation is based on the EC2 Query API described in the documentation. For
;; any EC2 Operation the only required element of the query parameter list is the '"Action"'
;; element and can take the form of:
;;
;; For Image Actions:<br>
;;     '"RegisterImage" "DescribeImages" "DeregisterImage"'
;;
;; For Instance Actions:<br>
;;     '"RunInstances" "DescribeInstances" "TerminateInstances" "ConfirmProductInstance"'
;;
;; For Key Pair Actions:<br>
;;     '"CreateKeyPair" "DescribeKeyPairs" "DeleteKeyPair"'
;;
;; For Image Attribute Actions:<br> 
;;     '"ModifyImageAttribute" "DescribeImageAttribute" "ResetImageAttribute"'
;;
;; For Security Group Actions:<br>
;;     '"CreateSecurityGroup" "DescribeSecurityGroups" "DeleteSecurityGroup"'<br>
;;     '"AuthorizeSecurityGroupIngress" "RevokeSecurityGroupIngress"'
;;
;; The full list of Actions and their corresponding parameters can be found here:
;; @link http://docs.amazonwebservices.com/AWSEC2/2007-08-29/DeveloperGuide/AESDG-query-by-function.html Operations_by_Function
;;
;; @example
;; (amazon:ec2-query (list
;;             (list "Action" "DescribeInstances")
;;             (list "InstanceId" (list "i-564fa43f" "i-e320c98a"))))

;; If a given Action handles multiple paramters of the same type, these can be provided as a list of values

(define (amazon:ec2-query param_list)
  (set 'q_str "?")
  (set 'cred_str "")
  (unless (lookup "Version" param_list)
    (push (list "Version" AWS-ec2-version) param_list -1)
  )
  (unless (lookup "Timestamp" param_list)
    (push (list "Timestamp" (amazon:ec2-date)) param_list -1)
  )
  (unless (lookup "SignatureVersion" param_list)
    (push (list "SignatureVersion" 1) param_list -1)
  )
  (unless (lookup "AWSAccessKeyId" param_list)
    (unless AWS-access-key
      (throw-error "You must first set you AWS credentials using the set-AWS-credentials function.")
      (push (list "AWSAccessKeyId" AWS-access-key) param_list -1)
    )
  )
  (unless (lookup "Action" param_list)
    (throw-error "You must provide an Action.")
  )
  (dolist (p (sort param_list  ;; sort the lower-cased list keys to get proper AWS ordering
    (fn (a b)
      (if (= (lower-case (first a)) (first (sort (list (lower-case (first a)) (lower-case (first b))))))
        a
      )
    )))
    (if (list? (set 'p_list (last p)))
      (dotimes (i (length p_list))
        (push (string (url-encode (first p)) "." i "=" (url-encode (string (p_list i))) "&") q_str -1)
        (push (string (first p) "." i (p_list i)) cred_str -1)
      )
      (begin
        (push (string (url-encode (first p)) "=" (url-encode (string (last p))) "&") q_str -1)
        (push (string (first p) (last p)) cred_str -1)
      )
    )
  )
  (if (set 'get-return (get-url (string AWS-ec2-url (chop q_str) "&Signature=" (amazon:url-encode (amazon:authorization cred_str 1)))))
    (begin
      (xml-type-tags nil nil nil nil)
      (xml-parse get-return (+ 1 2 4 8 16))
    )
  )
)


;; @syntax (amazon:authorization <str-sign> [<int-option>]) 
;; @param <str-sign> The string to sign.
;; @param <int-option> Integer value to toggle between the S3 and EC2 styles of signatures. 
;;
;; The <int-option> parameter, when set to <tt>0</tt> is for the S3 style of signature and 
;; <tt>1</tt> is for the EC2 style.If no value is provided, the default is S3 style.
;;
;; In the case of the S3 style, 'amazon:authorization' returns an authorization string of the form: 
;; 'AWS access-key:signature' where access-key is a 20 byte long key given
;; by Amazon when signing up for Amazon Web Services (AWS) and signature is
;; a 28 byte long BASE64 encoded string resulting from an 'crypto:hmac' signing of
;; the <str-sign> with the <secret-access-key>.
;;
;; In the case of the EC2 style, 'amazon:authorization' simply returns
;; a 28 byte long BASE64 encoded string resulting from an 'crypto:hmac' signing of
;; the <str-sign> with the <secret-access-key>. 
;;
;; This function is used by other functions in this API.

(define (amazon:authorization str-sign int-option)
  (unless (or AWS-secret-key AWS-access-key)
    (throw-error "You must first set you AWS credentials using the set-AWS-credentials function.")
    (unless (or int-option (= int-option 0))
      (append "AWS " AWS-access-key ":"
        (base64-enc (crypto:hmac crypto:sha1 str-sign AWS-secret-key)))
      (base64-enc (crypto:hmac crypto:sha1 str-sign AWS-secret-key))
    )
  )
)


;; @syntax (amazon:date [<offset>])
;; @param <offset> The offset in minutes from the local time. 
;;
;; Returns the current time string in Internet format, i.e: 'Fri, 23 Nov 2007 12:06:39 +0000'
;; for signing HTTP requests in the Amazon AWS interface and usage in HTTP headers.
;; The <offset> parameter is optional, when no offset is given the date string returned
;; is based on GMT and finishes with the letters 'GMT', else the string is based on
;; the local time and finishes with the '+nnnn' or -nnnn' offset number given in <offset>.
;;
;; @example
;; (amazon:date) =&gt; "Mon, 26 Nov 2007 20:08:13 GMT"
;; (amazon:date 300) =&gt; "Mon, 26 Nov 2007 15:08:17 +0300"
 
;; This functions is also used by other functions in this API.

(define (amazon:date offset)
	(if (not offset)
		(MAIN:date (date-value) ((now) -2) "%a, %d %b %Y %H:%M:%S GMT")
		(let (dfmt (MAIN:date (date-value) 0 "%a, %d %b %Y %H:%M:%S"))
			(append dfmt (format " %+05d" offset)))
	)
)

;; @syntax (amazon:ec2-date [<int-unix-time]>)
;; @param <int-unix-time> The time in seconds elapsed since midnight UTC of January 1, 1970. 
;;
;; Returns a time string of the format '2007-12-04T14:04:24-0800' as specified in the ISO 8601
;; standard for signing EC2 Query API requests. The <int-unix-time> parameter is optional, when this
;; is not provided the current time is used as a default value.
;;
;; @example
;; (amazon:ec2-date) =&gt; "2007-12-04T16:15:00-0800"
;; (amazon:ec2-date (+ (date-value) 300)) =&gt; "2007-12-04T16:20:00-0800"
 
;; This functions is also used by other functions in this API.

(define (amazon:ec2-date (epoch (date-value)))
  (MAIN:date epoch 0 "%Y-%m-%dT%H:%M:%S%z")
)


;; @syntax (amazon:url-encode <str>)
;; @param <str> The string to URL encode.
;;
;; @return Returns a url-encoded (e.g. percent-encoded) string of the input string. 
;;
;; @example
;; (amazon:url-encode "2007-12-04T14:06:31-0800") =&gt; "2007-12-04T14%3a06%3a31-0800"

; note that space to plus translation is redundant on encode, because
; spaces are % escaped too
(define (amazon:url-encode str)
   (replace {([^\w\-._])} str (format "%%%x" (char $1)) 0)
)


;; @syntax (amazon:url-decode <str>)
;; @param <str> The URL-encoded string to decode.
;;
;; Returns a decoded string of the url-encoded (e.g. percent-encoded) input string. 
;;
;; @example
;; (amazon:url-decode "2007-12-04T14%3a06%3a31-0800") =&gt; "2007-12-04T14:06:31-0800"

(define (amazon:url-decode str)
   (replace "+" str " ") ; translate for compatibility
   (replace "%([0-9A-F][0-9A-F])" str (char (int (append "0x" $1))) 1)
)

; eof ;