; -*- mode: lisp -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; A Trubanc client API. Talks the protocol of server.lisp
;;;

(in-package :trubanc-client)

(defun make-client (dir &rest rest)
  (apply 'make-instance 'client :db (make-fsdb dir) rest))

(defclass client ()
  ((db :type db
       :initarg :db
       :accessor db)
   (parser :type parser
           :accessor parser)
   (pubkeydb :type (or pubkeydb null)
             :initform nil
             :accessor pubkeydb)

  ;; Initialized by login() and newuser()
   (id :type (or string null)
       :initform nil
       :accessor id)
   (privkey :initform nil
            :accessor privkey)
   (pubkey :initform nil
           :accessor pubkey)

   ;; initialized by setbank() and addbank()
   (server :initform nil
           :accessor server)
   (test-server :initform nil
                :initarg :test-server
                :accessor test-server)
   (bankid :type (or string null)
           :initform nil
           :accessor bankid)

   ;; Set true by getreq()
   (syncedreq-p :type boolean
                :initform nil
                :accessor syncedreq-p)

   ;; The last coupon generated by a spend:
   ;; (<bankid>,couponenvelope,<id>,<encrypted-coupon>)
   (coupon :type (or string null)
           :initform nil
           :accessor coupon)

   ;; The last outbox time generated by a spend
   (last-spend-time :type (or string null)
                    :initform nil
                    :accessor last-spend-time)

   ;; Set true to keep history of spend & processinbox
   (keep-history-p :type boolean
                   :initform nil
                   :accessor keep-history-p)

   ;; Used to accumulate timing information from server (perf.lisp)
   (server-times :type (or hash-table null)
                 :initform nil
                 :accessor server-times)))

