#!/usr/local/bin/newlisp

;;
;; @module yubi
;; @author Kirill Miazine, km@krot.org
;; @version 0.1
;; @description Verify YubiKey one time passwords.
;; @location http://km.krot.org/code/newlisp/yubi.lsp
;;
;; This software is distributed under an ISC-style @link http://km.krot.org/code/license.txt license.
;;
;; newLISP library to verify @link http://www.yubikey.com/ YubiKey one time passwords.
;; The library implements YubiKey Validation Protocol version 2.0, as described in the
;; @link http://code.google.com/p/yubikey-val-server-php/wiki/ValidationProtocolV20 specificiation.
;;
;; This library will query following servers: <api.yubico.com>, <api2.yubico.com>,
;; <api3.yubico.com>, <api4.yubico.com> and <api5.yubico.com>. By setting 'yubi:PARALLEL' to an
;; integer from 1 to 5, it is possible to select how many servers the library will query.
;; If 'yubi:PARALLEL' is lower than 5, then the server(s) to query will be selected randomly.
;; By default, 2 servers will be queried in parallel.
;;
;; <h2>Requirements</h2>
;; Following libraries need to be obtainted and loaded first:
;; <ul>
;;   <li> @link http://www.newlisp.org/code/modules/crypto.lsp.html crypto.lsp </li>
;;   <li> @link https://raw.github.com/kanendosei/artful-newlisp/master/web.lsp web.lsp </li>
;; </ul>
;; Yubico <API key> and <API id> are also
;; @link http://api.yubico.com/get-api-key/ required.
;;
;;
;; @syntax (yubi:verify <otp-str>)
;; @param <otp-str> A string with a YubiKey one time password to verify
;; @return <true> on successfull authentication, <nil> otherwise
;; @example
;; #!/usr/local/bin/newlisp
;;
;; ; Save this as a file and run from command line, giving the YubiKey OTP as the first argument
;;
;; (load "/usr/local/share/newlisp/modules/crypto.lsp")
;; (load "/usr/local/share/newlisp/modules/web.lsp")
;; (load "/usr/local/share/newlisp/modules/yubi.lsp")
;;
;; ; API id and key "borrowed" from http://demo.yubico.com/php-yubico/demo.php
;; (setq yubi:API_ID 1851)                            ; API id
;; (setq yubi:API_KEY "oBVbNt7IZehZGR99rvq8d6RZ1DM=") ; Base64 encoded API key
;;
;; (println (yubi:verify (main-args 2)))
;; (exit)

(context 'yubi);

(setq API_ID 1851)
(setq API_KEY "oBVbNt7IZehZGR99rvq8d6RZ1DM=")
(setq PARALLEL 2)

(define (sorted-query params)
  (Web:build-query (map (fn (x) (list (x 0) (string (x 1))))
                        (sort (filter (fn (x) (true? (x 1))) params) (fn (x y) (< (x 0) (y 0)))))))

(define (hmac-sig key params (sorted? nil))
  (base64-enc (crypto:hmac crypto:sha1 (if sorted? params (sorted-query params)) (base64-dec key))))

(define (signed-query key params)
;  (append (sorted-query params) "&h=" (Web:url-encode (hmac-sig key params))))
;  avoid BAD_SIGNATURE, as in http://code.google.com/p/php-yubico/source/browse/trunk/Yubico.php
  (append (sorted-query params) "&h=" (replace "+" (hmac-sig key params) "%2B")))

(define (check-otp otp url , res)
  (setq res (get-url url 15000))
  (if (and (find (string "otp=" otp) res) (find "status=OK" res))
    (let (res (clean empty? (parse res "\r?\n" 0)))
      (if (= ((filter (fn (x) (starts-with x "h=")) res) 0)
             (string "h=" (hmac-sig API_KEY
                                    (join (sort (clean (fn (x) (starts-with x "h=")) res)) "&")
                                    true)))
        true nil)) nil))

(define (verify otp , req-params uri-map (res-map '()))
  (setq req-params (map (fn (x) (list (string x) nil)) '(id otp timestamp nonce sl timeout)))

  (setf (lookup "id" req-params) API_ID)
  (setf (lookup "otp" req-params) otp)
  (setf (lookup "nonce" req-params) (replace "-" (uuid) "" 1))

  (setq uri-map (randomize
                  (map (fn (x) (format "http://api%s.yubico.com/wsapi/2.0/verify?%s"
                                       (list (string x) (signed-query API_KEY req-params))))
                       '("" 2 3 4 5))))

  (dotimes (x (min PARALLEL (length uri-map)))
    (push (sym (format "api-res-%d" x)) res-map)
    (spawn (res-map 0) (check-otp otp (uri-map x))))
  (until (sync 200) (sleep 20))

  (if (filter true? (map eval res-map)) true nil))

(context 'MAIN);
; vim: set tw=100 ts=2 fileencoding=utf8 ft=lisp et: