Common.hs

{-
    Copyright 2015,2017 Markus Ongyerth, Stephan Guenther

    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/>.
-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE CPP #-}
{-|
Module      : Monky.Disk.Common
Description : Provides the common disk interfaces
Maintainer  : moepi
Stability   : experimental
Portability : Linux

This provides the class used by file system specific implementations
-}

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

-- | 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
specialized for different file systems and a generic block device
handler.

This typeclass gives the interface a file system handler has to
implement to be usable.
-}
class FsInfo a where
  -- |Get the bytes free on the file system
  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 Integer
  getFsSize h = do
    u <- getFsUsed h
    f <- getFsFree h
    return (u + f)
  -- |Get the bytes used by the file system
  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 (Integer, Integer, Integer)
  getFsAll h = do
    s <- getFsSize h
    f <- getFsFree h
    u <- getFsUsed h
    return (s, f, u)

-- |Existential datatype to wrap 'FsInfo' instances
data FSI = forall a. FsInfo a => FSI a

-- |Wrap a 'FsInfo' into an 'FSI'
fsToFSI :: FsInfo a => a -> FSI
fsToFSI = FSI

-- |The base path of block devices on the system
blBasePath :: String
blBasePath = "/sys/class/block/"

-- | 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
      return $ concat rec
    else return [x]

-- | 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
      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