1 files changed, 106 insertions, 0 deletions
diff --git a/src/FSD/Copyright.hs b/src/FSD/Copyright.hs
new file mode 100644
index 0000000..68b7b50
--- /dev/null
+++ b/src/FSD/Copyright.hs
@@ -0,0 +1,106 @@
+{-
+Copyright (C) 2022 Yuchen Pei.
+
+This file is part of fsd.
+
+fsd is free software: you can redistribute it and/or modify it under
+the terms of the GNU Affero General Public License as published by
+the Free Software Foundation, either version 3 of the License, or
+(at your option) any later version.
+
+fsd is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Affero General
+Public License for more details.
+
+You should have received a copy of the GNU Affero General Public
+License along with fsd.  If not, see <https://www.gnu.org/licenses/>.
+
+-}
+
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module FSD.Copyright where
+
+import FSD.Control
+import Data.Map hiding (filter)
+import Data.Maybe
+import Data.Text (Text)
+import Data.Text qualified as T
+import Debian.Control
+import Text.Regex.TDFA
+import FSD.Types
+
+parseCopyright :: Text -> Control -> Maybe (Upstream, Copyright)
+parseCopyright package control =
+  case unControl control of
+    [] -> Nothing
+    header : rest ->
+      -- no parse if header is wrong
+      if fromMaybe "" (firstFieldName header) /= "Format"
+        then Nothing
+        else
+        Just
+          ( getUpstream package header,
+            Copyright package (getLicenses (header : files) licenses)
+          )
+      where
+        files = filter (\para ->
+                          fromMaybe "" (firstFieldName para) == "Files") rest
+        licenses = filter
+                   (\para ->
+                       fromMaybe "" (firstFieldName para) == "License") rest
+
+getUpstream :: Text -> Paragraph -> Upstream
+getUpstream package para =
+  Upstream package uName contacts (SourceUrls source)
+  where
+    uName = T.pack <$> fieldValue "Upstream-Name" para
+    contacts = case fieldValue "Upstream-Contact" para of
+      Just contact -> parseContacts $ lbListFV contact
+      Nothing -> []
+    source = case fieldValue "Source" para of
+      Just source -> parseSource $ multilineFV source
+      Nothing -> []
+
+parseContacts :: [Text] -> [Contact]
+parseContacts = catMaybes . fmap parseContact
+
+parseContact :: Text -> Maybe Contact
+parseContact raw =
+  case T.unpack raw =~ ("^(.*)<(.*@.*)>$" :: String) :: [[String]] of
+    [[_, "", email]] -> Just $ Contact Nothing (T.pack email)
+    [[_, name, email]] ->
+      Just $
+        Contact
+          (Just $ T.strip $ T.pack name)
+          (T.pack email)
+    _ -> Nothing
+
+parseSource :: Text -> [Text]
+parseSource = fmap T.strip . T.splitOn "\n"
+
+getLicenses :: [Paragraph] -> [Paragraph] -> [LicenseInfo]
+getLicenses paras licenses =
+  catMaybes $ getLicense (getLicenseMap licenses) <$> paras
+
+getLicense :: Map Text Text -> Paragraph -> Maybe LicenseInfo
+getLicense licMap para = case fSynFV <$> fieldValue "License" para of
+  Just ("", _) -> Nothing
+  Nothing -> Nothing
+  Just (name, desc) ->
+    Just $
+      LicenseInfo
+        (multilineFV <$> fieldValue "Copyright" para)
+        name
+        (if T.null desc then Data.Map.lookup name licMap else Just desc)
+
+getLicenseMap :: [Paragraph] -> Map Text Text
+getLicenseMap licenses = fromList $ catMaybes $ toPair <$> licenses
+  where
+    toPair license = case fSynFV <$> fieldValue "License" license of
+      Just ("", _) -> Nothing
+      Just (_, "") -> Nothing
+      Just (name, desc) -> Just (name, desc)
+      Nothing -> Nothing