packages feed

monky 2.2.0.0 → 2.2.1.0

raw patch · 13 files changed

+362/−95 lines, 13 filesdep +old-time

Dependencies added: old-time

Files

Monky/Disk.hs view
@@ -1,5 +1,5 @@ {--    Copyright 2015 Markus Ongyerth, Stephan Guenther+    Copyright 2015,2017 Markus Ongyerth, Stephan Guenther      This file is part of Monky. @@ -31,6 +31,7 @@   , getDiskReadWrite   , getDiskFree   , getDiskHandle+  , getDiskHandleTag   ) where @@ -71,14 +72,14 @@   -- |Get the space left on the disk-getDiskFree :: DiskHandle -> IO Int+getDiskFree :: DiskHandle -> IO Integer getDiskFree (DiskH (FSI h) _ _ _ _) = getFsFree h  -getBtrfsDH :: (BtrfsHandle, [String]) -> IO DiskHandle+getBtrfsDH :: (BtrfsHandle, [Dev]) -> IO DiskHandle getBtrfsDH (h, devs) = do   -- Open the stat file for each physical device-  fs <- mapM (\dev -> fopen (blBasePath ++ dev ++ "/stat")) devs+  fs <- mapM (\(Dev dev) -> fopen (blBasePath ++ dev ++ "/stat")) devs   -- this gets the right number of IORefs without number hacking   wfs <- mapM (\_ -> newIORef 0) devs   rfs <- mapM (\_ -> newIORef 0) devs@@ -86,8 +87,8 @@   return (DiskH (FSI h) fs wfs rfs t)  -getBlockDH :: (BlockHandle, String) -> IO DiskHandle-getBlockDH (h, dev) = do+getBlockDH :: (BlockHandle, Dev) -> IO DiskHandle+getBlockDH (h, Dev dev) = do   f <- fopen (blBasePath ++ dev ++ "/stat")   wf <- newIORef 0   rf <- newIORef 0@@ -95,15 +96,19 @@   return (DiskH (FSI h) [f] [wf] [rf] t)  --- |Get the disk handle+-- | Get a disk handle from uuid. This special-cases btrfs. getDiskHandle :: String -> IO DiskHandle getDiskHandle uuid = do -- First try btrfs file systems   btrfs <- getBtrfsHandle uuid   case btrfs of     (Just x) -> getBtrfsDH x-    Nothing -> do-      block <- getBlockHandle uuid-      case block of+    Nothing -> getDiskHandleTag "UUID" uuid++-- | Get the disk handle from a user chosen blkid tag.+getDiskHandleTag :: String -> String -> IO DiskHandle+getDiskHandleTag t v = do+    block <- getBlockHandleTag t v+    case block of         Just x -> getBlockDH x         Nothing -> error "Disk currently does not support your setup"
Monky/Disk/Btrfs.hs view
@@ -1,5 +1,5 @@ {--    Copyright 2015 Markus Ongyerth, Stephan Guenther+    Copyright 2015,2017 Markus Ongyerth, Stephan Guenther      This file is part of Monky. @@ -47,7 +47,7 @@  -- Size data metadata system -- |The FsInfo exported by this module-data BtrfsHandle = BtrfsH Int File File File+data BtrfsHandle = BtrfsH Integer File File File  instance FsInfo BtrfsHandle where   getFsSize = return . getSize@@ -58,32 +58,33 @@ fsBasePath = "/sys/fs/btrfs/"  -sectorSize :: Int+sectorSize :: Num a => a sectorSize = 512  -getSize :: BtrfsHandle -> Int+getSize :: BtrfsHandle -> Integer getSize (BtrfsH s _ _ _) = s  -getUsed :: BtrfsHandle -> IO Int+getUsed :: BtrfsHandle -> IO Integer getUsed (BtrfsH _ d m s) = do-  dv <- readValue d-  mv <- readValue m-  sm <- readValue s+  dv <- readValueI d+  mv <- readValueI m+  sm <- readValueI s   return $ dv + mv + sm --- |Get the block devices used by a btrfs FileSystem. This resolves mappers as far as possible-getFSDevices :: String -> IO [String]+-- | Get the block devices used by a btrfs FileSystem. This resolves mappers as far as possible+getFSDevices :: String -> IO [Dev] getFSDevices fs = do-  let devP = fsBasePath ++ fs ++ "/devices/"-  concat <$> (mapM mapperToDev =<< listDirectory devP)+    let devP = fsBasePath ++ fs ++ "/devices/"+    devices <- map Label <$> listDirectory devP+    concat <$> mapM mapperToDev devices   getBtrfsHandle' :: String -> IO BtrfsHandle getBtrfsHandle' fs = do   devices <- getFSDevices fs-  sizes <- mapM (\dev -> fmap read $ readFile (blBasePath ++ dev ++ "/size")) devices+  sizes <- mapM (\(Dev dev) -> fmap read $ readFile (blBasePath ++ dev ++ "/size")) devices   let size = sum sizes   d <- fopen (fsBasePath ++ fs ++ "/allocation/data/bytes_used")   m <- fopen (fsBasePath ++ fs ++ "/allocation/metadata/bytes_used")@@ -104,7 +105,7 @@ -} getBtrfsHandle   :: String -- ^The UUID of the file system to monitor-  -> IO (Maybe (BtrfsHandle, [String]))+  -> IO (Maybe (BtrfsHandle, [Dev])) getBtrfsHandle fs = do   e <- doesDirectoryExist (fsBasePath ++ fs)   if e
Monky/Disk/Common.hs view
@@ -1,5 +1,5 @@ {--    Copyright 2015 Markus Ongyerth, Stephan Guenther+    Copyright 2015,2017 Markus Ongyerth, Stephan Guenther      This file is part of Monky. @@ -36,19 +36,74 @@   , blBasePath   , devToMapper   , mapperToDev+  , Dev (..)+  , Label (..)+  , labelToDev   ) where +import qualified Data.Map as M+import Data.Map (Map)+import Data.Bits+import Data.Maybe (fromMaybe)+import Data.Tuple (swap) import Monky.Utility import System.Directory (doesDirectoryExist) import Data.List (nub, sort)+import System.Posix.Files  #if MIN_VERSION_base(4,8,0) #else import Control.Applicative ((<$>)) #endif +newtype Label = Label { getLabel :: String } deriving (Show, Eq, Ord)+newtype Dev = Dev { getDev :: String } deriving (Show, Eq, Ord) +ltd :: Label -> Dev+ltd (Label x) = Dev x++dtl :: Dev -> Label+dtl (Dev x) = Label x++-- | Get the real device (e.g. dm-0) that's behind a device name+getMapperDev :: Label -> IO Dev+getMapperDev (Label dev) = do+    let devPath = "/dev/mapper/" ++ dev+    stat <- getSymbolicLinkStatus devPath+    Dev <$> if isSymbolicLink stat+        then reverse . takeWhile (/= '/') . reverse <$> readSymbolicLink devPath+        else if isBlockDevice stat+            then return ("dm-" ++ (show . snd $ statToMM stat))+            else error msg+    where msg = "The disk resolution is a bit buggy currently please make a bug report with an `ls -lh` of your /dev/mapper"++--  This could in theory be a global+getLabelPairs :: IO [(Label, Dev)]+getLabelPairs = do+    devs <- filter (/= "control") <$> listDirectory "/dev/mapper/"+    let labels = map Label devs+    mapM (\s -> (\d -> (s, d)) <$> getMapperDev s) labels++getLabelMap :: IO (Map Label Dev)+getLabelMap = M.fromList <$> getLabelPairs++getDeviceMap :: IO (Map Dev Label)+getDeviceMap = M.fromList . map swap <$> getLabelPairs++labelToDev' :: Map Label Dev -> Label -> Dev+labelToDev' m l =+    fromMaybe (ltd l) $ M.lookup l m++devToLabel' :: Map Dev Label -> Dev -> Label+devToLabel' m d =+    fromMaybe (dtl d) $ M.lookup d m++labelToDev :: Label -> IO Dev+labelToDev l = do+    m <- getLabelMap+    return $ labelToDev' m l+ {-| Type class that should be instanciated by file system handlers  The Monky.Disk module is designed to work with different handlers@@ -60,26 +115,26 @@ -} class FsInfo a where   -- |Get the bytes free on the file system-  getFsFree :: a -> IO Int+  getFsFree :: a -> IO Integer   getFsFree h = do     s <- getFsSize h     u <- getFsUsed h     return (s - u)   -- |Get the total size of the file system-  getFsSize :: a -> IO Int+  getFsSize :: a -> IO Integer   getFsSize h = do     u <- getFsUsed h     f <- getFsFree h     return (u + f)   -- |Get the bytes used by the file system-  getFsUsed :: a -> IO Int+  getFsUsed :: a -> IO Integer   getFsUsed h = do     s <- getFsSize h     f <- getFsFree h     return (s - f)   -- |Get all data, might be more efficient   -- (Size, Free, Used)-  getFsAll :: a -> IO (Int, Int, Int)+  getFsAll :: a -> IO (Integer, Integer, Integer)   getFsAll h = do     s <- getFsSize h     f <- getFsFree h@@ -97,24 +152,45 @@ blBasePath :: String blBasePath = "/sys/class/block/" --- |Get the physical block devices supporting some device-mapperToDev :: String -> IO [String]-mapperToDev x = sort . nub <$> do+-- | Go from the FileStatus record to Major and Minor device number+statToMM :: FileStatus -> (Int, Int)+statToMM stat =+    let both = fromIntegral . specialDeviceID $ stat+     in (both `shiftR` 8, both .&. 8)++-- | Traverse the device tree downwards (find all devices used) in kernel+-- | devcice name hirarchy+mapperToDev' :: String -> IO [String]+mapperToDev' x = sort . nub <$> do   let path = blBasePath ++ x ++ "/slaves/"   e <- doesDirectoryExist path   if e     then do-      rec <- mapM mapperToDev =<< listDirectory path+      rec <- mapM mapperToDev' =<< listDirectory path       return $ concat rec     else return [x] --- |Get the "top most" virtual device(s) based on the physical device-devToMapper :: String -> IO [String]-devToMapper x = sort . nub <$> do+-- | Get the physical block devices supporting some device+mapperToDev :: Label -> IO [Dev]+mapperToDev x = do+    m <- getLabelMap+    let (Dev dev) = fromMaybe (ltd x) $ M.lookup x m+    map Dev <$> mapperToDev' dev++-- | Traverse the device tree upwards (find all users of a device) in+-- | kernel device name hirarchy+devToMapper' :: String -> IO [String]+devToMapper' x = sort . nub <$> do   let path = blBasePath ++ x ++ "/holders/"   holders <- listDirectory path   if null holders     then return [x]     else do-      rec <- mapM devToMapper holders+      rec <- mapM devToMapper' holders       return $ concat rec++-- |Get the "top most" virtual device(s) based on the physical device+devToMapper :: Dev -> IO [Label]+devToMapper (Dev x) = do+    m <- getDeviceMap+    map (devToLabel' m . Dev) <$> devToMapper' x
Monky/Disk/Device.hs view
@@ -1,5 +1,5 @@ {--    Copyright 2015 Markus Ongyerth, Stephan Guenther+    Copyright 2015,2017 Markus Ongyerth, Stephan Guenther      This file is part of Monky. @@ -34,6 +34,7 @@ module Monky.Disk.Device   ( BlockHandle(..)   , getBlockHandle+  , getBlockHandleTag    , devToMount   )@@ -59,13 +60,13 @@ First one is mostly determined by order in /proc/mounts and should be the one that was mounted first (time since boot). -}-devToMount :: String -> IO (Maybe String)+devToMount :: Dev -> IO (Maybe String) devToMount dev = do   masters <- devToMapper dev   mounts <- map (take 2 . words) . lines <$> readFile "/proc/mounts"   return . listToMaybe . map (!! 1) $ filter (isDev masters) mounts   where-    isDev masters [x, _] = any (\master -> ('/':master) `isSuffixOf` x) masters+    isDev masters [x, _] = any (\(Label master) -> ('/':master) `isSuffixOf` x) masters     isDev _ _ = error "devToMount: How does take 2 not match [_, _]?"  @@ -78,24 +79,24 @@   getFsFree = getFree  -getSize :: BlockHandle -> IO Int+getSize :: BlockHandle -> IO Integer getSize (BlockH path) = do   fstat <- statVFS path-  return $fromIntegral (fromIntegral (statVFS_blocks fstat) * statVFS_frsize fstat)+  return $ (fromIntegral $ statVFS_blocks fstat) * (fromIntegral $ statVFS_frsize fstat)  -getFree :: BlockHandle -> IO Int+getFree :: BlockHandle -> IO Integer getFree (BlockH path) = do   fstat <- statVFS path-  return $fromIntegral (fromIntegral (statVFS_bavail fstat) * statVFS_frsize fstat)+  return $ (fromIntegral $ statVFS_bavail fstat) * (fromIntegral $ statVFS_frsize fstat)  -getBlockHandle' :: String -> IO (Maybe (BlockHandle, String))+getBlockHandle' :: Dev -> IO (Maybe (BlockHandle, Dev)) getBlockHandle' dev = do   path <- devToMount dev   case path of-    Just x -> return $Just (BlockH x, dev)-    Nothing -> return Nothing+        Just x -> return $Just (BlockH x, dev)+        Nothing -> return Nothing  {- |Get a fs handle for 'normal' devices @@ -105,9 +106,15 @@  In case of mapper devices, this is done by going through the chain of slaves. -}-getBlockHandle :: String -> IO (Maybe (BlockHandle, String))-getBlockHandle fs = do-  dev <- evaluateTag "UUID" fs+getBlockHandle :: String -> IO (Maybe (BlockHandle, Dev))+getBlockHandle = getBlockHandleTag "UUID"++-- | Same as 'getBlockHandle' but allow to pass the tag for libblkid+getBlockHandleTag :: String -> String -> IO (Maybe (BlockHandle, Dev))+getBlockHandleTag t fs = do+  dev <- evaluateTag t fs   case dev of-    Just x -> getBlockHandle' (reverse $takeWhile (/= '/') $reverse x)+    Just x -> do+        y <- labelToDev (Label . reverse . takeWhile (/= '/') . reverse $ x)+        getBlockHandle' y     Nothing -> return Nothing
Monky/Examples/Disk.hs view
@@ -27,6 +27,7 @@ -} module Monky.Examples.Disk   ( getDiskHandle+  , getDiskHandleTag   , DiskH   ) where@@ -36,23 +37,30 @@ import Monky.Examples.Utility import Monky.Examples.Images import Monky.Modules-import Monky.Disk hiding (getDiskHandle)-import qualified Monky.Disk as D (getDiskHandle)+import Control.Applicative ((<$>))+import qualified Monky.Disk as D  -- |The handle type for this module-newtype DiskH = DH DiskHandle+newtype DiskH = DH D.DiskHandle --- |Get a disk handle+-- |Get a disk handle by uuid. This special cases btrfs getDiskHandle   :: String -- ^The UUID of the device to monitor. It has to be mounted at monky startup!   -> IO DiskH getDiskHandle = fmap DH . D.getDiskHandle +-- |Get a disk handle from a given tag+getDiskHandleTag+  :: String -- ^Which tag to give to libblkid+  -> String -- ^The value of the tag+  -> IO DiskH+getDiskHandleTag t v = DH <$> D.getDiskHandleTag t v+ {- Disk module -} instance PollModule DiskH where   getOutput (DH dh) = do-    (dr, dw) <- getDiskReadWrite dh-    df <- getDiskFree dh+    (dr, dw) <- D.getDiskReadWrite dh+    df <- D.getDiskFree dh     return       [ diskImage       , MonkyPlain $ sformat (stext % " " % stext % " " % stext) (convertUnitSI df "B") (convertUnitSI dr "B" ) (convertUnitSI dw "B")
Monky/Examples/MPD.hs view
@@ -1,5 +1,5 @@ {--    Copyright 2015,2016 Markus Ongyerth+    Copyright 2015-2017 Markus Ongyerth      This file is part of Monky. @@ -16,6 +16,7 @@     You should have received a copy of the GNU Lesser General Public License     along with Monky.  If not, see <http://www.gnu.org/licenses/>. -}+{-# LANGUAGE OverloadedStrings #-} {-| Module      : Monky.Examples.MPD Description : An example module instance for the MPD module@@ -30,6 +31,7 @@ module Monky.Examples.MPD   ( MPDHandle   , getMPDHandle+  , getMPDHandleF   ) where @@ -37,7 +39,6 @@ import qualified Data.Text as T  import Data.IORef-import Data.Maybe (fromMaybe) import System.IO (hPutStrLn, stderr) import System.Posix.Types (Fd) @@ -47,35 +48,37 @@  #if MIN_VERSION_base(4,8,0) #else-import Control.Applicative ((<$>))+import Control.Applicative ((<$>), pure, (<*>)) #endif -getPlayingSong :: State -> MPDSocket -> IO (Either String SongInfo)-getPlayingSong Playing s = getMPDSong s-getPlayingSong _ _ = return (Left "Not playing")---extractTitle :: SongInfo -> Maybe Text-extractTitle = tagTitle . songTags-+type ConvertFun = (State, Maybe SongInfo) -> Text -getSongTitle :: MPDSocket -> IO Text-getSongTitle sock = getMPDStatus sock >>= getSong+getSongTitle :: MPDSocket -> ConvertFun -> IO Text+-- TODO: Clean this up a bit. Probably do notation?+getSongTitle sock fun = (fmap state <$> getMPDStatus sock) >>= getSong   where getSong (Left x) = return . T.pack $ x-        getSong (Right status) = getTitle <$> getPlayingSong (state status) sock-        getTitle (Left x) = T.pack x-        getTitle (Right x) = fromMaybe "No Title" $extractTitle x+        getSong (Right Playing) = do+            info <- getMPDSong sock+            case info of+                Right x -> pure $ fun (Playing, Just x)+                Left x -> pure $ T.pack x+        getSong (Right x) = pure $ fun (x, Nothing)   -- |The handle for this example-data MPDHandle = MPDHandle String String (IORef (Maybe MPDSocket))+data MPDHandle = MPDHandle+    { _host :: String+    , _port :: String+    , _sock :: IORef (Maybe MPDSocket)+    , _convert :: ConvertFun+    }   -- TODO ignoring errors is never a good idea-getEvent :: MPDSocket -> IO Text-getEvent s = do+getEvent :: MPDSocket -> ConvertFun -> IO Text+getEvent s fun = do   _ <- readOk s-  t <- getSongTitle s+  t <- getSongTitle s fun   _ <- goIdle s " player"   return t @@ -88,14 +91,14 @@   instance PollModule MPDHandle where-  getOutput (MPDHandle _ _ s) = do+  getOutput (MPDHandle _ _ s f) = do     r <- readIORef s     case r of       Nothing -> return [MonkyPlain "Broken"]       (Just x) -> do-        ret <- getSongTitle x+        ret <- getSongTitle x f         return [MonkyPlain ret]-  initialize (MPDHandle h p r) = do+  initialize (MPDHandle h p r _) = do     s <- getMPDSocket h p     case s of       (Right x) -> writeIORef r (Just x)@@ -103,7 +106,7 @@   instance EvtModule MPDHandle where-  startEvtLoop h@(MPDHandle _ _ s) fun = do+  startEvtLoop h@(MPDHandle _ _ s f) fun = do     initialize h     fun =<< getOutput h     r <- readIORef s@@ -111,13 +114,29 @@       Nothing -> hPutStrLn stderr "Could not initialize MPDHandle :("       (Just x) -> do         [fd] <- getFd x-        loopFd x fd fun (fmap (\y -> [MonkyPlain y]) . getEvent)+        loopFd x fd fun (fmap (\y -> [MonkyPlain y]) . flip getEvent f) +defaultConvert :: (State, Maybe SongInfo) -> Text+defaultConvert (Playing, Just x) = case tagTitle . songTags $ x of+    Nothing -> "Can't extract song title"+    Just y -> y+defaultConvert (Playing, Nothing) = "Can't extract song"+defaultConvert _ = "Not Playing"  -- |Get an 'MPDHandle' (server has to be running when this is executed) getMPDHandle   :: String -- ^The host to connect to- -> String  -- ^The port to connect to- -> IO MPDHandle-getMPDHandle h p = MPDHandle h p <$> newIORef Nothing+  -> String  -- ^The port to connect to+  -> IO MPDHandle+getMPDHandle h p =+    MPDHandle h p <$> newIORef Nothing <*> pure defaultConvert +-- | Get the 'MPDHandle' with a custom conversion function. You will need to+-- import `Monky.MPD` to get the definitions into scope+getMPDHandleF+    :: String -- ^The host to connect to+    -> String -- ^The port to connect to+    -> ConvertFun -- ^The function to extract the text+    -> IO MPDHandle+getMPDHandleF h p f =+    MPDHandle h p <$> newIORef Nothing <*> pure f
+ Monky/Examples/Tminus.hs view
@@ -0,0 +1,87 @@+{-+    Copyright 2017 Donat Khabibullaev++    This file is part of Monky.++    Monky is free software: you can redistribute it and/or modify+    it under the terms of the GNU Lesser General Public License as published by+    the Free Software Foundation, either version 3 of the License, or+    (at your option) any later version.++    Monky is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU Lesser General Public License for more details.++    You should have received a copy of the GNU Lesser General Public License+    along with Monky.  If not, see <http://www.gnu.org/licenses/>.+-}+{-|+Module      : Monky.Examples.Tminus+Description : Countdown clock for a specific time of day+Stability   : testing++-}+module Monky.Examples.Tminus+  ( getTargetHandle+  )+where++import Control.Applicative (pure)+import Data.Time.Clock (getCurrentTime)+import Data.Time.LocalTime+import System.Time+import qualified Data.Text as T++import Monky.Modules++getTargetHandle :: [Int] -> IO TargetTime+getTargetHandle xs = pure $ TargetTime xs++-- target time+-- HH MM SS+newtype TargetTime = TargetTime [Int]++{- | Render a number of seconds as a human-readable amount.  Shows the two+most significant places.  For instance:++>renderSecs 121 = "2m 1s"+-}+renderSecs :: Integer -> String+renderSecs i = renderTD $ diffClockTimes (TOD i 0) (TOD 0 0)++{- | Like 'renderSecs', but takes a TimeDiff instead of an integer second+count. -}+renderTD :: TimeDiff -> String+renderTD itd =+    case workinglist of+      [] -> "0s"+      _ -> unwords . map (\(q, s) -> show q ++ [s]) $ workinglist+    where td = normalizeTimeDiff itd+          suffixlist = "yMdhms"+          quantlist = (\(TimeDiff y mo d h m s _) -> [y, mo, d, h, m, s]) td+          zippedlist = zip quantlist suffixlist+          -- Drop all leading elements that are 0, then take at most 2+          workinglist = take 2 . dropWhile (\(q, _) -> q == 0) $ zippedlist++{- | Convert a list of hour, minute, seconds to seconds. -}+timeToSeconds :: [Int] -> Int+timeToSeconds l = sum (zipWith (*) l [3600, 60, 1])++diffTime :: Int -> Int -> Int+diffTime a b+    | a < b = a + (86400 - b)+    | otherwise = a - b++getCurrent :: TargetTime -> IO [MonkyOut]+getCurrent (TargetTime target) = do+    now <- getCurrentTime+    timezone <- getCurrentTimeZone+    let (TimeOfDay hour minute second) = localTimeOfDay $ utcToLocalTime timezone now+        nowSeconds = timeToSeconds [hour, minute, (floor second)]+        targetSeconds = timeToSeconds target+        delta = diffTime targetSeconds nowSeconds+    pure $ [ MonkyPlain . T.pack $ renderSecs (toInteger delta) ]++instance PollModule TargetTime where+    getOutput t = getCurrent t
Monky/Examples/Utility.hs view
@@ -1,5 +1,5 @@ {--    Copyright 2016 Markus Ongyerth+    Copyright 2016,2017 Markus Ongyerth      This file is part of Monky. @@ -72,7 +72,7 @@ convertUnitSI :: Integral a => a -> Text -> Text convertUnitSI rate b = convertUnitT (fromIntegral rate) 1000 b "k" "M" "G" -convertUnitT :: Float -> Int -> Text -> Text -> Text -> Text -> Text+convertUnitT :: Double -> Int -> Text -> Text -> Text -> Text -> Text convertUnitT rate step bs ks ms gs   | rate < fromIntegral (kf       ) = sformat ((left 4 ' ' %. fixed 0) % stext) rate bs   | rate < fromIntegral (kf * 10  ) = sformat ((left 4 ' ' %. fixed 2) % stext) kv ks
Monky/Examples/Wifi/Event.hs view
@@ -34,6 +34,9 @@   ( getWifiHandle   , getWifiHandle' +  , guessWifiHandle+  , guessWifiHandle'+   , getTextify    , WifiEvtHandle@@ -96,6 +99,28 @@     s <- getSSIDSocket     i <- fromMaybe (error ("Could not find interface: " ++ n)) <$> getInterface s n     return (WH s i f d)++-- | Lower level version of 'guessWifiHandle' for more control+guessWifiHandle'+    :: (WifiStats -> Text)+    -> Text -- ^Text that should be displayed when wifi is disconnected+    -> IO WifiEvtHandle+guessWifiHandle' f d = do+    s <- getSSIDSocket+    i <- fromMaybe (error "Couldn't find any NL80211 interface") <$> guessInterface s+    return (WH s i f d)++{- | Get a wifi handle, guess the interface++Guess isn't quite the right word here. This asks the NL80211 subsystem for a+list of devices and picks the first one.+-}+guessWifiHandle+    :: [WifiFormat] -- ^Format "String" for output generation+    -> Text -- ^Text that should be displayed when wifi is disconnected+    -> IO WifiEvtHandle+guessWifiHandle f d =+    guessWifiHandle' (getFunction f) d  getEventOutput :: WifiEvtHandle -> IO [MonkyOut] getEventOutput (WH s i f d) = do
Monky/Examples/Wifi/Poll.hs view
@@ -36,11 +36,12 @@      , getWifiHandle     , getWifiHandle'++    , guessWifiHandle+    , guessWifiHandle'     ) where -import Debug.Trace- import Data.Int (Int8)  import Data.Maybe (fromMaybe)@@ -153,7 +154,7 @@ getExtFun FormatSignal (_, info) =     case staSignalMBM info of         Nothing -> "No strength"-        Just x -> sformat int . doMBM . traceShowId $ fromIntegral x+        Just x -> sformat int . doMBM $ fromIntegral x getExtFun FormatSignalAverage (_, info) =     case staSignalMBMA info of         Nothing -> "No strength"@@ -184,7 +185,7 @@             ext <- getExtendedWifi s i x             pure . pure . MonkyPlain $ f (x, ext) --- | Lower level version of 'getWifiHandle' if you need exted information.+-- | Lower level version of 'getWifiHandle' for more level of control getWifiHandle'     :: ((WifiStats, Maybe NL80211Packet) -> Text)     -> Text@@ -203,3 +204,25 @@   -> IO WifiPollHandle getWifiHandle f d n =   getWifiHandle' (getCombiFun f) d n++-- | Lower level version of 'guessWifiHandle' for more control+guessWifiHandle'+    :: ((WifiStats, Maybe NL80211Packet) -> Text)+    -> Text -- ^Text that should be displayed when wifi is disconnected+    -> IO WifiPollHandle+guessWifiHandle' f d = do+    s <- getSSIDSocket+    i <- fromMaybe (error "Couldn't find any NL80211 interface") <$> guessInterface s+    return (WH s i f d)++{- | Get a wifi handle, guess the interface++Guess isn't quite the right word here. This asks the NL80211 subsystem for a+list of devices and picks the first one.+-}+guessWifiHandle+    :: [WifiFormat] -- ^Format "String" for output generation+    -> Text -- ^Text that should be displayed when wifi is disconnected+    -> IO WifiPollHandle+guessWifiHandle f d =+    guessWifiHandle' (getCombiFun f) d
Monky/Utility.hs view
@@ -29,6 +29,7 @@ -} module Monky.Utility     ( readValue+    , readValueI     , readValues     , fopen     , fclose@@ -106,6 +107,15 @@   line <- hGetReadable h   let value = fmap fst $ BS.readInt line   return . fromMaybe (error ("Failed to read value from file:" ++ show h)) $ value++-- |Read the first line of the file and convert it into an 'Integer'+readValueI :: File -> IO Integer+readValueI (File h) = do+  hSeek h AbsoluteSeek 0+  line <- hGetReadable h+  let value = fmap fst $ BS.readInteger line+  return . fromMaybe (error ("Failed to read value from file:" ++ show h)) $ value+  -- |Read the first line of the file and convert the words in it into 'Int's readValues :: File -> IO [Int]
Monky/Wifi.hs view
@@ -29,6 +29,7 @@   ( getCurrentWifi   , getCurrentWifiStats   , getInterface+  , guessInterface   , gotReadable   , getSSIDSocket   , Interface@@ -65,7 +66,7 @@  #if MIN_VERSION_base(4,8,0) #else-import Control.Applicative ((<$>))+import Control.Applicative ((<$>), pure) #endif  -- |The interface identifier@@ -157,6 +158,10 @@   interfaces <- getInterfaceList s   return $ snd <$> listToMaybe (filter ((==) n . fst) interfaces) +guessInterface :: SSIDSocket -> IO (Maybe Interface)+guessInterface (SSIDSocket s _) = do+    interfaces <- getInterfaceList s+    pure $ snd <$> listToMaybe interfaces  -- |get the raw fd for eventing getWifiFd :: SSIDSocket -> Fd
monky.cabal view
@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             2.2.0.0+version:             2.2.1.0  -- The ABOVE LINE has to stay AS IS (except for version changes) for the -- template to work properly@@ -140,6 +140,7 @@   exposed-modules: Monky.Examples.Connectivity Monky.Network.Dynamic   exposed-modules: Monky.Network.Static Monky.Examples.File Monky.Examples.Utility   exposed-modules: Monky.Examples.Sound.Alsa  Monky.Examples.Alsa +  exposed-modules: Monky.Examples.Tminus    exposed-modules: Monky.Version Monky.Examples.Combine   exposed-modules: Monky.Examples.Plain Monky.Disk.Common Monky.Blkid@@ -153,10 +154,10 @@   other-modules: Monky.Template Monky.VersionTH Monky.CUtil  -  build-depends:       base >=4.6.0.1 && <=5, directory, time+  build-depends:       base >=4.6.0.1 && <=5, directory, time, old-time   build-depends:       text, unix, network, mtl, transformers   build-depends:       template-haskell, containers, stm, statvfs-  build-depends:       bytestring, netlink, cereal, formatting, composition+  build-depends:       bytestring, netlink >= 1.1, cereal, formatting, composition   build-depends:       env-locale >= 1.0.0.1    -- force double-conversion version for old ghc/library?