{-# LANGUAGE CPP, OverloadedStrings #-}
module Release (
showReleaseCmd,
getRelease,
activeFedoraReleases,
BodhiRelease(..),
downloadServer
)
where
import Control.Monad.Extra (forM_, unless, void, when)
import Data.Bifunctor (first)
import qualified Data.CaseInsensitive as CI
import Data.List.Extra
import Data.Maybe (fromMaybe)
import Data.Time.Format (defaultTimeLocale, parseTimeM, rfc822DateFormat)
import Data.Time.LocalTime (utcToLocalZonedTime)
import Data.Version.Extra (readVersion, Version(..))
import qualified Distribution.Fedora.Release as F
import Network.Curl (curlHead, CurlOption(..))
import Safe (tailSafe)
import SimpleCmd (error', (+-+))
import Text.Regex (mkRegex, subRegex)
import Arch
import BodhiRelease
import Common (warning)
import Types
import URL
showReleaseCmd :: Bool -> Bool -> RepoSource -> Release -> Arch -> Maybe Arch
-> Bool -> IO ()
showReleaseCmd debug dynredir reposource release sysarch march testing =
void $ getRelease debug dynredir False True reposource release sysarch march testing
getRelease :: Bool -> Bool -> Bool -> Bool -> RepoSource -> Release -> Arch
-> Maybe Arch -> Bool -> IO [(String, URL)]
getRelease debug dynredir warn checkdate reposource@(RepoSource koji _mirror) release sysarch march testing = do
case release of
EPEL n | n >= 10 && koji -> do
version <- F.releaseVersion <$>
F.getBranchRelease (show release)
let minor =
case readVersion version of
Version [_maj,min'] [] -> toEnum min'
_ -> error' $ "invalid minor branch version:" +-+ version
getRelease' debug dynredir warn checkdate reposource (EpelMinor n minor) sysarch march testing
_ -> getRelease' debug dynredir warn checkdate reposource release sysarch march testing
-- FIXME should warn or error if url (release) does not exist
getRelease' :: Bool -> Bool -> Bool -> Bool -> RepoSource -> Release -> Arch
-> Maybe Arch -> Bool -> IO [(String, URL)]
getRelease' debug dynredir warn checkdate reposource@(RepoSource koji _mirror) release sysarch march testing = do
let arch = fromMaybe sysarch march
(url,path) <- getURL debug dynredir reposource release arch
let urlpath = url +//+ path
when debug $ print $ renderUrl Dir urlpath
(basicrepos,morerepos) <-
if koji
then return ([("koji",urlpath)],[])
else
case release of
Centos n -> return ([("BaseOS",urlpath)],
[("AppStream",url),(if n >= 9 then "CRB" else "PowerTools",url)])
ELN -> return ([("BaseOS",urlpath)],
[("AppStream",urlpath),("CRB",urlpath)])
Rawhide -> return ([("development", urlpath)],[])
-- curl -s https://bodhi.fedoraproject.org/releases/?exclude_archived=True | jq
Fedora n -> do
eactiverelease <- activeFedoraRelease n
case eactiverelease of
Left _oldest ->
return (("releases", urlpath) :
("updates", url +//+ ["updates",show n]) :
[("updates-testing", url +//+ ["updates","testing",show n]) | testing]
,[])
Right rel -> do
let composed = releaseComposed rel
state = releaseState rel
postbeta = releasePostBeta rel
return $
-- after Beta Freeze
-- {"state": "pending", "composed_by_bodhi": true,
-- "create_automatic_updates": false, "setting_status": "post_beta"}
--
-- final freeze
-- {"state": "frozen", "composed_by_bodhi": true,
-- "create_automatic_updates": false, "setting_status": "post_beta"}
--
-- final unfrozen
-- {"state": "current", "composed_by_bodhi": true,
-- "create_automatic_updates": false, "setting_status": "post_beta"}
--
-- released
-- {"state": "current", "composed_by_bodhi": true,
-- "create_automatic_updates": false, "setting_status": null}
--
-- Rawhide
-- {"state": "pending", "composed_by_bodhi": false,
-- "create_automatic_updates": true, "setting_status": "pre_beta"}
if state `elem` ["pending","frozen"] || state == "current" && postbeta
then (("development", urlpath) :
[("updates", url +//+ ["updates",show n]) | postbeta , state == "current"] ++
-- FIXME add way to disable or invert testing
[("updates-testing", url +//+ ["updates","testing",show n]) | testing || composed, state /= "current"]
,[])
else (("releases", urlpath) :
("updates", url +//+ ["updates",show n]) :
[("updates-testing", url +//+ ["updates","testing",show n]) | testing || postbeta]
,[])
EPEL n -> return
(("epel",urlpath) :
[("epel-testing",url +//+ ["testing", show n]) | testing],
[])
EpelMinor n m -> return
(("epel",urlpath) :
[("epel-testing",url +//+ ["testing", show n ++ "." ++ show m]) | testing],
[])
EPEL9Next -> return ([("epelnext",urlpath)],[])
System -> error' "showRelease: unsupported for system"
rawhide <- rawhideFedoraRelease
let basicrepourls =
map (repoConfigArgs reposource sysarch march rawhide release) basicrepos
morerepourls =
map (repoConfigArgs reposource sysarch march rawhide release) morerepos
forM_ basicrepourls $ \(reponame,(url',path')) -> do
let baserepo = url' +//+ path'
when debug $ print $ renderUrl Dir baserepo
unless (not checkdate || release == System) $ do
let composeinfo =
url' +//+
if koji
then ["repo.json"]
else
case release of
Centos 10 -> ["metadata","composeinfo.json"]
Centos _ -> ["COMPOSE_ID"] -- ["metadata","composeinfo.json"]
ELN -> ["COMPOSE_ID"]
EPEL _ -> ["Everything", "state"]
EpelMinor _ _ -> ["Everything", "state"]
EPEL9Next -> ["Everything", "state"]
Fedora _ -> if "updates" `isInfixOf` reponame
then ["Everything", "state"]
else ["COMPOSE_ID"]
Rawhide -> ["COMPOSE_ID"]
System -> error' "system not supported"
let composeUrl = renderUrl File composeinfo
when debug $ print composeUrl
mtimestr <- curlGetHeader Nothing "Last-Modified" composeUrl
case mtimestr of
Just timestr -> do
utc <- parseTimeM False defaultTimeLocale rfc822DateFormat timestr
date <- utcToLocalZonedTime utc
(if warn then warning else putStrLn) $ show date +-+ "<" ++ renderUrl Dir url' ++ ">"
Nothing ->
-- FIXME maybe error?
warning $ composeUrl +-+ "not found (Last-Modified)"
return $ map (fmap (uncurry (+//+))) $ basicrepourls ++ morerepourls
getURL :: Bool -> Bool -> RepoSource -> Release -> Arch
-> IO (URL,[String])
getURL debug dynredir reposource@(RepoSource koji _mirror) release arch =
case release of
Centos n ->
case n of
10 ->
let url = URL $
if koji
then "https://odcs.stream.centos.org/stream-10"
else "https://composes.stream.centos.org/stream-10/production/latest-CentOS-Stream/compose/"
in return (url,[])
9 ->
let url = URL $
if koji
then "https://odcs.stream.centos.org"
else "https://mirror.stream.centos.org/9-stream/"
in return (url,[])
8 -> return (URL "http://vault.centos.org/8-stream/", [])
_ -> error' "old Centos is not supported"
ELN ->
getFedoraServer debug dynredir reposource ["eln"] ["1"]
EPEL n | n < 7 ->
return
(URL "https://archives.fedoraproject.org/pub/archive/epel", [show n])
EPEL n -> getFedoraServer debug dynredir reposource ["epel"] [show n]
EpelMinor n m -> getFedoraServer debug dynredir reposource ["epel"] [show n ++ "." ++ show m]
EPEL9Next -> getFedoraServer debug dynredir reposource ["epel","next"] ["9"]
Fedora n -> do
eactiverelease <- activeFedoraRelease n
case eactiverelease of
Left oldest ->
if n < oldest
then
return
(URL "https://archives.fedoraproject.org/pub/archive" +//+ fedoraTop, ["releases", show n])
else error' $ "unknown fedora release:" +-+ show n
Right rel ->
-- state values: ["disabled","pending","frozen","current","archived"]
let pending = releaseState rel /= "current"
postbeta = releasePostBeta rel
rawhide = pending && releaseBranch rel == "rawhide"
releasestr = if rawhide then "rawhide" else show n
in
if arch == RISCV64
then return (URL "http://fedora.riscv.rocks",[])
else
getFedoraServer debug dynredir reposource fedoraTop
[if pending || postbeta then "development" else "releases",
releasestr]
Rawhide -> getFedoraServer debug dynredir reposource fedoraTop ["development", "rawhide"]
System -> error' "getURL: unsupported for system"
where
fedoraTop =
-- FIXME support older archs
if arch `elem` [PPC64LE, S390X]
then ["fedora-secondary"]
else ["fedora", "linux"]
repoConfigArgs :: RepoSource -> Arch -> Maybe Arch -> Natural -> Release
-> (String,URL) -> (String,(URL,[String]))
repoConfigArgs (RepoSource False _mirror) sysarch (Just RISCV64) _rawhide release (repo,url) =
let (compose,path) =
case release of
Rawhide -> (["repos-dist", show release, "latest"],"")
_ -> (["repos-dist", show release, "latest"],"")
arch = RISCV64
reponame = repo ++ "-" ++ show release ++
if arch == sysarch then "" else "-" ++ showArch arch
in (reponame, (url +//+ compose, [path, showArch arch, ""]))
-- non-koji
repoConfigArgs (RepoSource False mirror) sysarch march rawhide release (repo,url) =
let arch = fromMaybe sysarch march
archsuffix = if arch == sysarch then "" else "-" ++ showArch arch
reponame = repoVersion ++ archsuffix ++
case mirror of
DownloadFpo -> ""
Mirror serv ->
'-' : takeWhile (/= '/') (subRegex (mkRegex "https?://") serv "")
DlFpo -> "-dl.fpo"
CloudFront -> "-cf"
path =
case release of
Centos _ -> [repo, showArch arch] ++ (if arch == Source then ["tree"] else ["os"])
ELN -> [repo, showArch arch] ++ (if arch == Source then ["tree"] else ["os"])
EPEL n -> (if n >= 8 then ("Everything" :) else id) [showArch arch] ++ ["tree" | arch == Source]
EpelMinor _n _m -> "Everything" : showArch arch : ["tree" | arch == Source]
EPEL9Next -> ["Everything", showArch arch]
Fedora _ -> ["Everything", showArch arch] ++ (if arch == Source then ["tree"] else ["os" | repo `elem` ["releases","development"]])
Rawhide -> ["Everything", showArch arch, if arch == Source then "tree" else "os"]
System -> error' "repoConfigArgs: unsupported for system"
in (reponame, (url, path ++ ["/"]))
where
repoVersion :: String
repoVersion =
case release of
Rawhide -> "fedora-rawhide"
Fedora n ->
if n == rawhide
then "fedora-rawhide"
else show release ++ if repo == "releases" then "" else '-':repo
ELN -> show release ++ '-':repo
EpelMinor _ _ -> show release ++ if repo == "epel-testing" then "-testing" else ""
EPEL9Next -> show release ++ if repo == "epelnext-testing" then "-testing" else ""
EPEL _ -> show release ++ if repo == "epel-testing" then "-testing" else ""
Centos _ -> show release ++ '-':repo
System -> ""
-- koji
repoConfigArgs (RepoSource True _mirror) sysarch march _rawhide release (repo,url) =
let (compose,path) =
case release of
Rawhide -> (["repos", show release, "latest"],"")
_ -> (["repos", show release ++ "-build/latest"],"")
arch = fromMaybe sysarch march
reponame = repo ++ "-" ++ show release ++ "-build" ++
if arch == sysarch then "" else "-" ++ showArch arch
in (reponame, (url +//+ compose, [path, showArch arch, ""]))
-- repoConfigArgs url (RepoCentosStream chan) arch release repo =
-- let (compose,path) = (["composes", channel chan, "latest-CentOS-Stream", "compose"], repo)
-- reponame = repo ++ "-Centos-" ++ show release ++ "-Stream" ++ "-" ++ show chan ++ if arch == sysarch then "" else "-" ++ showArch arch
-- in (reponame, (url +//+ compose, [path, showArch arch, "os/"]))
getFedoraServer :: Bool -> Bool -> RepoSource -> [String] -> [String]
-> IO (URL,[String])
getFedoraServer debug dynredir (RepoSource koji mirror) top path =
if koji
then return (URL "https://kojipkgs.fedoraproject.org",[])
else
case mirror of
DownloadFpo -> do
let url = URL downloadServer +//+ top ++ path
rurl = renderUrl Dir url
when debug $ print rurl
redir <-
if dynredir
then return Nothing
else curlGetHeader (Just 3000) "Location" rurl
when debug $ print redir
case redir of
Nothing -> do
when (debug && not dynredir) $
warning $ "slow redirection for" +-+ rurl
return (URL downloadServer +//+ top,path)
Just actual -> do
when debug $ do
warning rurl
warning $ "redirected to" +-+ show actual
let actualstr =
if "https://ftp.yzyu.jp/" `isPrefixOf` actual
then replace "https://" "http://" actual
else actual
when (actual /= actualstr) $
warning $ "replacing to" +-+ actualstr
return (URL $ removeSubpath path actualstr, path)
-- FIXME how to handle any path
Mirror serv -> return (URL serv,path)
DlFpo -> return (URL "https://dl.fedoraproject.org/pub" +//+ top, path)
CloudFront -> return (URL "https://d2lzkl7pfhq30w.cloudfront.net/pub" +//+ top, path)
downloadServer :: String
downloadServer = "https://download.fedoraproject.org/pub"
-- FIXME check CurlCode(CurlOK) status
curlGetHeader :: Maybe Natural -> CI.CI String -> String -> IO (Maybe String)
curlGetHeader mtimeout field url = do
(_status,headers) <- curlHead url $ maybe [] (singleton . CurlConnectTimeoutMS . fromIntegral) mtimeout
-- tail because curl leaves space before field value
return $ tailSafe <$> lookup field (map (first CI.mk) headers)
#if !MIN_VERSION_base(4,15,0)
singleton :: a -> [a]
singleton x = [x]
#endif