propellor

propellor config for hosts.
git clone git://git.ricketyspace.net/propellor.git
Log | Files | Refs | LICENSE

Mount.hs (5664B)


      1 {-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances #-}
      2 
      3 -- | Properties in this module ensure that things are currently mounted,
      4 -- but without making the mount persistent. Use `Propellor.Property.Fstab`
      5 -- to configure persistent mounts.
      6 
      7 module Propellor.Property.Mount where
      8 
      9 import Propellor.Base
     10 import Utility.Path
     11 
     12 import Data.List
     13 import qualified Data.Semigroup as Sem
     14 
     15 -- | type of filesystem to mount ("auto" to autodetect)
     16 type FsType = String
     17 
     18 -- | A device or other thing to be mounted.
     19 type Source = String
     20 
     21 -- | A mount point for a filesystem.
     22 type MountPoint = FilePath
     23 
     24 -- | Filesystem mount options. Eg, MountOpts ["errors=remount-ro"]
     25 --
     26 -- For default mount options, use `mempty`.
     27 newtype MountOpts = MountOpts [String]
     28 	deriving (Sem.Semigroup, Monoid)
     29 
     30 class ToMountOpts a where
     31 	toMountOpts :: a -> MountOpts
     32 	
     33 instance ToMountOpts MountOpts where
     34 	toMountOpts = id
     35 
     36 instance ToMountOpts String where
     37 	toMountOpts s = MountOpts [s]
     38 
     39 formatMountOpts :: MountOpts -> String
     40 formatMountOpts (MountOpts []) = "defaults"
     41 formatMountOpts (MountOpts l) = intercalate "," l
     42 
     43 -- | Mounts a device, without listing it in </etc/fstab>.
     44 --
     45 -- Note that this property will fail if the device is already mounted
     46 -- at the MountPoint.
     47 mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property UnixLike
     48 mounted fs src mnt opts = property (mnt ++ " mounted") $ 
     49 	toResult <$> liftIO (mount fs src mnt opts)
     50 
     51 -- | Bind mounts the first directory so its contents also appear
     52 -- in the second directory.
     53 bindMount :: FilePath -> FilePath -> Property Linux
     54 bindMount src dest = tightenTargets $
     55 	cmdProperty "mount" ["--bind", src, dest]
     56 		`assume` MadeChange
     57 		`describe` ("bind mounted " ++ src ++ " to " ++ dest)
     58 
     59 -- | Enables swapping to a device, which must be formatted already as a swap
     60 -- partition.
     61 swapOn :: Source -> RevertableProperty Linux Linux
     62 swapOn mnt = tightenTargets doswapon <!> tightenTargets doswapoff
     63   where
     64 	swaps = lines <$> readProcess "swapon" ["--show=NAME"]
     65 	doswapon = check (notElem mnt <$> swaps) $
     66 		cmdProperty "swapon" [mnt]
     67 	doswapoff = check (elem mnt <$> swaps) $
     68 		cmdProperty "swapoff" [mnt]
     69 
     70 mount :: FsType -> Source -> MountPoint -> MountOpts -> IO Bool
     71 mount fs src mnt opts = boolSystem "mount" $
     72 	[ Param "-t", Param fs
     73 	, Param "-o", Param (formatMountOpts opts)
     74 	, Param src
     75 	, Param mnt
     76 	]
     77 
     78 -- | Lists all mount points of the system.
     79 mountPoints :: IO [MountPoint]
     80 mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"]
     81 
     82 -- | Checks if anything is mounted at the MountPoint.
     83 isMounted :: MountPoint -> IO Bool
     84 isMounted mnt = isJust <$> getFsType mnt
     85 
     86 -- | Finds all filesystems mounted inside the specified directory.
     87 mountPointsBelow :: FilePath -> IO [MountPoint]
     88 mountPointsBelow target = filter (\p -> simplifyPath p /= simplifyPath target)
     89 	. filter (dirContains target)
     90 	<$> mountPoints
     91 
     92 -- | Get mountpoints which are bind mounts of subdirectories of mounted
     93 -- filesystems
     94 --
     95 -- E.g. as created by @mount --bind /etc/foo /etc/bar@ where @/etc/foo@ is not
     96 -- itself a mount point, but just a subdirectory.  These are sometimes known as
     97 -- "partial bind mounts"
     98 partialBindMountsOf :: FilePath -> IO [MountPoint]
     99 partialBindMountsOf sourceDir =
    100 	map (drop 2 . dropWhile (/= ']')) . filter getThem . lines
    101 	<$> readProcess "findmnt" ["-rn", "--output", "source,target"]
    102   where
    103 	getThem l = bracketed `isSuffixOf` (takeWhile (/= ' ') l)
    104 	bracketed = "[" ++ sourceDir ++ "]"
    105 
    106 -- | Filesystem type mounted at a given location.
    107 getFsType :: MountPoint -> IO (Maybe FsType)
    108 getFsType p = findmntField "fstype" [p]
    109 
    110 -- | Mount options for the filesystem mounted at a given location.
    111 getFsMountOpts :: MountPoint -> IO MountOpts
    112 getFsMountOpts p = maybe mempty toMountOpts
    113 	<$> findmntField "fs-options" [p]
    114 
    115 type UUID = String
    116 
    117 -- | UUID of filesystem mounted at a given location.
    118 getMountUUID :: MountPoint -> IO (Maybe UUID)
    119 getMountUUID p = findmntField "uuid" [p]
    120 
    121 -- | UUID of a device
    122 getSourceUUID :: Source -> IO (Maybe UUID)
    123 getSourceUUID = blkidTag "UUID"
    124 
    125 type Label = String
    126 
    127 -- | Label of filesystem mounted at a given location.
    128 getMountLabel :: MountPoint -> IO (Maybe Label)
    129 getMountLabel p = findmntField "label" [p]
    130 
    131 -- | Label of a device
    132 getSourceLabel :: Source -> IO (Maybe UUID)
    133 getSourceLabel = blkidTag "LABEL"
    134 
    135 -- | Device mounted at a given location.
    136 getMountSource :: MountPoint -> IO (Maybe Source)
    137 getMountSource p = findmntField "source" [p]
    138 
    139 -- | Device that a given path is located within.
    140 getMountContaining :: FilePath -> IO (Maybe Source)
    141 getMountContaining p = findmntField "source" ["-T", p]
    142 
    143 findmntField :: String -> [String] -> IO (Maybe String)
    144 findmntField field ps = catchDefaultIO Nothing $
    145 	headMaybe . filter (not . null) . lines
    146 		<$> readProcess "findmnt" ("-n" : ps ++ ["--output", field])
    147 
    148 blkidTag :: String -> Source -> IO (Maybe String)
    149 blkidTag tag dev = catchDefaultIO Nothing $
    150 	headMaybe . filter (not . null) . lines
    151 		<$> readProcess "blkid" [dev, "-s", tag, "-o", "value"]
    152 
    153 -- | Unmounts a device or mountpoint,
    154 -- lazily so any running processes don't block it.
    155 --
    156 -- Note that this will fail if it's not mounted.
    157 umountLazy :: FilePath -> IO ()
    158 umountLazy mnt =  
    159 	unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $
    160 		stopPropellorMessage $ "failed unmounting " ++ mnt
    161 
    162 -- | Unmounts anything mounted inside the specified directory,
    163 -- not including the directory itself.
    164 unmountBelow :: FilePath -> IO ()
    165 unmountBelow d = do
    166 	submnts <- mountPointsBelow d
    167 	-- sort so sub-mounts are unmounted before the mount point
    168 	-- containing them
    169 	forM_ (reverse (sort submnts)) umountLazy