{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, OverloadedStrings #-}
module Debian.Policy
(
databaseDirectory
, dataDirectory
, apacheLogDirectory
, apacheErrorLog
, apacheAccessLog
, serverLogDirectory
, serverAppLog
, serverAccessLog
, errorLogBaseName
, appLogBaseName
, accessLogBaseName
, debianPackageVersion
, getDebhelperCompatLevel
, StandardsVersion(..)
, getDebianStandardsVersion
, parseStandardsVersion
, SourceFormat(..)
, readSourceFormat
, PackagePriority(..)
, readPriority
, PackageArchitectures(..)
, parsePackageArchitectures
, Section(..)
, readSection
, MultiArch(..)
, readMultiArch
, Area(..)
, parseUploaders
, parseMaintainer
, maintainerOfLastResort
, getCurrentDebianUser
, haskellMaintainer
, License(..)
, fromCabalLicense
, toCabalLicense
, readLicense
) where
import Codec.Binary.UTF8.String (decodeString)
import Control.Arrow (second)
import Control.Monad (mplus)
import Data.Char (isSpace, toLower)
import Data.Generics (Data, Typeable)
import Data.List (groupBy, intercalate)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid ((<>))
import Data.Text (pack, strip, Text, unpack)
import Debian.Debianize.Prelude (read')
import Debian.Pretty (PP(..))
import Debian.Relation (BinPkgName)
import Debian.Version (DebianVersion, parseDebianVersion', version)
import qualified Distribution.License as Cabal (License(..))
import Distribution.Package (PackageIdentifier(pkgName))
import Distribution.PackageDescription (PackageDescription(package))
import Distribution.Text (display)
import System.Environment (getEnvironment)
import System.FilePath ((</>))
import System.Process (readProcess)
import Text.Parsec (parse)
import Text.Parsec.Rfc2822 (address, NameAddr(..))
import Text.PrettyPrint.HughesPJClass (text)
import Distribution.Pretty (Pretty(pretty))
import Text.Read (readMaybe)
databaseDirectory :: BinPkgName -> String
databaseDirectory x = "/srv" </> show (pretty . PP $ x)
dataDirectory :: PackageDescription -> String
dataDirectory pkgDesc = "/usr/share" </> showPkgName (pkgName (package pkgDesc))
where
showPkgName = map fixchar . display
fixchar '-' = '_'
fixchar c = c
apacheLogDirectory :: BinPkgName -> String
apacheLogDirectory x = "/var/log/apache2/" ++ show (pretty . PP $ x)
apacheErrorLog :: BinPkgName -> String
apacheErrorLog x = apacheLogDirectory x </> errorLogBaseName
apacheAccessLog :: BinPkgName -> String
apacheAccessLog x = apacheLogDirectory x </> accessLogBaseName
serverLogDirectory :: BinPkgName -> String
serverLogDirectory x = "/var/log/" ++ show (pretty . PP $ x)
serverAppLog :: BinPkgName -> String
serverAppLog x = serverLogDirectory x </> appLogBaseName
serverAccessLog :: BinPkgName -> String
serverAccessLog x = serverLogDirectory x </> accessLogBaseName
appLogBaseName :: String
appLogBaseName = "app.log"
errorLogBaseName :: String
errorLogBaseName = "error.log"
accessLogBaseName :: String
accessLogBaseName = "access.log"
debianPackageVersion :: String -> IO (Maybe DebianVersion)
debianPackageVersion name =
readProcess "dpkg-query" ["--show", "--showformat=${version}", name] "" >>=
return . parseDebianVersion''
where
parseDebianVersion'' "" = Nothing
parseDebianVersion'' s = Just (parseDebianVersion' s)
getDebhelperCompatLevel :: IO (Maybe Int)
getDebhelperCompatLevel = return (Just 10)
data StandardsVersion = StandardsVersion Int Int Int (Maybe Int) deriving (Eq, Ord, Show, Data, Typeable)
instance Pretty (PP StandardsVersion) where
pretty (PP (StandardsVersion a b c (Just d))) = text (show a) <> text "." <> text (show b) <> text "." <> text (show c) <> text "." <> text (show d)
pretty (PP (StandardsVersion a b c Nothing)) = text (show a) <> text "." <> text (show b) <> text "." <> text (show c)
getDebianStandardsVersion :: IO (Maybe StandardsVersion)
getDebianStandardsVersion = debianPackageVersion "debian-policy" >>= return . fmap (parseStandardsVersion . version)
parseStandardsVersion :: String -> StandardsVersion
parseStandardsVersion s =
case filter (/= ".") (groupBy (\ a b -> (a == '.') == (b == '.')) s) of
(a : b : c : d : _) -> StandardsVersion (read' (error . ("StandardsVersion" ++) . show) a)
(read' (error . ("StandardsVersion" ++) . show) b)
(read' (error . ("StandardsVersion" ++) . show) c)
(Just (read' (error . ("StandardsVersion" ++) . show) d))
(a : b : c : _) -> StandardsVersion (read' (error . ("StandardsVersion" ++) . show) a)
(read' (error . ("StandardsVersion" ++) . show) b)
(read' (error . ("StandardsVersion" ++) . show) c) Nothing
_ -> error $ "Invalid Standards-Version string: " ++ show s
data SourceFormat
= Native3
| Quilt3
deriving (Eq, Ord, Show, Data, Typeable)
instance Pretty (PP SourceFormat) where
pretty (PP Quilt3) = text "3.0 (quilt)\n"
pretty (PP Native3) = text "3.0 (native)\n"
readSourceFormat :: Text -> Either Text SourceFormat
readSourceFormat s =
case () of
_ | strip s == "3.0 (native)" -> Right Native3
_ | strip s == "3.0 (quilt)" -> Right Quilt3
_ -> Left $ "Invalid debian/source/format: " <> pack (show (strip s))
data PackagePriority
= Required
| Important
| Standard
| Optional
| Extra
deriving (Eq, Ord, Read, Show, Data, Typeable)
readPriority :: String -> PackagePriority
readPriority s =
case unpack (strip (pack s)) of
"required" -> Required
"important" -> Important
"standard" -> Standard
"optional" -> Optional
"extra" -> Extra
x -> error $ "Invalid priority string: " ++ show x
instance Pretty (PP PackagePriority) where
pretty = text . map toLower . show . unPP
data PackageArchitectures
= All
| Any
| Names [String]
deriving (Read, Eq, Ord, Show, Data, Typeable)
instance Pretty (PP PackageArchitectures) where
pretty (PP All) = text "all"
pretty (PP Any) = text "any"
pretty (PP (Names xs)) = text $ intercalate " " xs
parsePackageArchitectures :: String -> PackageArchitectures
parsePackageArchitectures "all" = All
parsePackageArchitectures "any" = Any
parsePackageArchitectures s = error $ "FIXME: parsePackageArchitectures " ++ show s
data Section
= MainSection String
| AreaSection Area String
deriving (Read, Eq, Ord, Show, Data, Typeable)
readSection :: String -> Section
readSection s =
case break (== '/') s of
("contrib", '/' : b) -> AreaSection Contrib (tail b)
("non-free", '/' : b) -> AreaSection NonFree (tail b)
("main", '/' : b) -> AreaSection Main (tail b)
(a, '/' : _) -> error $ "readSection - unknown area: " ++ show a
(a, _) -> MainSection a
instance Pretty (PP Section) where
pretty (PP (MainSection sec)) = text sec
pretty (PP (AreaSection area sec)) = pretty (PP area) <> text "/" <> text sec
data MultiArch = MANo | MASame | MAForeign | MAAllowed
deriving (Read, Eq, Ord, Show, Data, Typeable)
readMultiArch :: String -> MultiArch
readMultiArch s =
case unpack (strip (pack s)) of
"no" -> MANo
"same" -> MASame
"foreign" -> MAForeign
"allowed" -> MAAllowed
x -> error $ "Invalid Multi-Arch string: " ++ show x
instance Pretty (PP MultiArch) where
pretty (PP MANo) = text "no"
pretty (PP MASame) = text "same"
pretty (PP MAForeign) = text "foreign"
pretty (PP MAAllowed) = text "allowed"
data Area
= Main
| Contrib
| NonFree
deriving (Read, Eq, Ord, Show, Data, Typeable)
instance Pretty (PP Area) where
pretty (PP Main) = text "main"
pretty (PP Contrib) = text "contrib"
pretty (PP NonFree) = text "non-free"
getCurrentDebianUser :: IO (Maybe NameAddr)
getCurrentDebianUser =
do env <- map (second decodeString) `fmap` getEnvironment
return $ do fullname <- lookup "DEBFULLNAME" env `mplus` lookup "NAME" env
email <- lookup "DEBEMAIL" env `mplus` lookup "EMAIL" env
either (const Nothing) Just (parseMaintainer (fullname ++ " <" ++ email ++ ">"))
haskellMaintainer :: NameAddr
haskellMaintainer =
NameAddr { nameAddr_name = Just "Debian Haskell Group"
, nameAddr_addr = "pkg-haskell-maintainers@lists.alioth.debian.org"}
parseUploaders :: String -> Either String [NameAddr]
parseUploaders x =
either (Left . show) fixNameAddrs (parse address "" ("Names: " ++ map fixWhite x ++ ";"))
where
fixWhite c = if isSpace c then ' ' else c
fixNameAddrs :: [NameAddr] -> Either String [NameAddr]
fixNameAddrs xs = case mapMaybe fixNameAddr xs of
[] -> Left ("No valid debian maintainers in " ++ show x)
xs' -> Right xs'
fixNameAddr :: NameAddr -> Maybe NameAddr
fixNameAddr y =
case nameAddr_name y of
Nothing -> Nothing
_ -> Just y
parseMaintainer :: String -> Either String NameAddr
parseMaintainer x =
case parseUploaders x of
Left s -> Left s
Right [y] -> Right y
Right [] -> Left $ "Missing maintainer: " ++ show x
Right ys -> Left $ "Too many maintainers: " ++ show ys
maintainerOfLastResort :: NameAddr
Right maintainerOfLastResort = parseMaintainer "nobody <nobody@nowhere>"
data License
= Public_Domain
| Apache
| Artistic
| BSD_2_Clause
| BSD_3_Clause
| BSD_4_Clause
| ISC
| CC_BY
| CC_BY_SA
| CC_BY_ND
| CC_BY_NC
| CC_BY_NC_SA
| CC_BY_NC_ND
| CC0
| CDDL
| CPL
| EFL
| Expat
| GPL
| LGPL
| GFDL
| GFDL_NIV
| LPPL
| MPL
| Perl
| Python
| QPL
| W3C
| Zlib
| Zope
| OtherLicense String
deriving (Read, Show, Eq, Ord, Data, Typeable)
instance Pretty License where
pretty Public_Domain = text "public-domain"
pretty Apache = text "Apache"
pretty Artistic = text "Artistic"
pretty BSD_2_Clause = text "BSD-2-clause"
pretty BSD_3_Clause = text "BSD-3-clause"
pretty BSD_4_Clause = text "BSD-4-clause"
pretty ISC = text "ISC"
pretty CC_BY = text "CC-BY"
pretty CC_BY_SA = text "CC-BY-SA"
pretty CC_BY_ND = text "CC-BY-ND"
pretty CC_BY_NC = text "CC-BY-NC"
pretty CC_BY_NC_SA = text "CC-BY-NC-SA"
pretty CC_BY_NC_ND = text "CC-BY-NC-ND"
pretty CC0 = text "CC0"
pretty CDDL = text "CDDL"
pretty CPL = text "CPL"
pretty EFL = text "EFL"
pretty Expat = text "Expat"
pretty GPL = text "GPL"
pretty LGPL = text "LGPL"
pretty GFDL = text "GFDL"
pretty GFDL_NIV = text "GFDL-NIV"
pretty LPPL = text "LPPL"
pretty MPL = text "MPL"
pretty Perl = text "Perl"
pretty Python = text "Python"
pretty QPL = text "QPL"
pretty W3C = text "W3C"
pretty Zlib = text "Zlib"
pretty Zope = text "Zope"
pretty (OtherLicense s) = text s
fromCabalLicense :: Cabal.License -> License
fromCabalLicense x =
case x of
Cabal.GPL _ -> GPL
Cabal.AGPL _ -> OtherLicense (show x)
Cabal.LGPL _ -> LGPL
Cabal.BSD3 -> BSD_3_Clause
Cabal.BSD4 -> BSD_4_Clause
Cabal.MIT -> Expat
Cabal.Apache _ -> Apache
Cabal.PublicDomain -> Public_Domain
Cabal.AllRightsReserved -> OtherLicense "AllRightsReserved"
Cabal.OtherLicense -> OtherLicense (show x)
Cabal.UnknownLicense _ -> OtherLicense (show x)
Cabal.MPL _ -> MPL
Cabal.BSD2 -> BSD_2_Clause
Cabal.ISC -> OtherLicense (show x)
Cabal.UnspecifiedLicense -> OtherLicense (show x)
toCabalLicense :: License -> Cabal.License
toCabalLicense x =
case x of
BSD_2_Clause -> Cabal.BSD2
BSD_3_Clause -> Cabal.BSD3
BSD_4_Clause -> Cabal.BSD4
Expat -> Cabal.MIT
OtherLicense s -> Cabal.UnknownLicense s
_ -> Cabal.UnknownLicense (show x)
invalidLicense :: Text -> License
invalidLicense = OtherLicense . unpack
readLicense :: Text -> License
readLicense t = let s = unpack (strip t) in fromMaybe (invalidLicense t) (readMaybe s)