    {-# LANGUAGE FlexibleContexts #-}

    module Propellor.Property.Partition where

    import Propellor.Base
    import Propellor.Types.Core
    import qualified Propellor.Property.Apt as Apt
    import Utility.Applicative

    import System.Posix.Files
    import Data.List
    import Data.Char

    -- | Filesystems etc that can be used for a partition.
    data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | LinuxSwap
    	deriving (Int -> Fs -> ShowS
    [Fs] -> ShowS
    Fs -> String
    (Int -> Fs -> ShowS)
    -> (Fs -> String) -> ([Fs] -> ShowS) -> Show Fs
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    showList :: [Fs] -> ShowS
    $cshowList :: [Fs] -> ShowS
    show :: Fs -> String
    $cshow :: Fs -> String
    showsPrec :: Int -> Fs -> ShowS
    $cshowsPrec :: Int -> Fs -> ShowS
    Show, Fs -> Fs -> Bool
    (Fs -> Fs -> Bool) -> (Fs -> Fs -> Bool) -> Eq Fs
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    /= :: Fs -> Fs -> Bool
    $c/= :: Fs -> Fs -> Bool
    == :: Fs -> Fs -> Bool
    $c== :: Fs -> Fs -> Bool
    Eq)

    -- | Parse commonly used names of filesystems.
    parseFs :: String -> Maybe Fs
    parseFs :: String -> Maybe Fs
    parseFs "ext2" = Fs -> Maybe Fs
    forall a. a -> Maybe a
    Just Fs
    EXT2
    parseFs "ext3" = Fs -> Maybe Fs
    forall a. a -> Maybe a
    Just Fs
    EXT3
    parseFs "ext4" = Fs -> Maybe Fs
    forall a. a -> Maybe a
    Just Fs
    EXT4
    parseFs "btrfs" = Fs -> Maybe Fs
    forall a. a -> Maybe a
    Just Fs
    BTRFS
    parseFs "reiserfs" = Fs -> Maybe Fs
    forall a. a -> Maybe a
    Just Fs
    REISERFS
    parseFs "xfs" = Fs -> Maybe Fs
    forall a. a -> Maybe a
    Just Fs
    XFS
    parseFs "fat" = Fs -> Maybe Fs
    forall a. a -> Maybe a
    Just Fs
    FAT
    parseFs "vfat" = Fs -> Maybe Fs
    forall a. a -> Maybe a
    Just Fs
    VFAT
    parseFs "ntfs" = Fs -> Maybe Fs
    forall a. a -> Maybe a
    Just Fs
    NTFS
    parseFs "swap" = Fs -> Maybe Fs
    forall a. a -> Maybe a
    Just Fs
    LinuxSwap
    parseFs _ = Maybe Fs
    forall a. Maybe a
    Nothing

    data Eep = YesReallyFormatPartition

    -- | Formats a partition.
    formatted :: Eep -> Fs -> FilePath -> Property DebianLike
    formatted :: Eep -> Fs -> String -> Property DebianLike
    formatted = MkfsOpts -> Eep -> Fs -> String -> Property DebianLike
    formatted' []

    -- | Options passed to a mkfs.* command when making a filesystem.
    --
    -- Eg, ["-m0"]
    type MkfsOpts = [String]

    formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property DebianLike
    formatted' :: MkfsOpts -> Eep -> Fs -> String -> Property DebianLike
    formatted' opts :: MkfsOpts
    opts YesReallyFormatPartition fs :: Fs
    fs dev :: String
    dev = String -> MkfsOpts -> UncheckedProperty UnixLike
    cmdProperty String
    cmd MkfsOpts
    opts'
    	UncheckedProperty UnixLike -> Result -> Property UnixLike
    forall (p :: * -> *) i.
    Checkable p i =>
    p i -> Result -> Property i
    `assume` Result
    MadeChange
    	Property UnixLike
    -> Property DebianLike
    -> CombinedType (Property UnixLike) (Property DebianLike)
    forall x y. Combines x y => x -> y -> CombinedType x y
    `requires` MkfsOpts -> Property DebianLike
    Apt.installed [String
    pkg]
      where
    	(cmd :: String
    cmd, opts' :: MkfsOpts
    opts', pkg :: String
    pkg) = case Fs
    fs of
    		EXT2 -> ("mkfs.ext2", MkfsOpts -> MkfsOpts
    q (MkfsOpts -> MkfsOpts) -> MkfsOpts -> MkfsOpts
    forall a b. (a -> b) -> a -> b
    $ MkfsOpts -> MkfsOpts
    eff MkfsOpts
    optsdev, "e2fsprogs")
    		EXT3 -> ("mkfs.ext3", MkfsOpts -> MkfsOpts
    q (MkfsOpts -> MkfsOpts) -> MkfsOpts -> MkfsOpts
    forall a b. (a -> b) -> a -> b
    $ MkfsOpts -> MkfsOpts
    eff MkfsOpts
    optsdev, "e2fsprogs")
    		EXT4 -> ("mkfs.ext4", MkfsOpts -> MkfsOpts
    q (MkfsOpts -> MkfsOpts) -> MkfsOpts -> MkfsOpts
    forall a b. (a -> b) -> a -> b
    $ MkfsOpts -> MkfsOpts
    eff MkfsOpts
    optsdev, "e2fsprogs")
    		BTRFS -> ("mkfs.btrfs", MkfsOpts
    optsdev, "btrfs-tools")
    		REISERFS -> ("mkfs.reiserfs", MkfsOpts -> MkfsOpts
    q (MkfsOpts -> MkfsOpts) -> MkfsOpts -> MkfsOpts
    forall a b. (a -> b) -> a -> b
    $ "-ff"String -> MkfsOpts -> MkfsOpts
    forall a. a -> [a] -> [a]
    :MkfsOpts
    optsdev, "reiserfsprogs")
    		XFS -> ("mkfs.xfs", "-f"String -> MkfsOpts -> MkfsOpts
    forall a. a -> [a] -> [a]
    :MkfsOpts -> MkfsOpts
    q MkfsOpts
    optsdev, "xfsprogs")
    		FAT -> ("mkfs.fat", MkfsOpts
    optsdev, "dosfstools")
    		VFAT -> ("mkfs.vfat", MkfsOpts
    optsdev, "dosfstools")
    		NTFS -> ("mkfs.ntfs", MkfsOpts -> MkfsOpts
    q (MkfsOpts -> MkfsOpts) -> MkfsOpts -> MkfsOpts
    forall a b. (a -> b) -> a -> b
    $ MkfsOpts -> MkfsOpts
    eff MkfsOpts
    optsdev, "ntfs-3g")
    		LinuxSwap -> ("mkswap", MkfsOpts
    optsdev, "util-linux")
    	optsdev :: MkfsOpts
    optsdev = MkfsOpts
    optsMkfsOpts -> MkfsOpts -> MkfsOpts
    forall a. [a] -> [a] -> [a]
    ++[String
    dev]
    	-- -F forces creating a filesystem even if the device already has one
    	eff :: MkfsOpts -> MkfsOpts
    eff l :: MkfsOpts
    l = "-F"String -> MkfsOpts -> MkfsOpts
    forall a. a -> [a] -> [a]
    :MkfsOpts
    l
    	-- Be quiet.
    	q :: MkfsOpts -> MkfsOpts
    q l :: MkfsOpts
    l = "-q"String -> MkfsOpts -> MkfsOpts
    forall a. a -> [a] -> [a]
    :MkfsOpts
    l

    data LoopDev = LoopDev
    	{ LoopDev -> String
    partitionLoopDev :: FilePath -- ^ device for a loop partition
    	, LoopDev -> String
    wholeDiskLoopDev :: FilePath -- ^ corresponding device for the whole loop disk
    	} deriving (Int -> LoopDev -> ShowS
    [LoopDev] -> ShowS
    LoopDev -> String
    (Int -> LoopDev -> ShowS)
    -> (LoopDev -> String) -> ([LoopDev] -> ShowS) -> Show LoopDev
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    showList :: [LoopDev] -> ShowS
    $cshowList :: [LoopDev] -> ShowS
    show :: LoopDev -> String
    $cshow :: LoopDev -> String
    showsPrec :: Int -> LoopDev -> ShowS
    $cshowsPrec :: Int -> LoopDev -> ShowS
    Show)

    isLoopDev :: LoopDev -> IO Bool
    isLoopDev :: LoopDev -> IO Bool
    isLoopDev l :: LoopDev
    l = String -> IO Bool
    isLoopDev' (LoopDev -> String
    partitionLoopDev LoopDev
    l) IO Bool -> IO Bool -> IO Bool
    forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
    <&&> String -> IO Bool
    isLoopDev' (LoopDev -> String
    wholeDiskLoopDev LoopDev
    l)

    isLoopDev' :: FilePath -> IO Bool
    isLoopDev' :: String -> IO Bool
    isLoopDev' f :: String
    f
    	| "loop" String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isInfixOf` String
    f = IO Bool -> IO Bool
    forall (m :: * -> *). MonadCatch m => m Bool -> m Bool
    catchBoolIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
    forall a b. (a -> b) -> a -> b
    $
    		FileStatus -> Bool
    isBlockDevice (FileStatus -> Bool) -> IO FileStatus -> IO Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> IO FileStatus
    getFileStatus String
    f
    	| Bool
    otherwise = Bool -> IO Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False

    -- | Uses the kpartx utility to create device maps for partitions contained
    -- within a disk image file. The resulting loop devices are passed to the
    -- property, which can operate on them. Always cleans up after itself,
    -- by removing the device maps after the property is run.
    kpartx :: FilePath -> ([LoopDev] -> Property DebianLike) -> Property DebianLike
    kpartx :: String -> ([LoopDev] -> Property DebianLike) -> Property DebianLike
    kpartx diskimage :: String
    diskimage mkprop :: [LoopDev] -> Property DebianLike
    mkprop = Property DebianLike
    go Property DebianLike
    -> Property DebianLike
    -> CombinedType (Property DebianLike) (Property DebianLike)
    forall x y. Combines x y => x -> y -> CombinedType x y
    `requires` MkfsOpts -> Property DebianLike
    Apt.installed ["kpartx"]
      where
    	go :: Property DebianLike
    	go :: Property DebianLike
    go = String
    -> (OuterMetaTypesWitness
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
        -> Propellor Result)
    -> Property DebianLike
    forall k (metatypes :: k).
    SingI metatypes =>
    String
    -> (OuterMetaTypesWitness metatypes -> Propellor Result)
    -> Property (MetaTypes metatypes)
    property' (Property DebianLike -> String
    forall p. IsProp p => p -> String
    getDesc ([LoopDev] -> Property DebianLike
    mkprop [])) ((OuterMetaTypesWitness
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
      -> Propellor Result)
     -> Property DebianLike)
    -> (OuterMetaTypesWitness
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
        -> Propellor Result)
    -> Property DebianLike
    forall a b. (a -> b) -> a -> b
    $ \w :: OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
    w -> do
    		Propellor ()
    cleanup -- idempotency
    		[LoopDev]
    loopdevs <- IO [LoopDev] -> Propellor [LoopDev]
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO [LoopDev] -> Propellor [LoopDev])
    -> IO [LoopDev] -> Propellor [LoopDev]
    forall a b. (a -> b) -> a -> b
    $ String -> [LoopDev]
    kpartxParse
    			(String -> [LoopDev]) -> IO String -> IO [LoopDev]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> MkfsOpts -> IO String
    readProcess "kpartx" ["-avs", String
    diskimage]
    		[LoopDev]
    bad <- IO [LoopDev] -> Propellor [LoopDev]
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO [LoopDev] -> Propellor [LoopDev])
    -> IO [LoopDev] -> Propellor [LoopDev]
    forall a b. (a -> b) -> a -> b
    $ (LoopDev -> IO Bool) -> [LoopDev] -> IO [LoopDev]
    forall (m :: * -> *) a.
    Applicative m =>
    (a -> m Bool) -> [a] -> m [a]
    filterM (Bool -> Bool
    not (Bool -> Bool) -> (LoopDev -> IO Bool) -> LoopDev -> IO Bool
    forall (f :: * -> *) a b c.
    Functor f =>
    (a -> b) -> (c -> f a) -> c -> f b
    <$$> LoopDev -> IO Bool
    isLoopDev) [LoopDev]
    loopdevs
    		Bool -> Propellor () -> Propellor ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless ([LoopDev] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [LoopDev]
    bad) (Propellor () -> Propellor ()) -> Propellor () -> Propellor ()
    forall a b. (a -> b) -> a -> b
    $
    			String -> Propellor ()
    forall a. HasCallStack => String -> a
    error (String -> Propellor ()) -> String -> Propellor ()
    forall a b. (a -> b) -> a -> b
    $ "kpartx output seems to include non-loop-devices (possible parse failure): " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ [LoopDev] -> String
    forall a. Show a => a -> String
    show [LoopDev]
    bad
    		Result
    r <- OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
    -> Property DebianLike -> Propellor Result
    forall (inner :: [MetaType]) (outer :: [MetaType]).
    EnsurePropertyAllowed inner outer =>
    OuterMetaTypesWitness outer
    -> Property (MetaTypes inner) -> Propellor Result
    ensureProperty OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
    w ([LoopDev] -> Property DebianLike
    mkprop [LoopDev]
    loopdevs)
    		Propellor ()
    cleanup
    		Result -> Propellor Result
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    r
    	cleanup :: Propellor ()
    cleanup = Propellor Bool -> Propellor ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (Propellor Bool -> Propellor ()) -> Propellor Bool -> Propellor ()
    forall a b. (a -> b) -> a -> b
    $ IO Bool -> Propellor Bool
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Bool -> Propellor Bool) -> IO Bool -> Propellor Bool
    forall a b. (a -> b) -> a -> b
    $ String -> [CommandParam] -> IO Bool
    boolSystem "kpartx" [String -> CommandParam
    Param "-d", String -> CommandParam
    File String
    diskimage]

    -- kpartx's output includes the device for the loop partition, and some
    -- information about the whole disk loop device. In earlier versions,
    -- this was simply the path to the loop device. But, in kpartx 0.6,
    -- this changed to the major:minor of the block device. Either is handled
    -- by this parser.
    kpartxParse :: String -> [LoopDev]
    kpartxParse :: String -> [LoopDev]
    kpartxParse = (String -> Maybe LoopDev) -> MkfsOpts -> [LoopDev]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe (MkfsOpts -> Maybe LoopDev
    finddev (MkfsOpts -> Maybe LoopDev)
    -> (String -> MkfsOpts) -> String -> Maybe LoopDev
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> MkfsOpts
    words) (MkfsOpts -> [LoopDev])
    -> (String -> MkfsOpts) -> String -> [LoopDev]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> MkfsOpts
    lines
      where
    	finddev :: MkfsOpts -> Maybe LoopDev
    finddev ("add":"map":ld :: String
    ld:_:_:_:_:s :: String
    s:_) = do
    		String
    wd <- if String -> Bool
    isAbsolute String
    s
    			then String -> Maybe String
    forall a. a -> Maybe a
    Just String
    s
    			-- A loop partition name loop0pn corresponds to
    			-- /dev/loop0. It would be more robust to check
    			-- that the major:minor matches, but haskell's
    			-- unix library lacks a way to do that.
    			else case (Char -> Bool) -> ShowS
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile Char -> Bool
    isDigit ((Char -> Bool) -> ShowS
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile (Bool -> Bool
    not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> Bool
    isDigit) String
    ld) of
    				[] -> Maybe String
    forall a. Maybe a
    Nothing
    				n :: String
    n -> String -> Maybe String
    forall a. a -> Maybe a
    Just (String -> Maybe String) -> String -> Maybe String
    forall a b. (a -> b) -> a -> b
    $ "/dev" String -> ShowS
    </> "loop" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    n
    		LoopDev -> Maybe LoopDev
    forall a. a -> Maybe a
    Just (LoopDev -> Maybe LoopDev) -> LoopDev -> Maybe LoopDev
    forall a b. (a -> b) -> a -> b
    $ LoopDev :: String -> String -> LoopDev
    LoopDev
    			{ partitionLoopDev :: String
    partitionLoopDev = "/dev/mapper/" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    ld
    			, wholeDiskLoopDev :: String
    wholeDiskLoopDev = String
    wd
    			}
    	finddev _ = Maybe LoopDev
    forall a. Maybe a
    Nothing