examples/ssshd.scm: Add `--detach' option.

* examples/ssshd.scm (close-ports): New procedure.
  (main): Add `--detach' option.

1 files changed, 35 insertions, 10 deletions

diff --git a/examples/ssshd.scm b/examples/ssshd.scm
index 54be68e..5e49a83 100755
--- a/examples/ssshd.scm
+++ b/examples/ssshd.scm
@@ -196,6 +196,15 @@
       (else
        (message-reply-success msg)))))
 
+(define (close-ports)
+  "Close default ports."
+  (close-port (current-input-port))
+  (close-port (current-output-port))
+
+  (let ((p (open-output-file "/dev/null")))
+    (set-current-output-port p)
+    (set-current-error-port  p)))
+
 (define (print-help-and-exit)
   "Print help message and exit."
   (display "\
@@ -204,6 +213,7 @@ Usage: ssshd.scm [ options ]
 Options:
   --rsakey=<key>, -r <key>      Set host RSA key.
   --dsakey=<key>, -d <key>      Set host DSA key.
+  --detach                      Detach mode
   --help, -h                    Print this message and exit.
 ")
   (exit))
@@ -214,19 +224,40 @@ Options:
 (define *option-spec*
   '((rsakey (single-char #\r) (value #t))
     (dsakey (single-char #\d) (value #t))
+    (detach                   (value #f))
     (help   (single-char #\h) (value #f))))
 
 (define (main args)
   "Entry point of the program."
   (display "---------- ssshd ----------\n")
-  (let* ((options     (getopt-long args *option-spec*))
-         (rsakey      (option-ref options 'rsakey *default-rsakey*))
-         (dsakey      (option-ref options 'dsakey *default-dsakey*))
-         (help-wanted (option-ref options 'help    #f)))
+  (let* ((options       (getopt-long args *option-spec*))
+         (rsakey        (option-ref options 'rsakey *default-rsakey*))
+         (dsakey        (option-ref options 'dsakey *default-dsakey*))
+         (detach-wanted (option-ref options 'detach #f))
+         (help-wanted   (option-ref options 'help    #f)))
 
     (if help-wanted
         (print-help-and-exit))
 
+    (format #t (string-append
+                "Using private key ~a~%"
+                "Listening on port ~a~%")
+            *default-rsakey*
+            *default-bindport*)    
+
+    (if detach-wanted
+        (let ((pid (primitive-fork)))
+          (cond
+           ((zero? pid)
+            (close-ports)
+            (setsid))
+           ((> pid 0)
+            (format #t "PID: ~a~%" pid)
+            (exit))
+           (#t
+            (display "Could not fork the processs\n")
+            (exit 1)))))
+
     (let ((server (make-server #:bindport      *default-bindport*
                                #:rsakey        rsakey
                                #:dsakey        dsakey
@@ -234,12 +265,6 @@ Options:
                                #:banner        "Scheme Secure Shell Daemon"))
           (channel #f))
 
-    (format #t (string-append
-                "Using private key ~a~%"
-                "Listening on port ~a~%")
-            *default-rsakey*
-            *default-bindport*)
-
     ;; Start listen to incoming connections.
     (server-listen server)