hans-pfq (empty) → 0.1.0.0

raw patch · 7 files changed

+275/−0 lines, 7 filesdep +basedep +bytestringdep +hanssetup-changed

Dependencies added: base, bytestring, hans, pfq

Files

CHANGES +3/−0
Hans/Device/PFq.hs +48/−0
LICENSE +28/−0
Setup.hs +2/−0
example/gal.hs +146/−0
example/test.hs +16/−0
hans-pfq.cabal +32/−0

+ CHANGES view

@@ -0,0 +1,3 @@++0.1.0.0+* Initial public version

+ Hans/Device/PFq.hs view

@@ -0,0 +1,48 @@++module Hans.Device.PFq (pfqOpen, pfqSend, pfqReceiveLoop) where++import Prelude              -- (String, IO, Bool(..), const, (.))+import Hans.Layer.Ethernet  (EthernetHandle, queueEthernet)+import Control.Monad        (void)+import Data.ByteString.Lazy (ByteString, toChunks)+import qualified Data.ByteString.Internal as B++import qualified Network.PFq as  PFq+import Network.PFq (PFqTag)++import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)++-- import Network.Pcap         (PcapHandle, openLive, loopBS, sendPacketBS)++-- | Open device with pcap, will give info about the state,+--   Unless the device is up it will throw errors later+--   Be sure to use fesh mac, otherwise all might fail.++type PFQHandle = ForeignPtr PFqTag++pfqOpen :: String -> IO PFQHandle+pfqOpen s = openLive s++openLive s = do+  dev <- PFq.open 1514 1+  withForeignPtr dev $ \ph -> do+           PFq.setPromisc ph s True+           PFq.bind       ph s 0+  -- egressBind ph s 0+  return dev++-- | send to deviece +pfqSend :: PFQHandle -> ByteString -> IO ()+pfqSend dev bs = withForeignPtr dev $ \ph ->  mapM_ (\p -> PFq.send ph p) $ toChunks bs++-- | receive from it+pfqReceiveLoop :: PFQHandle -> EthernetHandle -> IO ()+pfqReceiveLoop dev eh = withForeignPtr dev $ \ph ->  PFq.dispatch ph (wrapBS ( const . queueEthernet $ eh)) (-1)++wrapBS :: CallbackBS -> PFq.Callback+wrapBS f hdr ptr = do+  let len = PFq.hLen hdr+  bs <- B.create (fromIntegral len) $ \p -> B.memcpy p ptr (fromIntegral len)+  f hdr bs++type CallbackBS = PFq.PktHdr -> B.ByteString -> IO ()

+ LICENSE view

@@ -0,0 +1,28 @@+Copyright (c) 2015, Marcin Tolysz+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 the {organization} 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 HOLDER 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 view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ example/gal.hs view

