Move timestamps out into DetailedMessage

This cuts down on repetition dramatically, but was remarkably invasive.

2 files changed, 64 insertions, 51 deletions

diff --git a/Bustle/Loader/OldSkool.hs b/Bustle/Loader/OldSkool.hs
index 6f9d576..945b883 100644
--- a/Bustle/Loader/OldSkool.hs
+++ b/Bustle/Loader/OldSkool.hs
@@ -37,7 +37,7 @@ infixl 4 <*>
 (<*>) :: Monad m => m (a -> b) -> m a -> m b
 (<*>) = ap
 
-type Parser a = GenParser Char (Map (BusName, Serial) Message) a
+type Parser a = GenParser Char (Map (BusName, Serial) DetailedMessage) a
 
 t :: Parser Char
 t = char '\t'
@@ -89,10 +89,12 @@ entireMember = do
     Member <$> p <* t <*> i <* t <*> m
   <?> "member"
 
-addPendingCall :: Message -> Parser ()
-addPendingCall m = updateState $ Map.insert (sender m, serial m) m
+addPendingCall :: DetailedMessage -> Parser ()
+addPendingCall dm = updateState $ Map.insert (sender m, serial m) dm
+  where
+    m = dmMessage dm
 
-findPendingCall :: BusName -> Serial -> Parser (Maybe Message)
+findPendingCall :: BusName -> Serial -> Parser (Maybe DetailedMessage)
 findPendingCall dest s = do
     pending <- getState
     let key = (dest, s)
@@ -100,19 +102,22 @@ findPendingCall dest s = do
     when (isJust ret) $ updateState (Map.delete key)
     return ret
 
-methodCall :: Parser Message
+methodCall :: Parser DetailedMessage
 methodCall = do
     char 'c'
     t
-    m <- MethodCall <$> parseTimestamp <* t <*> parseSerial <* t
+    µs <- parseTimestamp
+    t
+    m <- MethodCall <$> parseSerial <* t
                     <*> parseBusName <* t <*> parseBusName <* t <*> entireMember
-    addPendingCall m
-    return m
+    let dm = DetailedMessage µs m Nothing
+    addPendingCall dm
+    return dm
   <?> "method call"
 
 parseReturnOrError :: String
-                   -> (Microseconds -> Maybe Message -> BusName -> BusName -> Message)
-                   -> Parser Message
+                   -> (Maybe DetailedMessage -> BusName -> BusName -> Message)
+                   -> Parser DetailedMessage
 parseReturnOrError prefix constructor = do
     string prefix <* t
     ts <- parseTimestamp <* t
@@ -124,25 +129,30 @@ parseReturnOrError prefix constructor = do
     -- If we can see a call, use its sender and destination as the destination
     -- and sender for the reply. This might prove unnecessary in the event of
     -- moving the name collapsing into the UI.
-    let (s', d') = case call of Just call_ -> (destination call_, sender call_)
-                                Nothing    -> (s, d)
-    return $ constructor ts call s' d'
+    let (s', d') = case call of
+            Just (DetailedMessage _ m _) -> (destination m, sender m)
+            Nothing                      -> (s, d)
+        message = constructor call s' d'
+    return $ DetailedMessage ts message Nothing
  <?> "method return or error"
 
-methodReturn, parseError :: Parser Message
+methodReturn, parseError :: Parser DetailedMessage
 methodReturn = parseReturnOrError "r" MethodReturn <?> "method return"
 parseError = parseReturnOrError "err" Error <?> "error"
 
-signal :: Parser Message
+signal :: Parser DetailedMessage
 signal = do
     string "sig"
     t
+    µs <- parseTimestamp
+    t
     -- Ignore serial
-    Signal <$> parseTimestamp <* t <*> (parseSerial >> t >> parseBusName) <* t
-           <*> entireMember
+    m <- Signal <$> (parseSerial >> t >> parseBusName) <* t
+                <*> entireMember
+    return $ DetailedMessage µs m Nothing
   <?> "signal"
 
