hask-home 2007.12.6 → 2009.3.18
raw patch · 2 files changed
+183/−80 lines, 2 filesdep +hsemaildep +parsecdep ~Cabaldep ~basenew-uploader
Dependencies added: hsemail, parsec
Dependency ranges changed: Cabal, base
Files
- hask-home.cabal +10/−14
- hask-home.hs +173/−66
hask-home.cabal view
@@ -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 <scsibug@imap.cc> 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
hask-home.hs view
@@ -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 "<!--[if IE]>",+ thelink ! [rel "stylesheet",+ href (css_base ++ "ie.css"),+ thetype "text/css",+ strAttr "media" "screen, projection"] << noHtml,+ primHtml "<![endif]-->",+ 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