-- | {-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TemplateHaskell, TupleSections, LambdaCase #-} module Debian.Debianize.CopyrightDescription ( CopyrightDescription(..) , FilesOrLicenseDescription(..) -- * Lenses , format , upstreamName , upstreamContact , upstreamSource , disclaimer , summaryComment , summaryLicense , summaryCopyright , filesAndLicenses , filesPattern , filesCopyright , filesLicense , filesComment , license , comment -- * Builders , readCopyrightDescription , parseCopyrightDescription , defaultCopyrightDescription ) where import Data.Char (isSpace) import Data.Default (Default(def)) import Data.Either (lefts, rights) import Data.Generics (Data, Typeable) import Control.Lens.TH (makeLenses) import Data.List as List (dropWhileEnd, partition) import Data.Maybe.Extended (isJust, catMaybes, fromJust, fromMaybe, listToMaybe, nothingIf) import Data.Monoid ((<>), mempty) import Data.Text as Text (Text, pack, strip, unpack, null, lines, unlines, dropWhileEnd) import Debian.Control (Field'(Field), fieldValue, Paragraph'(Paragraph), Control'(Control, unControl), parseControl) import Debian.Debianize.Prelude (readFileMaybe) import Debian.Orphans () import Debian.Policy (License(..), readLicense, fromCabalLicense) import Debian.Pretty (prettyText, ppText) import Debug.Trace import qualified Distribution.License as Cabal (License(UnknownLicense)) import qualified Distribution.Package as Cabal #if MIN_VERSION_Cabal(1,20,0) import qualified Distribution.PackageDescription as Cabal (PackageDescription(licenseFiles, copyright, license, package, maintainer)) #else import qualified Distribution.PackageDescription as Cabal (PackageDescription(licenseFile, copyright, license, package, maintainer)) #endif import Network.URI (URI, parseURI) import Prelude hiding (init, init, log, log, unlines, readFile) import Text.PrettyPrint.HughesPJClass (Pretty(pPrint), text) unPackageName :: Cabal.PackageName -> String unPackageName (Cabal.PackageName x) = x -- | Description of the machine readable debian/copyright file. A -- special case is used to represeent the old style free format file - -- if the value is equal to newCopyrightDescription except for the -- field _summaryComment, the text in _summaryComment is the copyright -- file. data CopyrightDescription = CopyrightDescription { _format :: URI , _upstreamName :: Maybe Text , _upstreamContact :: Maybe Text , _upstreamSource :: Maybe Text , _disclaimer :: Maybe Text , _summaryComment :: Maybe Text , _summaryLicense :: Maybe License , _summaryCopyright :: Maybe Text , _filesAndLicenses :: [FilesOrLicenseDescription] } deriving (Eq, Ord, Show, Data, Typeable) data FilesOrLicenseDescription = FilesDescription { _filesPattern :: FilePath , _filesCopyright :: Text , _filesLicense :: License , _filesComment :: Maybe Text } | LicenseDescription { _license :: License , _comment :: Maybe Text } deriving (Eq, Ord, Show, Data, Typeable) instance Pretty CopyrightDescription where -- Special case encodes free format debian/copyright file pPrint x@(CopyrightDescription {_summaryComment = Just t}) | x {_summaryComment = Nothing} == def = text (List.dropWhileEnd isSpace (unpack t) <> "\n") pPrint x = pPrint . toControlFile $ x instance Default CopyrightDescription where def = CopyrightDescription { _format = fromJust $ parseURI "http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/" , _upstreamName = Nothing , _upstreamContact = Nothing , _upstreamSource = Nothing , _disclaimer = Nothing , _summaryComment = Nothing , _summaryLicense = Nothing , _summaryCopyright = Nothing , _filesAndLicenses = [] } -- | Read a 'CopyrightDescription' from the text one might obtain from -- a @debian/copyright@ file. readCopyrightDescription :: Text -> CopyrightDescription readCopyrightDescription t = case parseControl "debian/copyright" t of Left _e -> def { _summaryComment = Just t } Right ctl -> case parseCopyrightDescription (unControl ctl) of Just cpy -> cpy Nothing -> def { _summaryComment = Just t } -- | Try to parse a structured copyright file parseCopyrightDescription :: [Paragraph' Text] -> Maybe CopyrightDescription parseCopyrightDescription (hd : tl) = let (muri :: Either (Paragraph' Text) URI) = maybe (Left hd) Right (maybe Nothing (parseURI . unpack) (fieldValue "Format" hd)) in case (muri, map parseFilesOrLicense tl) of (Right uri, fnls) | all (either (const False) (const True)) fnls -> Just $ CopyrightDescription { _format = uri , _upstreamName = fieldValue "Upstream-Name" hd , _upstreamContact = fieldValue "Upstream-Contact" hd , _upstreamSource = fieldValue "Source" hd , _disclaimer = fieldValue "Disclaimer" hd , _summaryComment = fieldValue "Comment" hd , _summaryLicense = fmap readLicense (fieldValue "License" hd) , _summaryCopyright = Nothing -- fieldValue "Copyright" hd , _filesAndLicenses = rights fnls } (_, fnls) -> trace ("Not a parsable copyright file: " ++ show (lefts [muri] ++ lefts fnls)) Nothing parseCopyrightDescription [] = Nothing parseFilesOrLicense :: Paragraph' Text -> Either (Paragraph' Text) (FilesOrLicenseDescription) parseFilesOrLicense p = case (fieldValue "Files" p, fieldValue "Copyright" p, fieldValue "License" p) of (Just files, Just copyright, Just license) -> Right $ FilesDescription { _filesPattern = unpack files , _filesCopyright = copyright , _filesLicense = readLicense license , _filesComment = fieldValue "Comment" p } (Nothing, Nothing, Just license) -> Right $ LicenseDescription { _license = readLicense license , _comment = fieldValue "Comment" p } _ -> Left p toControlFile :: CopyrightDescription -> Control' Text toControlFile d = Control ( Paragraph ( [ Field ("Format", (" " <> ppText (_format d))) ] ++ maybe [] (\x -> [Field ("Upstream-Name", " " <> x)]) (_upstreamName d) ++ maybe [] (\x -> [Field ("Upstream-Contact", " " <> x)]) (_upstreamContact d) ++ maybe [] (\x -> [Field ("Source", " " <> x)]) (_upstreamSource d) ++ maybe [] (\x -> [Field ("Disclaimer", " " <> x)]) (_disclaimer d) ++ maybe [] (\x -> [Field ("License", " " <> prettyText x)]) (_summaryLicense d) ++ maybe [] (\x -> [Field ("Copyright", " " <> x)]) (_summaryCopyright d) ++ maybe [] (\x -> [Field ("Comment", " " <> x)]) (_summaryComment d)) : map toParagraph (_filesAndLicenses d) ) toParagraph :: FilesOrLicenseDescription -> Paragraph' Text toParagraph fd@FilesDescription {} = Paragraph $ [ Field ("Files", " " <> pack (_filesPattern fd)) , Field ("Copyright", " " <> _filesCopyright fd) , Field ("License", " " <> prettyText (_filesLicense fd)) ] ++ maybe [] (\ t -> [Field ("Comment", " " <> t)]) (_filesComment fd) toParagraph ld@LicenseDescription {} = Paragraph $ [ Field ("License", " " <> prettyText (_license ld)) ] ++ maybe [] (\ t -> [Field ("Comment", " " <> t)]) (_comment ld) sourceDefaultFilesDescription :: Maybe Text -> License -> FilesOrLicenseDescription sourceDefaultFilesDescription copyrt license = FilesDescription { _filesPattern = "*" , _filesCopyright = fromMaybe "(No copyright field in cabal file)" copyrt , _filesLicense = license , _filesComment = mempty } debianDefaultFilesDescription :: License -> FilesOrLicenseDescription debianDefaultFilesDescription license = FilesDescription { _filesPattern = "debian/*" , _filesCopyright = "held by the contributors mentioned in debian/changelog" , _filesLicense = license , _filesComment = mempty } defaultLicenseDescriptions :: License -> [(FilePath, Maybe Text)] -> [FilesOrLicenseDescription] defaultLicenseDescriptions license = \case [] -> [] [(_, comment)] -> [LicenseDescription license comment] pairs -> map mkLicenseDescription pairs where mkLicenseDescription (path, comment) = LicenseDescription { _license = fromCabalLicense (Cabal.UnknownLicense path) , _comment = comment } -- | Infer a 'CopyrightDescription' from a Cabal package description. -- This will try to read any copyright files listed in the cabal -- configuration. Inputs include the license field from the cabal -- file, the contents of the license files mentioned there, and the -- provided @copyright0@ value. defaultCopyrightDescription :: Cabal.PackageDescription -> IO CopyrightDescription defaultCopyrightDescription pkgDesc = do #if MIN_VERSION_Cabal(1,20,0) let (debianCopyrightPath, otherLicensePaths) = partition (== "debian/copyright") (Cabal.licenseFiles pkgDesc) #else let (debianCopyrightPath, otherLicensePaths) = partition (== "debian/copyright") [Cabal.licenseFile pkgDesc] #endif license = fromCabalLicense $ Cabal.license pkgDesc pkgname = unPackageName . Cabal.pkgName . Cabal.package $ pkgDesc maintainer = Cabal.maintainer $ pkgDesc -- This is an @Nothing@ unless debian/copyright is (for some -- reason) mentioned in the cabal file. debianCopyrightText <- mapM readFileMaybe debianCopyrightPath >>= return . listToMaybe . catMaybes licenseCommentPairs <- mapM readFileMaybe otherLicensePaths >>= return . filter (isJust . snd) . zip otherLicensePaths return $ case debianCopyrightText of Just t -> def { _summaryComment = Just t } Nothing -> -- All we have is the name of the license let copyrt = fmap dots $ nothingIf (Text.null . strip) (pack (Cabal.copyright pkgDesc)) in def { _filesAndLicenses = [ sourceDefaultFilesDescription copyrt license, debianDefaultFilesDescription license ] ++ defaultLicenseDescriptions license licenseCommentPairs , _upstreamName = Just . pack $ pkgname , _upstreamSource = Just . pack $ "https://hackage.haskell.org/package/" ++ pkgname , _upstreamContact = nothingIf Text.null (pack maintainer) } {- -- We don't really have a way to associate licenses with -- file patterns, so we will just cover some simple cases, -- a single license, no license, etc. -- It is possible we might interpret the license file path -- as a license name, so I hang on to it here. return $ cabalToCopyrightDescription pkgDesc licenseComments (maybe def readCopyrightDescription debianCopyrightText) where cabalToCopyrightDescription :: Cabal.PackageDescription -> [Maybe Text] -> CopyrightDescription -> CopyrightDescription cabalToCopyrightDescription pkgDesc licenseComments copyright0 = let copyrt = fmap dots $ nothingIf (Text.null . strip) (pack (Cabal.copyright pkgDesc)) license = Cabal.license pkgDesc in copyright0 { _filesAndLicenses = map (\ comment -> FilesDescription { _filesPattern = "*" , _filesCopyright = fromMaybe (pack "(No copyright field in cabal file)") copyrt , _filesLicense = fromCabalLicense license , _filesComment = comment }) licenseComments } -} -- | Replace empty lines with single dots dots :: Text -> Text dots = Text.unlines . map (\ line -> if Text.null line then "." else line) . map (Text.dropWhileEnd isSpace) . Text.lines $(makeLenses ''CopyrightDescription) $(makeLenses ''FilesOrLicenseDescription)