Cache.hsc

{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ForeignFunctionInterface #-}

-- | Basic routines to work with @libblkid@ cache.
module System.Linux.Blkid.Cache
    ( CacheT
    , withCache
    , gcCache
    , probeAll
    , probeAllRemovable
    , probeAllNew
    , verify
    , evaluateTagUsingCache
    , evaluateSpecUsingCache
    , Device
    , getDevices
    , getDevicesWithTag
    , deviceGetTags
    , deviceHasTag
    , findDeviceWithTag
    , DevFlags(..)
    , getDevice
    , getDevname
    , getTagValue
    ) where

import Control.Exception (bracket)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import Foreign
import Foreign.C
import System.Linux.Blkid.Evaluate (Tag(..))

#include <blkid/blkid.h>

foreign import ccall "stdlib.h free"
  c_free :: Ptr a -> IO ()

type BlkidCache = Ptr BlkidStructCache

data BlkidStructCache

-- | An operation using the @blkid.tab@ cache file, and returning a
-- value of type @a@. The computation is not performed until
-- @'withCache'@ is called.
newtype CacheT m a = CacheT {runCacheT :: StateT BlkidCache m a}

instance MonadTrans CacheT where
    lift = CacheT . lift

instance Functor f => Functor (CacheT f) where
    fmap f = CacheT . (fmap f) . runCacheT

instance Monad m => Monad (CacheT m) where
    return = CacheT . return
    (CacheT m) >>= f = CacheT (m >>= runCacheT . f)
    fail = CacheT . fail


instance MonadIO m => MonadIO (CacheT m) where
    liftIO = CacheT . liftIO

-- | Run a @'CacheT'@ operation using the given cache file, or the
-- default (@\/run\/blkid\/blkid.tab@) if @'Nothing'@ is passed. After
-- completing the computation, the new cache is written to the file if
-- the user has sufficent privileges.
withCache :: MonadIO m => Maybe FilePath -> CacheT m a -> m a
withCache mpath (CacheT (StateT f)) =
    do c <- liftIO $
            maybeWith withCString mpath $ \cstr ->
                alloca $ \p ->
                    do e <- get_cache p cstr
                       if e < 0
                         then fail ("blkid_get_cache returned " ++ show e)
                         else peek p
       (a,c') <- f c
       liftIO $ put_cache c'
       return a

--getDevices :: MonadIO m => CacheT m [Device]

--getDevice :: MonadIO m => String -> DevFlags -> CacheT m (Maybe Device)

type BlkidDev = Ptr Device

-- | A device as represented in the @blkid.tab@ cache file.
data Device = Device (ForeignPtr Device) String

withDevice :: Device -> (BlkidDev -> IO a) -> IO a
withDevice (Device p _) = withForeignPtr p

toDevice :: BlkidDev -> IO Device
toDevice p = do fp <- newForeignPtr_ p
                name <- dev_devname p >>= peekCString
                return (Device fp name)

instance Show Device where
    show (Device _ name) = name

-- | Removes garbage (non-existing devices) from the cache.
gcCache :: MonadIO m => CacheT m ()
gcCache = CacheT $ StateT $ \c -> do liftIO $ gc_cache c
                                     return ((),c)

-- | Probes all block devices.
probeAll :: MonadIO m => CacheT m ()
probeAll =
    CacheT $ StateT $ \c ->
        do liftIO $ throwIfNeg_ (\e -> "blkid_probe_all returned " ++ show e)
                      (probe_all c)
           return ((),c)

-- | The libblkid probing is based on devices from
-- @\/proc\/partitions@ by default. This file usually does not contain
-- removable devices (e.g. CDROMs) and this kind of devices are
-- invisible for libblkid.
--
-- This function adds removable block devices to cache (probing is
-- based on information from the @\/sys@ directory). Don't forget that
-- removable devices (floppies, CDROMs, ...) could be pretty
-- slow. It's very bad idea to call this function by default.
--
-- Note that devices which were detected by this function won't be
-- written to @blkid.tab@ cache file.
probeAllRemovable :: MonadIO m => CacheT m ()
probeAllRemovable =
    CacheT $ StateT $ \c ->
        do liftIO $ throwIfNeg_ (\e -> "blkid_probe_all_removable returned " ++
                                 show e) (probe_all_removable c)
           return ((),c)

-- | Probes all new block devices.
probeAllNew :: MonadIO m => CacheT m ()
probeAllNew =
    CacheT $ StateT $ \c ->
        do liftIO $ throwIfNeg_ (\e -> "blkid_probe_all_new returned " ++
                                 show e) (probe_all_new c)
           return ((),c)

-- | Verify that the data in @'Device'@ is consistent with what is on
-- the actual block device (using the devname field only).  Normally
-- this will be called when finding items in the cache, but for long
-- running processes is also desirable to revalidate an item before
-- use.
verify :: MonadIO m => Device -> CacheT m Device
verify dev =
    CacheT $ StateT $ \c ->
        do dev' <- liftIO $ withDevice dev $ \d -> blkid_verify c d >>= toDevice
           return (dev',c)

-- | Get the list of tags and values for the given @'Device'@.
deviceGetTags :: MonadIO m => Device -> m [(String, String)]
deviceGetTags dev =
    liftIO $ withDevice dev $ \d -> bracket (begin d) tag_iterate_end getTag
    where begin ptr = do it <- tag_iterate_begin ptr
                         if it == nullPtr
                           then fail "blkid_tag_iterate_begin returned NULL"
                           else return it
          getTag iter = alloca $ \t ->
                            alloca $ \v ->
                                do e <- tag_next iter t v
                                   if e < 0
                                     then return []
                                     else do typ <- peek t >>= peekCString
                                             val <- peek v >>= peekCString
                                             xs <- getTag iter
                                             return ((typ,val):xs)

-- | Check if @'Device'@ has the give tag and value.
deviceHasTag :: MonadIO m => Device -> String -> String -> m Bool
deviceHasTag dev typ val =
    liftIO $ withDevice dev $ \d ->
        withCString typ $ \t ->
            withCString val $ \v ->
                dev_has_tag d t v >>= return . toBool

-- | Find a @'Device'@ in cache matching the given tag and value.
findDeviceWithTag :: MonadIO m => String -> String -> CacheT m (Maybe Device)
findDeviceWithTag typ val =
    CacheT $ StateT $ \c ->
        do mdev <- liftIO $ withCString typ $ \t ->
                   withCString val $ \v ->
                       find_dev_with_tag c t v >>= maybePeek toDevice
           return (mdev,c)

-- | Flags for @'getDevice'@.
data DevFlags = Find
              | Create
              | Verify
              | Normal
                deriving (Eq, Show)

fromDevFlags :: Num a => DevFlags -> a
fromDevFlags Find = #{const BLKID_DEV_FIND}
fromDevFlags Create = #{const BLKID_DEV_CREATE}
fromDevFlags Verify = #{const BLKID_DEV_VERIFY}
fromDevFlags Normal = #{const BLKID_DEV_NORMAL}

-- | Get the device in cache with the given name.
getDevice :: MonadIO m => String -> DevFlags -> CacheT m (Maybe Device)
getDevice nam fl =
     CacheT $ StateT $ \c ->
        do mdev <- liftIO $ withCString nam $ \n ->
                   get_dev c n (fromDevFlags fl) >>= maybePeek toDevice
           return (mdev,c)

-- | Get the device name of the device in cache matching the given tag
-- and value.
getDevname :: MonadIO m => String -> String -> CacheT m (Maybe String)
getDevname tok val =
    CacheT $ StateT $ \c ->
        do mstr <- liftIO $ withCString tok $ \t ->
                   withCString val $ \v ->
                       bracket (get_devname c t v) c_free (maybePeek peekCString)
           return (mstr,c)

-- | Get the value of a tag given the tag and device name.
getTagValue :: MonadIO m => String -> String -> CacheT m (Maybe String)
getTagValue tok nam =
    CacheT $ StateT $ \c ->
        do mstr <- liftIO $ withCString tok $ \t ->
                   withCString nam $ \n ->
                       bracket (get_tag_value c t n) c_free (maybePeek peekCString)
           return (mstr,c)

devIterate :: MonadIO m => Maybe String -> String -> CacheT m [Device]
devIterate mtok val =
    CacheT $ StateT $ \c ->
        do devs <- liftIO $ bracket (getIter c) dev_iterate_end getDev
           return (devs,c)
    where getIter p = do it <- dev_iterate_begin p
                         if it == nullPtr
                           then fail "blkid_dev_iterate_begin returned NULL" 
                           else case mtok of
                                  Nothing -> return it
                                  Just tok ->
                                      withCString tok $ \t ->
                                      withCString val $ \v ->
                                      do throwIfNeg_ (\e -> "blkid_dev_set_search returned " ++ show e)
                                           (dev_set_search it t v)
                                         return it
          getDev it = alloca $ \pd -> do e <- dev_next it pd
                                         if e < 0
                                           then return []
                                           else do d <- peek pd >>= toDevice
                                                   ds <- getDev it
                                                   return (d:ds)

-- | Get the list of devices in cache.
getDevices :: MonadIO m => CacheT m [Device]
getDevices = devIterate Nothing []

-- | Get the list of devices in cache matching the given tag and value.
getDevicesWithTag :: MonadIO m => String -> String -> CacheT m [Device]
getDevicesWithTag tok val = devIterate (Just tok) val

-- | Get the partition or filesystem device with the given @'Tag'@,
-- using the cache file.
evaluateTagUsingCache :: MonadIO m => Tag -> CacheT m (Maybe String)
evaluateTagUsingCache (Label str) = evalTag "LABEL" str
evaluateTagUsingCache (PartLabel str) = evalTag "PARTLABEL" str
evaluateTagUsingCache (UUID str) = evalTag "UUID" str
evaluateTagUsingCache (PartUUID str) = evalTag "PARTUUID" str

evalTag :: MonadIO m => String -> String -> CacheT m (Maybe String)
evalTag tok val =
    CacheT $ StateT $ \c ->
        liftIO $ alloca $ \p ->
            do poke p c
               mstr <- bracket (withCString tok $ \t ->
                                    withCString val $ \v ->
                                        evaluate_tag t v p)
                       c_free
                       (maybePeek peekCString)
               c' <- peek p
               return (mstr,c')

-- | Get the desired partition or filesystem device, using the cache
-- file.
evaluateSpecUsingCache :: MonadIO m => String -> CacheT m (Maybe String)
evaluateSpecUsingCache spec =
    CacheT $ StateT $ \c ->
        liftIO $ alloca $ \p ->
            do poke p c
               mstr <- bracket (withCString spec $ \s -> evaluate_spec s p)
                       c_free
                       (maybePeek peekCString)
               c' <- peek p
               return (mstr,c')

type BlkidDevIterate = Ptr DevIterate

data DevIterate

type BlkidTagIterate = Ptr TagIterate

data TagIterate

foreign import ccall "blkid_put_cache" put_cache :: BlkidCache -> IO ()

foreign import ccall "blkid_get_cache" get_cache :: Ptr BlkidCache
                                                 -> CString
                                                 -> IO CInt

foreign import ccall "blkid_gc_cache" gc_cache :: BlkidCache -> IO ()

foreign import ccall "blkid_dev_devname" dev_devname :: BlkidDev -> IO CString

foreign import ccall "blkid_dev_iterate_begin"
  dev_iterate_begin :: BlkidCache -> IO BlkidDevIterate

foreign import ccall "blkid_dev_set_search" dev_set_search :: BlkidDevIterate
                                                           -> CString
                                                           -> CString
                                                           -> IO CInt

foreign import ccall "blkid_dev_next" dev_next :: BlkidDevIterate
                                               -> Ptr BlkidDev
                                               -> IO CInt

foreign import ccall "blkid_dev_iterate_end" dev_iterate_end :: BlkidDevIterate
                                                             -> IO ()

foreign import ccall "blkid_probe_all" probe_all :: BlkidCache -> IO CInt

foreign import ccall "blkid_probe_all_new" probe_all_new :: BlkidCache
                                                         -> IO CInt

foreign import ccall "blkid_probe_all_removable"
  probe_all_removable :: BlkidCache -> IO CInt

foreign import ccall "blkid_get_dev"
  get_dev :: BlkidCache -> CString -> CInt -> IO BlkidDev

foreign import ccall "blkid_verify"
  blkid_verify :: BlkidCache -> BlkidDev -> IO BlkidDev

foreign import ccall "blkid_get_tag_value"
  get_tag_value :: BlkidCache -> CString -> CString -> IO CString

foreign import ccall "blkid_get_devname"
  get_devname :: BlkidCache -> CString -> CString -> IO CString

foreign import ccall "blkid_tag_iterate_begin"
  tag_iterate_begin :: BlkidDev -> IO BlkidTagIterate

foreign import ccall "blkid_tag_next"
  tag_next :: BlkidTagIterate -> Ptr CString -> Ptr CString -> IO CInt

foreign import ccall "blkid_tag_iterate_end"
  tag_iterate_end :: BlkidTagIterate -> IO ()

foreign import ccall "blkid_dev_has_tag"
  dev_has_tag :: BlkidDev -> CString -> CString -> IO CInt

foreign import ccall "blkid_find_dev_with_tag"
  find_dev_with_tag :: BlkidCache -> CString -> CString -> IO BlkidDev

foreign import ccall "blkid_evaluate_tag" evaluate_tag :: CString
                                                       -> CString
                                                       -> Ptr BlkidCache
                                                       -> IO CString

foreign import ccall "blkid_evaluate_spec" evaluate_spec :: CString
                                                         -> Ptr BlkidCache
                                                         -> IO CString