packages feed

Scurry 0.0.1 → 0.0.2

raw patch · 25 files changed

+1482/−1 lines, 25 files

Files

Scurry.cabal view
@@ -1,5 +1,5 @@ Name:          Scurry-Version:       0.0.1+Version:       0.0.2 Category:      Network Description:   A distributed VPN system written in Haskell. License:       BSD3@@ -35,6 +35,30 @@ Build-Type:    Simple  extra-source-files: src/C/help.h+                    src/Network/Util.hs+                    src/Scurry/Types/TAP.hs+                    src/Scurry/Types/Network.hs+                    src/Scurry/Types/Console.hs+                    src/Scurry/Types/Threads.hs+                    src/Scurry/Util.hs+                    src/Scurry/Peer.hs+                    src/Scurry/KeepAlive.hs+                    src/Scurry/Comm.hs+                    src/Scurry/Network.hs+                    src/Scurry/Console.hs+                    src/Scurry/State.hs+                    src/Scurry/TapConfig.hs+                    src/Scurry/Console/Parser.hs+                    src/Scurry/Management/Config.hs+                    src/Scurry/Management/Tracker.hs+                    src/Scurry/Types.hs+                    src/Scurry/Comm/Util.hs+                    src/Scurry/Comm/SockWrite.hs+                    src/Scurry/Comm/TapWriter.hs+                    src/Scurry/Comm/SockSource.hs+                    src/Scurry/Comm/ConnectionManager.hs+                    src/Scurry/Comm/TapSource.hs+                    src/Scurry/Comm/Message.hs  executable scurry     build-depends: base >= 3.0.0.0
+ src/Network/Util.hs view
@@ -0,0 +1,17 @@+{-# OPTIONS -XForeignFunctionInterface #-}+{-# LANGUAGE CPP #-}++module Network.Util (+    htonl,+    htons,+    ntohl,+    ntohs,+) where++import Data.Word++foreign import CALLCONV unsafe "htonl" htonl :: Word32 -> Word32 +foreign import CALLCONV unsafe "htons" htons :: Word16 -> Word16 +foreign import CALLCONV unsafe "ntohl" ntohl :: Word32 -> Word32+foreign import CALLCONV unsafe "ntohs" ntohs :: Word16 -> Word16+
+ src/Scurry/Comm.hs view
@@ -0,0 +1,88 @@+module Scurry.Comm(+    prepEndPoint,+    startCom,+    module Scurry.Comm.Message,+) where++import Data.Maybe++import Control.Concurrent.STM.TChan+import Control.Concurrent.MVar+import GHC.Conc+import Network.Socket (Socket(..), Family(..), socket, SocketType(..), defaultProtocol, bindSocket, setSocketOption, SocketOption(Broadcast))+import System.IO++import Scurry.Comm.Message+import Scurry.Comm.TapSource+import Scurry.Comm.TapWriter+import Scurry.Comm.SockSource+import Scurry.Comm.SockWrite+import Scurry.KeepAlive+import Scurry.Console+import Scurry.Comm.ConnectionManager++import Scurry.Util+import Scurry.State+import Scurry.Types.Network+import Scurry.TapConfig++-- |Bind the socket to the specified socket address.+-- This specifies the network configuration we are using+-- as well.+prepEndPoint :: EndPoint -> IO Socket+prepEndPoint ep = do+    s <- socket AF_INET Datagram defaultProtocol+    bindSocket s (epToSa ep)++    -- Set the broadcast option for IP packets (4) on the socket+    setSocketOption s Broadcast 4+    return s++startCom :: (Maybe ScurryAddress, Maybe ScurryMask) -> Socket -> ScurryState -> [EndPoint] -> IO ()+startCom tapCfg sock initSS eps = do+    sr <- mkState initSS -- Initial ScurryState+    swchan <- atomically newTChan -- SockWriter Channel+    cmchan <- atomically newTChan -- Connection Manager Channel+    twchan <- atomically newTChan -- TapWriter Channel++    tap_mv <- newEmptyMVar++    case tapCfg of+         (Just a, Just m) -> putMVar tap_mv (a,m)+         _                -> putStrLn "Requesting network settings from peers..."++    swt <- forkIO $ sockWriteThread sock swchan+    sst <- forkIO $ sockSourceThread twchan sock sr swchan cmchan tap_mv+    kat <- forkIO $ threadDelay (sToMs 5) >> keepAliveThread sr swchan tap_mv+    cmt <- forkIO $ conMgrThread sr swchan cmchan eps++    labelThread swt "Socket Write Thread"+    labelThread sst "Socket Source Thread"+    labelThread kat "Keep Alive Thread"+    labelThread cmt "Connection Manager Thread"++    helper <- forkIO $ do+        -- Use readMVar to prevent emptying the box.+        (tapaddr,tapmask) <- readMVar tap_mv++        putStrLn $ "Using TAP IP of " ++ (show tapaddr) ++ " and TAP netmask of " ++ (show tapmask)++        -- Bring up tap device+        Right (tap,macaddr) <- getTapHandle tapaddr tapmask +        -- alterState sr (setMac (Just macaddr))++        updateMyMAC sr macaddr+        updateMyVPNAddr sr tapaddr+        updateNetMask sr tapmask++        twt <- forkIO $ tapWriterThread twchan tap+        tst <- forkIO $ tapSourceThread tap sr swchan+        labelThread tst "TAP Source Thread"+        labelThread twt "Tap Writer Thread"++    -- Helper thread to get me to the console while we wait for the TAP to come up.+    labelThread helper "Helper Thread"++    -- Last thread is a continuation of the main thread+    consoleThread sr swchan+
+ src/Scurry/Comm/ConnectionManager.hs view
@@ -0,0 +1,282 @@+module Scurry.Comm.ConnectionManager (+    conMgrThread,+) where++import qualified Data.Map as M+import Control.Monad+import Control.Concurrent.STM+import GHC.Conc+import Data.Time+import Data.Maybe++import Scurry.State+import Scurry.Peer+import Scurry.Util+import Scurry.Types.Threads+import Scurry.Types.Network+import Scurry.Comm.Message+import Scurry.Comm.Util++-- | Connection Manager Thread State+data CMTState = CMTState {+        kaStatus :: EPKAMap+    } deriving (Show)++-- | End Point to Keep Alive time mapping+type EPKAMap = M.Map EndPoint EPStatus++-- | The maximum number of attempts we'll try and +-- establish a connection.+maxEstablishAttempts :: Int+maxEstablishAttempts = 5++-- | The amount of time we will allow a peer to go+-- without a KeepAlive before we drop the connection.+-- In seconds.+staleConnection :: NominalDiffTime+staleConnection = 60 -- seconds++heartBeatInterval :: Int+heartBeatInterval = sToMs 5++-- | A status type that determines the state specific+-- peers are in.+--  - EPUnestablished holds the number of attempts to connect+--  - EPEstablished holds the time since the last KeepAlive+data EPStatus = EPUnestablished Int+              | EPEstablished UTCTime+    deriving (Show)++-- | An EPStatus representing a new, unestablished peer.+freshEPStatus :: EPStatus+freshEPStatus = EPUnestablished 0++-- | (M)anager (M)essage is either a (H)eart (B)eat or a (C)hannel (R)ead+data MM = HB+        | CR (EndPoint,ScurryMsg)++-- | It's like forever, but it uses >>= (bind) instead of >>+foreverB :: (Monad m) => (a -> m a) -> a -> m b+foreverB f start = f start >>= foreverB f++-- | Connection Manager Thread+conMgrThread :: StateRef -> SockWriterChan -> ConMgrChan -> [EndPoint] -> IO ()+conMgrThread sr swc cmc eps = do+    mv <- newEmptyMVar+    hb <- forkIO $ heartBeatThread mv +    cr <- forkIO $ chanReadThread mv cmc++    labelThread hb "CMT's Heart Beat Thread"+    labelThread cr "CMT's Channel Reader Thread"++    -- Impersonate the HeartBeat thread to kick things off immediately+    -- after 'manage' begins.+    putMVar mv HB++    -- Add all the tracker end points to the initial CMTState variable.+    foreverB (manage mv) (CMTState (M.fromList $ zip eps (repeat freshEPStatus)))++    where+        -- | cmts is the conMgrThread state--an internal piece+        -- of state used to keep track of things unique to the+        -- manage function below.++        manage :: MVar MM -> CMTState -> IO CMTState+        manage mv cmts = do+            mv' <- takeMVar mv+            cmts' <- case mv' of+                          HB   -> return cmts+                          CR m -> msgHandler sr swc cmts m+            cleanConnections sr cmts' >>= manageConnections sr swc++-- | The Heart Beat Thread's purpose is to wake up the Connection+-- Manager and have it check everything for sanity and make sure+-- any stale connections are cleaned out.+heartBeatThread :: MVar MM -> IO ()+heartBeatThread mv = forever $ do+    threadDelay heartBeatInterval +    putMVar mv HB++-- | The Channel Reader Thread's purpose is to pull an item off+-- from the TChan and alert the Connection Manager when an item+-- is ready for processing.+chanReadThread :: MVar MM -> ConMgrChan -> IO ()+chanReadThread mv cmc = forever $ let rd = (atomically $ readTChan cmc)+                                      pt = putMVar mv . CR+                                  in rd >>= pt+-- | Connection Cleaner:+--   - Make sure that the connections are current (not stale)+--   - Make sure that the connections are established+cleanConnections :: StateRef -> CMTState -> IO CMTState+cleanConnections sr cmts = do+    ct <- getCurrentTime++    -- 1. Grab all the EndPoints (ps')+    -- 2. Check which of them need to be removed (bad)+    -- 3. Make a map we can run a difference on (bad')+    -- 4. Make a final map with all the good peers (good)+    let ps = check_cmts ct+        bad = filter snd ps+        bad' = M.fromList $ map (\(e,_) -> (e,Nothing)) bad+        good = M.differenceWithKey (\_ _ _ -> Nothing) (kaStatus cmts) bad'++    mapM_ (delPeer sr . fst) bad+    return $ cmts { kaStatus = good }++    where+        check_cmts ct = let cs = M.toList (kaStatus cmts)+                            f (ep,eps) = (ep,hdl_eps eps ct)+                        in  map f cs++        hdl_eps e ct = case e of+                            EPUnestablished ue -> ue > maxEstablishAttempts+                            EPEstablished   es -> (ct `diffUTCTime` es) > staleConnection++-- | Connection Manager:+--   - Sends out a SJoin message if the peer hasn't been connected yet+manageConnections :: StateRef -> SockWriterChan -> CMTState -> IO CMTState+manageConnections sr swc cmts = do++    rec <- getMyRecord sr++    let l = M.toList (kaStatus cmts)+        w_chan = atomically . writeTChan swc +        m t@(ep,s) = case s of+                          -- The peer is not established, send a join request+                          (EPUnestablished x) -> do w_chan (DestSingle ep,SJoin (rec { peerEndPoint = ep }))+                                                    return (ep,EPUnestablished (x + 1))+                          -- The peer is fine, don't do anything+                          _ -> return t++    liftM ((\ x -> cmts{kaStatus = x}) . M.fromList) (mapM m l)++msgHandler :: StateRef -> SockWriterChan -> CMTState -> (EndPoint,ScurryMsg) -> IO CMTState+msgHandler sr swc cmts (ep,sm) =+    case sm of+        SKeepAlive r     -> r_SKeepAlive r+        SJoin rec        -> r_SJoin rec+        SJoinReply rec p -> r_SJoinReply rec p+        SNotifyPeer np   -> r_SNotifyPeer np+        SRequestPeer     -> r_SRequestPeer+        SLANProbe        -> r_SLANProbe+        SLANSuggest pn   -> r_SLANSuggest pn+        SAddrRequest     -> r_SAddrRequest+        -- SAddrReject      -> error "Not implemented"+        SAddrPropose _ _ -> putStrLn "Got a proposal. Why?" >> return cmts+        -- SAddrSelect a    -> error "Not implemented"++        bad -> r_bad bad++    where+        keepOld _ o = o++        r_SAddrRequest = do+            peers <- getPeers sr+            myRec <- getMyRecord sr+            mask  <- getVpnMask sr++            case isJust (peerVPNAddr myRec) of+                False -> return ()+                True -> do let peerAddrs = map (fromJust . peerVPNAddr) (filter (isJust . peerVPNAddr) peers)+                               dest = DestSingle ep+            +                           addr <- genRandAddr peerAddrs (fromJust . peerVPNAddr $ myRec) (fromJust mask)++                           putStrLn $ "Suggesting address " ++ show addr ++ " to " ++ show ep++                           atomically $ writeTChan swc (dest,SAddrPropose addr (fromJust mask))++            return cmts++            -- genRandAddr :: [ScurryAddress] -> ScurryAddress -> ScurryAddress -> IO ScurryAddress++        {-+        r_SAddrReject = do+        r_SAddrPropose a = do+        r_SAddrSelect a = do+        -}++        r_SKeepAlive r = do+            ct <- getCurrentTime+            updatePeer sr ep r+            return $ cmts { kaStatus = (M.insert ep+                                                 (EPEstablished ct)+                                                 (kaStatus cmts)) }+        +        r_SJoin rec = do+            ct <- getCurrentTime+            addPeer sr (rec { peerEndPoint = ep })+            joinReply -- Send a reply+            joinNotify -- Notify every one else of this join+            lannerCheck ep+            return $ cmts { kaStatus = M.insert ep (EPEstablished ct) (kaStatus cmts) }++        r_SJoinReply rec p = do+            ct <- getCurrentTime+            addPeer sr (rec { peerEndPoint = ep })++            let cmts' = cmts { kaStatus = M.insert ep (EPEstablished ct) (kaStatus cmts) }+                cmts'' = cmts' {+                    kaStatus = foldr (\k m -> M.insertWith keepOld k freshEPStatus m) (kaStatus cmts') p+                }+            +            lannerCheck ep++            return cmts''++        -- | Some one has informed us of a new peer. Check if we have+        -- it in our list already. +        r_SNotifyPeer np = do+            let s = kaStatus cmts+                e = M.lookup np s+            case e of+                 Nothing  -> return $ cmts {kaStatus = M.insert np freshEPStatus s}+                 (Just _) -> return cmts -- Either establishing or connected++        r_SLANProbe = return $ cmts { kaStatus = M.insertWith keepOld ep freshEPStatus (kaStatus cmts) }++        r_SLANSuggest port = do+            let bcastAddr = ScurryAddress 0xFFFFFFFF+                dest = DestSingle (EndPoint bcastAddr port)+            atomically $ writeTChan swc (dest,SLANProbe)+            return cmts++        r_SRequestPeer = do+            putStrLn "Error: SRequestPeer not supported"+            return cmts++        r_bad bad = error $ "Software Design Error: msgHandler can't use " ++ show bad++        -- | When we get a SJoin message, we add the new peer to our+        -- own peer list (if we don't have them recorded yet), inform+        -- them of our MAC address and the peers we know about, and+        -- then tell every one else we know about the new peer.+        joinReply = do+            (ScurryState {scurryPeers = peers, scurryMyRecord = myrec}) <- getState sr        +            let d = (DestSingle ep)+                e' = map peerEndPoint peers+                p' = filter (/= ep) e'+                m = SJoinReply myrec p'+            atomically $ writeTChan swc (d,m)++        -- | This alerts the other peers on our network that some one+        -- has joined us.+        joinNotify = do+            peers <- getPeers sr+            let d = (DestList $ filter (/= ep) $ map peerEndPoint peers)+                m = (SNotifyPeer ep)+            atomically $ writeTChan swc (d,m)++        -- | Check if the provided address is the same as another in+        -- our peer list (this most likely means they are on the same+        -- LAN). If we find one, we send a SLANSuggest with the +        -- corresponding port number.+        lannerCheck e@(EndPoint addr _) = do+            peers <- getPeers sr+            +            let lan = map (\(EndPoint _ p) -> p) $ filter (\e'@(EndPoint a _) -> (e' /= e) && (addr == a)) $ map peerEndPoint peers+                dst = DestSingle e+                wrt m = atomically $ writeTChan swc (dst,m)++            mapM_ wrt (map SLANSuggest lan)+
+ src/Scurry/Comm/Message.hs view
@@ -0,0 +1,69 @@+module Scurry.Comm.Message(+    ScurryMsg(..),+) where++import Control.Monad+import Data.Binary+import qualified Data.ByteString as BSS+import Data.Word++import Scurry.Types.Network+import Scurry.Peer++type PingID = Word32++-- |These are the messages we get across the network.+-- They are the management and data protocol.+data ScurryMsg = SFrame BSS.ByteString            -- | An ethernet frame.+               | SJoin PeerRecord                 -- | A network join request.+               | SJoinReply PeerRecord [EndPoint] -- | A network join reply.+               | SKeepAlive PeerRecord            -- | A keep alive message. +               | SNotifyPeer EndPoint             -- | A message to notify others of a peer.+               | SRequestPeer                     -- | A message to request peer listings on the network.+               | SPing PingID                     -- | A Ping command used for diagnostics.+               | SEcho PingID                     -- | A Echo command used to respond to the Ping command.+               | SLANProbe                        -- | A message to probe the local LAN for other members.+               | SLANSuggest ScurryPort           -- | A message to inform a peer that they may share a LAN with another.+               | SAddrRequest                     -- | A message to request an available VPN address+               -- | SAddrReject                      -- | A message to reject the address a peer has chosen+               | SAddrPropose ScurryAddress ScurryMask -- | A message to suggest an address to a peer+               -- | SAddrSelect ScurryAddress        -- | A message to inform every one we're using an address +               | SUnknown                         -- | An unknown message+    deriving (Show)++instance Binary ScurryMsg where+    get = do tag <- getWord8+             case tag of+                  0  -> liftM SFrame get          -- SFrame+                  1  -> liftM SJoin  get          -- SJoin+                  2  -> liftM2 SJoinReply get get -- SJoinReply+                  3  -> liftM SKeepAlive get      -- SKeepAlive+                  4  -> liftM SNotifyPeer get     -- SNotifyPeer+                  5  -> return SRequestPeer       -- SRequestPeer+                  6  -> liftM SPing get           -- SPing+                  7  -> liftM SEcho get           -- SEcho+                  8  -> return SLANProbe          -- SLANProbe+                  9  -> liftM SLANSuggest get     -- SLANSuggest+                  10 -> return SAddrRequest       -- SAddrRequest+                  -- 11 -> return SAddrReject        -- SAddrReject+                  12 -> liftM2 SAddrPropose get get  -- SAddrPropose+                  -- 13 -> get >>= (return . SAddrSelect)  -- SAddrSelect+                  _  -> return SUnknown           -- Unknown Message+    +    put (SFrame fp)         = putWord8 0 >> put fp+    put (SJoin m)           = putWord8 1 >> put m+    put (SJoinReply m p)    = putWord8 2 >> put m >> put p+    put (SKeepAlive r)      = putWord8 3 >> put r+    put (SNotifyPeer p)     = putWord8 4 >> put p+    put SRequestPeer        = putWord8 5+    put (SPing pp)          = putWord8 6 >> put pp+    put (SEcho pe)          = putWord8 7 >> put pe+    put SLANProbe           = putWord8 8+    put (SLANSuggest ps)    = putWord8 9 >> put ps+    put SAddrRequest        = putWord8 10+    -- put SAddrReject         = putWord8 11+    put (SAddrPropose a m)    = putWord8 12 >> put a >> put m+    -- put (SAddrSelect p)     = putWord8 13 >> put p+    put SUnknown            = putWord8 255++
+ src/Scurry/Comm/SockSource.hs view
@@ -0,0 +1,50 @@+module Scurry.Comm.SockSource (+    sockSourceThread,+) where++import Control.Monad (forever)+import Data.Binary+import System.IO+import Network.Socket.ByteString (recvFrom)+import Network.Socket (Socket)+-- import qualified Data.ByteString as BSS+import qualified Data.ByteString.Lazy as BS+import Control.Concurrent.STM.TChan+import GHC.Conc++import Scurry.Comm.Message+import Scurry.Comm.Util+import Scurry.State+import Scurry.Types.Network+import Scurry.Types.Threads++sockSourceThread :: TapWriterChan -> Socket -> StateRef -> SockWriterChan -> ConMgrChan -> (MVar (ScurryAddress, ScurryMask)) -> IO ()+sockSourceThread tap sock sr swchan cmchan tap_mv = forever $ do+    (msg,addr) <- recvFrom sock readLength++    routeInfo tap sr swchan cmchan (saToEp addr,sockDecode msg) tap_mv+    return ()++    where sockDecode = decode  . BS.fromChunks . return+    +routeInfo :: TapWriterChan -> StateRef -> SockWriterChan -> ConMgrChan -> (EndPoint,ScurryMsg) -> (MVar (ScurryAddress, ScurryMask)) -> IO ()+routeInfo tap _ swchan cmchan (srcAddr,msg) tap_mv =+    case msg of+         SFrame frame   -> atomically $ writeTChan tap frame+         SKeepAlive _   -> fwd+         SJoin _        -> fwd+         SJoinReply _ _ -> fwd+         SNotifyPeer _  -> fwd+         SRequestPeer   -> fwd+         SLANProbe      -> fwd+         SLANSuggest _  -> fwd+         SPing pid      -> sckWrtWrite (DestSingle srcAddr) (SEcho pid)+         SEcho eid      -> putStrLn $ "Echo: " ++ show eid ++ show srcAddr+         SAddrRequest   -> fwd+         -- SAddrReject    -> fwd+         SAddrPropose a m -> tryPutMVar tap_mv (a,m) >> return ()+         -- SAddrSelect _  -> fwd+         SUnknown       -> putStrLn "Error: Received an unknown message tag."+    where fwd = writeChan cmchan srcAddr msg+          sckWrtWrite = writeChan swchan+          writeChan c d m = atomically $ writeTChan c (d,m)
+ src/Scurry/Comm/SockWrite.hs view
@@ -0,0 +1,33 @@+module Scurry.Comm.SockWrite (+sockWriteThread,+sendToAddr,+) where++import Control.Concurrent.STM.TChan+import Control.Monad (forever)+import Data.Binary+import qualified Data.ByteString as BSS+import qualified Data.ByteString.Lazy as BS+import GHC.Conc+import Network.Socket hiding (send, sendTo, recv, recvFrom)+import Network.Socket.ByteString++import Scurry.Comm.Util+import Scurry.Comm.Message+import Scurry.Types.Network+import Scurry.Types.Threads++sockWriteThread :: Socket -> SockWriterChan -> IO ()+sockWriteThread sock = forever . sockWriter sock++sockWriter :: Socket -> SockWriterChan -> IO ()+sockWriter sock chan = do+    (dst,msg) <- atomically $ readTChan chan+    +    case dst of+         DestSingle addr -> sendToAddr sock msg addr >> return ()+         DestList addrs -> mapM_ (sendToAddr sock msg) addrs+++sendToAddr :: Socket -> ScurryMsg -> EndPoint -> IO Int+sendToAddr s m = sendTo s (BSS.concat . BS.toChunks $ encode m) . epToSa
+ src/Scurry/Comm/TapSource.hs view
@@ -0,0 +1,40 @@+module Scurry.Comm.TapSource(+tapSourceThread +) where++import Control.Concurrent.STM.TChan+import Control.Monad (forever)+import System.IO+import qualified Data.ByteString as BSS+import GHC.Conc+import Data.List (find)+import Data.Maybe++import Scurry.Peer+import Scurry.Comm.Message+import Scurry.Comm.Util+import Scurry.TapConfig+import Scurry.State+import Scurry.Types.TAP+import Scurry.Types.Threads+import Scurry.Types.Network++tapSourceThread :: TapDesc -> StateRef -> SockWriterChan -> IO ()+tapSourceThread tap sr chan = forever $+    read_tap tap >>= ((frameSwitch sr chan) . tapDecode)++frameSwitch :: StateRef -> SockWriterChan -> ScurryMsg -> IO ()+frameSwitch sr chan m@(SFrame bs) = do+    peers <- getPeers sr++    let (EthernetHeader dst _ _) = bsToEthHdr bs+        sendMsg dest = atomically $ writeTChan chan (DestSingle dest, m)++    case find (\pr -> (Just dst) == peerMAC pr) peers of +      Just p  -> sendMsg (peerEndPoint p)+      Nothing -> mapM_ sendMsg (map peerEndPoint peers)+frameSwitch _ _ _ = error "Unexpected ScurryMsg sent to frameSwitch."+    +tapDecode :: BSS.ByteString -> ScurryMsg+tapDecode = SFrame+
+ src/Scurry/Comm/TapWriter.hs view
@@ -0,0 +1,16 @@+module Scurry.Comm.TapWriter (+    tapWriterThread,+) where++import Control.Monad (forever)+import Control.Concurrent.STM.TChan+import GHC.Conc++import Scurry.TapConfig+import Scurry.Types.Threads+import Scurry.Types.TAP++tapWriterThread :: TapWriterChan -> TapDesc -> IO ()+tapWriterThread c tap = forever $ do+    frame <- atomically $ readTChan c+    write_tap tap frame
+ src/Scurry/Comm/Util.hs view
@@ -0,0 +1,31 @@+module Scurry.Comm.Util (+    readLength,+    DestAddr(..),+    -- debugFrame,+    bsToEthHdr,+) where++import Data.Binary+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString as BSS++import Scurry.Types.Network++readLength :: Int+readLength = 1560+++data DestAddr = DestSingle EndPoint+              | DestList [EndPoint]+    deriving (Show)++bsToEthHdr :: BSS.ByteString -> EthernetHeader+bsToEthHdr d = decode (BS.fromChunks [d])++{-+-- |Takes an ethernet frame pair and prints some debug+-- information about it.+debugFrame :: (EthernetHeader,BSS.ByteString) -> IO ()+debugFrame (h,f) = putStrLn $ concat [(show h)," => Length: ",(show $ BSS.length f)]+-}+
+ src/Scurry/Console.hs view
@@ -0,0 +1,45 @@+module Scurry.Console (+    consoleThread+) where++import Control.Concurrent.STM.TChan+import Control.Monad (forever)+import Data.List+import System.IO+import System.Exit+import qualified GHC.Conc as GC++import Scurry.Console.Parser+import Scurry.Comm.Message+import Scurry.Comm.Util+import Scurry.Types.Network+import Scurry.Types.Console+import Scurry.Types.Threads++import Scurry.State+import Scurry.Peer++-- Console command interpreter++consoleThread :: StateRef -> SockWriterChan -> IO ()+consoleThread sr chan = do+    (ScurryState {scurryPeers = peers, scurryMyRecord = rec}) <- getState sr++    mapM_ (\(PeerRecord { peerEndPoint = ep }) -> GC.atomically $ writeTChan chan (DestSingle ep,SJoin rec)) peers++    forever $ do+        ln <- getLine++        case parseConsole ln of+             (Left err) -> badCmd err+             (Right ln') -> goodCmd ln'++    where goodCmd cmd = case cmd of+                             CmdShutdown           -> exitWith ExitSuccess+                             CmdListPeers          -> getState sr >>= print+                             {- TODO: Find a way to do this... -}+                             {- (CmdNewPeer ha pn)    -> addPeer sr (Nothing, (EndPoint ha pn)) -}+                             CmdNewPeer _ _        -> putStrLn "CmdNewPeer disabled for now..."+                             (CmdRemovePeer ha pn) -> delPeer sr (EndPoint ha pn)+          badCmd err = putStrLn $ "Bad Command: " ++ show err+
+ src/Scurry/Console/Parser.hs view
@@ -0,0 +1,75 @@+module Scurry.Console.Parser (+    parseConsole+) where++import Text.Parsec+import Text.Parsec.String+import Scurry.Util+import Scurry.Types.Network+import Scurry.Types.Console++parseConsole :: String -> Either ParseError ConsoleCmd+parseConsole = parse consoleCmd "Console"++consoleCmd :: Parser ConsoleCmd+consoleCmd = try cmdShutdown   <|>+             try cmdListPeers  <|>+             try cmdNewPeer    <|>+             try cmdRemovePeer <|>+             fail "Command not recognized"++cmdShutdown :: Parser ConsoleCmd+cmdShutdown = do+    string "shutdown"+    return CmdShutdown++cmdListPeers :: Parser ConsoleCmd+cmdListPeers = do+    string "peers"+    return CmdListPeers++cmdNewPeer :: Parser ConsoleCmd+cmdNewPeer = do+    string "new"+    spaces+    (ip,port) <- ip_port_pair+    return $ CmdNewPeer ip port++cmdRemovePeer :: Parser ConsoleCmd+cmdRemovePeer = do+    string "remove"+    spaces+    (ip,port) <- ip_port_pair+    return $ CmdRemovePeer ip port++{- Mostly helper parsers that don't exist in the Parsec libary -}    +ip_port_pair :: Parser (ScurryAddress,ScurryPort)+ip_port_pair = do+    ip <- ip_str+    char ':'+    port <- many1 digit++    let ip'   = inet_addr ip+        port' = (read port :: Integer)++    if port' > 65535 || port' < 0+       then parserFail "Not a valid port."+       else case ip' of+                 (Just ip'') -> return (ip'',ScurryPort $ fromIntegral port')+                 Nothing     -> parserFail "Not an ip address."++ip_str :: Parser String+ip_str = do+    q1 <- quad+    char '.'+    q2 <- quad+    char '.'+    q3 <- quad+    char '.'+    q4 <- quad+    return $ let dot = "."+             in concat [q1,dot,q2,dot,q3,dot,q4]+    where+        quad = choice [try $ count 3 digit,+                       try $ count 2 digit,+                       try $ count 1 digit]
+ src/Scurry/KeepAlive.hs view
@@ -0,0 +1,49 @@+module Scurry.KeepAlive (+    keepAliveThread+) where++import Control.Concurrent.STM.TChan+import Control.Monad (forever)+import GHC.Conc++import Scurry.Comm.Message+import Scurry.Comm.Util++import Scurry.State+import Scurry.Peer++import Scurry.Types.Threads+import Scurry.Types.Network++import Scurry.Util++isMVarFull :: (MVar a) -> IO Bool+isMVarFull mv = do+    var <- tryTakeMVar mv+    case var of+         (Just v) -> putMVar mv v >> return True+         Nothing  -> return False+++keepAliveThread :: StateRef -> SockWriterChan -> (MVar (ScurryAddress, ScurryMask)) -> IO ()+keepAliveThread sr chan tap_mv = forever $ do+    peers <- getPeers sr+    myref <- getMyRecord sr+    mapM_ (messenger myref) peers+    threadDelay (sToMs 10)++    b <- isMVarFull tap_mv++    if b then return ()+         else mapM_ reqaddr peers++    where sendMsg dest msg = atomically $ writeTChan chan (dest,msg)+          messenger rec pr = sendMsg (DestSingle (peerEndPoint pr)) (SKeepAlive rec)+          reqaddr   pr     = sendMsg (DestSingle (peerEndPoint pr)) SAddrRequest+          +            {-+            case mac of+                 Nothing  -> do mymac <- getMAC sr+                                sendMsg (DestSingle addr) (SJoin mymac)+                 (Just _) -> sendMsg (DestSingle addr) (SKeepAlive)+                 -}
+ src/Scurry/Management/Config.hs view
@@ -0,0 +1,96 @@+module Scurry.Management.Config(+    Scurry(..),+    VpnConfig(..),+    NetworkConfig(..),+    DevIP,+    DevMask,+    EndPoint,+    load_scurry_config_file+) where++import Scurry.Util++import Text.JSON++import Scurry.Types.Network++data Scurry = Scurry VpnConfig NetworkConfig+    deriving (Show)++data VpnConfig = VpnConfig DevIP DevMask+    deriving (Show)++data NetworkConfig = NetworkConfig EndPoint+    deriving (Show)++type DevIP = ScurryAddress+type DevMask = ScurryAddress++load_scurry_config_file :: FilePath -> IO (Maybe Scurry)+load_scurry_config_file file = do f <- readFile file+                                  return $ case decode f of+                                                Ok f'   -> Just f'+                                                Error _ -> Nothing++scurry_err, vpn_err, net_err :: Result a+scurry_err = Error "Not a Scurry JSON object."+vpn_err = Error "Not a Scurry VPN Config JSON object."+net_err = Error "Not a Scurry Network Config JSON object."++instance JSON Scurry where+    readJSON (JSObject obj) = let objl = fromJSObject obj+                                  vc = lookup "vpn" objl+                                  nc = lookup "network" objl+                              in case (vc,nc) of+                                      (Just v , Just n)  -> rj v n+                                      _ -> scurry_err+        where rj v n = let (v',n') = (readJSON v, readJSON n)+                       in case (v',n') of+                               (Ok v'', Ok n'') -> Ok $ Scurry v'' n''+                               _ -> scurry_err+    readJSON _ = scurry_err++    showJSON (Scurry vc nc) = JSObject $ toJSObject [("vpn",showJSON vc),+                                                     ("network",showJSON nc)]++instance JSON VpnConfig where+    showJSON (VpnConfig ip mask) = let (Just ip')   = inet_ntoa ip+                                       (Just mask') = inet_ntoa mask+                                   in rj ip' mask'+        where rj i m = JSObject $ toJSObject [("ip",JSString $ toJSString i),+                                              ("mask",JSString $ toJSString m)]++    readJSON (JSObject obj) = let objl = fromJSObject obj+                                  ip = lookup "ip" objl+                                  mask = lookup "mask" objl+                              in case (ip,mask) of+                                      (Just i,Just m) -> rj i m+                                      _ -> vpn_err+        where rj (JSString i) (JSString m) = +                    let i' = inet_addr (fromJSString i)+                        m' = inet_addr (fromJSString m)+                    in case (i',m') of+                            (Just i'',Just m'') -> Ok $ VpnConfig i'' m''+                            _ -> vpn_err+              rj _ _ = vpn_err+    readJSON _ = vpn_err++instance JSON NetworkConfig where+    showJSON (NetworkConfig (EndPoint host (ScurryPort port))) =+        let (Just host') = inet_ntoa host+        in JSObject $ toJSObject [("host",JSString $ toJSString host'),+                                  ("port",JSRational (fromIntegral port))]+    +    readJSON (JSObject obj) = let objl = fromJSObject obj+                                  host = lookup "host" objl+                                  port = lookup "port" objl+                              in case (host,port) of+                                      (Just h,Just p) -> rj h p+                                      _ -> net_err+        where rj (JSString h) (JSRational p) =+                let h' = inet_addr $ fromJSString h+                in case h' of+                        (Just h'') -> Ok $ NetworkConfig $ EndPoint h'' (ScurryPort (truncate p))+                        Nothing -> net_err+              rj _ _ = net_err+    readJSON _ = net_err
+ src/Scurry/Management/Tracker.hs view
@@ -0,0 +1,39 @@+module Scurry.Management.Tracker where++import Text.JSON+import Scurry.Util++import Scurry.Types.Network++type Tracker = [ScurryPeer]++data ScurryPeer = ScurryPeer ScurryAddress ScurryPort+    deriving (Show)++scurry_err :: Result a+scurry_err = Error "Not a Scurry Peer JSON object."++load_tracker_file :: FilePath -> IO (Maybe Tracker)+load_tracker_file path = do f <- readFile path+                            return $ case decode f of+                                          Ok f'   -> Just f'+                                          Error _ -> Nothing++instance JSON ScurryPeer where+    readJSON (JSObject obj) = let objl = fromJSObject obj+                                  h = lookup "host" objl+                                  p = lookup "port" objl+                              in case (h,p) of+                                      (Just h',Just p') -> rj h' p'+                                      _ -> scurry_err+        where rj (JSString h) (JSRational p) = let h' = inet_addr $ fromJSString h+                                                   p' = truncate p+                                               in case h' of+                                                       (Just h'') -> Ok $ ScurryPeer h'' (ScurryPort p')+                                                       _ -> scurry_err+              rj _ _ = scurry_err+    readJSON _ = scurry_err++    showJSON (ScurryPeer ha (ScurryPort pn)) = JSObject $ toJSObject o+        where o = [("host",JSString $ toJSString $ (\(Just v) -> v) $ inet_ntoa ha),+                   ("port",(JSRational . fromIntegral) pn)]
+ src/Scurry/Network.hs view
@@ -0,0 +1,9 @@+module Scurry.Network (+    ScurryNetwork(..),+) where++import Scurry.Types.Network++data ScurryNetwork = ScurryNetwork {+    scurryMask :: Maybe ScurryMask+} deriving (Show)
+ src/Scurry/Peer.hs view
@@ -0,0 +1,37 @@+module Scurry.Peer (+    PeerRecord(..),+    VPNAddr,+    LocalPort,+) where++import Data.Binary+import Scurry.Types.Network++type VPNAddr = ScurryAddress+type LocalPort = ScurryPort++data PeerRecord = PeerRecord {+    peerMAC :: Maybe MACAddr,+    peerEndPoint :: EndPoint,+    peerVPNAddr :: Maybe VPNAddr,+    peerLocalPort :: LocalPort+} deriving (Show)++-- | Binary Instance for PeerRecord+instance Binary PeerRecord where+    get = do+        m <- get+        e <- get+        v <- get+        p <- get+        return PeerRecord {+            peerMAC = m,+            peerEndPoint = e,+            peerVPNAddr = v,+            peerLocalPort = p+        }+    put p = do+        put (peerMAC p)+        put (peerEndPoint p)+        put (peerVPNAddr p)+        put (peerLocalPort p)
+ src/Scurry/State.hs view
@@ -0,0 +1,105 @@+module Scurry.State (+    ScurryState(..),+    StateRef,+    getState,+    alterState,+    addPeer,+    delPeer,+    updatePeer,++    getPeers,+    getEndPoint,+    getVpnMask,+    getMAC,+    getLocalPort,+    getVPNAddr,+    getMyRecord,++    updateMyMAC,+    updateMyVPNAddr,+    updateNetMask,++    mkState,+) where++import Data.IORef+import Data.List+import Control.Monad+import Scurry.Types.Network+import Scurry.Network+import Scurry.Peer++newtype StateRef = StateRef (IORef ScurryState)++-- | The state of the scurry application+data ScurryState = ScurryState {+    scurryPeers :: [PeerRecord],+    scurryEndPoint :: EndPoint,+    scurryNetwork :: ScurryNetwork,+    scurryMyRecord :: PeerRecord+} deriving (Show)++mkState :: ScurryState -> IO StateRef+mkState = liftM StateRef . newIORef++getState :: StateRef -> IO ScurryState+getState (StateRef sr) = readIORef sr++alterState :: StateRef -> (ScurryState -> ScurryState) -> IO ()+alterState (StateRef sr) f = atomicModifyIORef sr (\s -> (f s, ()))++addPeer :: StateRef -> PeerRecord -> IO ()+addPeer sr pr =+    let nubber (PeerRecord { peerEndPoint = a })+               (PeerRecord { peerEndPoint = b }) = a == b+        np ps = ps { scurryPeers = nubBy nubber (pr : scurryPeers ps) }+    in alterState sr np++delPeer :: StateRef -> EndPoint -> IO ()+delPeer sr ep = +    let f = filter (\(PeerRecord { peerEndPoint = o }) -> ep /= o)+        dp s = s { scurryPeers = f (scurryPeers s) }+    in alterState sr dp++updatePeer :: StateRef -> EndPoint -> PeerRecord -> IO ()+updatePeer sr ep pr =+    let pr'  = pr { peerEndPoint = ep } -- Just make sure that we have the right End Point filled in+        f    =  (pr':) . (filter (\(PeerRecord { peerEndPoint = e }) -> ep /= e))+        up s = s { scurryPeers = f (scurryPeers s) }+    in alterState sr up++getPeers :: StateRef -> IO [PeerRecord]+getPeers = extract scurryPeers++getEndPoint :: StateRef -> IO EndPoint+getEndPoint = extract scurryEndPoint++getVpnMask :: StateRef -> IO (Maybe ScurryMask)+getVpnMask = extract (scurryMask . scurryNetwork)++getMAC :: StateRef -> IO (Maybe MACAddr)+getMAC = extract (peerMAC . scurryMyRecord)++getLocalPort :: StateRef -> IO ScurryPort+getLocalPort = extract (peerLocalPort . scurryMyRecord)++getVPNAddr :: StateRef -> IO (Maybe ScurryAddress)+getVPNAddr = extract (peerVPNAddr . scurryMyRecord)++getMyRecord :: StateRef -> IO PeerRecord+getMyRecord = extract scurryMyRecord++updateMyMAC :: StateRef -> MACAddr -> IO ()+updateMyMAC sr ma = let umm s = s { scurryMyRecord = ((scurryMyRecord s) { peerMAC = (Just ma) }) }+                    in alterState sr umm++updateMyVPNAddr :: StateRef -> ScurryAddress -> IO ()+updateMyVPNAddr sr va = let uva s = s { scurryMyRecord = ((scurryMyRecord s) { peerVPNAddr = (Just va) }) }+                        in alterState sr uva++updateNetMask :: StateRef -> ScurryMask -> IO ()+updateNetMask sr sm = let unm s = s { scurryNetwork = ((scurryNetwork s) { scurryMask = (Just sm) }) }+                      in alterState sr unm++extract :: (ScurryState -> a) -> StateRef -> IO a+extract e (StateRef sr) = liftM e (readIORef sr)
+ src/Scurry/TapConfig.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS -XForeignFunctionInterface #-}++module Scurry.TapConfig(+    getTapHandle,+    closeTapHandle,+    read_tap,+    write_tap,+) where++import Foreign.C.Types+import Foreign.C.String+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.Storable+import Foreign.Marshal.Alloc+import Foreign.Marshal.Utils+import System.IO+import qualified Data.ByteString as BSS+import qualified Data.ByteString.Internal as BSI+import qualified Data.ByteString.Unsafe as BSU++import Scurry.Types.Network+import Scurry.Types.TAP++getTapHandle :: ScurryAddress -> ScurryMask -> IO (Either CInt (TapDesc,MACAddr))+getTapHandle ip mask = open_tap ip mask++closeTapHandle :: TapDesc -> IO ()+closeTapHandle = close_tap_ffi . unsafeForeignPtrToPtr++open_tap :: ScurryAddress -> ScurryAddress -> IO (Either CInt (TapDesc,MACAddr))+open_tap (ScurryAddress addr) (ScurryAddress mask) = do+    td' <- mkTapDesc++    let ti = (TapInfo td' $ MACAddr (255,255,255,255,255,255))++    ti' <- new ti -- MALLOC \+    res <- open_tap_ffi (fromIntegral addr) (fromIntegral mask) ti'+    (TapInfo _ mac) <- peek ti'+    free ti'      -- FREE   /++    if res < 0+        then return (Left res)+        else return $ Right (td',mac)++read_tap :: TapDesc -> IO BSI.ByteString+read_tap td = do+    let len = 1560+        ptd = unsafeForeignPtrToPtr td+    bs <- BSI.create len (\_ -> return ())+    r_len <- BSU.unsafeUseAsCString bs (\x -> read_tap_ffi ptd x (fromIntegral len))+    return (BSU.unsafeTake (fromIntegral r_len) bs)++write_tap :: TapDesc -> BSI.ByteString -> IO ()+write_tap td bs = do+    let ptd = unsafeForeignPtrToPtr td+    _ <- BSU.unsafeUseAsCString bs (\x -> write_tap_ffi ptd x ((fromIntegral . BSS.length) bs))+    return ()++foreign import ccall "help.h open_tap" open_tap_ffi :: CUInt -> CUInt -> (Ptr TapInfo) -> IO CInt+foreign import ccall "help.h close_tap" close_tap_ffi :: (Ptr TapDescX) -> IO ()+foreign import ccall "help.h read_tap" read_tap_ffi :: (Ptr TapDescX) -> CString -> CInt -> IO CInt+foreign import ccall "help.h write_tap" write_tap_ffi :: (Ptr TapDescX) -> CString -> CInt -> IO CInt
+ src/Scurry/Types.hs view
@@ -0,0 +1,12 @@+module Scurry.Types(+    module Scurry.Types.Network,+    module Scurry.Types.Console,+    module Scurry.Types.TAP,+    module Scurry.Types.Threads,+) where++import Scurry.Types.Network+import Scurry.Types.Console+import Scurry.Types.TAP+import Scurry.Types.Threads+
+ src/Scurry/Types/Console.hs view
@@ -0,0 +1,13 @@+module Scurry.Types.Console (+    ConsoleCmd(..),+) where++import Scurry.Types.Network++-- | Datatype for Console commands+data ConsoleCmd = CmdShutdown+                | CmdListPeers+                | CmdNewPeer ScurryAddress ScurryPort+                | CmdRemovePeer ScurryAddress ScurryPort+    deriving (Show)+
+ src/Scurry/Types/Network.hs view
@@ -0,0 +1,123 @@+{-# OPTIONS -XGeneralizedNewtypeDeriving #-}++module Scurry.Types.Network (+    MACAddr(..),+    EthernetHeader(..),+    SrcMAC,+    DstMAC,+    EthType,+    EndPoint(..),+    ScurryAddress(..),+    ScurryMask,+    ScurryPort(..),+    epToSa,+    saToEp,+) where++import Data.Binary+import Numeric+import Network.Socket (inet_ntoa,HostAddress,PortNumber(..),SockAddr(..))+import Network.Util+import Control.Monad (liftM,liftM2)+import System.IO.Unsafe (unsafePerformIO)++-- | MAC Address (6 8-bit words)+data MACAddr = MACAddr (Word8,Word8,Word8,Word8,Word8,Word8)+    deriving (Eq,Ord)++instance Show MACAddr where+    show (MACAddr (a,b,c,d,e,f)) = let s = flip showHex ":"+                                       l = flip showHex ""+                                   in concat [s a, s b, s c,+                                              s d, s e, l f]++instance Binary MACAddr where+    get = do+        { o1 <- get ; o2 <- get ; o3 <- get +        ; o4 <- get ; o5 <- get ; o6 <- get +        ; return $ MACAddr (o1,o2,o3,o4,o5,o6) }+    put (MACAddr (o1,o2,o3,o4,o5,o6)) = do+        { put o1 ; put o2 ; put o3+        ; put o4 ; put o5 ; put o6 }++data EthernetHeader = EthernetHeader DstMAC SrcMAC EthType+type SrcMAC = MACAddr+type DstMAC = MACAddr+type EthType = Word16++instance Show EthernetHeader where+    show (EthernetHeader d s t) = concat ["{EthHdr ", (show s),+                                          " -> ", (show d),+                                          " :: 0x", (showHex t "}")]++instance Binary EthernetHeader where+    get = do+        { d <- get ; s <- get ; t <- get+        ; return $ EthernetHeader d s t }+    put (EthernetHeader d s t) = do+        { put d ; put s ; put t }++type ScurryMask = ScurryAddress++newtype ScurryAddress = ScurryAddress {+    scurryAddr :: HostAddress+} deriving (Eq,Ord)++instance Enum ScurryAddress where+    succ (ScurryAddress a) = ScurryAddress $ htonl $ ntohl a + 1+    pred (ScurryAddress a) = ScurryAddress $ htonl $ ntohl a - 1+    toEnum = ScurryAddress . htonl . fromIntegral+    fromEnum (ScurryAddress a) = fromEnum (ntohl a)++instance Show ScurryAddress where+    -- We use unsafePerformIO here to avoid referencing the+    -- version of inet_ntoa in Scurry.Util since this would+    -- cause a cycle. TODO: Fix this later.+    show (ScurryAddress ha) = unsafePerformIO $ inet_ntoa ha++newtype ScurryPort = ScurryPort PortNumber+    deriving (Eq,Ord)++instance Show ScurryPort where+    show (ScurryPort pn) = show pn++data EndPoint = EndPoint ScurryAddress ScurryPort+    deriving (Show,Eq,Ord)++epToSa :: EndPoint -> SockAddr+epToSa (EndPoint (ScurryAddress ha) (ScurryPort pn)) = SockAddrInet pn ha ++saToEp :: SockAddr -> EndPoint+saToEp (SockAddrInet pn ha) = EndPoint (ScurryAddress ha) (ScurryPort pn)+saToEp _ = error "ERROR: Only IPV4 addresses are supported for now."++instance Binary ScurryPort where+    get = liftM (ScurryPort . PortNum) get+    put (ScurryPort (PortNum p)) = put p++instance Binary ScurryAddress where+    get = liftM ScurryAddress get+    put (ScurryAddress ha) = put ha++instance Binary EndPoint where+    get = do tag <- getWord8+             case tag of+                  0 -> liftM2 EndPoint get get+                  -- 1 -> liftM4 SockAddrInet6 get get get get -- #Job removed, not compatable with windows+                  -- 2 -> liftM SockAddrUnix get+                  _ -> error "Not a EndPoint"+    put (EndPoint sa sp) =+        do putWord8 0+           put sa+           put sp+    -- #Job - removed, not compatable with windows+    -- put (SockAddrInet6 pn fi ha si) =+        -- do putWord8 1+           -- put pn+           -- put fi+           -- put ha+           -- put si+    -- put (SockAddrUnix s) =+        -- do putWord8 2+           -- put s+
+ src/Scurry/Types/TAP.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS -XEmptyDataDecls #-}+module Scurry.Types.TAP (+    TapDesc,+    TapDescX,+    TapInfo(..),+    mkTapDesc,+) where++import Data.Binary+import Foreign.Storable+import Foreign.ForeignPtr+import Foreign.Ptr+import Scurry.Types.Network++-- | A TAP device descriptor. Since the C representation isn't uniform across+-- the different platforms we're trying to support, we're going to pull some+-- trickery with C unions. What the TapDesc type is going to do is hold a+-- pointer to the memory defining this struct. The TapDesc is passed to the+-- read/write/close calls to operate on the TAP device.+data TapDescX+type TapDesc = ForeignPtr TapDescX++instance Storable TapDescX where+    sizeOf    _ = 32+    alignment _ = 4+    peek _ = error "NONONO! NO CAN HAZ PEEK!!"+    poke _ = error "NONONO! NO CAN HAZ POKE!!"++mkTapDesc :: IO TapDesc+mkTapDesc = mallocForeignPtr++-- | TapInfo type. Holds information about a TAP device which is retreived+-- from the C bits of the applicatoin.+data TapInfo = TapInfo TapDesc MACAddr+    deriving (Show)++ptrSize :: Int+ptrSize = sizeOf (undefined :: Ptr ())++-- | Storable instance for TapInfo+instance Storable TapInfo where+    sizeOf _    = 8 + ptrSize+    alignment _ = 4+    peek a = do+        w1 <- peekByteOff a (ptrSize + 0)+        w2 <- peekByteOff a (ptrSize + 1)+        w3 <- peekByteOff a (ptrSize + 2)+        w4 <- peekByteOff a (ptrSize + 3)+        w5 <- peekByteOff a (ptrSize + 4)+        w6 <- peekByteOff a (ptrSize + 5)+        return $ TapInfo undefined (MACAddr (w1,w2,w3,w4,w5,w6))++    poke a (TapInfo td (MACAddr (w1,w2,w3,w4,w5,w6))) = do+        pokeByteOff a 0 (unsafeForeignPtrToPtr td)+        pokeByteOff a (ptrSize + 0) w1+        pokeByteOff a (ptrSize + 1) w2+        pokeByteOff a (ptrSize + 2) w3+        pokeByteOff a (ptrSize + 3) w4+        pokeByteOff a (ptrSize + 4) w5+        pokeByteOff a (ptrSize + 5) w6+        pokeByteOff a (ptrSize + 6) (0 :: Word8)+        pokeByteOff a (ptrSize + 7) (0 :: Word8)+
+ src/Scurry/Types/Threads.hs view
@@ -0,0 +1,16 @@+module Scurry.Types.Threads (+    SockWriterChan,+    ConMgrChan,+    TapWriterChan,+) where++import qualified Data.ByteString as BSS+import Control.Concurrent.STM.TChan++import Scurry.Comm.Util+import Scurry.Comm.Message+import Scurry.Types.Network++type SockWriterChan = TChan (DestAddr,ScurryMsg)+type ConMgrChan = TChan (EndPoint,ScurryMsg)+type TapWriterChan = TChan BSS.ByteString
+ src/Scurry/Util.hs view
@@ -0,0 +1,86 @@++module Scurry.Util(+    catch_to_maybe,+    inet_addr,+    inet_ntoa,+    sToMs,+    networkLowAddress,+    networkHighAddress,+    enumAllInMask,+    genRandAddr,+    isInMask,+) where++import qualified Network.Socket as INET (inet_addr,inet_ntoa)++import Data.Time+import Control.Monad+import System.Random+import System.IO.Unsafe (unsafePerformIO)++import Scurry.Types.Network+import Data.Bits++import Network.Util++{- I really don't like that inet_addr/inet_ntoa need to+ - run in IO. I also don't like how they throw errors+ - around instead of Nothing. I've fixed both problems! -}+catch_to_maybe :: (t -> IO a) -> t -> IO (Maybe a)+catch_to_maybe f a = catch (liftM Just (f a)) (\_ -> return Nothing)++inet_addr :: String -> Maybe ScurryAddress+inet_addr = unsafePerformIO .+              catch_to_maybe (\v -> liftM ScurryAddress (INET.inet_addr v))++inet_ntoa :: ScurryAddress -> Maybe String+inet_ntoa (ScurryAddress a) = unsafePerformIO $ catch_to_maybe INET.inet_ntoa a++-- | Seconds to milliseconds+sToMs :: Int -> Int+sToMs = (* 1000000)++genRandAddr :: [ScurryAddress] -> ScurryAddress -> ScurryAddress -> IO ScurryAddress+genRandAddr without mask net = do+    ct <- getCurrentTime++    let seed = 1000000000 * diffUTCTime ct (UTCTime (ModifiedJulianDay 0) 0)+        gen = mkStdGen $ round seed++    let (r,_) = randomR (0,100) gen+        a = (!! r) $ filter (not . flip elem without) $ enumAllInMask mask net++    return a+    ++-- | Network utility functions++isInMask :: ScurryMask -> ScurryAddress -> ScurryAddress -> Bool+isInMask mask net addr = let m = scurryAddr mask+                             n = m .&. scurryAddr net+                             a = scurryAddr addr+                         in n == a+enumAllInMask :: ScurryMask -> ScurryAddress -> [ScurryAddress]+enumAllInMask mask net = let l = networkLowAddress mask net+                             h = networkHighAddress mask net+                         in eh l h+    where eh l' h' = if l' == h'+                        then h' : []+                        else l' : (eh (incrementAddress l') h')++incrementAddress :: ScurryAddress -> ScurryAddress+incrementAddress a = let a' = (ntohl . scurryAddr) a+                     in ScurryAddress $ htonl (a' + 1)++networkLowAddress :: ScurryMask -> ScurryAddress -> ScurryAddress+networkLowAddress mask addr = let a = (ntohl . scurryAddr) addr+                                  m = (ntohl . scurryAddr) mask+                                  n = a .&. m+                              in ScurryAddress $ htonl (n + 1)++networkHighAddress :: ScurryMask -> ScurryAddress -> ScurryAddress+networkHighAddress mask addr = let m = (ntohl . scurryAddr) mask+                                   a = (ntohl . scurryAddr) addr+                                   c = complement m+                                   n = (m .&. a) + c+                               in ScurryAddress $ htonl (n - 1) -- Highest address is broadcast