Initial import

.gitignore

@@ -0,0 +1,6 @@
+/objs
+/dist
+.*.swp
+*~
+*.o
+test

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2006-2009 Galois Inc.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions 
+are met:
+
+  * Redistributions of source code must retain the above copyright 
+    notice, this list of conditions and the following disclaimer.
+
+  * Redistributions in binary form must reproduce the above copyright 
+    notice, this list of conditions and the following disclaimer in 
+    the documentation and/or other materials provided with the 
+    distribution.
+
+  * Neither the name of Galois, Inc. nor the names of its contributors 
+    may be used to endorse or promote products derived from this 
+    software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Setup.hs

@@ -0,0 +1,7 @@
+module Main (main) where
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain
+

TODO

@@ -0,0 +1,25 @@
+
+-- src/Layer/Arp.hs ------------------------------------------------------------
+ * There is currently no way to remove an address that has been added to the arp
+   layer
+
+
+-- src/Layer/Ethernet.hs -------------------------------------------------------
+ complete
+
+
+-- src/Layer/IP4 ---------------------------------------------------------------
+ * There is no way to remove a route
+
+
+-- src/Layer/Icmp4.hs ----------------------------------------------------------
+ * The only ICMP message that is currently handled is EchoRequest
+ * DestinationUnreachable needs to be communicated up to relevant layers
+
+
+-- src/Layer/Timer.hs ----------------------------------------------------------
+ complete
+
+
+-- src/Layer/Udp.hs ------------------------------------------------------------
+ complete

cbits/.gitignore

@@ -0,0 +1,2 @@
+send
+receive

cbits/Makefile

@@ -0,0 +1,22 @@
+
+OBJS = tapdevice.o
+
+ifndef V
+	QUIET_CC = @echo '   ' CC $@;
+endif
+
+all : $(OBJS) send receive
+
+send : send.c
+	$(QUIET_CC)$(CC) -Wall -o $@ $<
+
+receive : receive.c
+	$(QUIET_CC)$(CC) -Wall -o $@ $<
+
+tapdevice.o : tapdevice.c
+	$(QUIET_CC)$(CC) -Wall -c -o $@ $<
+
+clean:
+	$(RM) tapdevice.o
+	$(RM) send
+	$(RM) receive

cbits/receive.c

@@ -0,0 +1,46 @@
+#include <stdio.h>
+#include <string.h>
+#include <unistd.h>
+#include <sys/socket.h>
+#include <netinet/in.h>
+#include <arpa/inet.h>
+
+int main(int argc, char **argv)
+{
+	int fd, res, len;
+	struct sockaddr_in server, client;
+	char buf[1000];
+
+	socklen_t clilen;
+
+	memset(&server, 0x0, sizeof(server));
+	server.sin_family	= AF_INET;
+	server.sin_port		= htons(40000);
+	server.sin_addr.s_addr	= htonl(INADDR_ANY);
+
+	fd = socket(AF_INET, SOCK_DGRAM, 0);
+	if(fd < 0) {
+		fprintf(stderr, "socket failed\n");
+		return 1;
+	}
+
+	res = bind(fd, (struct sockaddr *)&server, sizeof(server));
+	if(res < 0) {
+		fprintf(stderr, "bind failed\n");
+		close(fd);
+		return 1;
+	}
+
+	while(1) {
+		memset(buf, 0x0, sizeof(buf));
+		len = recvfrom(fd, buf, sizeof(buf), 0,
+				(struct sockaddr *)&client, &clilen);
+		printf("Message from: %s\n\t%s\n", inet_ntoa(client.sin_addr),
+				buf);
+		sendto(fd, buf, len, 0, (struct sockaddr *)&client, clilen);
+	}
+
+	close(fd);
+
+	return 0;
+}

cbits/send.c

