diff --git a/Distribution/ArchLinux/AUR.hs b/Distribution/ArchLinux/AUR.hs new file mode 100644 --- /dev/null +++ b/Distribution/ArchLinux/AUR.hs @@ -0,0 +1,333 @@ +-- | +-- Module : Distribution.ArchLinux.AUR +-- Copyright : (c) 2009 Don Stewart +-- License : BSD3 +-- Maintainer : Don Stewart +-- +-- Support for querying the AUR database. +-- +module Distribution.ArchLinux.AUR ( + AURInfo(..), + info, + search, + maintainer, + package + + ) where + +{- +The methods currently allowed are: + + * search + * info + +Each method requires the following HTTP GET syntax: + type=methodname&arg=data + +Where methodname is the name of an allowed method, and data is the argument to the call. + +If you need jsonp type callback specification, you can provide an additional variable callback. +Example URL: + http://aur-url/rpc.php?type=search&arg=foobar&callback=jsonp1192244621103 +-} + +import Network.HTTP +import Distribution.Version +import Distribution.Text +import Text.JSON +import Text.JSON.String +import Text.PrettyPrint +import Text.PrettyPrint.HughesPJClass +import qualified Data.Map as M +import Control.Monad +import System.FilePath +import Data.List +import Data.Char + +import Distribution.ArchLinux.PkgBuild + +------------------------------------------------------------------------ + +-- | Query AUR for information on a package +-- +-- > $ info "xmonad" +-- > +-- > Right (AURInfo { packageID = 10593 +-- > , packageName = "xmonad" +-- > , packageVersion = Right (Version {versionBranch = [0,8,1] , versionTags = []},"1.2")i +-- > , packageCategory = 17 +-- > , packageDesc = "A lightweight X11 tiled window manager written in Haskell" +-- > , packageLocation = 3 +-- > , packageURL = "http://xmonad.org/" +-- > , packagePath = "/packages/xmonad/xmonad.tar.gz" +-- > , packageLicense = "custom:BSD3" +-- > , packageVotes = 260 +-- > , packageOutOfDate = False }) +-- +info :: String -> IO (Either String AURInfo) +info m = eval (InfoRequest (Name m)) + +-- | Search AUR for packages matching pattern. Returns a list of info results. +search :: String -> IO [AURInfo] +search m = do + v <- eval (SearchRequest (Name m)) + return $ case v of + Left e -> [] + Right a -> flatten a + +-- | Search AUR for packages owned by maintainer. Returns a list of info results. +maintainer :: String -> IO [AURInfo] +maintainer m = do + v <- eval (MaintainerRequest (Name m)) + return $ case v of + Left e -> [] + Right a -> maintainerPackages a + +------------------------------------------------------------------------ +-- +-- TODO: programmatically list all packages by arch-haskell +-- generate table of versions. +-- colour out of date things. +-- + +-- | Return the parsed PKGBUILD +-- pkgbuild :: String -> IO (Either String [String]) -- (Either String PkgBuild) + +package :: String -> IO (Either String AURInfo, Either String AnnotatedPkgBuild) +package m = do + v <- info m + case v of + Left s -> return $ (Left s, Left "No PKGBUILD found") + Right p -> do + let name = packageName p + aurUrl = "http://aur.archlinux.org/packages" name name "PKGBUILD" + + rsp <- simpleHTTP (getRequest aurUrl) + case rsp of + Left err -> return $ (Right p, Left (show err)) + Right _ -> do + pkg <- getResponseBody rsp -- TODO 404 + case decodePackage pkg of + Left e -> return (Right p, Left e) + Right k -> return (Right p, Right k) + +------------------------------------------------------------------------ +-- +-- TODO: +-- generate report on packages. groupBy +-- + +-- | List packages not built with up to date version of cabal2arch +{- +lint_cabal2arch = do + aurs <- search "haskell" + forM_ aurs $ \aur -> do + let n = packageName aur + k <- pkgbuild n + case k of + Left _ -> putStrLn $ "No pkgbuild for" ++ packageName aur + Right p -> do + + case cabal2arch_version p of + v | v == simpleParse "0.6" + -> putStrLn $ "GOOD " ++ packageName aur + + v -> do putStrLn $ "Missing cabal2arch version for: " ++ packageName aur ++ " " ++ show v + putStrLn $ "http://aur.archlinux.org/packages.php?ID=" ++ show ( packageID aur) + putStrLn "" +-} + +------------------------------------------------------------------------ +-- +-- TODO: from the packagename, construct the url to the AUR page. +-- + +-- | URL for AUR RPC server +url :: Doc +url = text "http://aur.archlinux.org/rpc.php" + +-- | Query the server +eval :: JSON a => AURRequest -> IO (Either String a) +eval m = do + rsp <- simpleHTTP (getRequest call) + json <- getResponseBody rsp + return . resultToEither . decode $ json + where + call = render $ url pPrint m + +------------------------------------------------------------------------ +-- RPC requests + +-- | Type for AUR RPC requests. They can be info queries, or search queries. +-- +data AURRequest + = SearchRequest Name + | MaintainerRequest Name + | InfoRequest Name + deriving Show + +instance Pretty AURRequest where + pPrint (SearchRequest n) = text "type" <=> text "search" <&> text "arg" <=> pPrint n + pPrint (InfoRequest n) = text "type" <=> text "info" <&> text "arg" <=> pPrint n + pPrint (MaintainerRequest n) = text "type" <=> text "msearch" <&> text "arg" <=> pPrint n + +-- | Wrap up a package name a bit safely. +newtype Name = Name String + deriving Show + +instance Pretty Name where + pPrint (Name n) = text n + +-- | Useful combinators +infixl 6 <=>, <&>, + +(<=>), (<&>), () :: Doc -> Doc -> Doc +p <=> q = p <> char '=' <> q +p <&> q = p <> char '&' <> q +p q = p <> char '?' <> q + +------------------------------------------------------------------------ +-- RPC response values + +-- We can in turn use this info to query PKGBUILDs on the server + +-- | A type for maintainer search. +data AURMaintainer = AURMaintainer { maintainerPackages :: [AURInfo] } deriving Show + +instance JSON AURMaintainer where + showJSON = undefined + + readJSON (JSObject o) = do + -- sanity check: + case M.lookup "type" json of + Just (JSString t) | fromJSString t == "msearch" -> do + as <- forM results $ \(JSObject o) -> do + let obj = M.fromList (fromJSObject o) :: M.Map String JSValue + parseInfo obj + + return (AURMaintainer as) + + s -> fail $ "No type field in JSON response!" ++ show s + + where + json = M.fromList (fromJSObject o) :: M.Map String JSValue + results = case M.lookup "results" json of + Nothing -> error $ "No results for info object" + Just (JSArray a) -> a -- a list. + +------------------------------------------------------------------------ + +-- | Type for AUR RPC responses. +data AURInfo + = AURInfo { + packageID :: Integer -- ^ unique ID of the package on AUR + ,packageURLinAUR :: String -- ^ url of AUR package + ,packageName :: String -- ^ string name of package + ,packageVersion :: Either String (Version,String) -- ^ either the AUR version (version,rev) or a string + ,packageCategory :: Integer -- ^ numeric category of the package (e.g. 17 == System) + ,packageDesc :: String -- ^ package synopsis + ,packageLocation :: Integer -- ^ which repository is it stored in (community, AUR etc) + ,packageURL :: String -- ^ url (sanity check: should be hackage url mostly) + ,packagePath :: FilePath -- ^ url path to package source. + ,packageLicense :: String -- ^ type of license + ,packageVotes :: Integer -- ^ votes on package + ,packageOutOfDate :: Bool -- ^ is the package flagged as out of date + } + + deriving Show + +instance JSON AURInfo where + showJSON = undefined + + readJSON (JSObject o) = do + -- sanity check: + case M.lookup "type" json of + Just (JSString t) | fromJSString t == "info" -> parseInfo results + s -> fail $ "No type field in JSON response!" ++ show s + where + json = M.fromList (fromJSObject o) :: M.Map String JSValue + + results = case M.lookup "results" json of + Nothing -> error $ "No results for info object" + Just (JSObject o) -> M.fromList (fromJSObject o) :: M.Map String JSValue + +-- Need a different JSON instance +data AURSearch = AURSearch { flatten :: [AURInfo] } + +-- A list of results +instance JSON AURSearch where + showJSON = undefined + + readJSON (JSObject o) = do + -- sanity check: + case M.lookup "type" json of + Just (JSString t) | fromJSString t == "search" -> do + as <- forM results $ \(JSObject o) -> do + let obj = M.fromList (fromJSObject o) :: M.Map String JSValue + parseInfo obj + + return (AURSearch as) + + s -> fail $ "No type field in JSON response!" ++ show s + + where + json = M.fromList (fromJSObject o) :: M.Map String JSValue + results = case M.lookup "results" json of + Nothing -> error $ "No results for info object" + Just (JSArray a) -> a -- a list. + + +-- | Parse a AURInfo. +parseInfo :: M.Map String JSValue -> Result AURInfo +parseInfo info_obj = do + JSString id_ <- label "ID" + JSString name_ <- label "Name" + JSString vers_ <- label "Version" + JSString cat_ <- label "CategoryID" + JSString desc_ <- label "Description" + JSString loc_ <- label "LocationID" + JSString url_ <- label "URL" + JSString path_ <- label "URLPath" + JSString lic_ <- label "License" + JSString vote_ <- label "NumVotes" + JSString date_ <- label "OutOfDate" + + let vers__ = fromJSString vers_ + (x,xs) = break (== '-') vers__ + version | '-' `elem` vers__ = case simpleParse x of + Nothing -> Left vers__ + Just v -> Right (v, tail xs) + | otherwise = Left vers__ + + id_ident = read (fromJSString id_) + + return $ AURInfo { + packageID = id_ident + ,packageURLinAUR = "http://aur.archlinux.org/packages.php?ID=" ++ show id_ident + ,packageName = fromJSString name_ + ,packageVersion = version + ,packageCategory = read (fromJSString cat_) + ,packageDesc = fromJSString desc_ + ,packageLocation = read (fromJSString loc_) + ,packageURL = fromJSString url_ -- TODO : should be hackage url + ,packagePath = fromJSString path_ -- TODO : should be hackage url + ,packageLicense = fromJSString lic_ -- TODO : should be hackage url + ,packageVotes = read (fromJSString vote_) + ,packageOutOfDate = case fromJSString date_ of + "0" -> False + _ -> True + } + where + + label k = case M.lookup k info_obj of + Nothing -> fail $ "No field " ++ show k + Just o -> return o + + + +{- +JSObject (JSONObject {fromJSObject = [("type",JSString (JSONString {fromJSString = "info"})),("results",JSObject (JSONObject {fromJSObject = [("ID",JSString (JSONString {fromJSString = "10593"})),("Name",JSString (JSONString {fromJSString = "xmonad"})),("Version",JSString (JSONString {fromJSString = "0.8.1-1.2"})),("CategoryID",JSString (JSONString {fromJSString = "17"})),("Description",JSString (JSONString {fromJSString = "A lightweight X11 tiled window manager written in Haskell"})),("LocationID",JSString (JSONString {fromJSString = "3"})),("URL",JSString (JSONString {fromJSString = "http://xmonad.org/"})),("URLPath",JSString (JSONString {fromJSString = "/packages/xmonad/xmonad.tar.gz"})),("License",JSString (JSONString {fromJSString = "custom:BSD3"})),("NumVotes",JSString (JSONString {fromJSString = "259"})),("OutOfDate",JSString (JSONString {fromJSString = "0"}))]}))]}) +Right () +-} + +------------------------------------------------------------------------ diff --git a/Distribution/ArchLinux/Report.hs b/Distribution/ArchLinux/Report.hs new file mode 100644 --- /dev/null +++ b/Distribution/ArchLinux/Report.hs @@ -0,0 +1,378 @@ +{-# LANGUAGE FlexibleInstances #-} +-- | Construct reports about a set of packages in AUR +-- +module Distribution.ArchLinux.Report ( + report , loadPackageIndex + ) where + +import Distribution.ArchLinux.AUR +import Distribution.ArchLinux.PkgBuild +import Distribution.ArchLinux.CabalTranslation (oldCabal2Arch) + +import Distribution.Text +import Control.DeepSeq + +import System.FilePath +import Data.Maybe + +import Text.XHtml.Transitional +import Control.OldException +import Control.Monad +import Data.List +import Data.Ord +import Data.Char + +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import Control.Concurrent (forkIO) +import Control.Concurrent.Chan.Strict +import Control.Concurrent.MVar.Strict +import qualified Control.OldException as C +import System.IO +import System.Process +import System.Time +import GHC.Conc (numCapabilities) +import Text.Printf +import Control.Parallel.Strategies + +import Distribution.Version +import qualified Data.Map as M + +import Text.CSV +import Network.HTTP + +instance NFData (IO a) where rnf x = () + +instance NFData Version where rnf x = x `seq` () +instance NFData AURInfo where rnf x = x `seq` () +instance NFData AnnotatedPkgBuild where rnf x = x `seq` () + +-- Parallel work queue, similar to forM +-- +parM tests f = do + let n = numCapabilities + chan <- newChan + ps <- getChanContents chan -- results + work <- newMVar tests -- where to take jobs from + let m = n * 64 + forM_ [1..m] $ forkIO . thread work chan -- how many threads to fork + + -- wait on i threads to close + -- logging them as they go + let wait xs i acc + | i >= m = return acc -- done + | otherwise = case xs of + Nothing : xs -> wait xs (i+1) acc + Just (s,a) : xs -> do a ; wait xs i (s : acc) + wait ps 0 [] + + where + -- thread :: MVar [Test] -> Chan (Maybe String) -> Int -> IO () + thread work chan me = loop + where + loop = do + job <- modifyMVar work $ \jobs -> return $ case jobs of + [] -> ([], Nothing) + (j:js) -> (js, Just j) + case job of + Nothing -> writeChan chan Nothing -- done + Just name -> do + v <- f name + writeChan chan . Just $ (v, printf "%d: %-25s\n" me name) + loop + + +-- | Take as input a list of package names, return an html page +-- with interesting facts about the state of the packages. +-- +report :: [String] -> IO String +report xs = do + -- load current index. + putStr "Loading package index ... " >> hFlush stdout + index <- loadPackageIndex + downloads <- loadHackageDownloads + builds <- loadBuildStatus + putStrLn "Done." + + -- collect sets of results + res_ <- parM (nub xs) $ \p -> do + handle (\s -> return (p, Nothing, (Left (show s), Left []))) $ do + k <- package p + + -- if there is a hackage path, lookup version. + -- cabal info xmonad -v0 + vers <- case k of + + (Right aur, _) | not (null (packageURL aur)) -> do + let name = takeFileName (packageURL aur) -- haskell package name + return $! M.lookup name index + _ -> return Nothing + + vers `seq` k `seq` return $! (p, vers, k) + + time <- getClockTime + + let results = sortBy (\(n,x,_) (m,y,_) -> n `compare` m) res_ + + return. showHtml $ + (header $ + (thetitle (toHtml "Arch Haskell Package Report")) +++ + (script ! [src "http://galois.com/~dons/sorttable.js"]) (toHtml "") +++ + ((thelink noHtml) ! [ rel "stylesheet" + , href "http://galois.com/~dons/arch-haskell.css" + , thetype "text/css" ])) +++ + + (body $ + center ((h2 (toHtml "Arch Haskell Package Status"))) + +++ + (table $ + (tr (td (toHtml $ "Results from " ++ show time))) + +++ + (tr (td (toHtml $ "Found " ++ show (length results) ++ " packages" ))) + ) + +++ + (scores . sortable . table $ + tr (concatHtml + [ th . categoryTag . toHtml $ "Package" + , th . categoryTag . toHtml $ "Hackage" + , th . categoryTag . toHtml $ "Version" + , th . categoryTag . toHtml $ "Latest" + , th . categoryTag . toHtml $ "cabal2arch" + , th . categoryTag . toHtml $ "Votes" + , th . categoryTag . toHtml $ "Downloads" + , th . categoryTag . toHtml $ "Description" + ]) +++ + + concatHtml + + [ + + tr $ concatHtml $ + case aur_ of + Left err -> + [ td $ (maybe id (\n -> if n then good else bad) (M.lookup p builds)) ( toHtml p ) + , td $ bad (toHtml "No AUR entry found!") + , td $ toHtml "" + , td $ toHtml "" + , td $ toHtml "" + , td $ toHtml "" + , td $ toHtml "" + , td $ toHtml "" + ] + + Right aur -> case pkg_ of + + -- Didn't find a PKGBUILD + Left err -> + [ td . toHtml $ + hotlink + (packageURLinAUR aur) + ((maybe id (\n -> if n then good else bad) + (M.lookup p builds)) (toHtml p)) + + , td . + (if null (packageURL aur) then bad else id) . toHtml $ + hotlink + (packageURL aur) + (toHtml (takeFileName (packageURL aur))) + + , td $ case packageVersion aur of + Left s -> bad $ toHtml s + Right (v,_) -> toHtml $ display v + + , td $ + + case vers of + Nothing | packageLocation aur == 3 -> toHtml "" + Nothing -> bad (toHtml "-") + Just v -> case packageVersion aur of + Left s -> toHtml (display v) + Right (v',_) | v == v' -> toHtml (display v) + | otherwise -> bad (toHtml (display v)) + + , td $ if packageLocation aur /= 3 + then bad (toHtml "Not Found") + else toHtml "" + + , td $ if packageVotes aur > 10 + then good $ toHtml $ show $ packageVotes aur + else toHtml $ show $ packageVotes aur + + , td $ case M.lookup (let n = takeFileName (packageURL aur) in if null n then packageName aur else n) downloads of + Nothing -> toHtml "" + Just n | n >= 1000 -> good (toHtml (show n)) + | otherwise -> (toHtml (show n)) + + , td $ toHtml $ packageDesc aur + ] + + -- Found everything + -- TODO parallelise this and remove redundancies + Right pkg -> + [ td . toHtml $ + hotlink + (packageURLinAUR aur) + ((maybe id (\n -> if n then good else bad) + (M.lookup p builds)) (toHtml p)) + + , td . + (if null (packageURL aur) then bad else id) . toHtml $ + hotlink + (packageURL aur) + (toHtml (takeFileName (packageURL aur))) + + , td $ + case packageVersion aur of + Left s -> bad $ toHtml s + Right (v,_) -> toHtml $ display v + + , td $ + case vers of + Nothing | packageLocation aur == 3 -> toHtml "" + Nothing -> bad (toHtml "-") + Just v -> case packageVersion aur of + Left s -> toHtml (display v) + Right (v',_) | v == v' -> toHtml (display v) + | otherwise -> bad (toHtml (display v)) + + , td $ + if oldCabal2Arch pkg + then bad . toHtml $ + case pkgBuiltWith pkg of + Nothing -> "Nothing" + Just v -> display v + + else toHtml $ + case pkgBuiltWith pkg of + Nothing -> "Nothing" + Just v -> display v + + , td $ if packageVotes aur > 10 + then good $ toHtml $ show $ packageVotes aur + else toHtml $ show $ packageVotes aur + + -- bug in computing real Haskell name. + , td $ case M.lookup (let n = takeFileName (packageURL aur) in if null n then packageName aur else n) downloads of + Nothing -> toHtml "" + Just n | n >= 1000 -> good (toHtml (show n)) + | otherwise -> (toHtml (show n)) + + , td $ toHtml $ packageDesc aur + + ] + + | (p, vers, (aur_,pkg_)) <- results + ] + ) + ) + +categoryTag x = thediv x ! [identifier "Category" ] +bad x = thediv x ! [identifier "Bad" ] +good x = thediv x ! [identifier "Best" ] +scores x = thediv x ! [identifier "Scores" ] + +sortable x = x ! [theclass "sortable"] + + +------------------------------------------------------------------------ +-- +-- Strict process reading +-- +myReadProcess :: FilePath -- ^ command to run + -> [String] -- ^ any arguments + -> String -- ^ standard input + -> IO (Either (ExitCode,String,String) String) -- ^ either the stdout, or an exitcode and any output + +myReadProcess cmd args input = C.handle (return . handler) $ do + (inh,outh,errh,pid) <- runInteractiveProcess cmd args Nothing Nothing + + output <- hGetContents outh + outMVar <- newEmptyMVar + forkIO $ (C.evaluate (length output) >> putMVar outMVar ()) + + errput <- hGetContents errh + errMVar <- newEmptyMVar + forkIO $ (C.evaluate (length errput) >> putMVar errMVar ()) + + when (not (null input)) $ hPutStr inh input + takeMVar outMVar + takeMVar errMVar + ex <- C.catch (waitForProcess pid) (\_e -> return ExitSuccess) + hClose outh + hClose inh -- done with stdin + hClose errh -- ignore stderr + + return $ case ex of + ExitSuccess -> Right output + ExitFailure _ -> Left (ex, errput, output) + + where + handler (C.ExitException e) = Left (e,"","") + handler e = Left (ExitFailure 1, show e, "") + +------------------------------------------------------------------------ +-- +-- | Load a table of packag names associated with their latest versions +-- +loadPackageIndex :: IO (M.Map String Version) +loadPackageIndex = do + v <- myReadProcess "cabal" ["list", "--simple-output"] [] + case v of + Left err -> error (show err) + Right idx -> do + + let table :: M.Map String Version + table = M.fromList -- last value is used. cabal prints in version order. + [ (name, vers) + | pkg <- lines idx + , let (name, _:vers_) = break isSpace pkg + , let vers = (case (simpleParse vers_) of + Nothing -> fromJust (simpleParse "0.0") + Just n -> n) + ] + + return $! table + + -- Data.Map String Version + -- + +------------------------------------------------------------------------ +-- +-- Todo : update +-- + +url :: String +url = "http://www.galois.com/~dons/hackage/hackage-downloads.csv" + +loadHackageDownloads :: IO (M.Map String Integer) +loadHackageDownloads = do + rsp <- simpleHTTP (getRequest url) + case rsp of + Left err -> error "Unable to get Hackage data" + Right _ -> do + idx <- getResponseBody rsp -- TODO 404 + case parseCSV "hackage.csv" idx of + Left err -> error (show err) + Right cvs -> do + let + table = M.fromList -- last value is used. cabal prints in version order. + [ (head row + ,read (last row)) + | row <- init (tail cvs) ] + return $! table + +filepath :: FilePath +filepath = ".build-all.log" + +loadBuildStatus :: IO (M.Map String Bool) +loadBuildStatus = do + s <- readFile filepath + let table = M.fromList + [ (n, read k) + | l <- lines s + , let [n, k] = words l + ] + + return $! table diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2009 Don Stewart + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/archlinux-web.cabal b/archlinux-web.cabal new file mode 100644 --- /dev/null +++ b/archlinux-web.cabal @@ -0,0 +1,150 @@ +name: archlinux-web +version: 0.1 +license: BSD3 +license-file: LICENSE +author: Don Stewart +maintainer: Don Stewart +homepage: http://code.haskell.org/~dons/code/archlinux +category: Distribution +synopsis: Website maintenance for Arch Linux packages +description: Website maintenance for Arch Linux packages + . + To get info about a package: + . + > info "xmonad" + . + To find packages matching a string: + . + > search "xmonad" + . + To find packages owned by a maintainer: + . + > maintainer "arch-haskell" + . + Generate an html page of interesting facts about + packages in AUR and Hackage. + . + > report ["xmonad"] + . + See also the cabal2arch tool + for conversion between Hackage and AUR. + +build-type: Simple +stability: stable +cabal-version: >= 1.8 + +library + build-depends: base >= 4 && < 6, + HTTP, + Cabal >= 1.6, + json, + pretty, + prettyclass, + containers, + filepath, + xhtml, + process, + directory, + parallel, + deepseq, + strict-concurrency, + old-time, + csv, + archlinux + + exposed-modules: + Distribution.ArchLinux.AUR + Distribution.ArchLinux.Report + +executable arch-report + main-is: scripts/arch-report.hs + build-depends: + base >= 4 && < 6, + HTTP, + Cabal >= 1.6, + json, + pretty, + prettyclass, + containers, + filepath, + xhtml, + process, + directory, + parallel, + deepseq, + strict-concurrency, + old-time, + csv, + archlinux + + other-modules: + Distribution.ArchLinux.Report + Distribution.ArchLinux.AUR + +executable distro-map + main-is: scripts/distro-map.hs + build-depends: + base >= 4 && < 6, + HTTP, + Cabal >= 1.6, + json, + pretty, + prettyclass, + containers, + filepath, + xhtml, + process, + directory, + parallel, + deepseq, + strict-concurrency, + old-time, + csv, + archlinux + + other-modules: + Distribution.ArchLinux.AUR + Distribution.ArchLinux.Report + +executable get-arch-url + main-is: scripts/get-arch-url.hs + build-depends: + base >= 4 && < 6, + HTTP, + Cabal >= 1.6, + json, + pretty, + prettyclass, + containers, + filepath, + process, + directory, + csv, + archlinux + + other-modules: + Distribution.ArchLinux.AUR + +executable arch-haskell-packages + main-is: scripts/mypackages.hs + build-depends: + base >= 4 && < 6, + HTTP, + Cabal >= 1.6, + json, + pretty, + prettyclass, + containers, + filepath, + process, + directory, + csv, + archlinux + + other-modules: + Distribution.ArchLinux.AUR + +executable update-aur-log + main-is: scripts/update-aur-log.hs + build-depends: + base >= 4 && < 6 diff --git a/scripts/arch-report.hs b/scripts/arch-report.hs new file mode 100644 --- /dev/null +++ b/scripts/arch-report.hs @@ -0,0 +1,24 @@ +import Distribution.ArchLinux.Report +import Distribution.ArchLinux.AUR +import Data.List + +-- $ time ./arch-report +RTS -N4 +-- compiled with -threaded. + +-- +-- Assumes the .build-all.log is in the current directory +-- To generate this file, +-- +-- > mypackages | sort > arch-haskell-packages.txt +-- + +me = "arch-haskell" + +main = do + -- s <- lines `fmap` readFile "arch-haskell-packages.txt" + packages <- maintainer me + let s = sort $ map packageName packages + + writeFile "/tmp/arch-haskell-status.html" =<< report s + putStrLn "scp /tmp/arch-haskell-status.html code.haskell.org:/srv/code/arch/" + diff --git a/scripts/distro-map.hs b/scripts/distro-map.hs new file mode 100644 --- /dev/null +++ b/scripts/distro-map.hs @@ -0,0 +1,155 @@ +import Distribution.ArchLinux.Report +import Distribution.ArchLinux.AUR +import Distribution.ArchLinux.PkgBuild + +import System.FilePath +import Control.Monad + +import Data.List +import Distribution.Text +import Distribution.Version + +import System.Directory +import Text.Printf +import Control.DeepSeq + +import GHC.Conc (numCapabilities) +import Control.Concurrent +import qualified Control.OldException as C +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Parallel.Strategies + + +{- +Generate the report of mappings of hackage to distro urls for Hackage +-} + +k = 32 + +-- Parallel work queue, similar to forM +-- +parM tests f = do + let n = numCapabilities + chan <- newChan + ps <- getChanContents chan -- results + work <- newMVar tests -- where to take jobs from + forM_ [1..n*k] $ forkIO . thread work chan -- how many threads to fork + + -- wait on i threads to close + -- logging them as they go + let wait xs i acc + | i >= (n*k) = return acc -- done + | otherwise = case xs of + Nothing : xs -> wait xs (i+1) acc + Just (s,a) : xs -> do a ; wait xs i (s : acc) + wait ps 0 [] + + where + -- thread :: MVar [Test] -> Chan (Maybe String) -> Int -> IO () + thread work chan me = loop + where + loop = do + job <- modifyMVar work $ \jobs -> return $ case jobs of + [] -> ([], Nothing) + (j:js) -> (js, Just j) + case job of + Nothing -> writeChan chan Nothing -- done + Just name -> do + v <- f name + writeChan chan . Just $ (v, printf "%d: %-25s\n" me name) + loop + +writer ch = do + v <- readChan ch + case v of + Nothing -> return () + Just s -> do appendFile "cabalArchMap.txt" s + writer ch + +me = "arch-haskell" + +main = do + C.handle (\e -> return ()) (removeFile "cabalArchMap.txt") + + -- todo: replace this with call to AUR json interface. + -- s <- lines `fmap` readFile "arch-haskell-packages.txt" + packages <- maintainer me + let s = sort $ map packageName packages + + -- just write out the ones we already know. + forM community $ \p@(name, vers, url) -> do + appendFile "cabalArchMap.txt" $ show p ++ "\n" + + -- one output writer + out <- newChan + forkIO $ writer out + + -- start with the Arch Package names, deriving the Cabal names, the + -- version, and the URL to find them. + -- + parM s $ \p -> do + k <- info p + case k of + Left err -> do putStrLn $ "Couldn't find package: " ++ show p + return () + Right aur -> do + + let name = takeFileName (packageURL aur) + vers = case packageVersion aur of + Left _ -> "" + Right (v,_) -> display v + url = packageURLinAUR aur + + -- (Agda,"2.2.4+dfsg","http://packages.debian.org/source/sid/agda") + + let s = show (name, vers, Just url) ++ "\n" + rnf s `seq` writeChan out . Just $ s + + writeChan out Nothing + + putStrLn "scp cabalArchMap.txt www.galois.com:www/" + +-- hand search: +-- +-- http://www.archlinux.org/packages/?sort=&arch=x86_64&repo=Extra&q=haskell&last_update=&limit=all +-- +community = + [ ("xmonad", "0.9.1", Just "http://www.archlinux.org/packages/community/i686/xmonad/") + + , ("packedstring", "0.1.0.1", Just "http://www.archlinux.org/packages/extra/i686/haskell-packedstring/") + , ("deepseq", "1.1.0.0", Just "http://www.archlinux.org/packages/extra/i686/haskell-deepseq/") + , ("haskell-src", "1.0.1.3", Just "http://www.archlinux.org/packages/extra/i686/haskell-haskell-src/") + , ("HUnit", "1.2.2.1", Just "http://www.archlinux.org/packages/extra/i686/haskell-hunit/") + , ("parallel", "2.2.0.1", Just "http://www.archlinux.org/packages/extra/i686/haskell-parallel/") + , ("QuickCheck", "2.1.0.3", Just "http://www.archlinux.org/packages/extra/i686/haskell-quickcheck/") + , ("stm", "2.1.1.2", Just "http://www.archlinux.org/packages/extra/i686/haskell-stm/") + , ("xhtml", "3000.2.0.1", Just "http://www.archlinux.org/packages/extra/i686/haskell-xhtml/") + , ("extensible-exceptions", "0.1.1.0", Just "http://www.archlinux.org/packages/extra/i686/haskell-extensible-exceptions/") + , ("haskeline", "0.6.2.2", Just "http://www.archlinux.org/packages/extra/i686/haskell-haskeline/") + , ("terminfo", "0.3.0.2", Just "http://www.archlinux.org/packages/extra/i686/haskell-terminfo/") + , ("mtl", "1.1.0.2", Just "http://www.archlinux.org/packages/extra/i686/haskell-mtl/") + , ("network", "2.2.1.7", Just "http://www.archlinux.org/packages/extra/i686/haskell-network/") + , ("dataenc", "0.13.0.2", Just "http://www.archlinux.org/packages/extra/i686/haskell-dataenc/") + , ("hashed-storage", "0.4.13", Just "http://www.archlinux.org/packages/extra/i686/haskell-hashed-storage/") + + , ("html", "1.0.1.2", Just "http://www.archlinux.org/packages/extra/i686/haskell-html/") + , ("mmap", "0.4.1", Just "http://www.archlinux.org/packages/extra/i686/haskell-mmap/") + , ("parsec", "3.0.1", Just "http://www.archlinux.org/packages/extra/i686/haskell-parsec/") + , ("regex-base", "0.93.1", Just "http://www.archlinux.org/packages/extra/i686/haskell-regex-base/") + , ("regex-compat", "0.92", Just "http://www.archlinux.org/packages/extra/i686/haskell-regex-compat/") + , ("regex-posix", "0.94.1", Just "http://www.archlinux.org/packages/extra/i686/haskell-regex-posix/") + , ("utf8-string","0.3.6", Just "http://www.archlinux.org/packages/extra/i686/haskell-utf8-string/") + , ("zlib", "0.5.2.0", Just "http://www.archlinux.org/packages/community/i686/haskell-zlib/") + + , ("happy" ,"1.18.4", Just "http://www.archlinux.org/packages/extra/i686/happy/") + , ("alex", "2.3.1", Just "http://www.archlinux.org/packages/community/i686/alex/") + , ("X11-xft", "0.3", Just "http://www.archlinux.org/packages/community/i686/haskell-x11-xft/") + , ("X11", "1.5.0.0", Just "http://www.archlinux.org/packages/community/i686/haskell-x11/") + , ("HTTP", "4000.0.9", Just "http://www.archlinux.org/packages/community/i686/haskell-http/") + + , ("gtk2hs", "0.10.1", Just "http://www.archlinux.org/packages/community/i686/gtk2hs/") + + , ("darcs", "2.3.1", Just "http://www.archlinux.org/packages/extra/i686/darcs/") + , ("cabal-install", "0.8.0", Just "http://www.archlinux.org/packages/community/i686/cabal-install/") + ] diff --git a/scripts/get-arch-url.hs b/scripts/get-arch-url.hs new file mode 100644 --- /dev/null +++ b/scripts/get-arch-url.hs @@ -0,0 +1,16 @@ +import Distribution.ArchLinux.AUR +import System.Environment +import System.Exit + +-- +-- given the name of a package in AUR, find the URL in AUR for that package. +-- + +main = do + [arch_name] <- getArgs + q <- info arch_name + case q of + Left err -> exitWith (ExitFailure 1) + Right v -> do + putStrLn (packageURLinAUR v) + exitSuccess diff --git a/scripts/mypackages.hs b/scripts/mypackages.hs new file mode 100644 --- /dev/null +++ b/scripts/mypackages.hs @@ -0,0 +1,12 @@ +import Distribution.ArchLinux.AUR +import Control.Monad + +-- +-- packages maintained by arch-haskell +-- + +me = "arch-haskell" + +main = do + packages <- maintainer me + forM_ packages $ putStrLn . packageName diff --git a/scripts/update-aur-log.hs b/scripts/update-aur-log.hs new file mode 100644 --- /dev/null +++ b/scripts/update-aur-log.hs @@ -0,0 +1,7 @@ +main = do + s <- getContents + let (name,desc,url) = read s + writeFile "/tmp/title" name + writeFile "/tmp/desc" desc + writeFile "/tmp/link" url +