hask-home-2007.12.6: hask-home.hs

#!/usr/bin/env runghc

-- 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 Control.Exception
import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import Distribution.PackageDescription
import Distribution.Simple
import Distribution.Simple.Utils
import Distribution.Verbosity
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

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"
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"]

-- 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/"))
                ]

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 String
txt2html s = do r <- markupToHtml defaultMarkupXHtmlPrefs s
                case r of
                  Left err -> fail err
                  Right h  -> return $ renderHtml 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 s = isJust $ matchRegex (mkRegex p) s

distDir :: PackageDescription -> String
distDir desc = showPackageId (package desc)

distFile :: PackageDescription -> String
distFile desc = distDir desc ++ ".tar.gz"

latestDistFile :: PackageDescription -> String
latestDistFile desc = pkgName (package desc) ++ "-latest.tar.gz"

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
darcsURI :: PackageDescription -> URI
darcsURI 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

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 :: PackageDescription -> String -> String -> Html
makeIndex desc setupProg readme = (header << hdr) +++ (body << bdy)
  where
  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]
  api | not (isLibrary desc) = noHtml
      | otherwise = section "API Documentation" 
                      [p << linkFile desc (haddockDir ++ "/" ++ "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 << 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"]]),
                             if isLibrary desc then
                                 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 " 
              +++ 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)

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 a = catch a (\e -> print e >> throw e)

main = do
       packageDesc <- defaultPackageDesc normal
       gDesc <- readPackageDescription normal packageDesc
       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
       readme <- readFileOrNull "README"
       readme' <- txt2html $ if null readme then description desc else readme
       hPutStrLn stderr $ "Writing " ++ indexFile ++ " ..."
       writeFile indexFile $ renderHtml $ makeIndex desc setupProg readme'
       hPutStrLn stderr $ "Writing " ++ htaccessFile ++ " ..."
       writeFile htaccessFile $ mkHtaccess desc