linux-blkid 0.1.0.0 → 0.2.0.0
raw patch · 4 files changed
+122/−80 lines, 4 filesdep +monad-controldep +transformers-base
Dependencies added: monad-control, transformers-base
Files
- System/Linux/Blkid/Cache.hsc +82/−63
- System/Linux/Blkid/Evaluate.hsc +10/−11
- System/Linux/Blkid/Probe.hsc +25/−3
- linux-blkid.cabal +5/−3
System/Linux/Blkid/Cache.hsc view
@@ -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 ()
System/Linux/Blkid/Evaluate.hsc view
@@ -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)
System/Linux/Blkid/Probe.hsc view
@@ -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
linux-blkid.cabal view
@@ -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