diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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//net/tcp` parser (thanks Maarten) +* Add simple tests. diff --git a/System/Linux/Proc.hs b/System/Linux/Proc.hs new file mode 100644 --- /dev/null +++ b/System/Linux/Proc.hs @@ -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 diff --git a/System/Linux/Proc/Errors.hs b/System/Linux/Proc/Errors.hs --- a/System/Linux/Proc/Errors.hs +++ b/System/Linux/Proc/Errors.hs @@ -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, "'" ] diff --git a/System/Linux/Proc/MemInfo.hs b/System/Linux/Proc/MemInfo.hs --- a/System/Linux/Proc/MemInfo.hs +++ b/System/Linux/Proc/MemInfo.hs @@ -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 diff --git a/System/Linux/Proc/Process.hs b/System/Linux/Proc/Process.hs --- a/System/Linux/Proc/Process.hs +++ b/System/Linux/Proc/Process.hs @@ -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" diff --git a/System/Linux/Proc/Tcp.hs b/System/Linux/Proc/Tcp.hs new file mode 100644 --- /dev/null +++ b/System/Linux/Proc/Tcp.hs @@ -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//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//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) diff --git a/system-linux-proc.cabal b/system-linux-proc.cabal --- a/system-linux-proc.cabal +++ b/system-linux-proc.cabal @@ -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 diff --git a/test/Test/System/Linux/Proc.hs b/test/Test/System/Linux/Proc.hs new file mode 100644 --- /dev/null +++ b/test/Test/System/Linux/Proc.hs @@ -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 diff --git a/test/Test/System/Linux/Proc/Hedgehog.hs b/test/Test/System/Linux/Proc/Hedgehog.hs new file mode 100644 --- /dev/null +++ b/test/Test/System/Linux/Proc/Hedgehog.hs @@ -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 diff --git a/test/test-io.hs b/test/test-io.hs --- a/test/test-io.hs +++ b/test/test-io.hs @@ -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 + ] +