{-# LANGUAGE CPP #-}
-- see https://pagure.io/pungi-fedora/
#if !MIN_VERSION_base(4,13,0)
import Control.Applicative ((<|>)
#if !MIN_VERSION_base(4,8,0)
, (<$>), (<*>)
#endif
)
import Data.Semigroup ((<>))
#endif
import Control.Exception.Extra (retry)
import Control.Monad.Extra (filterM, unless, unlessM, when, whenJust)
import qualified Data.ByteString.Char8 as B
import Data.Char (isDigit)
import Data.List.Extra
import Data.Ord (comparing, Down(Down))
import Data.Maybe
import qualified Data.Text as T
import Data.Time (UTCTime)
import Data.Time.LocalTime (getCurrentTimeZone, utcToZonedTime, TimeZone)
import Distribution.Fedora.Release (getCurrentFedoraVersion, getRawhideVersion)
import Network.HTTP.Client (managerResponseTimeout, newManager,
responseTimeoutNone)
import Network.HTTP.Client.TLS
import Network.HTTP.Directory
import Numeric.Natural
import Options.Applicative (fullDesc, header, progDescDoc)
import Paths_dl_fedora (version)
import SimpleCmd (cmd, cmd_, cmdBool, cmdN, error', grep_, logMsg,
pipe_, pipeBool, pipeFile_,
warning, (+-+),
#if MIN_VERSION_simple_cmd(0,2,7)
sudoLog
#else
sudo_
#endif
)
import SimpleCmdArgs
import SimplePrompt (yesNo, yesNoDefault)
import System.Directory (createDirectory, doesDirectoryExist, doesFileExist,
findExecutable, getPermissions, listDirectory,
pathIsSymbolicLink, removeFile, withCurrentDirectory,
writable)
import System.FilePath (dropFileName, joinPath, takeExtension, takeFileName,
(</>), (<.>))
import System.Posix.Files (createSymbolicLink, fileSize, getFileStatus,
readSymbolicLink)
import System.Posix.User (getLoginName)
import Text.Read
import qualified Text.ParserCombinators.ReadP as R
import qualified Text.ParserCombinators.ReadPrec as RP
import Text.Regex.Posix
import qualified Text.PrettyPrint.ANSI.Leijen as P
import DownloadDir
data FedoraEdition = Cloud
| Container
| Everything
| Server
| Workstation
| Budgie -- first spin: used below
| Cinnamon
| COSMIC
| I3
| KDE
| KDEMobile
| LXDE
| LXQt
| MATE
| Miracle
| SoaS
| Sway
| Xfce -- last spin: used below
| Silverblue
| Kinoite
| Onyx
| Sericea
| IoT
deriving (Show, Enum, Bounded, Eq)
showEdition :: Release -> FedoraEdition -> String
showEdition rel KDE =
case rel of
Rawhide -> "KDE-Desktop"
Fedora r | r >= 42 -> "KDE-Desktop"
_ -> "KDE"
showEdition _ KDEMobile = "KDE-Mobile"
showEdition _ MATE = "MATE_Compiz"
showEdition _ Miracle = "MiracleWM"
showEdition _ I3 = "i3"
showEdition _ e = show e
lowerEdition :: FedoraEdition -> String
lowerEdition = lower . show
instance Read FedoraEdition where
readPrec = do
s <- look
let e = lower s
editionMap =
("gnome", Workstation) :
("sb", Silverblue) :
("ws", Workstation) :
map (\ ed -> (lowerEdition ed, ed)) [minBound..maxBound]
res = lookup e editionMap
case res of
Nothing -> error' ("unknown edition: " ++ show s) >> RP.pfail
Just ed -> RP.lift (R.string e) >> return ed
type URL = String
fedoraSpins :: [FedoraEdition]
fedoraSpins = [Budgie .. Xfce]
allSpins :: Natural -> Natural -> Release -> [FedoraEdition]
allSpins rawhide current rel =
case rel of
Rawhide -> allSpins rawhide current $ Fedora rawhide
Fedora r ->
fedoraSpins \\ case compare r 41 of
GT -> []
EQ -> [COSMIC]
LT -> [COSMIC, KDEMobile, Miracle]
FedoraRespin -> delete KDEMobile $ allSpins rawhide current $ Fedora current
FedoraTest -> allSpins rawhide current $ Fedora current -- FIXME use fedora-releases
FedoraStage -> allSpins rawhide current $ Fedora (current + 1) -- FIXME use fedora-releases
CS 9 True -> [Cinnamon, KDE, MATE, Xfce] -- FIXME missing MAX, MIN
CS 10 True -> [KDE] -- FIXME missing MAX, MIN
CS n False -> error' $ "no spins available" ++ if n >= 9 then ": perhaps you want 'c" ++ show n ++ "s-live'?" else ""
CS _ _ -> error' "--all-spins not supported"
ELN -> error' "--all-spins not supported for this release"
allEditions :: Natural -> Natural -> Release -> [FedoraEdition]
allEditions rawhide current rel =
case rel of
Rawhide -> allEditions rawhide current $ Fedora rawhide
Fedora r ->
[minBound..maxBound] \\ missingEditions r
FedoraRespin -> Workstation : allSpins rawhide current FedoraRespin
FedoraTest -> allEditions rawhide current $ Fedora current -- FIXME use fedora-releases
FedoraStage -> allEditions rawhide current $ Fedora (current + 1) -- FIXME use fedora-releases
CS _ True -> Workstation : allSpins rawhide current rel
CS n False -> [Workstation]
_ -> error' "--all-editions not supported for this release"
where
missingEditions r =
case compare r 41 of
GT -> [IoT]
EQ -> [COSMIC]
LT -> [COSMIC, KDEMobile, Miracle]
data RequestEditions = Editions [FedoraEdition] | AllSpins | AllEditions
deriving Eq
data CheckSum = AutoCheckSum | NoCheckSum | CheckSum
deriving Eq
dlFpo, downloadFpo, kojiPkgs, odcsFpo, csComposes, odcsStream, csMirror
:: String
dlFpo = "https://dl.fedoraproject.org/pub" -- main repo
downloadFpo = "https://download.fedoraproject.org/pub" -- mirror redirect
kojiPkgs = "https://kojipkgs.fedoraproject.org/compose"
odcsFpo = "https://odcs.fedoraproject.org/composes"
csComposes = "https://composes.stream.centos.org"
odcsStream = "https://odcs.stream.centos.org" -- no cdn
csMirror = "https://mirror.stream.centos.org"
data Mirror = DlFpo | UseMirror | KojiFpo | Mirror String | DefaultLatest
deriving Eq
data CentosChannel = CSProduction | CSTest | CSDevelopment
deriving Eq
showChannel :: CentosChannel -> String
showChannel CSProduction = "production"
showChannel CSTest = "test"
showChannel CSDevelopment = "development"
data Release = Fedora Natural
| FedoraRespin
| Rawhide
| FedoraTest
| FedoraStage
| ELN
| CS Natural Bool -- alt live respin
deriving Eq
readRelease :: Natural -> Natural -> String -> Release
readRelease rawhide current rel =
case lower rel of
'f': n@(_:_) | all isDigit n -> Fedora (read n)
n@(_:_) | all isDigit n ->
let v = read n in
case compare v 11 of
LT -> CS v False
EQ -> ELN
GT ->
case compare v rawhide of
LT -> Fedora v
EQ -> Rawhide
GT -> error' $ "Current rawhide is" +-+ show rawhide
"current" -> Fedora current
"previous" -> Fedora (current -1)
-- FIXME hardcoding
"c8s" -> CS 8 False
"c9s" -> CS 9 False
"c10s" -> CS 10 False
"9-live" -> CS 9 True
"9-respin" -> CS 9 True
"c9s-live" -> CS 9 True
"c9s-respin" -> CS 9 True
"10-live" -> CS 10 True
"10-respin" -> CS 10 True
"c10s-live" -> CS 10 True
"c10s-respin" -> CS 10 True
"respin" -> FedoraRespin
"rawhide" -> Rawhide
"test" -> FedoraTest
"stage" -> FedoraStage
"eln" -> ELN
_ -> error' "unknown release"
data Mode = Check | Local | List | Download Bool -- replace
deriving Eq
main :: IO ()
main = do
let pdoc = Just $ P.vcat
[ P.text "Tool for downloading Fedora iso file images.",
P.text ("RELEASE = " <> intercalate ", " ["release number", "respin", "rawhide", "test (Beta)", "stage (RC)", "eln", "c9s", "c10s", "c9s-live"]),
P.text "EDITION = " <> P.lbrace <> P.align (P.fillCat (P.punctuate P.comma (map (P.text . lowerEdition) [(minBound :: FedoraEdition)..maxBound])) <> P.rbrace) <> P.text " [default: workstation]" ,
P.text "",
P.text "See <https://github.com/juhp/dl-fedora/#readme>"
]
sysarch <- readArch <$> cmd "rpm" ["--eval", "%{_arch}"]
rawhideVersion <- getRawhideVersion
currentRelease <- getCurrentFedoraVersion
simpleCmdArgsWithMods (Just version) (fullDesc <> header "Fedora iso downloader" <> progDescDoc pdoc) $
program rawhideVersion
<$> switchWith 'g' "gpg-keys" "Import Fedora GPG keys for verifying checksum file"
<*> checksumOpts
<*> switchLongWith "debug" "Debug output"
<*> switchWith 'T' "no-http-timeout" "Do not timeout for http response"
<*> (flagWith' Check 'c' "check" "Check if newer image available" <|>
flagWith' Local 'l' "local" "Show current local image" <|>
flagLongWith' List "list" "List spins and editions" <|>
Download <$> switchWith 'R' "replace" "Delete previous snapshot image after downloading latest one")
<*> switchWith 'n' "dry-run" "Don't actually download anything"
<*> switchWith 'r' "run" "Boot image in QEMU"
<*> mirrorOpt
<*> switchLongWith "dvd" "Download dvd iso instead of boot netinst (for Server, eln, centos)"
<*> optional (flagLongWith' CSDevelopment "cs-devel" "Use centos-stream development compose" <|>
flagLongWith' CSTest "cs-test" "Use centos-stream test compose" <|>
flagLongWith' CSProduction "cs-production" "Use centos-stream production compose (default is mirror.stream.centos.org)")
<*> optional (strOptionLongWith "alt-cs-extra-edition" "('MAX'|'MIN')" "Centos Stream Alternative Live Spin editions (MAX,MIN)")
<*> (optionWith (eitherReader eitherArch) 'a' "arch" "ARCH" ("Specify arch [default:" +-+ showArch sysarch ++ "]") <|> pure sysarch)
<*> (readRelease rawhideVersion currentRelease <$> strArg "RELEASE")
<*> (flagLongWith' AllSpins "all-spins" "Get all Fedora Spins" <|>
flagLongWith' AllEditions "all-editions" "Get all Fedora editions" <|>
Editions <$> many (argumentWith auto "EDITION..."))
where
mirrorOpt :: Parser Mirror
mirrorOpt =
flagWith' DefaultLatest 'L' "latest" "Get latest image either from mirror or dl.fp.o if newer" <|>
flagWith' DlFpo 'd' "dl" "Use dl.fedoraproject.org (dl.fp.o)" <|>
flagWith' KojiFpo 'k' "koji" "Use koji.fedoraproject.org" <|>
Mirror <$> strOptionWith 'm' "mirror" "URL" ("Mirror url for /pub [default " ++ downloadFpo ++ "]") <|>
pure UseMirror
checksumOpts :: Parser CheckSum
checksumOpts =
flagLongWith' NoCheckSum "no-checksum" "Do not check checksum" <|>
flagLongWith AutoCheckSum CheckSum "checksum" "Do checksum even if already downloaded"
data Primary = Primary {primaryUrl :: String,
primarySize :: Maybe Integer,
primaryTime :: Maybe UTCTime}
program :: Natural -> Bool -> CheckSum -> Bool -> Bool -> Mode -> Bool -> Bool
-> Mirror -> Bool -> Maybe CentosChannel -> Maybe String -> Arch
-> Release -> RequestEditions -> IO ()
program rawhide gpg checksum debug notimeout mode dryrun run mirror dvdnet mchannel mcsedition arch tgtrel reqeditions = do
when (isJust mchannel && not (isCentosStream tgtrel)) $
error' "channels are only for centos-stream"
let mirrorUrl =
case mirror of
Mirror m -> m
KojiFpo -> kojiPkgs
DlFpo -> dlFpo
-- UseMirror or DefaultLatest
_ ->
case tgtrel of
ELN -> odcsFpo
CS n _ | n >= 9 -> if isJust mchannel
then csComposes
else csMirror
CS 8 _ -> csComposes
_ -> downloadFpo
showdestdir <- setDownloadDir dryrun "iso"
when debug $ print showdestdir
mgr <- if notimeout
then newManager (tlsManagerSettings {managerResponseTimeout = responseTimeoutNone})
else httpManager
unless (reqeditions == Editions []) $
case tgtrel of
ELN -> error' "cannot specify edition for eln"
CS _ False -> error' "cannot specify edition for centos-stream"
_ -> return ()
when (isJust mcsedition) $
case tgtrel of
CS n True | n >= 9 ->
case reqeditions of
Editions [] -> return ()
_ -> error' "combining extra edition unsupported"
_ -> error' "--alt-cs-extra-edition is only for CS Alt Live spins"
current <- getCurrentFedoraVersion
mapM_ (runProgramEdition mgr mirrorUrl showdestdir gpg checksum debug mode dryrun run mirror dvdnet mchannel mcsedition arch tgtrel reqeditions) $
if mode == List
then [Workstation]
else
case reqeditions of
AllEditions -> allEditions rawhide current tgtrel
AllSpins -> allSpins rawhide current tgtrel
Editions editions ->
if null editions then [Workstation] else editions
runProgramEdition :: Manager -> URL -> String -> Bool -> CheckSum -> Bool
-> Mode -> Bool -> Bool -> Mirror -> Bool
-> Maybe CentosChannel -> Maybe String -> Arch -> Release
-> RequestEditions -> FedoraEdition -> IO ()
runProgramEdition mgr mirrorUrl showdestdir gpg checksum debug mode dryrun run mirror dvdnet mchannel mcsedition arch tgtrel reqeditions edition =
case mode of
Check -> do
(fileurl, filenamePrefix, _prime, _mchecksum, done) <- findURL True
if done
then do
putStrLn $ "Local:" +-+ takeFileName fileurl +-+ "is latest"
when debug $ print fileurl
else do
let symlink = filenamePrefix <> (if tgtrel == ELN then "-" <> showArch arch else "") <> "-latest" <.> takeExtension fileurl
mtarget <- derefSymlink symlink
case mtarget of
Just target -> do
if target == takeFileName fileurl
then putStrLn $ "Latest:" +-+ target +-+ "(locally incomplete)"
else do
putStrLn $ "Local:" +-+ target
putStrLn $ "Newer:" +-+ takeFileName fileurl
Nothing -> putStrLn $ "Available:" +-+ takeFileName fileurl
Local -> do
prefix <- getFilePrefix
-- FIXME support non-iso
let symlink = prefix <> (if tgtrel == ELN then "-" <> showArch arch else "") <> "-latest" <.> "iso"
mtarget <- derefSymlink symlink
whenJust mtarget $ \target -> do
putStrLn $ "Local:" +-+ target
when run $
bootImage dryrun target showdestdir
List -> do
rawhide <- getRawhideVersion
current <- getCurrentFedoraVersion
let editions =
case reqeditions of
AllSpins -> allSpins rawhide current tgtrel
_ -> allEditions rawhide current tgtrel
extras =
case tgtrel of
CS _ True -> ["max","min"]
_ -> []
putStrLn $ unwords $ sort (map lowerEdition editions) ++ extras
Download removeold -> do
(fileurl, filenamePrefix, prime, mchecksum, done) <- findURL False
let symlink = filenamePrefix <> (if tgtrel == ELN then "-" <> showArch arch else "") <> "-latest" <.> takeExtension fileurl
downloadFile dryrun debug done mgr fileurl prime showdestdir >>=
fileChecksum fileurl mchecksum
unless dryrun $ do
let localfile = takeFileName fileurl
updateSymlink localfile symlink removeold
when run $ bootImage dryrun localfile showdestdir
where
findURL :: Bool
-- urlpath, fileprefix, primary, checksum, downloaded
-> IO (URL, String, Primary, Maybe String, Bool)
findURL quiet = do
(path,mrelease) <- urlPathMRel
let path' = trailingSlash path
(primeDir,hrefs) <-
case tgtrel of
-- "koji" -> getUrlDirectory kojiPkgs path'
ELN -> getUrlDirectory odcsFpo path'
CS n _ ->
if n < 9 || isJust mchannel
then getUrlDirectory odcsStream path'
else getUrlDirectory csMirror path'
_ ->
if mirror `elem` [DefaultLatest, DlFpo]
then getUrlDirectory dlFpo path'
else do
(url,ls) <- getUrlDirectory downloadFpo path'
if null ls
then getUrlDirectory dlFpo path'
else return (url,ls)
when (null hrefs) $ error' $ primeDir +-+ "is empty"
let (prefixPat,selector) = makeFileSelector mrelease
fileslen = groupSortOn length $ filter selector $ map T.unpack hrefs
mchecksum = find ((if tgtrel == FedoraRespin then T.isPrefixOf else T.isSuffixOf) (T.pack "CHECKSUM")) hrefs
case fileslen of
[] -> error' $ "no match for " <> prefixPat <> " in " <> primeDir
(files:_) -> do
when (length files > 1) $ mapM_ putStrLn files
let file = last files
prefix = if '[' `elem` prefixPat
then (file =~ prefixPat) ++ if showArch arch `isInfixOf` prefixPat then "" else showArch arch
else prefixPat
primeUrl = primeDir +/+ file
(primeSize,primeTime) <- retry 3 $ httpFileSizeTime mgr primeUrl
(finalurl, already) <- do
let localfile = takeFileName primeUrl
exists <- doesFileExist localfile
if exists
then do
localsize <- toInteger . fileSize <$> getFileStatus localfile
done <- checkLocalFileSize localsize localfile primeSize primeTime quiet
if done
then return (primeUrl,True)
else do
unlessM (writable <$> getPermissions localfile) $ do
putStrLn $ localfile <> " does not have write permission!"
yes <- yesNo "Fix ownership"
if yes
then do
user <- getLoginName
sudoLog "chown" [user,localfile]
else
error' $ localfile <> " does not have write permission, aborting!"
findMirror primeUrl path file
else findMirror primeUrl path file
let finalDir = dropFileName finalurl
return (finalurl, prefix, Primary primeUrl primeSize primeTime,
(finalDir +/+) . T.unpack <$> mchecksum, already)
where
getUrlDirectory :: String -> FilePath -> IO (String, [T.Text])
getUrlDirectory top path = do
let url = top +/+ path
when debug $ do
print url
redirs <- retry 3 $ httpRedirects mgr $ replace "https:" "http:" url
print redirs
ls <- retry 3 $ httpDirectory mgr url
return (url, ls)
findMirror primeUrl path file = do
url <-
if mirrorUrl `elem` [dlFpo,kojiPkgs,odcsFpo]
then return primeUrl
else
if mirrorUrl /= downloadFpo
then return $ mirrorUrl +/+ path +/+ file
else do
redir <- retry 3 $ httpRedirect mgr $ mirrorUrl +/+ path +/+ file
case redir of
Nothing -> do
warning $ mirrorUrl +/+ path +/+ file <> " redirect failed"
return primeUrl
Just u -> do
let url = B.unpack u
exists <- retry 3 $ httpExists mgr url
when debug $ print (url, exists)
if exists then return url
else return primeUrl
return (url,False)
getFilePrefix :: IO String
getFilePrefix = do
let (prefixPat,selector) = makeFileSelector getRelease
symlinks <- listDirectory "." >>= filterM pathIsSymbolicLink
return $
case find selector (reverseSort symlinks) of
Nothing ->
if '[' `elem` prefixPat
then error' $ "no match for " <> prefixPat <> " in " <> showdestdir
else prefixPat
Just symlink ->
if '[' `elem` prefixPat
then (symlink =~ prefixPat) ++ if showArch arch `isInfixOf` prefixPat then "" else showArch arch
else prefixPat
getRelease :: Maybe String
getRelease =
case tgtrel of
-- FIXME IoT uses version for instead of Rawhide
Rawhide -> Just "Rawhide"
FedoraRespin -> Nothing
ELN -> Nothing
CS _ _ -> Nothing
Fedora rel -> Just $ show rel
_ -> error' "release target is unsupported with --dryrun"
checkLocalFileSize :: Integer -> FilePath -> Maybe Integer -> Maybe UTCTime
-> Bool -> IO Bool
checkLocalFileSize localsize localfile mprimeSize mprimeTime quiet = do
if Just localsize == mprimeSize
then do
unless quiet $ do
tz <- getCurrentTimeZone
-- FIXME abbreviate size?
putStrLn $ unwords [showdestdir </> localfile, renderTime tz mprimeTime, "size " ++ show localsize ++ " okay"]
return True
else do
when (isNothing mprimeSize) $
putStrLn "original size could not be read"
let sizepercent =
case mprimeSize of
Nothing -> show localsize
Just ms -> show (100 * localsize `div` ms) <> "%"
putStrLn $ "File " <> sizepercent <> " downloaded"
return False
urlPathMRel :: IO (FilePath, Maybe String)
urlPathMRel = do
let subdir =
if edition `elem` fedoraSpins
then joinPath ["Spins", showArch arch, "iso"]
else joinPath [showEdition tgtrel edition, showArch arch, editionMedia edition]
case tgtrel of
FedoraRespin -> return ("alt/live-respins", Nothing)
Rawhide -> return ("fedora/linux/development/rawhide" +/+ subdir, Just "Rawhide")
FedoraTest -> testRelease subdir
FedoraStage -> stageRelease subdir
ELN -> return ("production/latest-Fedora-ELN/compose" +/+ "BaseOS" +/+ showArch arch +/+ "iso", Nothing)
CS 8 False ->
return ("stream-8" +/+ showChannel (fromMaybe CSProduction mchannel) +/+ "latest-CentOS-Stream/compose" +/+ "BaseOS" +/+ showArch arch +/+ "iso", Nothing)
CS n cslive ->
return $
case mchannel of
Nothing ->
if cslive
then ("SIGs" +/+ show n ++ "-stream/altimages/images/live" +/+ showArch arch, Nothing)
else (show n ++ "-stream" +/+ "BaseOS" +/+ showArch arch +/+ "iso", Nothing)
Just channel ->
((if n == 9 then id else (("stream-" ++ show n) +/+)) $ showChannel channel +/+ "latest-CentOS-Stream/compose" +/+ "BaseOS" +/+ showArch arch +/+ "iso", Nothing)
Fedora n ->
if edition == IoT
then return ("alt/iot" +/+ show n +/+ subdir, Nothing)
else released (show n) subdir
testRelease :: FilePath -> IO (FilePath, Maybe String)
testRelease subdir = do
let path = "fedora/linux" +/+ "releases/test"
url = dlFpo +/+ path
rels <- map (T.unpack . noTrailingSlash) <$> retry 3 (httpDirectory mgr url)
let mrel = if null rels then Nothing else Just (last rels)
return (path +/+ fromMaybe (error' ("test release not found in " <> url)) mrel +/+ subdir, mrel)
stageRelease :: FilePath -> IO (FilePath, Maybe String)
stageRelease subdir = do
let path = "alt/stage"
url = dlFpo +/+ path
rels <- reverse . map (T.unpack . noTrailingSlash) <$> retry 3 (httpDirectory mgr url)
let mrel = listToMaybe rels
return (path +/+ fromMaybe (error' ("staged release not found in " <> url)) mrel +/+ subdir, takeWhile (/= '_') <$> mrel)
-- kojiCompose :: Manager -> FilePath -> IO (FilePath, Maybe String)
-- kojiCompose mgr subdir = do
-- let path = "branched"
-- url = kojiPkgs +/+ path
-- prefix = "latest-Fedora-"
-- latest <- filter (prefix `isPrefixOf`) . map T.unpack <$> retry 3 $ httpDirectory mgr url
-- let mlatest = listToMaybe latest
-- return (path +/+ fromMaybe (error' ("koji branched latest dir not found in " <> url)) mlatest +/+ "compose" +/+ subdir, removePrefix prefix <$> mlatest)
-- use https://admin.fedoraproject.org/pkgdb/api/collections ?
released :: FilePath -> FilePath -> IO (FilePath, Maybe String)
released rel subdir = do
let dir = "fedora/linux/releases"
url = dlFpo +/+ dir
exists <- retry 3 $ httpExists mgr $ url +/+ rel
when debug $ print (exists, url +/+ rel)
if exists
then return (dir +/+ rel +/+ subdir, Just rel)
else do
let dir' = "fedora/linux/development"
url' = dlFpo +/+ dir'
exists' <- retry 3 $ httpExists mgr $ url' +/+ rel
if exists'
then return (dir' +/+ rel +/+ subdir, Just rel)
else error' "release not found in releases/ or development/"
renderdvdboot = if dvdnet then "dvd1" else "boot"
makeFileSelector :: Maybe String -> (String, String -> Bool)
makeFileSelector mrelease =
let (prefixPat,msuffix) = makeFilePrefixSuffix mrelease
selector f =
not ("-latest-" `isInfixOf` f) &&
case msuffix of
Just suffix -> f =~ (prefixPat ++ ".*-" ++ suffix)
Nothing ->
if '[' `elem` prefixPat
then f =~ prefixPat
else prefixPat `isPrefixOf` f
in (prefixPat, selector)
makeFilePrefixSuffix :: Maybe String -> (String, Maybe String)
makeFilePrefixSuffix mrelease =
case tgtrel of
FedoraRespin ->
("F[1-9][0-9]-" <> liveRespin edition <> "-x86_64" <> "-LIVE",
Nothing)
ELN -> ("Fedora-eln", Just renderdvdboot)
CS n cslive ->
if cslive
then ("CentOS-Stream-Image-" ++ maybe (csLive edition) upper mcsedition ++ "-Live" <.> showArch arch ++ '-' : show n, Nothing)
else ("CentOS-Stream-" ++ show n, Just renderdvdboot)
_ ->
let showRel r = if last r == '/' then init r else r
rel = maybeToList (showRel <$> mrelease)
(midpref,middle) =
case edition of
-- https://github.com/fedora-iot/iot-distro/issues/1
IoT -> ("", rel)
Cloud | tgtrel == Fedora 40 -> ('.' : showArch arch, rel)
Container | tgtrel == Fedora 40 -> ('.' : showArch arch, rel)
_ -> ("",
if edition `elem` kiwiSpins
then rel
else showArch arch : rel)
in (intercalate "-" (["Fedora", showEdition tgtrel edition, editionType edition ++ midpref] ++ middle),
Nothing)
-- https://pagure.io/pungi-fedora/blob/main/f/fedora.conf#_251 kiwibuild
kiwiSpins :: [FedoraEdition]
kiwiSpins =
-- https://fedoraproject.org/wiki/Changes/EROFSforLiveMedia
(if fedoraVerOrLater 42 tgtrel
then [Budgie, COSMIC, KDE, LXQt, Workstation, Xfce]
else []) ++
(if fedoraVerOrLater 41 tgtrel
then [Cloud, Container, KDEMobile, Miracle]
else [])
where
fedoraVerOrLater :: Natural -> Release -> Bool
fedoraVerOrLater _ Rawhide = True
fedoraVerOrLater n (Fedora m) = m >= n
fedoraVerOrLater _ _ = False
editionType :: FedoraEdition -> String
editionType Server = if dvdnet then "dvd" else "netinst"
editionType IoT = "ostree"
editionType Kinoite = "ostree"
editionType Onyx = "ostree"
editionType Sericea = "ostree"
editionType Silverblue = "ostree"
editionType Everything = "netinst"
editionType Cloud = "Base-Generic"
editionType Container = "Base-Generic"
editionType _ = "Live"
fileChecksum :: String -> Maybe URL -> Maybe Bool -> IO ()
fileChecksum _ Nothing _ = return ()
fileChecksum imageurl (Just url) mneedChecksum =
when ((mneedChecksum == Just True && checksum /= NoCheckSum) || (isJust mneedChecksum && checksum == CheckSum)) $ do
let checksumdir = ".dl-fedora-checksums"
checksumfilename = takeFileName url
checksumpath = checksumdir </> checksumfilename
exists <- do
dirExists <- doesDirectoryExist checksumdir
if dirExists
then checkChecksumfile url checksumpath
else createDirectory checksumdir >> return False
putStrLn ""
haveChksum <-
if exists
then return True
else do
remoteExists <- retry 3 $ httpExists mgr url
if remoteExists
then do
withCurrentDirectory checksumdir $ do
ok <- curl debug $ (if debug then ["--silent", "--show-error"] else []) ++ ["--remote-name", url]
unless ok $ error' $ "failed to download" +-+ url
doesFileExist checksumpath
else return False
if not haveChksum
then putStrLn "No checksum file found"
else do
pgp <- grep_ "PGP" checksumpath
when (gpg && pgp) $ do
case tgtrel of
Fedora n -> do
havekey <- checkForFedoraKeys n
unless havekey $ do
putStrLn "Importing Fedora GPG keys:\n"
-- https://fedoramagazine.org/verify-fedora-iso-file/
pipe_ ("curl",["--silent", "--show-error", "https://fedoraproject.org/fedora.gpg"]) ("gpg",["--import"])
putStrLn ""
_ -> return ()
chkgpg <-
if pgp
then
case tgtrel of
Fedora n -> checkForFedoraKeys n
_ -> return False
else return False
let shasum = if "CHECKSUM512" `isPrefixOf` checksumfilename
then "sha512sum" else "sha256sum"
if chkgpg then do
putStrLn $ "Running gpg verify and " <> shasum <> ":"
pipeFile_ checksumpath ("gpg",["-q"]) (shasum, ["-c", "--ignore-missing"])
else do
putStrLn $ "Running " <> shasum <> ":"
-- FIXME ignore other downloaded iso's (eg partial images error)
pipe_
("grep",[takeFileName imageurl,checksumpath])
(shasum,["-c","-"])
checkChecksumfile :: URL -> FilePath -> IO Bool
checkChecksumfile url checksumfile = do
exists <- doesFileExist checksumfile
if not exists then return False
else do
filesize <- toInteger . fileSize <$> getFileStatus checksumfile
when (filesize == 0) $ error' $ checksumfile +-+ "empty!"
(primeSize,primeTime) <- retry 3 $ httpFileSizeTime mgr url
when debug $ print (primeSize,primeTime,url)
ok <- checkLocalFileSize filesize checksumfile primeSize primeTime True
unless ok $ error' $ "Checksum file filesize mismatch for " ++ checksumfile
return ok
checkForFedoraKeys :: Natural -> IO Bool
checkForFedoraKeys n =
pipeBool ("gpg",["--list-keys"]) ("grep", ["-q", " Fedora .*(" <> show n <> ").*@fedoraproject.org>"])
updateSymlink :: FilePath -> FilePath -> Bool -> IO ()
updateSymlink target symlink removeold = do
mmsymlinkTarget <- do
havefile <- doesFileExist symlink
if havefile
then Just . Just <$> readSymbolicLink symlink
else do
-- check for broken symlink
dirfiles <- listDirectory "."
return $ if symlink `elem` dirfiles then Just Nothing else Nothing
case mmsymlinkTarget of
Nothing -> makeSymlink
Just Nothing -> do
removeFile symlink
makeSymlink
Just (Just symlinktarget) -> do
when (symlinktarget /= target) $ do
when removeold $ removeFile symlinktarget
removeFile symlink
makeSymlink
where
makeSymlink = do
putStrLn ""
createSymbolicLink target symlink
putStrLn $ unwords [showdestdir </> symlink, "->", target]
derefSymlink :: FilePath -> IO (Maybe FilePath)
derefSymlink symlink = do
havefile <- doesFileExist symlink
if havefile
then Just <$> readSymbolicLink symlink
else return Nothing
renderTime :: TimeZone -> Maybe UTCTime -> String
renderTime tz mprimeTime =
"(" ++ maybe "" (show . utcToZonedTime tz) mprimeTime ++ ")"
downloadFile :: Bool -> Bool -> Bool -> Manager -> URL -> Primary -> String
-> IO (Maybe Bool)
downloadFile dryrun debug done mgr url prime showdestdir = do
unless debug $ putStrLn url
if done
then return (Just False)
else do
mtime <- do
if url /= primaryUrl prime
then do
(mirrorSize,mirrorTime) <- retry 3 $ httpFileSizeTime mgr url
unless (mirrorSize == primarySize prime) $
putStrLn "Warning! Mirror filesize differs from primary file"
unless (mirrorTime == primaryTime prime) $
putStrLn "Warning! Mirror timestamp differs from primary file"
return mirrorTime
else return $ primaryTime prime
if dryrun
then return Nothing
else do
tz <- getCurrentTimeZone
putStrLn $ unwords ["downloading", takeFileName url, renderTime tz mtime, "to", showdestdir]
doCurl
return (Just True)
where
doCurl = do
ok <- curl debug ["--fail", "--remote-name", url]
unless ok $ do
yes <- yesNoDefault True "retry download"
if yes
then doCurl
else error' "download failed"
editionMedia :: FedoraEdition -> String
editionMedia Cloud = "images"
editionMedia Container = "images"
editionMedia _ = "iso"
liveRespin :: FedoraEdition -> String
liveRespin Budgie = "Budgie"
liveRespin I3 = "i3"
liveRespin Miracle = "MiracleWM"
liveRespin e = take 4 . upper . showEdition FedoraRespin $ e
bootImage :: Bool -> FilePath -> String -> IO ()
bootImage dryrun img showdir = do
let fileopts =
case takeExtension img of
".iso" -> ["-boot", "d", "-cdrom"]
_ -> []
mQemu <- findExecutable "qemu-kvm"
case mQemu of
Just qemu -> do
let args = ["-m", "3072", "-rtc", "base=localtime", "-cpu", "host"] ++ fileopts
cmdN qemu (args ++ [showdir </> img])
unless dryrun $
cmd_ qemu (args ++ [img])
Nothing -> error' "Need qemu to run image"
#if !MIN_VERSION_http_directory(0,1,6)
noTrailingSlash :: T.Text -> T.Text
noTrailingSlash = T.dropWhileEnd (== '/')
#endif
#if !MIN_VERSION_http_directory(0,1,9)
infixr 5 +/+
(+/+) :: String -> String -> String
"" +/+ s = s
s +/+ "" = s
s +/+ t | last s == '/' = init s +/+ t
| head t == '/' = s +/+ tail t
s +/+ t = s ++ "/" ++ t
#endif
-- derived from fedora-repoquery Types
data Arch = Source
| X86_64
| AARCH64
| S390X
| PPC64LE
deriving Eq
eitherArch :: String -> Either String Arch
eitherArch s =
case lower s of
"source" -> Right Source
"x86_64" -> Right X86_64
"aarch64" -> Right AARCH64
"s390x" -> Right S390X
"ppc64le" -> Right PPC64LE
_ -> Left $ "unknown arch: " ++ s
readArch :: String -> Arch
readArch =
either error' id . eitherArch
showArch :: Arch -> String
showArch Source = "source"
showArch X86_64 = "x86_64"
showArch AARCH64 = "aarch64"
showArch S390X = "s390x"
showArch PPC64LE = "ppc64le"
curl :: Bool -> [String] -> IO Bool
curl debug args = do
let opts = ["--location", "--continue-at", "-"]
when debug $
logMsg $ unwords $ "curl" : opts ++ args
cmdBool "curl" $ opts ++ args
isCentosStream :: Release -> Bool
isCentosStream (CS _ _) = True
isCentosStream _ = False
csLive :: FedoraEdition -> String
csLive Workstation = "GNOME"
csLive Cinnamon = "CINNAMON"
csLive KDE = "KDE"
csLive MATE = "MATE"
csLive Xfce = "XFCE"
csLive ed = error' $ "unsupported edition:" +-+ showEdition FedoraRespin ed
#if !MIN_VERSION_simple_cmd(0,2,7)
sudoLog :: String -- ^ command
-> [String] -- ^ arguments
-> IO ()
sudoLog = sudo_
#endif
reverseSort :: Ord a => [a] -> [a]
reverseSort = sortBy (comparing Down)