summaryrefslogtreecommitdiff
path: root/src/eris-decode.lisp
blob: df649135badec2bcb619dc51b308bc5f687a957b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
;; This file is part of eris-cl.
;; Copyright (C) 2022 Piotr Szarmański

;; eris-cl is free software: you can redistribute it and/or modify it under the
;; terms of the GNU Lesser General Public License as published by the Free
;; Software Foundation, either version 3 of the License, or (at your option) any
;; later version.

;; eris-cl is distributed in the hope that it will be useful, but WITHOUT ANY
;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
;; A PARTICULAR PURPOSE. See the GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License along with
;; eris-cl. If not, see <https://www.gnu.org/licenses/>.

(in-package :eris)

(defvar *decode-safety-checks* t
  "If set to nil, disable computationally expensive safety checks that ensure the
fetched blocks are what they claim to be. Only disable this if the blocks are
fetched from a trusted party.")

(defmacro hash-check (block rk &optional key)
  `(when *decode-safety-checks*
     (let ((hash (ironclad:digest-sequence :blake2/256 ,block)))
       (unless (octet-vector= ,rk hash ,(if key :start1 :end1) 32)
         (error 'hash-mismatch :reference ,rk :hash hash )))))

;; This is quite pointless.
(defmacro execute-fetch-function (fetch-function &rest args)
  `(restart-case (funcall ,fetch-function (subseq ,@args 0 32))
     (use-value (value) value)))

(defun key-reference-null? (kr)
  (octet-vector= kr #.(make-array 64 :element-type 'octet :initial-element 0)))

(defclass high-block ()
  ((data :initarg :data :accessor data :type octet-vector)
   (position :initarg :position :accessor pos :type integer
             :documentation "Position relative to the higher block.")
   (level :initarg :level :accessor level :type octet)))

(defclass buffer ()
  ((data :initarg :data :accessor data :type octet-vector)
   (pos :initarg :pos :accessor pos :type fixnum)
   (eof :initarg :eof :accessor eof :type fixnum
        :documentation "Either the position of the EOF in the buffer, or the length of the buffer.")))

(defclass eris-decode-stream (fundamental-binary-input-stream)
  ((position :initform 0 :accessor pos :initarg :position :type integer)
   (get-block :accessor get-block :initarg :get-block :type function)
   (block-size :accessor block-size :type block-size :initarg :block-size)
   (root :accessor root :type high-block :initarg :root :documentation "A list of blocks, starting from the root to the level 1 block.")
   (buffer :accessor buffer :initarg :buffer :type buffer)
   (eof :accessor eof :initarg :eof :type integer)
   (nonce-array :accessor nonce-array :initarg :nonce-array :type simple-array))
  (:documentation "Class representing the stream object that decodes an ERIS read capability."))

(defun initialize-nonce-array (level)
  (let ((array (make-array (1+ level))))
    (loop for i from 0 to level
          do (setf (aref array i) (make-nonce i)))
    array))

(defun unpad-block (block)
  (let ((padding (position #x80 block :from-end t)))
    (unless padding
      (error 'padding-error))
    (unless (loop for i across (nsubseq block (1+ padding))
                  always (zerop i))
      (error 'padding-error))
    padding))

(defun unpad-buffer (buffer)
  (with-slots (eof data) buffer
    (setf eof (unpad-block data))))

(defun local-range (level block-size)
  "Given a level and a block-size, determine the range of bytes that it
represents."
  (declare (type fixnum level)
           (type block-size block-size))
  (ecase block-size
    (1024 (expt 2 (+ 10 (* level 4))))
    (32768 (expt 2 (+ 15 (* level 9))))))

(defun find-eof (root get-block block-size level)
  "Find the end of file in a given tree."
  ;; The standard states that:
  ;; "If 64 bytes of zeroes are encountered the rest of the node MUST be checked to be all zeroes"
  ;; This procedure processes the block from right to left so it's not really applicable here
  ;; A maliciously crafted ERIS block which contains 0 ... kr ... 0 ... kr could fool this.

  (flet ((find-last-reference (block)
           (loop for i from (1- (/ block-size 64)) downto 0
                 for key-reference = (subseq block (* 64 i) (+ 64 (* 64 i)))
                 unless (key-reference-null? key-reference)
                   return (values key-reference i))))
    (loop with position = 0
          for local-level = level then (1- local-level)
          for block = root then (funcall get-block key-reference (make-nonce local-level))
          for (key-reference block-pos) = (multiple-value-list (find-last-reference block))
          if (eql 0 local-level)
            do (setf position (+ position (unpad-block block)))
            and return position
          else
            do (setf position (+ position (* block-pos (local-range (1- local-level) block-size)))))))

(defun advance-next-block (stream)
  "Advance to the next block. 

This function walks the tree in order to get the next block, which is then put
in the buffer object of the STREAM. It sets the EOF indicator of the buffer if
it is necessary and sets the position in the buffer to 0."
  (declare (optimize (speed 3) (debug 0))
           (type eris-decode-stream stream)) 
  (with-slots (buffer position eof block-size root get-block nonce-array) stream
    (declare (type integer position eof)
             (type block-size block-size)
             #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
    (labels ((process-block (blocks mod level) ;; A recursive function that 1+'s each block until the 
               (declare (type fixnum mod))
               (let* ((current (car blocks))
                      (next-pos (setf (pos current)
                                      (mod (the fixnum (1+ (the fixnum (pos current)))) mod))))
                 (declare (type high-block current)
                          (type fixnum next-pos))
                 (when (zerop next-pos) ;; if 1+ mod blocks results in a zero, then update the next block
                   (process-block (cdr blocks) mod (1+ level)))
                 (let ((kr (let ((a (make-octet-vector 64)))
                             (replace a (data (cadr blocks)) :start2 (the fixnum (* next-pos 64)))
                             a)))
                   (setf (data current)
                         (funcall get-block kr (svref nonce-array level)))))))
      (process-block (reverse root) (/ block-size 64) 0) ;; process the blocks from level 0 up
      ;; setf the buffer data to the level 0 block
      (setf (data buffer) (data (car (last root)))
            (pos buffer) 0)
      ;; if the EOF block is reached, unpad it.
      (when (= (- eof (mod eof block-size)) position)
        (unpad-buffer buffer)))))

(defun read-to-seq (sequence buf &key (start 0) (end (length sequence)) stream)
  (declare (optimize (speed 3) (debug 0))
           (type array-total-size end start)
           #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
  (with-slots (data pos eof) buf
    (declare (type (integer 0 32768) pos eof)
             (type octet-vector data))
    (let ((buffer-bytes (- eof pos))
          (seq-bytes (- end start)))
      (declare (dynamic-extent buffer-bytes seq-bytes)
               (type integer seq-bytes)
               (type (integer 0 32768) buffer-bytes))
      (cond
        ((> buffer-bytes seq-bytes) ;; seq is smaller than buffer case
         (replace sequence data :start1 start :end1 end :start2 pos)
         (setf pos (+ pos seq-bytes)
               (pos stream) (+ (pos stream) seq-bytes))
         (+ start seq-bytes))
        ((eql eof (length data)) ;; seq is larger or equal than buffer case
         (replace sequence data :start1 start :end1 end :start2 pos)
         (setf (pos stream) (+ (pos stream) buffer-bytes))
         (advance-next-block stream) 
         (read-to-seq sequence buf :start (+ start buffer-bytes) :end end :stream stream))
        (t ;; if there is an eof in the buffer
         (replace sequence data :start1 start :end1 end :start2 pos :end2 eof)
         (setf pos (+ pos buffer-bytes)
               (pos stream) (+ (pos stream) buffer-bytes))
         (+ start buffer-bytes))))))


(defun reupdate-block (stream new-pos)
  "Update the blocks of the stream according to new-pos. Used for random access and initialization."
  (unless (root stream)
    (error 'eof :eof new-pos :position (pos stream)))
  (with-slots (block-size root get-block buffer nonce-array eof) stream
    (loop with update-tree = nil
          for blocks = root then (cdr blocks)
          for level = (level (car blocks)) ;; then (decf level)
          for position = new-pos then (mod position (local-range (1- level) block-size)) ;; local position
          for block-position = (floor (/ position (local-range (1- level) block-size))) ;; the position of the block
          for lower-block = (second blocks)
          when (> block-position (/ block-size 64))
            do (error 'eof :eof new-pos :position (pos stream))
          until (eq nil (cdr blocks))
          when (or update-tree (not (eq block-position (pos lower-block))))
            do (let ((rk (let ((a (make-octet-vector 64)))
                           (replace a (data (car blocks)) :start2 (* 64 block-position))
                           a)))
                 (when (key-reference-null? rk)
                   (error 'eof :eof new-pos :position (pos stream)))
                 (setf (data lower-block) (funcall get-block rk (svref nonce-array (1- level)))
                       (pos lower-block) block-position
                       update-tree t))
          finally (when update-tree ;; if anything changed
                    (setf (pos stream) new-pos
                          (data buffer) (data (car (last root)))
                          (pos buffer) (mod new-pos block-size))
                    (if (< (- eof (mod eof block-size)) new-pos)
                        (unpad-buffer buffer)
                        (setf (eof buffer) block-size))))))

(defun initialize-high-blocks (level)
  (case level
    (-1 nil)
    (t (cons (make-instance 'high-block :level level :position -1 :data (make-array 0 :element-type 'octet))
             (initialize-high-blocks (1- level))))))



(defun eris-decode (read-capability fetch-function &key (cache-capacity 2048))
  "Using the FETCH-FUNCTION, return a stream that decodes the READ-CAPABILITY.
This stream implements the Gray streams protocol.

Fetch-function must be a function with one argument, the reference octet, which
returns a (simple-array (unsigned-byte 8)) containing the block. The block will
be destructively modified, so you MUST provide a fresh array every time. If a
hash-table is used, a (copy-seq) needs to be done on the return value of
gethash.

The keyword argument CACHE-CAPACITY indicates the amount of blocks stored in the
cache. It may be NIL to turn off caching entirely.

The conditions ERIS:MISSING-BLOCK, ERIS:PADDING, ERIS:HASH-MISMATCH and ERIS:EOF
may be signaled by operations on the stream. Any condition signaled from within
FETCH-FUNCTION is not handled."
  (declare (type read-capability read-capability)
           (type function fetch-function)
           (type (or integer null) cache-capacity))
  (with-slots (level block-size root-reference-pair) read-capability
    (let* ((get-block (if cache-capacity ;; handle caching
                          (cached-lambda (:cache-class 'lru-cache 
                                                       :capacity cache-capacity
                                                       :table (make-hash-table :size (1+ cache-capacity) :test #'equalp))
                                         (rk nonce)
                                         (declare (type octet-vector rk nonce))
                                         (let ((block (execute-fetch-function fetch-function rk)))
                                           (declare (type octet-vector block))
                                           (hash-check block rk)
                                           (decrypt-block block rk nonce)))
                        (lambda (rk nonce)
                          (declare (type octet-vector rk nonce)) 
                          (let ((block (execute-fetch-function fetch-function rk)))
                            (declare (type octet-vector block))
                            (hash-check block rk)
                            (decrypt-block block rk nonce)))))
           (root (funcall get-block root-reference-pair  (make-nonce level))))
      ;; "Implementations MUST verify the key appearing in the read capability
      ;; if level of encoded content is larger than 0."
      (when (> level 0) (hash-check root root-reference-pair :key))
      (case level
        ;; Treat level 0 blocks specially, since those are just a single buffer.
        (0 (let ((stream
                   (make-instance 'eris-decode-stream
                                  :buffer (make-instance 'buffer
                                                         :data (make-array block-size :element-type 'octet)
                                                         :pos 0
                                                         :eof -1)
                                  :get-block (lambda (rk)
                                               (error 'missing-block :reference rk))
                                  :block-size block-size
                                  :root nil
                                  :eof (find-eof root get-block block-size level)
                                  :nonce-array (initialize-nonce-array 0))))
             (replace (data (buffer stream)) root)
             (unpad-buffer (buffer stream))
             stream))
        (t (make-instance 'eris-decode-stream
                          :buffer (make-instance 'buffer
                                                 :data (make-array block-size :element-type 'octet)
                                                 :pos -1
                                                 :eof block-size)
                          :get-block get-block
                          :block-size block-size
                          :root (cons (make-instance 'high-block :level level
                                                                 :data root
                                                                 :position 0)
                                      (initialize-high-blocks (1- level)))
                          :eof (find-eof root get-block block-size level)
                          :nonce-array (initialize-nonce-array level)))))))

(defmethod stream-file-position ((stream eris-decode-stream))
  "Provides the file position of the stream. This method is setf-able in order to
change the position."
  (pos stream))

(defmethod stream-read-sequence ((stream eris-decode-stream) seq start end &key)
  (when (minusp (pos (buffer stream)))
    ;; initializes the buffer
    (reupdate-block stream (pos stream)))
  (with-slots (buffer position) stream
    (read-to-seq seq buffer :start start :end end :stream stream)))

(defmethod stream-read-byte ((stream eris-decode-stream))
  (when (minusp (pos (buffer stream)))
    ;; initializes the buffer
    (reupdate-block stream (pos stream)))
  (with-slots (position buffer block-size) stream
    (with-slots (pos eof data) buffer
      (cond
        ((eql pos block-size)
         (advance-next-block stream)
         (stream-read-byte stream))
        ((eql pos eof)
         :eof)
        (t (prog1 (aref data pos)
             (incf pos)
             (incf position)))))))

(defmethod stream-element-type ((stream eris-decode-stream))
  '(unsigned-byte 8))

(defun eris-file-length (stream)
  "This is the equivalent of \"file-length\" for eris-decode-stream."
  (eof stream))

(defmethod (setf stream-file-position) (set-position (stream eris-decode-stream))
  (with-slots (position block-size buffer eof) stream
    (when set-position
      (case set-position
        (:end (setf set-position eof))
        (:start (setf set-position 0)))
      (let ((buffer-pos (mod set-position block-size)))
        (if (< set-position eof)
            (cond
              ;; If the pos is within the buffer (and initialized): 
              ((and (<= 0 (- set-position (- position (pos buffer))) (1- block-size))
                    (not (minusp (pos buffer))))
               (setf (pos buffer) buffer-pos
                     position set-position))
              
              (t (reupdate-block stream set-position)
                 (setf (pos buffer) buffer-pos)))
            (error 'eof :eof eof :position position))))
    set-position))