(defmethod initialize-instance :after ((client client) &rest rest)
  (declare (ignore rest))
  (setf (pubkeydb client)
        (make-instance 'pubkeydb
                       :client client
                       :db (db-subdir (db client) $PUBKEY))
        (parser client)
        (make-instance 'parser :keydb (pubkeydb client))
        (parser-always-verify-sigs-p (parser client)) t))

(defmethod finalize ((client client))
  (let ((privkey (privkey client))
        (proxy (server client)))
    (when privkey
      (setf (privkey client) nil)
      (rsa-free privkey))
    (when (and proxy (typep proxy 'serverproxy))
      (finalize proxy))))

;; API Methods

(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.
   If it is an integer, default 3072, create a new private key with that many bits
   User is logged in when this returns successfully."
  (let ((db (db client))
        (hash (passphrase-hash passphrase)))

    (logout client)

    (when (db-get db $PRIVKEY hash)
      (error "Passphrase already has an associated private key"))

    (when (integerp privkey)
      ;; privkey is size in bits for new private key
      (setq privkey (rsa-generate-key privkey)))

    (let* ((pubkey (encode-rsa-public-key privkey))
           (id (pubkey-id pubkey))
           (privkey-str (encode-rsa-private-key privkey passphrase)))
      (setf (db-get db $PRIVKEY hash) privkey-str)
      (db-put db (pubkeykey id) (format nil "~a~%" (trim pubkey)))

      (setf (id client) id
            (privkey client) privkey
            (pubkey client) pubkey))))

(defmethod get-privkey ((client client) passphrase)
  (let ((db (db client))
        (hash (passphrase-hash passphrase)))
    (decode-rsa-private-key
     (or (db-get db $PRIVKEY hash)
         (error "No account for passphrase in database"))
     passphrase)))

(defmethod login ((client client) passphrase)
  "Log in with the given passphrase. Error if no user associated with passphrase."
  (logout client)
  (let* ((privkey (get-privkey client passphrase))
         (pubkey (encode-rsa-public-key privkey))
         (id (pubkey-id pubkey)))
    (setf (id client) id
          (privkey client) privkey
          (pubkey client) pubkey)))

(defmethod login-with-sessionid ((client client) sessionid)
  (let ((passphrase (session-passphrase client sessionid)))
    (unwind-protect (login client passphrase)
      (destroy-password passphrase))
    (setf (syncedreq-p client) t))) ;; no server sync for session login

(defmethod login-new-session ((client client) passphrase)
  "Login, create a new session, and return a sessionid."
    (login client passphrase)
    (make-session client passphrase))

(defmethod logout ((client client))
  (when (id client)
    (remove-session client)
    (setf (id client) nil))
  (let ((privkey (privkey client)))
    (when privkey
      (setf (privkey client) nil)
      (rsa-free privkey))
    (setf (bankid client) nil
          (server client) nil)))

;; All the API methods below require the user to be logged in.
;; id and privkey must be set.

(defmethod current-user ((client client))
  "Return current user ID if logged in, otherwise nil."
  (and (privkey client) (id client)))

(defmethod require-current-user ((client client))
  (or (current-user client) (error "Not logged in")))

(defmethod user-pubkey ((client client) &optional (id (id client)))
  "Return pubkey of a user, default logged-in user"
  (let ((db (db client)))
    (and id (db-get db $PUBKEY id))))

(defstruct bank
  id
  name
  url)

(defmethod getbank ((client client) bankid &optional all)
  "Returns a BANK instance, or NIL if it doesn't find the BANKID.
   If ALL is true, return the bank even if the current user isn't logged in."
  (and (or all (userreq client bankid))
       (make-bank :id bankid
                  :name (bankprop client $NAME bankid)
                  :url (bankprop client $URL bankid))))

(defmethod getbanks ((client client) &optional all)
  "Return all the banks known by the current user,
   as a list of BANK instances.
   (BANK-PUBKEYSIG BANK) will be blank if the user has no account at BANK."
  (let* ((db (db client))
         (id (require-current-user client))
         (banks (db-contents db $ACCOUNT id $BANK))
         (res nil))
    (dolist (bankid banks)
      (let ((bank (getbank client bankid all)))
        (when bank (push bank res))))

    (sort (nreverse res) #'string-lessp :key #'bank-name)))

(defun url-p (url)
  "Returns true if $url might be a properly-formed URL."
  (ignore-errors
    (and (not (blankp url))
         (puri:parse-uri url))))

(defun encode-coupon (url number)
  (format nil "[~a ~a]" url number))

(defun decode-coupon (coupon)
  (check-type coupon string)
  (handler-case
      (let* ((coupon (trim coupon))
             (len (length coupon)))
        (when (eql #\] (aref coupon (1- len)))
          (setq coupon (subseq coupon 0 (1- len))))
        (when (eql #\[ (aref coupon 0))
          (setq coupon (subseq coupon 1)))
        (setq coupon (substitute #\space #\, coupon))
        (let* ((pos (position #\space coupon))
               (pos2 (position #\space coupon
                               :start pos
                               :test (lambda (x y) (not (eql x y))))))
          (values (subseq coupon 0 pos)
                  (subseq coupon pos2))))
    (error ()
      (error "Malformed coupon"))))
  

(defun parse-coupon (coupon)
  "Parse a coupon into bankid, url, and coupon number.
   Returns two values:
     1) url
     2) coupon-number
   Coupon can be [$url,$coupon_number] or
   ($bankid,coupon,$url,$coupon_number,$asset,$amount,note:$note)"
  (multiple-value-bind (url coupon-number) (decode-coupon coupon)
    (unless (url-p url)
      (error "Coupon url isn't a url: ~s" url))
    (unless (coupon-number-p coupon-number)
      (error "Coupon number malformed: ~a" coupon-number))
    (values url coupon-number)))

(defmethod verify-coupon ((client client) coupon bankid url)
  "Verify that a message is a valid coupon.
   Check that it is actually signed by the bank that it
   claims to be from.
   Ask the bank whether a coupon of that number exists."
  (let ((parser (parser client))
        (coupon-number (nth-value 1 (parse-coupon coupon))))
    (verify-bank client url bankid)
    (let* ((msg (strcat "(0," $BANKID ",0," coupon-number "):0"))
           (server (make-server-proxy client url))
           (msg (process server msg))
           (reqs (parse parser msg)))
      (match-bankreq client (car reqs) $REGISTER bankid)
      (unless (eql 2 (length reqs))
        (error "verifycoupon: expected 2 messages from bank"))
      (match-bankreq client (cadr reqs) $COUPONNUMBERHASH bankid))))

;; Returns three values:
;;   1) bankid
;;   2) bank pubkey
;;   3) bank name
(defmethod bankid-for-url ((client client) url &optional bankid)
  (let* ((parser (parser client))
         (msg (strcat "(0," $BANKID ",0):0"));
         (server (make-server-proxy client url))
         (msg (process server msg))
         (save-bankid (prog1 (bankid client)
                        (setf (bankid client) bankid)))
         (args (unwind-protect (match-message parser msg)
                 (setf (bankid client) save-bankid)))
         (request (getarg $REQUEST args))
         (bankid (getarg $CUSTOMER args))
         (pubkey (getarg $PUBKEY args))
         (name (getarg $NAME args)))
    (when (equal $FAILED request)
      (error "Failed to register at bank: ~s"
             (or (getarg $ERRMSG args) msg)))
    (unless (and (equal $REGISTER request)
                 (equal bankid (getarg $BANKID args)))
      (error "Bank's register message malformed"))
    (unless (equal (pubkey-id pubkey) bankid)
      (error "verifybank: Bank's id doesn't match its public key"))
    (values bankid pubkey name)))

(defmethod verify-bank ((client client) url &optional id)
  "Verify that a bank matches its URL.
   Add the bank to our database if it's not there already.
   Error if ID is non-null and doesn't match bankid at URL.
   Return bankid, or error."
  (unless (url-p url)
    (error "Not a URL: ~s" url))
  (when (blankp id) (setq id nil))
  (let* ((db (db client))
         (urlhash (sha1 url))
         (bankid (db-get db $BANK $BANKID urlhash)))
    (cond (bankid
           (when (and id (not (equal id bankid)))
             (error "verifybank: id <> bankid"))
           (unless id (setq id bankid)))
          (t
           (multiple-value-bind (bankid pubkey name) (bankid-for-url client url)
             (if (not id)
                 (setq id bankid)
                 (unless (equal bankid id)
                   (error "Bankid different than expected")))
             (unless (bankprop client $URL bankid)
               ;; Initialize the bank in the database
               (setf (db-get db $BANK $BANKID urlhash) bankid
                     (db-get db (bankkey client $URL bankid)) url
                     (db-get db (bankkey client $NAME bankid)) name
                     (db-get db (pubkeykey bankid))
                     (format nil "~a~%" (trim pubkey))))
             bankid)))))

(defmethod addbank ((client client) url &optional name couponok)
  "Add a bank with the given URL to the database.
   URL can be a coupon to redeem that with registration.
   No error, but does nothing, if the bank is already there.
   If the bank is NOT already there, registers with the given NAME and coupon.
   If registration fails, removes the bank and you'll have to add it again
   after getting enough usage tokens at the bank to register.
   Sets the client instance to use this bank until addbank() or setbank()
   is called to change it.
   If COUPONOK is true, does not verify a coupon with the bank before using it."
  (let ((db (db client))
        (bankid nil)
        (realurl nil)
        (coupon nil))
    (require-current-user client)
    (cond ((url-p url)
           (setq realurl url
                 bankid (verify-bank client url)))
          (t (multiple-value-setq (realurl coupon) (parse-coupon url))
             (setq bankid (verify-bank client realurl))
             (unless couponok
               (verify-coupon client url bankid realurl))))
    (let ((already-registered-p t))
      (handler-case (setbank client bankid nil)
        (error ()
          (setq already-registered-p nil)))
      (cond (already-registered-p
             ;; User already has an account at this bank.
             ;; Redeem the coupon
             (when coupon
               (redeem client coupon)))
            (t 
             (let ((oldbankid (bankid client))
                   (oldserver (server client))
                   (ok nil))
               (setf (bankid client) bankid
                     url (bankprop client $URL bankid))
               (unwind-protect
                    (progn
                      (unless url
                        (error "URL not stored for verified bank: ~s" bankid))
                      (setf (server client) (make-server-proxy client url))
                      (register client name coupon bankid)
                      (setq ok t))
                 (unless ok
                   (setf (db-get db (userreqkey client bankid)) nil
                         (bankid client) oldbankid
                         (server client) oldserver)))))))))

(defmethod setbank ((client client) bankid &optional (check-p t))
  "Set the bank to the given id.
   Sets the client instance to use this bank until addbank() or setbank()
   is called to change it, by setting $this->bankid and $this->server"
  (let ((url (or (bankprop client $URL bankid)
                 (error "Bank not known: ~s" bankid))))
    (require-current-user client)
    (unless (userbankprop client $REQ bankid)
      (error "User not registered at bank"))
    (setf (bankid client) bankid
          (server client) (make-server-proxy client url))

    (when check-p
      (let* ((msg (sendmsg client $BANKID (pubkey client)))
             (args (handler-case (match-message (parser client) msg)
                     (error (c)
                       (setf (bankid client) nil)
                       (error "setbank: Bank's bankid response error: ~a" c)))))
        (unless (equal bankid (getarg $CUSTOMER args))
          (setf (bankid client) nil)
          (error "Bankid changed since we last contacted this bank, old: ~s, new: ~s"
                 bankid (getarg $CUSTOMER args)))
        (unless (and (equal (getarg $REQUEST args) $REGISTER)
                     (equal (getarg $BANKID args) bankid))
          (setf (bankid client) nil)
          (error "Bank's bankid message wrong: ~s" msg))))))

(defmethod current-bank ((client client))
  "Return current bank if the user is logged in and the bank is set, else false."
  (and (current-user client) (server client) (bankid client)))

(defmethod require-current-bank ((client client) &optional msg)
  (unless (current-bank client)
    (error (or msg "Bank not set"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  All the API methods below require the user to be logged and the bank to be set.
;;;  Do this by calling newuser() or login(), and addbank() or setbank().
;;;  id, privkey, bankid, & server must all be set.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmethod register ((client client) &optional name coupons bankid)
  "Register at the current bank.
   No error if already registered
   If not registered, and COUPONS is a string or array of strings,
   assumes the string(s) are coupons, encrypts and signs them,
   and sends them to the bank with the registration request."
  (let ((db (db client))
        (id (require-current-user client))
        server)
    (cond ((null bankid)
           (setq bankid (bankid client)
                 server (server client)))
          (t 
           (let ((url (or (bankprop client $URL)
                          (error "In register: Unknown bankid"))))
             (setq server (make-server-proxy client url)))))

    (require-current-bank client "In register(): Bank not set")

    ;; If already registered and we know it, nothing to do
    (when (db-get db (userbankkey client $PUBKEYSIG bankid) id)
      (return-from register))

    ;; See if bank already knows us
    ;; Resist the urge to change this to a call to
    ;; get-pubkey-from-server. Trust me.
    (let* ((msg (process server (custmsg client $ID bankid id)))
           args)
      (handler-case
          (setq args (unpack-bankmsg client msg $ATREGISTER))
        (error ()
          ;; Bank doesn't know us. Register with bank.
          (setq msg (apply #'custmsg client $REGISTER bankid (pubkey client)
                           (and name (list name))))
          (when coupons
            (when (stringp coupons) (setq coupons (list coupons)))
            (let ((pubkey (db-get (pubkeydb client) bankid)))
              (unless pubkey (error "Can't get bank public key"))
              (dolist (coupon coupons)
                (dotcat msg "." (custmsg client $COUPONENVELOPE bankid
                                         (pubkey-encrypt coupon pubkey))))))
          (setq msg (process server msg)
                args (unpack-bankmsg client msg $ATREGISTER))))

      ;; Didn't fail. Notice registration here
      (setq args (getarg $MSG args))
      (unless (and (equal (getarg $CUSTOMER args) id)
                   (equal (getarg $REQUEST args) $REGISTER)
                   (equal (getarg $BANKID args) bankid))
        (error "Malformed registration message"))
      (let* ((pubkey (getarg $PUBKEY args))
             (keyid (pubkey-id pubkey)))
        (unless (equal keyid id)
          (error "Server's pubkey wrong"))
        (setf (db-get db (userbankkey client $PUBKEYSIG) id) msg
              (db-get db (userbankkey client $REQ)) "-1")))))

(defconstant $PRIVKEY-CACHE-SALT "privkey-cache-salt")

(defmethod privkey-cached-p ((client client) &optional bankid)
  (unless bankid
    (require-current-bank client "In privkey-cached-p: no current bank")
    (setq bankid (bankid client)))
  (equal "cached" (userbankprop client $PRIVKEYCACHEDP bankid)))

(defmethod (setf privkey-cached-p) (value (client client) &optional bankid)
  (unless bankid
    (require-current-bank client "In (setf privkey-cached-p): no current bank")
    (setf bankid (bankid client)))
  (setf (userbankprop client $PRIVKEYCACHEDP bankid) (and value "cached"))
  value)

(defmethod need-privkey-cache-p ((client client) &optional bankid)
  (unless bankid
    (require-current-bank client "In privkey-cached-p: no current bank")
    (setq bankid (bankid client)))
  (equal $NEEDPRIVKEYCACHE (userbankprop client $NEEDPRIVKEYCACHE bankid)))

(defmethod (setf need-privkey-cache-p) (value (client client) &optional bankid)
  (unless bankid
    (require-current-bank client "In privkey-cached-p: no current bank")
    (setq bankid (bankid client)))
  (setf (userbankprop client $NEEDPRIVKEYCACHE bankid)
        (and value $NEEDPRIVKEYCACHE))
  value)

;; We could encrypt the private key again, so it doesn't look like a
;; private key, but that's really not any more secure, since it will
;; only use the passphrase a second time. We could require yet
;; another passphrase, but users will forget that, since they'll
;; hardly ever use it.
(defmethod cache-privkey ((client client) sessionid &optional uncache-p)
  (require-current-bank client "In cache-privkey: no current bank")
  (flet ((doit (passphrase)
           (let* ((db (db client))
                  (data (if uncache-p
                            ""
                            (db-get db $PRIVKEY (passphrase-hash passphrase))))
                  (key (passphrase-hash passphrase $PRIVKEY-CACHE-SALT)))
             (writedata client key data t)
             (setf (privkey-cached-p client) (not uncache-p))
             nil)))
    (let ((passphrase (session-passphrase client sessionid)))
      (unwind-protect (doit passphrase)
        (destroy-password passphrase)))))

(defmethod fetch-privkey ((client client) bankurl passphrase)
  (let ((key (passphrase-hash passphrase $PRIVKEY-CACHE-SALT)))
    (readdata client key :anonymous-p t :bankurl bankurl)))

(defstruct contact
  id
  name
  nickname
  note
  banks
  client)

(defmethod contact-contact-p ((contact contact))
  (and (contact-client contact)
       (member (bankid (contact-client contact))
               (contact-banks contact)
               :test #'equal)))

(defun string-compare (s1 s2)
  (cond ((string-lessp s1 s2) 1)
        ((string-equal s1 s2) 0)
        (t -1)))

(defun properties-compare (a1 a2 keys &optional (comparef #'string-compare))
  (dolist (key keys 0)
    (let ((comparef comparef))
      (when (listp key)
        (setq comparef (cdr key) key (car key)))
      (let ((res (funcall comparef (funcall key a1) (funcall key a2))))
        (unless (eql 0 res) (return res))))))

(defun properties-lessp (a1 a2 keys &optional (comparef #'string-compare))
  (< (properties-compare a1 a2 keys comparef) 0))

(defun contacts-lessp (c1 c2)
  (properties-lessp c1 c2 '(contact-nickname contact-name contact-id)))

;; Move contacts from old location, under bank, to new location,
;; top-level of contact.
(defmethod fix-contacts ((client client))
  (let ((db (db client))
        (id (id client)))
    (when (and id (not (db-contents db $ACCOUNT id $CONTACT $BANKS)))
      (let ((bankkey (append-db-keys $ACCOUNT id $BANK))
            (contactkey (append-db-keys $ACCOUNT id $CONTACT)))
        (dolist (bankid (db-contents db bankkey))
          (dolist (otherid (db-contents db bankkey bankid $CONTACT))
            (let ((old-contactkey (append-db-keys bankkey bankid $CONTACT otherid))
                  (new-contactkey (append-db-keys contactkey otherid)))
              (unless (db-get db new-contactkey $NICKNAME)
                (setf (db-get db new-contactkey $NICKNAME)
                      (db-get db old-contactkey $NICKNAME)))
              (setf (db-get db new-contactkey $NOTE)
                    (let ((note (db-get db new-contactkey $NOTE))
                          (new-note (db-get db old-contactkey $NOTE)))
                      (cond (note
                             (if new-note
                                 (strcat note #\newline new-note)
                                 note))
                            (t note))))
              (unless (db-get db new-contactkey $NAME)
                (setf (db-get db new-contactkey $NAME)
                      (db-get db old-contactkey $NAME)))
              (unless (db-get db new-contactkey $PUBKEYSIG)
                (setf (db-get db new-contactkey $PUBKEYSIG)
                      (db-get db old-contactkey $PUBKEYSIG)))
              (let ((banks (adjoin bankid
                                   (explode
                                    #\space (db-get db new-contactkey $BANKS))
                                   :test #'equal)))
                (setf (db-get db new-contactkey $BANKS)
                      (apply #'implode #\space banks)))
              (setf (db-get db old-contactkey $NICKNAME) nil
                    (db-get db old-contactkey $NOTE) nil
                    (db-get db old-contactkey $NAME) nil
                    (db-get db old-contactkey $PUBKEYSIG) nil))))))))

(defmethod getcontacts ((client client) &optional all-p)
  "Get contacts for the current bank.
   Contacts are sorted by nickname, name, id
   Signals an error or returns a list of CONTACT instances.
   If ALL-P is true, return all contacts.
   Otherwise, return only contacts for the current bank."
  (let ((db (db client)))
    (require-current-bank client "In getcontacts(): Bank not set")
    (fix-contacts client)
    (with-db-lock (db (userreqkey client))
      (let* ((ids (db-contents db (contactkey client)))
             (bankid (bankid client))
             (res (loop
                     for otherid in ids
                     for contact = (getcontact-internal client otherid nil nil)
                     when contact
                     collect contact)))
        (unless all-p
          (setq res
                (delete-if (lambda (contact)
                             (not (member bankid (contact-banks contact)
                                          :test #'equal)))
                           res)))
        (sort res #'contacts-lessp)))))

(defmethod getcontact ((client client) otherid &optional add)
  "Get a contact, by ID. Return a CONTACT instance."
  (when (current-bank client)
    (with-db-lock ((db client) (userreqkey client))
      (getcontact-internal client otherid add))))

(defmethod getcontact-internal ((client client) otherid &optional add (probebank t))
  (fix-contacts client)
  (let ((pubkeysig (contactprop client otherid $PUBKEYSIG)))
    (unless pubkeysig
      (cond (add
             (addcontact-internal client otherid)
             (setq pubkeysig (contactprop client otherid $PUBKEYSIG)))
            (probebank
             (multiple-value-bind (pubkeysig name) (get-id client otherid)
               (return-from getcontact-internal
                 (and pubkeysig (make-contact :id otherid :name name
                                              :client client)))))))
    (when pubkeysig
      (make-contact
       :id otherid
       :name (contactprop client otherid $NAME)
       :nickname (contactprop client otherid $NICKNAME)
       :note (contactprop client otherid $NOTE)
       :banks (explode #\space (contactprop client otherid $BANKS))
       :client client))))
  
(defmethod addcontact ((client client) otherid &optional nickname note)
  "Add a contact to the current bank.
   If it's already there, change its nickname and note, if included."
  (require-current-bank client)
  (with-db-lock ((db client) (userreqkey client))
    (addcontact-internal client otherid nickname note)))

(defmethod addcontact-internal ((client client) otherid &optional nickname note)
  (let ((db (db client))
        pubkeysig
        name)
    (let* ((bankid (bankid client))
           (banks (explode #\space (contactprop client otherid $BANKS))))
      (unless (member bankid banks :test #'equal)
        (setf (db-get db (contactkey client otherid $BANKS))
              (apply #'implode #\space bankid banks))))
    (cond ((contactprop client otherid $PUBKEYSIG)
           (when nickname
             (setf (db-get db (contactkey client otherid $NICKNAME)) nickname))
           (when note
             (setf (db-get db (contactkey client otherid $NOTE)) note)))
          (t
           (multiple-value-setq (pubkeysig name) (get-id client otherid))
           (unless pubkeysig (error "Can't find id at bank: ~s" otherid))
           (unless nickname
             (setq nickname (or name "anonymous")))
           (setf (db-get db (contactkey client otherid $NICKNAME)) nickname
                 (db-get db (contactkey client otherid $NOTE)) note
                 (db-get db (contactkey client otherid $NAME)) name
                 (db-get db (contactkey client otherid $PUBKEYSIG)) pubkeysig)))
    pubkeysig))

(defmethod deletecontact ((client client) otherid)
  "Delete a contact from the current bank."
  (let ((db (db client)))
    (with-db-lock (db (userreqkey client))
      (let ((key (contactkey client otherid)))
        (dolist (k (db-contents db key))
          (setf (db-get db key k) nil))))))

(defconstant $SERVER-CONTACTS-SALT "server-contacts-salt")

(defun server-contacts-key (client)
  (sha1 (xor-salt (id client) $SERVER-CONTACTS-SALT)))

(defmethod %get-server-contacts ((client client))
  (ignore-errors
    (readdata client (server-contacts-key client))))

(defmethod (setf %get-server-contacts) (value client)
  (writedata client (server-contacts-key client) (or value ""))
  value)

(defun pack-contact (contact)
  (check-type contact contact)
  `(:id ,(contact-id contact)
    :name ,(contact-name contact)
    :nickname ,(contact-nickname contact)
    :note ,(contact-note contact)
    :banks ,(contact-banks contact)))

(defun unpack-contact (client list)
  (apply #'make-contact :client client list))

(defun pack-contacts (contacts)
  (prin1-to-string (mapcar #'pack-contact contacts)))

(defun unpack-contacts (client string)
  (mapcar (lambda (parms) (unpack-contact client parms))
          (read-from-string string)))

(defmethod get-server-contacts ((client client))
  (let ((string (%get-server-contacts client)))
    (and string
         (unpack-contacts
          client (privkey-decrypt string (privkey client))))))

(defmethod (setf get-server-contacts) (value (client client))
  (setf (%get-server-contacts client)
        (pubkey-encrypt (pack-contacts value) (privkey client)))
  value)

(defun merge-contact-strings (old new)
  (if (blankp old) new old))

(defmethod sync-contacts ((client client))
  (let ((contacts (getcontacts client t))
        (server-contacts (ignore-errors (get-server-contacts client)))
        (changed-p nil))
    (dolist (sc server-contacts)
      (let* ((otherid (contact-id sc))
             (c (find otherid contacts :test #'equal :key #'contact-id)))
        (cond (c
               (let ((new-nick
                      (merge-contact-strings
                       (contact-nickname c) (contact-nickname sc)))
                     (new-note
                      (merge-contact-strings
                      (contact-note c) (contact-note sc)))
                     (new-banks
                      (union (contact-banks c) (contact-banks sc)
                             :test #'equal)))
                 (unless (equal new-nick (contact-nickname c))
                   (setf (contact-nickname c) new-nick
                         (contactprop client otherid $NICKNAME) new-nick))
                 (unless (equal new-note (contact-note c))
                   (setf (contact-note c) new-note
                         (contactprop client otherid $NOTE) new-note))
                 (unless (eql (length new-banks) (length (contact-banks c)))
                   (setf (contact-banks c) new-banks
                         (contactprop client otherid $BANKS)
                         (apply #'implode #\space new-banks)))
                 (unless changed-p
                   (setq changed-p
                         (not (and (equal new-nick (contact-nickname sc))
                                   (equal new-note (contact-note sc))
                                   (eql (length new-banks)
                                        (length (contact-banks sc)))))))))
              (t (push sc contacts)
                 (setq changed-p t)
                 (let ((pubkeysig (and (not (contactprop client otherid $PUBKEYSIG))
                                       (ignore-errors (get-id client otherid)))))
                   (when pubkeysig
                     (setf (contactprop client otherid $PUBKEYSIG) pubkeysig))
                   (setf (contactprop client otherid $NICKNAME)
                         (contact-nickname sc)
                         (contactprop client otherid $NOTE)
                         (contact-note sc)
                         (contactprop client otherid $NAME)
                         (contact-name sc)
                         (contactprop client otherid $BANKS)
                         (apply #'implode #\space (contact-banks sc))))))))
    (when (or changed-p (not (eql (length contacts) (length server-contacts))))
      (setf (get-server-contacts client) contacts))
    (values contacts changed-p)))

(defmethod get-id ((client client) id)
  "Check for an id at the bank. Return false if not there.
   Return two values: pubkeysig & name"
  (let ((db (db client))
        (bankid (bankid client)))
    (when bankid
      (let* ((key (append-db-keys (userbankkey client $PUBKEYSIG) id))
             (pubkeysig (db-get db key))
             (needstore nil))
        (unless pubkeysig
          (setq pubkeysig (sendmsg client $ID bankid id)
                needstore t))
        (let ((args (ignore-errors
                      (unpack-bankmsg client pubkeysig $ATREGISTER))))
          (when args
            (setq args (getarg $MSG args))
            (let ((pubkey (getarg $PUBKEY args))
                  (name (getarg $NAME args)))
              (when (equal id (pubkey-id pubkey))
                (when needstore (setf (db-get db key) pubkeysig))
                (values pubkeysig name)))))))))

(defun acct-compare (a1 a2)
  (cond ((equal a1 a2) 0)
        ((equal a1 $MAIN) -1)
        ((equal a2 $MAIN) 1)
        ((string-lessp a1 a2) -1)
        (t 1)))
  
(defun acct-lessp (a1 a2)
  (< (acct-compare a1 a2) 0))

(defmethod getaccts ((client client))
  "GET sub-account names.
   Returns an error string or an array of the sub-account names."
  (let ((db (db client)))

    (require-current-bank client "In getaccts(): Bank not set")
    (init-bank-accts client)
    
    (sort (db-contents db (userbalancekey client)) #'acct-lessp)))

(defstruct asset
  id
  assetid
  scale
  precision
  name
  issuer
  percent)

(defun asset-lessp (a1 a2)
  (properties-lessp a1 a2 '(asset-name asset-id)))

(defmethod getassets ((client client))
  "Return the assets for which the customer has balances as
   a list of ASSET instances."
  (let ((db (db client))
        (bankid (bankid client))
        (res nil))
    (when bankid
      (let* ((key (userbalancekey client))
             (accts (db-contents db key)))
        (dolist (acct accts)
          (let ((assetids (db-contents db key acct)))
            (dolist (assetid assetids)
              (unless (find assetid res
                            :test #'equal
                            :key #'asset-assetid)
                (let ((asset (getasset client assetid)))
                  (when asset (push asset res))))))))
      (sort res #'asset-lessp))))

(defmethod getasset ((client client) assetid &optional forceserver)
  "Look up an asset.
   Signals an error or returns an ASSET instance.
   If the asset isn't found in the client database, looks it up on the
   server, and stores it in the client database."
  (require-current-bank client "In getacct(): Bank not set")
  (let ((db (db client))
        (key (assetkey client assetid)))
    (with-db-lock (db key)
      (let ((msg (unless forceserver (db-get db key)))
            args)
        (cond (msg
               (setq args (unpack-bankmsg client msg $ATASSET)))
              (t
               (setq args (getasset-internal client assetid key))))
        (let ((req (cadr (getarg $UNPACK-REQS-KEY args)))
              (args (getarg $MSG args))
              (percent nil)
              (issuer nil))
          (when req
            (let* ((args1 (getarg $MSG (match-bankreq client req $ATSTORAGE))))
              (setq issuer (getarg $CUSTOMER args1)
                    percent (getarg $PERCENT args1))))
          (make-asset
           :id (getarg $CUSTOMER args)
           :assetid assetid
           :scale (getarg $SCALE args)
           :precision (getarg $PRECISION args)
           :name (getarg $ASSETNAME args)
           :issuer issuer
           :percent percent))))))

(defmethod getasset-internal ((client client) assetid key)
  (let* ((db (db client))
         (bankid (bankid client))
         (req (getreq client))
         (msg (sendmsg client $GETASSET bankid req assetid))
         (args (with-verify-sigs-p ((parser client) t)
                 (unpack-bankmsg client msg $ATASSET)))
         (msgargs (getarg $MSG args)))
    (unless (and (equal (getarg $REQUEST msgargs) $ASSET)
                 (equal (getarg $BANKID msgargs) bankid)
                 (equal (getarg $ASSET msgargs) assetid))
      (error "Bank wrapped wrong object with @asset"))
    (setf (db-get db key) msg)
    args))

(defmethod addasset ((client client) scale precision assetname &optional percent)
  (let ((db (db client)))
    (with-db-lock (db (userreqkey client))
      (let ((id (id client))
            (bankid (bankid client))
            (server (server client))
            (parser (parser client)))

        (unless (and id bankid)
          (error "Can't add asset unless bank is set"))

        (let* ((assetid (assetid id scale precision assetname))
               (time (gettime client))
               (tranfee (getfees client))
               (tokenid (fee-assetid tranfee))
               (msg (custmsg client $ASSET bankid assetid scale precision assetname))
               (nonbankp (not (equal id bankid)))
               (bal1 (and nonbankp
                          (balance-amount (or (getbalance client $MAIN tokenid)
                                              (error "No token balance")))))
               (oldasset (ignore-errors (getasset client assetid t)))
               (bal2 nil)
               (storage nil)
               (mainbals (make-equal-hash))
               (acctbals (make-equal-hash $MAIN mainbals))
               balancehash)
          (cond ((and oldasset
                      (if (blankp percent)
                          (blankp (asset-percent oldasset))
                          (and (equal id (asset-issuer oldasset))
                               (equal percent (asset-percent oldasset)))))
                 ;; check to be sure we've got a balance in this asset
                 (let ((db (db client)))
                   (unless (dolist (acct (db-contents db (userbalancekey client)))
                             (when (db-get db (userbalancekey client acct assetid))
                               (return t)))
                     (forceinit client))))                   
                (t
                 (when nonbankp
                   (let ((tokens (if oldasset 1 2))
                         (ispos (>= (bccomp bal1 0) 0)))
                     (setq bal1 (bcsub bal1 tokens))
                     (when (and ispos (< (bccomp bal1 0) 0))
                       (error
                        (if oldasset
                            "You need 1 usage token to update an asset"
                            "You need 2 usage tokens to create a new asset")))))
                 (setq bal1 (custmsg client $BALANCE bankid time tokenid bal1))
                 (unless oldasset
                   (setq bal2 (custmsg client $BALANCE bankid time assetid "-1")))
                 (when bal1
                   (setf (gethash tokenid mainbals) bal1))
                 (when bal2
                   (setf (gethash assetid mainbals) bal2))
                 (when nonbankp
                   (setq balancehash (balancehashmsg client time acctbals)))

                 (unless (blankp percent)
                   (unless (is-numeric-p percent)
                     (error "percent must be numeric"))
                   (setq storage
                         (custmsg client $STORAGE bankid time assetid percent))
                   (dotcat msg "." storage))
                 (when bal1 (dotcat msg "." bal1))
                 (when bal2 (dotcat msg "." bal2))
                 (when balancehash (dotcat msg "." balancehash))

                 (setq msg (process server msg))

                 ;; Request sent. Check for error
                 (let ((reqs (parse parser msg))
                       gotbal1
                       gotbal2
                       gotstorage)
                   (dolist (req reqs)
                     (let* ((args (match-bankreq client req))
                            (msg (get-parsemsg req))
                            (m (trim (get-parsemsg (getarg $MSG args)))))
                       (cond ((equal m bal1) (setq gotbal1 msg))
                             ((equal m bal2) (setq gotbal2 msg))
                             ((equal m storage) (setq gotstorage msg)))))
                   (when (or (and bal1 (not gotbal1))
                             (and bal2 (not gotbal2)))
                     (error
                      "While adding asset: missing returned balance from server"))
                   (when (and percent (not gotstorage))
                     (error
                      "While adding asset: storage fee not returned from server"))

                   ;; All is well. Commit the balance changes
                   (when bal1
                     (setf (db-get db (userbalancekey client $MAIN tokenid))
                           gotbal1))
                   (when bal2
                     (setf (db-get db (userbalancekey client $MAIN assetid))
                           gotbal2))
            
                   (getasset client assetid t)))))))))

(defstruct fee
  type
  assetid
  amount)

(defmethod getfees ((client client) &optional reload)
  "Look up the transaction cost.
   Returns three values (FEE instances)
     1) tranfee
     2) regfee
     3) List of other fees
   Currently, only the tranfee and regfee are supported by the server,
   and only a single fee, in usage tokens, is charged for each.
   So that's all the spend code handles."
    (require-current-bank client "In getfees(): Bank not set")
    (let ((msg (unless reload (tranfee client))))
      (unless msg
        (setq msg (getfees-internal client)))
      (let* ((args (unpack-bankmsg client msg $TRANFEE))
             (tranfee (make-fee :type $TRANFEE
                                :assetid (getarg $ASSET args)
                                :amount (getarg $AMOUNT args)))
             regfee)
        (setq msg (regfee client)
              args (unpack-bankmsg client msg $REGFEE)
              regfee (make-fee :type $REGFEE
                               :assetid (getarg $ASSET args)
                               :amount (getarg $AMOUNT args)))
        (values tranfee regfee))))

(defmethod getfees-internal ((client client))
  (let ((db (db client))
        (key (tranfeekey client))
        (parser (parser client))
        (bankid (bankid client)))
    (with-db-lock (db key)
      (let* ((req (getreq client))
             (msg (sendmsg client $GETFEES bankid req))
             (reqs (parse parser msg t))
             (feemsg nil))
        (dolist (req reqs)
          (let* ((args (match-bankreq client req))
                 (request (getarg $REQUEST args)))
            (cond ((equal request $TRANFEE)
                   (setq feemsg (get-parsemsg req))
                   (setf (db-get db key) feemsg))
                  ((equal request $REGFEE)
                   (setf (db-get db (regfee-key client)) (get-parsemsg req))))))
        (unless feemsg (error "No tranfee from getfees request"))
        feemsg))))

(defstruct balance
  acct
  assetid
  assetname
  amount
  time
  formatted-amount)

(defun balance-lessp (b1 b2)
  (< (properties-compare b1 b2 '((balance-acct . acct-compare) balance-assetid)) 0))

(defmethod getbalance ((client client) &optional (acct t) assetid includeraw)
  "Get user balances for all sub-accounts or just one.
   Returns a list of (ACCT BALANCE ...) lists, where the
   BALANCE instances are sorted by ASSETNAME and ASSETID.

   The ACCT arg is T for all sub-accounts, nil for the
   $MAIN sub-account only, or a string for that sub-account only.
   The ASSETID arg is false for all assets or an ID for that asset only.

   If you include a specific ACCT and a specific ASSETID, the result
   is a single BALANCE instance, not a list of lists.

   If INCLUDERAW is true, returns a second value, a hash table mapping
   each BALANCE instance to the raw message that encodes it."
  (require-current-bank client "In getbalance(): Bank not set")
  (init-bank-accts client)
  (with-db-lock ((db client) (userreqkey client))
    (getbalance-internal client acct assetid includeraw)))

(defmethod getbalance-internal ((client client) acct assetid &optional includeraw)
  (unless acct (setq acct $MAIN))
  (let* ((db (db client))
         (accts (if (stringp acct)
                    (list acct)
                    (db-contents db (userbalancekey client))))
         (res nil)
         (msghash (and includeraw (make-hash-table :test 'eq))))
    (dolist (acct accts)
      (let ((assetids (if assetid
                          (list assetid)
                          (db-contents db (userbalancekey client acct))))
            (balances nil))
        (dolist (assetid assetids)
          (multiple-value-bind (amount time msg)
              (userbalanceandtime client acct assetid)
            (when amount
              (unless (is-numeric-p amount t)
                (error "While gathering balances, non-numeric amount: ~s" amount))
              (let* ((asset (getasset client assetid))
                     (formatted-amount (format-asset-value client amount asset))
                     (assetname (asset-name asset)))
                (push (make-balance :acct acct
                                    :assetid assetid
                                    :assetname assetname
                                    :amount amount
                                    :time time
                                    :formatted-amount formatted-amount)
                      balances)
                (when includeraw
                  (setf (gethash (car balances) msghash) msg))))))
        (when balances
          (push (cons acct (sort balances #'balance-lessp)) res))))
    (values
     (if (and (stringp acct) assetid)
         (cadar res)
         (sort res #'acct-lessp :key #'car))
     msghash)))

(defstruct fraction
  assetid
  assetname
  amount
  scale)

(defmethod getfraction ((client client) &optional assetid includeraw)
  "Get the fraction balance for a particular assetid, or all assetids,
   Returns a list of FRACTION instances, or a single FRACTION instance,
   if ASSETID is specified.
   If INCLUDERAW is true, return, as a second value, a hash table mapping
   from FRACTION instances to message strings."
  (let ((db (db client)))
    (require-current-bank client "In getfraction(): Bank not set")
    (init-bank-accts client)

    (with-db-lock (db (userreqkey client))
      (let ((assetids (if assetid
                          (list assetid)
                          (db-contents db (userfractionkey client))))
            (res nil)
            (msghash (and includeraw (make-hash-table :test 'eq))))
        (dolist (assetid assetids)
          (let* ((key (userfractionkey client assetid))
                 (msg (db-get db key)))
            (when msg
              (let* ((args (getarg $MSG
                                   (unpack-bankmsg client msg $ATFRACTION)))
                     (fraction (getarg $AMOUNT args))
                     (asset (getasset client assetid))
                     (scale (asset-scale asset))
                     (assetname (asset-name asset)))
                (push (make-fraction :assetid assetid
                                     :assetname assetname
                                     :amount fraction
                                     :scale scale)
                      res)
                (when includeraw
                  (setf (gethash (car res) msghash) msg))))))
        (values
         (if assetid (car res) (nreverse res))
         msghash)))))

(defmethod getstoragefee ((client client) &optional assetid)
  "Get the storagefee balance for a particular assetid, or all assetids,
   Returns a list of BALANCE instances, or a single BALANCE instance, if
   ASSETID is specified."
  (let ((db (db client)))
    (require-current-bank client "In getfraction(): Bank not set")
    (init-bank-accts client)

    (with-db-lock (db (userreqkey client))
      (let* ((key (userstoragefeekey client))
             (assetids (if assetid
                           (list assetid)
                           (db-contents db key)))
            (res nil))
        (dolist (assetid assetids)
          (let ((msg (db-get db key assetid)))
            (when msg
              (let* ((args (unpack-bankmsg client msg $STORAGEFEE))
                     (time (getarg $TIME args))
                     (assetid (getarg $ASSET args))
                     (amount (getarg $AMOUNT args))
                     (fraction "0"))
                (multiple-value-setq (amount fraction)
                  (normalize-balance amount fraction 0))
                (when (not (eql 0 (bccomp amount 0)))
                  (let* ((asset (getasset client assetid))
                         (formatted-amount (format-asset-value client amount asset))
                         (assetname (asset-name asset)))
                    (push (make-balance :time time
                                        :assetid assetid
                                        :assetname assetname
                                        :amount amount
                                        :formatted-amount formatted-amount)
                          res)))))))
        (if assetid (car res) (sort res #'balance-lessp))))))

(define-condition validation-error (simple-error)
  ())

(defun validation-error (format-control &rest format-arguments)
  (error 'validation-error
         :format-control format-control
         :format-arguments format-arguments))

(defmethod spend ((client client) toid assetid formattedamount &optional acct note)
  "Initiate a spend
   TOID is the id of the recipient of the spend
     May be $COUPON to generate a coupon
     In that case, the coupon itself can be fetched with getcoupon()
   ASSETID is the id of the asset to spend.
   FORMATTEDAMOUNT is the formatted amount to spend.
   ACCT is the source sub-account, default $MAIN.
   ACCT can also be a list: (FROMACCT TOACCT), for a transfer.
   In that case TOID should be the logged in ID.
   Fees are always taken from $MAIN."
  (let ((db (db client))
        (parser (parser client)))
    (require-current-bank client "In spend(): Bank not set")
    (init-bank-accts client)
    (handler-bind
        ((validation-error #'signal)
         (error (lambda (c)
                  (declare (ignore c))
                  (forceinit client))))
      (with-verify-sigs-p (parser nil)
        (with-db-lock (db (userreqkey client))
          (handler-bind
              ((validation-error #'signal)
               (error (lambda (c)
                        (declare (ignore c))
                        (if (reload-asset-p client assetid)
                            (return-from spend
                              (spend-internal
                               client toid assetid formattedamount acct note))))))
            (spend-internal client toid assetid formattedamount acct note)))))))

(defmethod spend-internal ((client client) toid assetid formattedamount acct note)
  (let ((db (db client))
        (id (id client))
        (bankid (bankid client))
        (server (server client))
        (parser (parser client))
        (acct (or (if (listp acct) (car acct) acct) $MAIN))
        (toacct (or (and (listp acct) (cadr acct)) $MAIN))
        (amount (unformat-asset-value client formattedamount assetid))
        oldamount
        oldtime
        time
        (storagefee 0)
        (digits 0)
        percent
        fraction
        fractime
        fracfee
        baseoldamount
        newamount
        oldtoamount
        newtoamount
        (tranfee nil)
        tranfee-asset
        (tranfee-amt nil)
        fee-balance
        (need-fee-balance-p nil))

    (assert (and (stringp acct) (stringp toacct)))

    (when (and (equal id toid) (equal acct toacct))
      (validation-error "Transfer from and to the same acct (~s). Nothing to do."
             acct))

    ;; Must get time before accessing balances since GETTIME may FORCEINIT.
    (setq time (gettime client))

    (when (< (bccomp amount 0) 0)
      (let ((bal (userbalance client acct assetid)))
        (unless (eql 0 (bccomp bal amount))
          (validation-error
           "Negative spends must be for the whole issuer balance"))))

    (multiple-value-setq (oldamount oldtime)
      (userbalanceandtime client acct assetid))
    (cond (oldamount
           (unless (is-numeric-p oldamount t)
             (validation-error
              "Error getting balance for asset in acct ~s: ~s" acct oldamount))

           (multiple-value-setq (percent fraction fractime)
             (client-storage-info client assetid))
           (when percent
             (setq digits (fraction-digits percent))
             (multiple-value-setq (fracfee fraction)
               (storage-fee fraction fractime time percent digits))
             (multiple-value-setq (storagefee oldamount)
               (storage-fee oldamount oldtime time percent digits))
             (wbp (digits)
               (setq storagefee (bcadd storagefee fracfee)
                     baseoldamount oldamount))
             (multiple-value-setq (oldamount fraction)
               (normalize-balance oldamount fraction digits))))
          (t (setq oldamount "0")))

    (setq newamount (bcsub oldamount amount))
    (when (and (>= (bccomp oldamount 0) 0)
               (< (bccomp newamount 0) 0))
      (cond ((and (equal id toid)
                  percent
                  (<= (bccomp amount baseoldamount) 0))
             ;; User asked to transfer less than the whole amount, but the
             ;; storage fee put it over. Reduce amount to leave 0 in ACCT
             (setq amount oldamount
                   newamount 0))
            (t (validation-error "Insufficient balance"))))

    (when (equal id toid)
      (let (totime tofee)
        (multiple-value-setq (oldtoamount totime)
          (userbalanceandtime client toacct assetid))
        (when (and percent oldtoamount)
          (multiple-value-setq (tofee oldtoamount)
            (storage-fee oldtoamount totime time percent digits))
          (wbp (digits)
            (setq storagefee (bcadd storagefee tofee)
                  oldtoamount (bcsub oldtoamount tofee))))
        (wbp (digits)
          (setq newtoamount (bcadd (or oldtoamount 0) amount digits)))
        (when percent
          (multiple-value-setq (newtoamount fraction)
            (normalize-balance newtoamount fraction digits)))
        (when (and oldtoamount
                   (< (bccomp oldtoamount 0) 0)
                   (>= (bccomp newtoamount 0) 0))
          ;; This shouldn't be possible.
          ;; If it happens, it means the asset is out of balance.
          (validation-error "Asset out of balance on self-spend"))))

    (unless (equal id bankid)
      (setq tranfee (getfees client)
            tranfee-asset (fee-assetid tranfee))
      (setq tranfee-amt
            (if (equal id toid)
                (if oldtoamount "0" "1")
                (fee-amount tranfee)))
      (cond ((and (equal tranfee-asset assetid)
                  (equal $MAIN acct))
             (setq newamount (bcsub newamount tranfee-amt))
             (when (and (>= (bccomp oldamount 0) 0)
                        (< (bccomp newamount 0) 0))
               (validation-error "Insufficient balance for transaction fee")))
            ((and (equal id toid)
                  (equal tranfee-asset assetid)
                  (equal $MAIN toacct))
             (setq newtoamount (bcsub newtoamount tranfee-amt))
             (when (eql 0 (bccomp newtoamount oldtoamount))
               (validation-error "Transferring one token to a new acct is silly"))
             (when (and (>= (bccomp oldtoamount 0) 0)
                        (< (bccomp newtoamount 0) 0))
               (validation-error
                "Insufficient destination balance for transaction fee")))
            (t
             (let ((old-fee-balance (userbalance client $MAIN tranfee-asset)))
               (unless (eql 0 (bccomp tranfee-amt 0))
                 (setq fee-balance (bcsub old-fee-balance tranfee-amt)
                       need-fee-balance-p t)
                 (when (and (>= (bccomp old-fee-balance 0) 0)
                            (< (bccomp fee-balance 0) 0))
                   (validation-error
                    "Insufficient tokens for transaction fee")))))))

    ;; Numbers are computed and validated.
    ;; Create messages for server.
    (let (spend
          (feeandbal nil)
          (feebal nil)
          (feemsg nil)
          balance
          (tobalance nil)
          (outboxhash nil)
          (balancehash nil)
          (storagefeemsg nil)
          (fracmsg nil)
          msg)
      (setq spend (apply #'custmsg client $SPEND bankid time
                         toid assetid amount (and note (list note))))
      (when (and tranfee-amt (not (equal id toid)))
        (setq feemsg (custmsg client $TRANFEE bankid time
                              tranfee-asset tranfee-amt)
              feeandbal feemsg))
      (when need-fee-balance-p
        (setq feebal (custmsg client $BALANCE bankid time
                              tranfee-asset fee-balance))
        (if feeandbal
            (dotcat feeandbal "." feebal)
            (setq feeandbal feebal)))

      (setq balance (custmsg client $BALANCE bankid time
                             assetid newamount acct))
      (when (equal id toid)
        (setq tobalance (custmsg client $BALANCE bankid time
                                 assetid newtoamount toacct)))
      (when (and (not (equal id bankid))
                 (not (equal id toid)))
        (setq outboxhash (outboxhashmsg client time spend)))

      ;; Compute balancehash
      (unless (equal id bankid)
        (let* ((acctbals (make-equal-hash)))
          (setf (gethash assetid (get-inited-hash acct acctbals))
                balance)
          (when feebal
            (setf (gethash tranfee-asset (get-inited-hash $MAIN acctbals))
                  feebal))
          (when tobalance
            (setf (gethash assetid (get-inited-hash toacct acctbals))
                  tobalance))
          (setq balancehash (balancehashmsg client time acctbals))))

      ;; Prepare storage fee related message components
      (when percent
        (setq storagefeemsg (custmsg client $STORAGEFEE bankid time
                                     assetid storagefee)
              fracmsg (custmsg client $FRACTION bankid time assetid fraction)))

      ;; Send request to server, and get response
      (setq msg spend)
      (when feeandbal (dotcat msg "." feeandbal))
      (dotcat msg "." balance)
      (when tobalance (dotcat msg "." tobalance))
      (when outboxhash (dotcat msg "." outboxhash))
      (when balancehash (dotcat msg "." balancehash))
      (when percent (dotcat msg "." storagefeemsg "." fracmsg))

      (let* ((bankmsg (process server msg)) ; *** Here's the server call ***
             (reqs (parse parser bankmsg t))
             (msgs (make-equal-hash spend t
                                    balance t))
             (coupon nil)
             encrypted-coupon)
        (handler-case (match-bankreq client (car reqs) $ATSPEND)
          (error ()
            (let* ((args (match-bankreq client (car reqs)))
                   (request (getarg $REQUEST args)))
              (error "Spend request returned unknown message type: ~s"
                     request))))
        (when tobalance (setf (gethash tobalance msgs) t))
        (when outboxhash (setf (gethash outboxhash msgs) t))
        (when balancehash (setf (gethash balancehash msgs) t))
        (when feeandbal
          (when feemsg (setf (gethash feemsg msgs) t))
          (when feebal (setf (gethash feebal msgs) t)))
        (when percent
          (setf (gethash storagefeemsg msgs) t
                (gethash fracmsg msgs) t))

        (dolist (req reqs)
          (let ((onemsg (get-parsemsg req))
                (oneargs (match-bankreq client req)))
            (cond ((equal (getarg $REQUEST oneargs) $COUPONENVELOPE)
                   (when coupon
                     (error "Multiple coupons returned from server"))
                   (setq coupon onemsg
                         encrypted-coupon (getarg $ENCRYPTEDCOUPON oneargs)))
                  (t
                   (let ((m (trim (get-parsemsg (getarg $MSG oneargs)))))
                     (typecase (gethash m msgs)
                       (null (error "Returned message wasn't sent: ~s" m))
                       (string (error "Duplicate returned message: ~s" m)))
                     (setf (gethash m msgs) onemsg))))))

        (loop
           for m being the hash-key using (hash-value msg) of msgs
           do
           (when (eq msg t)
             (error "Message not returned from spend: ~s" m)))
          
        ;; All is well. Commit this baby.
        (setf (db-get db (userbalancekey client acct assetid))
              (gethash balance msgs))
        (when tobalance
          (setf (db-get db (userbalancekey client toacct assetid))
                (gethash tobalance msgs)))
        (when outboxhash
          (setf (db-get db (useroutboxhashkey client))
                (gethash outboxhash msgs)))
        (when balancehash
          (setf (db-get db (userbalancehashkey client))
                (gethash balancehash msgs)))
        (let ((spend (gethash spend msgs)))
          (when feeandbal
            (dotcat spend "." (gethash feemsg msgs))
            (when feebal
              (setf (db-get db (userbalancekey client $MAIN tranfee-asset))
                    (gethash feebal msgs))))
          (when coupon
            (dotcat spend "." coupon)
            (setf (coupon client) encrypted-coupon))

          (when (and (not (equal id toid))
                     (not (equal id bankid)))
            (setf (db-get db (useroutboxkey client time)) spend))
          (setf (last-spend-time client) time)

          (when percent
            (setf (db-get db (userfractionkey client assetid))
                  (gethash fracmsg msgs)))

          (when (keep-history-p client)
            (setf (db-get db (userhistorykey client) time) spend)))))))

(defmethod reload-asset-p ((client client) assetid)
  "Reload an asset from the server.
   Return true if the storage percent changed."
  (let* ((asset (getasset client assetid))
         (percent (asset-percent asset)))
    (setq asset (getasset client assetid t))
    (not (equal percent (asset-percent asset)))))

(defmethod spendreject ((client client) time &optional note)
  (let ((db (db client))
        (parser (parser client))
        (need-init-p t))
    (require-current-bank client "In spendreject(): Bank not set")
    (init-bank-accts client)

    (unwind-protect
         (with-verify-sigs-p (parser nil)
           (with-db-lock (db (userreqkey client))
             (prog1 (spendreject-internal client time note)
               (setq need-init-p nil))))
      (when need-init-p
        (forceinit client)))))

(defmethod spendreject-internal ((client client) time note)
  (let* ((db (db client))
         (bankid (bankid client))
         (id (id client))
         (server (server client))
         (parser (parser client))
         (msg (or (ignore-errors (useroutbox client time))
                  (error "No outbox entry at time: ~s" time)))
         (reqs (parse parser msg)))
    (dolist (req reqs)
      (let ((args (match-bankreq client req)))
        (when (equal (getarg $REQUEST args) $COUPONENVELOPE)
          (let ((coupon (getarg $ENCRYPTEDCOUPON args)))
            (when coupon
              (setq coupon (privkey-decrypt coupon (privkey client)))
              (return-from spendreject-internal
                (redeem client coupon)))))))
    (setq msg (apply #'custmsg client $SPENDREJECT bankid time id
                     (and note (list note))))
    (let* ((bankmsg (process server msg))
           (args (with-verify-sigs-p (parser t)
                   (unpack-bankmsg client bankmsg $INBOX)))
           (time (getarg $TIME args))
           (args2 (getarg $MSG args))
           (msg2 (get-parsemsg args2)))
      (unless (equal (trim msg2) (trim msg))
        (error "Bank return didn't wrap request"))
      (setf (db-get db (userinboxkey client) time) bankmsg))))

(defmethod gethistorytimes ((client client))
  (let ((db (db client)))
    (require-current-bank client "In gethistorytimes(): Bank not set")
    (sort (db-contents db (userhistorykey client))
          (lambda (x y) (< (bccomp y x) 0)))))

(defmethod gethistoryitems ((client client) time)
  "Get the history items for $time.
   Return nil if there is no corresponding item.
   Otherwise, return a list of matched inner message hash tables."
  (let ((db (db client))
        (parser (parser client)))
    (require-current-bank client "In gethistoryitems(): Bank not set")
    (let* ((msg (db-get db (userhistorykey client) time)))
      (when msg
        (let ((reqs (parse parser msg))
              res)
          (dolist (req reqs)
            (let* ((args (match-pattern parser req))
                   (inner (getarg $MSG args)))
              (when inner
                (let* ((atrequest (getarg $REQUEST args)))
                  (setq args (match-pattern parser inner))
                  (setf (getarg $ATREQUEST args) atrequest)))
              (let* ((assetid (getarg $ASSET args))
                     (amount (getarg $AMOUNT args)))
                (when (and assetid amount)
                  (let ((asset (getasset client assetid)))
                         (setf (getarg $ASSETNAME args) (asset-name asset)
                               (getarg $FORMATTEDAMOUNT args)
                               (format-asset-value client amount asset nil)))))
              (push args res)))
          (nreverse res))))))

(defmethod removehistoryitem ((client client) time)
  "Remove a history item"
  (let ((db (db client)))
    (require-current-bank client "In removehistoryitem(): Bank not set")
    (setf (db-get db (userhistorykey client) time) nil)))

(defmethod getcoupon ((client client))
  "Return the last coupon resulting from a spend.
   Clear the coupon store, so you can only get the coupon once."
  (let ((coupon (coupon client)))
    (setf (coupon client) nil)
    (and coupon (privkey-decrypt coupon (privkey client)))))

(defstruct inbox
  request
  id
  time
  msgtime
  assetid
  assetname
  amount
  formattedamount
  note
  reply                                 ;used by client-web.lisp
  items)

(defmethod getinbox ((client client) &optional includeraw)
  "Get the inbox contents.
   Returns a list of INBOX instances, sorted by INBOX-TIME.
   If INCLUDERAW is true, will return as a second value a
   hash table mapping those instances to the raw message
   strings from which they came.
   INBOX-REQUEST is $SPEND, $SPENDACCEPT, or $SPENDREJECT,
   INBOX-ID is the ID of the sender of the inbox entry,
   INBOX-TIME is the timestamp from the bank on the inbox entry,
   INBOX-MSGTIME is the timestamp in the sender's message,
   INBOX-ASSETID & INBOX-ASSETNAME describe the asset being transferred,
   INBOX-AMOUNT is the amount of the asset being transferred, as an integer,
   INBOX-FORMATTEDAMOUNT is the amount as a decimal number with the scale
   and precision applied,
   INBOX-NOTE is the note that came from the sender
   INBOX-ITEMS is other items from the same inbox entry, e.g. fees."
  (let ((db (db client)))
    (require-current-bank client "In getinbox(): Bank not set")
    (init-bank-accts client)
    (with-db-lock (db (userreqkey client))
      (getinbox-internal client includeraw))))

(defmethod getinbox-internal ((client client) includeraw)
  (let ((db (db client))
        (parser (parser client))
        (bankid (bankid client))
        (res nil)
        (msghash (and includeraw (make-hash-table :test #'eq)))
        (key (userinboxkey client)))
    (sync-inbox client)
    (dolist (time (db-contents db key))
      (let* ((msg (db-get db key time))
             (reqs (parse parser msg))
             last-item)
        (dolist (req reqs)
          (let* ((args (match-bankreq client req))
                 (argstime (getarg $TIME args)))
            (unless (or (null argstime) (equal argstime time))
              (error "Inbox message timestamp mismatch"))
            (setq args (getarg $MSG args))
            (let ((request (getarg $REQUEST args))
                  (id (getarg $CUSTOMER args))
                  (msgtime (getarg $TIME args))
                  (note (getarg $NOTE args))
                  assetid
                  amount
                  assetname
                  formattedamount)
              (cond ((or (equal request $SPEND)
                         (equal request $TRANFEE))
                     (setq assetid (getarg $ASSET args)
                           amount (getarg $AMOUNT args))
                     (let ((asset (ignore-errors (getasset client assetid)))
                           incnegs-p)
                       (when asset
                         (setq assetname (asset-name asset)
                               incnegs-p (not (equal (getarg $CUSTOMER args)
                                                     bankid))
                               formattedamount (format-asset-value
                                                client amount asset incnegs-p)))))
                    ((or (equal request $SPENDACCEPT)
                         (equal request $SPENDREJECT))
                     ;; To do: Pull in data from outbox to get amounts
                     )
                    (t (error "Bad request in inbox: ~s" request)))
              (let ((item (make-inbox :request request
                                      :id id
                                      :time time
                                      :msgtime msgtime
                                      :assetid assetid
                                      :assetname assetname
                                      :amount amount
                                      :formattedamount formattedamount
                                      :note note)))
                (cond ((equal request $SPEND)
                       (push item res)
                       (setq last-item item))
                      ((equal request $TRANFEE)
                       (unless last-item
                         (error "tranfee without matching spend"))
                       (push item (inbox-items last-item)))
                      (t (push item res)
                         (setq last-item nil)))
              (when (and includeraw (eq (car res) item))
                (setf (gethash item msghash) msg))))))))
    (values
     (sort res (lambda (t1 t2) (< (bccomp t1 t2) 0)) :key #'inbox-time)
     msghash)))

(defmethod sync-inbox ((client client))
  "Synchronize the current customer inbox with the current bank.
   Assumes that there IS a current user and bank.
   Does no database locking."
  (handler-case (sync-inbox-internal client)
    (error ()
      (forceinit client)
      (sync-inbox-internal client))))

(defmethod sync-inbox-internal ((client client))
  (let* ((db (db client))
         (bankid (bankid client))
         (parser (parser client))
         (server (server client))
         (msg (custmsg client $GETINBOX bankid (getreq client)))
         (bankmsg (process server msg))
         (reqs (parse parser bankmsg))
         (inbox (make-equal-hash))
         (times nil)
         (storagefees (make-equal-hash))
         (last-time nil))
    (dolist (req reqs)
      (let* ((args (match-bankreq client req))
             (bankmsg (get-parsemsg req))
             (request (getarg $REQUEST args)))
        (cond ((equal request $ATGETINBOX)
               (let ((retmsg (get-parsemsg (getarg $MSG args))))
                 (unless (equal (trim retmsg) (trim msg))
                   (error "getinbox return doesn't wrap message sent"))
                 (setq last-time nil)))
              ((equal request $INBOX)
               (let ((time (getarg $TIME args)))
                 (when (gethash time inbox)
                   (error "getinbox return included multiple entries for time: ~s"
                          time))
                 (setf (gethash time inbox) bankmsg
                       last-time time)))
              ((equal request $ATTRANFEE)
               (unless last-time
                 (error "In getinbox return: @tranfee not after inbox"))
               (setf (gethash last-time inbox)
                     (strcat (gethash last-time inbox) "." bankmsg)
                     last-time nil))
              ((equal request $TIME)
               (push (getarg $TIME args) times)
               (setq last-time nil))
              ((equal request $STORAGEFEE)
               (let ((assetid (getarg $ASSET args)))
                 (setf (gethash assetid storagefees) bankmsg)))
              ((not (equal request $COUPONNUMBERHASH))
               (error "Unknown request in getinbox return: ~s" request)))))

    (let* ((key (userinboxkey client))
           (keys (db-contents db key)))
      (dolist (time keys)
        (let ((inmsg (gethash time inbox)))
          (if inmsg
            (let ((msg (db-get db key time)))
              (unless (equal msg inmsg)
                (error "Inbox mismatch at time: ~s" time))
              (remhash time inbox))
            (setf (db-get db key time) nil))))
      (loop
         for time being the hash-key using (hash-value msg) of inbox
         do
           (setf (db-get db key time) msg)))

    (let ((key (userstoragefeekey client)))
      (dolist (assetid (db-contents db key))
        (unless (gethash assetid storagefees)
          (setf (db-get db key assetid) nil)))
      (loop
         for assetid being the hash-key using (hash-value storagefee) of storagefees
         do
           (setf (db-get db key assetid) storagefee)))

    (when times
      (setf (db-get db (usertimekey client)) (apply #'implode "," times)))))

(defmethod getinboxignored ((client client))
  "Return a list of the timestamps that were ignored in the last processinbox"
  (explode #\, (db-get (db client) (userinboxignoredkey client))))

(defmethod (setf getinboxignored) (list (client client))
  "Return a list of the timestamps that were ignored in the last processinbox"
  (setf (db-get (db client) (userinboxignoredkey client))
        (apply #'implode #\, list))
  list)

(defstruct process-inbox
  time                                  ;timestamp in the inbox
  request                               ;$SPENDACCEPT, SPENDREJECT, or nil
  note                                  ;note for accept or reject
  acct)                                 ;Account into which to transfer

(defmethod processinbox ((client client) directions)
  "Process the inbox contents.
   DIRECTIONS is a list of PROCESS-INBOX instances."
  (let ((db (db client))
        (parser (parser client))
        (need-init-p t))
    (require-current-bank client "In processinbox(): Bank not set")
    (init-bank-accts client)

    (unwind-protect
         (with-verify-sigs-p (parser nil)
           (with-db-lock (db (userreqkey client))
             (prog1 (processinbox-internal client directions nil)
               (setq need-init-p nil))))
      (when need-init-p (forceinit client)))))

(defmethod processinbox-internal ((client client) directions recursive)
  (let ((db (db client))
        (bankid (bankid client))
        (server (server client))
        (parser (parser client))
        (trans (gettime client))
        inbox inbox-msgs
        outbox outbox-msgs
        (balance (getbalance-internal client t nil))
        (timelist "")
        (deltas (make-equal-hash)) ;(acct => (asset => delta, ...), ...) 
        (outbox-deletions nil)
        (msg "")
        (msgs (make-equal-hash))
        (history "")
        (hist "")
        (charges (make-equal-hash)))
    (multiple-value-setq (inbox inbox-msgs)
      (getinbox-internal client (keep-history-p client)))
    (multiple-value-setq (outbox outbox-msgs)
      (getoutbox-internal client (keep-history-p client)))
    (dolist (dir directions)
      (let* ((time (process-inbox-time dir))
             (request (process-inbox-request dir))
             (note (process-inbox-note dir))
             (acct (or (process-inbox-acct dir) $MAIN))
             (in (or (find time inbox :test #'equal :key #'inbox-time)
                     (error "No inbox entry for time: ~s" time)))
             (fee (car (inbox-items in))) ;change this when I add multiple fees
             (inmsg (and inbox-msgs (gethash in inbox-msgs)))
             (inreq (inbox-request in))
             (delta (get-inited-hash acct deltas)))

        (unless (equal "" timelist) (dotcat timelist "|"))
        (dotcat timelist time)

        (cond ((equal inreq $SPEND)
               (let ((id (inbox-id in))
                     (assetid (inbox-assetid in))
                     (msgtime (inbox-msgtime in))
                     (amount (inbox-amount in)))
                 (unless (equal msg "") (dotcat msg "."))
                 (cond ((equal request $SPENDACCEPT)
                        (setq amount
                              (do-storagefee
                                  client charges amount msgtime trans assetid))
                        (setf (gethash assetid delta)
                              (bcadd (gethash assetid delta 0) amount))
                        (let ((smsg (custmsg client $SPENDACCEPT bankid
                                             msgtime id note)))
                          (setf (gethash smsg msgs) t)
                          (dotcat msg smsg)
                          (when inmsg
                            (dotcat hist "." smsg "." inmsg))))
                       ((equal request $SPENDREJECT)
                        (when fee
                          (let ((feeasset (inbox-assetid fee)))
                            (setf (gethash feeasset delta)
                                  (bcadd (gethash feeasset delta 0)
                                         (inbox-amount fee)))))
                        (let ((smsg (custmsg client $SPENDREJECT bankid
                                             msgtime id note)))
                          (setf (gethash smsg msgs) t)
                          (dotcat msg smsg)
                          (when inmsg
                            (dotcat hist "." smsg "." inmsg))))
                       (t (error "Illegal request for spend: ~s" request)))))
              ((or (equal inreq $SPENDACCEPT) (equal inreq $SPENDREJECT))
               (let* ((msgtime (inbox-msgtime in))
                      (outspend (or (find msgtime outbox
                                          :test #'equal :key #'outbox-time)
                                    (error "Can't find outbox for ~s at time ~s"
                                           inreq msgtime)))
                      (outfee (car (outbox-items outspend)))
                      (outmsg (and outbox-msgs (gethash outspend outbox-msgs))))
                 (push msgtime outbox-deletions)
                 (cond ((equal inreq $SPENDREJECT)
                        ;; For rejected spends, we get our money back
                        (let ((assetid (outbox-assetid outspend))
                              (amount (outbox-amount outspend)))
                          (setq amount
                                (do-storagefee
                                    client charges amount msgtime trans assetid))
                          (setf (gethash assetid delta)
                                (bcadd (gethash assetid delta 0) amount))))
                       (outfee
                        ;; For accepted spends, we get our tranfee back
                        (let ((feeasset (outbox-assetid outfee)))
                          (setf (gethash feeasset delta)
                              (bcadd (gethash feeasset delta 0)
                                     (outbox-amount outfee))))))
                 (when outmsg
                   (dotcat hist "." inmsg "." outmsg))))
              (t "Unrecognized inbox request: ~s" inreq))))

    (let ((pmsg (custmsg client $PROCESSINBOX bankid trans timelist))
          (acctbals (make-equal-hash))
          (outboxhash nil)
          (balancehash nil)
          (fracmsgs nil))
      (setf (gethash pmsg msgs) t)
      (setq msg (if (equal msg "") pmsg (dotcat pmsg "." msg)))
      (when (keep-history-p client)
        (setq history (strcat pmsg hist)))

      ;; Compute fees for new balance files
      (let* ((tranfee (getfees client))
             (feeasset (fee-assetid tranfee))
             (delta-main (get-inited-hash $MAIN deltas)))
        (loop
           for acct being the hash-key using (hash-value amounts) of deltas
           for bals = (cdr (assoc acct balance :test #'equal))
           do
           (loop
              for assetid being the hash-key of amounts
              for oldbal = (find assetid bals
                                 :test #'equal :key #'balance-assetid)
              for oldamount = (and oldbal (balance-amount oldbal))
              do
                (when (and oldamount (> (bccomp oldamount 0) 0))
                  (let ((oldtime (balance-time oldbal)))
                    (setf oldamount (do-storagefee
                                        client charges oldamount oldtime trans assetid)
                          (balance-amount oldbal) oldamount)))
                (unless oldamount
                  (setf (gethash feeasset delta-main)
                        (bcsub (gethash feeasset delta-main 0) 1))))))

      ;; Create balance, outboxhash, and balancehash messages
      (loop
         for acct being the hash-key using (hash-value amounts) of deltas
         for bals = (cdr (assoc acct balance :test #'equal))
         for acctbal = (get-inited-hash acct acctbals)
         do
         (loop
            for assetid being the hash-key using (hash-value amount) of amounts
            for bal = (find assetid bals :test #'equal :key #'balance-assetid)
            for oldamount = (if bal (balance-amount bal) 0)
            for sum = (bcadd oldamount amount)
            for balmsg = (custmsg client $BALANCE bankid trans assetid sum acct)
            do
              (setf (gethash balmsg msgs) t
                    (gethash assetid acctbal) balmsg)
              (dotcat msg "." balmsg)))

      (when outbox-deletions
        (setf outboxhash (outboxhashmsg client trans nil outbox-deletions)
              (gethash outboxhash msgs) t)
        (dotcat msg "." outboxhash))

      (setf balancehash (balancehashmsg client trans acctbals)
            (gethash balancehash msgs) t)
      (dotcat msg "." balancehash)

      ;; Add storage and fraction messages
      (loop
         for assetid being the hash-key using (hash-value assetinfo) of charges
         for percent = (assetinfo-percent assetinfo)
         do
           (when percent
             (let* ((storagefee (assetinfo-storagefee assetinfo))
                    (fraction (assetinfo-fraction  assetinfo))
                    (storagefeemsg (custmsg client $STORAGEFEE bankid
                                            trans assetid storagefee))
                    (fracmsg (custmsg client $FRACTION bankid
                                      trans assetid fraction)))
               (unless fracmsgs (setq fracmsgs (make-equal-hash)))
               (setf (gethash storagefeemsg msgs) t
                     (gethash fracmsg msgs) t
                     (gethash assetid fracmsgs) fracmsg)
               (dotcat msg "." storagefeemsg "." fracmsg))))

    (let* ((retmsg (process server msg)) ;send request to server
           (reqs (parse parser retmsg t)))
      ;; Validate return from server
      (handler-case (match-bankreq client (car reqs) $ATPROCESSINBOX)
        (error ()
          (let ((args
                 (handler-case (match-bankreq client (car reqs))
                   (error (c)
                     (unless recursive
                       (with-verify-sigs-p (parser t)
                         ;; Force reload of balances and outbox
                         (forceinit client)
                         ;; Force reload of assets
                         (when charges
                           (loop
                              for assetid being the hash-keys of
                              charges
                              do
                                (reload-asset-p client assetid)))
                         (return-from processinbox-internal
                           (processinbox-internal client directions t))))
                     (error "Error from processinbox request: ~a" c)))))
            (error "Processinbox request returned unknown message type: ~s"
                   (getarg $REQUEST args)))))
      (dolist (req reqs)
        (let* ((reqmsg (get-parsemsg req))
               (args (match-bankreq client req))
               (m (trim (get-parsemsg (getarg $MSG args))))
               (msgm (gethash m msgs)))
          (unless msgm (error "Returned message wasn't sent: ~s" m))
          (when (stringp msgm) (error "Duplicate returned message: ~s" m))
          (setf (gethash m msgs) reqmsg)))

      (loop
         for m being the hash-key using (hash-value msg) of msgs
         do
           (when (eq msg t)
             (error "Message not returned from processinbox: ~s" m)))

      ;; Commit to database
      (loop
         for acct being the hash-key using (hash-value bals) of acctbals
         do
         (loop
            for asset being the hash-key using (hash-value balmsg) of bals
            do
              (setf (db-get db (userbalancekey client acct asset))
                    (gethash balmsg msgs))))

      (when fracmsgs
        (loop
           for assetid being the hash-key using (hash-value fracmsg) of fracmsgs
           for key = (userfractionkey client assetid)
           do
           (setf (db-get db key) (gethash fracmsg msgs))))

      (when outboxhash
        (dolist (outbox-time outbox-deletions)
          (setf (db-get db (useroutboxkey client outbox-time)) nil))
        (setf (db-get db (useroutboxhashkey client)) (gethash outboxhash msgs)))

      (setf (db-get db (userbalancehashkey client)) (gethash balancehash msgs))

      (when history
        (let ((key (userhistorykey client)))
          (setf (db-get db key trans) history)))))))

(defmethod storagefees ((client client))
  "Tell server to move storage fees to inbox
   You need to call getinbox to see the new data (via its call to sync_inbox)."
  (let ((db (db client)))
    (require-current-bank client "In storagefees(): Bank not set")
    (init-bank-accts client)
    (with-db-lock (db (userreqkey client))
      (let* ((bankid (bankid client))
             (server (server client))
             (req (getreq client))
             (msg (custmsg client $STORAGEFEES bankid req))
             (bankmsg (process server msg))
             (args (unpack-bankmsg client bankmsg))
             (request (getarg $REQUEST args)))
        (unless (equal request $ATSTORAGEFEES)
          (error "Unknown response type: ~s" request))))))

(defstruct assetinfo
  percent
  fraction
  storagefee
  digits)

(defmethod do-storagefee ((client client) charges amount msgtime time assetid)
  "Add storage fee for AMOUNT/MSGTIME to
   (STORAGEINFO-STORAGEFEE (GETHASH ASSETID CHARGES))
   and set (STORAGEINFO-FRACTION (GETHASH ASSETID CHARGES))
   to the fractional balance.
   Return the updated AMOUNT."
  (when (> (bccomp amount 0) 0)
    (let ((assetinfo (gethash assetid charges))
          (digits nil)
          (fracfee nil))
      (unless assetinfo
        (multiple-value-bind (percent fraction fractime)
            (client-storage-info client assetid)
        (when percent
          (setq digits (fraction-digits percent)
                fracfee 0)
          (when fraction
            (multiple-value-setq (fracfee fraction)
              (storage-fee fraction fractime time percent digits))))
        (setf assetinfo (make-assetinfo
                         :percent percent
                         :fraction fraction
                         :storagefee fracfee
                         :digits digits)
              (gethash assetid charges) assetinfo)))
      (let ((percent (assetinfo-percent assetinfo)))
        (when percent
          (let ((digits (assetinfo-digits assetinfo))
                (storagefee (assetinfo-storagefee assetinfo))
                (fraction (assetinfo-fraction assetinfo))
                fee)
            (wbp (digits)
              (multiple-value-setq (fee amount)
                (storage-fee amount msgtime time percent digits))
              (setf (assetinfo-storagefee assetinfo) (bcadd storagefee fee))
              (when fraction
                (multiple-value-setq (amount fraction)
                  (normalize-balance amount fraction digits)))
              (setf (assetinfo-fraction assetinfo) fraction)))))))
  amount)

(defstruct outbox
  time
  id
  request
  assetid
  assetname
  amount
  formattedamount
  note
  items
  coupons)

(defmethod getoutbox ((client client) &optional includeraw)
  "Get the outbox contents.
   Returns a list of OUTBOX instances:
   TIME is the timestamp of the outbox entry.
   REQUEST is $SPEND, $TRANFEE, or $COUPONENVELOPE.
   ASSETID is the ID of the asset transferred.
   ASSETNAME is the name of ASSETID.
   AMOUNT is the amount transferred.
   FORMATTEDAMOUNT is amount formatted for output.
   NOTE is the transfer note, omitted for tranfee.
   ITEMS is a list of OUTBOX instances for the fees for this spend.
   COUPONs is a list of coupons in this spend."
  (let ((db (db client)))
    (require-current-bank client "In getoutbox(): Bank not set")
    (init-bank-accts client)
    (with-db-lock (db (userreqkey client))
      (getoutbox-internal client includeraw))))

(defmethod getoutbox-internal ((client client) &optional includeraw)
  (let* ((db (db client))
         (parser (parser client))
         (bankid (bankid client))
         (res nil)
         (msghash (and includeraw (make-hash-table :test #'eq)))
         (key (useroutboxkey client))
         (outbox (db-contents db key)))
    (dolist (time outbox)
      (let* ((msg (db-get db key time))
             (reqs (parse parser msg t))
             (item nil)
             (items nil)
             (coupons nil))
        (dolist (req reqs)
          (let* ((args (match-bankreq client req))
                 (request (getarg $REQUEST args))
                 (incnegs t)
                 assetid
                 amount
                 assetname
                 formattedamount
                 id
                 outbox)
            (unless (equal request $COUPONENVELOPE)
              (setq args (getarg $MSG args))
              (unless (equal (getarg $TIME args) time)
                (error "Outbox message timestamp mismatch")))
            (setq id (getarg $ID args)
                  request (getarg $REQUEST args)
                  assetid (getarg $ASSET args)
                  amount (getarg $AMOUNT args))
            (when (equal id bankid) (setq incnegs nil))
            (when assetid
              (let ((asset (getasset client assetid)))
                (setq assetname (asset-name asset)
                      formattedamount (format-asset-value
                                       client amount asset incnegs))))
            (setq outbox
                  (make-outbox
                   :time time
                   :id id
                   :request request
                   :assetid assetid
                   :assetname assetname
                   :amount amount
                   :formattedamount formattedamount))

            (cond ((equal request $SPEND)
                   (when item
                     (error "More than one spend message in an outbox item"))
                   (setf item outbox
                         (outbox-note item) (getarg $NOTE args)))
                  ((equal request $TRANFEE)
                   (push outbox items))
                  ((equal request $COUPONENVELOPE)
                   (let* ((coupon (privkey-decrypt
                                   (or (getarg $ENCRYPTEDCOUPON args)
                                       (error "No encryptedcoupon in a coupon"))
                                   (privkey client)))
                          (args (unpack-bankmsg client coupon $COUPON))
                          (url (getarg $BANKURL args))
                          (coupon-number (getarg $COUPON args)))
                     (push (format nil "[~a, ~a]" url coupon-number)
                           coupons)))
                  (t (error "Bad request in outbox: ~s" request)))))
        (unless item
          (error "No spend found in outbox item"))
        (setf (outbox-items item) items
              (outbox-coupons item) coupons)
        (push item res)
        (when includeraw
          (setf (gethash item msghash) msg))))
    (values
     (sort res (lambda (x y) (< (bccomp x y) 0))
           :key #'outbox-time)
     msghash)))

(defmethod redeem ((client client) coupon)
  "Redeem a coupon
   If successful, add an inbox entry for the coupon spend and return false.
   If fails, return error message.
   Needs an option to process the coupon, intead of just adding it to
   the inbox."
  (let* ((bankid (bankid client))
         (pubkey (or (db-get (pubkeydb client) bankid)
                     (error "Can't get bank public key")))
         (coupon (pubkey-encrypt coupon pubkey))
         (msg (sendmsg client $COUPONENVELOPE bankid coupon)))
    (unpack-bankmsg client msg $ATCOUPONENVELOPE))
  nil)

(defmethod getversion ((client client) &optional forceserver)
  "Returns two values: version & time."
  (let* ((db (db client))
         (key (userversionkey client)))
    (require-current-bank client "In getversion(): Bank not set")
    (with-db-lock (db (userreqkey client))
      (let ((msg (unless forceserver (db-get db key))))
        (unless msg
          (setq msg (sendmsg client $GETVERSION (bankid client) (getreq client))
                forceserver t))
        (let ((args (unpack-bankmsg client msg $VERSION)))
          (when forceserver (setf (db-get db key) msg))
          (values (getarg $VERSION args) (getarg $TIME args)))))))

(defmethod readdata ((client client) key &key
                     anonymous-p size-p bankurl)
  (unless anonymous-p
    (require-current-bank client "In readdata(): Bank not set"))
  (let* ((bankid (or (and anonymous-p
                          bankurl
                          (verify-bank client bankurl))
                     (bankid client)
                     (error "Can't determine bankid")))
         (size-arg (and size-p (list "Y")))
         (msg (if anonymous-p
                  (strcat
                   (apply #'makemsg (parser client)
                          "0" $READDATA bankid "0" key size-arg)
                   ":0")
                 (apply #'custmsg client
                        $READDATA bankid (getreq client) key size-arg)))
         (server (if (and anonymous-p bankurl)
                     (make-server-proxy client bankurl)
                     (server client)))
         (save-bankid (prog1 (bankid client)
                        (setf (bankid client) bankid)))
         (bankmsg (process server msg))
         (args (unwind-protect (unpack-bankmsg client bankmsg)
                 (setf (bankid client) save-bankid)))
         (request (getarg $REQUEST args))
         (reqid (getarg $ID args))
         (time (getarg $TIME args))
         (data (getarg $DATA args)))
    (unless (equal request $ATREADDATA)
      (error "Unknown response type: ~s, expected: ~s" request $ATREADDATA))
    (unless (equal (if anonymous-p "0" (id client)) reqid)
      (error "Wrong id returned from readdata"))
    (values data time)))

(defmethod writedata ((client client) key data &optional anonymous-p)
  (require-current-bank client "In writedata(): Bank not set")
  (handler-case (writedata-internal client key data anonymous-p)
    (error ()
      (forceinit client)
      (writedata-internal client key data anonymous-p))))

(defmethod writedata-internal ((client client) key data anonymous-p)
  (let ((db (db client)))
    (with-db-lock (db (userreqkey client))
      (let* ((oldsize (ignore-errors
                        (parse-integer (readdata client key
                                                 :anonymous-p anonymous-p
                                                 :size-p t))))
             (old-cost (if oldsize (data-cost oldsize) 0))
             (new-cost (data-cost data))
             (net-cost (- new-cost old-cost))
             (tokenid (fee-assetid (getfees client)))
             (bal (balance-amount (or (getbalance client $MAIN tokenid)
                                      (error "Insufficient tokens"))))
             (newbal (bcsub bal net-cost)))
        (unless (or (< (bccomp bal 0) 0) (>= (bccomp newbal 0) 0))
          (error "Insufficient balance, need ~a tokens" net-cost))
        (let* ((time (gettime client))
               (bankid (bankid client))
               (anonymous (if anonymous-p "T" ""))
               (msg (custmsg client $WRITEDATA bankid time anonymous key data))
               (balmsg (custmsg client $BALANCE bankid time tokenid newbal))
               (acctbals (make-equal-hash $MAIN (make-equal-hash tokenid newbal)))
               (balhashmsg (balancehashmsg client time acctbals))
               (bankmsg (process (server client)
                                 (strcat msg "." balmsg "." balhashmsg)))
               (reqs (parse (parser client) bankmsg t))
               (args (match-bankreq client (car reqs) $ATWRITEDATA)))
          (unless (and (equal (getarg $ID args) (id client))
                       (equal (getarg $TIME args) time)
                       (equal (getarg $ANONYMOUS args) anonymous)
                       (equal (getarg $KEY args) key))
            (error "Bad return message from bank"))
          (unless (eql 3 (length reqs))
            (error "Wrong number of return messages"))
          (let* ((balreq (second reqs))
                 (balhashreq (third reqs))
                 (bankbalmsg (get-parsemsg balreq))
                 (bankbalhashmsg (get-parsemsg balhashreq)))
            (unless (equal balmsg
                           (get-parsemsg
                            (getarg
                             $MSG (match-bankreq client balreq $ATBALANCE))))
              (error "Returned balance message mismatch"))
            (unless (equal balhashmsg
                           (get-parsemsg
                            (getarg
                             $MSG (match-bankreq client balhashreq $ATBALANCEHASH))))
              (error "Returns balancehash message mismatch"))
            (setf (db-get db (userbalancekey client $MAIN tokenid)) bankbalmsg
                  (db-get db (userbalancehashkey client)) bankbalhashmsg)
            data))))))

(defmethod backup ((client client) &rest keys&values)
  (backup* client keys&values))

(defmethod backup* ((client client) keys&values)
  (require-current-bank client "In writedata(): Bank not set")
  (unless (evenp (length keys&values))
    (error "odd length keys&values list"))
  (let* ((req (getreq client))
         (msg (apply #'sendmsg client $BACKUP req keys&values))
         (args (unpack-bankmsg client msg $ATBACKUP))
         (id (getarg $CUSTOMER args))
         (msgreq (getarg $REQ args)))
    (unless (equal id (bankid client))
      (error "Return from backup request not from bank."))
    (unless (equal req msgreq)
      (error "Mistmatch in req from backup request, sb: ~s, was: ~s"
             req msgreq))))

;;;
;;; End of API methods
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun passphrase-hash (passphrase &optional salt)
  (sha1 (xor-salt (trim passphrase) salt)))

(defmethod custmsg ((client client) &rest args)
  "Create a signed customer message.
   Takes an arbitrary number of args."
  (let* ((id (id client))
         (parser (parser client))
         (privkey (privkey client))
         (args (cons id args))
         (msg (apply #'makemsg parser args))
         (sig (sign msg privkey)))
    (trim (format nil "~a:~%~a~%" msg sig))))

(defmethod sendmsg ((client client) &rest args)
  "Send a customer message to the server.
   Takes an arbitrary number of args."
  (let ((server (server client))
        (msg (apply #'custmsg client args)))
    (process server msg)))

(defmethod unpack-bankmsg ((client client) msg &optional request bankid)
  "Unpack a bank message.
   Return a string if parse error or fail from bank.
   This is called via the $unpacker arg to utility->dirhash & balancehash."
  (let* ((parser (parser client))
         (reqs (parse parser msg))
         (req (car reqs))
         (args (match-bankreq client req request bankid)))
    (setf (getarg $UNPACK-REQS-KEY args) reqs) ;; save parse results
    args))

(defmethod match-bankreq ((client client) req &optional request bankid)
  "Unpack a bank message that has already been parsed."
  (unless (not (blankp bankid)) (setq bankid (bankid client)))
  (let* ((parser (parser client))
         (args (match-pattern parser req bankid)))
    (unless (or (not bankid) (equal (getarg $CUSTOMER args) bankid))
      (error "Return message not from bank"))
    (when (equal (getarg $REQUEST args) $FAILED)
      (error "Server error: ~a" (getarg $ERRMSG args)))
    (when (and request (not (equal (getarg $REQUEST args) request)))
      (error "Wrong return type from bank; sb: ~s, was: ~s"
             request (getarg $REQUEST args)))
    (let* ((msg (getarg $MSG args))
           (msgargs (and msg (match-pattern parser (getarg $MSG args)))))
      (when msgargs
        (let ((msgargs-bankid (getarg $BANKID msgargs)))
          (when (and msgargs-bankid (not (equal msgargs-bankid bankid)))
            (error "While matching bank-wrapped msg: bankid mismatch")))
        (setf (getarg $MSG args) msgargs)))
    args))

(defmethod client-storage-info ((client client) assetid)
  "Get the values necessary to compute the storage fee.
   Returns three values:
    1) percent - The storage fee
    2) fraction - the fraction balance for assetid
    3) fractime - the time of the fraction"
  (let* ((db (db client))
         (asset (or (getasset client assetid) (return-from client-storage-info nil)))
         (issuer (asset-issuer asset))
         (percent (asset-percent asset)))
    (cond ((equal issuer (id client)) nil)
          ((not percent) nil)
          (t (let* ((key (userfractionkey client assetid))
                    (msg (db-get db key)))
               (if msg
                   (let ((args (getarg $MSG (unpack-bankmsg
                                             client msg $ATFRACTION))))
                     (values percent (getarg $AMOUNT args) (getarg $TIME args)))
                   (values percent "0" "0")))))))

(defun pubkeykey (id)
  (append-db-keys $PUBKEY id))

(defmethod bankkey ((client client) &optional prop (bankid (bankid client)))
  (let ((key (append-db-keys $BANK bankid)))
    (if prop
        (append-db-keys key prop)
        key)))

(defmethod bankprop ((client client) prop &optional (bankid (bankid client)))
  (db-get (db client) (bankkey client prop bankid)))


(defmethod assetkey ((client client) &optional assetid)
  (let ((key (bankkey client $ASSET)))
    (if assetid
        (append-db-keys key assetid )
        key)))

(defmethod assetprop ((client client) assetid)
  (db-get (db client) (assetkey client assetid)))

(defmethod tranfeekey ((client client))
  (bankkey client $TRANFEE))

(defmethod tranfee ((client client))
  (db-get (db client) (tranfeekey client)))

(defmethod regfee-key ((client client))
  (bankkey client $REGFEE))

(defmethod regfee ((client client))
  (db-get (db client) (regfee-key client)))

(defmethod userbankkey ((client client) &optional prop (bankid (bankid client)))
  (let ((key (append-db-keys $ACCOUNT (id client) $BANK bankid)))
    (if prop
        (append-db-keys key prop)
        key)))

(defmethod userbankprop ((client client) &optional prop (bankid (bankid client)))
  (db-get (db client) (userbankkey client prop bankid)))

(defmethod (setf userbankprop) (value (client client) prop
                                &optional (bankid (bankid client)))
  (setf (db-get (db client) (userbankkey client prop bankid)) value))

(defmethod userreqkey ((client client) &optional (bankid (bankid client)))
  (userbankkey client $REQ bankid))

(defmethod userreq ((client client) &optional (bankid (bankid client)))
  (db-get (db client) (userreqkey client bankid)))

(defmethod usertimekey ((client client))
  (userbankkey client $TIME))

(defmethod userfractionkey ((client client) &optional assetid)
  (let ((key (userbankkey client $FRACTION)))
    (if assetid
        (append-db-keys key assetid)
        key)))

(defmethod userstoragefeekey ((client client) &optional assetid)
  (let ((key (userbankkey client $STORAGEFEE)))
    (if assetid
        (append-db-keys key assetid)
        key)))

(defmethod userbalancekey ((client client)  &optional acct assetid)
  (let ((key (userbankkey client $BALANCE)))
    (cond (acct
           (setq key (append-db-keys key acct))
           (if assetid
               (append-db-keys key assetid)
               key))
          (t key))))

(defmethod userbalance ((client client) acct assetid)
  (userbalanceandtime client acct assetid))

(defmethod userbalanceandtime ((client client) acct assetid)
  "Returns three values: the balance, time, and raw message"
  (when (null acct) (setq acct $MAIN))
  (let* ((msg (db-get (db client) (userbalancekey client acct assetid))))
    (when msg
      (let ((args (unpack-bankmsg client msg $ATBALANCE)))
        (setq args (getarg $MSG args))
        (values (getarg $AMOUNT args) (getarg $TIME args) msg)))))

(defmethod useroutboxkey ((client client) &optional time)
  (let ((key (userbankkey client $OUTBOX)))
    (if time
        (append-db-keys key time)
        key)))

(defmethod useroutbox ((client client) time)
  (db-get (db client) (useroutboxkey client time)))

(defmethod useroutboxhashkey ((client client))
  (userbankkey client $OUTBOXHASH))

(defmethod useroutboxhash ((client client))
  (db-get (db client) (useroutboxhashkey client)))

(defmethod userbalancehashkey ((client client))
  (userbankkey client $BALANCEHASH))

(defmethod userbalancehash ((client client))
  (db-get (db client) (userbalancehashkey client)))

(defmethod userinboxkey ((client client))
  (userbankkey client $INBOX))

(defmethod userinboxignoredkey ((client client))
  (userbankkey client $INBOXIGNORED))

(defmethod contactkey ((client client) &optional otherid prop)
  (let ((key (append-db-keys $ACCOUNT (id client) $CONTACT)))
    (cond (otherid
           (setq key (append-db-keys key otherid))
           (if prop
               (append-db-keys key prop)
               key))
          (t key))))

(defmethod contactprop ((client client) otherid prop)
    (db-get (db client) (contactkey client otherid prop)))

(defmethod (setf contactprop) (value (client client) otherid prop)
  (setf (db-get (db client) (contactkey client otherid prop)) value))

(defmethod userhistorykey ((client client))
  (userbankkey client $HISTORY))

(defmethod userversionkey ((client client))
  (userbankkey client $VERSION))

(defmethod format-asset-value ((client client) value assetid &optional (incnegs t))
  "Format an asset value from the asset ID or $this->getasset($assetid)"
  (let ((asset (if (stringp assetid)
                   (getasset client assetid)
                   assetid)))
    (format-value
     value (asset-scale asset) (asset-precision asset) incnegs)))

(defmethod unformat-asset-value ((client client) formattedvalue assetid)
  "Unformat an asset value from the asset ID or $this->getasset($assetid)"
  (let ((asset (if (stringp assetid)
                   (getasset client assetid)
                   assetid)))
    (unformat-value formattedvalue (asset-scale asset))))

(defun fill-string (len &optional (char #\0))
  (make-string len :initial-element char))

(defun format-value (value scale precision &optional (incnegs t))
  ;; format an asset value for user printing
  (let ((sign 1)
        res)
    (when (and incnegs (< (bccomp value 0) 0))
      (setq value (bcadd value 1)
            sign -1))
    (cond ((and (eql 0 (bccomp scale 0)) (eql 0 (bccomp precision 0)))
           (setq res value))
          ((> (bccomp scale 0) 0)
           (let ((pow (bcpow 10 scale)))
             (wbp (scale)
               (setq res (bcdiv value pow))))
           (let ((dotpos (position #\. res))
                 (precision (parse-integer precision)))
             (cond ((null dotpos)
                    (unless (eql 0 (bccomp precision 0))
                      (dotcat res "." (fill-string precision))))
                   (t
                    ;; Remove trailing zeroes
                    (let ((endpos (1- (length res))))
                      (loop
                         while (> endpos dotpos)
                         do
                           (unless (eql #\0 (aref res endpos)) (return))
                           (decf endpos))
                      (let* ((zeroes (- precision (- endpos dotpos)))
                             (zerostr (if (> zeroes 0) (fill-string zeroes) "")))
                        (setq res (strcat (subseq res 0 (1+ endpos)) zerostr)))))))))

    (when (and (eql 0 (bccomp value 0)) (< sign 0))
      (setq res (strcat "-" res)))

    ;; Insert commas
    (let* ((start 0)
           (dotpos (or (position #\. res) (length res)))
           (len dotpos))
      (when (eql #\- (aref res 0))
        (incf start)
        (decf len))
      (loop
         for pos = (+ len start -3)
         while (> pos start)
         do
           (setq res (strcat (subseq res 0 pos) "," (subseq res pos)))
           (decf len 3)))

    res))

(defun unformat-value (formattedvalue scale)
  (let ((value (if (eql 0 (bccomp scale 0))
                   formattedvalue
                   (split-decimal
                    (wbp (scale) (bcmul formattedvalue (bcpow 10 scale)))))))
    (if (or (< (bccomp value 0) 0)
            (and (eql 0 (bccomp value 0))
                 (eql #\- (aref formattedvalue 0))))
      (bcsub value 1)
      value)))

(defmethod get-pubkey-from-server ((client client) id)
  "Send an $ID command to the server, if there is one.
   Parse out the pubkey, cache it in the database, and return it.
   Return nil if there is no server or it doesn't know the id."
  (let* ((db (db client))
         (bankid (or (current-bank client)
                     (return-from get-pubkey-from-server nil)))
         (msg (sendmsg client $ID bankid id))
         (args (getarg $MSG (unpack-bankmsg client msg $ATREGISTER)))
         (pubkey (getarg $PUBKEY args))
         (pubkeykey (pubkeykey id)))
    (when pubkey
      (db-put db pubkeykey pubkey)
      pubkey)))

(defmethod getreq ((client client) &optional reinit-p)
  "Get a new request"
  (let ((db (db client))
        (key (userreqkey client)))
    (when reinit-p
      (let* ((msg (sendmsg client $GETREQ (bankid client)))
             (args (unpack-bankmsg client msg $REQ))
             (req (getarg $REQ args)))
        (setf (db-get db key) req)))
    (with-db-lock (db key)
      (setf (db-get db key) (bcadd (db-get db key) 1)))))

(defmethod gettime ((client client) &optional forcenew)
  "Get a timestamp from the server"
  (let ((db (db client))
        (bankid (bankid client))
        (key (usertimekey client)))
    (with-db-lock (db key)
      (cond (forcenew (setf (db-get db key) nil))
            (t
             (let ((times (db-get db key)))
               (when times
                 (setf times (explode #\, times)
                       (db-get db key) (cadr times))
                 (return-from gettime (car times)))))))
    (flet ((get-time-args ()
             (let* ((req (getreq client))
                    (msg (sendmsg client $GETTIME bankid req)))
               (unpack-bankmsg client msg $TIME))))
      (let ((args (handler-case (get-time-args)
                    (error ()
                      (forceinit client)
                      (get-time-args)))))
        (getarg $TIME args)))))

(defmethod syncreq ((client client))
  "Check once per instance that the local idea of the reqnum matches
   that at the bank.
   If it doesn't, clear the account information, so that init-bank-accts()
   will reinitialize.
   Eventually, we want to compare to see if we can catch a bank error."
  (let* ((db (db client))
         (key (userbankkey client $REQ))
         (reqnum (db-get db key)))
    (when (equal reqnum "-1") (setf (syncedreq-p client) t))
    (unless (syncedreq-p client)
      (let* ((bankid (bankid client))
             (msg (sendmsg client $GETREQ bankid))
             (args (unpack-bankmsg client msg $REQ))
             (newreqnum (getarg $REQ args)))
      (unless (equal reqnum newreqnum)
        (setq reqnum "-1")
        (let* ((balkey (userbalancekey client))
               (accts (db-contents db balkey)))
          (dolist (acct accts)
            (let* ((acctkey (append-db-keys balkey acct))
                   (assetids (db-contents db acctkey)))
              (dolist (assetid assetids)
                (setf (db-get db acctkey assetid) nil)))))
        (let* ((frackey (userfractionkey client))
               (assetids (db-contents db frackey)))
          (dolist (assetid assetids)
            (setf (db-get db frackey assetid) nil)))
        (let* ((outboxkey (useroutboxkey client))
               (outtimes (db-contents db outboxkey)))
          (dolist (outtime outtimes)
            (setf (db-get db outboxkey outtime) nil)))
        (setf (db-get db (userbalancehashkey client)) nil
              (db-get db (useroutboxhashkey client)) nil)
        (setf (syncedreq-p client) t))))
    reqnum))

(defmethod reinit-balances ((client client))
  "Synchronize with the bank"
  (require-current-bank client "Can't reinitialize balances")
  (forceinit client))

;; Internal implementation of reinit-balances
(defmethod forceinit ((client client))
  "Force a reinit of the client database for the current user"
  (let ((db (db client)))
    (setf (db-get db (userreqkey client)) "0"
          (syncedreq-p client) nil)
    (init-bank-accts client)))

(defmethod init-bank-accts ((client client))
  "If we haven't yet downloaded accounts from the bank, do so now.
   This is how a new client instance gets initialized from an existing
   bank instance."
  (let* ((db (db client))
         (id (id client))
         (bankid (bankid client))
         (parser (parser client))
         (reqnum (syncreq client)))

    (when (equal reqnum "-1")
      ;; Get $REQ
      (let* ((msg (sendmsg client $GETREQ bankid))
             (args (unpack-bankmsg client msg $REQ))
             (reqnum (bcadd (getarg $REQ args) 1)))

        ;; Get account balances
        (setq msg (sendmsg client $GETBALANCE bankid reqnum))
        (let ((reqs (and msg (parse parser msg t)))
              (balances (make-equal-hash))
              (fractions (make-equal-hash))
              (balancehash nil))
          (dolist (req reqs)
            (setq args (match-bankreq client req))
            (let* ((request (getarg $REQUEST args))
                   (msgargs (getarg $MSG args))
                   (customer (and msgargs (getarg $CUSTOMER msgargs))))
              (when (and msgargs (not (equal customer id)))
                (error "Bank wrapped somebody else's (~a) message: ~s" customer msg))
              (cond ((equal request $ATBALANCE)
                     (unless (equal (getarg $REQUEST msgargs) $BALANCE)
                       (error "Bank wrapped a non-balance request with @balance"))
                     (let ((assetid
                            (or (getarg $ASSET msgargs)
                                (error "Bank wrapped balance missing asset ID")))
                           (acct (or (getarg $ACCT msgargs) $MAIN)))
                       (setf (gethash assetid (get-inited-hash acct balances))
                             (get-parsemsg req))))
                    ((equal request $ATBALANCEHASH)
                     (unless (equal (getarg $REQUEST msgargs) $BALANCEHASH)
                       (error "Bank wrapped a non-balancehash request with @balancehash"))
                     (setq balancehash (get-parsemsg req)))
                    ((equal request $ATFRACTION)
                     (unless (equal (getarg $REQUEST msgargs) $FRACTION)
                       (error "Bank wrapped a non-fraction request with @fraction"))
                     (let ((assetid
                            (or (getarg $ASSET msgargs)
                                (error "Bank wrapped fraction missing asset ID")))
                           (fraction (get-parsemsg req)))
                       (setf (gethash assetid fractions) fraction))))))
          ;; Get outbox
          (setq reqnum (bcadd reqnum 1)
                msg (sendmsg client $GETOUTBOX bankid reqnum))
          (let ((reqs (parse parser msg t))
                (outbox (make-equal-hash))
                (outboxhash nil)
                (outboxtime nil))
            (dolist (req reqs)
              (setq args (match-bankreq client req))
              (let* ((request (getarg $REQUEST args))
                     (msgargs (getarg $MSG args))
                     (customer (and msgargs (getarg $CUSTOMER msgargs))))
                (when (and msgargs (not (equal customer id)))
                  (error "Bank wrapped somebody else's (~a) message: ~s"
                         customer msg))
                (cond ((equal request $ATGETOUTBOX))
                      ((equal request $ATSPEND)
                       (unless (equal (getarg $REQUEST msgargs) $SPEND)
                         (error "Bank wrapped a non-spend request with @spend"))
                       (let ((time (getarg $TIME msgargs)))
                         (setf outboxtime time
                               (gethash time outbox) (get-parsemsg req))))
                      ((equal request $ATTRANFEE)
                       (unless (equal (getarg $REQUEST msgargs) $TRANFEE)
                         (error "Bank wrapped a non-tranfee request with @tranfee"))
                       (let* ((time (getarg $TIME msgargs))
                              (msg (or (gethash time outbox)
                                       (error "No spend message for time: ~s" time))))
                         (setf (gethash time outbox)
                               (strcat msg "." (get-parsemsg req)))))
                      ((equal request $ATOUTBOXHASH)
                       (unless (equal (getarg $REQUEST msgargs) $OUTBOXHASH)
                         (error "Bank wrapped a non-outbox request with @outboxhash"))
                       (setq outboxhash (get-parsemsg req)))
                      ((equal request $COUPONENVELOPE)
                       (unless outboxtime
                         (error "Got a coupon envelope with no outboxtime"))
                       (let ((msg (or (gethash outboxtime outbox)
                                      (error "No spend message for coupon envelope"))))
                         (setq msg (append-db-keys  msg (get-parsemsg req)))
                         (setf (gethash outboxtime outbox) msg
                               outboxtime nil)))
                      (t
                       (error "While processing getoutbox: bad request: ~s"
                              request)))))

            (when (and (not (equal id bankid))
                       (not outboxhash)
                       outbox
                       (> (hash-table-count outbox) 0))
              (error "While procesing getoutbox: outbox items but no outboxhash"))

            ;; All is well. Write the data
            (loop
               for acct being the hash-key using (hash-value assets) of balances
               do
               (loop
                  for assetid being the hash-key using (hash-value msg) of assets
                  do
                  (setf (db-get db (userbalancekey client acct assetid)) msg)))

            (loop
               for assetid being the hash-key using (hash-value fraction)
               of fractions
               do
               (setf (db-get db (userfractionkey client assetid)) fraction))

            (loop
               for time being the hash-key using (hash-value msg) of outbox
               do
               (setf (db-get db (useroutboxkey client time)) msg))

            (setf (db-get db (userbalancehashkey client)) balancehash
                  (db-get db (useroutboxhashkey client)) outboxhash
                  (db-get db (userreqkey client)) reqnum)))))))

(defmethod unpacker ((client client))
  #'(lambda (msg) (unpack-bankmsg client msg)))

(defmethod balancehashmsg ((client client) time acctbals)
  (let* ((db (db client))
         (bankid (bankid client)))
    (multiple-value-bind (hash hashcnt)
        (balancehash db (unpacker client) (userbalancekey client) acctbals)
      (custmsg client $BALANCEHASH bankid time hashcnt hash))))

(defmethod outboxhashmsg ((client client) transtime &optional newitem removed-times)
  (let ((db (db client))
        (bankid (bankid client))
        (key (useroutboxkey client)))
    (multiple-value-bind (hash hashcnt)
        (dirhash db key (unpacker client) newitem removed-times)
      (custmsg client $OUTBOXHASH bankid transtime (or hashcnt 0) (or hash "")))))

;; Web client session support

(defun newsessionid ()
  "Return a new, random, session ID"
  (let ((res (bin2hex (urandom-bytes 20))))
    (if (< (length res) 40)
        (strcat (fill-string (- 40 (length res))) res)
        res)))

(defun xorcrypt (key string)
  "xor hashed copies of KEY with STRING and return the result.
   This is a really simple encryption that only really works if
   KEY is known to be random, e.g. the output of (newsessionid)."
  (let* ((key (hex2bin (sha1 key) :string))
         (idx 0)
         (keylen (length key))
         (len (length string)))
    (with-output-to-string (s)
      (dotimes (i len)
        (write-char (code-char
                     (logxor (char-code (aref key idx))
                             (char-code (aref string i))))
                    s)
        (incf idx)
        (when (>= idx keylen)
          (setq idx 0
                key (hex2bin (sha1 key) :string)
                keylen (length key)))))))

(defmethod usersessionkey ((client client))
  "Return the database key for the user's session hash."
  (append-db-keys $ACCOUNT (id client) $SESSION))

(defmethod usersessionhash ((client client))
  "Return the user's session hash."
  (db-get (db client) (usersessionkey client)))

(defun sessionkey (sessionhash)
  "Return the database key for a session hash"
  (append-db-keys $SESSION sessionhash))

(defmethod session-passphrase ((client client) sessionid)
  "Return the passphrase corresponding to a session id"
  (let* ((db (db client))
         (passcrypt (or (db-get db (sessionkey (sha1 sessionid)))
                        (error "No passphrase for session"))))
    (xorcrypt sessionid passcrypt)))

(defmethod make-session ((client client) passphrase)
  "Create a new user session, encoding $passphrase with a new session id.
   Return the new session id.
   If the user already has a session stored with another session id,
   remove that one first."
  (let* ((db (db client))
         (sessionid (newsessionid))
         (passcrypt (xorcrypt sessionid passphrase))
         (usersessionkey (usersessionkey client)))
    (with-db-lock (db usersessionkey)
      (let ((oldhash (db-get db usersessionkey)))
        (when oldhash
          (setf (db-get db (sessionkey oldhash)) nil)))
      (let ((newhash (sha1 sessionid)))
        (setf (db-get db (sessionkey newhash)) passcrypt
              (db-get db usersessionkey) newhash)))
    sessionid))

(defmethod remove-session ((client client))
  "Remove the current user's session"
  (let* ((db (db client))
         (usersessionkey (usersessionkey client)))
    (with-db-lock (db usersessionkey)
      (let ((oldhash (db-get db usersessionkey)))
        (when oldhash
          (setf (db-get db (sessionkey oldhash)) nil
                (db-get db usersessionkey) nil))))))

(defmethod user-preference-key (client pref)
  "Preferences"
  (append-db-keys $ACCOUNT (id client) $PREFERENCE pref))

(defmethod user-preference ((client client) pref)
  "Get or set a user preference.
   Include the $value to set."
  (require-current-user client)
  (let* ((db (db client))
         (key (user-preference-key client pref)))
    (db-get db key)))

(defmethod (setf user-preference) (value (client client) pref)
  (require-current-user client)
  (let* ((db (db client))
         (key (user-preference-key client pref)))
    (setf (db-get db key) value)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Connection to the server
;;;

(defmethod make-server-proxy ((client client) url)
  (make-instance 'serverproxy :url url :client client))

(defclass serverproxy ()
  ((url :type string
        :initarg :url
        :accessor url)
   (client :type client
           :initarg :client
           :accessor client)
   (stream :initform nil
           :accessor post-stream)))

(defmethod finalize ((proxy serverproxy))
  (let ((stream (post-stream proxy)))
    (when stream
      (setf (post-stream proxy) nil)
      (ignore-errors (close stream)))))

;; Don't know what makes sense here, but not infinite
(defparameter *max-redirect-count* 5)

(defmethod post ((proxy serverproxy) url &optional parameters)
  (let* ((stream (post-stream proxy)))
    (multiple-value-bind (res status headers uri stream)
        (block nil
          (handler-bind ((error (lambda (c)
                                  (declare (ignore c))
                                  (when stream
                                    (ignore-errors (close stream))
                                    (setf (post-stream proxy) nil)
                                    ;; I don't know if this is necessary
                                    (return (drakma:http-request
                                             url
                                             :method :post
                                             :parameters parameters
                                             :form-data t
                                             :redirect *max-redirect-count*
                                             :close nil
                                             :keep-alive t))))))
            (drakma:http-request
             url
             :method :post
             :parameters parameters
             :form-data t
             :redirect *max-redirect-count*
             :stream stream
             :close nil
             :keep-alive t)))
      (declare (ignore uri))
      (setf (post-stream proxy) stream)
      (values res status headers))))

(defmethod process ((proxy serverproxy) msg)
  (let* ((url (url proxy))
         (client (client proxy))
         (test-server (test-server client)))

    ;; This is a kluge to get around versions of Apache that insist
    ;; on sending "301 Moved Permanently" for directory URLs that
    ;; are missing a trailing slash.
    ;; Drakma can likely handle this, but I'm just copying the PHP
    ;; code for now.
    (unless (eql #\/ (aref url (1- (length url))))
      (dotcat url "/"))

    (let* ((vars `(("msg" . ,msg))))

      (when (debug-stream-p)
        (push '("debugmsgs" . "true") vars))

      (when (debug-stream-p)
        (debugmsg "<b>===SENT</b>: ~a~%" (trimmsg msg)))

      (let ((res (if test-server
                     (trubanc-server:process test-server msg)
                     (multiple-value-bind (res status headers)
                         (post proxy url vars)
                       (cond ((eql status 301)
                              (let ((location
                                     (cdr (assoc :location headers :test #'eq))))
                                (cond (location
                                       (setf (url proxy) location)
                                       (post proxy location vars)))))
                             (t res)))))
            (text nil))
        (when (and (> (length res) 2)
                   (equal "<<" (subseq res 0 2)))
          (let ((pos (search #.(format nil ">>~%") res)))
            (when pos
              (setq text (subseq res 2 pos)
                    res (subseq res (+ pos 3))))))
        (when text
          (debugmsg "<b>===SERVER SAID</b>: ~a" (hsc text))
          (let ((len (length text)))
            (unless (and (> len 0) (eql #\newline (aref text (1- len))))
              (debugmsg "~%"))))
    
        (when (debug-stream-p)
          (debugmsg "<b>===RETURNED</b>: ~a~%" (and msg (trimmsg res))))

        res))))

(defun trimmsg (msg)
  (let* ((msg (remove-signatures msg))
         (tokens (mapcar #'cdr (tokenize msg)))
         (res ""))
    (dolist (token tokens)
      (cond ((characterp token) (dotcat res (hsc (string token))))
            ((ishex-p token) (dotcat res (hsc token)))
            (t (dotcat res "<b>" (hsc token) "</b>"))))
    res))

(defun ishex-p (str)
  (let ((len (length str)))
    (dotimes (i len t)
      (unless (position (aref str i) "0123456789abcdef")
        (return nil)))))

;; Look up a public key, from the client database first, then from the
;; current bank.
(defclass pubkeydb (db)
  ((client :type client
           :initarg :client
           :accessor client)
   (db :type db
       :initarg :db
       :accessor db)))

(defvar *insidep* nil)

(defmethod db-get ((pubkeydb pubkeydb) id &rest more-keys)
  (assert (null more-keys) nil "PUBKEYDB takes only a single DB-GET key")
  (or (db-get (db pubkeydb) id)
      (and (not *insidep*)
           (let ((*insidep* t))
             (get-pubkey-from-server (client pubkeydb) id)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright 2009 Bill St. Clair
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;     http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions
;;; and limitations under the License.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;