diff --git a/System/Linux/Blkid/Cache.hsc b/System/Linux/Blkid/Cache.hsc --- a/System/Linux/Blkid/Cache.hsc +++ b/System/Linux/Blkid/Cache.hsc @@ -1,5 +1,11 @@ {-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | Basic routines to work with @libblkid@ cache. module System.Linux.Blkid.Cache @@ -22,11 +28,16 @@ , getDevice , getDevname , getTagValue - ) where + , initDebug ) where +import Control.Applicative (Alternative, Applicative) import Control.Exception (bracket) +import Control.Monad (MonadPlus) +import Control.Monad.Base +import Control.Monad.Fix (MonadFix) import Control.Monad.IO.Class import Control.Monad.Trans.Class +import Control.Monad.Trans.Control import Control.Monad.Trans.State import Foreign import Foreign.C @@ -44,43 +55,37 @@ -- | 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 +newtype CacheT m a = CacheT {unCacheT :: StateT BlkidCache m a} + deriving (Alternative, Applicative, Functor, Monad + , MonadFix, MonadIO, MonadPlus, MonadTrans) -instance Monad m => Monad (CacheT m) where - return = CacheT . return - (CacheT m) >>= f = CacheT (m >>= runCacheT . f) - fail = CacheT . fail +instance MonadBase b m => MonadBase b (CacheT m) where + liftBase = liftBaseDefault +instance MonadTransControl CacheT where + newtype StT CacheT a = StCache {unStCache :: StT (StateT BlkidCache) a} + liftWith = defaultLiftWith CacheT unCacheT StCache + restoreT = defaultRestoreT CacheT unStCache -instance MonadIO m => MonadIO (CacheT m) where - liftIO = CacheT . liftIO +instance MonadBaseControl b m => MonadBaseControl b (CacheT m) where + newtype StM (CacheT m) a = StMCache {unStMCache :: ComposeSt CacheT m a} + liftBaseWith = defaultLiftBaseWith StMCache + restoreM = defaultRestoreM unStMCache -- | 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 :: MonadBaseControl IO 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) + liftBaseOp (bracket getCache put_cache) (\c -> f c >>= return . fst) + where getCache = + maybeWith withCString mpath $ \cstr -> + alloca $ \p -> + do throwIfNeg_ + (\e -> "blkid_get_cache returned " ++ show e) + (get_cache p cstr) + peek p type BlkidDev = Ptr Device @@ -99,16 +104,16 @@ 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 +gcCache :: MonadBase IO m => CacheT m () +gcCache = CacheT $ StateT $ \c -> do liftBase $ gc_cache c return ((),c) -- | Probes all block devices. -probeAll :: MonadIO m => CacheT m () +probeAll :: MonadBase IO m => CacheT m () probeAll = CacheT $ StateT $ \c -> - do liftIO $ throwIfNeg_ (\e -> "blkid_probe_all returned " ++ show e) - (probe_all c) + do liftBase $ throwIfNeg_ (\e -> "blkid_probe_all returned " ++ show e) + (probe_all c) return ((),c) -- | The libblkid probing is based on devices from @@ -123,19 +128,20 @@ -- -- Note that devices which were detected by this function won't be -- written to @blkid.tab@ cache file. -probeAllRemovable :: MonadIO m => CacheT m () +probeAllRemovable :: MonadBase IO m => CacheT m () probeAllRemovable = CacheT $ StateT $ \c -> - do liftIO $ throwIfNeg_ (\e -> "blkid_probe_all_removable returned " ++ - show e) (probe_all_removable c) + do liftBase $ 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 :: MonadBase IO m => CacheT m () probeAllNew = CacheT $ StateT $ \c -> - do liftIO $ throwIfNeg_ (\e -> "blkid_probe_all_new returned " ++ - show e) (probe_all_new c) + do liftBase $ 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 @@ -143,16 +149,17 @@ -- 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 :: MonadBase IO m => Device -> CacheT m Device verify dev = CacheT $ StateT $ \c -> - do dev' <- liftIO $ withDevice dev $ \d -> blkid_verify c d >>= toDevice + do dev' <- liftBase $ 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 :: MonadBase IO m => Device -> m [(String, String)] deviceGetTags dev = - liftIO $ withDevice dev $ \d -> bracket (begin d) tag_iterate_end getTag + liftBase $ 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" @@ -168,18 +175,18 @@ return ((typ,val):xs) -- | Check if @'Device'@ has the give tag and value. -deviceHasTag :: MonadIO m => Device -> String -> String -> m Bool +deviceHasTag :: MonadBase IO m => Device -> String -> String -> m Bool deviceHasTag dev typ val = - liftIO $ withDevice dev $ \d -> + liftBase $ 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 :: MonadBase IO m => String -> String -> CacheT m (Maybe Device) findDeviceWithTag typ val = CacheT $ StateT $ \c -> - do mdev <- liftIO $ withCString typ $ \t -> + do mdev <- liftBase $ withCString typ $ \t -> withCString val $ \v -> find_dev_with_tag c t v >>= maybePeek toDevice return (mdev,c) @@ -198,36 +205,36 @@ 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 :: MonadBase IO m => String -> DevFlags -> CacheT m (Maybe Device) getDevice nam fl = CacheT $ StateT $ \c -> - do mdev <- liftIO $ withCString nam $ \n -> + do mdev <- liftBase $ 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 :: MonadBase IO m => String -> String -> CacheT m (Maybe String) getDevname tok val = CacheT $ StateT $ \c -> - do mstr <- liftIO $ withCString tok $ \t -> + do mstr <- liftBase $ 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 :: MonadBase IO m => String -> String -> CacheT m (Maybe String) getTagValue tok nam = CacheT $ StateT $ \c -> - do mstr <- liftIO $ withCString tok $ \t -> + do mstr <- liftBase $ 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 :: MonadBase IO m => Maybe String -> String -> CacheT m [Device] devIterate mtok val = CacheT $ StateT $ \c -> - do devs <- liftIO $ bracket (getIter c) dev_iterate_end getDev + do devs <- liftBase $ bracket (getIter c) dev_iterate_end getDev return (devs,c) where getIter p = do it <- dev_iterate_begin p if it == nullPtr @@ -248,25 +255,25 @@ return (d:ds) -- | Get the list of devices in cache. -getDevices :: MonadIO m => CacheT m [Device] +getDevices :: MonadBase IO 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 :: MonadBase IO 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 :: MonadBase IO 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 :: MonadBase IO m => String -> String -> CacheT m (Maybe String) evalTag tok val = CacheT $ StateT $ \c -> - liftIO $ alloca $ \p -> + liftBase $ alloca $ \p -> do poke p c mstr <- bracket (withCString tok $ \t -> withCString val $ \v -> @@ -278,10 +285,10 @@ -- | Get the desired partition or filesystem device, using the cache -- file. -evaluateSpecUsingCache :: MonadIO m => String -> CacheT m (Maybe String) +evaluateSpecUsingCache :: MonadBase IO m => String -> CacheT m (Maybe String) evaluateSpecUsingCache spec = CacheT $ StateT $ \c -> - liftIO $ alloca $ \p -> + liftBase $ alloca $ \p -> do poke p c mstr <- bracket (withCString spec $ \s -> evaluate_spec s p) c_free @@ -289,6 +296,16 @@ c' <- peek p return (mstr,c') +-- | @0xffff@ to enable full debuging. +-- +-- If the mask is not specified then this function reads +-- @LIBBLKID_DEBUG@ environment variable to get the mask. +-- +-- Already initialized debugging stuff cannot be changed. It does not +-- have effect to call this function twice. +initDebug :: Int -> IO () +initDebug = init_debug . fromIntegral + type BlkidDevIterate = Ptr DevIterate data DevIterate @@ -296,6 +313,8 @@ type BlkidTagIterate = Ptr TagIterate data TagIterate + +foreign import ccall "blkid_init_debug" init_debug :: CInt -> IO () foreign import ccall "blkid_put_cache" put_cache :: BlkidCache -> IO () diff --git a/System/Linux/Blkid/Evaluate.hsc b/System/Linux/Blkid/Evaluate.hsc --- a/System/Linux/Blkid/Evaluate.hsc +++ b/System/Linux/Blkid/Evaluate.hsc @@ -11,7 +11,6 @@ ) where import Control.Exception (bracket) -import Control.Monad.IO.Class import Foreign import Foreign.C @@ -49,11 +48,11 @@ -- -- >>> evaluateTag (PartLabel "EFI System Partition") -- Just "/dev/sda1" -evaluateTag :: MonadIO m => Tag -> m (Maybe String) -evaluateTag (Label str) = liftIO $ evalTag "LABEL" str -evaluateTag (PartLabel str) = liftIO $ evalTag "PARTLABEL" str -evaluateTag (UUID str) = liftIO $ evalTag "UUID" str -evaluateTag (PartUUID str) = liftIO $ evalTag "PARTUUID" str +evaluateTag :: Tag -> IO (Maybe String) +evaluateTag (Label str) = evalTag "LABEL" str +evaluateTag (PartLabel str) = evalTag "PARTLABEL" str +evaluateTag (UUID str) = evalTag "UUID" str +evaluateTag (PartUUID str) = evalTag "PARTUUID" str evalTag :: String -> String -> IO (Maybe String) evalTag tok val = @@ -86,12 +85,12 @@ -- -- >>> evaluateSpec "/dev/disk/by-label/EFI" -- Just "/dev/sda1" -evaluateSpec :: MonadIO m => String -> m (Maybe String) +evaluateSpec :: String -> IO (Maybe String) evaluateSpec spec = - liftIO $ bracket - (withCString spec $ \s -> evaluate_spec s nullPtr) - c_free - (maybePeek peekCString) + bracket + (withCString spec $ \s -> evaluate_spec s nullPtr) + c_free + (maybePeek peekCString) {- evaluateSpecUsingCache :: MonadIO m => String -> CacheT m (Maybe String) diff --git a/System/Linux/Blkid/Probe.hsc b/System/Linux/Blkid/Probe.hsc --- a/System/Linux/Blkid/Probe.hsc +++ b/System/Linux/Blkid/Probe.hsc @@ -18,6 +18,7 @@ , probeGetWholediskDevno , probeSetDevice , probeIsWholedisk + , probeStepBack , resetProbe -- * Low-level tags , doProbe @@ -232,8 +233,10 @@ -- parental partition for nested -- patition tables. , parttableParent :: Maybe Partition -- ^ Parent for nested - -- partitition tables or - -- @'Nothing'@. + -- partitition tables or + -- @'Nothing'@. + , parttableID :: Maybe String -- ^ GPT disk UUID or DOS disk ID + -- (in hex format). } deriving (Eq, Show) toPartTable :: BlkidParttable -> IO PartTable @@ -241,7 +244,8 @@ do typ <- parttable_get_type pt >>= peekCString off <- parttable_get_offset pt >>= return . fromIntegral par <- parttable_get_parent pt >>= maybePeek toPartition - return $ PartTable typ off par + mid <- parttable_get_id pt >>= maybePeek peekCString + return $ PartTable typ off par mid -- | Usage filter to use with @'probeFilterSuperblocksUsageNotIn'@ and -- @'probeFilterSuperblocksUsageOnlyIn'@. @@ -351,6 +355,18 @@ probeIsWholedisk pr = withProbe pr $ \p -> probe_is_wholedisk p >>= return . toEnum . fromIntegral +-- | Move pointer to the probing chain one step back -- it means that +-- the previously used probing function will be called again in the +-- next @'doProbe'@ call. +-- +-- This is necessary for example if you erase or modify on-disk +-- superblock according to the current libblkid probing result. +probeStepBack :: Probe -> IO () +probeStepBack pr = + withProbe pr $ \p -> + throwIfNeg_ (\e -> "blkid_probe_step_back returned " ++ show e) $ + probe_step_back p + -- | Zeroize probing results and resets the current probing (this has -- impact to @'doProbe'@ only). This function does not touch probing -- filters and keeps assigned device. @@ -967,6 +983,9 @@ foreign import ccall "blkid_parttable_get_type" parttable_get_type :: BlkidParttable -> IO CString +foreign import ccall "blkid_parttable_get_id" + parttable_get_id :: BlkidParttable -> IO CString + foreign import ccall "blkid_parttable_get_offset" parttable_get_offset :: BlkidParttable -> IO BlkidLoff @@ -1000,4 +1019,7 @@ -> IO CInt foreign import ccall "blkid_do_wipe" do_wipe :: BlkidProbe -> CInt -> IO CInt + +foreign import ccall "blkid_probe_step_back" + probe_step_back :: BlkidProbe -> IO CInt diff --git a/linux-blkid.cabal b/linux-blkid.cabal --- a/linux-blkid.cabal +++ b/linux-blkid.cabal @@ -1,5 +1,5 @@ Name: linux-blkid -Version: 0.1.0.0 +Version: 0.2.0.0 Cabal-Version: >= 1.8 Build-Type: Simple License: LGPL-2.1 @@ -15,7 +15,9 @@ Library Build-Depends: base == 4.*, - transformers == 0.3.* + monad-control == 0.3.*, + transformers == 0.3.*, + transformers-base == 0.4.* -- uuid == 1.2.* Ghc-Options: -Wall Exposed-modules: System.Linux.Blkid @@ -23,4 +25,4 @@ System.Linux.Blkid.Evaluate System.Linux.Blkid.Probe System.Linux.Blkid.Utils - Pkgconfig-Depends: blkid + Pkgconfig-Depends: blkid == 2.23.0