-method :: Parser Message
+method :: Parser DetailedMessage
 method = char 'm' >> (methodCall <|> methodReturn)
   <?> "method call or return"
 
@@ -161,7 +171,7 @@ atLeastOne :: OtherName -> Parser a
 atLeastOne n = fail ""
   <?> unOtherName n ++ " to gain or lose an owner"
 
-nameOwnerChanged :: Parser Message
+nameOwnerChanged :: Parser DetailedMessage
 nameOwnerChanged = do
     string "nameownerchanged"
     t
@@ -169,6 +179,12 @@ nameOwnerChanged = do
     t
     n <- parseBusName
     t
+    m <- parseNOCDetails n
+    return $ DetailedMessage ts m Nothing
+
+parseNOCDetails :: BusName
+                -> Parser Message
+parseNOCDetails n =
     case n of
         U u -> do
             old <- perhaps parseUniqueName
@@ -177,12 +193,12 @@ nameOwnerChanged = do
                     t
                     u' <- parseUniqueName
                     sameUnique u u'
-                    return $ Connected ts u
+                    return $ Connected u
                 Just u' -> do
                     sameUnique u u'
                     t
                     noName
-                    return $ Disconnected ts u
+                    return $ Disconnected u
         O o -> do
             old <- perhaps parseUniqueName
             t
@@ -192,15 +208,15 @@ nameOwnerChanged = do
                 (Just  a, Nothing) -> return $ Released a
                 (Nothing, Just  b) -> return $ Claimed b
                 (Just  a, Just  b) -> return $ Stolen a b
-            return $ NameChanged ts o c
+            return $ NameChanged o c
 
-event :: Parser Message
+event :: Parser DetailedMessage
 event = method <|> signal <|> nameOwnerChanged <|> parseError
 
-events :: Parser [Message]
+events :: Parser [DetailedMessage]
 events = sepEndBy event (char '\n') <* eof
 
-readLog :: String -> Either ParseError [Message]
+readLog :: String -> Either ParseError [DetailedMessage]
 readLog filename = runParser events Map.empty "" filename
 
 -- vim: sw=2 sts=2
diff --git a/Bustle/Loader/Pcap.hs b/Bustle/Loader/Pcap.hs
index dc27193..5b8f04e 100644
--- a/Bustle/Loader/Pcap.hs
+++ b/Bustle/Loader/Pcap.hs
@@ -48,11 +48,11 @@ convertMember getObjectPath getInterfaceName getMemberName m =
              (fmap (T.unpack . strInterfaceName) . getInterfaceName $ m)
              (T.unpack . strMemberName . getMemberName $ m)
 
-type PendingMessages = Map (Maybe BusName, Serial) (MethodCall, B.Message)
+type PendingMessages = Map (Maybe BusName, Serial) (MethodCall, B.DetailedMessage)
 
 popMatchingCall :: Maybe BusName
                 -> Serial
-                -> State PendingMessages (Maybe (MethodCall, B.Message))
+                -> State PendingMessages (Maybe (MethodCall, B.DetailedMessage))
 popMatchingCall name serial = do
     ret <- tryPop (name, serial)
     case (ret, name) of
@@ -68,7 +68,7 @@ popMatchingCall name serial = do
         modify $ Map.delete key
         return call
 
-insertPending :: Maybe BusName -> Serial -> MethodCall -> B.Message -> State PendingMessages ()
+insertPending :: Maybe BusName -> Serial -> MethodCall -> B.DetailedMessage -> State PendingMessages ()
 insertPending n s rawCall b = modify $ Map.insert (n, s) (rawCall, b)
 
 isNOC :: Maybe BusName -> Signal -> Maybe (BusName, Maybe BusName, Maybe BusName)
@@ -88,16 +88,15 @@ isNOC (Just sender) s | looksLikeNOC =
 isNOC _ _ = Nothing
 
 
-bustlifyNOC :: B.Microseconds
-            -> (BusName, Maybe BusName, Maybe BusName)
+bustlifyNOC :: (BusName, Maybe BusName, Maybe BusName)
             -> B.Message
