Fix HTTP body framing and eliminate request over-read

lib/http.tri

@@ -159,7 +159,7 @@ responseForMethod = (method resp :
 -- ---------------------------------------------------------------------------
 
 recvUntilMax_ = (y (self sock pattern maxBytes acc accLen :
-  onResult_ (recv sock 4096)
+  onResult_ (recv sock 1)
     (err :
       pure (err 400 acc))
     (chunk :
@@ -518,63 +518,130 @@ contentLength = (headers :
 --  Body reading
 -- ---------------------------------------------------------------------------
 
-consumeAvailable_ = (y (self bytes remaining acc :
+bodyReadState = (remaining accRev rest :
-  lazyList
+  pair remaining (pair accRev rest))
-    (_ : pair (reverse acc) (pair remaining t))
-    (h r :
-      lazyBool
-        (_ : pair (reverse acc) (pair 0 r))
-        (_ : self r (pred remaining) (pair h acc))
-        (isZero? remaining))
-    bytes))
 
-consumeAvailable = (bytes n :
+bodyReadRemaining = (state :
-  consumeAvailable_ bytes n t)
+  fst state)
 
-readBodyN_ = (y (self sock remaining acc :
+bodyReadAccRev = (state :
+  fst (snd state))
+
+bodyReadRest = (state :
+  snd (snd state))
+
+takeBodyBytes_ = (self bytes remaining accRev :
   lazyBool
-    (_ : pure (ok acc t))
+    (_ : bodyReadState 0 accRev bytes)
     (_ :
-      onResult_ (recv sock remaining)
+      lazyList
-        (err :
+        (_ : bodyReadState remaining accRev t)
-          pure (err 400 acc))
+        (h r :
-        (chunk :
+          self r (pred remaining) (pair h accRev))
-          ((got :
+        bytes)
-            lazyBool
+    (isZero? remaining))
-              (_ : pure (err 400 acc))
-              (_ : self sock (sub remaining got) (append acc chunk))
-              (equal? got 0))
-           (length chunk))))
-    (isZero? remaining)))
 
-readBodyN = (sock n acc :
+takeBodyBytes = (bytes remaining accRev :
-  readBodyN_ sock n acc)
+  y takeBodyBytes_ bytes remaining accRev)
+
+readBodyRecv = (self sock remaining accRev recvBytes :
+  onResult_ (recv sock recvBytes)
+    (errMsg :
+      pure
+        (err
+          400
+          (append "recv failed while reading body: " errMsg)))
+    (chunk :
+      ((state :
+        ((nextRemaining :
+          ((nextAccRev :
+            lazyBool
+              (_ : pure (ok (reverse nextAccRev) (bodyReadRest state)))
+              (_ : self sock nextRemaining nextAccRev)
+              (isZero? nextRemaining))
+           (bodyReadAccRev state)))
+         (bodyReadRemaining state)))
+       (takeBodyBytes chunk remaining accRev))))
+
+readBodyMore_ = (self sock remaining accRev :
+  lazyBool
+    (_ : pure (ok (reverse accRev) t))
+    (_ :
+      lazyBool
+        (_ : readBodyRecv self sock remaining accRev 4096)
+        (_ :
+          lazyBool
+            (_ : readBodyRecv self sock remaining accRev 1024)
+            (_ :
+              lazyBool
+                (_ : readBodyRecv self sock remaining accRev 256)
+                (_ :
+                  lazyBool
+                    (_ : readBodyRecv self sock remaining accRev 64)
+                    (_ :
+                      lazyBool
+                        (_ : readBodyRecv self sock remaining accRev 16)
+                        (_ : readBodyRecv self sock remaining accRev 1)
+                        (lte? 16 remaining))
+                    (lte? 64 remaining))
+                (lte? 256 remaining))
+            (lte? 1024 remaining))
+        (lte? 4096 remaining))
+    (isZero? remaining))
+
+readBodyMore = (sock remaining accRev :
+  y readBodyMore_ sock remaining accRev)
+
+readBodyExact = (sock expected initialBytes :
+  ((state :
+    ((remaining :
+      ((accRev :
+        lazyBool
+          (_ : pure (ok (reverse accRev) (bodyReadRest state)))
+          (_ : readBodyMore sock remaining accRev)
+          (isZero? remaining))
+       (bodyReadAccRev state)))
+     (bodyReadRemaining state)))
+   (takeBodyBytes initialBytes expected t)))
+
+validateBodyLength = (expected body rest :
+  ((actual :
+    lazyBool
+      (_ : pure (ok body rest))
+      (_ :
+        pure
+          (err
+            400
+            (append
+              "body length mismatch expected="
+              (append
+                (showNumber expected)
+                (append
+                  " actual="
+                  (showNumber actual))))))
+      (equal? actual expected))
+   (length body)))
 
 readBody = (sock headers initialBytes :
   matchResult
     (status msg :
-      pure (err status "Bad Request\n"))
+      pure (err status msg))
     (maybeLen rest :
       lazyMaybe
         (_ : pure (ok t initialBytes))
         (n :
-          ((consumed :
-            ((body0 :
-              ((remaining :
           lazyBool
-                  (_ : pure (ok body0 t))
             (_ :
-                    onOk (readBodyN sock remaining body0)
+              onOk (readBodyExact sock n initialBytes)
-                      (body rest : pure (ok body t)))
+                (body rest :
-                  (isZero? remaining))
+                  validateBodyLength n body rest))
-               (fst (snd consumed))))
+            (_ : pure (err 400 "Request body too large\n"))
-             (fst consumed)))
+            (lte? n maxBodyBytes))
-           (consumeAvailable initialBytes n)))
         maybeLen)
     (contentLength headers))
 
 -- ---------------------------------------------------------------------------
--- 10. Request validation
+-- Request validation
 -- ---------------------------------------------------------------------------
 
 validMethod? = (method :
@@ -629,12 +696,12 @@ respondAndClose = (sock resp :
     pure (ok t t)))
 
 handleReadableRequest = (router client method target headers rest3 :
-  onResult_ (readBody client headers rest3)
+  onResult (readBody client headers rest3)
-    (status :
+    (status msg :
       respondAndClose client
         (responseForMethod method
-          (badRequestResponse "Bad Request\n")))
+          (errorResponse status msg)))
-    (body :
+    (body rest :
       respondAndClose client
         (responseForMethod method
           (router (routerMethod method) target headers body))))
@@ -680,12 +747,12 @@ httpHandler = (router client peer :
 -- ---------------------------------------------------------------------------
 
 handleReadableRequestIO = (routerIO client method target headers rest3 :
-  onResult_ (readBody client headers rest3)
+  onResult (readBody client headers rest3)
-    (status :
+    (status msg :
       respondAndClose client
         (responseForMethod method
-          (badRequestResponse "Bad Request\n")))
+          (errorResponse status msg)))
-    (body :
+    (body rest :
       bind (routerIO (routerMethod method) target headers body) (resp :
         respondAndClose client (responseForMethod method resp))))