@@ -0,0 +1,42 @@
+#include <stdio.h>
+#include <string.h>
+#include <sys/socket.h>
+#include <netinet/in.h>
+#include <arpa/inet.h>
+
+int main(int argc, char **argv)
+{
+	int fd, res, len;
+	struct sockaddr_in server;
+	char buf[1000] = "Hello, world.";
+
+	if(argc < 2) {
+		fprintf(stderr, "usage: %s <ip>\n", argv[0]);
+		return 1;
+	}
+
+	memset(&server, 0x0, sizeof(server));
+	server.sin_family	= AF_INET;
+	server.sin_port		= htons(40000);
+
+	res = inet_pton(AF_INET, argv[1], &server.sin_addr);
+	if(res < 0) {
+		fprintf(stderr, "Unable to parse ip\n");
+		return 1;
+	}
+
+	fd = socket(AF_INET, SOCK_DGRAM, 0);
+	if(fd < 0) {
+		fprintf(stderr, "socket failed\n");
+		return 1;
+	}
+
+	sendto(fd, buf, sizeof(buf), 0,
+			(struct sockaddr *)&server, sizeof(server));
+
+	len = recvfrom(fd, buf, sizeof(buf), 0, NULL, NULL);
+
+	printf("received: %s\n", buf);
+
+	return 0;
+}

cbits/tapdevice.c

@@ -0,0 +1,36 @@
+
+#include <string.h>
+#include <unistd.h>
+#include <fcntl.h>
+
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <sys/ioctl.h>
+#include <linux/if.h>
+#include <linux/if_tun.h>
+
+int init_tap_device(char *name) {
+	int fd, ret;
+	struct ifreq ifr;
+
+	if(name == NULL) {
+		return -1;
+	}
+
+	fd = open("/dev/net/tun", O_RDWR);
+	if(fd < 0) {
+		return -2;
+	}
+
+	memset(&ifr, 0x0, sizeof(struct ifreq));
+	ifr.ifr_flags = IFF_TAP | IFF_NO_PI;
+	strncpy(ifr.ifr_name, name, IFNAMSIZ);
+
+	ret = ioctl(fd, TUNSETIFF, (void*) &ifr);
+	if(ret != 0) {
+		close(fd);
+		return -3;
+	}
+
+	return fd;
+}

cbits/tapdevice.h

@@ -0,0 +1,6 @@
+#ifndef __TAP_DEVICE_H
+#define __TAP_DEVICE_H
+
+int init_tap_device(char *name);
+
+#endif

example/WebServer.hs

