summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/DotDir.hs26
-rw-r--r--src/Propellor/Git.hs7
-rw-r--r--src/Propellor/Property/DiskImage.hs2
-rw-r--r--src/Propellor/Property/DiskImage/PartSpec.hs9
-rw-r--r--src/Propellor/Property/Installer/Target.hs4
-rw-r--r--src/Propellor/Property/Parted.hs18
-rw-r--r--src/Propellor/Property/Parted/Types.hs7
7 files changed, 44 insertions, 29 deletions
diff --git a/src/Propellor/DotDir.hs b/src/Propellor/DotDir.hs
index e9253b87..f62b38f8 100644
--- a/src/Propellor/DotDir.hs
+++ b/src/Propellor/DotDir.hs
@@ -358,7 +358,7 @@ checkRepoUpToDate = whenM (gitbundleavail <&&> dotpropellorpopulated) $ do
withQuietOutput createProcessSuccess $
proc "git" ["log", headrev]
if (headknown == Nothing)
- then setupUpstreamMaster headrev
+ then updateUpstreamMaster headrev
else do
theirhead <- getCurrentGitSha1 =<< getCurrentBranchRef
when (theirhead /= headrev) $ do
@@ -372,26 +372,30 @@ checkRepoUpToDate = whenM (gitbundleavail <&&> dotpropellorpopulated) $ do
d <- dotPropellor
doesFileExist (d </> "propellor.cabal")
--- Makes upstream/master in dotPropellor be a usefully mergeable branch.
+-- Updates upstream/master in dotPropellor so merging from it will update
+-- to the latest distrepo.
--
--- We cannot just use origin/master, because in the case of a distrepo,
--- it only contains 1 commit. So, trying to merge with it will result
--- in lots of merge conflicts, since git cannot find a common parent
--- commit.
+-- We cannot just fetch the distrepo because the distrepo contains only
+-- 1 commit. So, trying to merge with it will result in lots of merge
+-- conflicts, since git cannot find a common parent commit.
--
--- Instead, the upstream/master branch is created by taking the
--- upstream/master branch (which must be an old version of propellor,
+-- Instead, the new upstream/master branch is updated by taking the
+-- current upstream/master branch (which must be an old version of propellor,
-- as distributed), and diffing from it to the current origin/master,
-- and committing the result. This is done in a temporary clone of the
-- repository, giving it a new master branch. That new branch is fetched
-- into the user's repository, as if fetching from a upstream remote,
-- yielding a new upstream/master branch.
-setupUpstreamMaster :: String -> IO ()
-setupUpstreamMaster newref = do
+--
+-- If there's no upstream/master, the user is not using the distrepo,
+-- so do nothing. And, if there's a remote named "upstream", the user
+-- must have set that up is not using the distrepo, so do nothing.
+updateUpstreamMaster :: String -> IO ()
+updateUpstreamMaster newref = unlessM (hasRemote "upstream") $ do
changeWorkingDirectory =<< dotPropellor
go =<< catchMaybeIO getoldrev
where
- go Nothing = warnoutofdate False
+ go Nothing = return ()
go (Just oldref) = do
let tmprepo = ".git/propellordisttmp"
let cleantmprepo = void $ catchMaybeIO $ removeDirectoryRecursive tmprepo
diff --git a/src/Propellor/Git.hs b/src/Propellor/Git.hs
index 1d81c157..10b88ddd 100644
--- a/src/Propellor/Git.hs
+++ b/src/Propellor/Git.hs
@@ -23,9 +23,12 @@ getCurrentGitSha1 branchref = takeWhile (/= '\n')
<$> readProcess "git" ["show-ref", "--hash", branchref]
hasOrigin :: IO Bool
-hasOrigin = catchDefaultIO False $ do
+hasOrigin = hasRemote "origin"
+
+hasRemote :: String -> IO Bool
+hasRemote remotename = catchDefaultIO False $ do
rs <- lines <$> readProcess "git" ["remote"]
- return $ "origin" `elem` rs
+ return $ remotename `elem` rs
hasGitRepo :: IO Bool
hasGitRepo = doesFileExist ".git/HEAD"
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 24459476..289de151 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -420,7 +420,7 @@ imageFinalized final img mnts mntopts devs (PartTable _ _ parts) =
orderedmntsdevs = sortBy (compare `on` fst) $ zip mnts (zip mntopts devs)
swaps = map (SwapPartition . partitionLoopDev . snd) $
- filter ((== LinuxSwap) . partFs . fst) $
+ filter ((== Just LinuxSwap) . partFs . fst) $
zip parts devs
mountall top = forM_ orderedmntsdevs $ \(mp, (mopts, loopdev)) -> case mp of
diff --git a/src/Propellor/Property/DiskImage/PartSpec.hs b/src/Propellor/Property/DiskImage/PartSpec.hs
index 942cfa3e..b78e4280 100644
--- a/src/Propellor/Property/DiskImage/PartSpec.hs
+++ b/src/Propellor/Property/DiskImage/PartSpec.hs
@@ -9,6 +9,7 @@ module Propellor.Property.DiskImage.PartSpec (
partition,
-- * PartSpec combinators
swapPartition,
+ rawPartition,
mountedAt,
addFreeSpace,
setSize,
@@ -48,11 +49,15 @@ import Data.Ord
-- The partition is not mounted anywhere by default; use the combinators
-- below to configure it.
partition :: Monoid t => Fs -> PartSpec t
-partition fs = (Nothing, mempty, mkPartition fs, mempty)
+partition fs = (Nothing, mempty, mkPartition (Just fs), mempty)
-- | Specifies a swap partition of a given size.
swapPartition :: Monoid t => PartSize -> PartSpec t
-swapPartition sz = (Nothing, mempty, const (mkPartition LinuxSwap sz), mempty)
+swapPartition sz = (Nothing, mempty, const (mkPartition (Just LinuxSwap) sz), mempty)
+
+-- | Specifies a partition without any filesystem, of a given size.
+rawPartition :: Monoid t => PartSize -> PartSpec t
+rawPartition sz = (Nothing, mempty, const (mkPartition Nothing sz), mempty)
-- | Specifies where to mount a partition.
mountedAt :: PartSpec t -> MountPoint -> PartSpec t
diff --git a/src/Propellor/Property/Installer/Target.hs b/src/Propellor/Property/Installer/Target.hs
index 62ec4082..80e660ad 100644
--- a/src/Propellor/Property/Installer/Target.hs
+++ b/src/Propellor/Property/Installer/Target.hs
@@ -246,10 +246,10 @@ fstabLists userinput (TargetPartTable _ partspecs) = setup <!> doNothing
partitions = map (\(mp, _, mkpart, _) -> (mp, mkpart mempty)) partspecs
mnts = mapMaybe fst $
- filter (\(_, p) -> partFs p /= LinuxSwap) partitions
+ filter (\(_, p) -> partFs p /= Just LinuxSwap && partFs p /= Nothing) partitions
swaps targetdev =
map (Fstab.SwapPartition . diskPartition targetdev . snd) $
- filter (\((_, p), _) -> partFs p == LinuxSwap)
+ filter (\((_, p), _) -> partFs p == Just LinuxSwap)
(zip partitions partNums)
-- | Make the target bootable using whatever bootloader is installed on it.
diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs
index 97cf815e..81b84972 100644
--- a/src/Propellor/Property/Parted.hs
+++ b/src/Propellor/Property/Parted.hs
@@ -62,8 +62,10 @@ partitioned eep disk parttable@(PartTable _ _ parts) = property' desc $ \w -> do
where
desc = disk ++ " partitioned"
formatl devs = combineProperties desc (toProps $ map format (zip parts devs))
- format (p, dev) = Partition.formatted' (partMkFsOpts p)
- Partition.YesReallyFormatPartition (partFs p) dev
+ format (p, dev) = case partFs p of
+ Just fs -> Partition.formatted' (partMkFsOpts p)
+ Partition.YesReallyFormatPartition fs dev
+ Nothing -> doNothing
-- | Gets the total size of the disk specified by the partition table.
partTableSize :: PartTable -> ByteSize
@@ -81,12 +83,12 @@ calcPartedParamsSize (PartTable tabletype alignment parts) =
, pval f
, pval b
]
- mkpart partnum startpos endpos p =
- [ "mkpart"
- , pval (partType p)
- , pval (partFs p)
- , partposexact startpos
- , partposfuzzy endpos
+ mkpart partnum startpos endpos p = catMaybes
+ [ Just "mkpart"
+ , Just $ pval (partType p)
+ , fmap pval (partFs p)
+ , Just $ partposexact startpos
+ , Just $ partposfuzzy endpos
] ++ case partName p of
Just n -> ["name", show partnum, n]
Nothing -> []
diff --git a/src/Propellor/Property/Parted/Types.hs b/src/Propellor/Property/Parted/Types.hs
index e5c62739..cfd8760d 100644
--- a/src/Propellor/Property/Parted/Types.hs
+++ b/src/Propellor/Property/Parted/Types.hs
@@ -31,7 +31,7 @@ instance Monoid PartTable where
data Partition = Partition
{ partType :: PartType
, partSize :: PartSize
- , partFs :: Partition.Fs
+ , partFs :: Maybe Partition.Fs
, partMkFsOpts :: Partition.MkfsOpts
, partFlags :: [(PartFlag, Bool)] -- ^ flags can be set or unset (parted may set some flags by default)
, partName :: Maybe String -- ^ optional name for partition (only works for GPT, PC98, MAC)
@@ -39,7 +39,7 @@ data Partition = Partition
deriving (Show)
-- | Makes a Partition with defaults for non-important values.
-mkPartition :: Partition.Fs -> PartSize -> Partition
+mkPartition :: Maybe Partition.Fs -> PartSize -> Partition
mkPartition fs sz = Partition
{ partType = Primary
, partSize = sz
@@ -105,7 +105,7 @@ fromAlignment :: Alignment -> ByteSize
fromAlignment (Alignment n) = n
-- | Flags that can be set on a partition.
-data PartFlag = BootFlag | RootFlag | SwapFlag | HiddenFlag | RaidFlag | LvmFlag | LbaFlag | LegacyBootFlag | IrstFlag | EspFlag | PaloFlag
+data PartFlag = BootFlag | RootFlag | SwapFlag | HiddenFlag | RaidFlag | LvmFlag | LbaFlag | LegacyBootFlag | IrstFlag | EspFlag | PaloFlag | BiosGrubFlag
deriving (Show)
instance PartedVal PartFlag where
@@ -120,6 +120,7 @@ instance PartedVal PartFlag where
pval IrstFlag = "irst"
pval EspFlag = "esp"
pval PaloFlag = "palo"
+ pval BiosGrubFlag = "bios_grub"
instance PartedVal Bool where
pval True = "on"
generated by cgit v1.3-2-g0d8e (git 2.53.0) at 2026-07-03 12:05:00 +0000