Pcap.hs

{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses #-}
{-
Bustle.Loader.Pcap: loads logs out of pcap files
Copyright © 2011–2012 Collabora Ltd.
Copyright © 2017–2018 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 PatternGuards, FlexibleContexts #-}
module Bustle.Loader.Pcap
  ( readPcap

  , convert
  )
where

import Data.Maybe (fromMaybe)
import Data.Either (partitionEithers)
import qualified Data.Map as Map
import Data.Map (Map)
import Control.Exception (try)
import Control.Monad.State
import Control.Monad.Trans.Maybe

import System.Glib (GError)

import qualified Bustle.Types as B
import Bustle.GDBusMessage
import Bustle.Reader

-- Conversions from dbus-core's types into Bustle's more stupid types. This
-- whole section is pretty upsetting.
stupifyBusName :: BusName
               -> B.TaggedBusName
stupifyBusName n
    | isUnique n = B.U $ B.UniqueName n
    | otherwise  = B.O $ B.OtherName n

isUnique :: BusName -> Bool
isUnique n = head (formatBusName n) == ':'

convertBusName :: String
               -> Maybe BusName
               -> B.TaggedBusName
convertBusName fallback n =
    stupifyBusName (fromMaybe fallback_ n)
  where
    fallback_ = busName_ fallback

convertMember :: MonadIO m
              => GDBusMessage
              -> m B.Member
convertMember m = liftIO $ do
    p <- fromMaybe (objectPath_ "") <$> messagePath m
    i <- messageInterface m
    member <- fromMaybe (memberName_ "") <$> messageMember m
    return $ B.Member p i member


type PendingMessages = Map (Maybe BusName, Serial)
                           (B.Detailed B.Message)

popMatchingCall :: (MonadState PendingMessages m)
                => Maybe BusName
                -> Serial
                -> m (Maybe (B.Detailed B.Message))
popMatchingCall name serial = do
    ret <- tryPop (name, serial)
    case (ret, name) of
        -- If we don't get an answer, but we know a destination, this may be
        -- because we didn't know the sender's bus name because it was the
        -- logger itself. So try looking up pending replies whose sender is
        -- Nothing.
        (Nothing, Just _) -> tryPop (Nothing, serial)
        _                 -> return ret
  where
    tryPop key = do
        call <- gets $ Map.lookup key
        modify $ Map.delete key
        return call

insertPending :: MonadState PendingMessages m
              => Maybe BusName
              -> Serial
              -> B.Detailed B.Message
              -> m ()
insertPending n s b = modify $ Map.insert (n, s) b

isNOC :: MonadIO m
      => Maybe BusName
      -> GDBusMessage
      -> m (Maybe (BusName, Maybe BusName, Maybe BusName))
isNOC maybeSender message = liftIO $ runMaybeT $ do
    sender <- MaybeT . return $ maybeSender
    guard (sender == B.dbusName)
    type_ <- liftIO $ messageType message
    guard (type_ == MessageTypeSignal)
    iface <- MaybeT $ messageInterface message
    guard (iface == B.dbusInterface)
    member <- MaybeT $ messageMember message
    guard (formatMemberName member == "NameOwnerChanged")
    n <- MaybeT $ messageGetBodyString message 0
    old <- MaybeT $ messageGetBodyString message 1
    new <- MaybeT $ messageGetBodyString message 2
    return (busName_ n, asBusName old, asBusName new)
  where
    asBusName "" = Nothing
    asBusName name = Just $ busName_ name

bustlifyNOC :: (BusName, Maybe BusName, Maybe BusName)
            -> B.NOC
bustlifyNOC ns@(name, oldOwner, newOwner)
    | isUnique name =
          case (oldOwner, newOwner) of
              (Nothing, Just _) -> B.Connected (uniquify name)
              (Just _, Nothing) -> B.Disconnected (uniquify name)
              _                 -> error $ "wtf: NOC" ++ show ns
    | otherwise = B.NameChanged (otherify name) $
          case (oldOwner, newOwner) of
              (Just old, Nothing)  -> B.Released (uniquify old)
              (Just old, Just new) -> B.Stolen (uniquify old) (uniquify new)
              (Nothing, Just new)  -> B.Claimed (uniquify new)
              (Nothing, Nothing)   -> error $ "wtf: NOC" ++ show ns
  where
    uniquify = B.UniqueName
    otherify = B.OtherName

tryBustlifyGetNameOwnerReply :: MonadIO m
                             => Maybe (B.Detailed a)
                             -> GDBusMessage
                             -> m (Maybe B.NOC)
tryBustlifyGetNameOwnerReply maybeCall reply = liftIO $ runMaybeT $ do
    -- FIXME: obviously this should be more robust:
    --  • check that the service really is the bus daemon
    --  • don't crash if the body of the call or reply doesn't contain one bus name.
    call <- MaybeT . return $ B.deReceivedMessage <$> maybeCall
    member <- MaybeT $ messageMember call
    guard (formatMemberName member == "GetNameOwner")
    ownedName <- MaybeT $ messageGetBodyString call 0
    owner <- MaybeT $ messageGetBodyString reply 0
    return $ bustlifyNOC ( busName_ ownedName
                         , Nothing
                         , Just $ busName_ owner
                         )

bustlify :: (MonadIO m, MonadState PendingMessages m)
         => B.Microseconds
         -> Int
         -> GDBusMessage
         -> m B.DetailedEvent
bustlify µs bytes m = do
    sender <- liftIO $ messageSender m
    -- FIXME: can we do away with the un-Maybe-ing and just push that Nothing
    -- means 'the monitor' downwards? Or skip the message if sender is Nothing.
    let wrappedSender = convertBusName "sen.der" sender
    serial <- liftIO $ messageSerial m
    replySerial <- liftIO $ messageReplySerial m
    destination <- liftIO $ messageDestination m

    let detailed x = B.Detailed µs x bytes m
    type_ <- liftIO $ messageType m
    detailed <$> case type_ of
        MessageTypeMethodCall -> do
            member <- convertMember m
            let call = B.MethodCall
                             { B.serial = serial
                             , B.sender = wrappedSender
                             , B.destination = convertBusName "method.call.destination" destination
                             , B.member = member
                             }
            insertPending sender serial (detailed call)
            return $ B.MessageEvent call

        MessageTypeMethodReturn -> do
            call <- popMatchingCall destination replySerial
            noc_ <- tryBustlifyGetNameOwnerReply call m
            return $ case noc_ of
                Just noc -> B.NOCEvent noc
                Nothing  -> B.MessageEvent $ B.MethodReturn
                               { B.inReplyTo = call
                               , B.sender = wrappedSender
                               , B.destination = convertBusName "method.return.destination" destination
                               }

        MessageTypeError -> do
            call <- popMatchingCall destination replySerial
            return $ B.MessageEvent $ B.Error
                        { B.inReplyTo = call
                        , B.sender = wrappedSender
                        , B.destination = convertBusName "method.error.destination" destination
                        }

        MessageTypeSignal -> do
            names_ <- isNOC sender m
            member <- convertMember m
            return $ case names_ of
                Just names -> B.NOCEvent $ bustlifyNOC names
                Nothing    -> B.MessageEvent $
                    B.Signal { B.sender = wrappedSender
                             , B.member = member
                             , B.signalDestination = stupifyBusName <$> destination
                             }

        _ -> error "woah there! someone added a new message type."

convert :: (MonadIO m, MonadState PendingMessages m)
        => B.Microseconds
        -> Int
        -> GDBusMessage
        -> m (Either String B.DetailedEvent)
convert µs bytes message = Right <$> bustlify µs bytes message

readOne :: (MonadState s m, MonadIO m)
        => Reader
        -> (B.Microseconds -> Int -> GDBusMessage -> m (Either e a))
        -> m (Maybe (Either e a))
readOne p f = do
    ret <- liftIO $ readerReadOne p
    case ret of
        Nothing -> return Nothing
        Just (µsec, bytes, body) -> Just <$> f µsec bytes 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)
          => Reader
          -> (B.Microseconds -> Int -> GDBusMessage -> m (Either e a))
          -> m [Either e a]
mapBodies p f = do
    ret <- readOne p f
    case ret of
        Nothing -> return []
        Just x  -> do
            xs <- mapBodies p f
            return $ x:xs

readPcap :: MonadIO m
         => FilePath
         -> m (Either GError ([String], [B.DetailedEvent]))
readPcap path = liftIO $ try $ do
    p <- readerOpen path
    partitionEithers <$> evalStateT (mapBodies p convert) Map.empty