@@ -0,0 +1,153 @@
+module WebServer where
+
+import Control.Concurrent (forkIO,threadDelay)
+import Data.Time.Calendar (Day(..))
+import Data.Time.Clock (UTCTime(..),addUTCTime)
+import Data.Time.Clock.POSIX (POSIXTime,getPOSIXTime,posixSecondsToUTCTime)
+import Data.Time.Format (formatTime)
+import Hans.Layer.Tcp.Socket
+    (Socket,readLine,sendSocket,acceptSocket,listenPort,closeSocket
+    ,SocketError(..))
+import Hans.Message.Tcp (TcpPort)
+import Hans.Setup (NetworkStack(nsTcp))
+import System.Exit (exitFailure)
+import System.Locale (defaultTimeLocale)
+import qualified Control.Exception as X
+import qualified Data.ByteString as S
+
+webserver :: NetworkStack -> TcpPort -> IO ()
+webserver ns port = body `X.catch` \se -> print (se :: X.SomeException)
+  where
+  body = do
+    start <- getPOSIXTime
+    sock  <- initServer ns port
+    serverLoop start sock
+
+accept :: Socket -> IO Socket
+accept sock = loop
+  where
+  loop = X.catch (acceptSocket sock) $ \se -> do
+    case se of
+      AcceptError err -> putStrLn ("Accept error: " ++ err)
+      _               -> putStrLn ("Socket error: " ++ show se)
+    loop
+
+serverLoop :: POSIXTime -> Socket -> IO ()
+serverLoop start sock = loop
+  where
+  loop = do
+    client <- accept sock
+    _      <- forkIO (handleClient start client)
+    loop
+
+initServer :: NetworkStack -> TcpPort -> IO Socket
+initServer ns port = listenPort (nsTcp ns) port `X.catch` h
+  where
+  h ListenError{} = do
+    putStrLn ("Unable to listen on port: " ++ show port)
+    exitFailure
+  h se = do
+    print se
+    exitFailure
+
+handleClient :: POSIXTime -> Socket -> IO ()
+handleClient start client = body `X.catch` \se -> print (se :: X.SomeException)
+  where
+  body = do
+    mb <- processRequest client
+    case mb of
+      Nothing        -> closeSocket client
+      Just (url,req) -> do
+        sendSocket client =<< makeResponse start url req
+        threadDelay 1000000
+        closeSocket client
+
+processRequest :: Socket -> IO (Maybe (String,[S.ByteString]))
+processRequest sock = do
+  ls <- readRequest sock
+  case ls of
+    []   -> return Nothing
+    l:_  -> return (Just (parseUrl l, ls))
+
+crlf :: S.ByteString
+crlf  = S.pack [0x0d, 0x0a]
+
+readRequest :: Socket -> IO [S.ByteString]
+readRequest sock = loop
+  where
+  loop = do
+    line <- readLine sock
+    if line == crlf
+       then return []
+       else do
+         rest <- loop
+         return (line:rest)
+
+parseUrl :: S.ByteString -> String
+parseUrl  = head . drop 1 . words . toString
+
+fromString :: String -> S.ByteString
+fromString  = S.pack . map (toEnum . fromEnum)
+
+toString :: S.ByteString -> String
+toString  = map (toEnum . fromEnum) . S.unpack
+
+status200 :: S.ByteString
+status200  = fromString "HTTP/1.1 200 OK\r\n"
+
+contentLength :: Int -> S.ByteString
+contentLength len = fromString ("Content-Length: " ++ show len)
+
+contentType :: String -> S.ByteString
+contentType ty = fromString ("Content-Type: " ++ ty)
+
+response404 :: S.ByteString
+response404  = fromString $ concat
+  [ "HTTP/1.1 404 Not Found\r\n"
+  , "Content-Length: 0\r\n"
+  , "\r\n"
+  ]
+
+connectionClose :: S.ByteString
+connectionClose  = fromString "Connection: close"
+
+makeResponse :: POSIXTime -> String -> [S.ByteString] -> IO S.ByteString
+makeResponse start url req
+  | url == "/favicon.ico" = return response404
+  | otherwise             = do
+    uptime <- timePassed start
+    let date = posixSecondsToUTCTime start
+        body = fromString (concat
+               [ "<html><head><title>HaLVM</title></head><body>"
+               , "<h1>Welcome to the HaLVM!</h1><br />\r\n\r\n"
+               , "Started on: "
+               , formatDate date
+               , ", and up for "
+               , uptime
+               , "\r\n<h2>HTTP Request:</h2>\r\n<pre>"
+               ]) `S.append` S.concat req
+                  `S.append` fromString "</pre></body></html>"
+    return $! S.concat
+          [ status200
+          , contentLength (S.length body), crlf
+          , contentType "text/html", crlf
+          , connectionClose, crlf
+          , crlf
+          , body
+          ]
+
+formatDate :: UTCTime -> String
+formatDate  = formatTime defaultTimeLocale "%c"
+
+zeroUTCTime :: UTCTime
+zeroUTCTime  = UTCTime (ModifiedJulianDay 0) 0
+
+timePassed :: POSIXTime -> IO String
+timePassed start = do
+  now <- getPOSIXTime
+  let date@(UTCTime day _) = addUTCTime (now - start) zeroUTCTime
+  return $ concat
+    [ show (toModifiedJulianDay day)
+    , " days, "
+    , formatTime defaultTimeLocale "%k hours, %M minutes, %S seconds." date
+    ]