#!/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 -- with crazy path stuff everywhere. I should clean this up. 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 import System.Environment import System.Exit import System.IO import System.Cmd import Text.Regex import Text.XHtml.Strict import Text.HMarkup -- These paths are all relative to the root of the darcs repo. docDir = "doc" 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 = 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 = [(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 [ "body { background-color: white; color: black; margin: 0; padding: 0; }", "h1, .footer { background-color:silver; color: black; margin: 0; border: 0 solid black; }", "h1 { border-bottom-width: thin; padding: 1em; }", ".footer { font-size: smaller; text-align:center; border-top-width: thin; padding: 0.25em 1em; }", ".footer span { padding: 0 0.25em; } ", "hr { display: none; }", ".section { padding: 0; margin: 0 5em; }" ] txt2html :: String -> IO Html txt2html s = do r <- markupToHtml defaultMarkupXHtmlPrefs s case r of Left err -> fail err Right h -> return h buildHaddock :: PackageDescription -> IO () buildHaddock desc = do showExceptions $ withArgs ["haddock","-v"] $ defaultMainNoRead desc rawSystem "rm" ["-rf", haddockDir] rawSystem "cp" ["-r", "dist/doc/html", haddockDir] return () systemOrFail :: String -> IO () systemOrFail cmd = do e <- system cmd case e of ExitSuccess -> return () ExitFailure i -> do hPutStrLn stderr $ "Command failed with status " ++ show i ++ ": " ++ cmd exitWith e readFileOrNull :: FilePath -> IO String readFileOrNull f = do e <- doesFileExist f if e then readFile f else do hPutStrLn stderr $ f ++ " not found, skipping" return "" match :: String -> String -> Bool match p = isJust . matchRegex (mkRegex p) distDir :: PackageDescription -> String 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 = 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 -- 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 = 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 = do system ("darcs dist --dist-name=" ++ distDir desc) createDirectoryIfMissing True downloadDir let f = downloadDir ++ "/" ++ distFile desc renameFile (distFile desc) f 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 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/"], 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 ++ "/" ++ pkgNameFromDesc desc ++ "/index.html") << "Haddock-generated API documentation"] dow = section "Download" ([h3 << "Darcs", pre << ("$ darcs get --partial " ++ show (darcsURI desc))] ++ [h3 << "Tarball", p << ("Latest release: " +++ linkFile desc (downloadDir ++ "/" ++ distFile desc) (distFile desc)), 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 | otherwise = section "Requirements" [ulist << reqs] reqs = catMaybes $ map formatReq (buildDepends desc) formatReq d@(Dependency p v) | p `elem` standardPackages = Nothing | otherwise = Just $ case lookup p knownPackages of Just (n,u) -> li << hlink u n 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]]), li << ("Configure:" +++ pre << [unlines ["$ runghc " ++ setupProg ++ " configure"]]), li << ("Build:" +++ pre << [unlines ["$ runghc " ++ setupProg ++ " build"]]), li << ("Install (as root):" +++ pre << [unlines ["# runghc " ++ setupProg ++ " install"]]) ] ] 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"] << [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 = unlines [ unwords["Redirect" , uriPath $ fileURI desc (downloadDir ++ "/" ++ latestDistFile desc), show $ fileURI desc (downloadDir ++ "/" ++ distFile desc)] ] isLibrary :: PackageDescription -> Bool isLibrary = isJust . library findSetup :: IO String findSetup = do b <- doesFileExist "Setup.hs" if b then return "Setup.hs" else do b <- doesFileExist "Setup.lhs" if b then return "Setup.lhs" else fail "No setup program found" hlink :: HTML a => String -> a -> Html hlink u b = anchor ! [href u] << b 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 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..." 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 blueprint_css_base desc setupProg readme' doap hPutStrLn stderr $ "Writing " ++ htaccessFile ++ " ..." writeFile htaccessFile $ mkHtaccess desc