diff --git a/hask-home.cabal b/hask-home.cabal --- a/hask-home.cabal +++ b/hask-home.cabal @@ -1,30 +1,26 @@ Name: hask-home -Version: 2007.12.6 -Cabal-version: >= 1.2 +Version: 2009.3.18 +Cabal-version: >= 1.6 Build-type: Simple Copyright: Bjorn Bringert 2006 -Maintainer: bjorn@bringert.net +Maintainer: Greg Heartsfield Author: Bjorn Bringert -Homepage: http://www.cs.chalmers.se/~bringert/darcs/hask-home/doc/ +Homepage: http://gregheartsfield.com/hask-home License: BSD3 Synopsis: Generate homepages for cabal packages Description: This program generates simple homepages for cabalized Haskell packages. -Flag split-base +source-repository head + type: darcs + location: http://gregheartsfield.com/repos/hask-home/ Executable hask-home Main-Is: hask-home.hs - Build-depends: Cabal >= 1.2, regex-compat, network, hmarkup >= 3000.0.1, xhtml >= 3000.0.2.1 - if flag(split-base) - Build-depends: base >= 3.0, process, directory - else - Build-depends: base < 3.0 + Build-depends: Cabal >= 1.6, regex-compat, network, hmarkup >= 3000.0.1, xhtml >= 3000.0.2.1 + Build-depends: base >= 4.0, process, directory, hsemail, parsec Executable hask-home-upload Main-Is: hask-home-upload.hs - if flag(split-base) - Build-depends: base >= 3.0, process - else - Build-depends: base < 3.0 + Build-depends: base >= 4.0, process diff --git a/hask-home.hs b/hask-home.hs --- a/hask-home.hs +++ b/hask-home.hs @@ -1,18 +1,32 @@ #!/usr/bin/env runghc +{-# LANGUAGE ScopedTypeVariables #-} -- Generate a homepage for a darcsized cabalized Haskell package. --- NOTE: this is very hack, making lots of assumptions and +-- NOTE: this is very hack, making lots of assumptions and -- with crazy path stuff everywhere. I should clean this up. -import Control.Exception +import qualified Control.Exception as C import Control.Monad import Data.Char import Data.List import Data.Maybe import Distribution.PackageDescription + (PackageDescription,RepoKind(RepoHead),RepoType(..),repoLocation,repoKind, + repoType,package,homepage,synopsis,buildDepends,maintainer,licenseFile, + license,library,description,sourceRepos) +import Distribution.PackageDescription.Configuration + (flattenPackageDescription) +import Distribution.PackageDescription.Parse + (readPackageDescription) import Distribution.Simple import Distribution.Simple.Utils + (defaultPackageDesc) import Distribution.Verbosity + (normal) +import Data.Version (showVersion) +import Text.ParserCombinators.Parsec (parse) +import Text.ParserCombinators.Parsec.Rfc2822 + (mailbox,NameAddr,nameAddr_addr,nameAddr_name) import Network.URI import Prelude hiding (catch) import System.Directory @@ -21,7 +35,7 @@ import System.IO import System.Cmd import Text.Regex -import Text.XHtml +import Text.XHtml.Strict import Text.HMarkup @@ -31,28 +45,29 @@ downloadDir = "download" haddockDir = docDir ++ "/" ++ "api" indexFile = docDir ++ "/" ++ "index.html" +doapFile = docDir ++ "/" ++ "doap.rdf" htaccessFile = downloadDir ++ "/" ++ ".htaccess" -- packages that we don't need to list as requirements - -standardPackages = ["base","stm","mtl","fgl","QuickCheck", - "Cabal","network","readline","unix","parsec", - "haskell98","posix","html"] +standardPackages = map (\x -> PackageName x) + ["base","stm","mtl","fgl","QuickCheck", + "Cabal","network","readline","unix","parsec","haskell98", + "posix","html","random","old-time","regex-compat"] -- Packages whose homepages we know - -knownPackages = [("fps",("FastPackedString","http://www.cse.unsw.edu.au/~dons/fps.html")), - ("Crypto",("The Haskell Cryptographic Library","http://haskell.org/crypto/")), - ("HTTP",("The Haskell HTTP package","http://haskell.org/http/")), - ("XmlRpc",("HaXR - the Haskell XML-RPC library","http://haskell.org/haxr/")), - ("xhtml",("Text.XHtml","http://www.cs.chalmers.se/~bringert/darcs/haskell-xhtml/doc/")), - ("cgi-compat",("cgi-compat","http://www.cs.chalmers.se/~bringert/darcs/cgi-compat/doc/")), - ("haskelldb",("HaskellDB","http://haskelldb.sourceforge.net/")), - ("parsedate",("parsedate","http://www.cs.chalmers.se/~bringert/darcs/parsedate/doc/")), - ("hmarkup",("hmarkup","http://www.cs.chalmers.se/~bringert/darcs/hmarkup/doc/")) +knownPackages = [(PackageName "fps",("FastPackedString","http://www.cse.unsw.edu.au/~dons/fps.html")), + (PackageName "Crypto",("The Haskell Cryptographic Library","http://haskell.org/crypto/")), + (PackageName "HTTP",("The Haskell HTTP package","http://haskell.org/http/")), + (PackageName "XmlRpc",("HaXR - the Haskell XML-RPC library","http://haskell.org/haxr/")), + (PackageName "xhtml",("Text.XHtml","http://www.cs.chalmers.se/~bringert/darcs/haskell-xhtml/doc/")), + (PackageName "cgi-compat",("cgi-compat","http://www.cs.chalmers.se/~bringert/darcs/cgi-compat/doc/")), + (PackageName "haskelldb",("HaskellDB","http://haskelldb.sourceforge.net/")), + (PackageName "parsedate",("parsedate","http://www.cs.chalmers.se/~bringert/darcs/parsedate/doc/")), + (PackageName "hmarkup",("hmarkup","http://www.cs.chalmers.se/~bringert/darcs/hmarkup/doc/")), + (PackageName "hxt",("Haskell XML Toolbox","http://www.fh-wedel.de/~si/HXmlToolbox/index.html")) ] -stylesheet = unlines $ +stylesheet = unlines [ "body { background-color: white; color: black; margin: 0; padding: 0; }", "h1, .footer { background-color:silver; color: black; margin: 0; border: 0 solid black; }", @@ -63,14 +78,14 @@ ".section { padding: 0; margin: 0 5em; }" ] -txt2html :: String -> IO String +txt2html :: String -> IO Html txt2html s = do r <- markupToHtml defaultMarkupXHtmlPrefs s case r of Left err -> fail err - Right h -> return $ renderHtml h + Right h -> return h buildHaddock :: PackageDescription -> IO () -buildHaddock desc = +buildHaddock desc = do showExceptions $ withArgs ["haddock","-v"] $ defaultMainNoRead desc rawSystem "rm" ["-rf", haddockDir] @@ -78,10 +93,10 @@ return () systemOrFail :: String -> IO () -systemOrFail cmd = +systemOrFail cmd = do e <- system cmd - case e of + case e of ExitSuccess -> return () ExitFailure i -> do hPutStrLn stderr $ "Command failed with status " ++ show i ++ ": " ++ cmd @@ -90,64 +105,136 @@ readFileOrNull :: FilePath -> IO String readFileOrNull f = do e <- doesFileExist f - if e then readFile f + if e then readFile f else do hPutStrLn stderr $ f ++ " not found, skipping" return "" match :: String -> String -> Bool -match p s = isJust $ matchRegex (mkRegex p) s +match p = isJust . matchRegex (mkRegex p) distDir :: PackageDescription -> String -distDir desc = showPackageId (package desc) +distDir desc = name ++ "-" ++ version where + name = pkgNameFromDesc desc + version = showVersion (pkgVersion (packageId desc)) +getPkgNameStr :: PackageName -> String +getPkgNameStr desc = case desc of + PackageName x -> x + distFile :: PackageDescription -> String distFile desc = distDir desc ++ ".tar.gz" latestDistFile :: PackageDescription -> String -latestDistFile desc = pkgName (package desc) ++ "-latest.tar.gz" +latestDistFile desc = pkgNameFromDesc desc ++ "-latest.tar.gz" +pkgNameFromDesc :: PackageDescription -> String +pkgNameFromDesc desc = case (pkgName (package desc)) of + PackageName name -> name + fileURI :: PackageDescription -> String -> URI fileURI desc f = fromJust $ (nullURI { uriPath = f }) `relativeTo` darcsURI desc linkFile :: HTML a => PackageDescription -> String -> a -> Html linkFile desc f x = hlink (show $ fileURI desc f `relativeFrom` homepageURI desc) << x --- FIXME: gigantic hack +-- Uses source-repository sections to try and find a Darcs repo. +-- This is a darcs-centric tool, but it would be nice to handle the +-- other (hg,git,etc.) repository types that are possible. +-- Falls back on darcsURI_hack when source-repository is missing. darcsURI :: PackageDescription -> URI -darcsURI desc = home { uriPath = reverse $ drop (length docDir) $ dropWhile (=='/') $ reverse $ uriPath home } +darcsURI desc = fromMaybe (darcsURI_hack desc) source_repo where + all_repos = sourceRepos desc + darcs_head_repos = filter (\r -> repoType r == Just Darcs && + repoKind r == RepoHead) all_repos + source_repo = do repo <- listToMaybe darcs_head_repos + repo_l <- repoLocation repo + parseURI repo_l + +darcsURI_hack :: PackageDescription -> URI +darcsURI_hack desc = home { uriPath = reverse $ drop (length docDir) $ dropWhile (=='/') $ reverse $ uriPath home } where home = homepageURI desc homepageURI :: PackageDescription -> URI homepageURI desc = fromMaybe (error $ "Package homepage is not a valid URI: " ++ homepage desc) $ parseURI $ homepage desc +-- Create DOAP file using 'cabal2doap' program if available. +-- Return path to DOAP, if successful. +mkDoap :: IO (Maybe String) +mkDoap = do ec <- system ("cabal2doap > " ++ doapFile) + return $ case ec of + ExitSuccess -> Just doapFile + _ -> Nothing + mkTarball :: PackageDescription -> IO () -mkTarball desc = +mkTarball desc = do system ("darcs dist --dist-name=" ++ distDir desc) createDirectoryIfMissing True downloadDir let f = downloadDir ++ "/" ++ distFile desc renameFile (distFile desc) f -makeIndex :: PackageDescription -> String -> String -> Html -makeIndex desc setupProg readme = (header << hdr) +++ (body << bdy) +makeIndex :: Maybe String -- ^ Blueprint base CSS URL (relative or absolute, with trailing slash) + -> PackageDescription + -> String -- ^ Name of Setup program (Setup.hs/Setup.lhs) + -> Html -- ^ README rendered as HTML + -> Maybe String -- ^ DOAP file location, if one was generated + -> Html +makeIndex blueprint desc setupProg readme doap = (header << hdr) +++ (body << bdy) where - hdr = [thetitle << t, + style_elems = + case blueprint of + Nothing -> [style ! [thetype "text/css"] << stylesheet] + Just css_base -> [thelink ! [rel "stylesheet", + href (css_base ++ "screen.css"), + thetype "text/css", + strAttr "media" "screen, projection"] << noHtml, + thelink ! [rel "stylesheet", + href (css_base ++ "print.css"), + thetype "text/css", + strAttr "media" "print"] << noHtml, + primHtml "", + thelink ! [rel "stylesheet", + href (css_base ++ "plugins/fancy-type/screen.css"), + thetype "text/css", + strAttr "media" "screen, projection"] << noHtml + ] + doap_elems = case doap of + Just doap_loc -> [thelink ! [rel "meta", + thetype "application/rdf+xml", + title "doap", + href (uriPath (fileURI desc doap_loc))] + << noHtml] + Nothing -> [] + hdr = [thetitle << t, meta ! [name "generator", content "hask-home, http://www.cs.chalmers.se/~bringert/darcs/hask-home/doc/"], - style ! [thetype "text/css"] << stylesheet - ] - t = pkgName (package desc) ++ " - " ++ synopsis desc - bdy = [h1 << t, des, api, dow, req, ins, mai, lic, foo] - des = section "Description" [primHtml readme] + meta ! [httpequiv "content-type", content "text/html; charset=UTF-8"] + ] ++ style_elems ++ doap_elems + t = pkgNameFromDesc desc ++ " - " ++ synopsis desc + title_block = case blueprint of + Nothing -> [h1 << t] + _ -> [thediv ! [theclass "span-22"] + << [h1 << pkgNameFromDesc desc, h1 ! [theclass "alt"] + << synopsis desc], + hr] + bdy = [thediv ! [theclass "prepend-1"] + << [thediv ! [theclass "container"] + << [title_block ++ [des, api, dow, req, ins, mai, lic, foo]]]] + des = section "Description" [readme] api | not (isLibrary desc) = noHtml - | otherwise = section "API Documentation" - [p << linkFile desc (haddockDir ++ "/" ++ "index.html") + | otherwise = section "API Documentation" + [p << linkFile desc (haddockDir ++ "/" ++ pkgNameFromDesc desc ++ "/index.html") << "Haddock-generated API documentation"] - dow = section "Download" + dow = section "Download" ([h3 << "Darcs", pre << ("$ darcs get --partial " ++ show (darcsURI desc))] ++ [h3 << "Tarball", - p << ("Latest release: " + p << ("Latest release: " +++ linkFile desc (downloadDir ++ "/" ++ distFile desc) (distFile desc)), - p << ("You can also use " + p << ("You can also use " +++ linkFile desc (downloadDir ++ "/" ++ latestDistFile desc) (latestDistFile desc) +++ " which should always redirect you to the latest release tarball.")]) req | null reqs = noHtml @@ -157,8 +244,8 @@ | p `elem` standardPackages = Nothing | otherwise = Just $ case lookup p knownPackages of Just (n,u) -> li << hlink u n - Nothing -> li << p - ins = section "Installation" + Nothing -> li << getPkgNameStr p + ins = section "Installation" [olist << [li << ("Unpack the sources and enter the source directory:" +++ pre << [unlines ["$ tar -zxf " ++ distFile desc, "$ cd " ++ distDir desc]]), @@ -166,31 +253,41 @@ +++ pre << [unlines ["$ runghc " ++ setupProg ++ " configure"]]), li << ("Build:" +++ pre << [unlines ["$ runghc " ++ setupProg ++ " build"]]), - if isLibrary desc then - li << ("Install (as root):" + li << ("Install (as root):" +++ pre << [unlines ["# runghc " ++ setupProg ++ " install"]]) - else noHtml ] ] - mai = section "Maintainer" [p << maintainer desc] - lic | null (licenseFile desc) = section "License" [p << show (license desc)] - | otherwise = section "License" - [p << ("See " - +++ (linkFile desc (licenseFile desc) << licenseFile desc) - +++ ".")] - validXHtml = thespan << hlink "http://validator.w3.org/check?uri=referer" "Validate XHTML" - validCSS = thespan << hlink "http://jigsaw.w3.org/css-validator/check/referer" "Validate CSS" - generator = thespan << ("Page generated by " + mai = section "Maintainer" [maintainerToHtml (maintainer desc)] + lic = section "License" + [p << (show (license desc) +++ + case (licenseFile desc) of + "" -> noHtml + path -> ", see " +++ (linkFile desc path << path) +++ ".") + ] + validXHtml = thespan << hlink "http://validator.w3.org/check?uri=referer" "Validate XHTML" + validCSS = thespan << hlink "http://jigsaw.w3.org/css-validator/check/referer" "Validate CSS" + generator = thespan << ("Page generated by " +++ hlink "http://www.cs.chalmers.se/~bringert/darcs/hask-home/doc/" "hask-home") - foo = thediv ! [theclass "footer"] + foo = thediv ! [theclass "footer"] << [hr, p << [generator +++ " " +++ validXHtml +++ " " +++ validCSS]] section h xs = thediv ! [theclass "section"] << ((h2 << [h]):xs) +maintainerToHtml :: String -> Html +maintainerToHtml m = + let addrp = parse mailbox "maintainer" m + in case addrp of + Left _ -> p << m -- parse error + Right name_addr -> p << hlink ("mailto:"++addr) linktext where + addr = nameAddr_addr name_addr + linktext = case (nameAddr_name name_addr) of + Nothing -> addr + Just name -> name + mkHtaccess :: PackageDescription -> String -mkHtaccess desc = +mkHtaccess desc = unlines [ - unwords["Redirect" , - uriPath $ fileURI desc (downloadDir ++ "/" ++ latestDistFile desc), + unwords["Redirect" , + uriPath $ fileURI desc (downloadDir ++ "/" ++ latestDistFile desc), show $ fileURI desc (downloadDir ++ "/" ++ distFile desc)] ] @@ -209,22 +306,32 @@ hlink :: HTML a => String -> a -> Html hlink u b = anchor ! [href u] << b -showExceptions a = catch a (\e -> print e >> throw e) +showExceptions :: IO a -> IO a +showExceptions a = a `C.catches` + [C.Handler (\(e::ExitCode) -> (print e >> C.throw e)), + C.Handler (\(e::IOError) -> (print e >> C.throw e))] main = do - packageDesc <- defaultPackageDesc normal - gDesc <- readPackageDescription normal packageDesc + args <- getArgs + let blueprint_css_base = case args of + ["--blueprint", css_base] -> Just css_base + _ -> Nothing + packageDescPath <- defaultPackageDesc normal + gDesc <- readPackageDescription normal packageDescPath let desc = flattenPackageDescription gDesc hPutStrLn stderr $ "Creating " ++ docDir ++ " ..." createDirectoryIfMissing True docDir setupProg <- findSetup - when (isLibrary desc) $ do hPutStrLn stderr $ "Building API documentation..." + when (isLibrary desc) $ do hPutStrLn stderr "Building API documentation..." buildHaddock desc hPutStrLn stderr $ "Building tarball " ++ distFile desc ++ " ..." mkTarball desc + hPutStrLn stderr $ "Building DOAP RDF: " ++ doapFile ++ " ..." + doap <- mkDoap readme <- readFileOrNull "README" readme' <- txt2html $ if null readme then description desc else readme hPutStrLn stderr $ "Writing " ++ indexFile ++ " ..." - writeFile indexFile $ renderHtml $ makeIndex desc setupProg readme' + writeFile indexFile $ renderHtml $ + makeIndex blueprint_css_base desc setupProg readme' doap hPutStrLn stderr $ "Writing " ++ htaccessFile ++ " ..." writeFile htaccessFile $ mkHtaccess desc