-bustlifyNOC µs ns@(name, oldOwner, newOwner)
+bustlifyNOC ns@(name, oldOwner, newOwner)
     | isUnique name =
           case (oldOwner, newOwner) of
-              (Just _, Nothing) -> B.Connected µs (uniquify name)
-              (Nothing, Just _) -> B.Disconnected µs (uniquify name)
+              (Just _, Nothing) -> B.Connected (uniquify name)
+              (Nothing, Just _) -> B.Disconnected (uniquify name)
               _                 -> error $ "wtf: NOC" ++ show ns
-    | otherwise = B.NameChanged µs (otherify name) $
+    | 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)
@@ -115,37 +114,37 @@ bustlify :: B.Microseconds
          -> State PendingMessages B.DetailedMessage
 bustlify µs m = do
     bm <- buildBustledMessage
-    return $ B.DetailedMessage bm (Just m)
+    return $ B.DetailedMessage µs bm (Just m)
   where
     buildBustledMessage = case m of
         (ReceivedMethodCall serial sender mc) -> do
             let call = B.MethodCall
-                             { B.timestamp = µs
-                             , B.serial = serialValue serial
+                             { B.serial = serialValue serial
                              -- sender may be empty if it's us who sent it
                              , B.sender = convertBusName "method.call.sender" sender
                              , B.destination = convertBusName "method.call.destination" $ methodCallDestination mc
                              , B.member = convertMember methodCallPath methodCallInterface methodCallMember mc
                              }
-            insertPending sender serial mc call
+            -- FIXME: we shouldn't need to construct the same DetailedMessage
+            -- both here and 10 lines above.
+            insertPending sender serial mc (B.DetailedMessage µs call (Just m))
             return call
 
         (ReceivedMethodReturn _serial sender mr) -> do
             call <- popMatchingCall (methodReturnDestination mr) (methodReturnSerial mr)
 
             return $ case call of
-                Just (rawCall, bustleCall)
+                Just (rawCall, dm)
                     -- 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.
-                    | B.membername (B.member bustleCall) == "GetNameOwner"
-                        -> bustlifyNOC µs ( fromJust . fromVariant $ (methodCallBody rawCall !! 0)
-                                          , Nothing
-                                          , fromVariant $ (methodReturnBody mr !! 0)
-                                          )
+                    | B.membername (B.member (B.dmMessage dm)) == "GetNameOwner"
+                        -> bustlifyNOC ( fromJust . fromVariant $ (methodCallBody rawCall !! 0)
+                                       , Nothing
+                                       , fromVariant $ (methodReturnBody mr !! 0)
+                                       )
                 _ -> B.MethodReturn
-                               { B.timestamp = µs
-                               , B.inReplyTo = fmap snd call
+                               { B.inReplyTo = fmap snd call
                                , B.sender = convertBusName "method.return.sender" sender
                                , B.destination = convertBusName "method.return.destination" $ methodReturnDestination mr
                                }
@@ -153,17 +152,15 @@ bustlify µs m = do
         (ReceivedError _serial sender e) -> do
             call <- popMatchingCall (errorDestination e) (errorSerial e)
             return $ B.Error
-                        { B.timestamp = µs
-                        , B.inReplyTo = fmap snd call
+                        { B.inReplyTo = fmap snd call
                         , B.sender = convertBusName "method.error.sender" sender
                         , B.destination = convertBusName "method.error.destination" $ errorDestination e
                         }
 
         (ReceivedSignal _serial sender sig)
-            | Just names <- isNOC sender sig -> return $ bustlifyNOC µs names
+            | Just names <- isNOC sender sig -> return $ bustlifyNOC names
             | otherwise                      -> return $
-                B.Signal { B.timestamp = µs
-                         , B.sender = convertBusName "signal.sender" sender
+                B.Signal { B.sender = convertBusName "signal.sender" sender
                          , B.member = convertMember signalPath (Just . signalInterface) signalMember sig
                          }