@@ -0,0 +1,146 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Hans.Address+import Hans.DhcpClient+import Hans.Address.Mac+import Hans.Address.IP4+import Hans.NetworkStack++-- switch backends+#define PFQ++#ifdef HaLVM_HOST_OS+import Hans.Device.Xen+import Hypervisor.Console+import Hypervisor.XenStore+import XenDevice.NIC+#endif++#ifdef TAP+import Hans.Device.Tap+#endif++#ifdef PCAP+import Hans.Device.Pcap+#endif++#ifdef PFQ+import Hans.Device.PFq+#endif++import Control.Concurrent (newEmptyMVar,putMVar,takeMVar,threadDelay,forkIO+                          ,killThread,myThreadId)+import Control.Monad (forever,when)+import System.Environment (getArgs)+import qualified Data.ByteString.Lazy as L+++localAddr :: IP4+localAddr  = IP4 192 168 90 2++main :: IO ()+main  = do+  ns  <- newNetworkStack+  mac <- initEthernetDevice ns+  deviceUp ns mac+  putStrLn "Network stack running..."++  args <- getArgs+  if args == ["dhcp"]+     then do putStrLn "Discovering address"+             res <- newEmptyMVar+             dhcpDiscover ns mac (putMVar res)+             ip  <- takeMVar res+             putStrLn ("Bound to address: " ++ show ip)++             putStrLn "Looking up galois.com..."+             HostEntry { .. } <- getHostByName ns "galois.com"+             print hostAddresses++             server ns ip++     else do setAddress mac ns+             server ns localAddr++server :: NetworkStack -> IP4 -> IO ()+server ns ip = do+  sock <- listen ns ip 9001++  forever $ do+    putStrLn "Waiting..."+    conn <- accept sock+    _    <- forkIO (handleClient conn)+    return ()++handleClient :: Socket -> IO ()+handleClient conn =+  do putStrLn ("Got one: " ++ show (sockRemoteHost conn))+     loop+  where+  loop =+    do buf <- recvBytes conn 512+       if L.null buf+          then do putStrLn "Client closed connection"+                  close conn+          else do _ <- sendBytes conn buf+                  loop++message :: L.ByteString+message  = "Hello, world\n"++sleep :: Int -> IO ()+sleep s = threadDelay (s * 1000 * 1000)++setAddress :: Mac -> NetworkStack -> IO ()+setAddress mac ns = do+  addIP4Addr ns (localAddr `withMask` 24) mac 1500+  routeVia ns (IP4 0 0 0 0 `withMask` 0) (IP4 192 168 90 1)++#ifdef HaLVM_HOST_OS+initEthernetDevice :: NetworkStack -> IO Mac+initEthernetDevice ns =+  do xs <- initXenStore+     _ <- initXenConsole -- should set up putStrLn+     nics <- listNICs xs+     case nics of+       [] -> fail "No NICs found to use!"+       (macstr:_) ->+         do let mac = read macstr+            nic <- openNIC xs macstr +            addDevice ns mac (xenSend nic) (xenReceiveLoop nic)+            return mac+#endif++#ifdef TAP+dname = "tap6"+initEthernetDevice :: NetworkStack -> IO Mac+initEthernetDevice ns = do+  let mac = Mac 0x52 0x54 0x00 0x12 0x34 0x56+  Just dev <- openTapDevice dname+  addDevice ns mac (tapSend dev) (tapReceiveLoop dev)+  return mac+#endif++#ifdef PCAP+dname = "eth0"+initEthernetDevice :: NetworkStack -> IO Mac+initEthernetDevice ns = do+     let mac = Mac 0x12 0x34 0x56 0x78 0x9A 0xBC+     dev <- pcapOpen dname+     addDevice ns mac (pcapSend dev) (pcapReceiveLoop dev)+     return mac+#endif++#ifdef PFQ+dname = "eth0"+initEthernetDevice :: NetworkStack -> IO Mac+initEthernetDevice ns = do+     let mac = Mac 0x12 0x34 0x56 0x78 0x9A 0xBC+     dev <- pfqOpen dname+     addDevice ns mac (pfqSend dev) (pfqReceiveLoop dev)+     return mac+#endif

+ example/test.hs view

@@ -0,0 +1,16 @@++module Main where++import Hans.NetworkStack+import qualified Hans.Layer.Ethernet as Eth+import Hans.Device.Pcap++main :: IO ()+main = do+  ns  <- newNetworkStack+  Just (dev,nd) <- openPcap "eth0" $ Just $ Mac 1 2 3 4 5 6+  print nd+  let Just mac = (ndMAC nd)+  Eth.addEthernetDevice (nsEthernet ns) mac (pcapSend dev) (pcapReceiveLoop dev)+  Eth.startEthernetDevice (nsEthernet ns) mac+  -- and we can do whatever we could earlier

+ hans-pfq.cabal view

@@ -0,0 +1,32 @@+-- Initial dhcp.cabal generated by cabal init.  For further documentation, +-- see http://haskell.org/cabal/users-guide/+cabal-version:       >=1.10+name:                hans-pfq+version:             0.1.0.0+synopsis:            Driver for real ethernet devices for HaNS+description:         Network ethernet device for HaNS(Currently requires hans-2.4 from the github), which can tap into a real ethernet interface, all using pfq library and preform raw packet reads & writes.+                     This is a very simple. But requires: root - to be able to use PFQ, not really tested...++homepage:            https://github.com/tolysz/hans-pfq+license:             BSD3+license-file:        LICENSE+author:              Marcin Tolysz+maintainer:          tolysz@gmail.com+copyright:           ©2015 Marcin Tolysz+category:            Networking+build-type:          Simple+extra-source-files:  example/test.hs, example/gal.hs+                     CHANGES+Stability:           experimental+Source-Repository head+  type: git+  location: https://github.com/tolysz/hans-pfq+++library+  exposed-modules:     Hans.Device.PFq+  build-depends      : base >=4 && < 5+                     , hans >=2.4+                     , pfq  >=4.0+                     , bytestring+  default-language:    Haskell2010