From 937b55549b4ba72b0392d7e139e592a40eec2101 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 27 Apr 2017 09:39:55 -0400 Subject: rename LogMessage to AnyMessage Not related to the Log anymore. --- Log.hs | 6 +++--- Role/Developer.hs | 12 ++++++------ Role/Downloader.hs | 2 +- Role/User.hs | 2 +- Role/Watcher.hs | 2 +- Server.hs | 6 +++--- Types.hs | 10 +++++----- WebSockets.hs | 20 ++++++++++---------- 8 files changed, 30 insertions(+), 30 deletions(-) diff --git a/Log.hs b/Log.hs index 948ab19..ffb4eb7 100644 --- a/Log.hs +++ b/Log.hs @@ -20,7 +20,7 @@ import System.IO -- Note that changing this in ways that change the JSON serialization -- changes debug-me's log file format. data Log = Log - { loggedMessage :: LogMessage + { loggedMessage :: AnyMessage , loggedHash :: Maybe Hash , loggedTimestamp :: Timestamp } @@ -34,7 +34,7 @@ instance DataSize Log where instance ToJSON Log instance FromJSON Log -mkLog :: LogMessage -> POSIXTime -> Log +mkLog :: AnyMessage -> POSIXTime -> Log mkLog m now = Log { loggedMessage = m , loggedHash = case m of @@ -47,7 +47,7 @@ mkLog m now = Log type Timestamp = POSIXTime -type Logger = LogMessage -> IO () +type Logger = AnyMessage -> IO () withLogger :: FilePath -> (Logger -> IO a) -> IO a withLogger logfile a = withFile logfile WriteMode (a . mkLogger) diff --git a/Role/Developer.hs b/Role/Developer.hs index d5c3463..a0e178e 100644 --- a/Role/Developer.hs +++ b/Role/Developer.hs @@ -25,13 +25,13 @@ import Data.Time.Clock.POSIX run :: DeveloperOpts -> IO () run = run' developer . debugUrl -run' :: (TMChan (Message Entered) -> TMChan LogMessage -> SessionID -> IO ()) -> UrlString -> IO () +run' :: (TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO ()) -> UrlString -> IO () run' runner url = void $ runClientApp app where connect = ConnectMode (T.pack url) app = clientApp connect Developer Just runner -developer :: TMChan (Message Entered) -> TMChan LogMessage -> SessionID -> IO () +developer :: TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () developer ichan ochan _ = withLogger "debug-me-developer.log" $ \logger -> do (devstate, startoutput) <- processSessionStart ochan logger emitOutput startoutput @@ -103,7 +103,7 @@ sendTtyInput ichan devstate logger = go go -- | Read activity from the TMChan and display it to the developer. -sendTtyOutput :: TMChan LogMessage -> TVar DeveloperState -> Logger -> IO () +sendTtyOutput :: TMChan AnyMessage -> TVar DeveloperState -> Logger -> IO () sendTtyOutput ochan devstate logger = go where go = do @@ -119,7 +119,7 @@ sendTtyOutput ochan devstate logger = go -- | Present our session key to the user. -- Wait for them to accept or reject it, while displaying any Seen data -- in the meantime. -authUser :: TMChan (Message Entered) -> TMChan LogMessage -> TVar DeveloperState -> Logger -> IO Bool +authUser :: TMChan (Message Entered) -> TMChan AnyMessage -> TVar DeveloperState -> Logger -> IO Bool authUser ichan ochan devstate logger = do ds <- atomically $ readTVar devstate spk <- myPublicKey (developerSessionKey ds) (GpgSign True) @@ -167,7 +167,7 @@ emitOutput NoOutput = -- | Get messages from server, check their signature, and make sure that they -- are properly chained from past messages, before returning. -getServerMessage :: TMChan LogMessage -> TVar DeveloperState -> POSIXTime -> STM (Maybe (Output, LogMessage)) +getServerMessage :: TMChan AnyMessage -> TVar DeveloperState -> POSIXTime -> STM (Maybe (Output, AnyMessage)) getServerMessage ochan devstate ts = do let ignore = getServerMessage ochan devstate ts mmsg <- readTMChan ochan @@ -288,7 +288,7 @@ isLegalSeen act@(Activity (Seen (Val b)) (Just hp) _ _) ds ts -- | Start by reading the initial two messages from the user, -- their session key and the startup message. -processSessionStart :: TMChan LogMessage -> Logger -> IO (TVar DeveloperState, Output) +processSessionStart :: TMChan AnyMessage -> Logger -> IO (TVar DeveloperState, Output) processSessionStart ochan logger = do sessionmsg <- fromMaybe (error "Did not get session initialization message") <$> atomically (readTMChan ochan) diff --git a/Role/Downloader.hs b/Role/Downloader.hs index 243410b..d49b4ec 100644 --- a/Role/Downloader.hs +++ b/Role/Downloader.hs @@ -13,7 +13,7 @@ import Data.Time.Clock.POSIX run :: DownloadOpts -> IO () run = run' downloader . downloadUrl -downloader :: TMChan (Message Entered) -> TMChan LogMessage -> SessionID -> IO () +downloader :: TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () downloader _ichan ochan sid = do let logfile = sessionLogFile "." sid putStrLn $ "Starting download to " ++ logfile diff --git a/Role/User.hs b/Role/User.hs index 51688af..be546cf 100644 --- a/Role/User.hs +++ b/Role/User.hs @@ -54,7 +54,7 @@ run os = fromMaybe (ExitFailure 101) <$> connect _ <- waitCatch p2 return exitstatus -developerMessages :: LogMessage -> Maybe (Message Entered) +developerMessages :: AnyMessage -> Maybe (Message Entered) developerMessages (Developer m) = Just m developerMessages (User _) = Nothing diff --git a/Role/Watcher.hs b/Role/Watcher.hs index 1ca0ae7..8bcc91c 100644 --- a/Role/Watcher.hs +++ b/Role/Watcher.hs @@ -14,7 +14,7 @@ import Data.Time.Clock.POSIX run :: WatchOpts -> IO () run = run' watcher . watchUrl -watcher :: TMChan (Message Entered) -> TMChan LogMessage -> SessionID -> IO () +watcher :: TMChan (Message Entered) -> TMChan AnyMessage -> SessionID -> IO () watcher _ichan ochan _ = inRawMode $ do (st, startoutput) <- processSessionStart ochan nullLogger emitOutput startoutput diff --git a/Server.hs b/Server.hs index 0906937..62d0a3c 100644 --- a/Server.hs +++ b/Server.hs @@ -154,7 +154,7 @@ user o ssv conn = withSessionID (serverDirectory o) $ \(loghv, sid) -> do case v of Just (Broadcast l _from) -> case loggedMessage l of Developer m -> do - sendBinaryData conn (LogMessage (Developer m)) + sendBinaryData conn (AnyMessage (Developer m)) relaytouser userchan User _ -> relaytouser userchan Nothing -> return () @@ -196,7 +196,7 @@ developer o ssv sid conn = bracket setup cleanup go case v of Just (Broadcast l from) -> do let sendit = sendBinaryData conn - (LogMessage $ loggedMessage l) + (AnyMessage $ loggedMessage l) case loggedMessage l of User _ -> sendit -- Relay messages from other @@ -232,5 +232,5 @@ replayBacklog :: ServerOpts -> SessionID -> WS.Connection -> IO () replayBacklog o sid conn = do ls <- streamLog (sessionLogFile (serverDirectory o) sid) forM_ ls $ \l -> case loggedMessage <$> l of - Right m -> sendBinaryData conn (LogMessage m) + Right m -> sendBinaryData conn (AnyMessage m) Left _ -> return () diff --git a/Types.hs b/Types.hs index 2dc5d28..75d22cf 100644 --- a/Types.hs +++ b/Types.hs @@ -160,7 +160,7 @@ mkElapsedTime start end = ElapsedTime $ fromRational $ toRational (end - start) instance DataSize ElapsedTime where dataSize _ = 16 -- 128 bit Double -data LogMessage +data AnyMessage = User (Message Seen) | Developer (Message Entered) deriving (Show, Generic) @@ -169,15 +169,15 @@ instance Binary ElapsedTime instance ToJSON ElapsedTime instance FromJSON ElapsedTime -instance DataSize LogMessage where +instance DataSize AnyMessage where dataSize (User a) = dataSize a dataSize (Developer a) = dataSize a -instance Binary LogMessage -instance ToJSON LogMessage where +instance Binary AnyMessage +instance ToJSON AnyMessage where toJSON = genericToJSON sumOptions toEncoding = genericToEncoding sumOptions -instance FromJSON LogMessage where +instance FromJSON AnyMessage where parseJSON = genericParseJSON sumOptions instance Binary Seen diff --git a/WebSockets.hs b/WebSockets.hs index d8d43e7..2fa9e35 100644 --- a/WebSockets.hs +++ b/WebSockets.hs @@ -56,11 +56,11 @@ runClientApp app = do catchconnclosed ConnectionClosed = Just () catchconnclosed _ = Nothing --- | Make a client that sends and receives LogMessages over a websocket. +-- | Make a client that sends and receives AnyMessages over a websocket. clientApp :: Mode - -> (sent -> LogMessage) - -> (LogMessage -> Maybe received) + -> (sent -> AnyMessage) + -> (AnyMessage -> Maybe received) -> (TMChan sent -> TMChan received -> SessionID -> IO a) -> ClientApp a clientApp mode mksent filterreceived a conn = do @@ -98,20 +98,20 @@ clientApp mode mksent filterreceived a conn = do void $ waitCatch rthread go sid (schan, rchan, _, _) = a schan rchan sid -relayFromSocket :: Connection -> (LogMessage -> IO ()) -> IO () +relayFromSocket :: Connection -> (AnyMessage -> IO ()) -> IO () relayFromSocket conn sender = go where go = do r <- receiveData conn case r of - LogMessage msg -> do + AnyMessage msg -> do sender msg go Done -> return () WireProtocolError e -> protocolError conn e _ -> protocolError conn "Protocol error" -relayToSocket :: Connection -> (received -> LogMessage) -> IO (Maybe received) -> IO () +relayToSocket :: Connection -> (received -> AnyMessage) -> IO (Maybe received) -> IO () relayToSocket conn mksent getter = go where go = do @@ -119,7 +119,7 @@ relayToSocket conn mksent getter = go case mmsg of Nothing -> return () Just msg -> do - sendBinaryData conn $ LogMessage $ mksent msg + sendBinaryData conn $ AnyMessage $ mksent msg go -- | Framing protocol used over a websocket connection. @@ -133,7 +133,7 @@ data WireProtocol = Version [WireVersion] | SelectMode ClientSends Mode | Ready ServerSends SessionID - | LogMessage LogMessage + | AnyMessage AnyMessage | Done | WireProtocolError String @@ -144,7 +144,7 @@ instance WebSocketsData WireProtocol where toLazyByteString (Version v) = "V" <> Data.Aeson.encode v toLazyByteString (SelectMode _ m) = "M" <> Data.Aeson.encode m toLazyByteString (Ready _ sid) = "R" <> Data.Aeson.encode sid - toLazyByteString (LogMessage msg) = "L" <> Data.Binary.encode msg + toLazyByteString (AnyMessage msg) = "L" <> Data.Binary.encode msg toLazyByteString Done = "D" toLazyByteString (WireProtocolError s) = "E" <> Data.Aeson.encode s fromLazyByteString b = case L.splitAt 1 b of @@ -159,7 +159,7 @@ instance WebSocketsData WireProtocol where (Data.Aeson.decode sid) ("L", l) -> case Data.Binary.decodeOrFail l of Left (_, _, err) -> WireProtocolError $ "Binary decode error: " ++ err - Right (_, _, msg) -> LogMessage msg + Right (_, _, msg) -> AnyMessage msg ("D", "") -> Done ("E", s) -> maybe (WireProtocolError "invalid JSON in WireProtocolError") WireProtocolError -- cgit v1.2.3