180 lines
5.1 KiB
Haskell
180 lines
5.1 KiB
Haskell
--------------------------------------------------------------------------------
|
|
-- Random IO-ish functions used throughtout xmonad
|
|
--
|
|
-- Most (probably all) of these functions are intended to work with sysfs where
|
|
-- some safe assumptions can be made about file contents.
|
|
|
|
module XMonad.Internal.IO
|
|
( readInt
|
|
, readBool
|
|
, readPercent
|
|
, writeInt
|
|
, writeBool
|
|
, writePercent
|
|
, writePercentMin
|
|
, writePercentMax
|
|
, decPercent
|
|
, incPercent
|
|
-- , isReadable
|
|
-- , isWritable
|
|
, PermResult (..)
|
|
, getPermissionsSafe
|
|
, waitUntilExit
|
|
, withOpenDisplay
|
|
)
|
|
where
|
|
|
|
import Data.Char
|
|
import Graphics.X11.Xlib.Display
|
|
import Graphics.X11.Xlib.Event
|
|
import Graphics.X11.Xlib.Types
|
|
import RIO hiding (Display)
|
|
import RIO.Directory
|
|
import RIO.FilePath
|
|
import qualified RIO.Text as T
|
|
import System.IO.Error
|
|
import System.Process
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- read
|
|
|
|
readInt :: MonadIO m => (Read a, Integral a) => FilePath -> m a
|
|
readInt = fmap (fromMaybe 0 . readMaybe . takeWhile isDigit . T.unpack) . readFileUtf8
|
|
|
|
readBool :: MonadIO m => FilePath -> m Bool
|
|
readBool = fmap (== (1 :: Int)) . readInt
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- write
|
|
|
|
writeInt :: (MonadIO m, Show a) => FilePath -> a -> m ()
|
|
writeInt f = writeFileUtf8 f . T.pack . show
|
|
|
|
writeBool :: MonadIO m => FilePath -> Bool -> m ()
|
|
writeBool f b = writeInt f ((if b then 1 else 0) :: Int)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- percent-based read/write
|
|
--
|
|
-- "Raw" values are whatever is stored in sysfs and "percent" is the user-facing
|
|
-- value. Assume that the file being read has a min of 0 and an unchanging max
|
|
-- given by a runtime argument, which is scaled linearly to the range 0-100
|
|
-- (percent).
|
|
rawToPercent :: (Integral a, Integral b, RealFrac c) => (a, a) -> b -> c
|
|
rawToPercent (lower, upper) raw =
|
|
100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)
|
|
|
|
-- rawToPercent upper raw = 100 * fromIntegral raw / fromIntegral upper
|
|
|
|
readPercent :: MonadIO m => (Integral a, RealFrac b) => (a, a) -> FilePath -> m b
|
|
readPercent bounds path = do
|
|
i <- readInt path
|
|
return $ rawToPercent bounds (i :: Integer)
|
|
|
|
percentToRaw :: (Integral a, RealFrac b, Integral c) => (a, a) -> b -> c
|
|
percentToRaw (lower, upper) perc =
|
|
round $
|
|
fromIntegral lower + perc / 100.0 * (fromIntegral upper - fromIntegral lower)
|
|
|
|
writePercent
|
|
:: (MonadIO m, Integral a, RealFrac b)
|
|
=> (a, a)
|
|
-> FilePath
|
|
-> b
|
|
-> m b
|
|
writePercent bounds path perc = do
|
|
let t
|
|
| perc > 100 = 100
|
|
| perc < 0 = 0
|
|
| otherwise = perc
|
|
writeInt path (percentToRaw bounds t :: Int)
|
|
return t
|
|
|
|
writePercentMin
|
|
:: (MonadIO m, Integral a, RealFrac b)
|
|
=> (a, a)
|
|
-> FilePath
|
|
-> m b
|
|
writePercentMin bounds path = writePercent bounds path 0
|
|
|
|
writePercentMax
|
|
:: (MonadIO m, Integral a, RealFrac b)
|
|
=> (a, a)
|
|
-> FilePath
|
|
-> m b
|
|
writePercentMax bounds path = writePercent bounds path 100
|
|
|
|
shiftPercent
|
|
:: (MonadIO m, Integral a, RealFrac b)
|
|
=> (b -> b -> b)
|
|
-> Int
|
|
-> FilePath
|
|
-> (a, a)
|
|
-> m b
|
|
shiftPercent f steps path bounds =
|
|
writePercent bounds path . f stepsize
|
|
=<< readPercent bounds path
|
|
where
|
|
stepsize = 100 / fromIntegral steps
|
|
|
|
incPercent
|
|
:: (MonadIO m, Integral a, RealFrac b)
|
|
=> Int
|
|
-> FilePath
|
|
-> (a, a)
|
|
-> m b
|
|
incPercent = shiftPercent (+)
|
|
|
|
decPercent
|
|
:: (MonadIO m, Integral a, RealFrac b)
|
|
=> Int
|
|
-> FilePath
|
|
-> (a, a)
|
|
-> m b
|
|
decPercent = shiftPercent subtract -- silly (-) operator thingy error
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- permission query
|
|
|
|
data PermResult a = PermResult a | NotFoundError | PermError
|
|
deriving (Show, Eq)
|
|
|
|
-- instance Functor PermResult where
|
|
-- fmap f (PermResult r) = PermResult $ f r
|
|
-- fmap _ NotFoundError = NotFoundError
|
|
-- fmap _ PermError = PermError
|
|
|
|
getPermissionsSafe :: MonadUnliftIO m => FilePath -> m (PermResult Permissions)
|
|
getPermissionsSafe f = do
|
|
r <- tryIO $ getPermissions f
|
|
return $ case r of
|
|
Right z -> PermResult z
|
|
Left (isPermissionError -> True) -> PermError
|
|
Left (isDoesNotExistError -> True) -> NotFoundError
|
|
-- the above error should be the only ones thrown by getPermission,
|
|
-- so the catchall case should never happen
|
|
_ -> error "Unknown permission error"
|
|
|
|
-- isReadable :: FilePath -> IO (PermResult Bool)
|
|
-- isReadable = fmap (fmap readable) . getPermissionsSafe
|
|
|
|
-- isWritable :: FilePath -> IO (PermResult Bool)
|
|
-- isWritable = fmap (fmap writable) . getPermissionsSafe
|
|
|
|
-- | Block until a PID has exited.
|
|
-- Use this to control flow based on a process that was not explicitly started
|
|
-- by the Haskell runtime itself, and thus has no data structures to query.
|
|
waitUntilExit :: (MonadUnliftIO m) => Pid -> m ()
|
|
waitUntilExit pid = do
|
|
res <- doesDirectoryExist $ "/proc" </> show pid
|
|
when res $ do
|
|
threadDelay 100000
|
|
waitUntilExit pid
|
|
|
|
withOpenDisplay :: MonadUnliftIO m => (Display -> m a) -> m a
|
|
withOpenDisplay = bracket (liftIO $ openDisplay "") cleanup
|
|
where
|
|
cleanup dpy = liftIO $ do
|
|
flush dpy
|
|
closeDisplay dpy
|