Factor PARSE-PORT-ARG out of FTPD into FTP-LIBRARY (in preparation of

passive mode support in FTP).

scheme/ftpd/ftpd.scm

@@ -880,52 +880,21 @@
   (log (syslog-level debug) "successfully done nothing (200)")
   (register-reply! 200 "Done nothing, but successfully."))
 
-(define *port-arg-regexp*
-  (make-regexp "^([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)$"))
-
-(define (parse-port-arg string)
-  (log (syslog-level debug) "parsing port-string ~S" string)
-  (cond
-   ((regexp-exec *port-arg-regexp* string)
-    => (lambda (match)
-	 (let ((components
-		(map (lambda (match-index)
-		       (string->number
-			(match:substring match match-index)))
-		     '(1 2 3 4 5 6))))
-	   (if (any (lambda (component)
-		      (> component 255))
-		    components)
-	       (begin
-		 (log (syslog-level debug)
-		      "rejecting PORT-command because of invalid arguments (port-component > 255) (501)")
-		 (signal-error! 501
-				"Invalid arguments to PORT.")))
-	   (apply
-	    (lambda (a1 a2 a3 a4 p1 p2)
-	      (let ((address (+ (arithmetic-shift a1 24)
-				(arithmetic-shift a2 16)
-				(arithmetic-shift a3 8)
-				a4))
-		    (port (+ (arithmetic-shift p1 8) p2)))
-		(log (syslog-level debug)
-		     "port-parse result: address ~D, port ~D (from compononets: address: ~A, ~A, ~A, ~A, port: ~A, ~A)"
-		     address port
-		     a1 a2 a3 a4 p1 p2)
-		 (values address port)))
-	    components))))
-   (else
-    (log (syslog-level debug) "reporting syntax error in argument (500)")
-    (signal-error! 500
-		   "Syntax error in argument to PORT."))))
-
+(define (ftpd-parse-port-arg stuff)
+  (with-fatal-error-handler*
+   (lambda (condition more)
+     (log (syslog-level debug) "reporting syntax error in argument (500)")
+     (signal-error! 500
+		    "Syntax error in argument to PORT."))
+   (lambda ()
+     (parse-port-arg stuff))))
 
 (define (handle-port stuff)
   (log-command (syslog-level info) "PORT" stuff)
   (ensure-authenticated-login)
   (maybe-close-data-connection)
   (call-with-values
-   (lambda () (parse-port-arg stuff))
+   (lambda () (ftpd-parse-port-arg stuff))
    (lambda (address port)
      (let ((socket (create-socket protocol-family/internet
 				  socket-type/stream)))
@@ -1207,7 +1176,9 @@
   (dynamic-wind ensure-data-connection
 		thunk
 		maybe-close-data-connection))
-  
+
+(define *window-size* 4096)
+
 (define (ensure-data-connection)
   (if (and (not (the-session-data-socket)) 
 	   (not (the-session-passive-socket)))

scheme/lib/ftp-library.scm

@@ -44,4 +44,33 @@
 	    (write-string line output-port 0 length)
 	    (newline output-port)
 	    (loop)))))
-  (force-output output-port))
+  (force-output output-port))
+
+(define *port-arg-regexp*
+  (make-regexp "^([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)$"))
+
+(define (parse-port-arg string)
+  (cond
+   ((regexp-exec *port-arg-regexp* string)
+    => (lambda (match)
+	 (let ((components
+		(map (lambda (match-index)
+		       (string->number
+			(match:substring match match-index)))
+		     '(1 2 3 4 5 6))))
+	   (if (any (lambda (component)
+		      (> component 255))
+		    components)
+	       (call-error "invalid PORT argument" parse-port-arg))
+	   (apply
+	    (lambda (a1 a2 a3 a4 p1 p2)
+	      (let ((address (+ (arithmetic-shift a1 24)
+				(arithmetic-shift a2 16)
+				(arithmetic-shift a3 8)
+				a4))
+		    (port (+ (arithmetic-shift p1 8) p2)))
+		 (values address port)))
+	    components))))
+   (else
+    (call-error "invalid PORT argument" parse-port-arg))))
+

scheme/packages.scm

@@ -86,7 +86,8 @@
 (define-interface ftp-library-interface
   (export copy-port->port-binary
 	  copy-port->port-ascii
-	  copy-ascii-port->port))
+	  copy-ascii-port->port
+	  parse-port-arg))
 
 (define-interface ftp-interface
   (export ftp-connect
@@ -408,6 +409,8 @@
 
 (define-structure ftp-library ftp-library-interface
   (open scheme-with-scsh
+	(subset signals (call-error))
+	(subset srfi-1 (any))
 	crlf-io)
   (files (lib ftp-library)))
 
@@ -532,7 +535,7 @@
 	fluids thread-fluids
 	locks
 	(subset srfi-13 (string-map string-trim-both string-index))
-	(subset srfi-1 (any partition))
+	(subset srfi-1 (partition))
 	crlf-io
 	ls
 	ftp-library