system-linux-proc 0.1.0.3 → 0.1.1
raw patch · 10 files changed
+354/−45 lines, 10 filesdep +pretty-showdep +system-linux-procdep ~directorydep ~errorsdep ~hedgehog
Dependencies added: pretty-show, system-linux-proc
Dependency ranges changed: directory, errors, hedgehog
Files
- ChangeLog.md +3/−2
- System/Linux/Proc.hs +9/−0
- System/Linux/Proc/Errors.hs +6/−6
- System/Linux/Proc/MemInfo.hs +42/−24
- System/Linux/Proc/Process.hs +3/−7
- System/Linux/Proc/Tcp.hs +182/−0
- system-linux-proc.cabal +13/−5
- test/Test/System/Linux/Proc.hs +50/−0
- test/Test/System/Linux/Proc/Hedgehog.hs +36/−0
- test/test-io.hs +10/−1
ChangeLog.md view
@@ -1,5 +1,6 @@ # Revision history for system-linux-memory -## 0.1.0.0 -- YYYY-mm-dd+## 0.1.1.0 -- 2020-04-04 -* First version. Released on an unsuspecting world.+* Add `/proc/<pid>/net/tcp` parser (thanks Maarten)+* Add simple tests.
+ System/Linux/Proc.hs view
@@ -0,0 +1,9 @@+module System.Linux.Proc+ ( module X+ ) where++import System.Linux.Proc.Errors as X+import System.Linux.Proc.IO as X+import System.Linux.Proc.MemInfo as X+import System.Linux.Proc.Process as X+import System.Linux.Proc.Tcp as X
System/Linux/Proc/Errors.hs view
@@ -7,7 +7,7 @@ ) where import Data.Text (Text)-import qualified Data.Text as T+import qualified Data.Text as Text data ProcError@@ -18,11 +18,11 @@ renderProcError :: ProcError -> Text renderProcError = \case- ProcReadError fp msg -> T.concat- [ "Error reading '", T.pack fp, "': ", msg ]- ProcParseError fp msg -> T.concat- [ "Parser error on file '", T.pack fp, ": ", msg ]- ProcMemInfoKeyError key -> T.concat+ ProcReadError fp msg -> mconcat+ [ "Error reading '", Text.pack fp, "': ", msg ]+ ProcParseError fp msg -> mconcat+ [ "Parser error on file '", Text.pack fp, ": ", msg ]+ ProcMemInfoKeyError key -> mconcat [ "MemInfo: Key not found: '", key, "'" ]
System/Linux/Proc/MemInfo.hs view
@@ -5,19 +5,22 @@ , readProcMemInfo , readProcMemInfoKey , readProcMemUsage+ , renderSizeBytes ) where import Control.Error (ExceptT (..), fromMaybe, runExceptT, throwE) import Data.Attoparsec.ByteString.Char8 (Parser)-import qualified Data.Attoparsec.ByteString.Char8 as A+import qualified Data.Attoparsec.ByteString.Char8 as Atto import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS -import qualified Data.List as DL-import qualified Data.Map.Strict as DM+import qualified Data.List as List+import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe)-import qualified Data.Text as T+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as Text import Data.Word (Word64) import System.Linux.Proc.IO@@ -45,8 +48,8 @@ readProcMemInfo = runExceptT $ do bs <- readProcFile fpMemInfo- case A.parseOnly parseFields bs of- Left e -> throwE $ ProcParseError fpMemInfo (T.pack e)+ case Atto.parseOnly parseFields bs of+ Left e -> throwE $ ProcParseError fpMemInfo (Text.pack e) Right xs -> pure $ construct xs -- | Read `/proc/meminfo` file and return a value calculated from:@@ -59,13 +62,13 @@ readProcMemUsage = runExceptT $ do xs <- BS.lines <$> readProcFile fpMemInfo- pure . convert $ DL.foldl' getValues (0, 1) xs+ pure . convert $ List.foldl' getValues (0, 1) xs where getValues :: (Word64, Word64) -> ByteString -> (Word64, Word64) getValues (avail, total) bs = case BS.break (== ':') bs of- ("MemTotal", rest) -> (avail, fromEither total $ A.parseOnly pValue rest)- ("MemAvailable", rest) -> (fromEither avail $ A.parseOnly pValue rest, total)+ ("MemTotal", rest) -> (avail, fromEither total $ Atto.parseOnly pValue rest)+ ("MemAvailable", rest) -> (fromEither avail $ Atto.parseOnly pValue rest, total) _ -> (avail, total) convert :: (Word64, Word64) -> Double@@ -83,12 +86,27 @@ findValue :: ByteString -> Maybe Word64 findValue bs = let (key, rest) = BS.break (== ':') bs in- if key /= target + if key /= target then Nothing- else either (const Nothing) Just $ A.parseOnly pValue rest+ else either (const Nothing) Just $ Atto.parseOnly pValue rest keyError :: ProcError- keyError = ProcMemInfoKeyError $ T.pack (BS.unpack target)+ keyError = ProcMemInfoKeyError $ Text.pack (BS.unpack target) +-- | Render a Word64 as an easy to read size with a bytes, kB, MB, GB TB or PB+-- suffix.+renderSizeBytes :: Word64 -> Text+renderSizeBytes s+ | d >= 1e15 = render (d * 1e15) <> " PB"+ | d >= 1e12 = render (d * 1e12) <> " TB"+ | d >= 1e12 = render (d * 1e12) <> " TB"+ | d >= 1e9 = render (d * 1e-9) <> " GB"+ | d >= 1e6 = render (d * 1e-6) <> " MB"+ | d >= 1e3 = render (d * 1e-3) <> " kB"+ | otherwise = Text.pack (show s) <> " bytes"+ where+ d = fromIntegral s :: Double+ render = Text.pack . List.take 5 . show+ -- ----------------------------------------------------------------------------- -- Internals. @@ -108,21 +126,21 @@ construct :: [(ByteString, Word64)] -> MemInfo construct xs = MemInfo- (fromMaybe 0 $ DM.lookup "MemTotal" mp)- (fromMaybe 0 $ DM.lookup "MemFree" mp)- (fromMaybe 0 $ DM.lookup "MemAvailable" mp)- (fromMaybe 0 $ DM.lookup "Buffers" mp)- (fromMaybe 0 $ DM.lookup "SwapTotal" mp)- (fromMaybe 0 $ DM.lookup "SwapFree" mp)+ (fromMaybe 0 $ Map.lookup "MemTotal" mp)+ (fromMaybe 0 $ Map.lookup "MemFree" mp)+ (fromMaybe 0 $ Map.lookup "MemAvailable" mp)+ (fromMaybe 0 $ Map.lookup "Buffers" mp)+ (fromMaybe 0 $ Map.lookup "SwapTotal" mp)+ (fromMaybe 0 $ Map.lookup "SwapFree" mp) where- mp = DM.fromList xs+ mp = Map.fromList xs -- ----------------------------------------------------------------------------- -- Parsers. parseFields :: Parser [(ByteString, Word64)] parseFields =- A.many1 (pFieldValue <* A.endOfLine)+ Atto.many1 (pFieldValue <* Atto.endOfLine) {-@@ -143,13 +161,13 @@ pName :: Parser ByteString pName =- A.takeWhile (/= ':')+ Atto.takeWhile (/= ':') pValue :: Parser Word64 pValue = do- val <- A.char ':' *> A.skipSpace *> A.decimal- A.skipSpace- rest <- A.takeWhile (not . A.isSpace)+ val <- Atto.char ':' *> Atto.skipSpace *> Atto.decimal+ Atto.skipSpace+ rest <- Atto.takeWhile (not . Atto.isSpace) case rest of "" -> pure val "kB" -> pure $ 1024 * val
System/Linux/Proc/Process.hs view
@@ -12,6 +12,8 @@ import System.Linux.Proc.IO import System.Linux.Proc.Errors +import Text.Read (readMaybe)+ newtype ProcessId = ProcessId { unProcessId :: Int } deriving (Eq, Show)@@ -20,10 +22,4 @@ getProcProcessIds :: IO (Either ProcError [ProcessId]) getProcProcessIds = runExceptT $- mapMaybe maybeProcessId <$> listProcDirectory "/proc"- where- maybeProcessId :: String -> Maybe ProcessId- maybeProcessId str =- case reads str of- [(i, "")] -> Just $ ProcessId i- _ -> Nothing+ mapMaybe (fmap ProcessId . readMaybe) <$> listProcDirectory "/proc"
+ System/Linux/Proc/Tcp.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE OverloadedStrings #-}++module System.Linux.Proc.Tcp+ ( TcpSocket (..)+ , TcpState (..)+ , readProcTcpSockets+ )+ where++import Control.Error (runExceptT, throwE)+import Control.Monad (replicateM, void)++import Data.Attoparsec.ByteString.Char8 (Parser)+import qualified Data.Attoparsec.ByteString.Char8 as Atto+import Data.Bits ((.|.), shiftL)+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS+import qualified Data.List as List+import qualified Data.Text as Text++import System.Linux.Proc.Errors (ProcError (..))+import System.Linux.Proc.Process (ProcessId (..))+import System.Linux.Proc.IO (readProcFile)++++data TcpState+ = TcpEstablished+ | TcpSynSent+ | TcpSynReceive+ | TcpFinWait1+ | TcpFinWait2+ | TcpTimeWait+ | TcpClose+ | TcpCloseWait+ | TcpLastAck+ | TcpListen+ | TcpClosing+ | TcpNewSynReceive+ deriving (Show, Eq)++-- | TCP socket used by a process according to the `/proc/<pid>/net/tcp`+-- file of the process. Only non-debug fields are parsed and described the socket+-- data structure.+data TcpSocket = TcpSocket+ { tcpLocalAddr :: !(ByteString, Int)+ , tcpRemoteAddr :: !(ByteString, Int)+ , tcpTcpState :: !TcpState+ , tcpUid :: !Int+ , tcpInode :: !Int+ } deriving (Show)+++-- | Read and parse the `/proc/<pid>/net/tcp` file. Read and parse errors are caught+-- and returned.+readProcTcpSockets :: ProcessId -> IO (Either ProcError [TcpSocket])+readProcTcpSockets pid =+ runExceptT $ do+ let fpath = mkNetTcpPath pid+ bs <- readProcFile fpath+ case Atto.parseOnly (pTcpSocketList <* Atto.endOfInput) bs of+ Left e -> throwE $ ProcParseError fpath (Text.pack e)+ Right ss -> pure ss+++-- -----------------------------------------------------------------------------+-- Internals.++mkNetTcpPath :: ProcessId -> FilePath+mkNetTcpPath (ProcessId pid) = "/proc/" ++ show pid ++ "/net/tcp"++-- -----------------------------------------------------------------------------+-- Parsers.++pTcpSocketList :: Parser [TcpSocket]+pTcpSocketList = pHeaders *> Atto.many' pTcpSocket++-- Parse a single pSpace. The net/tcp file does not use tabs. Attoparsec's pSpace+-- includes tab, newline and return feed which captures too much in our case.+pSpace :: Parser Char+pSpace = Atto.char ' '++pMany1Space :: Parser ()+pMany1Space = void $ Atto.many1 pSpace++pStringSpace :: ByteString -> Parser ()+pStringSpace s =+ Atto.string s *> pMany1Space++pHeaders :: Parser ()+pHeaders =+ pMany1Space+ *> pStringSpace "sl"+ *> pStringSpace "local_address"+ *> pStringSpace "rem_address"+ *> pStringSpace "st"+ *> pStringSpace "tx_queue"+ *> pStringSpace "rx_queue"+ *> pStringSpace "tr"+ *> pStringSpace "tm->when"+ *> pStringSpace "retrnsmt"+ *> pStringSpace "uid"+ *> pStringSpace "timeout inode"+ <* Atto.endOfLine++pTcpSocket :: Parser TcpSocket+pTcpSocket = do+ _ <- pMany1Space+ _ <- (Atto.many1 Atto.digit *> Atto.char ':') <* pMany1Space -- Parse kernel slot+ localAddr <- pAddressPort <* pMany1Space+ remoteAddr <- pAddressPort <* pMany1Space+ tcpState <- pTcpState <* pMany1Space+ _ <- pInternalData+ uid <- Atto.decimal <* pMany1Space+ _ <- Atto.hexadecimal <* pMany1Space :: Parser Int -- internal kernel state+ inode <- Atto.decimal <* pMany1Space :: Parser Int+ _ <- Atto.many1 (Atto.satisfy (/= '\n')) -- remaining internal state+ _ <- Atto.endOfLine+ pure $ TcpSocket localAddr remoteAddr tcpState uid inode++pInternalData :: Parser ()+pInternalData = do+ _ <- Atto.hexadecimal :: Parser Int -- outgoing data queue+ _ <- Atto.char ':'+ _ <- Atto.hexadecimal :: Parser Int -- incoming data queue+ _ <- Atto.many1 pSpace+ _ <- Atto.hexadecimal :: Parser Int -- internal kernel state+ _ <- Atto.char ':'+ _ <- Atto.hexadecimal :: Parser Int -- internal kernel state+ _ <- Atto.many1 pSpace+ _ <- Atto.hexadecimal :: Parser Int -- internal kernel state+ _ <- Atto.many1 pSpace+ pure ()++-- The address parts of the `net/tcp` file is a hexadecimal representation of the IP+-- address and the port. The octets of the IP address have been reversed: 127.0.0.1+-- has been reversed to 1.0.0.127 and then rendered as hex numbers. The port is only+-- rendered as a hex number; it's not been reversed.+pAddressPort :: Parser (ByteString, Int)+pAddressPort = do+ addrParts <- replicateM 4 $ pHexadecimalOfLength 2+ _ <- Atto.char ':'+ port <- pHexadecimalOfLength 4+ let addr' =+ BS.concat . List.intersperse "." . fmap (BS.pack . show) $ reverse addrParts+ pure (addr', port)++-- See include/net/tcp_states.h of your kernel's source code for all possible states.+pTcpState :: Parser TcpState+pTcpState =+ lookupState <$> (Atto.char '0' *> Atto.anyChar)+ where+ lookupState :: Char -> TcpState+ lookupState '1' = TcpEstablished+ lookupState '2' = TcpSynSent+ lookupState '3' = TcpSynReceive+ lookupState '4' = TcpFinWait1+ lookupState '5' = TcpFinWait2+ lookupState '6' = TcpTimeWait+ lookupState '7' = TcpClose+ lookupState '8' = TcpCloseWait+ lookupState '9' = TcpLastAck+ lookupState 'A' = TcpListen+ lookupState 'B' = TcpClosing+ lookupState 'C' = TcpNewSynReceive+ lookupState c = error $ "System.Linux.Proc.Tcp.pTcpState: " ++ show c++-- Helper parser for hexadecimal strings of a known length. Attoparsec's hexadecimal+-- will keep parsing digits to cover cases like '1', 'AB2', 'deadbeef', etc. In our+-- case we need to parse cases of exact length like port numbers.+pHexadecimalOfLength :: Int -> Parser Int+pHexadecimalOfLength n = do+ ds <- Atto.count n (Atto.satisfy (isHexDigit . fromEnum))+ return $ foldl step 0 (fmap (fromEnum :: Char -> Int) ds)+ where+ isHexDigit :: Int -> Bool+ isHexDigit w =+ (w >= 48 && w <= 57) || (w >= 97 && w <= 102) || (w >= 65 && w <= 70)+ step :: Int -> Int -> Int+ step a w | w >= 48 && w <= 57 = (a `shiftL` 4) .|. (w - 48)+ | w >= 97 = (a `shiftL` 4) .|. (w - 87)+ | otherwise = (a `shiftL` 4) .|. (w - 55)
system-linux-proc.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: system-linux-proc-version: 0.1.0.3+version: 0.1.1 synopsis: A library for accessing the /proc filesystem in Linux -- description: homepage: https://github.com/erikd/system-linux-proc@@ -22,17 +22,19 @@ ghc-options: -Wall -fwarn-tabs hs-source-dirs: . - exposed-modules: System.Linux.Proc.Errors+ exposed-modules: System.Linux.Proc+ , System.Linux.Proc.Errors , System.Linux.Proc.IO , System.Linux.Proc.MemInfo , System.Linux.Proc.Process+ , System.Linux.Proc.Tcp build-depends: base >= 4.8 && < 5.0 , attoparsec >= 0.12 && < 0.14 , bytestring == 0.10.* , containers == 0.5.* , directory >= 1.2 && < 1.4- , errors == 2.2.*+ , errors == 2.3.* , text == 1.2.* test-suite test@@ -40,8 +42,14 @@ ghc-options: -Wall -fwarn-tabs -threaded -O2 type: exitcode-stdio-1.0 - main-is: test-io.hs hs-source-dirs: test+ main-is: test-io.hs + other-modules: Test.System.Linux.Proc+ Test.System.Linux.Proc.Hedgehog+ build-depends: base >= 4.8 && < 5.0- , hedgehog+ , directory == 1.3.*+ , hedgehog == 1.0.*+ , pretty-show == 1.10.*+ , system-linux-proc
+ test/Test/System/Linux/Proc.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Test.System.Linux.Proc+ ( tests+ ) where++import Control.Monad.IO.Class (liftIO)++import Data.Either (isRight)++import Hedgehog (Property, discover)+import qualified Hedgehog as H+import qualified Hedgehog.Gen as Gen++import System.Linux.Proc++import Test.System.Linux.Proc.Hedgehog++prop_read_MemInfo :: Property+prop_read_MemInfo =+ propertyWithTests 10 $ do+ mi <- H.evalEither =<< liftIO readProcMemInfo+ assertShow mi (memTotal mi > memAvailable mi)+ assertShow mi (memTotal mi > memFree mi)+ assertShow mi (memTotal mi > memBuffers mi)+ assertShow mi (memSwapTotal mi >= memSwapFree mi)++prop_read_ProcessIds :: Property+prop_read_ProcessIds =+ propertyWithTests 10 $ do+ pids <- H.evalEither =<< liftIO getProcProcessIds+ assertShow pids (length pids > 0)++prop_read_process_tcp :: Property+prop_read_process_tcp =+ propertyWithTests 50 $ do+ pids <- H.evalEither =<< liftIO getProcProcessIds+ pid <- H.forAll $ Gen.element pids+ eTcp <- liftIO $ readProcTcpSockets pid+ case eTcp of+ Left (ProcReadError {}) -> H.success -- Ignore pid that do not have a tcp entry.+ Left _ -> H.failure+ Right _tcp -> H.success -- Is there anything we can check here?+ H.cover 80 " interesting" (isRight eTcp)++-- -----------------------------------------------------------------------------++tests :: IO Bool+tests =+ H.checkParallel $$discover
+ test/Test/System/Linux/Proc/Hedgehog.hs view
@@ -0,0 +1,36 @@+module Test.System.Linux.Proc.Hedgehog+ ( assertShow+ , predicate+ , predicate2+ , propertyWithTests+ ) where++import GHC.Stack (HasCallStack, withFrozenCallStack)++import Hedgehog (Property, PropertyT, TestLimit,+ diff, property, success, withTests)+import Hedgehog.Internal.Property (MonadTest, eval, failWith)++import Text.Show.Pretty (ppShow)++assertShow :: (MonadTest m, HasCallStack, Show a) => a -> Bool -> m ()+assertShow a b =+ if b then+ success+ else+ withFrozenCallStack $ failWith Nothing (ppShow a)++predicate :: (MonadTest m, HasCallStack, Show a) => a -> (a -> Bool) -> m ()+predicate a prd = do+ ok <- withFrozenCallStack $ eval (prd a)+ if ok then+ success+ else+ withFrozenCallStack $ failWith Nothing (ppShow a)++predicate2 :: (MonadTest m, HasCallStack, Show a) => a -> a -> (a -> a -> Bool) -> m ()+predicate2 a b prd =+ withFrozenCallStack $ diff a prd b++propertyWithTests :: TestLimit -> PropertyT IO () -> Property+propertyWithTests n = withTests n . property
test/test-io.hs view
@@ -1,2 +1,11 @@++import Hedgehog.Main (defaultMain)+import qualified Test.System.Linux.Proc++ main :: IO ()-main = putStrLn "Need more tests."+main =+ defaultMain+ [ Test.System.Linux.Proc.tests+ ]+