-- | Code pulled out of cabal-debian that straightforwardly implements-- parts of the Debian policy manual, or other bits of Linux standards.{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}moduleDebian.Policy(-- * PathsdatabaseDirectory,apacheLogDirectory,apacheErrorLog,apacheAccessLog,serverLogDirectory,serverAppLog,serverAccessLog-- * Installed packages,debianPackageVersion,getDebhelperCompatLevel,StandardsVersion(..),getDebianStandardsVersion,parseStandardsVersion-- * Package fields,SourceFormat(..),readSourceFormat,PackagePriority(..),readPriority,PackageArchitectures(..),parsePackageArchitectures,Section(..),readSection,Area(..),parseUploaders,parseMaintainer,getDebianMaintainer,haskellMaintainer)whereimportCodec.Binary.UTF8.String(decodeString)importControl.Arrow(second)importControl.Monad(mplus)importData.Char(toLower,isSpace)importData.List(groupBy,intercalate)importData.Generics(Data,Typeable)importData.Text(Text,pack,unpack,strip)importData.Monoid((<>))importDebian.Relation(BinPkgName)importDebian.Version(DebianVersion,parseDebianVersion,version)importSystem.Environment(getEnvironment)importSystem.FilePath((</>))importSystem.Process(readProcess)importText.Parsec(parse)importText.ParserCombinators.Parsec.Rfc2822(NameAddr,address)importText.PrettyPrint.ANSI.Leijen(Pretty(pretty),text)databaseDirectory::BinPkgName->StringdatabaseDirectoryx="/srv"</>show(prettyx)apacheLogDirectory::BinPkgName->StringapacheLogDirectoryx="/var/log/apache2/"++show(prettyx)apacheErrorLog::BinPkgName->StringapacheErrorLogx=apacheLogDirectoryx</>"error.log"apacheAccessLog::BinPkgName->StringapacheAccessLogx=apacheLogDirectoryx</>"access.log"serverLogDirectory::BinPkgName->StringserverLogDirectoryx="/var/log/"++show(prettyx)serverAppLog::BinPkgName->StringserverAppLogx=serverLogDirectoryx</>"app.log"serverAccessLog::BinPkgName->StringserverAccessLogx=serverLogDirectoryx</>"access.log"debianPackageVersion::String->IODebianVersiondebianPackageVersionname=readProcess"dpkg-query"["--show","--showformat=${version}",name]"">>=return.parseDebianVersion-- | Assumes debhelper is installedgetDebhelperCompatLevel::IOIntgetDebhelperCompatLevel=debianPackageVersion"debhelper">>=return.read.takeWhile(/='.').versiondataStandardsVersion=StandardsVersionIntIntInt(MaybeInt)deriving(Eq,Ord,Show,Data,Typeable)instancePrettyStandardsVersionwherepretty(StandardsVersionabc(Justd))=text$showa<>"."<>showb<>"."<>showc<>"."<>showdpretty(StandardsVersionabcNothing)=text$showa<>"."<>showb<>"."<>showc-- | Assumes debian-policy is installedgetDebianStandardsVersion::IOStandardsVersiongetDebianStandardsVersion=debianPackageVersion"debian-policy">>=\v->return(parseStandardsVersion(versionv))parseStandardsVersion::String->StandardsVersionparseStandardsVersions=casefilter(/=".")(groupBy(\ab->(a=='.')==(b=='.'))s)of(a:b:c:d:_)->StandardsVersion(reada)(readb)(readc)(Just(readd))(a:b:c:_)->StandardsVersion(reada)(readb)(readc)Nothing_->error$"Invalid Standards-Version string: "++showsdataSourceFormat=Native3|Quilt3deriving(Eq,Ord,Show,Data,Typeable)instancePrettySourceFormatwhereprettyQuilt3=text"3.0 (quilt)\n"prettyNative3=text"3.0 (native)\n"readSourceFormat::Text->EitherTextSourceFormatreadSourceFormats=case()of_|strips=="3.0 (native)"->RightNative3_|strips=="3.0 (quilt)"->RightQuilt3_->Left$"Invalid debian/source/format: "<>pack(show(strips))dataPackagePriority=Required|Important|Standard|Optional|Extraderiving(Eq,Ord,Read,Show,Data,Typeable)readPriority::String->PackagePriorityreadPrioritys=caseunpack(strip(packs))of"required"->Required"important"->Important"standard"->Standard"optional"->Optional"extra"->Extrax->error$"Invalid priority string: "++showxinstancePrettyPackagePrioritywherepretty=text.maptoLower.show-- | The architectures for which a binary deb can be built.dataPackageArchitectures=All-- ^ The package is architecture independenct|Any-- ^ The package can be built for any architecture|Names[String]-- ^ The list of suitable architecturesderiving(Read,Eq,Ord,Show,Data,Typeable)instancePrettyPackageArchitectureswhereprettyAll=text"all"prettyAny=text"any"pretty(Namesxs)=text$intercalate" "xsparsePackageArchitectures::String->PackageArchitecturesparsePackageArchitectures"all"=AllparsePackageArchitectures"any"=AnyparsePackageArchitecturess=error$"FIXME: parsePackageArchitectures "++showsdataSection=MainSectionString-- Equivalent to AreaSection Main s?|AreaSectionAreaStringderiving(Read,Eq,Ord,Show,Data,Typeable)readSection::String->SectionreadSections=casebreak(=='/')sof("contrib",'/':b)->AreaSectionContrib(tailb)("non-free",'/':b)->AreaSectionNonFree(tailb)("main",'/':b)->AreaSectionMain(tailb)(a,'/':_)->error$"readSection - unknown area: "++showa(a,_)->MainSectionainstancePrettySectionwherepretty(MainSectionsec)=textsecpretty(AreaSectionareasec)=prettyarea<>text("/"<>sec)-- Is this really all that is allowed here? Doesn't Ubuntu have different areas?dataArea=Main|Contrib|NonFreederiving(Read,Eq,Ord,Show,Data,Typeable)instancePrettyAreawhereprettyMain=text"main"prettyContrib=text"contrib"prettyNonFree=text"non-free"{-
Create a debian maintainer field from the environment variables:
DEBFULLNAME (preferred) or NAME
DEBEMAIL (preferred) or EMAIL
More work could be done to match dch, but this is sufficient for
now. Here is what the man page for dch has to say:
If the environment variable DEBFULLNAME is set, this will be used for
the maintainer full name; if not, then NAME will be checked. If the
environment variable DEBEMAIL is set, this will be used for the email
address. If this variable has the form "name <email>", then the
maintainer name will also be taken from here if neither DEBFULLNAME
nor NAME is set. If this variable is not set, the same test is
performed on the environment variable EMAIL. Next, if the full name
has still not been determined, then use getpwuid(3) to determine the
name from the pass‐word file. If this fails, use the previous
changelog entry. For the email address, if it has not been set from
DEBEMAIL or EMAIL, then look in /etc/mailname, then attempt to build
it from the username and FQDN, otherwise use the email address in the
previous changelog entry. In other words, it’s a good idea to set
DEBEMAIL and DEBFULLNAME when using this script.
-}getDebianMaintainer::IO(MaybeNameAddr)getDebianMaintainer=doenv<-map(seconddecodeString)`fmap`getEnvironmentreturn$dofullname<-lookup"DEBFULLNAME"env`mplus`lookup"NAME"envemail<-lookup"DEBEMAIL"env`mplus`lookup"EMAIL"enveither(constNothing)Just(parseMaintainer(fullname++" <"++email++">"))haskellMaintainer::NameAddrhaskellMaintainer=eithererrorid(parseMaintainer"Debian Haskell Group <pkg-haskell-maintainers@lists.alioth.debian.org>")parseUploaders::String->EitherString[NameAddr]parseUploadersx=either(Left.show)Right(parseaddress""("Names: "++mapfixWhitex++";"))-- either (\ e -> error ("Failure parsing uploader list: " ++ show x ++ " -> " ++ show e)) id $ wherefixWhitec=ifisSpacecthen' 'elsecparseMaintainer::String->EitherStringNameAddrparseMaintainerx=caseparseUploadersxofLefts->LeftsRight[y]->RightyRight[]->Left$"Missing maintainer: "++showxRightys->Left$"Too many maintainers: "++showys