diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for Z-IO +## 0.1.7.0 -- 2020-10-24 + +* Add `iso8016DateFormat`, change logger's default time format to include time zone. +* Rename `warn` to `warning`, change `Level` to `Int` type alias in `Z.IO.Logger`, add `critical`. +* Export `TimeVal` from `Z.IO.Environment`. +* Add `getCPUInfo`, `getLoadAvg`, `getXXXMem` to `Z.IO.Environment`. + ## 0.1.6.1 -- 2020-10-17 * Export `ResUsage` from `Z.IO.Environment`. diff --git a/Z-IO.cabal b/Z-IO.cabal --- a/Z-IO.cabal +++ b/Z-IO.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: Z-IO -version: 0.1.6.1 +version: 0.1.7.0 synopsis: Simple and high performance IO toolkit for Haskell description: Simple and high performance IO toolkit for Haskell, including file system, network, ipc and more! @@ -115,7 +115,7 @@ Z.Compression.Zlib build-depends: base >= 4.12 && < 5.0 - , Z-Data >= 0.1.7.2 && < 0.1.8 + , Z-Data >= 0.1.7.2 && < 0.1.9 , primitive >= 0.7.1 && < 0.7.2 , exceptions == 0.10.* , time >= 1.8 && < 2.0 diff --git a/Z/IO/Environment.hs b/Z/IO/Environment.hs --- a/Z/IO/Environment.hs +++ b/Z/IO/Environment.hs @@ -19,7 +19,8 @@ , setEnv, unsetEnv -- * other environment infos , getCWD, chDir, getHomeDir, getTempDir - , getResUsage, ResUsage(..) + , getRandom, getRandomT + , getResUsage, ResUsage(..), TimeVal(..) , getResidentSetMemory , getUpTime , getHighResolutionTime @@ -28,7 +29,9 @@ , getHostname , getOSName, OSName(..) , getPassWD, PassWD(..), UID, GID - , getRandom, getRandomT + , getCPUInfo, CPUInfo(..) + , getLoadAvg + , getFreeMem, getTotalMem, getConstrainedMem ) where import Control.Monad @@ -240,6 +243,22 @@ _ -> do throwUVIfMinus_ (return r) return v + +-- | Gets the amount of free memory available in the system, as reported by the kernel (in bytes). +getFreeMem :: IO Word64 +getFreeMem = uv_get_free_memory + +-- | Gets the total amount of physical memory in the system (in bytes). +getTotalMem :: IO Word64 +getTotalMem = uv_get_total_memory + +-- | Gets the amount of memory available to the process (in bytes) based on limits imposed by the OS. +-- +-- If there is no such constraint, or the constraint is unknown, 0 is returned. +-- Note that it is not unusual for this value to be less than or greater than 'getTotalMem'. +-- Note This function currently only returns a non-zero value on Linux, based on cgroups if it is present. +getConstrainedMem :: IO Word64 +getConstrainedMem = uv_get_constrained_memory -------------------------------------------------------------------------------- diff --git a/Z/IO/Exception.hs b/Z/IO/Exception.hs --- a/Z/IO/Exception.hs +++ b/Z/IO/Exception.hs @@ -69,6 +69,7 @@ , HasCallStack , CallStack , callStack + , module Z.IO.UV.Errno ) where import Control.Exception hiding (IOException) diff --git a/Z/IO/FileSystem/FilePath.hsc b/Z/IO/FileSystem/FilePath.hsc --- a/Z/IO/FileSystem/FilePath.hsc +++ b/Z/IO/FileSystem/FilePath.hsc @@ -374,7 +374,7 @@ -- | Joins multiple paths together. -- -- This function generates a new path by joining multiple paths together. --- It will remove double separators, and unlike 'getAbsolute', +-- It will remove double separators, and unlike 'absolute', -- it permits the use of multiple relative paths to combine. concat :: [CBytes] -> IO CBytes concat ps = do diff --git a/Z/IO/Logger.hs b/Z/IO/Logger.hs --- a/Z/IO/Logger.hs +++ b/Z/IO/Logger.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + {-| Module : Z.IO.Logger Description : High performance logger @@ -17,7 +19,10 @@ * Each logging thread only need perform a CAS to prepend log 'V.Bytes' into a list, which reduces contention. * Each log call is atomic, Logging order is preserved under concurrent settings. -Flushing is automatic and throttled for 'debug', 'info', 'warn' to boost performance, but a 'fatal' log will always flush logger's buffer. This could lead to a problem that if main thread exits too early logs may missed, to add a flushing when program exits, use 'withDefaultLogger' like: +Flushing is automatic and throttled for 'debug', 'info', 'warning' to boost +performance, but a 'fatal' and 'critical' log will always flush logger's buffer. +This could lead to a problem that if main thread exits too early logs may missed, +to add a flushing when program exits, use 'withDefaultLogger' like: @ import Z.IO.Logger @@ -44,37 +49,47 @@ -- * logging functions , debug , info - , warn + , warning , fatal + , critical , otherLevel - , Level -- * logging functions with specific logger , debugTo , infoTo - , warnTo + , warningTo , fatalTo , otherLevelTo - -- * Helper to write new logger + -- * Helpers to write new logger , defaultTSCache , defaultFmtCallStack + , defaultLevelFmt , LogFormatter, defaultFmt, coloredFmt - , flushLog + , pushLogIORef, flushLogIORef + -- * Constants + -- ** Level + , Level + , pattern DEBUG + , pattern INFO + , pattern WARNING + , pattern FATAL + , pattern CRITICAL + , pattern NOTSET ) where -import Control.Monad -import Z.Data.Vector.Base as V -import Z.IO.LowResTimer -import Z.IO.StdStream -import Z.IO.StdStream.Ansi (color, AnsiColor(..)) -import Z.IO.Buffered -import System.IO.Unsafe (unsafePerformIO) -import Z.IO.Exception -import Z.IO.Time -import Data.IORef -import Control.Concurrent.MVar -import GHC.Stack -import qualified Z.Data.Builder as B -import qualified Z.Data.CBytes as CB +import Control.Concurrent.MVar +import Control.Monad +import Data.IORef +import GHC.Stack +import System.IO.Unsafe (unsafePerformIO) +import qualified Z.Data.Builder as B +import qualified Z.Data.CBytes as CB +import Z.Data.Vector.Base as V +import Z.IO.Buffered +import Z.IO.Exception +import Z.IO.LowResTimer +import Z.IO.StdStream +import Z.IO.StdStream.Ansi (AnsiColor (..), color) +import Z.IO.Time type LogFormatter = B.Builder () -- ^ data\/time string -> Level -- ^ log level @@ -82,29 +97,40 @@ -> CallStack -- ^ call stack trace -> B.Builder () +-- | Extensible logger type. data Logger = Logger - { loggerPushBuilder :: B.Builder () -> IO () -- ^ push log into buffer - , flushLogger :: IO () -- ^ flush logger's buffer to output device - , flushLoggerThrottled :: IO () -- ^ throttled flush, e.g. use 'throttleTrailing_' from "Z.IO.LowResTimer" - , loggerTSCache :: IO (B.Builder ()) -- ^ A IO action return a formatted date\/time string - , loggerFmt :: LogFormatter + { loggerPushBuilder :: B.Builder () -> IO () + -- ^ Push log into buffer + , flushLogger :: IO () + -- ^ Flush logger's buffer to output device + , flushLoggerThrottled :: IO () + -- ^ Throttled flush, e.g. use 'throttleTrailing_' from "Z.IO.LowResTimer" + , loggerTSCache :: IO (B.Builder ()) + -- ^ An IO action return a formatted date\/time string + , loggerFmt :: LogFormatter + -- ^ Output logs if level is equal or higher than this value. + , loggerLevel :: {-# UNPACK #-} !Level } +-- | Logger config type used in this module. data LoggerConfig = LoggerConfig - { loggerMinFlushInterval :: {-# UNPACK #-} !Int -- ^ Minimal flush interval, see Notes on 'debug' - , loggerLineBufSize :: {-# UNPACK #-} !Int -- ^ Buffer size to build each log line - , loggerShowDebug :: Bool -- ^ Set to 'False' to filter debug logs + { loggerMinFlushInterval :: {-# UNPACK #-} !Int + -- ^ Minimal flush interval, see Notes on 'debug' + , loggerLineBufSize :: {-# UNPACK #-} !Int + -- ^ Buffer size to build each log line + , loggerConfigLevel :: {-# UNPACK #-} !Level + -- ^ Config log's filter level } -- | A default logger config with -- -- * 0.1s minimal flush interval -- * line buffer size 240 bytes --- * show debug True +-- * show everything by default defaultLoggerConfig :: LoggerConfig -defaultLoggerConfig = LoggerConfig 1 240 True +defaultLoggerConfig = LoggerConfig 1 240 NOTSET --- | A default timestamp cache with format @%Y-%m-%dT%H:%M:%S%Z@ +-- | A default timestamp cache with format @%Y-%m-%dT%H:%M:%S%Z@('iso8061DateFormat'). -- -- The timestamp will updated in 0.1s granularity to ensure a seconds level precision. defaultTSCache :: IO (B.Builder ()) @@ -112,23 +138,7 @@ defaultTSCache = unsafePerformIO $ do throttle 1 $ do t <- getSystemTime - CB.toBuilder <$> formatSystemTime simpleDateFormat t - --- | Use this function to implement a simple 'IORef' based concurrent logger. --- --- @ --- bList <- newIORef [] --- let flush = flushLog buffered bList --- .. --- return $ Logger (pushLog bList) flush ... --- @ --- -flushLog :: (HasCallStack, Output o) => MVar (BufferedOutput o) -> IORef [V.Bytes] -> IO () -flushLog oLock bList = - withMVar oLock $ \ o -> do - bss <- atomicModifyIORef' bList (\ bss -> ([], bss)) - forM_ (reverse bss) (writeBuffer o) - flushBuffer o + CB.toBuilder <$> formatSystemTime iso8061DateFormat t -- | Make a new simple logger. -- @@ -137,40 +147,59 @@ -> MVar (BufferedOutput o) -> IO Logger newLogger LoggerConfig{..} oLock = do - bList <- newIORef [] - let flush = flushLog oLock bList + logsRef <- newIORef [] + let flush = flushLogIORef oLock logsRef throttledFlush <- throttleTrailing_ loggerMinFlushInterval flush - return $ Logger (pushLog bList) flush throttledFlush defaultTSCache - (defaultFmt loggerShowDebug) - where - pushLog bList b = do - let !bs = B.buildBytesWith loggerLineBufSize b - atomicModifyIORef' bList (\ bss -> (bs:bss, ())) + return $ Logger (pushLogIORef logsRef loggerLineBufSize) + flush throttledFlush defaultTSCache defaultFmt + loggerConfigLevel --- | Make a new colored logger connected to stderr. +-- | Make a new colored logger(connected to stderr). -- -- This logger will output colorized log if stderr is connected to TTY. newColoredLogger :: LoggerConfig -> IO Logger newColoredLogger LoggerConfig{..} = do - bList <- newIORef [] - let flush = flushLog stderrBuf bList + logsRef <- newIORef [] + let flush = flushLogIORef stderrBuf logsRef throttledFlush <- throttleTrailing_ loggerMinFlushInterval flush - return $ Logger (pushLog bList) flush throttledFlush defaultTSCache - (if isStdStreamTTY stderr then coloredFmt loggerShowDebug - else defaultFmt loggerShowDebug) + return $ Logger (pushLogIORef logsRef loggerLineBufSize) + flush throttledFlush defaultTSCache + (if isStdStreamTTY stderr then coloredFmt + else defaultFmt) + loggerConfigLevel - where - pushLog bList b = do - let !bs = B.buildBytesWith loggerLineBufSize b - atomicModifyIORef' bList (\ bss -> (bs:bss, ())) +-- | Use 'pushLogIORef' and 'pushLogIORef' to implement a simple 'IORef' based concurrent logger. +-- +-- @ +-- logsRef <- newIORef [] +-- let push = pushLogIORef logsRef lineBufSize +-- flush = flushLogIORef stderrBuf logsRef +-- throttledFlush <- throttleTrailing_ flushInterval flush +-- .. +-- return $ Logger push flush throttledFlush ... +-- @ +-- +pushLogIORef :: IORef [V.Bytes] -- ^ logs stored in a list, new log will be CASed into it. + -> Int -- ^ buffer size to build each log + -> B.Builder () -- ^ formatted log + -> IO () +pushLogIORef logsRef loggerLineBufSize b = do + let !bs = B.buildBytesWith loggerLineBufSize b + unless (V.null bs) $ atomicModifyIORef' logsRef (\ bss -> (bs:bss, ())) +flushLogIORef :: (HasCallStack, Output o) => MVar (BufferedOutput o) -> IORef [V.Bytes] -> IO () +flushLogIORef oLock logsRef = + withMVar oLock $ \ o -> do + bss <- atomicModifyIORef' logsRef (\ bss -> ([], bss)) + forM_ (reverse bss) (writeBuffer o) + flushBuffer o + -- | A default log formatter -- -- @ [DEBUG][2020-10-09T07:44:14UTC][:7:1]This a debug message\\n@ -defaultFmt :: Bool -- ^ show DEGUG? - -> LogFormatter -defaultFmt showdebug ts level content cstack = when (showdebug || level /= "DEBUG") $ do - B.square (CB.toBuilder level) +defaultFmt :: LogFormatter +defaultFmt ts level content cstack = do + B.square (defaultLevelFmt level) B.square ts B.square $ defaultFmtCallStack cstack content @@ -178,16 +207,16 @@ -- | A default colored log formatter -- --- DEBUG level is 'Cyan', WARN level is 'Yellow', FATAL level is 'Red'. -coloredFmt :: Bool -- ^ show DEBUG? - -> LogFormatter -coloredFmt showdebug ts level content cstack = when (showdebug || level /= "DEBUG") $ do - let blevel = CB.toBuilder level +-- DEBUG level is 'Cyan', WARNING level is 'Yellow', FATAL and CRITICAL level are 'Red'. +coloredFmt :: LogFormatter +coloredFmt ts level content cstack = do + let blevel = defaultLevelFmt level B.square (case level of - "DEBUG" -> color Cyan blevel - "WARN" -> color Yellow blevel - "FATAL" -> color Red blevel - _ -> blevel) + DEBUG -> color Cyan blevel + WARNING -> color Yellow blevel + FATAL -> color Red blevel + CRITICAL -> color Red blevel + _ -> blevel) B.square ts B.square $ defaultFmtCallStack cstack content @@ -228,20 +257,76 @@ -------------------------------------------------------------------------------- -type Level = CB.CBytes +-- | Logging Levels +-- +-- We following the Python logging levels, for details, +-- see: +-- +-- +----------+---------------+ +-- | Level | Numeric value | +-- +----------+---------------+ +-- | CRITICAL | 50 | +-- +----------+---------------+ +-- | FATAL | 40 | +-- +----------+---------------+ +-- | WARNING | 30 | +-- +----------+---------------+ +-- | INFO | 20 | +-- +----------+---------------+ +-- | DEBUG | 10 | +-- +----------+---------------+ +-- | NOTSET | 0 | +-- +----------+---------------+ +-- +type Level = Int +pattern CRITICAL :: Level +pattern CRITICAL = 50 + +pattern FATAL :: Level +pattern FATAL = 40 + +pattern WARNING :: Level +pattern WARNING = 30 + +pattern INFO :: Level +pattern INFO = 20 + +pattern DEBUG :: Level +pattern DEBUG = 10 + +pattern NOTSET :: Level +pattern NOTSET = 0 + +-- | Format 'DEBUG' to 'DEBUG', etc. +-- +-- Level other than built-in ones, are formatted in decimal numeric format, i.e. +-- @defaultLevelFmt 60 == "LEVEL60"@ +defaultLevelFmt :: Level -> B.Builder () +defaultLevelFmt level = case level of + CRITICAL -> "CRITICAL" + FATAL -> "FATAL" + WARNING -> "WARNING" + INFO -> "INFO" + DEBUG -> "DEBUG" + NOTSET -> "NOTSET" + level' -> "LEVEL" >> B.int level' + debug :: HasCallStack => B.Builder () -> IO () -debug = otherLevel_ "DEBUG" False callStack +debug = otherLevel_ DEBUG False callStack info :: HasCallStack => B.Builder () -> IO () -info = otherLevel_ "INFO" False callStack +info = otherLevel_ INFO False callStack -warn :: HasCallStack => B.Builder () -> IO () -warn = otherLevel_ "WARN" False callStack +warning :: HasCallStack => B.Builder () -> IO () +warning = otherLevel_ WARNING False callStack fatal :: HasCallStack => B.Builder () -> IO () -fatal = otherLevel_ "FATAL" True callStack +fatal = otherLevel_ FATAL True callStack +critical :: HasCallStack => B.Builder () -> IO () +critical = otherLevel_ CRITICAL True callStack + otherLevel :: HasCallStack => Level -- ^ log level -> Bool -- ^ flush immediately? @@ -257,16 +342,16 @@ -------------------------------------------------------------------------------- debugTo :: HasCallStack => Logger -> B.Builder () -> IO () -debugTo = otherLevelTo_ "DEBUG" False callStack +debugTo = otherLevelTo_ DEBUG False callStack infoTo :: HasCallStack => Logger -> B.Builder () -> IO () -infoTo = otherLevelTo_ "INFO" False callStack +infoTo = otherLevelTo_ INFO False callStack -warnTo :: HasCallStack => Logger -> B.Builder () -> IO () -warnTo = otherLevelTo_ "WARN" False callStack +warningTo :: HasCallStack => Logger -> B.Builder () -> IO () +warningTo = otherLevelTo_ WARNING False callStack fatalTo :: HasCallStack => Logger -> B.Builder () -> IO () -fatalTo = otherLevelTo_ "FATAL" True callStack +fatalTo = otherLevelTo_ FATAL True callStack otherLevelTo :: HasCallStack => Logger @@ -278,7 +363,7 @@ otherLevelTo_ level flushNow callStack logger otherLevelTo_ :: Level -> Bool -> CallStack -> Logger -> B.Builder () -> IO () -otherLevelTo_ level flushNow cstack logger bu = do +otherLevelTo_ level flushNow cstack logger bu = when (level >= loggerLevel logger) $ do ts <- loggerTSCache logger (loggerPushBuilder logger) $ (loggerFmt logger) ts level bu cstack if flushNow diff --git a/Z/IO/Resource.hs b/Z/IO/Resource.hs --- a/Z/IO/Resource.hs +++ b/Z/IO/Resource.hs @@ -27,6 +27,7 @@ , PoolState(..) , initPool , initInPool + , withResourceInPool , poolStat, poolInUse ) where @@ -43,7 +44,7 @@ -- | A 'Resource' is an 'IO' action which acquires some resource of type a and -- also returns a finalizer of type IO () that releases the resource. -- --- The only safe way to use a 'Resource' is 'withResource' and 'withResource\'', +-- The only safe way to use a 'Resource' is 'withResource' and 'withResource'', -- You should not use the 'acquire' field directly, unless you want to implement your own -- resource management. In the later case, you should 'mask_' 'acquire' since -- some resource initializations may assume async exceptions are masked. @@ -288,3 +289,11 @@ | life > 1 = age es deadNum dead (Entry a (life-1):living) | otherwise = age es (deadNum+1) (a:dead) living age _ !deadNum dead living = (deadNum, dead, living) + +-- | Open resource inside a given resource pool and do some computation. +-- +withResourceInPool :: (MonadCatch.MonadMask m, MonadIO m, HasCallStack) + => Pool a -> (a -> m b) -> m b +withResourceInPool pool = withResource res + where + res = initInPool pool diff --git a/Z/IO/StdStream.hs b/Z/IO/StdStream.hs --- a/Z/IO/StdStream.hs +++ b/Z/IO/StdStream.hs @@ -45,8 +45,9 @@ , stdin, stdout, stderr , stdinBuf, stdoutBuf, stderrBuf -- * utils - , printStd , readLineStd + , printStd + , printLineStd , putStd , putLineStd -- * re-export @@ -208,7 +209,7 @@ -------------------------------------------------------------------------------- -- | Print a 'ShowT' and flush to stdout. -printStd :: HasCallStack => ShowT a => a -> IO () +printStd :: (HasCallStack, ShowT a) => a -> IO () printStd s = putStd (toBuilder s) -- | Print a 'Builder' and flush to stdout. @@ -216,6 +217,10 @@ putStd b = withMVar stdoutBuf $ \ o -> do writeBuilder o b flushBuffer o + +-- | Print a 'ShowT' and flush to stdout, with a linefeed. +printLineStd :: (HasCallStack, ShowT a) => a -> IO () +printLineStd s = putLineStd (toBuilder s) -- | Print a 'Builder' and flush to stdout, with a linefeed. putLineStd :: HasCallStack => Builder a -> IO () diff --git a/Z/IO/Time.hs b/Z/IO/Time.hs --- a/Z/IO/Time.hs +++ b/Z/IO/Time.hs @@ -20,7 +20,7 @@ -- * Formatting , formatSystemTime, formatSystemTimeGMT -- * Format - , TimeFormat, simpleDateFormat, webDateFormat, mailDateFormat + , TimeFormat, simpleDateFormat, iso8061DateFormat, webDateFormat, mailDateFormat ) where import Data.Time.Clock.System @@ -40,6 +40,13 @@ -- This should be used with 'formatSystemTime' and 'parseSystemTime'. simpleDateFormat :: TimeFormat simpleDateFormat = "%Y-%m-%d %H:%M:%S" + +-- | Simple format @2020-10-16T03:15:29@. +-- +-- The value is \"%Y-%m-%dT%H:%M:%S%z\". +-- This should be used with 'formatSystemTime' and 'parseSystemTime'. +iso8061DateFormat :: TimeFormat +iso8061DateFormat = "%Y-%m-%dT%H:%M:%S%z" -- | Format for web (RFC 2616). -- diff --git a/Z/IO/UV/FFI.hsc b/Z/IO/UV/FFI.hsc --- a/Z/IO/UV/FFI.hsc +++ b/Z/IO/UV/FFI.hsc @@ -13,6 +13,7 @@ module Z.IO.UV.FFI where +import Control.Monad import Data.Bits import Data.Int import Data.Word @@ -22,7 +23,6 @@ import Foreign.Ptr import Foreign.Storable import Z.Data.Array.Unaligned -import qualified Z.Data.Array as A import Z.Data.Text.ShowT (ShowT(..)) import Z.Data.JSON (EncodeJSON, ToValue, FromValue) import Z.Data.CBytes as CBytes @@ -852,6 +852,10 @@ foreign import ccall unsafe uv_uptime :: MBA## Double -> IO CInt foreign import ccall unsafe uv_getrusage :: MBA## a -> IO CInt +foreign import ccall unsafe uv_get_free_memory :: IO Word64 +foreign import ccall unsafe uv_get_total_memory :: IO Word64 +foreign import ccall unsafe uv_get_constrained_memory :: IO Word64 + -- | Data type for storing times. -- typedef struct { long tv_sec; long tv_usec; } uv_timeval_t; data TimeVal = TimeVal @@ -947,6 +951,7 @@ pattern UV_MAXHOSTNAMESIZE = #const UV_MAXHOSTNAMESIZE foreign import ccall unsafe uv_os_gethostname :: MBA## Word8 -> MBA## CSize -> IO CInt +-- | Data type for operating system name and version information. data OSName = OSName { os_sysname :: CBytes , os_release :: CBytes @@ -957,7 +962,7 @@ getOSName :: IO OSName getOSName = do - (A.MutablePrimArray mba## :: A.MutablePrimArray A.RealWorld Word8) <- A.newArr (#size uv_utsname_t) + (MutableByteArray mba##) <- newByteArray (#size uv_utsname_t) throwUVIfMinus_ (uv_os_uname mba##) sn <- peekMBA mba## (#offset uv_utsname_t, sysname) re <- peekMBA mba## (#offset uv_utsname_t, release) @@ -990,11 +995,11 @@ -- On Windows, uid and gid are set to -1 and have no meaning, and shell is empty. getPassWD :: IO PassWD getPassWD = bracket - (do mpa@(A.MutablePrimArray mba## :: A.MutablePrimArray A.RealWorld Word8) <- A.newArr (#size uv_passwd_t) + (do mpa@(MutableByteArray mba##) <- newByteArray (#size uv_passwd_t) throwUVIfMinus_ (uv_os_get_passwd mba##) return mpa) - (\ (A.MutablePrimArray mba##) -> uv_os_free_passwd mba##) - (\ (A.MutablePrimArray mba##) -> do + (\ (MutableByteArray mba##) -> uv_os_free_passwd mba##) + (\ (MutableByteArray mba##) -> do username <- fromCString =<< peekMBA mba## (#offset uv_passwd_t, username) uid <- fromIntegral <$> (peekMBA mba## (#offset uv_passwd_t, uid) :: IO CLong) gid <- fromIntegral <$> (peekMBA mba## (#offset uv_passwd_t, gid) :: IO CLong) @@ -1006,3 +1011,50 @@ foreign import ccall unsafe uv_chdir :: BA## Word8 -> IO CInt foreign import ccall unsafe uv_os_homedir :: MBA## Word8 -> MBA## CSize -> IO CInt foreign import ccall unsafe uv_os_tmpdir :: MBA## Word8 -> MBA## CSize -> IO CInt + +foreign import ccall unsafe uv_cpu_info :: MBA## (Ptr CPUInfo) -> MBA## CInt -> IO CInt +foreign import ccall unsafe uv_free_cpu_info :: Ptr CPUInfo -> CInt -> IO () + +-- | Data type for CPU information. +data CPUInfo = CPUInfo + { cpu_model :: CBytes + , cpu_speed :: CInt + , cpu_times_user :: Word64 -- ^ milliseconds + , cpu_times_nice :: Word64 -- ^ milliseconds + , cpu_times_sys :: Word64 -- ^ milliseconds + , cpu_times_idle :: Word64 -- ^ milliseconds + , cpu_times_irq :: Word64 -- ^ milliseconds + } deriving (Eq, Ord, Show, Generic) + deriving anyclass (ShowT, EncodeJSON, ToValue, FromValue) + +-- | Gets information about the CPUs on the system. +getCPUInfo :: IO [CPUInfo] +getCPUInfo = bracket + (do (p, (len, _)) <- allocPrimUnsafe $ \ pp -> + allocPrimUnsafe $ \ plen -> + throwUVIfMinus_ (uv_cpu_info pp plen) + return (p, len)) + (\ (p, len) -> uv_free_cpu_info p len) + (\ (p, len) -> forM [0..fromIntegral len-1] (peekCPUInfoOff p)) + +peekCPUInfoOff :: Ptr CPUInfo -> Int -> IO CPUInfo +peekCPUInfoOff p off = do + let p' = p `plusPtr` (off * (#size uv_cpu_info_t)) + model <- fromCString =<< (#peek uv_cpu_info_t, model) p' + speed <- (#peek uv_cpu_info_t, speed) p' + user <- (#peek uv_cpu_info_t, cpu_times.user) p' + nice <- (#peek uv_cpu_info_t, cpu_times.nice) p' + sys <- (#peek uv_cpu_info_t, cpu_times.sys) p' + idle <- (#peek uv_cpu_info_t, cpu_times.idle) p' + irq <- (#peek uv_cpu_info_t, cpu_times.irq) p' + return (CPUInfo model speed user nice sys idle irq) + +foreign import ccall unsafe uv_loadavg :: MBA## (Double, Double, Double) -> IO () + +-- | Gets the load average. See: +getLoadAvg :: IO (Double, Double, Double) +getLoadAvg = do + (arr, _) <- allocPrimArrayUnsafe 3 uv_loadavg + return ( indexPrimArray arr 0 + , indexPrimArray arr 1 + , indexPrimArray arr 2)