module Debian.Debianize.CopyrightDescription
( CopyrightDescription(..)
, FilesOrLicenseDescription(..)
, format
, upstreamName
, upstreamContact
, upstreamSource
, disclaimer
, summaryComment
, summaryLicense
, summaryCopyright
, filesAndLicenses
, filesPattern
, filesCopyright
, filesLicense
, filesComment
, license
, comment
, 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
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
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 = [] }
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 }
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
, _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
}
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
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 ->
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)
}
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)