json-newuser

src/client-json.lisp

@@ -4,13 +4,13 @@
 ;;;
 ;;; The Truledger JSON webapp server
 ;;;
-;;; See www/docs/json.txt for spec
+;;; See www/docs/json.txt (http://truledger.com/doc/json.txt) for spec.
 ;;;
 
 (in-package :truledger-json)
 
 ;; Called from do-truledger-json in server-web.lisp
-;; Returns a string with the contents of the client web page.
+;; Returns a JSON string.
 (defun json-server ()
   (let* ((client (make-client (client-db-dir))))
     (let* ((res (catch 'error-return
@@ -28,8 +28,8 @@
 
 (defun json-error (format-string &rest format-args)
   (throw 'error-return
-    `((@type . error)
-      (message . ,(apply #'format nil format-string format-args)))))
+    `(("@type" . "error")
+      ("message" . ,(apply #'format nil format-string format-args)))))
 
 (defparameter *json-commands*
   '("newuser"
@@ -54,7 +54,6 @@
     "getassets"
     "addasset"
     "getfees"
-    "setfees"
     "getbalance"
     "getbalances"
     "getrawbalances"
@@ -139,10 +138,96 @@
                                     val-form)))
          ,@body))))
 
+(defun parse-proxy (proxy)
+  (check-type proxy (or null string))
+  (unless (blankp proxy)
+    (let ((colon-pos (position #\: proxy :from-end t)))
+      (unless colon-pos
+        (json-error "Proxy must be host:port"))
+      (let ((host (subseq proxy 0 colon-pos))
+            (port (subseq proxy (1+ colon-pos))))
+        (unless (ignore-errors
+                  (setf port (parse-integer port)))
+          (json-error "Proxy port not an integer: ~s" proxy))
+        (when (string-equal host "localhost")
+          (setf host "127.0.0.1"))
+        (list host port)))))
+
+(defun ensure-string (var name &optional optionalp)
+  (unless (or (and optionalp (null var))
+              (stringp var))
+    (json-error "~a must be a string" name)))
+
+(defun ensure-integer (var name &optional optionalp)
+  (unless (or (and optionalp (null var))
+              (integerp var))
+    (json-error "~a must be an integer" name)))
+
 (defun json-newuser (client args)
-  client
-  (with-json-args (passphrase size privkey coupon proxy) args
-    (list passphrase size privkey coupon proxy)))
+  (with-json-args (passphrase) args
+    (unwind-protect
+         (json-newuser-internal client passphrase args)
+      (when (stringp passphrase)
+        (destroy-password passphrase)))))
+
+(defun json-newuser-internal (client passphrase args)
+  (with-json-args (keysize name privkey fetch-privkey? url coupon proxy)
+      args
+    (ensure-string passphrase "passphrase")
+    (ensure-integer keysize "keysize" t)
+    (ensure-string name "name" t)
+    (ensure-string privkey "privkey" t)
+    (ensure-string url "url" t)
+    (ensure-string coupon "coupon" t)
+    (ensure-string proxy "proxy" t)
+    (when (cond (keysize (or privkey fetch-privkey?))
+                (privkey fetch-privkey?)
+                ((not fetch-privkey?)
+                 (json-error
+                  "One of keysize, privkey, and fetch-privkey? must be included")))
+      (json-error
+       "Only one of keysize, privkey, and fetch-privkey? may be included"))
+    (when (and url coupon)
+      (error "Only one of url and coupon may be included"))
+    (when (passphrase-exists-p client passphrase)
+      (json-error "There is already a client account for passphrase"))
+    (when proxy
+      (setf proxy (parse-proxy proxy)))
+    (when fetch-privkey?
+      (unless url
+        (json-error "url required to fetch private key from server"))
+      (verify-server client url nil proxy)
+      (when fetch-privkey?
+        (handler-case
+            (setf privkey (fetch-privkey client url passphrase
+                                         :http-proxy proxy))
+          (error (c)
+            (json-error "Error fetching private key from ~a: ~a"
+                        url c)))))
+    (cond ((and privkey url)
+           ;; Make sure we've got an account.
+           (verify-private-key client privkey passphrase url proxy))
+          ((not coupon)
+           (when (server-db-exists-p)
+             (json-error "Coupon must be included to create new account")))
+          (t
+           (let ((url (parse-coupon coupon)))
+             (handler-case
+                 (verify-coupon client coupon nil url :http-proxy proxy)
+               (error (c)
+                 (json-error "Coupon didn't verify: ~a" c))))))
+    (newuser client :passphrase passphrase :privkey (or privkey keysize))
+    (let ((session (login-new-session client passphrase)))
+      ;; Not calling maybe-start-server here. Maybe I should
+      (handler-case
+          (addserver client (or coupon url) :name name :couponok t
+                     :http-proxy proxy)
+        (error (c)
+          (logout client)
+          (json-error "Failed to add server: ~a" c)))
+      (when fetch-privkey?
+        (setf (privkey-cached-p client) t))
+      session)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;

src/client-web.lisp

@@ -347,14 +347,6 @@
 (defun settitle (cw subtitle)
   (setf (cw-title cw) (stringify subtitle "~a - Truledger Client")))
 
-(defun server-db-exists-p ()
-  (or (ignore-errors (get-running-server))
-      (server-privkey-file-exists-p)))
-
-(defun server-privkey-file-exists-p ()
-  (let ((db (make-fsdb (server-db-dir))))
-    (not (null (db-get db $PRIVKEY)))))
-
 (defun is-local-server-server-p (cw &optional (acceptor hunchentoot:*acceptor*))
   (let* ((port (acceptor-port acceptor))
          (server (port-server port))
@@ -372,12 +364,6 @@
                                     (getarg 2 (car reqs)))))))))
         (and (not server) (not (server-db-exists-p))))))
 
-(defun get-running-server ()
-  (port-server (get-current-port)))
-
-(defun get-current-port (&optional (acceptor hunchentoot:*acceptor*))
-  (acceptor-port acceptor))
-
 (defun setmenu (cw &optional highlight (menuitems *default-menuitems*))
   (let ((items nil)
         (client (cw-client cw)))

src/client.lisp

@@ -92,6 +92,9 @@
 
 ;; API Methods
 
+(defmethod passphrase-exists-p ((client client) passphrase)
+  (not (null (db-get (db client) $PRIVKEY (passphrase-hash passphrase)))))
+
 (defmethod newuser ((client client) &key passphrase (privkey 3072))
   "Create a new user with the given passphrase, error if already there.
    If privkey is a string, use that as the private key.
@@ -176,6 +179,7 @@
       (setf (privkey client) nil)
       (rsa-free privkey))
     (setf (serverid client) nil
+          (pubkey client) nil
           (server client) nil)))
 
 ;; All the API methods below require the user to be logged in.
@@ -279,7 +283,7 @@
    Ask the server whether a coupon of that number exists."
   (let ((parser (parser client))
         (coupon-number (nth-value 1 (parse-coupon coupon))))
-    (verify-server client url serverid http-proxy)
+    (setf serverid (verify-server client url serverid http-proxy))
     (let* ((msg (strcat "(0," $SERVERID ",0," coupon-number "):0"))
            (server (make-server-proxy
                     (make-client (db client)) url :http-proxy http-proxy))
@@ -288,7 +292,33 @@
       (match-serverreq client (car reqs) $REGISTER serverid)
       (unless (eql 2 (length reqs))
         (error "verifycoupon: expected 2 messages from server"))
-      (match-serverreq client (cadr reqs) $COUPONNUMBERHASH serverid))))
+      (match-serverreq client (cadr reqs) $COUPONNUMBERHASH serverid)
+      serverid)))
+
+(defmethod verify-private-key ((client client) privkey passphrase url
+                               &optional http-proxy)
+  "Verify that privkey has an account with the server at URL.
+Error if it does not. If it does, return two values:
+1) The server id
+2) The id for privkey"
+  (let ((serverid (verify-server client url nil http-proxy)))
+    (with-rsa-private-key (pk privkey passphrase)
+      (let* ((pubkey (encode-rsa-public-key pk))
+             (id (pubkey-id pubkey))
+             (client (make-client (db client)))
+             (parser (parser client))
+             (server (make-server-proxy client url :http-proxy http-proxy)))
+        (setf (id client) id
+              (privkey client) pk
+              (get-keydict parser id) pubkey)
+        (let* ((msg (process server (custmsg client $ID serverid id)))
+               (reqs (parse parser msg))
+               (args (match-serverreq client (car reqs) $ATREGISTER serverid)))
+          (setf args (getarg $MSG args))
+          (unless (and (equal $REGISTER (getarg $REQUEST args))
+                       (equal id (getarg $CUSTOMER args)))
+            (error "Malformed ~s message from server" $REGISTER))
+          (values serverid id))))))
 
 ;; Returns three values:
 ;;   1) serverid

