From f46082b665d7748bdec2981e21d332ee90a7c1cd Mon Sep 17 00:00:00 2001 From: simonmar Date: Thu, 19 Dec 2002 13:52:55 +0000 Subject: [project @ 2002-12-19 13:52:55 by simonmar] Fill in some more bits in the new Unix library: specifically the contents of PosixTTY and PosixDB (now System.Posix.Terminal and System.Posix.User respectively). We're now about 95% complete w.r.t. the old posix library. I've identified the reminaing bits to do in System/Posix.hs. --- System/Posix/Files.hsc | 9 +- System/Posix/IO.hsc | 2 - System/Posix/Process.hsc | 42 ++- System/Posix/Terminal.hsc | 674 ++++++++++++++++++++++++++++++++++++++++++++++ System/Posix/Time.hsc | 35 +++ System/Posix/Unistd.hsc | 97 +------ System/Posix/User.hsc | 260 ++++++++++++++++++ 7 files changed, 992 insertions(+), 127 deletions(-) create mode 100644 System/Posix/Terminal.hsc create mode 100644 System/Posix/Time.hsc create mode 100644 System/Posix/User.hsc (limited to 'System/Posix') diff --git a/System/Posix/Files.hsc b/System/Posix/Files.hsc index a12b34c..660c7ae 100644 --- a/System/Posix/Files.hsc +++ b/System/Posix/Files.hsc @@ -15,7 +15,7 @@ module System.Posix.Files ( -- * File modes - FileMode, + -- FileMode exported by System.Posix.Types unionFileModes, intersectFileModes, nullFileMode, ownerReadMode, ownerWriteMode, ownerExecuteMode, ownerModes, @@ -74,6 +74,7 @@ module System.Posix.Files ( -} ) where +#include "HsUnix.h" import System.Posix.Types import System.IO.Unsafe @@ -82,12 +83,6 @@ import GHC.Posix import Foreign import Foreign.C -#include -#include -#include -#include -#include - -- ----------------------------------------------------------------------------- -- POSIX file modes diff --git a/System/Posix/IO.hsc b/System/Posix/IO.hsc index 9468f0e..f7baed7 100644 --- a/System/Posix/IO.hsc +++ b/System/Posix/IO.hsc @@ -69,8 +69,6 @@ import GHC.Handle hiding (fdToHandle, openFd) import qualified GHC.Handle #endif -#include -#include #include "HsUnix.h" -- ----------------------------------------------------------------------------- diff --git a/System/Posix/Process.hsc b/System/Posix/Process.hsc index e20830c..ec0bc33 100644 --- a/System/Posix/Process.hsc +++ b/System/Posix/Process.hsc @@ -60,21 +60,8 @@ module System.Posix.Process ( -- getEnvironment, ) where -#include "config.h" #include "HsUnix.h" -#ifdef HAVE_SYS_TIMES_H -#include -#endif - -#ifdef HAVE_SYS_TIME_H -#include -#endif - -#ifdef HAVE_SYS_RESOURCE_H -#include -#endif - import Foreign import Foreign.C import System.IO @@ -230,24 +217,29 @@ executeFile :: FilePath -- Command -> IO () executeFile path search args Nothing = do withCString path $ \s -> - withMany withCString args $ \cstrs -> - withArray0 nullPtr cstrs $ \arr -> - if search then - throwErrnoIfMinus1_ "executeFile" (c_execvp s arr) - else - throwErrnoIfMinus1_ "executeFile" (c_execv s arr) + withMany withCString (path:args) $ \cstrs -> + withArray0 nullPtr cstrs $ \arr -> do + pPrPr_disableITimers + if search + then throwErrnoIfMinus1_ "executeFile" (c_execvp s arr) + else throwErrnoIfMinus1_ "executeFile" (c_execv s arr) executeFile path search args (Just env) = do withCString path $ \s -> - withMany withCString args $ \cstrs -> + withMany withCString (path:args) $ \cstrs -> withArray0 nullPtr cstrs $ \arg_arr -> let env' = map (\ (name, val) -> name ++ ('=' : val)) env in withMany withCString env' $ \cenv -> - withArray0 nullPtr cenv $ \env_arr -> - if search then - throwErrnoIfMinus1_ "executeFile" (c_execvpe s arg_arr env_arr) - else - throwErrnoIfMinus1_ "executeFile" (c_execve s arg_arr env_arr) + withArray0 nullPtr cenv $ \env_arr -> do + pPrPr_disableITimers + if search + then throwErrnoIfMinus1_ "executeFile" (c_execvpe s arg_arr env_arr) + else throwErrnoIfMinus1_ "executeFile" (c_execve s arg_arr env_arr) + +-- this function disables the itimer, which would otherwise cause confusing +-- signals to be sent to the new process. +foreign import ccall unsafe "pPrPr_disableITimers" + pPrPr_disableITimers :: IO () foreign import ccall unsafe "execvp" c_execvp :: CString -> Ptr CString -> IO CInt diff --git a/System/Posix/Terminal.hsc b/System/Posix/Terminal.hsc new file mode 100644 index 0000000..90265d6 --- /dev/null +++ b/System/Posix/Terminal.hsc @@ -0,0 +1,674 @@ +{-# OPTIONS -fffi #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Terminal +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- POSIX Terminal support +-- +----------------------------------------------------------------------------- + +module System.Posix.Terminal ( + -- * Terminal support + + -- ** Terminal attributes + TerminalAttributes, + getTerminalAttributes, + TerminalState(..), + setTerminalAttributes, + + TerminalMode(..), + withoutMode, + withMode, + terminalMode, + bitsPerByte, + withBits, + + ControlCharacter(..), + controlChar, + withCC, + withoutCC, + + inputTime, + withTime, + minInput, + withMinInput, + + BaudRate(..), + inputSpeed, + withInputSpeed, + outputSpeed, + withOutputSpeed, + + -- ** Terminal operations + sendBreak, + drainOutput, + QueueSelector(..), + discardData, + FlowAction(..), + controlFlow, + + -- ** Process groups + getTerminalProcessGroupID, + setTerminalProcessGroupID, + + -- ** Testing a file descriptor + queryTerminal, + getTerminalName, +#if !defined(cygwin32_TARGET_OS) + getControllingTerminalName, +#endif + + ) where + +#include "HsUnix.h" + +import Data.Bits +import Data.Char +import Foreign +import Foreign.C +import System.Posix.Types + +-- ----------------------------------------------------------------------------- +-- Terminal attributes + +type CTermios = () +type TerminalAttributes = ForeignPtr CTermios + +data TerminalMode + -- input flags + = InterruptOnBreak -- BRKINT + | MapCRtoLF -- ICRNL + | IgnoreBreak -- IGNBRK + | IgnoreCR -- IGNCR + | IgnoreParityErrors -- IGNPAR + | MapLFtoCR -- INLCR + | CheckParity -- INPCK + | StripHighBit -- ISTRIP + | StartStopInput -- IXOFF + | StartStopOutput -- IXON + | MarkParityErrors -- PARMRK + + -- output flags + | ProcessOutput -- OPOST + -- ToDo: ONLCR, OCRNL, ONOCR, ONLRET, OFILL, + -- NLDLY(NL0,NL1), CRDLY(CR0,CR1,CR2,CR2) + -- TABDLY(TAB0,TAB1,TAB2,TAB3) + -- BSDLY(BS0,BS1), VTDLY(VT0,VT1), FFDLY(FF0,FF1) + + -- control flags + | LocalMode -- CLOCAL + | ReadEnable -- CREAD + | TwoStopBits -- CSTOPB + | HangupOnClose -- HUPCL + | EnableParity -- PARENB + | OddParity -- PARODD + + -- local modes + | EnableEcho -- ECHO + | EchoErase -- ECHOE + | EchoKill -- ECHOK + | EchoLF -- ECHONL + | ProcessInput -- ICANON + | ExtendedFunctions -- IEXTEN + | KeyboardInterrupts -- ISIG + | NoFlushOnInterrupt -- NOFLSH + | BackgroundWriteInterrupt -- TOSTOP + +withoutMode :: TerminalAttributes -> TerminalMode -> TerminalAttributes +withoutMode termios InterruptOnBreak = clearInputFlag (#const BRKINT) termios +withoutMode termios MapCRtoLF = clearInputFlag (#const ICRNL) termios +withoutMode termios IgnoreBreak = clearInputFlag (#const IGNBRK) termios +withoutMode termios IgnoreCR = clearInputFlag (#const IGNCR) termios +withoutMode termios IgnoreParityErrors = clearInputFlag (#const IGNPAR) termios +withoutMode termios MapLFtoCR = clearInputFlag (#const INLCR) termios +withoutMode termios CheckParity = clearInputFlag (#const INPCK) termios +withoutMode termios StripHighBit = clearInputFlag (#const ISTRIP) termios +withoutMode termios StartStopInput = clearInputFlag (#const IXOFF) termios +withoutMode termios StartStopOutput = clearInputFlag (#const IXON) termios +withoutMode termios MarkParityErrors = clearInputFlag (#const PARMRK) termios +withoutMode termios ProcessOutput = clearOutputFlag (#const OPOST) termios +withoutMode termios LocalMode = clearControlFlag (#const CLOCAL) termios +withoutMode termios ReadEnable = clearControlFlag (#const CREAD) termios +withoutMode termios TwoStopBits = clearControlFlag (#const CSTOPB) termios +withoutMode termios HangupOnClose = clearControlFlag (#const HUPCL) termios +withoutMode termios EnableParity = clearControlFlag (#const PARENB) termios +withoutMode termios OddParity = clearControlFlag (#const PARODD) termios +withoutMode termios EnableEcho = clearLocalFlag (#const ECHO) termios +withoutMode termios EchoErase = clearLocalFlag (#const ECHOE) termios +withoutMode termios EchoKill = clearLocalFlag (#const ECHOK) termios +withoutMode termios EchoLF = clearLocalFlag (#const ECHONL) termios +withoutMode termios ProcessInput = clearLocalFlag (#const ICANON) termios +withoutMode termios ExtendedFunctions = clearLocalFlag (#const IEXTEN) termios +withoutMode termios KeyboardInterrupts = clearLocalFlag (#const ISIG) termios +withoutMode termios NoFlushOnInterrupt = setLocalFlag (#const NOFLSH) termios +withoutMode termios BackgroundWriteInterrupt = clearLocalFlag (#const TOSTOP) termios + +withMode :: TerminalAttributes -> TerminalMode -> TerminalAttributes +withMode termios InterruptOnBreak = setInputFlag (#const BRKINT) termios +withMode termios MapCRtoLF = setInputFlag (#const ICRNL) termios +withMode termios IgnoreBreak = setInputFlag (#const IGNBRK) termios +withMode termios IgnoreCR = setInputFlag (#const IGNCR) termios +withMode termios IgnoreParityErrors = setInputFlag (#const IGNPAR) termios +withMode termios MapLFtoCR = setInputFlag (#const INLCR) termios +withMode termios CheckParity = setInputFlag (#const INPCK) termios +withMode termios StripHighBit = setInputFlag (#const ISTRIP) termios +withMode termios StartStopInput = setInputFlag (#const IXOFF) termios +withMode termios StartStopOutput = setInputFlag (#const IXON) termios +withMode termios MarkParityErrors = setInputFlag (#const PARMRK) termios +withMode termios ProcessOutput = setOutputFlag (#const OPOST) termios +withMode termios LocalMode = setControlFlag (#const CLOCAL) termios +withMode termios ReadEnable = setControlFlag (#const CREAD) termios +withMode termios TwoStopBits = setControlFlag (#const CSTOPB) termios +withMode termios HangupOnClose = setControlFlag (#const HUPCL) termios +withMode termios EnableParity = setControlFlag (#const PARENB) termios +withMode termios OddParity = setControlFlag (#const PARODD) termios +withMode termios EnableEcho = setLocalFlag (#const ECHO) termios +withMode termios EchoErase = setLocalFlag (#const ECHOE) termios +withMode termios EchoKill = setLocalFlag (#const ECHOK) termios +withMode termios EchoLF = setLocalFlag (#const ECHONL) termios +withMode termios ProcessInput = setLocalFlag (#const ICANON) termios +withMode termios ExtendedFunctions = setLocalFlag (#const IEXTEN) termios +withMode termios KeyboardInterrupts = setLocalFlag (#const ISIG) termios +withMode termios NoFlushOnInterrupt = clearLocalFlag (#const NOFLSH) termios +withMode termios BackgroundWriteInterrupt = setLocalFlag (#const TOSTOP) termios + +terminalMode :: TerminalMode -> TerminalAttributes -> Bool +terminalMode InterruptOnBreak = testInputFlag (#const BRKINT) +terminalMode MapCRtoLF = testInputFlag (#const ICRNL) +terminalMode IgnoreBreak = testInputFlag (#const IGNBRK) +terminalMode IgnoreCR = testInputFlag (#const IGNCR) +terminalMode IgnoreParityErrors = testInputFlag (#const IGNPAR) +terminalMode MapLFtoCR = testInputFlag (#const INLCR) +terminalMode CheckParity = testInputFlag (#const INPCK) +terminalMode StripHighBit = testInputFlag (#const ISTRIP) +terminalMode StartStopInput = testInputFlag (#const IXOFF) +terminalMode StartStopOutput = testInputFlag (#const IXON) +terminalMode MarkParityErrors = testInputFlag (#const PARMRK) +terminalMode ProcessOutput = testOutputFlag (#const OPOST) +terminalMode LocalMode = testControlFlag (#const CLOCAL) +terminalMode ReadEnable = testControlFlag (#const CREAD) +terminalMode TwoStopBits = testControlFlag (#const CSTOPB) +terminalMode HangupOnClose = testControlFlag (#const HUPCL) +terminalMode EnableParity = testControlFlag (#const PARENB) +terminalMode OddParity = testControlFlag (#const PARODD) +terminalMode EnableEcho = testLocalFlag (#const ECHO) +terminalMode EchoErase = testLocalFlag (#const ECHOE) +terminalMode EchoKill = testLocalFlag (#const ECHOK) +terminalMode EchoLF = testLocalFlag (#const ECHONL) +terminalMode ProcessInput = testLocalFlag (#const ICANON) +terminalMode ExtendedFunctions = testLocalFlag (#const IEXTEN) +terminalMode KeyboardInterrupts = testLocalFlag (#const ISIG) +terminalMode NoFlushOnInterrupt = not . testLocalFlag (#const NOFLSH) +terminalMode BackgroundWriteInterrupt = testLocalFlag (#const TOSTOP) + +bitsPerByte :: TerminalAttributes -> Int +bitsPerByte termios = unsafePerformIO $ do + withForeignPtr termios $ \p -> do + cflag <- (#peek struct termios, c_cflag) p + return $! (word2Bits (cflag .&. (#const CSIZE))) + where + word2Bits :: CTcflag -> Int + word2Bits x = + if x == (#const CS5) then 5 + else if x == (#const CS6) then 6 + else if x == (#const CS7) then 7 + else if x == (#const CS8) then 8 + else 0 + +withBits :: TerminalAttributes -> Int -> TerminalAttributes +withBits termios bits = unsafePerformIO $ do + withNewTermios termios $ \p -> do + cflag <- (#peek struct termios, c_cflag) p + (#poke struct termios, c_cflag) p + ((cflag .&. complement (#const CSIZE)) .|. mask bits) + where + mask :: Int -> Word + mask 5 = (#const CS5) + mask 6 = (#const CS6) + mask 7 = (#const CS7) + mask 8 = (#const CS8) + mask _ = error "withBits bit value out of range [5..8]" + +data ControlCharacter + = EndOfFile -- VEOF + | EndOfLine -- VEOL + | Erase -- VERASE + | Interrupt -- VINTR + | Kill -- VKILL + | Quit -- VQUIT + | Start -- VSTART + | Stop -- VSTOP + | Suspend -- VSUSP + +controlChar :: TerminalAttributes -> ControlCharacter -> Maybe Char +controlChar termios cc = unsafePerformIO $ do + withForeignPtr termios $ \p -> do + let c_cc = (#ptr struct termios, c_cc) p + val <- peekElemOff c_cc (cc2Word cc) + if val == ((#const _POSIX_VDISABLE)::CCc) + then return Nothing + else return (Just (chr (fromEnum val))) + +withCC :: TerminalAttributes + -> (ControlCharacter, Char) + -> TerminalAttributes +withCC termios (cc, c) = unsafePerformIO $ do + withNewTermios termios $ \p -> do + let c_cc = (#ptr struct termios, c_cc) p + pokeElemOff c_cc (cc2Word cc) (fromIntegral (ord c) :: CCc) + +withoutCC :: TerminalAttributes + -> ControlCharacter + -> TerminalAttributes +withoutCC termios cc = unsafePerformIO $ do + withNewTermios termios $ \p -> do + let c_cc = (#ptr struct termios, c_cc) p + pokeElemOff c_cc (cc2Word cc) ((#const _POSIX_VDISABLE) :: CCc) + +inputTime :: TerminalAttributes -> Int +inputTime termios = unsafePerformIO $ do + withForeignPtr termios $ \p -> do + c <- peekElemOff ((#ptr struct termios, c_cc) p) (#const VTIME) + return (fromEnum (c :: CCc)) + +withTime :: TerminalAttributes -> Int -> TerminalAttributes +withTime termios time = unsafePerformIO $ do + withNewTermios termios $ \p -> do + let c_cc = (#ptr struct termios, c_cc) p + pokeElemOff c_cc (#const VTIME) (fromIntegral time :: CCc) + +minInput :: TerminalAttributes -> Int +minInput termios = unsafePerformIO $ do + withForeignPtr termios $ \p -> do + c <- peekElemOff ((#ptr struct termios, c_cc) p) (#const VMIN) + return (fromEnum (c :: CCc)) + +withMinInput :: TerminalAttributes -> Int -> TerminalAttributes +withMinInput termios count = unsafePerformIO $ do + withNewTermios termios $ \p -> do + let c_cc = (#ptr struct termios, c_cc) p + pokeElemOff c_cc (#const VMIN) (fromIntegral count :: CCc) + +data BaudRate + = B0 + | B50 + | B75 + | B110 + | B134 + | B150 + | B200 + | B300 + | B600 + | B1200 + | B1800 + | B2400 + | B4800 + | B9600 + | B19200 + | B38400 + +inputSpeed :: TerminalAttributes -> BaudRate +inputSpeed termios = unsafePerformIO $ do + withForeignPtr termios $ \p -> do + w <- c_cfgetispeed p + return (word2Baud w) + +foreign import ccall unsafe "cfgetispeed" + c_cfgetispeed :: Ptr CTermios -> IO CSpeed + +withInputSpeed :: TerminalAttributes -> BaudRate -> TerminalAttributes +withInputSpeed termios br = unsafePerformIO $ do + withNewTermios termios $ \p -> c_cfsetispeed p (baud2Word br) + +foreign import ccall unsafe "cfsetispeed" + c_cfsetispeed :: Ptr CTermios -> CSpeed -> IO CInt + + +outputSpeed :: TerminalAttributes -> BaudRate +outputSpeed termios = unsafePerformIO $ do + withForeignPtr termios $ \p -> do + w <- c_cfgetospeed p + return (word2Baud w) + +foreign import ccall unsafe "cfgetospeed" + c_cfgetospeed :: Ptr CTermios -> IO CSpeed + +withOutputSpeed :: TerminalAttributes -> BaudRate -> TerminalAttributes +withOutputSpeed termios br = unsafePerformIO $ do + withNewTermios termios $ \p -> c_cfsetospeed p (baud2Word br) + +foreign import ccall unsafe "cfsetospeed" + c_cfsetospeed :: Ptr CTermios -> CSpeed -> IO CInt + + +getTerminalAttributes :: Fd -> IO TerminalAttributes +getTerminalAttributes fd = do + fp <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp $ \p -> + throwErrnoIfMinus1_ "getTerminalAttributes" (c_tcgetattr fd p) + return fp + +foreign import ccall unsafe "tcgetattr" + c_tcgetattr :: Fd -> Ptr CTermios -> IO CInt + +data TerminalState + = Immediately + | WhenDrained + | WhenFlushed + +setTerminalAttributes :: Fd + -> TerminalAttributes + -> TerminalState + -> IO () +setTerminalAttributes fd termios state = do + withForeignPtr termios $ \p -> + throwErrnoIfMinus1_ "setTerminalAttributes" + (c_tcsetattr fd (state2Int state) p) + where + state2Int :: TerminalState -> CInt + state2Int Immediately = (#const TCSANOW) + state2Int WhenDrained = (#const TCSADRAIN) + state2Int WhenFlushed = (#const TCSAFLUSH) + +foreign import ccall unsafe "tcsetattr" + c_tcsetattr :: Fd -> CInt -> Ptr CTermios -> IO CInt + + +sendBreak :: Fd -> Int -> IO () +sendBreak fd duration + = throwErrnoIfMinus1_ "sendBreak" (c_tcsendbreak fd (fromIntegral duration)) + +foreign import ccall unsafe "tcsendbreak" + c_tcsendbreak :: Fd -> CInt -> IO CInt + +drainOutput :: Fd -> IO () +drainOutput fd = throwErrnoIfMinus1_ "drainOutput" (c_tcdrain fd) + +foreign import ccall unsafe "tcdrain" + c_tcdrain :: Fd -> IO CInt + + +data QueueSelector + = InputQueue -- TCIFLUSH + | OutputQueue -- TCOFLUSH + | BothQueues -- TCIOFLUSH + +discardData :: Fd -> QueueSelector -> IO () +discardData fd queue = + throwErrnoIfMinus1_ "discardData" (c_tcflush fd (queue2Int queue)) + where + queue2Int :: QueueSelector -> CInt + queue2Int InputQueue = (#const TCIFLUSH) + queue2Int OutputQueue = (#const TCOFLUSH) + queue2Int BothQueues = (#const TCIOFLUSH) + +foreign import ccall unsafe "tcflush" + c_tcflush :: Fd -> CInt -> IO CInt + +data FlowAction + = SuspendOutput -- TCOOFF + | RestartOutput -- TCOON + | TransmitStop -- TCIOFF + | TransmitStart -- TCION + +controlFlow :: Fd -> FlowAction -> IO () +controlFlow fd action = + throwErrnoIfMinus1_ "controlFlow" (c_tcflow fd (action2Int action)) + where + action2Int :: FlowAction -> CInt + action2Int SuspendOutput = (#const TCOOFF) + action2Int RestartOutput = (#const TCOON) + action2Int TransmitStop = (#const TCIOFF) + action2Int TransmitStart = (#const TCION) + +foreign import ccall unsafe "tcflow" + c_tcflow :: Fd -> CInt -> IO CInt + +getTerminalProcessGroupID :: Fd -> IO ProcessGroupID +getTerminalProcessGroupID fd = do + throwErrnoIfMinus1 "getTerminalProcessGroupID" (c_tcgetpgrp fd) + +foreign import ccall unsafe "tcgetpgrp" + c_tcgetpgrp :: Fd -> IO CPid + +setTerminalProcessGroupID :: Fd -> ProcessGroupID -> IO () +setTerminalProcessGroupID fd pgid = + throwErrnoIfMinus1_ "setTerminalProcessGroupID" (c_tcsetpgrp fd pgid) + +foreign import ccall unsafe "tcsetpgrp" + c_tcsetpgrp :: Fd -> CPid -> IO CInt + +-- ----------------------------------------------------------------------------- +-- file descriptor queries + +queryTerminal :: Fd -> IO Bool +queryTerminal fd = do + r <- c_isatty fd + return (r == 1) + -- ToDo: the spec says that it can set errno to EBADF if the result is zero + +foreign import ccall unsafe "isatty" + c_isatty :: Fd -> IO CInt + + +getTerminalName :: Fd -> IO FilePath +getTerminalName fd = do + s <- throwErrnoIfNull "getTerminalName" (c_ttyname fd) + peekCString s + +foreign import ccall unsafe "ttyname" + c_ttyname :: Fd -> IO CString + +-- ToDo: should be #ifdef HAVE_CTERMID +#if !defined(cygwin32_TARGET_OS) +getControllingTerminalName :: IO FilePath +getControllingTerminalName = do + s <- throwErrnoIfNull "getControllingTerminalName" (c_ctermid nullPtr) + peekCString s + +foreign import ccall unsafe "ctermid" + c_ctermid :: CString -> IO CString +#endif + +-- ----------------------------------------------------------------------------- +-- Local utility functions + +-- Convert Haskell ControlCharacter to Int + +cc2Word :: ControlCharacter -> Int +cc2Word EndOfFile = (#const VEOF) +cc2Word EndOfLine = (#const VEOL) +cc2Word Erase = (#const VERASE) +cc2Word Interrupt = (#const VINTR) +cc2Word Kill = (#const VKILL) +cc2Word Quit = (#const VQUIT) +cc2Word Suspend = (#const VSUSP) +cc2Word Start = (#const VSTART) +cc2Word Stop = (#const VSTOP) + +-- Convert Haskell BaudRate to unsigned integral type (Word) + +baud2Word :: BaudRate -> CSpeed +baud2Word B0 = (#const B0) +baud2Word B50 = (#const B50) +baud2Word B75 = (#const B75) +baud2Word B110 = (#const B110) +baud2Word B134 = (#const B134) +baud2Word B150 = (#const B150) +baud2Word B200 = (#const B200) +baud2Word B300 = (#const B300) +baud2Word B600 = (#const B600) +baud2Word B1200 = (#const B1200) +baud2Word B1800 = (#const B1800) +baud2Word B2400 = (#const B2400) +baud2Word B4800 = (#const B4800) +baud2Word B9600 = (#const B9600) +baud2Word B19200 = (#const B19200) +baud2Word B38400 = (#const B38400) + +-- And convert a word back to a baud rate +-- We really need some cpp macros here. + +word2Baud :: CSpeed -> BaudRate +word2Baud x = + if x == (#const B0) then B0 + else if x == (#const B50) then B50 + else if x == (#const B75) then B75 + else if x == (#const B110) then B110 + else if x == (#const B134) then B134 + else if x == (#const B150) then B150 + else if x == (#const B200) then B200 + else if x == (#const B300) then B300 + else if x == (#const B600) then B600 + else if x == (#const B1200) then B1200 + else if x == (#const B1800) then B1800 + else if x == (#const B2400) then B2400 + else if x == (#const B4800) then B4800 + else if x == (#const B9600) then B9600 + else if x == (#const B19200) then B19200 + else if x == (#const B38400) then B38400 + else error "unknown baud rate" + +-- Clear termios i_flag + +clearInputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes +clearInputFlag flag termios = unsafePerformIO $ do + fp <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp $ \p1 -> do + withForeignPtr termios $ \p2 -> do + copyBytes p1 p2 (#const sizeof(struct termios)) + iflag <- (#peek struct termios, c_iflag) p2 + (#poke struct termios, c_iflag) p1 (iflag .&. complement flag) + return fp + +-- Set termios i_flag + +setInputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes +setInputFlag flag termios = unsafePerformIO $ do + fp <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp $ \p1 -> do + withForeignPtr termios $ \p2 -> do + copyBytes p1 p2 (#const sizeof(struct termios)) + iflag <- (#peek struct termios, c_iflag) p2 + (#poke struct termios, c_iflag) p1 (iflag .|. flag) + return fp + +-- Examine termios i_flag + +testInputFlag :: CTcflag -> TerminalAttributes -> Bool +testInputFlag flag termios = unsafePerformIO $ + withForeignPtr termios $ \p -> do + iflag <- (#peek struct termios, c_iflag) p + return $! ((iflag .&. flag) /= 0) + +-- Clear termios c_flag + +clearControlFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes +clearControlFlag flag termios = unsafePerformIO $ do + fp <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp $ \p1 -> do + withForeignPtr termios $ \p2 -> do + copyBytes p1 p2 (#const sizeof(struct termios)) + cflag <- (#peek struct termios, c_cflag) p2 + (#poke struct termios, c_cflag) p1 (cflag .&. complement flag) + return fp + +-- Set termios c_flag + +setControlFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes +setControlFlag flag termios = unsafePerformIO $ do + fp <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp $ \p1 -> do + withForeignPtr termios $ \p2 -> do + copyBytes p1 p2 (#const sizeof(struct termios)) + cflag <- (#peek struct termios, c_cflag) p2 + (#poke struct termios, c_cflag) p1 (cflag .|. flag) + return fp + +-- Examine termios c_flag + +testControlFlag :: CTcflag -> TerminalAttributes -> Bool +testControlFlag flag termios = unsafePerformIO $ + withForeignPtr termios $ \p -> do + cflag <- (#peek struct termios, c_cflag) p + return $! ((cflag .&. flag) /= 0) + +-- Clear termios l_flag + +clearLocalFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes +clearLocalFlag flag termios = unsafePerformIO $ do + fp <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp $ \p1 -> do + withForeignPtr termios $ \p2 -> do + copyBytes p1 p2 (#const sizeof(struct termios)) + lflag <- (#peek struct termios, c_lflag) p2 + (#poke struct termios, c_lflag) p1 (lflag .&. complement flag) + return fp + +-- Set termios l_flag + +setLocalFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes +setLocalFlag flag termios = unsafePerformIO $ do + fp <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp $ \p1 -> do + withForeignPtr termios $ \p2 -> do + copyBytes p1 p2 (#const sizeof(struct termios)) + lflag <- (#peek struct termios, c_lflag) p2 + (#poke struct termios, c_lflag) p1 (lflag .|. flag) + return fp + +-- Examine termios l_flag + +testLocalFlag :: CTcflag -> TerminalAttributes -> Bool +testLocalFlag flag termios = unsafePerformIO $ + withForeignPtr termios $ \p -> do + lflag <- (#peek struct termios, c_lflag) p + return $! ((lflag .&. flag) /= 0) + +-- Clear termios o_flag + +clearOutputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes +clearOutputFlag flag termios = unsafePerformIO $ do + fp <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp $ \p1 -> do + withForeignPtr termios $ \p2 -> do + copyBytes p1 p2 (#const sizeof(struct termios)) + oflag <- (#peek struct termios, c_oflag) p2 + (#poke struct termios, c_oflag) p1 (oflag .&. complement flag) + return fp + +-- Set termios o_flag + +setOutputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes +setOutputFlag flag termios = unsafePerformIO $ do + fp <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp $ \p1 -> do + withForeignPtr termios $ \p2 -> do + copyBytes p1 p2 (#const sizeof(struct termios)) + oflag <- (#peek struct termios, c_oflag) p2 + (#poke struct termios, c_oflag) p1 (oflag .|. flag) + return fp + +-- Examine termios o_flag + +testOutputFlag :: CTcflag -> TerminalAttributes -> Bool +testOutputFlag flag termios = unsafePerformIO $ + withForeignPtr termios $ \p -> do + oflag <- (#peek struct termios, c_oflag) p + return $! ((oflag .&. flag) /= 0) + +withNewTermios :: TerminalAttributes -> (Ptr CTermios -> IO a) + -> IO TerminalAttributes +withNewTermios termios action = do + fp1 <- mallocForeignPtrBytes (#const sizeof(struct termios)) + withForeignPtr fp1 $ \p1 -> do + withForeignPtr termios $ \p2 -> do + copyBytes p1 p2 (#const sizeof(struct termios)) + action p1 + return fp1 diff --git a/System/Posix/Time.hsc b/System/Posix/Time.hsc new file mode 100644 index 0000000..a1d8f2f --- /dev/null +++ b/System/Posix/Time.hsc @@ -0,0 +1,35 @@ +{-# OPTIONS -fffi #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Time +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- POSIX Time support +-- +----------------------------------------------------------------------------- + +module System.Posix.Time ( + epochTime, + -- ToDo: lots more from sys/time.h + -- how much already supported by System.Time? + ) where + +#include "HsUnix.h" + +import System.Posix.Types +import Foreign +import Foreign.C + +-- ----------------------------------------------------------------------------- +-- epochTime + +epochTime :: IO EpochTime +epochTime = throwErrnoIfMinus1 "epochTime" (c_time nullPtr) + +foreign import ccall unsafe "time" + c_time :: Ptr CTime -> IO CTime diff --git a/System/Posix/Unistd.hsc b/System/Posix/Unistd.hsc index affdc2e..4ae14d4 100644 --- a/System/Posix/Unistd.hsc +++ b/System/Posix/Unistd.hsc @@ -14,21 +14,6 @@ ----------------------------------------------------------------------------- module System.Posix.Unistd ( - -- * User environment - -- * Querying user environment - getRealUserID, - getRealGroupID, - getEffectiveUserID, - getEffectiveGroupID, -#if !defined(cygwin32_TARGET_OS) - getGroups, -#endif - getLoginName, - - -- * Modifying the user environment - setUserID, - setGroupID, - -- * System environment SystemID(..), getSystemID, @@ -49,102 +34,25 @@ module System.Posix.Unistd ( -- should be in System.Posix.Files? pathconf, fpathconf, - queryTerminal, - getTerminalName, -#if !defined(cygwin32_TARGET_OS) - getControllingTerminalName, -#endif -- System.Posix.Signals ualarm, - -- System.Posix.Terminal - isatty, tcgetpgrp, tcsetpgrp, ttyname(_r), - -- System.Posix.IO read, write, - -- should be in System.Posix.Time? - epochTime, - -- should be in System.Posix.User? getEffectiveUserName, -} ) where -#include "config.h" +#include "HsUnix.h" import Foreign import Foreign.C import System.Posix.Types import GHC.Posix -#include -#include - --- ----------------------------------------------------------------------------- --- user environemnt - -getRealUserID :: IO UserID -getRealUserID = c_getuid - -foreign import ccall unsafe "getuid" - c_getuid :: IO CUid - -getRealGroupID :: IO GroupID -getRealGroupID = c_getgid - -foreign import ccall unsafe "getgid" - c_getgid :: IO CGid - -getEffectiveUserID :: IO UserID -getEffectiveUserID = c_geteuid - -foreign import ccall unsafe "geteuid" - c_geteuid :: IO CUid - -getEffectiveGroupID :: IO GroupID -getEffectiveGroupID = c_getegid - -foreign import ccall unsafe "getegid" - c_getegid :: IO CGid - --- getgroups() is not supported in beta18 of --- cygwin32 -#if !defined(cygwin32_TARGET_OS) -getGroups :: IO [GroupID] -getGroups = do - ngroups <- c_getgroups 0 nullPtr - allocaArray (fromIntegral ngroups) $ \arr -> do - throwErrnoIfMinus1_ "getGroups" (c_getgroups ngroups arr) - groups <- peekArray (fromIntegral ngroups) arr - return groups - -foreign import ccall unsafe "getgroups" - c_getgroups :: CInt -> Ptr CGid -> IO CInt -#endif - --- ToDo: use getlogin_r -getLoginName :: IO String -getLoginName = do - str <- throwErrnoIfNull "getLoginName" c_getlogin - peekCString str - -foreign import ccall unsafe "getlogin" - c_getlogin :: IO CString - -setUserID :: UserID -> IO () -setUserID uid = throwErrnoIfMinus1_ "setUserID" (c_setuid uid) - -foreign import ccall unsafe "setuid" - c_setuid :: CUid -> IO CInt - -setGroupID :: GroupID -> IO () -setGroupID gid = throwErrnoIfMinus1_ "setGroupID" (c_setgid gid) - -foreign import ccall unsafe "setgid" - c_setgid :: CGid -> IO CInt - -- ----------------------------------------------------------------------------- -- System environment (uname()) @@ -172,6 +80,9 @@ getSystemID = do machine = mach }) +foreign import ccall unsafe "uname" + c_uname :: Ptr CUtsname -> IO CInt + -- ----------------------------------------------------------------------------- -- sleeping diff --git a/System/Posix/User.hsc b/System/Posix/User.hsc new file mode 100644 index 0000000..1201164 --- /dev/null +++ b/System/Posix/User.hsc @@ -0,0 +1,260 @@ +{-# OPTIONS -fffi #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.User +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- POSIX user/group support +-- +----------------------------------------------------------------------------- + +module System.Posix.User ( + -- * User environment + -- ** Querying the user environment + getRealUserID, + getRealGroupID, + getEffectiveUserID, + getEffectiveGroupID, +#if !defined(cygwin32_TARGET_OS) + getGroups, +#endif + getLoginName, + getEffectiveUserName, + + -- *** The group database + GroupEntry(..), + getGroupEntryForID, + getGroupEntryForName, + + -- *** The user database + UserEntry(..), + getUserEntryForID, + getUserEntryForName, + + -- ** Modifying the user environment + setUserID, + setGroupID, + + ) where + +#include "HsUnix.h" + +import System.Posix.Types +import Foreign +import Foreign.C +import GHC.Posix ( CGroup, CPasswd ) + +-- ----------------------------------------------------------------------------- +-- user environemnt + +getRealUserID :: IO UserID +getRealUserID = c_getuid + +foreign import ccall unsafe "getuid" + c_getuid :: IO CUid + +getRealGroupID :: IO GroupID +getRealGroupID = c_getgid + +foreign import ccall unsafe "getgid" + c_getgid :: IO CGid + +getEffectiveUserID :: IO UserID +getEffectiveUserID = c_geteuid + +foreign import ccall unsafe "geteuid" + c_geteuid :: IO CUid + +getEffectiveGroupID :: IO GroupID +getEffectiveGroupID = c_getegid + +foreign import ccall unsafe "getegid" + c_getegid :: IO CGid + +-- getgroups() is not supported in beta18 of +-- cygwin32 +#if !defined(cygwin32_TARGET_OS) +getGroups :: IO [GroupID] +getGroups = do + ngroups <- c_getgroups 0 nullPtr + allocaArray (fromIntegral ngroups) $ \arr -> do + throwErrnoIfMinus1_ "getGroups" (c_getgroups ngroups arr) + groups <- peekArray (fromIntegral ngroups) arr + return groups + +foreign import ccall unsafe "getgroups" + c_getgroups :: CInt -> Ptr CGid -> IO CInt +#endif + +-- ToDo: use getlogin_r +getLoginName :: IO String +getLoginName = do + str <- throwErrnoIfNull "getLoginName" c_getlogin + peekCString str + +foreign import ccall unsafe "getlogin" + c_getlogin :: IO CString + +setUserID :: UserID -> IO () +setUserID uid = throwErrnoIfMinus1_ "setUserID" (c_setuid uid) + +foreign import ccall unsafe "setuid" + c_setuid :: CUid -> IO CInt + +setGroupID :: GroupID -> IO () +setGroupID gid = throwErrnoIfMinus1_ "setGroupID" (c_setgid gid) + +foreign import ccall unsafe "setgid" + c_setgid :: CGid -> IO CInt + +-- ----------------------------------------------------------------------------- +-- User names + +getEffectiveUserName :: IO String +getEffectiveUserName = do + euid <- getEffectiveUserID + pw <- getUserEntryForID euid + return (userName pw) + +-- ----------------------------------------------------------------------------- +-- The group database (grp.h) + +data GroupEntry = + GroupEntry { + groupName :: String, + groupID :: GroupID, + groupMembers :: [String] + } + +getGroupEntryForID :: GroupID -> IO GroupEntry +#ifdef HAVE_GETGRGID_R +getGroupEntryForID gid = do + allocaBytes (#const sizeof(struct group)) $ \pgr -> + allocaBytes grBufSize $ \pbuf -> + alloca $ \ ppgr -> do + err <- c_getgrgid_r gid pgr pbuf (fromIntegral grBufSize) ppgr + if (err == 0) + then unpackGroupEntry pgr + else ioError (errnoToIOError "getGroupEntryForID" + (Errno (fromIntegral err)) Nothing Nothing) + +foreign import ccall unsafe "getgrgid_r" + c_getgrgid_r :: CGid -> Ptr CGroup -> CString + -> CSize -> Ptr (Ptr CGroup) -> IO CInt +#else +getGroupEntryForID = error "System.Posix.User.getGroupEntryForID: not supported" +#endif + + +getGroupEntryForName :: String -> IO GroupEntry +#ifdef HAVE_GETGRNAM_R +getGroupEntryForName name = do + allocaBytes (#const sizeof(struct group)) $ \pgr -> + allocaBytes grBufSize $ \pbuf -> + alloca $ \ ppgr -> + withCString name $ \ pstr -> do + err <- c_getgrnam_r pstr pgr pbuf (fromIntegral grBufSize) ppgr + if (err == 0) + then unpackGroupEntry pgr + else ioError (errnoToIOError "getGroupEntryForName" + (Errno (fromIntegral err)) Nothing Nothing) + +foreign import ccall unsafe "getgrnam_r" + c_getgrnam_r :: CString -> Ptr CGroup -> CString + -> CSize -> Ptr (Ptr CGroup) -> IO CInt +#else +getGroupEntryForName = error "System.Posix.User.getGroupEntryForName: not supported" +#endif + +#if (defined(HAVE_GETGRGID_R) || defined(HAVE_GETGRNAM_R)) \ + && defined(HAVE_SYSCONF) +grBufSize :: Int +grBufSize = fromIntegral $ unsafePerformIO $ + c_sysconf (#const _SC_GETGR_R_SIZE_MAX) +#endif + +unpackGroupEntry :: Ptr CGroup -> IO GroupEntry +unpackGroupEntry ptr = do + name <- (#peek struct group, gr_name) ptr >>= peekCString + gid <- (#peek struct group, gr_gid) ptr + mem <- (#peek struct group, gr_mem) ptr + members <- peekArray0 nullPtr mem >>= mapM peekCString + return (GroupEntry name gid members) + +-- ----------------------------------------------------------------------------- +-- The user database (pwd.h) + +data UserEntry = + UserEntry { + userName :: String, + userID :: UserID, + userGroupID :: GroupID, + homeDirectory :: String, + userShell :: String + } + +getUserEntryForID :: UserID -> IO UserEntry +#ifdef HAVE_GETPWUID_R +getUserEntryForID uid = do + allocaBytes (#const sizeof(struct passwd)) $ \ppw -> + allocaBytes pwBufSize $ \pbuf -> + alloca $ \ pppw -> do + err <- c_getpwuid_r uid ppw pbuf (fromIntegral pwBufSize) pppw + if (err == 0) + then unpackUserEntry ppw + else ioError (errnoToIOError "getUserEntryForID" + (Errno (fromIntegral err)) Nothing Nothing) + +foreign import ccall unsafe "getpwuid_r" + c_getpwuid_r :: CUid -> Ptr CPasswd -> + CString -> CSize -> Ptr (Ptr CPasswd) -> IO CInt +#else +getUserEntryForID = error "System.Posix.User.getUserEntryForID: not supported" +#endif + +getUserEntryForName :: String -> IO UserEntry +#if HAVE_GETPWNAM_R +getUserEntryForName name = do + allocaBytes (#const sizeof(struct passwd)) $ \ppw -> + allocaBytes pwBufSize $ \pbuf -> + alloca $ \ pppw -> + withCString name $ \ pstr -> do + err <- c_getpwnam_r pstr ppw pbuf (fromIntegral pwBufSize) pppw + if (err == 0) + then unpackUserEntry ppw + else ioError (errnoToIOError "getUserEntryForID" + (Errno (fromIntegral err)) Nothing Nothing) + +foreign import ccall unsafe "getpwnam_r" + c_getpwnam_r :: CString -> Ptr CPasswd -> + CString -> CSize -> Ptr (Ptr CPasswd) -> IO CInt +#else +getUserEntryForName = error "System.Posix.User.getUserEntryForName: not supported" +#endif + +#if (defined(HAVE_GETPWUID_R) || defined(HAVE_GETPWNAM_R)) \ + && defined(HAVE_SYSCONF) +pwBufSize :: Int +pwBufSize = fromIntegral $ unsafePerformIO $ + c_sysconf (#const _SC_GETPW_R_SIZE_MAX) +#endif + +#ifdef HAVE_SYSCONF +foreign import ccall unsafe "sysconf" + c_sysconf :: CInt -> IO CLong +#endif + +unpackUserEntry :: Ptr CPasswd -> IO UserEntry +unpackUserEntry ptr = do + name <- (#peek struct passwd, pw_name) ptr >>= peekCString + uid <- (#peek struct passwd, pw_uid) ptr + gid <- (#peek struct passwd, pw_gid) ptr + dir <- (#peek struct passwd, pw_dir) ptr >>= peekCString + shell <- (#peek struct passwd, pw_shell) ptr >>= peekCString + return (UserEntry name uid gid dir shell) + -- cgit v1.2.3