Use BustlePcapReader rather than 'pcap' binding

3 files changed, 134 insertions, 35 deletions

diff --git a/Bustle/Loader/Pcap.hs b/Bustle/Loader/Pcap.hs
index 88eacb3..eb0485d 100644
--- a/Bustle/Loader/Pcap.hs
+++ b/Bustle/Loader/Pcap.hs
@@ -32,17 +32,15 @@ import qualified Data.Map as Map
 import Data.Map (Map)
 import Control.Exception (try)
 import Control.Monad.State
-import System.IO.Error ( mkIOError
-                       , userErrorType
-                       )
 
-import Network.Pcap
+import System.Glib (GError)
 
 import DBus
 
 import qualified Data.ByteString as BS
 
 import qualified Bustle.Types as B
+import Bustle.Reader
 
 -- Conversions from dbus-core's types into Bustle's more stupid types. This
 -- whole section is pretty upsetting.
@@ -218,50 +216,33 @@ convert µs body =
         Left e  -> return $ Left $ unmarshalErrorMessage e
         Right m -> Right <$> bustlify µs (BS.length body) m
 
-data Result e a =
-    EOF
-  | Packet (Either e a)
-  deriving Show
-
 readOne :: (MonadState s m, MonadIO m)
-        => PcapHandle
+        => Reader
         -> (B.Microseconds -> BS.ByteString -> m (Either e a))
-        -> m (Result e a)
+        -> m (Maybe (Either e a))
 readOne p f = do
-    (hdr, body) <- liftIO $ nextBS p
-    -- No really, nextBS just returns null packets when you hit the end of the
-    -- file.
-    --
-    -- It occurs to me that we could stream by just polling this every second
-    -- or something?
-    if hdrCaptureLength hdr == 0
-        then return EOF
-        else Packet <$> f (fromIntegral (hdrTime hdr)) body
+    ret <- liftIO $ readerReadOne p
+    case ret of
+        Nothing -> return Nothing
+        Just (µsec, body) -> Just <$> f µsec body
 
 -- This shows up as the biggest thing on the heap profile. Which is kind of a
 -- surprise. It's supposedly the list.
 mapBodies :: (MonadState s m, MonadIO m)
-          => PcapHandle
+          => Reader
           -> (B.Microseconds -> BS.ByteString -> m (Either e a))
           -> m [Either e a]
 mapBodies p f = do
     ret <- readOne p f
     case ret of
-        EOF      -> return []
-        Packet x -> do
+        Nothing -> return []
+        Just x  -> do
             xs <- mapBodies p f
             return $ x:xs
 
 readPcap :: MonadIO m
          => FilePath
-         -> m (Either IOError ([String], [B.DetailedEvent]))
+         -> m (Either GError ([String], [B.DetailedEvent]))
 readPcap path = liftIO $ try $ do
-    p <- openOffline path
-    dlt <- datalink p
-    -- DLT_NULL for extremely old logs.
-    -- DLT_DBUS is missing: https://github.com/bos/pcap/pull/8
-    unless (dlt `elem` [DLT_NULL, DLT_UNKNOWN 231]) $ do
-        let message = "Incorrect link type " ++ show dlt
-        ioError $ mkIOError userErrorType message Nothing (Just path)
-
+    p <- readerOpen path
     partitionEithers <$> evalStateT (mapBodies p convert) Map.empty
