-----------------------------------------------------------------------------
-- |
-- Module : cabal2doap
-- Copyright : (c) Greg Heartsfield 2009
-- License : BSD3
--
-- Generate description-of-a-project (DOAP) files from cabal packages.
-- Usage: execute in the project root, RDF-XML is generated on standard
-- output. If the project is a darcs repository, commit records
-- will be scanned and used to publish developer information.
--
-----------------------------------------------------------------------------
import Distribution.PackageDescription
(PackageDescription,SourceRepo,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 Distribution.License
(License)
import Text.XML.HXT.Arrow
import Data.Maybe (catMaybes,listToMaybe)
import Data.Either (rights)
import Data.List (nub)
import Data.Version (showVersion)
import Text.ParserCombinators.Parsec (parse)
import Text.ParserCombinators.Parsec.Rfc2822
(mailbox_list,mailbox,NameAddr,nameAddr_addr,nameAddr_name)
import System.Process (readProcessWithExitCode)
import System.Exit (ExitCode(..))
-- Common namespaces
doap_ns = "http://usefulinc.com/ns/doap#"
foaf_ns = "http://xmlns.com/foaf/0.1/"
rdf_ns = "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
------ Qualified Names we'll make use of
-- RDF QNames
rdfQ = mkQName "rdf" "RDF" rdf_ns
rdfresQ = mkQName "rdf" "resource" rdf_ns
rdfaboutQ = mkQName "rdf" "about" rdf_ns
-- DOAP QNames
projectQ = mkQName "doap" "Project" doap_ns
proj_nameQ = mkQName "doap" "name" doap_ns
shortdescQ = mkQName "doap" "shortdesc" doap_ns
descQ = mkQName "doap" "description" doap_ns
homepageQ = mkQName "doap" "homepage" doap_ns
licenseQ = mkQName "doap" "license" doap_ns
releaseQ = mkQName "doap" "release" doap_ns
versionQ = mkQName "doap" "Version" doap_ns
revisionQ = mkQName "doap" "revision" doap_ns
maintainerQ = mkQName "doap" "maintainer" doap_ns
developerQ = mkQName "doap" "developer" doap_ns
programminglangQ = mkQName "doap" "programming-language" doap_ns
repoRelQ = mkQName "doap" "repository" doap_ns
repoQ = mkQName "doap" "Repository" doap_ns
darcsRepoQ = mkQName "doap" "DarcsRepository" doap_ns
gitRepoQ = mkQName "doap" "GitRepository" doap_ns
svnRepoQ = mkQName "doap" "SVNRepository" doap_ns
cvsRepoQ = mkQName "doap" "CVSRepository" doap_ns
hgRepoQ = mkQName "doap" "HgRepository" doap_ns
bzrRepoQ = mkQName "doap" "BazaarBranch" doap_ns
archRepoQ = mkQName "doap" "ArchRepository" doap_ns
locationQ = mkQName "doap" "location" doap_ns
-- FOAF QNames
personQ = mkQName "foaf" "Person" foaf_ns
nameQ = mkQName "foaf" "name" foaf_ns
mboxQ = mkQName "foaf" "mbox" foaf_ns
-- directly map a string field to a DOAP top-level project element.
-- Empty strings result in Nothing.
simpleElement :: ArrowXml a => String -> QName -> Maybe (a XmlTree XmlTree)
simpleElement n qn = case n of
[] -> Nothing
_ -> Just (mkqelem qn [] [txt n])
-- Create homepage DOAP element, if it exists.
homepageElement :: ArrowXml a => String -> Maybe (a XmlTree XmlTree)
homepageElement h = case h of
[] -> Nothing
_ -> Just (mkqelem homepageQ [sqattr rdfresQ h] [])
-- Create release/version elements, if a Cabal version was specified.
-- release, Version, name/created/revision
versionElement :: ArrowXml a => String -> Maybe (a XmlTree XmlTree)
versionElement v =
case v of
[] -> Nothing
_ -> Just $ mkqelem releaseQ []
[mkqelem versionQ [] [mkqelem revisionQ [] [txt v]]]
-- Create maintainer elements, one for each address listed.
maintainerElements :: ArrowXml a => String -> [a XmlTree XmlTree]
maintainerElements m =
let mboxes_parsed = parse mailbox_list "maintainers" m in
case mboxes_parsed of
Left _ -> [] --Error
Right mboxes -> map (personElementFromAddr maintainerQ) mboxes
personElementFromAddr :: ArrowXml a => QName -> NameAddr -> a XmlTree XmlTree
personElementFromAddr rel na =
mkqelem rel []
[mkqelem personQ []
(mkqelem mboxQ
[sqattr rdfresQ ("mailto:" ++ nameAddr_addr na)] []
: nameElems)]
where
nameElems = case (nameAddr_name na) of
Nothing -> []
Just name -> [mkqelem nameQ [] [txt name]]
-- Need URIs for other Cabal-recognized licenses
licenseElement :: ArrowXml a => License -> Maybe (a XmlTree XmlTree)
licenseElement l =
case l of
GPL -> Just (mkqelem licenseQ
[sqattr rdfresQ "http://usefulinc.com/doap/licenses/gpl"] [])
LGPL -> Just (mkqelem licenseQ
[sqattr rdfresQ "http://usefulinc.com/doap/licenses/lgpl"] [])
BSD3 -> Just (mkqelem licenseQ
[sqattr rdfresQ "http://usefulinc.com/doap/licenses/bsd"] [])
BSD4 -> Nothing
PublicDomain -> Nothing
AllRightsReserved -> Nothing
OtherLicense -> Nothing
UnknownLicense n -> Nothing
-- Find a "HEAD" source repository, if one exists, and reference the location.
-- This only finds the first HEAD repo. TODO: find and reference all repos.
sourceRepoElement :: ArrowXml a => [SourceRepo] -> Maybe (a XmlTree XmlTree)
sourceRepoElement repos =
fmap (\r -> mkqelem repoRelQ [] [
mkqelem repoTypeQ [] [
mkqelem locationQ [sqattr rdfresQ r] []
]]) source_repo
where
head_repos = filter (\r -> repoKind r == RepoHead) repos
head_repo = listToMaybe head_repos
source_repo = head_repo >>= repoLocation
repo_type = head_repo >>= repoType
repoTypeQ = case repo_type of
Just Darcs -> darcsRepoQ
Just Git -> gitRepoQ
Just SVN -> svnRepoQ
Just CVS -> cvsRepoQ
Just Mercurial -> hgRepoQ
Just GnuArch -> archRepoQ
Just Bazaar -> bzrRepoQ
_ -> repoQ
developerElements :: ArrowXml a => [NameAddr] -> [a XmlTree XmlTree]
developerElements = map (personElementFromAddr developerQ)
doapFromPackageDesc :: ArrowXml a => PackageDescription -- ^ Cabal package
-> [NameAddr] -- ^ Developer addresses
-> a XmlTree XmlTree
doapFromPackageDesc pkg_desc developers =
mkqelem rdfQ [] [
mkqelem projectQ [sqattr rdfaboutQ (homepage pkg_desc)]
(catMaybes
[(simpleElement (nameFromPkgDesc pkg_desc) proj_nameQ),
(simpleElement (synopsis pkg_desc) shortdescQ),
(simpleElement (description pkg_desc) descQ),
(simpleElement "Haskell" programminglangQ),
(licenseElement (license pkg_desc)),
(homepageElement (homepage pkg_desc)),
(sourceRepoElement (sourceRepos pkg_desc)),
(versionElement (showVersion (packageVersion (package pkg_desc))))
] ++ maintainerElements (maintainer pkg_desc)
++ developerElements developers
)
]
nameFromPkgDesc :: PackageDescription -> String
nameFromPkgDesc pkg_desc = case (pkgName (package pkg_desc)) of
PackageName n -> n
-- Use darcs repo to get a change log (XML)
getDarcsChanges :: IO (Maybe String)
getDarcsChanges =
do (ec, out, err) <- readProcessWithExitCode "darcs" ["changes", "--xml-output"] ""
case ec of
ExitSuccess -> return (Just out)
ExitFailure _ -> return Nothing
-- The vast majority of darcs author fields look like either:
-- contrib@example.org OR
-- Contributor Name <contrib@example.org>
developersFromDarcs :: String -- ^ Darcs XML changes
-> IO [NameAddr] -- ^ list of developers
developersFromDarcs xml =
do res <- runX (readString [] xml >>>
deep (isElem >>>
hasName "patch") >>>
getAttrValue "author")
let uniq_dvlp = map (parse mailbox "developers") (nub res)
return (rights uniq_dvlp)
main = do
chg <- getDarcsChanges
dvlprs <- maybe (return []) developersFromDarcs chg
packageDescPath <- defaultPackageDesc normal
gDesc <- readPackageDescription normal packageDescPath
let desc = flattenPackageDescription gDesc
runX (root [] [doapFromPackageDesc desc dvlprs
>>> uniqueNamespacesFromDeclAndQNames
]
>>> writeDocument [(a_indent,v_1),(a_check_namespaces, v_1)] "-")
return ()