diff --git a/Makefile b/Makefile index 9e04261..b190fa4 100644 --- a/Makefile +++ b/Makefile @@ -6,6 +6,7 @@ EXAMPLE_PROGRAMS += $(EXAMPLE_DST)/hello-linux-i386 EXAMPLE_PROGRAMS += $(EXAMPLE_DST)/hello-linux-i386-elf64 EXAMPLE_PROGRAMS += $(EXAMPLE_DST)/hello-linux-x86_64 EXAMPLE_PROGRAMS += $(EXAMPLE_DST)/symlinkat +EXAMPLE_PROGRAMS += $(EXAMPLE_DST)/poll EXAMPLE_PROGRAMS += $(EXAMPLE_DST)/segfault EXAMPLE_PROGRAMS += $(EXAMPLE_DST)/execve EXAMPLE_PROGRAMS += $(EXAMPLE_DST)/execve-linux-null-envp diff --git a/example-programs/poll.c b/example-programs/poll.c new file mode 100644 index 0000000..24fbd99 --- /dev/null +++ b/example-programs/poll.c @@ -0,0 +1,70 @@ +#ifdef __linux__ +#define USE_POLL_POLLRDHUP +#endif + +#ifdef USE_POLL_POLLRDHUP +#define _GNU_SOURCE +#endif + +#include +#include +#include +#include +#include + +#define TIMEOUT 5 + +void die_usage(void) { + fprintf(stderr, "Usage: poll file\n"); + exit(1); +} + +int main (int argc, char const *argv[]) { + if (argc < 1) { + die_usage(); + } + + struct pollfd fds[3]; + int ret; + int fd = open(argv[1], O_RDWR); + + if (fd < 0) { + perror("could not open provided file"); + return 1; + } + + /* watch stdout for ability to write */ + fds[0].fd = STDOUT_FILENO; +#ifdef USE_POLL_POLLRDHUP + fds[0].events = POLLHUP | POLLOUT | POLLIN | POLLRDHUP; +#else + fds[0].events = POLLHUP | POLLOUT | POLLIN; +#endif + + fds[1].fd = STDIN_FILENO; + fds[1].events = POLLIN; + + fds[2].fd = fd; + fds[2].events = POLLIN | POLLOUT; + + ret = poll(fds, 3, TIMEOUT * 1000); + + if (ret == -1) { + perror("poll returned error"); + return 1; + } + + if (!ret) { + perror("poll timed out before stdout was available for write"); + return 1; + } + + if (fds[0].revents & POLLOUT) { + return 0; + } + + perror("poll returned success response, but stdout is not available for write"); + return 1; + +} + diff --git a/hatrace.cabal b/hatrace.cabal index 827877e..1ef08d7 100644 --- a/hatrace.cabal +++ b/hatrace.cabal @@ -52,6 +52,12 @@ library , unix , unliftio , unliftio-core + if os(linux) + -- On Linux with glibc, POLLRDHUP support must be enabled + -- manually; see `man 2 poll`. We control this with this macro. + -- By the way: musl libc supports POLLRDHUP unconditionally, + -- see https://git.musl-libc.org/cgit/musl/commit/?id=8442358d9dfc78261a5eab1f2cb13861c6e13207 + cpp-options: -DUSE_POLL_POLLRDHUP ghc-options: -Wall default-language: Haskell2010 @@ -83,6 +89,9 @@ test-suite hatrace-test , unliftio , unliftio-core ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + if os(linux) + -- See note on `DUSE_POLL_POLLRDHUP` above. + cpp-options: -DUSE_POLL_POLLRDHUP default-language: Haskell2010 source-repository head diff --git a/src/System/Hatrace.hs b/src/System/Hatrace.hs index 92572dd..2e4f01b 100644 --- a/src/System/Hatrace.hs +++ b/src/System/Hatrace.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} @@ -75,6 +76,8 @@ module System.Hatrace , SyscallExitDetails_set_tid_address(..) , SyscallEnterDetails_sysinfo(..) , SyscallExitDetails_sysinfo(..) + , SyscallEnterDetails_poll(..) + , SyscallExitDetails_poll(..) , DetailedSyscallEnter(..) , DetailedSyscallExit(..) , ERRNO(..) @@ -125,9 +128,10 @@ import Foreign.C.Types (CInt(..), CLong(..), CULong(..), CChar(..), CS import Foreign.ForeignPtr (withForeignPtr) import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Array (withArray) +import qualified Foreign.Marshal.Array (peekArray) import Foreign.Marshal.Utils (withMany) -import Foreign.Ptr (Ptr, nullPtr, wordPtrToPtr) -import Foreign.Storable (peekByteOff, sizeOf) +import Foreign.Ptr (castPtr, Ptr, nullPtr, wordPtrToPtr) +import Foreign.Storable (Storable, peekByteOff, sizeOf) import GHC.Stack (HasCallStack, callStack, getCallStack, prettySrcLoc) import System.Directory (canonicalizePath, doesFileExist, findExecutable) import System.Exit (ExitCode(..), die) @@ -949,6 +953,24 @@ instance SyscallExitFormatting SyscallExitDetails_brk where syscallExitToFormatted SyscallExitDetails_brk{ enterDetail, brkResult } = (syscallEnterToFormatted enterDetail, formatReturn brkResult) +data SyscallEnterDetails_poll = SyscallEnterDetails_poll + { fds :: Ptr PollFdStruct + , nfds :: CULong + , timeout :: CInt + } deriving (Eq, Ord, Show) + +instance SyscallEnterFormatting SyscallEnterDetails_poll where + syscallEnterToFormatted SyscallEnterDetails_poll{ fds, nfds, timeout} = + FormattedSyscall "poll" [formatPtrArg "pollfd" fds, formatArg nfds, formatArg timeout] + +data SyscallExitDetails_poll = SyscallExitDetails_poll + { enterDetail :: SyscallEnterDetails_poll + , pollfds :: [PollFdStruct] + } deriving (Eq, Ord, Show) + +instance SyscallExitFormatting SyscallExitDetails_poll where + syscallExitToFormatted SyscallExitDetails_poll{ enterDetail, pollfds } = + (syscallEnterToFormatted enterDetail, formatReturn pollfds) data ArchPrctlAddrArg = ArchPrctlAddrArgVal CULong @@ -1053,6 +1075,7 @@ data DetailedSyscallEnter | DetailedSyscallEnter_arch_prctl SyscallEnterDetails_arch_prctl | DetailedSyscallEnter_set_tid_address SyscallEnterDetails_set_tid_address | DetailedSyscallEnter_sysinfo SyscallEnterDetails_sysinfo + | DetailedSyscallEnter_poll SyscallEnterDetails_poll | DetailedSyscallEnter_unimplemented Syscall SyscallArgs deriving (Eq, Ord, Show) @@ -1085,6 +1108,7 @@ data DetailedSyscallExit | DetailedSyscallExit_arch_prctl SyscallExitDetails_arch_prctl | DetailedSyscallExit_set_tid_address SyscallExitDetails_set_tid_address | DetailedSyscallExit_sysinfo SyscallExitDetails_sysinfo + | DetailedSyscallExit_poll SyscallExitDetails_poll | DetailedSyscallExit_unimplemented Syscall SyscallArgs Word64 deriving (Eq, Ord, Show) @@ -1364,6 +1388,14 @@ getSyscallEnterDetails syscall syscallArgs pid = let proc = TracedProcess pid in pure $ DetailedSyscallEnter_set_tid_address $ SyscallEnterDetails_set_tid_address { tidptr } + Syscall_poll -> do + let SyscallArgs{ arg0 = pollfdAddr, arg1 = nfds, arg2 = timeout } = syscallArgs + let pollfdPtr = word64ToPtr pollfdAddr + pure $ DetailedSyscallEnter_poll $ SyscallEnterDetails_poll + { fds = pollfdPtr + , nfds = fromIntegral nfds + , timeout = fromIntegral timeout + } _ -> pure $ DetailedSyscallEnter_unimplemented (KnownSyscall syscall) syscallArgs @@ -1550,9 +1582,29 @@ getSyscallExitDetails' knownSyscall syscallArgs result pid = pure $ DetailedSyscallExit_sysinfo $ SyscallExitDetails_sysinfo{ enterDetail, sysinfo } + DetailedSyscallEnter_poll + enterDetail@SyscallEnterDetails_poll{ fds, nfds } -> do + -- This capping to max int below is a consequence of nfds var being a long, + -- while peekArray taking as an argument just an int. The assumption made + -- in here is that the number of checked fds will be less than max int. + let n = fromIntegral $ min nfds $ fromIntegral (maxBound :: Int) + pollfds <- peekArray (TracedProcess pid) n fds + pure $ DetailedSyscallExit_poll $ + SyscallExitDetails_poll{ enterDetail, pollfds } + DetailedSyscallEnter_unimplemented syscall _syscallArgs -> pure $ DetailedSyscallExit_unimplemented syscall syscallArgs result +peekArray :: Storable a => TracedProcess -> Int -> Ptr a -> IO [a] +peekArray pid size ptr + | size <= 0 = return [] + | otherwise = do + arrayBytes <- Ptrace.peekBytes pid ptr (size * elemSize) + let (tmpPtr, _, _) = BSI.toForeignPtr arrayBytes + withForeignPtr tmpPtr (\p -> Foreign.Marshal.Array.peekArray size (castPtr p)) + where + elemSize = sizeOf ptr + readPipeFds :: CPid -> Ptr CInt -> IO (CInt, CInt) readPipeFds pid pipefd = do let fdSize = sizeOf (undefined :: CInt) @@ -1940,6 +1992,8 @@ formatSyscallEnter syscall syscallArgs pid = DetailedSyscallEnter_exit_group details -> syscallEnterToFormatted details + DetailedSyscallEnter_poll details -> syscallEnterToFormatted details + DetailedSyscallEnter_unimplemented unimplementedSyscall unimplementedSyscallArgs -> FormattedSyscall ("unimplemented_syscall_details(" ++ show unimplementedSyscall ++ ")") (unimplementedArgs unimplementedSyscallArgs) @@ -2035,6 +2089,8 @@ formatDetailedSyscallExit detailedExit handleUnimplemented = DetailedSyscallExit_exit_group details -> formatDetails details + DetailedSyscallExit_poll details -> formatDetails details + DetailedSyscallExit_unimplemented syscall syscallArgs result -> handleUnimplemented syscall syscallArgs result diff --git a/src/System/Hatrace/Format.hs b/src/System/Hatrace/Format.hs index 9211000..b02f04f 100644 --- a/src/System/Hatrace/Format.hs +++ b/src/System/Hatrace/Format.hs @@ -25,7 +25,7 @@ import qualified Data.Text.Encoding.Error as TE import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Void (Void) import Data.Word (Word64) -import Foreign.C.Types (CUShort(..), CInt(..), CUInt(..), CLong(..), CULong(..), CSize(..), CTime(..)) +import Foreign.C.Types (CShort(..), CUShort(..), CInt(..), CUInt(..), CLong(..), CULong(..), CSize(..), CTime(..)) import Foreign.Ptr (Ptr, nullPtr, ptrToIntPtr) import System.Posix.Types (CMode(..)) @@ -60,6 +60,9 @@ instance ArgFormatting Word64 where instance ArgFormatting CUShort where formatArg = IntegerArg . fromIntegral +instance ArgFormatting CShort where + formatArg = IntegerArg . fromIntegral + instance ArgFormatting CInt where formatArg = IntegerArg . fromIntegral diff --git a/src/System/Hatrace/Types.hsc b/src/System/Hatrace/Types.hsc index ab0c5b6..e646890 100644 --- a/src/System/Hatrace/Types.hsc +++ b/src/System/Hatrace/Types.hsc @@ -1,8 +1,17 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- To use `POLLRDHUP` with glibc, `_GNU_SOURCE` must be defined +-- before any header file imports; see `man 2 poll`. +#ifdef USE_POLL_POLLRDHUP +#define _GNU_SOURCE +#endif + #include #include #include #include +#include module System.Hatrace.Types ( FileAccessMode(..) @@ -11,13 +20,16 @@ module System.Hatrace.Types , StatStruct(..) , TimespecStruct(..) , ArchPrctlSubfunction(..) + , PollFdStruct(..) + , PollEvents(..) + , GranularPollEvents(..) , CIntRepresentable(..) , SysinfoStruct(..) ) where import Data.Bits import Data.List (intercalate) -import Foreign.C.Types (CUShort(..), CInt(..), CUInt(..), CLong(..), CULong(..)) +import Foreign.C.Types (CShort(..), CUShort(..), CInt(..), CUInt(..), CLong(..), CULong(..)) import Foreign.Marshal.Array (peekArray, pokeArray) import Foreign.Ptr (plusPtr) import Foreign.Storable (Storable(..)) @@ -28,6 +40,10 @@ class CIntRepresentable a where toCInt :: a -> CInt fromCInt :: CInt -> a +class CShortRepresentable a where + toCShort :: a -> CShort + fromCShort :: CShort -> a + data FileAccessMode = FileAccessKnown GranularAccessMode | FileAccessUnknown CInt @@ -259,3 +275,136 @@ instance Storable SysinfoStruct where #{poke struct sysinfo, totalhigh} p totalhigh #{poke struct sysinfo, freehigh} p freehigh #{poke struct sysinfo, mem_unit} p mem_unit + +data PollFdStruct = PollFdStruct + { fd :: CInt + , events :: PollEvents + , revents :: PollEvents + } deriving (Eq, Ord, Show) + +instance Storable PollFdStruct where + sizeOf _ = #{size struct pollfd} + alignment _ = #{alignment struct pollfd} + peek p = do + fd <- #{peek struct pollfd, fd} p + events <- fromCShort <$> #{peek struct pollfd, events} p + revents <- fromCShort <$> #{peek struct pollfd, revents} p + return PollFdStruct{ fd = fd + , events = events + , revents = revents + } + poke p PollFdStruct{..} = do + #{poke struct pollfd, fd} p fd + #{poke struct pollfd, events} p (toCShort events) + #{poke struct pollfd, revents} p (toCShort revents) + +instance ArgFormatting PollFdStruct where + formatArg PollFdStruct {..} = + StructArg [ ("fd", formatArg fd) + , ("events", formatArg events) + , ("revents", formatArg revents) + ] + +data PollEvents = PollEventsKnown GranularPollEvents + | PollEventsUnknown CShort deriving (Eq, Ord, Show) + +instance ArgFormatting PollEvents where + formatArg = FixedStringArg . formatMode + where + formatMode (PollEventsKnown gpe) = + let granularPollEvents = + [ "POLLIN" | pollin gpe ] ++ + [ "POLLPRI" | pollpri gpe ] ++ + [ "POLLOUT" | pollout gpe ] ++ +#ifdef USE_POLL_POLLRDHUP + [ "POLLRDHUP" | pollrdhup gpe ] ++ +#endif + [ "POLLERR" | pollerr gpe ] ++ + [ "POLLHUP" | pollhup gpe ] ++ + [ "POLLNVAL" | pollnval gpe ] ++ +#ifdef _XOPEN_SOURCE + [ "POLLRDNORM" | pollrdnorm gpe ] ++ + [ "POLLRDBAND" | pollrdband gpe ] ++ + [ "POLLWRNORM" | pollwrnorm gpe ] ++ + [ "POLLWRBAND" | pollwrband gpe ] ++ +#endif + [] + in if null granularPollEvents then "0" else intercalate "|" granularPollEvents + formatMode (PollEventsUnknown x) = show x + +-- |Only explicitly defined in man pages poll bits are currently used. +data GranularPollEvents = GranularPollEvents + { pollin :: Bool + , pollpri :: Bool + , pollout :: Bool +#ifdef USE_POLL_POLLRDHUP + , pollrdhup :: Bool +#endif + , pollerr :: Bool + , pollhup :: Bool + , pollnval :: Bool +#ifdef _XOPEN_SOURCE + , pollrdnorm :: Bool + , pollrdband :: Bool + , pollwrnorm :: Bool + , pollwrband :: Bool +#endif + } deriving (Eq, Ord, Show) + +instance CShortRepresentable PollEvents where + toCShort (PollEventsKnown gpe) = foldr (.|.) (fromIntegral (0 :: Int)) setBits + where + setBits = + [ if pollin gpe then (#const POLLIN) else 0 + , if pollpri gpe then (#const POLLPRI) else 0 + , if pollout gpe then (#const POLLOUT) else 0 +#ifdef USE_POLL_POLLRDHUP + , if pollrdhup gpe then (#const POLLRDHUP) else 0 +#endif + , if pollerr gpe then (#const POLLERR) else 0 + , if pollhup gpe then (#const POLLHUP) else 0 + , if pollnval gpe then (#const POLLNVAL) else 0 +#ifdef _XOPEN_SOURCE + , if pollrdnorm gpe then (#const POLLRDNORM) else 0 + , if pollrdband gpe then (#const POLLRDBAND) else 0 + , if pollwrnorm gpe then (#const POLLWRNORM) else 0 + , if pollwrband gpe then (#const POLLWRBAND) else 0 +#endif + ] + toCShort (PollEventsUnknown x) = x + fromCShort m | (m .&. complement pollEventsBits) /= zeroBits = PollEventsUnknown m + | otherwise = + let isset f = (m .&. f) /= zeroBits + in PollEventsKnown GranularPollEvents + { pollin = isset (#const POLLIN) + , pollpri = isset (#const POLLPRI) + , pollout = isset (#const POLLOUT) +#ifdef USE_POLL_POLLRDHUP + , pollrdhup = isset (#const POLLRDHUP) +#endif + , pollerr = isset (#const POLLERR) + , pollhup = isset (#const POLLHUP) + , pollnval = isset (#const POLLNVAL) +#ifdef _XOPEN_SOURCE + , pollrdnorm = isset (#const POLLRDNORM) + , pollrdband = isset (#const POLLRDBAND) + , pollwrnorm = isset (#const POLLWRNORM) + , pollwrband = isset (#const POLLWRBAND) +#endif + } + where + pollEventsBits = (#const POLLIN) + .|. (#const POLLPRI) + .|. (#const POLLOUT) +#ifdef USE_POLL_POLLRDHUP + .|. (#const POLLRDHUP) +#endif + .|. (#const POLLERR) + .|. (#const POLLHUP) + .|. (#const POLLNVAL) +#ifdef _XOPEN_SOURCE + .|. (#const POLLRDNORM) + .|. (#const POLLRDBAND) + .|. (#const POLLWRNORM) + .|. (#const POLLWRBAND) +#endif diff --git a/test/HatraceSpec.hs b/test/HatraceSpec.hs index b15bca9..770781d 100644 --- a/test/HatraceSpec.hs +++ b/test/HatraceSpec.hs @@ -2,6 +2,8 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} module HatraceSpec where @@ -676,6 +678,34 @@ spec = before_ assertNoChildren $ do ] length symlinkEvents `shouldBe` 1 + describe "poll" $ do + it "detects correctly all events" $ do + let pollCall = "example-programs-build/poll" + callProcess "make" ["--quiet", pollCall] + tmpFile <- emptySystemTempFile "temp-file" + argv <- procToArgv pollCall [tmpFile] + (exitCode, events) <- + sourceTraceForkExecvFullPathWithSink argv $ + syscallExitDetailsOnlyConduit .| CL.consume + exitCode `shouldBe` ExitSuccess + let pollResult = [ (nfds, pollfds) + | (_pid + , Right (DetailedSyscallExit_poll + SyscallExitDetails_poll + { enterDetail = SyscallEnterDetails_poll{ nfds }, pollfds }) + ) <- events + ] + length pollResult `shouldBe` 1 + let (nfds, pollfds) = head pollResult + length pollfds `shouldBe` 3 +#ifdef USE_POLL_POLLRDHUP + System.Hatrace.Types.events (head pollfds) `shouldSatisfy` ( \case + PollEventsKnown gpe -> pollrdhup gpe + _ -> False + ) +#endif + nfds `shouldBe` 3 + describe "arch_prctl" $ do it "seen ARCH_GET_FS used by example executable" $ do callProcess "make" ["--quiet", "example-programs-build/get-fs"]