Commits

Maxime Henrion committed 25e7ae6

Initial import of the bsd-sysctl 1.0.0 release.

Comments (0)

Files changed (7)

+Copyright (c) 2009 Maxime Henrion <mhenrion@gmail.com>
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.
+import Distribution.Simple
+
+main = defaultMain

System/BSD/Sysctl.hsc

+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+-- vim:filetype=haskell
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.BSD.Sysctl
+-- Copyright   :  (c) Maxime Henrion 2009
+-- License     :  see LICENSE
+-- 
+-- Maintainer  :  mhenrion@gmail.com
+-- Stability   :  stable
+-- Portability :  portable
+--
+-- This module allows access to the BSD sysctl(3) interface via the Haskell FFI.
+--
+-- Convenience functions to read and write the usual sysctl types are provided,
+-- as well as more advanced functions to handle binary values given a suitable
+-- Storable instance.  It is also possible to retrieve data whose size changes
+-- at runtime with the 'sysctlPeekArray' function.
+--
+-- Nodes may be queried either by their name, their OID as a list of 'Int's, or
+-- by an OID returned by 'sysctlNameToOid' if speed is a concern.
+-------------------------------------------------------------------------------
+
+#include <sys/param.h>
+#include <sys/sysctl.h>
+module System.BSD.Sysctl (
+  -- * The data types
+  SysctlKey,		-- The class of types that can be used to identify a node
+  OID,			-- The @OID@ datatype identifies a sysctl node
+
+  -- * Name to OID conversion
+  sysctlNameToOid,	-- :: String -> IO OID
+
+  -- * Basic reading functions
+  sysctlReadInt,	-- :: SysctlKey k => k -> IO #{type int}
+  sysctlReadUInt,	-- :: SysctlKey k => k -> IO #{type unsigned int}
+  sysctlReadLong,	-- :: SysctlKey k => k -> IO #{type long}
+  sysctlReadULong,	-- :: SysctlKey k => k -> IO #{type unsigned long}
+  sysctlReadQuad,	-- :: SysctlKey k => k -> IO Int64
+  sysctlReadUQuad,	-- :: SysctlKey k => k -> IO Word64
+  sysctlReadString,	-- :: SysctlKey k => k -> IO String
+
+  -- * Advanced reading functions
+  sysctlPeek,		-- :: forall k a. (SysctlKey k, Storable a) => k -> IO a
+  sysctlPeekArray,	-- :: forall k a. (SysctlKey k, Storable a) => k -> IO [a]
+
+  -- * Basic writing functions
+  sysctlWriteInt,	-- :: SysctlKey k => k -> #{type int} -> IO ()
+  sysctlWriteUInt,	-- :: SysctlKey k => k -> #{type unsigned int} -> IO ()
+  sysctlWriteLong,	-- :: SysctlKey k => k -> #{type long} -> IO ()
+  sysctlWriteULong,	-- :: SysctlKey k => k -> #{type unsigned long} -> IO ()
+  sysctlWriteQuad,	-- :: SysctlKey k => k -> Int64 -> IO ()
+  sysctlWriteUQuad,	-- :: SysctlKey k => k -> Word64 -> IO ()
+  sysctlWriteString,	-- :: SysctlKey k => k -> String -> IO ()
+
+  -- * Advanced writing functions
+  sysctlPoke		-- :: (SysctlKey k, Storable a) => k -> a -> IO ()
+  ) where
+
+import Control.Arrow (second)
+import Data.Int
+import Data.Word
+
+import Foreign.Ptr
+import Foreign.C
+import Foreign.Marshal
+import Foreign.Storable
+import Foreign.ForeignPtr
+
+data OID = OID {-# UNPACK #-} !(ForeignPtr CInt)
+               {-# UNPACK #-} !CUInt
+
+class SysctlKey k where
+  withKey :: k -> (Ptr CInt -> CUInt -> IO a) -> IO a
+
+instance SysctlKey OID where
+  withKey (OID fp len) f = withForeignPtr fp (\ptr -> f ptr len)
+
+instance SysctlKey String where
+  withKey name f = sysctlNameToOid name >>= flip withKey f
+
+instance SysctlKey [Int] where
+  withKey oid f = withArrayLen (map fromIntegral oid)
+                               (\len ptr -> f ptr (fromIntegral len))
+
+foreign import ccall unsafe "sysctl"
+  c_sysctl :: Ptr CInt -> CUInt -> Ptr a -> Ptr CSize -> Ptr b -> CSize -> IO CInt
+
+foreign import ccall unsafe "sysctlnametomib"
+  c_sysctlnametomib :: CString -> Ptr CInt -> Ptr CSize -> IO CInt
+
+-- Call sysctl with a size set to 0 to retrieve the size of the object.
+sysctlGetSize :: Ptr CInt -> CUInt -> IO CSize
+sysctlGetSize oid len = sysctlRead oid len nullPtr 0 (const return)
+
+-- Get the OID corresponding to a sysctl name.
+sysctlNameToOid :: String -> IO OID
+sysctlNameToOid name =
+  withCString name $ \cname -> do
+    fp  <- mallocForeignPtrArray (fromIntegral maxlen)
+    len <- withForeignPtr fp $ \oid ->
+             alloca $ \sizePtr -> do
+               poke sizePtr maxlen
+               throwErrnoIfMinus1_ "sysctlnametomib"
+                 (c_sysctlnametomib cname oid sizePtr)
+               peek sizePtr
+    return (OID fp (fromIntegral len))
+  where maxlen = #{const CTL_MAXNAME}
+
+{-
+-- This could be used to implement some form of type checking at runtime some
+-- day, but the interface is undocumented and probably unportable though.
+oidToType :: Ptr CInt -> CUInt -> IO (CUInt, String)
+oidToType oid len =
+  let len' = len + 2 in
+    allocaArray (fromIntegral len') $ \oid' ->
+      allocaBytes defaultBufSize $ \buf ->
+        alloca $ \sizePtr ->
+          do poke oid' 0
+             poke (oid' `advancePtr` 1) 4
+             copyArray (oid' `advancePtr` 2) oid (fromIntegral len)
+             poke sizePtr (fromIntegral defaultBufSize)
+             throwErrnoIfMinus1_ "sysctl"
+               (c_sysctl oid' len' buf sizePtr nullPtr 0)
+             kind <- peek buf
+             fmt  <- peekCString (buf `plusPtr` (sizeOf kind))
+             return (kind, fmt)
+  where defaultBufSize = 1024 -- as in FreeBSD's libc
+-}
+
+-- Base primitive for all reading operations.  Abstracts away the low-level C
+-- machinery such as using a pointer to have multiple return values.
+sysctlRead :: Ptr CInt -> CUInt -> Ptr a -> CSize -> (Ptr a -> CSize -> IO b) -> IO b
+sysctlRead oid len buf size f =
+  alloca $ \sizePtr -> do
+    poke sizePtr size
+    throwErrnoIfMinus1_ "sysctl"
+      (c_sysctl oid len buf sizePtr nullPtr 0)
+    realSize <- peek sizePtr
+    f buf realSize
+
+-- Read a sysctl value that is an instance of Storable.
+sysctlPeek :: forall k a. (SysctlKey k, Storable a) => k -> IO a
+sysctlPeek key =
+  withKey key $ \oid len ->
+    alloca $ \buf ->
+      sysctlRead oid len buf (fromIntegral (sizeOf (undefined::a)))
+                 (const . peek)
+
+sysctlReadInt :: SysctlKey k => k -> IO #{type int}
+sysctlReadInt = sysctlPeek
+
+sysctlReadUInt :: SysctlKey k => k -> IO #{type unsigned int}
+sysctlReadUInt = sysctlPeek
+
+sysctlReadLong :: SysctlKey k => k -> IO #{type long}
+sysctlReadLong = sysctlPeek
+
+sysctlReadULong :: SysctlKey k => k -> IO #{type unsigned long}
+sysctlReadULong = sysctlPeek
+
+sysctlReadQuad :: SysctlKey k => k -> IO Int64
+sysctlReadQuad = sysctlPeek
+
+sysctlReadUQuad :: SysctlKey k => k -> IO Word64
+sysctlReadUQuad = sysctlPeek
+
+-- Useful specialisation of sysctlRead for when the size of the data isn't
+-- statically known, and also potentially variable with time.
+sysctlReadDynamic :: SysctlKey k => k -> (CSize -> CSize) -> (Ptr a -> CSize -> IO b) -> IO b
+sysctlReadDynamic key scale f =
+  withKey key $ \oid len -> do
+    size <- sysctlGetSize oid len
+    let bufSize = scale size	-- Allows to make room for lists of variable length
+    allocaBytes (fromIntegral bufSize) $ \buf ->
+      sysctlRead oid len buf bufSize f
+
+-- Retrieve a variable number of elements from a sysctl.
+sysctlPeekArray :: forall k a. (SysctlKey k, Storable a) => k -> IO [a]
+sysctlPeekArray key =
+  sysctlReadDynamic key (*2) $ \buf size ->
+    peekArray (fromIntegral size `div` sizeOf (undefined::a)) buf
+
+-- Read a String from a sysctl.  If the string can possibly change with
+-- time, use sysctlPeekArray instead.
+sysctlReadString :: SysctlKey k => k -> IO String
+sysctlReadString key =
+  sysctlReadDynamic key id (curry (peekCStringLen . second ((subtract 1) . fromIntegral)))
+
+-- Base primitive for all writing operations.
+sysctlWrite :: Ptr CInt -> CUInt -> Ptr a -> CSize -> IO ()
+sysctlWrite oid len buf size =
+  throwErrnoIfMinus1_ "sysctl" (c_sysctl oid len nullPtr nullPtr buf size)
+
+sysctlPoke :: (SysctlKey k, Storable a) => k -> a -> IO ()
+sysctlPoke key x =
+  withKey key $ \oid len ->
+    with x $ \buf -> sysctlWrite oid len buf (fromIntegral (sizeOf buf))
+
+sysctlWriteInt :: SysctlKey k => k -> #{type int} -> IO ()
+sysctlWriteInt = sysctlPoke
+
+sysctlWriteUInt :: SysctlKey k => k -> #{type unsigned int} -> IO ()
+sysctlWriteUInt = sysctlPoke
+
+sysctlWriteLong :: SysctlKey k => k -> #{type long} -> IO ()
+sysctlWriteLong = sysctlPoke
+
+sysctlWriteULong :: SysctlKey k => k -> #{type unsigned long} -> IO ()
+sysctlWriteULong = sysctlPoke
+
+sysctlWriteQuad :: SysctlKey k => k -> Int64 -> IO ()
+sysctlWriteQuad = sysctlPoke
+
+sysctlWriteUQuad :: SysctlKey k => k -> Word64 -> IO ()
+sysctlWriteUQuad = sysctlPoke
+
+sysctlWriteString :: SysctlKey k => k -> String -> IO ()
+sysctlWriteString key s =
+  withKey key $ \oid len ->
+    withCStringLen s $ \(cs,slen) -> sysctlWrite oid len cs (fromIntegral slen)
+Name:		bsd-sysctl
+Version:	1.0.0
+License-File:	LICENSE
+License:	BSD3
+Author:		Maxime Henrion
+Copyright:	2009, Maxime Henrion
+Maintainer:	Maxime Henrion <mhenrion@gmail.com>
+Category:	System
+Synopsis:	Access to the BSD sysctl(3) interface
+Description:	This module provides efficient access to the BSD sysctl(3)
+                interface via the Haskell FFI.  It allows to read and write
+                both basic sysctl types, as well as complex opaque types
+                described via Storable instances.
+Build-Type:	Simple
+Cabal-Version:	>= 1.2
+Tested-with:	GHC ==6.10
+Data-Files:	demo/Demo.hsc demo/demo.cabal demo/demo.output
+
+Library
+  Build-Depends:	base
+  Exposed-Modules:	System.BSD.Sysctl
+  Extensions:		ForeignFunctionInterface, ScopedTypeVariables,
+                        TypeSynonymInstances, FlexibleInstances
+  GHC-Options:		-Wall -O2 -funbox-strict-fields
+#include <sys/types.h>
+#include <sys/user.h>
+#include <sys/time.h>
+#include <sys/sysctl.h>
+-- vim:filetype=haskell
+module Main where
+
+import System.BSD.Sysctl
+import System.Posix.Types
+import Foreign.C
+import Foreign.Ptr
+import Foreign.Storable
+
+-- This demo program is designed to run on FreeBSD; other BSD systems
+-- are likely to have different names and/or types for these sysctls.
+
+data TimeVal = TimeVal CTime CLong
+
+instance Storable TimeVal where
+  sizeOf _    = #{size struct timeval}
+  alignment _ = alignment (undefined::CTime)
+  peek ptr    = do sec  <- #{peek struct timeval, tv_sec} ptr
+                   usec <- #{peek struct timeval, tv_usec} ptr
+                   return (TimeVal sec usec)
+
+instance Show TimeVal where
+  showsPrec p (TimeVal sec usec) = showString "{ usec = " .
+                                   showsPrec p sec .
+                                   showString ", usec = " .
+                                   showsPrec p usec .
+                                   showString " }"
+
+data Proc = Proc CPid CUid String
+
+instance Storable Proc where
+  sizeOf _    = #{size struct kinfo_proc}
+  alignment _ = alignment (undefined::CInt)
+  peek ptr    = do pid <- #{peek struct kinfo_proc, ki_pid} ptr
+                   uid <- #{peek struct kinfo_proc, ki_uid} ptr
+                   cmd <- peekCString (#{ptr struct kinfo_proc, ki_comm} ptr)
+                   return (Proc pid uid cmd )
+
+instance Show Proc where
+  showsPrec p (Proc pid uid cmd) = showsPrec p pid .
+                                   showString "\t" .
+                                   showsPrec p uid .
+                                   showString ('\t':cmd)
+
+main :: IO ()
+main = do osrelease <- sysctlReadString "kern.osrelease"
+          putStrLn ("kern.osrelease: " ++ osrelease)
+          tv <- sysctlPeek "kern.boottime" :: IO TimeVal
+          putStrLn ("kern.boottime: " ++ show tv)
+          maxfiles <- sysctlNameToOid "kern.maxfiles" >>= sysctlReadInt
+          putStrLn ("kern.maxfiles: " ++ show maxfiles)
+          lastpid <- sysctlReadInt "kern.lastpid"
+          putStrLn ("kern.lastpid: " ++ show lastpid)
+          numvnodes <- sysctlReadLong "vfs.numvnodes"
+          putStrLn ("vfs.numvnodes: " ++ show numvnodes)
+          recvspace <- sysctlReadULong "net.inet.tcp.recvspace"
+          putStrLn ("net.inet.tcp.recvspace: " ++ show recvspace)
+          procs <- sysctlPeekArray "kern.proc.all" :: IO [Proc]
+          putStrLn "PID\tUID\tCOMMAND"
+          mapM_ print procs
+          sysctlWriteInt "vfs.usermount" 0 -- Will explode if not root
+Name: demo
+Version: 0.0
+Build-Depends: base, bsd-sysctl
+Build-Type: Simple
+Executable: demo
+Main-is: Demo.hs
+kern.osrelease: 7.2-PRERELEASE
+kern.boottime: { usec = 1241115805, usec = 736670 }
+kern.maxfiles: 32768
+kern.lastpid: 90199
+vfs.numvnodes: 45973
+net.inet.tcp.recvspace: 65536
+PID	UID	COMMAND
+90199	1001	demo
+89970	1001	vim
+89593	1001	zsh
+87861	1001	screen
+87841	1001	ssh
+[...lots of lines removed...]
+test: sysctl: permission denied (Operation not permitted)