----------------------------------------------------------------------------- -- | -- 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 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 ()