module Monky.Disk.Common
( FSI(FSI)
, FsInfo(..)
, fsToFSI
, 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
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"
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
class FsInfo a where
getFsFree :: a -> IO Integer
getFsFree h = do
s <- getFsSize h
u <- getFsUsed h
return (s u)
getFsSize :: a -> IO Integer
getFsSize h = do
u <- getFsUsed h
f <- getFsFree h
return (u + f)
getFsUsed :: a -> IO Integer
getFsUsed h = do
s <- getFsSize h
f <- getFsFree h
return (s f)
getFsAll :: a -> IO (Integer, Integer, Integer)
getFsAll h = do
s <- getFsSize h
f <- getFsFree h
u <- getFsUsed h
return (s, f, u)
data FSI = forall a. FsInfo a => FSI a
fsToFSI :: FsInfo a => a -> FSI
fsToFSI = FSI
blBasePath :: String
blBasePath = "/sys/class/block/"
statToMM :: FileStatus -> (Int, Int)
statToMM stat =
let both = fromIntegral . specialDeviceID $ stat
in (both `shiftR` 8, both .&. 8)
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
return $ concat rec
else return [x]
mapperToDev :: Label -> IO [Dev]
mapperToDev x = do
m <- getLabelMap
let (Dev dev) = fromMaybe (ltd x) $ M.lookup x m
map Dev <$> mapperToDev' dev
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
return $ concat rec
devToMapper :: Dev -> IO [Label]
devToMapper (Dev x) = do
m <- getDeviceMap
map (devToLabel' m . Dev) <$> devToMapper' x