json.lisp

;;; Copyright 2020 Google LLC
;;;
;;; Use of this source code is governed by an MIT-style
;;; license that can be found in the LICENSE file or at
;;; https://opensource.org/licenses/MIT.

(defpackage #:cl-protobufs.json
  (:use #:cl
        #:cl-protobufs
        #:cl-protobufs.implementation)
  ;; Shadow fmt from cl-protobufs text-format.
  (:shadow #:fmt)
  (:export #:print-json
           #:parse-json
           #:fmt)
  (:local-nicknames
   (#:pi #:cl-protobufs.implementation)
   (#:google #:cl-protobufs.google.protobuf)
   (#:wkt #:cl-protobufs.well-known-types)))

(in-package #:cl-protobufs.json)

;;; This file implements the protobuf JSON parser and printer.
;;; The exported symbols are parse-json and print-json.

(defun print-json (object &key (pretty-print-p t) (stream *standard-output*)
                          (camel-case-p t) (numeric-enums-p nil))
  "Prints a protocol buffer message to a stream in JSON format. The parameters
CAMEL-CASE-P and NUMERIC-ENUMS-P implement optional JSON printing options:
https://developers.google.com/protocol-buffers/docs/proto3#json_options.

Parameters:
  OBJECT: The protocol buffer message to print.
  PRETTY-PRINT-P: When true, generate line breaks and other human readable output
    in the json. When false, replace line breaks with spaces.
  STREAM: The stream to print to.
  CAMEL-CASE-P: If true print proto field names in camelCase.
  NUMERIC-ENUMS-P: If true, use enum numeric values rather than names."
  (print-json-impl object (when pretty-print-p 0) stream camel-case-p numeric-enums-p
                   nil))

(defun print-json-impl (object indent stream camel-case-p numeric-enums-p
                        spliced-p)
  "Prints a protocol buffer message to a stream in JSON format.
Parameters:
  OBJECT: The protocol buffer message to print.
  INDENT: Indent the output by INDENT spaces. If INDENT is NIL, then the
    output will not be pretty-printed.
  STREAM: The stream to print to.
  CAMEL-CASE-P: If true print proto field names in camelCase.
  NUMERIC-ENUMS-P: If true, use enum numeric values rather than names.
  SPLICED-P: Prints a protocol buffer object inside of the printing
    of another protocol buffer object as if they were spliced
    together. Currently only happens while printing a well-known-type.
    This happens because we have to print the well-known-type metadata.
    Example using Any well known type:
      {
        \"url\": \"type.googleapis.com/google.protobuf.Struct\",
        contained-proto
      }"
  (let* ((type (type-of object))
         (message (find-message-descriptor type :error-p t)))
    ;; If TYPE has a special JSON mapping, use that.
    (when (special-json-p type)
      (print-special-json object type stream indent camel-case-p numeric-enums-p)
      (return-from print-json-impl))
    (unless spliced-p
      (format stream "{")
      (when indent (format stream "~%")))
    ;; Boolean that tracks if a field is printed. Used for printing commas
    ;; correctly. If this object is spliced into an existing JSON object, then
    ;; a field has been already printed, so always print a comma.
    (let ((field-printed spliced-p))
      (dolist (field (proto-fields message))
        (when (if (eq (slot-value field 'pi::kind) :extends)
                  (has-extension object (slot-value field 'external-field-name))
                  (has-field object (slot-value field 'pi::external-field-name)))
          (let* ((name (if camel-case-p
                           (pi::proto-json-name field)
                           (proto-name field)))
                 (type (proto-class field))
                 (value
                   (if (eq (slot-value field 'pi::kind) :extends)
                       (get-extension object (slot-value field 'pi::external-field-name))
                       (proto-slot-value object (slot-value field 'pi::external-field-name)))))
            (if field-printed
                (format stream ",")
                (setf field-printed t))
            (if indent
                (format stream "~&~V,0T\"~A\": " (+ indent 2) name)
                (format stream "\"~A\":" name))
            (if (not (eq (proto-label field) :repeated))
                (print-field-to-json value type (and indent (+ indent 2))
                                     stream camel-case-p numeric-enums-p)
                (let (repeated-printed)
                  (format stream "[")
                  (pi::doseq (v value)
                    (if repeated-printed
                        (format stream ",")
                        (setf repeated-printed t))
                    (when indent (format stream "~&~V,0T" (+ indent 4)))
                    (print-field-to-json v type (and indent (+ indent 4))
                                         stream camel-case-p numeric-enums-p))
                  (if indent
                      (format stream "~&~V,0T]" (+ indent 2))
                      (format stream "]")))))))
      (dolist (oneof (pi::proto-oneofs message))
        (let* ((oneof-data (slot-value object (pi::oneof-descriptor-internal-name oneof)))
               (set-field (pi::oneof-set-field oneof-data)))
          (when set-field
            (let* ((field-desc (aref (pi::oneof-descriptor-fields oneof) set-field))
                   (type (proto-class field-desc))
                   (value (pi::oneof-value oneof-data))
                   (name (if camel-case-p
                             (pi::proto-json-name field-desc)
                             (proto-name field-desc))))
              (if field-printed
                  (format stream ",")
                  (setf field-printed t))
              (if indent
                  (format stream "~&~V,0T\"~A\": " (+ indent 2) name)
                  (format stream "\"~A\":" name))
              (print-field-to-json value type (and indent (+ indent 2))
                                   stream camel-case-p numeric-enums-p))))))
    (if indent
        (format stream "~&~V,0T}" indent)
        (format stream "}"))))

(defun print-field-to-json (value type indent stream camel-case-p numeric-enums-p)
  "Print a field to JSON format.

 Parameters:
  VALUE: The value held by the field
  TYPE: The proto-class slot of the field.
  INDENT: If non-nil, the amount to indent when pretty-printing.
  STREAM: The stream to print to.
  CAMEL-CASE-P: Passed recursively to PRINT-JSON.
  NUMERIC-ENUMS-P: Passed recursively to PRINT-ENUM-TO-JSON and PRINT-JSON."
  (let ((descriptor (or (find-message-descriptor type)
                        (find-enum-descriptor type)
                        (find-map-descriptor type))))
    (cond
      ((pi::scalarp type)
       (print-scalar-to-json value type stream))
      ((typep descriptor 'pi::message-descriptor)
       (print-json-impl value indent stream camel-case-p numeric-enums-p nil))
      ((typep descriptor 'pi::enum-descriptor)
       (print-enum-to-json value type stream numeric-enums-p))
      ((typep descriptor 'pi::map-descriptor)
       (print-map-to-json value descriptor indent
                          stream camel-case-p numeric-enums-p)))))

(defun print-scalar-to-json (value type stream)
  "Print scalar VALUE of type TYPE to STREAM."
  (ecase type
    ((int32 fixed32 uint32 sfixed32 sint32)
     (format stream "~D" value))
    ((int64 fixed64 uint64 sfixed64 sint64)
     (format stream "\"~D\"" value))
    ((float double-float)
     (format stream "~F" value))
    ((string)
     (format stream "\"~A\"" value))
    ((boolean)
     (format stream "~A" (if value "true" "false")))
    ((byte-vector)
     (format stream "\"~A\"" (cl-base64:usb8-array-to-base64-string value)))
    ((keyword)
     (format stream "\"~A\"" value))
    ((symbol)
     (let ((*package* (find-package "COMMON-LISP")))
       (format stream "\"~S\"" value)))))

(defun print-enum-to-json (value type stream numeric-enums-p)
  "Print an enum VALUE of type TYPE to STREAM. If NUMERIC-ENUMS-P, then print the enums value
rather than its name."
  (when (eql type 'google:null-value)
    (format stream "null")
    (return-from print-enum-to-json))
  (if numeric-enums-p
      (format stream "~D" (enum-keyword-to-int type value))
      (format stream "\"~A\"" (pi::enum-name->proto value))))

(defun print-map-to-json (value map-descriptor indent stream camel-case-p numeric-enums-p)
  "Print a map type to JSON.

Parameters:
  VALUE: The hash-table to print.
  MAP-DESCRIPTOR: The map-descriptor of the map.
  INDENT: If non-nil, the amount to indent when pretty-printing.
  STREAM: The stream to print to.
  CAMEL-CASE-P, NUMERIC-ENUMS-P: passed recursively to PRINT-FIELD-TO-JSON."
  (format stream "{")
  (when indent (format stream "~%"))
  (let ((pair-printed nil))
    (loop for k being the hash-key of value using (hash-value v)
          do (if pair-printed
                 (format stream ",")
                 (setf pair-printed t))
             (if indent
                 (format stream "~&~V,0T\"~A\": " (+ indent 2) k)
                 (format stream "\"~A\":"  (write-to-string k)))
             (print-field-to-json v (pi::proto-value-type map-descriptor)
                                  (and indent (+ indent 2)) stream camel-case-p numeric-enums-p)))
    (if indent
        (format stream "~&~V,0T}" indent)
        (format stream "}")))

;;; Parse objects that were serialized using JSON format.

;;; TODO(cgay): replace all assertions here with something that signals a
;;; subtype of protobuf-error and shows current stream position.

(defun parse-json (type
                   &key (stream *standard-input*) ignore-unknown-fields-p)
  "Parses JSON text into a protobuf messsage of type TYPE.

Parameters:
  TYPE: The object type as a symbol.
  STREAM: The stream to read from.
  IGNORE-UNKNOWN-FIELDS-P: If true, then skip fields which are not defined in the
    message TYPE descriptor. Otherwise, throw an error."
  (declare (type symbol type))
  (let ((message (find-message-descriptor type :error-p t)))
    (parse-json-impl message stream ignore-unknown-fields-p nil)))

(defun parse-json-impl (msg-desc stream ignore-unknown-fields-p spliced-p)
  "Parse a JSON formatted message with descriptor MSG-DESC from STREAM. If IGNORE-UNKNOWN-FIELDS-P
is true, then skip fields which are not defined in MSG-DESC. Otherwise, throw an error. If
SPLICED-P is true, then do not attempt to parse an opening bracket."
  (declare (type message-descriptor msg-desc))
  (let ((object (funcall (pi::get-constructor-name
                          (or (pi::proto-alias-for msg-desc)
                              (proto-class msg-desc)))))
        ;; Repeated slot names, tracks which slots need to be nreversed.
        (rslots ()))
    (when (special-json-p (proto-class msg-desc))
      (return-from parse-json-impl
        (parse-special-json (proto-class msg-desc)
                            stream
                            ignore-unknown-fields-p)))
    (unless spliced-p
      (pi::expect-char stream #\{))
    (loop
      (let* ((name  (pi::parse-string stream))
             (field (or (find-field-descriptor msg-desc name)
                        (find-field-descriptor-by-json-name msg-desc name)))
             (type  (and field (proto-class field)))
             (slot  (and field (pi::proto-external-field-name field))))
        (pi::expect-char stream #\:)
        (if (null field)
            ;; If FIELD is null, then we assume that MSG-DESC describes a
            ;; different version of the proto on the wire which doesn't
            ;; have FIELD, and continue,
            (if ignore-unknown-fields-p
                (skip-json-value stream)
                (error 'unknown-field-type
                       :format-control "unknown field ~S encountered in message ~S"
                       :format-arguments (list name msg-desc)))
            (let (val error-p null-p)
              (cond
                ((eql (peek-char nil stream nil) #\n)
                 (pi::expect-token-or-string stream "null")
                 (setf null-p t))
                ((eq (proto-label field) :repeated)
                 (pi::expect-char stream #\[)
                 (loop
                   (multiple-value-bind (data err)
                       (parse-value-from-json type :stream stream
                                                   :ignore-unknown-fields-p ignore-unknown-fields-p)
                     (if err
                         (setf error-p t)
                         (push data val)))
                   (if (eql (peek-char nil stream nil) #\,)
                       (pi::expect-char stream #\,)
                       (return)))
                 (pi::expect-char stream #\]))
                (t (multiple-value-setq (val error-p)
                     (parse-value-from-json type
                                            :stream stream
                                            :ignore-unknown-fields-p ignore-unknown-fields-p))))
              (cond
                (null-p nil)
                (error-p
                 (unknown-field-type type field msg-desc)
                 (return-from parse-json-impl))
                ((eq (pi::proto-kind field) :map)
                 (dolist (pair val)
                   (setf (gethash (car pair) (proto-slot-value object slot))
                         (cdr pair))))
                (t
                 (when slot
                   (setf (proto-slot-value object slot) val)
                   (when (eq (proto-label field) :repeated)
                     (pushnew slot rslots))))))))
      (if (eql (peek-char nil stream nil) #\,)
        (pi::expect-char stream #\,)
        (progn
          (pi::expect-char stream #\})
          (dolist (slot rslots)
            (setf (proto-slot-value object slot)
                  (nreverse (proto-slot-value object slot))))
          (return-from parse-json-impl object))))))

(defun parse-value-from-json (type &key (stream *standard-input*) ignore-unknown-fields-p)
  "Parse a single JSON value of type TYPE from STREAM. IGNORE-UNKNOWN-FIELDS-P is passed
   to recursive calls to PARSE-JSON-IMPL."
  (let ((desc (or (find-message-descriptor type)
                  (find-enum-descriptor type)
                  (find-map-descriptor type))))
    (cond ((pi::scalarp type)
           (case type
             ((float) (pi::parse-float stream))
             ((double-float) (pi::parse-double stream :append-d0 t))
             ((string) (pi::parse-string stream))
             ((boolean)
              (let ((token (pi::parse-token stream)))
                (cond ((string= token "true") t)
                      ((string= token "false") nil)
                      ;; Parsing failed, return T as a second
                      ;; value to indicate a failure.
                      (t (values nil t)))))
             ((byte-vector)
              (cl-base64:base64-string-to-usb8-array (pi::parse-string stream)))
             (otherwise
              (if (eql (peek-char nil stream nil) #\")
                  (let (ret)
                    (pi::expect-char stream #\")
                    (setf ret (pi::parse-signed-int stream))
                    (pi::expect-char stream #\")
                    ret)
                  (pi::parse-signed-int stream)))))
          ((typep desc 'pi::message-descriptor)
           (parse-json-impl desc stream ignore-unknown-fields-p nil))
          ((typep desc 'pi::enum-descriptor)
           (multiple-value-bind (name type-parsed)
               (pi::parse-token-or-string stream)
             ;; special handling for well known enum NullValue.
             (when (eql type 'google:null-value)
               (if (string= name "null")
                   (return-from parse-value-from-json :null-value)
                   (protobuf-error
                    "~S is not a valid keyword for well-known enum NullValue" name)))
             (let ((enum (if (eql type-parsed 'symbol)
                             ;; If the parsed type is a symbol, then the enum was printed
                             ;; as an integer. Otherwise, it is a string which names a
                             ;; keyword.
                             (find (parse-integer name) (pi::enum-descriptor-values desc)
                                   :key #'pi::enum-value-descriptor-value)
                             (find (pi::keywordify name)
                                   (pi::enum-descriptor-values desc)
                                   :key #'pi::enum-value-descriptor-name))))
               (and enum (pi::enum-value-descriptor-name enum)))))
          ;; In the case of maps, return a list of key-value pairs.
          ((typep desc 'pi::map-descriptor)
           (pi::expect-char stream #\{)
           (loop with pairs = ()
                 with key-type = (pi::proto-key-type desc)
                 with val-type = (pi::proto-value-type desc)
                 for pair = (cons nil nil)
                 do (setf (car pair)
                          (if (eql key-type 'string)
                              (pi::parse-string stream)
                              (parse-integer (pi::parse-string stream))))
                    (pi::expect-char stream #\:)
                    (setf (cdr pair) (parse-value-from-json val-type :stream stream))
                    (push pair pairs)
                    (if (eql (peek-char nil stream nil) #\,)
                        (pi::expect-char stream #\,)
                        (progn
                          (pi::expect-char stream #\})
                          (return pairs)))))
          (t (values nil t)))))

(defun skip-json-value (stream)
  "Skip a single JSON value in STREAM. This can
be either an array, object, or primitive."
  (pi::skip-whitespace stream)
  (case (peek-char nil stream nil)
    ((#\{) (skip-json-object stream))
    ((#\[) (skip-json-array stream))
    (t (pi::parse-token-or-string stream))))

(defun skip-json-array (stream)
  "Skip a JSON array in STREAM."
  (pi::expect-char stream #\[)
  (loop do (skip-json-value stream)
           (if (eql (peek-char nil stream nil) #\,)
               (pi::expect-char stream #\,)
               (return)))
  (pi::skip-whitespace stream)
  (pi::expect-char stream #\]))

(defun skip-json-object (stream)
  "Skip a JSON object in STREAM."
  (pi::expect-char stream #\{)
  (loop do (pi::parse-string stream)
           (pi::expect-char stream #\:)
           (skip-json-value stream)
           (if (eql (peek-char nil stream nil) #\,)
               (pi::expect-char stream #\,)
               (return)))
  (pi::skip-whitespace stream)
  (pi::expect-char stream #\}))

(defun find-field-descriptor-by-json-name (msg-desc name)
  "Return the field-descriptor with json-name NAME in MSG-DESC."
  (or (find name (proto-fields msg-desc) :key #'pi::proto-json-name :test #'string=)
      (loop for oneof in (pi::proto-oneofs msg-desc)
              thereis (find name (pi::oneof-descriptor-fields oneof)
                            :key #'pi::proto-json-name
                            :test #'string=))))

;; Special JSON mappings for well known types below

(defun special-json-p (type)
  "Check if the message TYPE has a special JSON mapping."
  (member type '(google:any
                 google:timestamp
                 google:duration
                 google:struct
                 google:value
                 google:field-mask
                 google:list-value
                 google:bool-value
                 google:string-value
                 google:bytes-value
                 google:double-value
                 google:float-value
                 google:int32-value
                 google:int64-value
                 google:u-int32-value
                 google:u-int64-value)))

(defun wrapper-message->type (type)
  "For a well known wrapper type TYPE, return the type being wrapped."
  (ecase type
    ((google:bool-value) 'boolean)
    ((google:string-value) 'string)
    ((google:bytes-value) 'byte-vector)
    ((google:double-value) 'double-float)
    ((google:float-value) 'float)
    ((google:int32-value) 'int32)
    ((google:int64-value) 'int64)
    ((google:u-int32-value) 'uint32)
    ((google:u-int64-value) 'uint64)))


(defun print-special-json (object type stream indent camel-case-p numeric-enums-p)
  "For an OBJECT whose TYPE is a well-known type, print the object's special JSON mapping
to STREAM. INDENT, CAMEL-CASE-P, and NUMERIC-ENUMS-P are passed recursively to
PRINT-JSON-IMPL for any types."
  (declare (type symbol type))
  (case type
    ((google:any)
     (let ((url (google:any.type-url object))
           (packed-message (wkt:unpack-any object)))
       (format stream "{")
       (if indent
           (format stream "~&~V,0T\"url\": \"~A\"" (+ indent 2) url)
           (format stream "\"url\": \"~A\"" url))
       (if (special-json-p (type-of packed-message))
           ;; special handling for nested special json mapping within an ANY.
           (progn
             (if indent
                 (format stream ",~&~V,0T\"value\": " (+ indent 2))
                 (format stream ",\"value\":"))
             (print-special-json packed-message (type-of packed-message) stream
                                 (and indent (+ indent 2)) camel-case-p numeric-enums-p)
             (if indent
                 (format stream "~&~V,0T}" indent)
                 (format stream "}")))
           (print-json-impl packed-message indent stream camel-case-p
                            numeric-enums-p t))))
    ((google:timestamp)
     (let* ((nsec (google:timestamp.nanos object))
            (timestamp (local-time:unix-to-timestamp
                        (google:timestamp.seconds object)
                        :nsec nsec))
            (prefix '((:year 4) #\- (:month 2) #\- (:day 2) #\T
                      (:hour 2) #\: (:min 2) #\: (:sec 2)))
            (suffix '(:gmt-offset-or-z))
            (format (cond ((= nsec 0) (append prefix suffix))
                          ((= (mod nsec 1000000) 0) (append prefix '(#\. (:msec 3)) suffix))
                          ((= (mod nsec 1000) 0) (append prefix '(#\. (:usec 6)) suffix))
                          (t (append prefix '(#\. (:nsec 9)) suffix)))))
       (format stream "~S" (local-time:format-timestring
                            nil timestamp
                            :format format
                            :timezone local-time:+utc-zone+))))
    ((google:duration)
     (let ((seconds (google:duration.seconds object))
           (nanos (google:duration.nanos object)))
       (assert (eql (signum seconds) (signum nanos)))
       (format stream "\"~D.~V,VDs\"" seconds 9 #\0 (abs nanos))))
    ((google:field-mask)
     (let ((paths (google:field-mask.paths object)))
       (format stream "\"~{~a~^,~}\"" (mapcar (lambda (name)
                                            (pi::camel-case-but-one name '(#\_)))
                                              paths))))
    ((google:struct)
     (let ((field (pi::%find-field-descriptor (find-message-descriptor type) 'google::%fields)))
       (print-map-to-json (google:fields object) (find-map-descriptor (proto-class field))
                          indent stream camel-case-p numeric-enums-p)))
    ((google:list-value)
     (format stream "[")
     (loop for print-comma-p = nil then t
           for value in (google:values object)
           do (when print-comma-p (format stream ","))
              (when indent (format stream "~&~V,0T" (+ 2 indent)))
              (print-field-to-json value 'google:value (and indent (+ indent 2))
                                   stream camel-case-p numeric-enums-p))
     (if indent
         (format stream "~&~V,0T]" indent)
         (format stream "]")))
    ((google:value)
     (let* ((oneof-data (slot-value object 'google::%kind))
            ;; The wkt Value consists of a single oneof, so the first oneof in the
            ;; descriptor's list is the one we are looking for.
            (oneof-desc (first (pi::proto-oneofs (find-message-descriptor type))))
            (set-field (pi::oneof-set-field oneof-data)))
       (assert set-field ()
               "Message ~S must have a set 'kind' oneof as it has well-known-type 'Value'." object)
       (let* ((field (aref (pi::oneof-descriptor-fields oneof-desc)
                           (pi::oneof-set-field oneof-data)))
              (value (pi::oneof-value oneof-data)))
         (print-field-to-json value (proto-class field)
                              indent stream camel-case-p numeric-enums-p))))
    ;; Otherwise, TYPE is a wrapper type.
    (t (if object
           (print-scalar-to-json (google:value object)
                                 (wrapper-message->type type)
                                 stream)
           (format stream "null")))))

(defun parse-special-json (type stream ignore-unknown-fields-p)
  "Parse a well known type TYPE from STREAM. IGNORE-UNKNOWN-FIELDS-P is passed to recursive
calls to PARSE-JSON-IMPL."
  ;; If the stream starts with 'n', then the data is NULL. In which case, return NIL.
  ;; In all cases except the `Value` well-known-type, we return NIL. However, if TYPE is
  ;; GOOGLE:VALUE, then we return the wrapper enum that represents null as per the spec.
  (when (eql (peek-char nil stream nil) #\n)
    (pi::expect-token-or-string stream "null")
    (return-from parse-special-json
      (and (eql type 'google:value)
           (google:make-value :null-value :null-value))))
  (case type
    ((google:any)
     (pi::expect-char stream #\{)
     (pi::expect-token-or-string stream "url")
     (pi::expect-char stream #\:)
     (let* ((type-url (pi::parse-string stream))
            (type (wkt::resolve-type-url type-url)))
       (pi::expect-char stream #\,)
       (if (not (special-json-p type))
           ;; Parse the remaining elements in the object into a new message, then pack that message.
           (wkt:pack-any
            (parse-json-impl (find-message-descriptor type :error-p t)
                             stream ignore-unknown-fields-p t))
           ;; If URL names a well-known-type, then the next element in the object has key "VALUE",
           ;; and the value is the special JSON format. Parse that and close the object.
           (let (ret)
             (pi::expect-token-or-string stream "value")
             (pi::expect-char stream #\:)
             (setf ret (parse-special-json type stream ignore-unknown-fields-p))
             (pi::expect-char stream #\})
             (wkt:pack-any ret)))))

    ((google:timestamp)
     (let* ((timestring (pi::parse-string stream))
            (timestamp (local-time:parse-rfc3339-timestring timestring)))
       (google:make-timestamp
        :seconds (local-time:timestamp-to-unix timestamp)
        :nanos (local-time:nsec-of timestamp))))

    ;; Durations can feasibly have 64-bit seconds place, so parsing a float/double is lossy.
    ((google:duration)
     (pi::expect-char stream #\")
     (let ((seconds (pi::parse-signed-int stream)))
       (ecase (peek-char nil stream nil)
         ;; Duration has no decimal component.
         ((#\s)
          (pi::expect-char stream #\s)
          (pi::expect-char stream #\")
          (google:make-duration :seconds seconds))
         ((#\.)
          (pi::expect-char stream #\.)
          ;; Parse the decimal part of the string, and convert to nanoseconds.
          (let ((remainder (pi::parse-token stream)))
            (assert (eql (char remainder (1- (length remainder))) #\s)
                    nil "Duration string ~S.~A does end with \"s\"" seconds remainder)
            (pi::expect-char stream #\")
            (let* ((decimals (subseq remainder 0 (1- (length remainder))))
                   ;; If there are more than 9 decimal points, trim to length 9.
                   (decimals (if (< 9 (length decimals))
                                 (subseq decimals 0 10)
                                 decimals))
                   (dec-length (length decimals)))
              (google:make-duration
               :seconds seconds
               ;; Nanoseconds are in the range 0 through 999,999,999. Pad the decimal string
               ;; with 0s to make the string have total length 9.
               ;; Lastly, multiply by the sign of SECONDS, as NANOS and and SECONDS must
               ;; have the same sign.
               :nanos (* (if (= 0 seconds) 1 (signum seconds))
                         (parse-integer (concatenate 'string
                                                     decimals
                                                     (make-string (- 9 dec-length)
                                                                  :initial-element #\0)))))))))))

    ;; Field masks are in the form \"camelCasePath1,path2,path3\". We need to first split,
    ;; then convert to proto field name format (lowercase, separated by underscore).
    ((google:field-mask)
     (let ((camel-case-paths (pi::split-string (pi::parse-string stream)
                                                       :separators '(#\,))))
       (google:make-field-mask
        :paths (mapcar (lambda (path) (nstring-downcase (pi::uncamel-case path #\_)))
                       camel-case-paths))))

    ((google:struct)
     (pi::expect-char stream #\{)
     (loop with ret = (google:make-struct)
           for key = (pi::parse-string stream)
           do (pi::expect-char stream #\:)
              (setf (google:struct.fields-gethash key ret)
                    (parse-special-json 'google:value stream ignore-unknown-fields-p))
              (if (eql (peek-char nil stream nil) #\,)
                  (pi::expect-char stream #\,)
                  (progn
                    (pi::expect-char stream #\})
                    (return ret)))))

    ((google:list-value)
     (pi::expect-char stream #\[)
     (loop with ret = (google:make-list-value)
           do (multiple-value-bind (data err)
                  (parse-value-from-json 'google:value
                                         :stream stream
                                         :ignore-unknown-fields-p ignore-unknown-fields-p)
                (if err
                    (error "Error while parsing well known type VALUE from JSON format.")
                    (push data (google:list-value.values ret))))
              (if (eql (peek-char nil stream nil) #\,)
                  (pi::expect-char stream #\,)
                  (progn
                    (pi::expect-char stream #\])
                    (return ret)))))

    ((google:value)
     (case (peek-char nil stream nil)
       ((#\{) (google:make-value
               :struct-value (parse-special-json 'google:struct stream ignore-unknown-fields-p)))
       ((#\[) (google:make-value
               :list-value (parse-special-json 'google:list-value stream ignore-unknown-fields-p)))
       ((#\") (google:make-value :string-value (pi::parse-string stream)))
       ((#\t)
        (pi::expect-token-or-string stream "true")
        (google:make-value :bool-value t))
       ((#\f)
        (pi::expect-token-or-string stream "false")
        (google:make-value :bool-value nil))
       ;; Otherwise, the value has type double.
       (t (google:make-value :number-value (pi::parse-double stream :append-d0 t)))))

    ;; Otherwise, the well known type is a wrapper type.
    (t (let ((object (funcall (pi::get-constructor-name type)))
             (value (parse-value-from-json (wrapper-message->type type) :stream stream)))
         (setf (google:value object) value)
         object))))

(defun fmt (stream proto colon-p at-sign-p &optional width &rest other-args)
  "Format command for protobufs
   ~/cl-protobufs.json:fmt/ emits a non-pretty-printed protobuf of PROTO to STREAM.
   ~@/cl-protobufs.json:fmt/ emits a pretty-printed protobuf of PROTO to STREAM.
   COLON-P and AT-SIGN-P are the usual for format directives.
   WIDTH and OTHER-ARGS are ignored."
  (declare (ignore width))
  (cond (other-args (error "FORMAT directive ~~/cl-protobufs.json:fmt/ takes only one argument."))
        (colon-p (error "FORMAT directive ~~/cl-protobufs.json:fmt/ does not take colons."))
        (t (print-json proto :stream stream :pretty-print-p at-sign-p))))