summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorongyerth <>2017-07-15 10:35:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-07-15 10:35:00 (GMT)
commit4c697dc89ddec7eccb460f3575d79f80b8ddb447 (patch)
tree921677af3a16e6d060b5e243b09c8bebcb965636
parent5a60a9c2b096817f65e2cb35a680c390c8900822 (diff)
version 2.2.1.02.2.1.0
-rw-r--r--Monky/Disk.hs25
-rw-r--r--Monky/Disk/Btrfs.hs29
-rw-r--r--Monky/Disk/Common.hs102
-rw-r--r--Monky/Disk/Device.hs35
-rw-r--r--Monky/Examples/Disk.hs20
-rw-r--r--Monky/Examples/MPD.hs77
-rw-r--r--Monky/Examples/Tminus.hs87
-rw-r--r--Monky/Examples/Utility.hs4
-rw-r--r--Monky/Examples/Wifi/Event.hs25
-rw-r--r--Monky/Examples/Wifi/Poll.hs31
-rw-r--r--Monky/Utility.hs10
-rw-r--r--Monky/Wifi.hs7
-rw-r--r--monky.cabal7
13 files changed, 363 insertions, 96 deletions
diff --git a/Monky/Disk.hs b/Monky/Disk.hs
index e627c15..a160910 100644
--- a/Monky/Disk.hs
+++ b/Monky/Disk.hs
@@ -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 @@ module Monky.Disk
, getDiskReadWrite
, getDiskFree
, getDiskHandle
+ , getDiskHandleTag
)
where
@@ -71,14 +72,14 @@ getDiskReadWrite (DiskH _ fs readrefs writerefs timeref) = do
-- |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 @@ getBtrfsDH (h, devs) = do
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 @@ getBlockDH (h, dev) = do
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"
diff --git a/Monky/Disk/Btrfs.hs b/Monky/Disk/Btrfs.hs
index a473a82..4441d25 100644
--- a/Monky/Disk/Btrfs.hs
+++ b/Monky/Disk/Btrfs.hs
@@ -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 @@ import Control.Applicative ((<$>))
-- 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 :: String
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 @@ device may be quite different to the one that application see.
-}
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
diff --git a/Monky/Disk/Common.hs b/Monky/Disk/Common.hs
index 141fade..d546fcb 100644
--- a/Monky/Disk/Common.hs
+++ b/Monky/Disk/Common.hs
@@ -1,5 +1,5 @@
{-
- Copyright 2015 Markus Ongyerth, Stephan Guenther
+ Copyright 2015,2017 Markus Ongyerth, Stephan Guenther
This file is part of Monky.
@@ -36,18 +36,73 @@ module Monky.Disk.Common
, 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
@@ -60,26 +115,26 @@ implement to be usable.
-}
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 @@ fsToFSI = FSI
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
diff --git a/Monky/Disk/Device.hs b/Monky/Disk/Device.hs
index dd68ead..35f61ed 100644
--- a/Monky/Disk/Device.hs
+++ b/Monky/Disk/Device.hs
@@ -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 @@ file system
module Monky.Disk.Device
( BlockHandle(..)
, getBlockHandle
+ , getBlockHandleTag
, devToMount
)
@@ -59,13 +60,13 @@ return the first one found.
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 @@ instance FsInfo BlockHandle where
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 @@ fsStat takes the mount point of the file system, so we need to find the mount po
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
diff --git a/Monky/Examples/Disk.hs b/Monky/Examples/Disk.hs
index 28a5e0a..384bd65 100644
--- a/Monky/Examples/Disk.hs
+++ b/Monky/Examples/Disk.hs
@@ -27,6 +27,7 @@ Portability : Linux
-}
module Monky.Examples.Disk
( getDiskHandle
+ , getDiskHandleTag
, DiskH
)
where
@@ -36,23 +37,30 @@ import Formatting
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")
diff --git a/Monky/Examples/MPD.hs b/Monky/Examples/MPD.hs
index fdb120a..6323732 100644
--- a/Monky/Examples/MPD.hs
+++ b/Monky/Examples/MPD.hs
@@ -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 @@ Portability : Linux
module Monky.Examples.MPD
( MPDHandle
, getMPDHandle
+ , getMPDHandleF
)
where
@@ -37,7 +39,6 @@ import Data.Text (Text)
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 @@ import Monky.Examples.Utility
#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 @@ getFd s = do
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 PollModule MPDHandle where
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 @@ instance EvtModule MPDHandle where
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
diff --git a/Monky/Examples/Tminus.hs b/Monky/Examples/Tminus.hs
new file mode 100644
index 0000000..284888f
--- /dev/null
+++ b/Monky/Examples/Tminus.hs
@@ -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
diff --git a/Monky/Examples/Utility.hs b/Monky/Examples/Utility.hs
index cb3cb49..ca22579 100644
--- a/Monky/Examples/Utility.hs
+++ b/Monky/Examples/Utility.hs
@@ -1,5 +1,5 @@
{-
- Copyright 2016 Markus Ongyerth
+ Copyright 2016,2017 Markus Ongyerth
This file is part of Monky.
@@ -72,7 +72,7 @@ convertUnitB rate b = convertUnitT (fromIntegral rate) 1024 (" " `T.append` b) "
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
diff --git a/Monky/Examples/Wifi/Event.hs b/Monky/Examples/Wifi/Event.hs
index f7c818f..bbaa034 100644
--- a/Monky/Examples/Wifi/Event.hs
+++ b/Monky/Examples/Wifi/Event.hs
@@ -34,6 +34,9 @@ module Monky.Examples.Wifi.Event
( getWifiHandle
, getWifiHandle'
+ , guessWifiHandle
+ , guessWifiHandle'
+
, getTextify
, WifiEvtHandle
@@ -97,6 +100,28 @@ getWifiHandle' f d n = do
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
new <- gotReadable s i
diff --git a/Monky/Examples/Wifi/Poll.hs b/Monky/Examples/Wifi/Poll.hs
index 200d421..e6c5a9e 100644
--- a/Monky/Examples/Wifi/Poll.hs
+++ b/Monky/Examples/Wifi/Poll.hs
@@ -36,11 +36,12 @@ module Monky.Examples.Wifi.Poll
, getWifiHandle
, getWifiHandle'
+
+ , guessWifiHandle
+ , guessWifiHandle'
)
where
-import Debug.Trace
-
import Data.Int (Int8)
import Data.Maybe (fromMaybe)
@@ -153,7 +154,7 @@ getExtFun FormatBitrateMin (_, info) = -- Bitrate from RX/TX Rate
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 @@ instance PollModule WifiPollHandle where
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 @@ getWifiHandle
-> 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
diff --git a/Monky/Utility.hs b/Monky/Utility.hs
index e61cfaa..bdc7ea7 100644
--- a/Monky/Utility.hs
+++ b/Monky/Utility.hs
@@ -29,6 +29,7 @@ This module provides utility functions used in monky modules
-}
module Monky.Utility
( readValue
+ , readValueI
, readValues
, fopen
, fclose
@@ -107,6 +108,15 @@ readValue (File h) = do
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]
readValues (File h) = do
diff --git a/Monky/Wifi.hs b/Monky/Wifi.hs
index 8b84051..9e3b594 100644
--- a/Monky/Wifi.hs
+++ b/Monky/Wifi.hs
@@ -29,6 +29,7 @@ module Monky.Wifi
( getCurrentWifi
, getCurrentWifiStats
, getInterface
+ , guessInterface
, gotReadable
, getSSIDSocket
, Interface
@@ -65,7 +66,7 @@ import Data.Serialize.Put (runPut, putWord32host)
#if MIN_VERSION_base(4,8,0)
#else
-import Control.Applicative ((<$>))
+import Control.Applicative ((<$>), pure)
#endif
-- |The interface identifier
@@ -157,6 +158,10 @@ getInterface (SSIDSocket s _) n = do
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
diff --git a/monky.cabal b/monky.cabal
index 61bf0cc..1d49949 100644
--- a/monky.cabal
+++ b/monky.cabal
@@ -10,7 +10,7 @@ name: monky
-- 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 @@ library
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 @@ library
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?