diff options
Diffstat (limited to 'Bustle/Loader/Pcap.hs')
| -rw-r--r-- | Bustle/Loader/Pcap.hs | 104 |
1 files changed, 56 insertions, 48 deletions
diff --git a/Bustle/Loader/Pcap.hs b/Bustle/Loader/Pcap.hs index a10ee85..e82ea82 100644 --- a/Bustle/Loader/Pcap.hs +++ b/Bustle/Loader/Pcap.hs @@ -34,8 +34,6 @@ import Control.Exception (try) import Control.Monad.State import Control.Monad.Trans.Maybe -import System.IO.Unsafe (unsafePerformIO) - import System.Glib (GError) import qualified Bustle.Types as B @@ -61,12 +59,15 @@ convertBusName fallback n = where fallback_ = busName_ fallback -convertMember :: GDBusMessage - -> B.Member -convertMember m = - B.Member (fromMaybe (objectPath_ "") $ messagePath m) - (messageInterface m) - (fromMaybe (memberName_ "") $ messageMember m) +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) @@ -97,16 +98,19 @@ insertPending :: MonadState PendingMessages m -> m () insertPending n s b = modify $ Map.insert (n, s) b --- FIXME: IO -isNOC :: Maybe BusName -> GDBusMessage -> Maybe (BusName, Maybe BusName, Maybe BusName) -isNOC maybeSender message = unsafePerformIO $ runMaybeT $ do +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) - guard (messageType message == MessageTypeSignal) - iface <- MaybeT . return $ messageInterface message + type_ <- liftIO $ messageType message + guard (type_ == MessageTypeSignal) + iface <- MaybeT $ messageInterface message guard (iface == B.dbusInterface) - member <- MaybeT . return $ formatMemberName <$> messageMember message - guard (member == "NameOwnerChanged") + member <- MaybeT $ messageMember message + guard (formatMemberName member == "NameOwnerChanged") n <- MaybeT $ messageGetBodyString message 0 old <- MaybeT $ messageGetBodyString message 1 new <- MaybeT $ messageGetBodyString message 2 @@ -133,16 +137,16 @@ bustlifyNOC ns@(name, oldOwner, newOwner) uniquify = B.UniqueName otherify = B.OtherName --- FIXME: IO -tryBustlifyGetNameOwnerReply :: Maybe (B.Detailed a) +tryBustlifyGetNameOwnerReply :: MonadIO m + => Maybe (B.Detailed a) -> GDBusMessage - -> Maybe B.NOC -tryBustlifyGetNameOwnerReply maybeCall reply = unsafePerformIO $ runMaybeT $ do + -> 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 . return $ messageMember call + member <- MaybeT $ messageMember call guard (formatMemberName member == "GetNameOwner") ownedName <- MaybeT $ messageGetBodyString call 0 owner <- MaybeT $ messageGetBodyString reply 0 @@ -151,63 +155,67 @@ tryBustlifyGetNameOwnerReply maybeCall reply = unsafePerformIO $ runMaybeT $ do , Just $ busName_ owner ) -bustlify :: MonadState PendingMessages m +bustlify :: (MonadIO m, MonadState PendingMessages m) => B.Microseconds -> Int -> GDBusMessage -> m B.DetailedEvent bustlify µs bytes m = do - bm <- buildBustledMessage - return $ B.Detailed µs bm bytes m - where - sender = messageSender m + 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. - wrappedSender = convertBusName "sen.der" sender - - buildBustledMessage = case messageType m of + 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 = messageSerial m + { B.serial = serial , B.sender = wrappedSender - , B.destination = convertBusName "method.call.destination" $ messageDestination m - , B.member = convertMember m + , B.destination = convertBusName "method.call.destination" destination + , B.member = member } - -- FIXME: we shouldn't need to construct almost the same thing here - -- and 10 lines above maybe? - insertPending sender (messageSerial m) (B.Detailed µs call bytes m) + insertPending sender serial (detailed call) return $ B.MessageEvent call MessageTypeMethodReturn -> do - call <- popMatchingCall (messageDestination m) (messageReplySerial m) - - return $ case tryBustlifyGetNameOwnerReply call m of + 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" $ messageDestination m + , B.destination = convertBusName "method.return.destination" destination } MessageTypeError -> do - call <- popMatchingCall (messageDestination m) (messageReplySerial m) + call <- popMatchingCall destination replySerial return $ B.MessageEvent $ B.Error { B.inReplyTo = call , B.sender = wrappedSender - , B.destination = convertBusName "method.error.destination" $ messageDestination m + , B.destination = convertBusName "method.error.destination" destination } - MessageTypeSignal - | Just names <- isNOC sender m -> return $ B.NOCEvent $ bustlifyNOC names - | otherwise -> return $ B.MessageEvent $ - B.Signal { B.sender = wrappedSender - , B.member = convertMember m - , B.signalDestination = stupifyBusName <$> messageDestination m - } + 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 :: MonadState PendingMessages m +convert :: (MonadIO m, MonadState PendingMessages m) => B.Microseconds -> Int -> GDBusMessage |