diff --git a/Bustle/Reader.hs b/Bustle/Reader.hs
new file mode 100644
index 0000000..ae9a611
--- /dev/null
+++ b/Bustle/Reader.hs
@@ -0,0 +1,119 @@
+{-
+Bustle.Reader: Haskell binding for pcap-reader.c
+Copyright © 2020 Will Thompson
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 of the License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
+-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+module Bustle.Reader
+  (
+-- * Types
+    Reader
+
+-- * Methods
+  , readerOpen
+  , readerReadOne
+  , readerClose
+  , withReader
+  )
+where
+
+import Control.Exception (bracket)
+
+import Foreign.C
+import Foreign.ForeignPtr
+import Foreign.Marshal.Alloc
+import Foreign.Ptr
+import Foreign.Storable
+
+import qualified Data.ByteString as BS
+
+import System.Glib.GObject
+import System.Glib.GError
+
+import Bustle.GDBusMessage
+import Bustle.Types (Microseconds)
+
+-- Gtk2HS boilerplate
+newtype Reader = Reader { unReader :: ForeignPtr Reader }
+    deriving (Eq, Ord)
+
+mkReader :: (ForeignPtr Reader -> Reader, FinalizerPtr a)
+mkReader = (Reader, objectUnref)
+
+instance GObjectClass Reader where
+    toGObject = GObject . castForeignPtr . unReader
+    unsafeCastGObject = Reader . castForeignPtr . unGObject
+
+-- Foreign imports
+foreign import ccall "bustle_pcap_reader_open"
+    bustle_pcap_reader_open :: CString
+                            -> Ptr (Ptr ())
+                            -> IO (Ptr Reader)
+
+-- Foreign imports
+foreign import ccall "bustle_pcap_reader_read_one"
+    bustle_pcap_reader_read_one :: Ptr Reader
+                                -> Ptr CLong
+                                -> Ptr CLong
+                                -> Ptr (Ptr CChar)
+                                -> Ptr CUInt
+                                -> Ptr GDBusMessage
+                                -> Ptr (Ptr ())
+                                -> IO CInt
+
+foreign import ccall "bustle_pcap_reader_close"
+    bustle_pcap_reader_close :: Ptr Reader
+                             -> IO ()
+
+-- Throws a GError if the file can't be opened
+readerOpen :: FilePath
+           -> IO Reader
+readerOpen filename =
+    wrapNewGObject mkReader $
+      propagateGError $ \gerrorPtr ->
+        withCString filename $ \c_filename ->
+          bustle_pcap_reader_open c_filename gerrorPtr
+
+readerReadOne :: Reader
+              -> IO (Maybe (Microseconds, BS.ByteString))
+readerReadOne reader =
+    withForeignPtr (unReader reader) $ \c_reader ->
+    alloca $ \secPtr ->
+    alloca $ \usecPtr ->
+    alloca $ \blobPtrPtr ->
+    alloca $ \lengthPtr -> do
+        propagateGError $ bustle_pcap_reader_read_one c_reader secPtr usecPtr blobPtrPtr lengthPtr nullPtr
+        blob <- peek blobPtrPtr
+        if blob == nullPtr
+            then return Nothing
+            else do
+                sec <- peek secPtr
+                usec <- peek usecPtr
+                blobLength <- peek lengthPtr
+                blobBS <- BS.packCStringLen (blob, fromIntegral blobLength)
+                let µsec = fromIntegral sec * (10 ^ (6 :: Int)) + fromIntegral usec
+                return $ Just (µsec, blobBS)
+
+readerClose :: Reader
+            -> IO ()
+readerClose reader =
+    withForeignPtr (unReader reader) bustle_pcap_reader_close
+
+withReader :: FilePath
+           -> (Reader -> IO a)
+           -> IO a
+withReader filename f = do
+    bracket (readerOpen filename) readerClose f
diff --git a/bustle.cabal b/bustle.cabal
index 569ad50..7c7a921 100644
--- a/bustle.cabal
+++ b/bustle.cabal
@@ -87,6 +87,7 @@ Executable bustle
                , Bustle.Missing
                , Bustle.Monitor
                , Bustle.Noninteractive
+               , Bustle.Reader
                , Bustle.Regions
                , Bustle.Renderer
                , Bustle.StatisticsPane
@@ -113,6 +114,7 @@ Executable bustle
   C-sources: c-sources/pcap-reader.c
            , c-sources/pcap-monitor.c
   cc-options: -fPIC -g
+  extra-libraries: pcap
   pkgconfig-depends: glib-2.0 >= 2.54,
                      gio-unix-2.0
   Build-Depends: base >= 4.11 && < 5
@@ -127,7 +129,6 @@ Executable bustle
                , gtk3
                , mtl >= 2.2.1
                , pango
-               , pcap
                , process
                , text
                , time
@@ -155,7 +156,6 @@ Executable dump-messages
                , containers
                , dbus >= 0.10
                , mtl
-               , pcap
                , text
 
   if flag(hgettext)
@@ -181,7 +181,6 @@ Test-suite test-pcap-crash
                  , containers
                  , dbus >= 0.10
                  , mtl
-                 , pcap
                  , text
     if flag(hgettext)
         Build-Depends: hgettext >= 0.1.5