[Pkg-haskell-commits] [tools] 01/01: Switched to file fetching with curl. So Fetched files can be moved to other locations. Moved cache filed to <filename>.debian, to distinguish from files that come from derivatives (which might get implemented in the future). Sorted functions by category.
Sven Bartscher
svenb-guest at moszumanska.debian.org
Wed Aug 20 16:38:21 UTC 2014
This is an automated email from the git hooks/post-receive script.
svenb-guest pushed a commit to branch master
in repository tools.
commit cc7c30725999343cbdbacd0ebb29674b67e21cac
Author: Sven Bartscher <sven.bartscher at weltraumschlangen.de>
Date: Wed Aug 20 18:36:09 2014 +0200
Switched to file fetching with curl. So Fetched files can be moved to other
locations.
Moved cache filed to <filename>.debian, to distinguish from files that come
from derivatives (which might get implemented in the future).
Sorted functions by category.
---
reasons.hs | 248 +++++++++++++++++++++++++++++++++++++------------------------
1 file changed, 152 insertions(+), 96 deletions(-)
diff --git a/reasons.hs b/reasons.hs
index c2dacb1..6d9991c 100644
--- a/reasons.hs
+++ b/reasons.hs
@@ -1,19 +1,77 @@
-import Text.Regex.PCRE
+import Codec.Compression.GZip
+import Control.Exception
+import Control.Monad
+import Data.Maybe
+import Data.List
+import Data.Char
+import Data.Time.Clock
+import Data.Time.Clock.POSIX
+import Network.Curl
import System.Environment
import System.Exit
import System.Process
+import System.Directory
import System.IO
-import Data.Maybe
-import Data.List
-import Data.Char
-import qualified Data.Set as S
-import Control.Exception
import System.IO.Error
-import System.Directory
+import Text.Regex.PCRE
import qualified Data.ByteString.Lazy.Char8 as B
-import Codec.Compression.GZip
-import Control.Monad
-import Debug.Trace
+import qualified System.IO.Strict as S
+
+-- Constants
+
+fileSuffix :: String
+fileSuffix = "debian" -- Hardcoded for now, because there are no supported
+ -- derivatives.
+
+outputURL :: String
+outputURL = "https://release.debian.org/britney/"
+
+packageNotFoundMsg :: String
+packageNotFoundMsg
+ = "The package you requested was not processed by the autohinter.\n\
+ \grep-excuses <pkg> should list all reasons why this package doesn't \
+ \migrate."
+
+-- Main
+
+main = withCurlDo $ do
+ package <- getArgs >>= parse
+ output <- fmap lines
+ $ acquireFile outputURL "update_output.txt" fileSuffix False
+ let bins = getBinBlockers output package
+ result <- try (fmap nub $ mapM getSrcPackage bins) :: IO (Either ErrorCall [String])
+ srcBlockers <- case result of
+ Left e -> putStrLn packageNotFoundMsg >> exitFailure
+ Right pkgs -> return pkgs
+ excuses <- mapM getExcuse srcBlockers
+ additionalExcuses <- getAdditionalExcuses srcBlockers excuses
+ filteredExcuses <- filterExcuses (isInteresting fileSuffix) $ excuses ++ additionalExcuses
+ mapM_ putStrLn $ map excuses2String filteredExcuses
+
+-- Command line parsing
+
+parse :: [String] -> IO String
+parse [package] = return package
+parse _ = printUsage >> exitFailure
+
+printUsage :: IO ()
+printUsage = do
+ progName <- getProgName
+ putStrLn $ "Usage: " ++ progName ++ " package-name"
+
+-- Utility
+
+maybeTail :: [a] -> Maybe [a]
+maybeTail [] = Nothing
+maybeTail (x:xs) = Just xs
+
+removeFieldPrefix :: String -> String
+removeFieldPrefix arch = drop 2 $ dropWhile (/= ':') arch
+
+matches :: String -> String -> Bool
+str `matches` pattern = (not . null) (str =~ pattern :: String)
+
+-- Excuses
data Excuses = Excuses String [String]
@@ -22,35 +80,60 @@ isEmpty (Excuses _ []) = False
isEmpty (Excuses _ _) = True
excuses2String :: Excuses -> String
-excuses2String (Excuses pkg excuses) = unlines $ (pkg ++ ":"):(map (" " ++) excuses)
-
-main = do
- package <- getArgs >>= parse
- output <- fmap lines
- $ acquireFile outputURL
- "update_output.txt" False
- let bins = getBinBlockers output package
- result <- try (fmap nub $ mapM getSrcPackage bins) :: IO (Either ErrorCall [String])
- srcBlockers <- case result of
- Left e -> putStrLn packageNotFoundMsg >> exitFailure
- Right pkgs -> return pkgs
- excuses <- mapM getExcuse srcBlockers
- additionalExcuses <- getAdditionalExcuses srcBlockers excuses
- filteredExcuses <- filterExcuses isInteresting $ excuses ++ additionalExcuses
- mapM_ putStrLn $ map excuses2String filteredExcuses
-
-acquireFile :: String -> String -> Bool -> IO String
-acquireFile urldir filename ungz = do
- cachePath <- chooseCachePath
- case cachePath of
- Nothing -> readProcess "/usr/bin/wget" ["-q", "-O", "-", urldir ++ ('/':filename)] ""
- Just path -> do
- createDirectoryIfMissing False path
- setCurrentDirectory path
- readProcess "/usr/bin/wget" ["-q", "-N", urldir ++ ('/':filename)] ""
- if ungz
- then fmap (B.unpack . decompress) $ B.readFile filename
- else readFile filename
+excuses2String (Excuses pkg excuses) = unlines
+ $ (pkg ++ ":"):(map (" " ++) excuses)
+
+flattenExcuses :: [Excuses] -> [String]
+flattenExcuses excuses = concat $ map unpackExcuses excuses
+
+unpackExcuses :: Excuses -> [String]
+unpackExcuses (Excuses _ excuses) = excuses
+
+-- File acquirance
+
+acquireFile :: String -> String -> String -> Bool -> IO String
+acquireFile urldir filename suffix ungz = do
+ cachePath <- chooseCachePath
+ case cachePath of
+ Nothing -> do
+ (status, text) <- curlGetString url [CurlFollowLocation True]
+ check status
+ return text
+ Just path -> do
+ createDirectoryIfMissing False path
+ setCurrentDirectory path
+ time <- getTime
+ readProcess "/usr/bin/curl" [ "-R"
+ , "-s"
+ , "-o", savename
+ , "-z", savename
+ , url] ""
+ file <- openFile savename ReadMode
+ if ungz
+ then hSetBinaryMode file True
+ else hSetEncoding file utf8
+ text <- S.hGetContents file
+ hClose file
+ return $ if ungz
+ then B.unpack $ decompress $ B.pack text
+ else text
+ where url = urldir ++ ('/':filename)
+ getTime = do
+ result <- tryJust (\e -> if isDoesNotExistError e
+ then Just e
+ else Nothing)
+ $ fmap (floor . utcTimeToPOSIXSeconds)
+ $ getModificationTime $ filename ++
+ ('.':suffix)
+ return $ case result of
+ Right time -> time
+ Left _ -> 0
+ check status = if status /= CurlOK
+ then putStrLn ("Download of " ++ url ++ " failed (" ++
+ show status ++ ")")
+ >> exitFailure
+ else return ()
+ savename = filename ++ ('.':suffix)
chooseCachePath :: IO (Maybe String)
chooseCachePath = do
@@ -65,32 +148,16 @@ chooseCachePath = do
then Just e
else Nothing
-outputURL :: String
-outputURL = "release.debian.org/britney/"
-
-parse :: [String] -> IO String
-parse [package] = return package
-parse _ = printUsage >> exitFailure
-
-printUsage :: IO ()
-printUsage = do
- progName <- getProgName
- putStrLn $ "Usage: " ++ progName ++ " package-name"
-
-packageNotFoundMsg :: String
-packageNotFoundMsg
- = "The package you requested was not processed by the autohinter.\n\
- \grep-excuses <pkg> should list all reasons why this package doesn't \
- \migrate."
+-- Excuse filtering
filterExcuses :: (String -> String -> IO Bool) -> [Excuses] -> IO [Excuses]
filterExcuses f excuses = fmap (filter isEmpty) $ mapM filterPkgExcuses excuses
where filterPkgExcuses (Excuses pkg excuses)
= fmap (Excuses pkg) $ filterM (f pkg) excuses
-isInteresting :: String -> String -> IO Bool
-isInteresting pkg excuse = do
- interestingOUD <- isInterestingOUD pkg excuse
+isInteresting :: String -> String -> String -> IO Bool
+isInteresting fileSuffix pkg excuse = do
+ interestingOUD <- isInterestingOUD fileSuffix pkg excuse
return $ interestingOUD
|| "introduces new bugs" `isInfixOf` excuse
|| "Too young" `isPrefixOf` excuse
@@ -101,6 +168,17 @@ isInterestingDependency pkgs _ excuse = return
$ "(not considered)" `isSuffixOf` excuse
&& (mangleDependency excuse) `notElem` pkgs
+isInterestingOUD :: String -> String -> String -> IO Bool
+isInterestingOUD fileSuffix pkg excuse = if "out of date" `isPrefixOf` excuse
+ then do
+ let arch = mangleOUD excuse
+ text <- acquireFile "https://buildd.debian.org/stats/"
+ (arch ++ "-dump.txt.gz") fileSuffix True
+ return $ (status $ B.pack text) /= (B.pack "BD-Uninstallable")
+ else return False
+ where status = (=~ (B.pack $ "(?<=state: ).*(?=\n(.+\n)*package: "
+ ++ pkg ++ ")"))
+
mangleDependency :: String -> String
mangleDependency excuse
| null dependency = ""
@@ -110,16 +188,7 @@ mangleDependency excuse
mangleOUD :: String -> String
mangleOUD = (=~ "(?<=out of date on ).*(?=:)")
-isInterestingOUD :: String -> String -> IO Bool
-isInterestingOUD pkg excuse = if "out of date" `isPrefixOf` excuse
- then do
- let arch = mangleOUD excuse
- text <- acquireFile "buildd.debian.org/stats/"
- (arch ++ "-dump.txt.gz") True
- return $ (status $ B.pack text) /= (B.pack "BD-Uninstallable")
- else return False
- where status
- = (=~ (B.pack $ "(?<=state: ).*(?=\n(.+\n)*package: " ++ pkg ++ ")"))
+-- Fetching Excuses
-- Takes a list of already fetched excuses and returns the excuses of missing dependencies
getAdditionalExcuses :: [String] -> [Excuses] -> IO [Excuses]
@@ -133,16 +202,6 @@ getAdditionalExcuses pkgs excuses = do
evenMoreExcuses <- getAdditionalExcuses (pkgs ++ dependencies) excuses
return $ excuses ++ evenMoreExcuses
-flattenExcuses :: [Excuses] -> [String]
-flattenExcuses excuses = concat $ map unpackExcuses excuses
-
-unpackExcuses :: Excuses -> [String]
-unpackExcuses (Excuses _ excuses) = excuses
-
-maybeTail :: [a] -> Maybe [a]
-maybeTail [] = Nothing
-maybeTail (x:xs) = Just xs
-
getExcuse :: String -> IO Excuses
getExcuse pkg = do
--hPutStrLn stderr $ "retrievieng excuses for " ++ pkg
@@ -150,12 +209,23 @@ getExcuse pkg = do
return $ Excuses pkg $ map (dropWhile isSpace)
$ fromMaybe [] $ maybeTail $ lines excuses
+-- Package Gathering
+
getSrcPackage :: String -> IO String
getSrcPackage bin = do
--hPutStrLn stderr $ "querying source for " ++ bin
packageDesc <- readProcess "/usr/bin/apt-cache" ["showsrc", bin] ""
return $ parseDesc packageDesc
+getBinBlockers :: [String] -> String -> [String]
+getBinBlockers output package = let arches = getArches package output
+ in nub $ map stripComma
+ $ concat
+ $ map (words . removeFieldPrefix) arches
+ where stripComma str = if last str == ','
+ then init str
+ else str
+
parseDesc :: String -> String
parseDesc desc = let ls = lines desc
srcln = findSourceLine ls
@@ -166,18 +236,7 @@ findSourceLine (curLine:rest)
| "Package: " `isPrefixOf` curLine = curLine
| otherwise = findSourceLine rest
-getBinBlockers :: [String] -> String -> [String]
-getBinBlockers output package = let arches = getArches package output
- in nub $ map stripComma
- $ concat
- $ map words
- $ map removeFieldPrefix arches
- where stripComma str = if last str == ','
- then init str
- else str
-
-removeFieldPrefix :: String -> String
-removeFieldPrefix arch = drop 2 $ dropWhile (/= ':') arch
+-- Britney output parsing
getArches :: String -> [String] -> [String]
getArches package output = get $ removeStats $ fromJust $ findAutohint package output
@@ -185,9 +244,6 @@ getArches package output = get $ removeStats $ fromJust $ findAutohint package o
| line `matches` " *\\* .*:" = line : get rest
| otherwise = []
-removeStats :: [String] -> [String]
-removeStats = drop 4
-
findAutohint :: String -> [String] -> Maybe [String]
findAutohint _ [] = Nothing
findAutohint package (curLine:rest)
@@ -195,5 +251,5 @@ findAutohint package (curLine:rest)
= Just rest
| otherwise = findAutohint package rest
-matches :: String -> String -> Bool
-str `matches` pattern = (not . null) (str =~ pattern :: String)
+removeStats :: [String] -> [String]
+removeStats = drop 4
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-haskell/tools.git
More information about the Pkg-haskell-commits
mailing list