Add error handling to oneapi update script
Reviewed-by: Rodrigo Arias Mallo <rodrigo.arias@bsc.es>
This commit is contained in:
@@ -1,30 +1,32 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Main (main) where
|
||||
|
||||
import Control.Arrow (second, (&&&))
|
||||
import Control.Monad (when)
|
||||
|
||||
import qualified Data.Map.Lazy as M
|
||||
import qualified Data.Map.Strict as MS
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as TIO
|
||||
|
||||
import Data.Char (isAlpha, isNumber)
|
||||
import Data.Char (isAlpha)
|
||||
import Data.List (find, nub, sortOn)
|
||||
import Data.Map.Lazy (Map)
|
||||
import Data.Maybe (catMaybes, maybeToList)
|
||||
import Data.Maybe (maybeToList)
|
||||
import Data.Ord (Down (Down))
|
||||
import Data.Text.Read (decimal)
|
||||
|
||||
import Debug.Trace (trace, traceShow)
|
||||
import Debug.Trace (trace)
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit (exitFailure)
|
||||
import System.IO (stderr)
|
||||
import Text.Printf (PrintfType, hPrintf, printf)
|
||||
import Text.Printf (hPrintf, printf)
|
||||
|
||||
type Str = T.Text
|
||||
type Data = Map Str [Package]
|
||||
type Version = [Int]
|
||||
type Err a = Either Str a
|
||||
|
||||
data Package = Package
|
||||
{ name :: Str
|
||||
@@ -41,67 +43,90 @@ data Dependency = Dependency
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Kit = Kit
|
||||
{ kitMajorVersion, kitFullVersion :: Version
|
||||
, kitPackages :: [Package]
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- Standard Ordering cannot represent GE or LE, we have to cook our own
|
||||
data Ordering' = GT' | LT' | EQ' | GE' | LE' deriving (Show, Eq)
|
||||
|
||||
-- PARSING
|
||||
|
||||
parse :: Str -> Data
|
||||
parse :: Str -> Err Data
|
||||
parse =
|
||||
M.map (sortOn (Down . version))
|
||||
. M.fromListWith (++)
|
||||
. fmap (second pure)
|
||||
. catMaybes
|
||||
. fmap
|
||||
( (parsePackage . M.fromList)
|
||||
. fmap (second (T.strip . T.drop 1) . T.breakOn ":")
|
||||
. T.lines
|
||||
. T.strip
|
||||
)
|
||||
. T.splitOn "\n\n"
|
||||
fmap (M.map (sortOn (Down . version)) . M.fromListWith (++) . fmap (second pure))
|
||||
. mapM parsePackage
|
||||
. ( init
|
||||
. fmap
|
||||
( M.fromList
|
||||
. ( fmap (second (T.strip . T.drop 1) . T.breakOn ":")
|
||||
. T.lines
|
||||
. T.strip
|
||||
)
|
||||
)
|
||||
. T.splitOn "\n\n"
|
||||
)
|
||||
|
||||
parseDependency :: Str -> Dependency
|
||||
parseDependency t = case (T.words t) of
|
||||
(a : b : c : []) -> mkPkg a b c
|
||||
(a : c : []) -> let (a', b) = T.breakOn "(" a in mkPkg a' b c -- workaround for packages that don't have a space between the name and the version parenthesis
|
||||
(a : []) -> Dependency a Nothing
|
||||
(b) -> traceShow b $ undefined
|
||||
parseDependency :: Str -> Err Dependency
|
||||
parseDependency t = case (T.breakOn "(" t) of
|
||||
(a, "") -> Right $ Dependency (T.strip a) Nothing
|
||||
(a, b) -> do
|
||||
let (o, v) = T.span (`elem` ("<=>" :: String)) $ T.tail b
|
||||
o' <- toOrd' o
|
||||
v' <- parseVersion . T.strip $ T.dropEnd 1 v
|
||||
return . Dependency (T.strip a) $ Just (o', v')
|
||||
where
|
||||
mkPkg a b c = Dependency a (Just ((toOrd' $ T.drop 1 b), (parseVersion $ T.dropEnd 1 c)))
|
||||
|
||||
toOrd' :: Str -> Ordering'
|
||||
toOrd' ">>" = GT'
|
||||
toOrd' "<<" = LT'
|
||||
toOrd' "=" = EQ'
|
||||
toOrd' ">=" = GE'
|
||||
toOrd' "<=" = LE'
|
||||
toOrd' t = traceShow t $ undefined
|
||||
toOrd' :: Str -> Err Ordering'
|
||||
toOrd' ">>" = Right GT'
|
||||
toOrd' "<<" = Right LT'
|
||||
toOrd' "=" = Right EQ'
|
||||
toOrd' ">=" = Right GE'
|
||||
toOrd' "<=" = Right LE'
|
||||
toOrd' r = Left $ T.unwords ["could not parse dependency", quote t, "(unknown constraint type", quote r <> ")"]
|
||||
|
||||
dropEmpty :: [Str] -> [Str]
|
||||
dropEmpty = Prelude.filter (not . T.null)
|
||||
dropEmpty = filter (not . T.null)
|
||||
|
||||
parseVersion :: Str -> Version
|
||||
parseVersion = fmap (unwrapEither . decimal) . dropEmpty . T.split (not . isNumber)
|
||||
tshow :: (Show a) => a -> Str
|
||||
tshow = T.pack . show
|
||||
|
||||
quote :: Str -> Str
|
||||
quote = ("\"" <>) . (<> "\"")
|
||||
|
||||
parseVersion :: Str -> Err Version
|
||||
parseVersion = (>>= validateVersion) . mapM (unwrapDecimal . decimal) . dropEmpty . T.split (`elem` ("-._~" :: String))
|
||||
where
|
||||
unwrapEither (Right (a, "")) = a
|
||||
-- should never fail, since we filtered non numbers for the split and removed empty strings
|
||||
unwrapEither (Left err) = trace err $ undefined
|
||||
unwrapEither (Right (_, b)) = trace (T.unpack b) $ undefined
|
||||
unwrapDecimal (Left err) = Left . T.pack $ "version parsing failed with error: " <> err
|
||||
unwrapDecimal (Right (a, "")) = Right a
|
||||
unwrapDecimal (Right (a, b)) =
|
||||
Left $ T.unwords ["version parsing failed, parsed", quote $ tshow a, "(leftover:", quote b <> ")"]
|
||||
|
||||
parsePackage :: Map Str Str -> Maybe (Str, Package)
|
||||
validateVersion [] = Left "version is empty"
|
||||
validateVersion v = Right v
|
||||
|
||||
parsePackage :: Map Str Str -> Err (Str, Package)
|
||||
parsePackage d =
|
||||
(,)
|
||||
<$> package
|
||||
<*> ( Package
|
||||
<$> package
|
||||
<*> (parseVersion <$> d M.!? "Version")
|
||||
<*> (d M.!? "Filename")
|
||||
<*> (d M.!? "SHA256")
|
||||
<*> (read . T.unpack <$> (d M.!? "Installed-Size"))
|
||||
<*> (pure $ fmap parseDependency $ dropEmpty $ (>>= T.splitOn ",") $ maybeToList $ d M.!? "Depends")
|
||||
<*> (d !? "Version" >>= parseVersion)
|
||||
<*> (d !? "Filename")
|
||||
<*> (d !? "SHA256")
|
||||
<*> (read . T.unpack <$> (d !? "Installed-Size"))
|
||||
<*> (mapM parseDependency . dropEmpty . (>>= T.splitOn ",") . maybeToList $ d M.!? "Depends")
|
||||
)
|
||||
where
|
||||
package = d M.!? "Package"
|
||||
package = d !? "Package"
|
||||
|
||||
(!?) :: (Show a) => Map Str a -> Str -> Err a
|
||||
m !? k = maybeToEither ("missing key " <> quote k <> " in:\n" <> tshow m) $ m M.!? k
|
||||
|
||||
maybeToEither :: a -> Maybe b -> Either a b
|
||||
maybeToEither _ (Just b) = Right b
|
||||
maybeToEither a Nothing = Left a
|
||||
|
||||
-- DEPENDENCY SOLVER
|
||||
|
||||
@@ -125,7 +150,8 @@ compareVersions :: Maybe (Ordering', Version) -> Version -> Bool
|
||||
compareVersions Nothing _ = True
|
||||
compareVersions (Just (kind, want)) got
|
||||
| null want = True
|
||||
| kind == GE' = and (Prelude.take 2 $ zipWith (==) got want) && result
|
||||
| kind == GE' = and (take 2 $ zipWith (==) got want) && result
|
||||
| kind == EQ' = and $ zipWith (==) want got -- Only compare up to the smallest list
|
||||
| otherwise = result
|
||||
where
|
||||
result = matches (compare got want) kind
|
||||
@@ -136,32 +162,39 @@ compareVersions (Just (kind, want)) got
|
||||
matches GT b = b `elem` [GT', GE']
|
||||
|
||||
findMatching :: Data -> Dependency -> Maybe Package
|
||||
findMatching pkgList (Dependency name ver) = pkgList M.!? name >>= find (compareVersions (ver) . version)
|
||||
findMatching pkgList (Dependency n v) = pkgList M.!? n >>= find (compareVersions v . version)
|
||||
|
||||
getHpckit :: Data -> Version -> Maybe Package
|
||||
getHpckit d v = findMatching d (Dependency "intel-hpckit" (Just (GE', v)))
|
||||
findMatchingTraced :: Data -> Dependency -> [Package]
|
||||
findMatchingTraced l d@(Dependency n v) = case findMatching l d of
|
||||
Nothing ->
|
||||
trace
|
||||
( unwords $
|
||||
["[WARN]: dependency:", T.unpack n]
|
||||
++ (case v of Nothing -> []; Just v' -> [show v'])
|
||||
++ ["not found"]
|
||||
)
|
||||
[]
|
||||
Just a -> [a]
|
||||
|
||||
-- TODO: replace maybeToList with proper error handling. Right now, if a
|
||||
-- dependency is not found it is silently skipped.
|
||||
solveDeps :: Data -> Package -> [Package]
|
||||
solveDeps d p = removeDupes $ go ([], [p])
|
||||
solveDeps d p = removeDupes $ go [] [p]
|
||||
where
|
||||
go (done, todo)
|
||||
go done todo
|
||||
| null todo = done'
|
||||
| otherwise = go (done', todo')
|
||||
| otherwise = go done' todo'
|
||||
where
|
||||
done' = filter (not . isBlacklisted) $ nub $ done ++ (filter isMetaPackage todo)
|
||||
todo' = concatMap depends todo >>= maybeToList . findMatching d
|
||||
isMetaPackage = ((/= 0) . size) -- Packages with size 0
|
||||
done' = filter (not . isBlacklisted) . nub $ done ++ (filter (not . isMetaPackage) todo)
|
||||
todo' = todo >>= depends >>= findMatchingTraced d
|
||||
isMetaPackage = ((== 0) . size) -- Meta Packages are only used to pull dependencies
|
||||
removeDupes :: [Package] -> [Package]
|
||||
removeDupes l = fmap snd . MS.toList $ MS.fromListWith (getLatest) $ (cleanName . name &&& id) <$> l
|
||||
removeDupes = fmap snd . MS.toList . MS.fromListWith getLatest . fmap (cleanName . name &&& id)
|
||||
|
||||
getLatest a b
|
||||
| version a > version b = a
|
||||
| otherwise = b
|
||||
|
||||
-- Remove trailing version information from package name
|
||||
cleanName :: T.Text -> T.Text
|
||||
cleanName :: Str -> Str
|
||||
cleanName = T.dropWhileEnd (not . isAlpha)
|
||||
|
||||
isBlacklisted :: Package -> Bool
|
||||
@@ -189,36 +222,42 @@ isBlacklisted = (`elem` blacklist) . cleanName . name
|
||||
, "intel-oneapi-vtune-eclipse-plugin-vtune"
|
||||
]
|
||||
|
||||
application :: [String] -> Str -> Err [Kit]
|
||||
application args contents = do
|
||||
v <- mapM (parseVersion . T.pack) $ case args of
|
||||
[] -> ["2025"]
|
||||
_ -> args
|
||||
|
||||
d <- parse contents
|
||||
mapM (processKit d) v
|
||||
|
||||
processKit :: Data -> Version -> Err Kit
|
||||
processKit d v = do
|
||||
kit <- findHpckit "intel-hpckit"
|
||||
return $ Kit v (version kit) (solveDeps d kit)
|
||||
where
|
||||
findHpckit pName =
|
||||
maybeToEither (T.unwords ["package not found:", pName, "=", showVer v]) $
|
||||
findMatching d (Dependency pName (Just (EQ', v)))
|
||||
|
||||
-- OUTPUT
|
||||
|
||||
showVer, showVerDash :: [Int] -> T.Text
|
||||
showVer = T.dropEnd 1 . T.concat . zipWith (flip (<>)) ([".", ".", "-"] ++ repeat ".") . fmap (T.pack . show)
|
||||
showVerDash = T.intercalate "-" . fmap (T.pack . show)
|
||||
showVer, showVerDash :: [Int] -> Str
|
||||
showVer = T.dropEnd 1 . T.concat . zipWith (flip (<>)) ([".", ".", "-"] ++ repeat ".") . fmap tshow
|
||||
showVerDash = T.intercalate "-" . fmap tshow
|
||||
|
||||
displayTOML :: (PrintfType t) => Version -> Package -> t
|
||||
displayTOML kit (Package n v f h _ _) = printf "[[hpckit-%s]]\nname=\"%s\"\nversion=\"%s\"\nfile=\"%s\"\nsha256=\"%s\"\n\n" (showVerDash kit) (cleanName n) (showVer v) f h
|
||||
|
||||
-- Reads debian Package List from apt repo from stdin and outputs TOML with
|
||||
-- Reads Debian Package List from apt repo from stdin and outputs TOML with
|
||||
-- hpckit versions passed as arguments
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- fmap T.pack <$> getArgs
|
||||
|
||||
let v = case args of
|
||||
[] -> ["2025"]
|
||||
_ -> args
|
||||
|
||||
d <- parse <$> TIO.getContents
|
||||
|
||||
mapM_ (processHpcKit d . parseVersion) v
|
||||
main =
|
||||
application <$> getArgs <*> TIO.getContents >>= \case
|
||||
Left err -> hPrintf stderr "[ERROR]: %s\n" err *> exitFailure
|
||||
Right l -> mapM_ (TIO.putStrLn) $ l >>= formatKit
|
||||
where
|
||||
processHpcKit :: Data -> Version -> IO ()
|
||||
processHpcKit d v =
|
||||
case (getHpckit d v) of
|
||||
Nothing -> hPrintf stderr "[WARN]: Could not find hpckit with version %s [SKIPPED]\n" (show v)
|
||||
(Just kit) -> do
|
||||
-- Save resolved hpckit version information
|
||||
printf "[meta.hpckit-%s]\nversion=\"%s\"\n\n" (showVerDash v) (showVer $ version kit)
|
||||
let deps = solveDeps d kit
|
||||
when (null deps) $ hPrintf stderr "[WARN]: Empty hpckit? (hpckit-%s)\n" (show v)
|
||||
mapM_ (displayTOML v) deps
|
||||
formatKit (Kit majorVer fullVer pkgs) =
|
||||
T.pack
|
||||
<$> (printf "[meta.hpckit-%s]\nversion=%s\n" (showVerDash majorVer) (quote $ showVer fullVer))
|
||||
: ((formatPackage) <$> pkgs)
|
||||
where
|
||||
formatPackage (Package n v f h _ _) =
|
||||
printf "[[hpckit-%s]]\nname=%s\nversion=%s\nfile=%s\nsha256=%s\n" (showVerDash majorVer) (quote $ cleanName n) (quote $ showVer v) (quote f) (quote h)
|
||||
|
||||
Reference in New Issue
Block a user