acab4f5 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Say: Send unformatted time over the wire

acab4f5Ben Gamari10 years ago

ChangeLog+5

compare with master

unifiedsplit

@@ -1,3 +1,8 @@

1+2016-07-06 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.0

3+* Change type of message sent by `say` from a 3-tuple to a proper

4+type (`SayMessage`) with a proper `UTCTime`.

12016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.4

62016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.4

3* Fixup build errors.

8* Fixup build errors.

src/Control/Distributed/Process/Internal/Primitives.hs+44−7

@@ -79,6 +79,7 @@ module Control.Distributed.Process.Internal.Primitives

79 , withMonitor

80 , withMonitor_

81 -- * Logging

82+ , SayMessage(..)

82 , say

83 , say

83 -- * Registry

84 -- * Registry

84 , register

85 , register

@@ -126,8 +127,9 @@ module Control.Distributed.Process.Internal.Primitives

126import Prelude hiding (catch)

127import Prelude hiding (catch)

127#endif

128#endif

128

129

129−import Data.Binary (decode)

130+import Data.Binary (Binary(..), Put, Get, decode)

130−import Data.Time.Clock (getCurrentTime)

131+import Data.Time.Clock (getCurrentTime, UTCTime(..))

132+import Data.Time.Calendar (Day(..))

131import Data.Time.Format (formatTime)

133import Data.Time.Format (formatTime)

132#if MIN_VERSION_time(1,5,0)

134#if MIN_VERSION_time(1,5,0)

133import Data.Time.Format (defaultTimeLocale)

135import Data.Time.Format (defaultTimeLocale)

@@ -1077,17 +1079,52 @@ unlinkPortAsync (SendPort cid) =

1077-- Logging --

1079-- Logging --

1078--------------------------------------------------------------------------------

1080--------------------------------------------------------------------------------

1079

1081

1082+data SayMessage = SayMessage { sayTime :: UTCTime

1083+ , sayProcess :: ProcessId

1084+ , sayMessage :: String }

1085+ deriving (Typeable)

1086+

1087+-- There is sadly no Show UTCTime instance

1088+instance Show SayMessage where

1089+ showsPrec p msg =

1090+ showParen (p >= 11)

1091+ $ showString "SayMessage "

1092+ . showString (formatTime defaultTimeLocale "%c" (sayTime msg))

1093+ . showChar ' '

1094+ . showsPrec 11 (sayProcess msg) . showChar ' '

1095+ . showsPrec 11 (sayMessage msg) . showChar ' '

1096+

1097+instance Binary SayMessage where

1098+ put s = do

1099+ putUTCTime (sayTime s)

1100+ put (sayProcess s)

1101+ put (sayMessage s)

1102+ get = SayMessage <$> getUTCTime <*> get <*> get

1103+

1104+-- Sadly there is no Binary UTCTime instance

1105+putUTCTime :: UTCTime -> Put

1106+putUTCTime (UTCTime (ModifiedJulianDay day) tod) = do

1107+ put day

1108+ put (toRational tod)

1109+

1110+getUTCTime :: Get UTCTime

1111+getUTCTime = do

1112+ day <- get

1113+ tod <- get

1114+ return $! UTCTime (ModifiedJulianDay day)

1115+ (fromRational tod)

1116+

1080-- | Log a string

1117-- | Log a string

1081--

1118--

1082−-- @say message@ sends a message (time, pid of the current process, message)

1119+-- @say message@ sends a message of type 'SayMessage' with the current time and

1083−-- to the process registered as 'logger'. By default, this process simply

1120+-- 'ProcessId' of the current process to the process registered as @logger@. By

1084−-- sends the string to 'stderr'. Individual Cloud Haskell backends might

1121+-- default, this process simply sends the string to @stderr@. Individual Cloud

1085−-- replace this with a different logger process, however.

1122+-- Haskell backends might replace this with a different logger process, however.

1086say :: String -> Process ()

1123say :: String -> Process ()

1087say string = do

1124say string = do

1088 now <- liftIO getCurrentTime

1125 now <- liftIO getCurrentTime

1089 us <- getSelfPid

1126 us <- getSelfPid

1090− nsend "logger" (formatTime defaultTimeLocale "%c" now, us, string)

1127+ nsend "logger" (SayMessage now us string)

1091

1128

1092--------------------------------------------------------------------------------

1129--------------------------------------------------------------------------------

1093-- Registry --

1130-- Registry --

src/Control/Distributed/Process/Node.hs+10−2

@@ -37,6 +37,12 @@ import qualified Data.Map as Map

37 , filterWithKey

38 , foldlWithKey

39 )

40+import Data.Time.Format (formatTime)

41+#if MIN_VERSION_time(1,5,0)

42+import Data.Time.Format (defaultTimeLocale)

43+#else

44+import System.Locale (defaultTimeLocale)

45+#endif

40import Data.Set (Set)

46import Data.Set (Set)

41import qualified Data.Set as Set

47import qualified Data.Set as Set

42 ( empty

48 ( empty

@@ -200,6 +206,7 @@ import Control.Distributed.Process.Internal.Primitives

200 , match

206 , match

201 , sendChan

207 , sendChan

202 , unwrapMessage

208 , unwrapMessage

209+ , SayMessage(..)

203 )

210 )

204import Control.Distributed.Process.Internal.Types (SendPort, Tracer(..))

211import Control.Distributed.Process.Internal.Types (SendPort, Tracer(..))

205import qualified Control.Distributed.Process.Internal.Closure.BuiltIn as BuiltIn (remoteTable)

212import qualified Control.Distributed.Process.Internal.Closure.BuiltIn as BuiltIn (remoteTable)

@@ -317,8 +324,9 @@ startServiceProcesses node = do

317 where

324 where

318 loop = do

325 loop = do

319 receiveWait

326 receiveWait

320− [ match $ \((time, pid, string) ::(String, ProcessId, String)) -> do

327+ [ match $ \(SayMessage time pid string) -> do

328+ let time' = formatTime defaultTimeLocale "%c" time

321− liftIO . hPutStrLn stderr $ time ++ " " ++ show pid ++ ": " ++ string

329+ liftIO . hPutStrLn stderr $ time' ++ " " ++ show pid ++ ": " ++ string

322 loop

330 loop

323 , match $ \((time, string) :: (String, String)) -> do

331 , match $ \((time, string) :: (String, String)) -> do

324 -- this is a 'trace' message from the local node tracer

332 -- this is a 'trace' message from the local node tracer