src/crypto-api.lisp

@@ -150,15 +150,15 @@
           (rsa-free key)))
       (funcall thunk key)))
 
-(defmacro with-rsa-private-key ((keyvar key) &body body)
+(defmacro with-rsa-private-key ((keyvar key &optional password) &body body)
   (let ((thunk (gensym)))
     `(flet ((,thunk (,keyvar) ,@body))
        (declare (dynamic-extent #',thunk))
-       (call-with-rsa-private-key #',thunk ,key))))
+       (call-with-rsa-private-key #',thunk ,key ,password))))
 
-(defun call-with-rsa-private-key (thunk key)
+(defun call-with-rsa-private-key (thunk key &optional password)
   (if (stringp key)
-      (let ((key (decode-rsa-private-key key)))
+      (let ((key (decode-rsa-private-key key password)))
         (unwind-protect
              (funcall thunk key)
           (rsa-free key)))

src/package.lisp

@@ -281,6 +281,7 @@
    #:match-message
    #:tokenize
    #:remove-signatures
+   #:get-keydict
 
    ;; bcmath.lisp
    #:bccomp
@@ -443,6 +444,10 @@
    #:port-forwarded-from
    #:acceptor-port
    #:bind-parameters
+   #:get-running-server
+   #:get-current-port
+   #:server-db-exists-p
+   #:server-privkey-file-exists-p
 
    ;; toplevel.lisp
    #:write-application-name
@@ -483,6 +488,7 @@
    #:keep-history-p
    #:server-times
    #:showprocess
+   #:passphrase-exists-p
    #:newuser
    #:remove-user
    #:get-privkey
@@ -505,6 +511,7 @@
    #:url-p
    #:parse-coupon
    #:verify-coupon
+   #:verify-private-key
    #:serverid-for-url
    #:verify-server
    #:addserver

src/parser.lisp

@@ -178,6 +178,12 @@
         (error "Premature end of message"))
       (nreverse res))))
 
+(defmethod get-keydict ((parser parser) id)
+  (gethash id (parser-keydict parser)))
+
+(defmethod (setf get-keydict) (pubkey (parser parser) id)
+  (setf (gethash id (parser-keydict parser)) pubkey))
+
 (defmethod parser-get-pubkey ((parser parser) id dict)
   (let* ((keydict (parser-keydict parser))
          (keydb (parser-keydb parser))

src/server-web.lisp

@@ -118,6 +118,20 @@
                  params)
      ,@body))
 
+(defun get-running-server ()
+  (port-server (get-current-port)))
+
+(defun get-current-port (&optional (acceptor hunchentoot:*acceptor*))
+  (acceptor-port acceptor))
+
+(defun server-db-exists-p ()
+  (or (ignore-errors (get-running-server))
+      (server-privkey-file-exists-p)))
+
+(defun server-privkey-file-exists-p ()
+  (let ((db (make-fsdb (server-db-dir))))
+    (not (null (db-get db $PRIVKEY)))))
+
 (defvar *debug-stream* t)
 
 (defmacro with-debug-stream ((&optional (only-if-p t)) &body body)
@@ -987,7 +1001,7 @@ openssl x509 -in cert.pem -text -noout
                   (get-web-script-handler port "/client/loom")
                   'do-loom-web-client
                   (get-web-script-handler port "/json")
-                  #'(lambda () (redirect "/json/"))
+                  'do-truledger-json
                   (get-web-script-handler port "/json/")
                   'do-truledger-json)
             (when *url-prefix*

todo.txt

@@ -1,4 +1,12 @@
-Webapp access to client. Maybe a simple scripting language.
+Webapp access to client.
+
+----------------------------------------------------------------------
+
+Command line passphrase, to make server startup automatable, at
+expense of security.
+
+Negative storage fee = interest
+For investment assets, e.g. stocks
 
 ----------------------------------------------------------------------
 

www/doc/json.txt

@@ -13,24 +13,32 @@ The general form of a <string> is:
 Results vary by function and are documented with each function.
 Error results are always returned as {"@type":"error","message":<string>}
 
-["newuser",{"passphrase":<string>,"size":<integer>,"privkey":<string>,
+["newuser",{"passphrase":<string>,"keysize":<integer>,"name":<string>,
+          "privkey":<string>,"fetch-privkey?":<boolean>,"url":<string>,
           "coupon":<string>,"proxy":<string>] => <client-handle>
   Create a new user with the given "passphrase". Error if already there.
-  If "size" is included, create a new private key of the given size
+  All other parameters are optional
+  If "keysize" is included, create a new private key of the given size
     (512, 1024, 2048, 3072, or 4096).
+  If "name" is included, it will be attached to the new server account.
   If "privkey" is included, it should be the ASCII encoding of
     the private key, encrypted with the passhprase.
-  If "coupon" is included, it should either be a coupon or the URL of
-    truledger server on which you already have an account.
+    That will create a local account on a client with no running server.
+    If you include a "url", will look for the account on that server.
+    If you include a "coupon", will register with that coupon on its server.
+  If "fetch-privkey?" is true, then "url" must be included, and
+    the cached private key is fetched from "url".
+  If "coupon" is included, it should be a coupon for
+    a truledger server on which you want to create an account.
     This is not required if logging into a client with no running server,
     But it IS required if there is a running server, to avoid
     a multitude of new accounts being created by bots.
   If "proxy" is included, it is the "host:port" for an http proxy
-    to use to contact the server in coupon.
+    to use to contact the server in "coupon" or "url".
   On successful return, the new user is logged in to the client,
     and, if "coupon" was included, the current server is set to
     that server.
-  The returned <client-handle> is a rantom string, passed as a
+  The returned <client-handle> is a random string, passed as a
     parameter to the other functions.  
 
 ["getprivkey",{"client":<client-handle>,"passphrase":<string>}] => <string>
@@ -130,9 +138,6 @@ Error results are always returned as {"@type":"error","message":<string>}
   The second element is of "type":"regfee"
   The other elements are of "type":"spend" or "type":"transfer"
 
-["setfees",{"client":<client-handle>,"fees":[{"@type":"foo",...},...]}] => null
-  Set fees. You must be logged in as the server to do this.
-
 ["getbalance",{"client":<client-handle>,"assetid":<string>,"acct":<string>}]
   => {"@type":"balance>,"acct":<string>,"assetid":<string>,"assetname":<string>,
       "amount":<string>,"time":<string>,"formatted-amount":<string>}