[chatter] r11817 - in trunk/libraries: registry/generic tcp-command-server

[hannes at mccarthy.opendylan.org]

Author: hannes
Date: Wed May 21 02:35:54 2008
New Revision: 11817

Added:
   trunk/libraries/registry/generic/tcp-command-server   (contents, props changed)
   trunk/libraries/tcp-command-server/
   trunk/libraries/tcp-command-server/tcp-command-server-exports.dylan   (contents, props changed)
   trunk/libraries/tcp-command-server/tcp-command-server.dylan   (contents, props changed)
   trunk/libraries/tcp-command-server/tcp-command-server.lid   (contents, props changed)
Log:
Job: minor
command server for usage on lovelace since
 lovelace and mccarthy are now separate systems
(thus, a commit to www must trigger a remote svn checkout, ...)


Added: trunk/libraries/registry/generic/tcp-command-server
==============================================================================
--- (empty file)
+++ trunk/libraries/registry/generic/tcp-command-server	Wed May 21 02:35:54 2008
@@ -0,0 +1 @@
+abstract://dylan/tcp-command-server/tcp-command-server.lid

Added: trunk/libraries/tcp-command-server/tcp-command-server-exports.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/tcp-command-server/tcp-command-server-exports.dylan	Wed May 21 02:35:54 2008
@@ -0,0 +1,20 @@
+module: dylan-user
+
+define library tcp-command-server
+  use common-dylan;
+  use io;
+  use system;
+  use network;
+end library;
+
+define module tcp-command-server
+  use common-dylan;
+  use format-out;
+  use sockets;
+  use date;
+  use operating-system;
+  use threads;
+  use streams;
+  use file-system;
+  use locators;
+end module;

Added: trunk/libraries/tcp-command-server/tcp-command-server.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/tcp-command-server/tcp-command-server.dylan	Wed May 21 02:35:54 2008
@@ -0,0 +1,86 @@
+module: tcp-command-server
+
+define variable *working-directory* = #f;
+
+define function main(name, arguments)
+  start-sockets();
+  if (arguments.size == 1)
+    *working-directory* := as(<directory-locator>, arguments[0]);
+  else
+    format-out("Usage: %s working-directory\n", name);
+    exit-application(-1);
+  end;
+  let lsocket = make(<server-socket>, port: 1234);
+  while(#t)
+    let socket = accept(lsocket);
+    make(<thread>, function: curry(reply-to-request, socket));
+  end
+end function main;
+
+//code from koala, static-file-responder
+define method locator-below-root?
+    (locator :: <physical-locator>, root :: <directory-locator>)
+ => (below? :: <boolean>)
+  let relative = relative-locator(locator, root);
+  // do they at least share a common ancestor?
+  if (locator-relative?(relative))
+    let relative-parent = locator-directory(relative);
+    // is it a file directly in the root dir?
+    ~relative-parent | begin
+      let relative-path = locator-path(relative-parent);
+      // again, is it directly in the root dir?
+      empty?(relative-path) | 
+        relative-path[0] ~= #"parent"  // does it start with ".."?
+    end;
+  end if;
+end method locator-below-root?;
+
+define function duration-to-string (duration :: <day/time-duration>) => (res :: <string>)
+  let (days, hours, minutes, seconds) = decode-duration(duration);
+  if (days > 0)
+    format-to-string("%dd %dh %dm %ds",
+		     days, hours, minutes, seconds);
+  elseif (hours > 0)
+    format-to-string("%dh %dm %ds",
+		     hours, minutes, seconds);
+  elseif (minutes > 0)
+    format-to-string("%dm %ds", minutes, seconds);
+  else
+    format-to-string("%ds", seconds);
+  end;
+end;
+
+define function reply-to-request (socket :: <socket>)
+  block(ret)
+    let now = current-date();
+    format-out("%s host %s ",
+	       format-date("%d/%b/%Y:%T %z", now),
+	       as(<string>, host-address(remote-host(socket))));
+
+    let command =
+      block ()
+	let line = read-line(socket);
+	close(socket);
+	line;
+      exception (e :: <error>)
+	format-out("communication error %=\n", e);
+	ret();
+      end;
+    
+    format-out("\"%s\" ", command);
+    let exec = as(<file-locator>,
+		  concatenate(as(<string>, *working-directory*), command));
+    if (file-exists?(exec)
+	  & locator-below-root?(exec, *working-directory*))
+      let exit = run-application(as(<string>, exec));
+      format-out("succeeded with %= in %s\n",
+		 exit, duration-to-string(current-date() - now));
+    else
+      format-out("unknown command\n");
+    end;
+  exception (e :: <error>)
+    format-out("got exception %=\n", e);
+  end
+end;
+
+main(application-name(), application-arguments());

Added: trunk/libraries/tcp-command-server/tcp-command-server.lid
==============================================================================
--- (empty file)
+++ trunk/libraries/tcp-command-server/tcp-command-server.lid	Wed May 21 02:35:54 2008
@@ -0,0 +1,4 @@
+library: tcp-command-server
+executable: tcp-command-server
+files: tcp-command-server-exports
+  tcp-command-server