aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorYuchen Pei <hi@ypei.me>2022-05-19 22:23:10 +1000
committerYuchen Pei <hi@ypei.me>2022-05-19 22:23:10 +1000
commit3db93bc6f7b46bc322694e6658b8f559433a03c6 (patch)
tree1273a17e11e0d9888ae57676906c68f8bb77e287 /src
parent09c05e86a1096b08eb7483b970207d47d0388665 (diff)
Replacing the files with a haskell rewrite.
Diffstat (limited to 'src')
-rw-r--r--src/FSD/ChangeLog.hs60
-rw-r--r--src/FSD/Control.hs84
-rw-r--r--src/FSD/Copyright.hs106
-rw-r--r--src/FSD/Db.hs211
-rw-r--r--src/FSD/Download.hs118
-rw-r--r--src/FSD/Package.hs61
-rw-r--r--src/FSD/PackageInfo.hs70
-rw-r--r--src/FSD/Source.hs45
-rw-r--r--src/FSD/Translation.hs41
-rw-r--r--src/FSD/Types.hs248
-rw-r--r--src/FSD/Wiki.hs156
-rw-r--r--src/Main.hs312
12 files changed, 1512 insertions, 0 deletions
diff --git a/src/FSD/ChangeLog.hs b/src/FSD/ChangeLog.hs
new file mode 100644
index 0000000..195b713
--- /dev/null
+++ b/src/FSD/ChangeLog.hs
@@ -0,0 +1,60 @@
+{-
+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 #-}
+module FSD.ChangeLog where
+
+import Data.Generics
+import Data.Time
+import Data.Text qualified as T
+import Debian.Changes
+import Debian.Version
+import Text.Regex.TDFA
+import FSD.Types
+
+readChangeLog :: String -> Maybe ChangeLogEntry
+readChangeLog raw = case parseEntry raw of
+ Left _ -> Nothing
+ Right (entry, _) -> Just entry
+
+-- Debian version is an abstract type with no constructor, hence the ugly hack.
+getVersion :: DebianVersion -> Maybe String
+getVersion v =
+ let match = show v =~ ("\".*\"" :: String)
+ in if null match then Nothing else Just $ init $ tail match
+
+convertChangeLogEntry :: ChangeLogEntry -> Maybe FSDChangeLogEntry
+convertChangeLogEntry entry = do
+ version <- getVersion $ logVersion entry
+ time <- parseTime' $ logDate entry
+ return $
+ FSDChangeLogEntry
+ (T.pack $ logPackage entry)
+ (T.pack version)
+ (T.pack $ logWho entry)
+ time
+ where
+ parseTime' raw =
+ orElse
+ (parseTimeM False defaultTimeLocale "%a, %d %b %Y %T %Z" raw)
+ (parseTimeM False defaultTimeLocale "%a, %e %b %Y %T %Z" raw)
+
+getChangeLogEntry :: String -> Maybe FSDChangeLogEntry
+getChangeLogEntry raw = readChangeLog raw >>= convertChangeLogEntry
diff --git a/src/FSD/Control.hs b/src/FSD/Control.hs
new file mode 100644
index 0000000..2395f85
--- /dev/null
+++ b/src/FSD/Control.hs
@@ -0,0 +1,84 @@
+{-
+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.Control where
+
+import Data.Either
+import Data.List.Extra
+import Data.Text (Text)
+import Data.Text qualified as T
+import Debian.Control
+import Debug.Trace
+
+-- import Text.Regex.TDFA
+
+-- parse sources, packages, translations and copyright
+-- https://manpages.debian.org/bullseye/dpkg-dev/deb822.5.en.html
+-- https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
+
+readControl :: String -> Control
+readControl =
+ fromRight (Control []) . parseControl ""
+
+-- stripControl . fromRight (Control []) . parseControl ""
+
+simpleFV :: String -> Text
+simpleFV = T.pack
+
+-- multiple lines with nonsignficant whitespaces
+foldedFV :: String -> Text
+foldedFV = undefined
+
+-- multilines
+-- may erroneously remove first char of first line (we'll see)
+multilineFV :: String -> Text
+multilineFV raw =
+ let (first, rest) = fSynFV raw
+ in T.strip $ T.concat [first, "\n", rest]
+
+-- whitespace separated list
+wsListFV :: String -> [Text]
+wsListFV = T.splitOn " " . foldedFV
+
+-- line-based lists
+lbListFV :: String -> [Text]
+lbListFV = fmap T.strip . T.splitOn "\n" . T.pack
+
+-- formatted text with synopsis
+fSynFV :: String -> (Text, Text)
+fSynFV raw =
+ let (synopsis, longRaw) = breakOn "\n" $ raw
+ paras =
+ if null longRaw
+ then []
+ else T.splitOn "\n .\n" $ T.pack $ tail longRaw
+ full =
+ T.intercalate "\n\n" $
+ (T.intercalate "\n" . fmap T.tail . T.lines) <$> paras
+ in (T.pack synopsis, full)
+
+firstFieldName :: Paragraph -> Maybe String
+firstFieldName (Paragraph []) = Nothing
+firstFieldName (Paragraph (Comment _ : xs)) =
+ firstFieldName (Paragraph xs)
+firstFieldName (Paragraph (Field (name, _) : _)) = Just name
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
diff --git a/src/FSD/Db.hs b/src/FSD/Db.hs
new file mode 100644
index 0000000..38a822c
--- /dev/null
+++ b/src/FSD/Db.hs
@@ -0,0 +1,211 @@
+{-
+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 #-}
+{-# LANGUAGE TypeOperators #-}
+
+module FSD.Db where
+
+import Control.Monad
+import FSD.Copyright
+import Data.Text (Text)
+import Data.Text qualified as T
+import Database.SQLite.Simple
+import FSD.Types
+
+newtype FsDb = FsDb {getConn :: Connection}
+
+withFsDb :: FilePath -> (FsDb -> IO a) -> IO a
+withFsDb path f = withConnection path (f . FsDb)
+
+-- creations
+
+initConn :: FsDb -> IO ()
+initConn (FsDb conn) = do
+ execute_
+ conn
+ "CREATE TABLE IF NOT EXISTS sources \
+ \( package TEXT NOT NULL PRIMARY KEY ON CONFLICT REPLACE \
+ \, version TEXT NOT NULL \
+ \, file TEXT NOT NULL \
+ \, homepage TEXT \
+ \)"
+ execute_
+ conn
+ "CREATE TABLE IF NOT EXISTS packages \
+ \( package TEXT NOT NULL PRIMARY KEY ON CONFLICT REPLACE \
+ \, version TEXT NOT NULL \
+ \, homepage TEXT \
+ \, tags TEXT NOT NULL \
+ \)"
+ execute_
+ conn
+ "CREATE TABLE IF NOT EXISTS translation \
+ \( package TEXT NOT NULL PRIMARY KEY ON CONFLICT REPLACE \
+ \, shortDesc TEXT NOT NULL \
+ \, fullDesc TEXT NOT NULL \
+ \)"
+ execute_
+ conn
+ "CREATE TABLE IF NOT EXISTS changelog \
+ \( package TEXT NOT NULL PRIMARY KEY ON CONFLICT REPLACE \
+ \, version TEXT NOT NULL \
+ \, author TEXT NOT NULL \
+ \, date TEXT NOT NULL \
+ \)"
+ execute_
+ conn
+ "CREATE TABLE IF NOT EXISTS copyright \
+ \( id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT \
+ \, package TEXT NOT NULL \
+ \, entryId INTEGER NOT NULL \
+ \, copyright TEXT \
+ \, license TEXT NOT NULL \
+ \, note TEXT \
+ \, CONSTRAINT uniqname UNIQUE (package, entryId) ON CONFLICT REPLACE \
+ \)"
+ execute_
+ conn
+ "CREATE TABLE IF NOT EXISTS upstream \
+ \( package TEXT NOT NULL PRIMARY KEY ON CONFLICT REPLACE \
+ \, name TEXT \
+ \, contacts TEXT \
+ \, sources TEXT \
+ \)"
+
+-- insertions
+
+insertSource :: FsDb -> Source -> IO ()
+insertSource (FsDb conn) source =
+ execute conn "INSERT INTO sources VALUES (?,?,?,?)" source
+
+insertPackage :: FsDb -> Package -> IO ()
+insertPackage (FsDb conn) package =
+ execute conn "INSERT INTO packages VALUES (?,?,?,?)" package
+
+insertTranslation :: FsDb -> Translation -> IO ()
+insertTranslation (FsDb conn) translation =
+ execute conn "INSERT INTO translation VALUES (?,?,?)" translation
+
+insertFSDChangeLogEntry :: FsDb -> FSDChangeLogEntry -> IO ()
+insertFSDChangeLogEntry (FsDb conn) change =
+ execute conn "INSERT INTO changelog VALUES (?,?,?,?)" change
+
+insertCopyright :: FsDb -> Copyright -> IO ()
+insertCopyright db (Copyright package licenses) =
+ zipWithM_ (insertLicense db package) [0 ..] licenses
+
+insertUpstream :: FsDb -> Upstream -> IO ()
+insertUpstream (FsDb conn) upstream =
+ execute conn "INSERT INTO upstream VALUES (?,?,?,?)" upstream
+
+insertLicense :: FsDb -> Text -> Int -> LicenseInfo -> IO ()
+insertLicense (FsDb conn) package idx (LicenseInfo copyright license note) =
+ execute
+ conn
+ "INSERT INTO copyright (package,entryId,copyright,license,note) \
+ \VALUES (?,?,?,?,?)"
+ (package, idx, copyright, license, note)
+
+-- queries
+getDbAll :: FsDb -> IO [Source :. Package :. Translation :. FSDChangeLogEntry :. Upstream]
+getDbAll (FsDb conn) =
+ query_
+ conn
+ "SELECT sources.*,packages.*,translation.*,changelog.*,upstream.* \
+ \FROM sources JOIN packages USING (package,version)\
+ \ JOIN changelog USING (package,version)\
+ \ JOIN translation USING (package)\
+ \ JOIN upstream USING (package)\
+ \"
+
+getDbPkgNames :: FsDb -> IO [Text]
+getDbPkgNames (FsDb conn) = do
+ rows <- query_ conn
+ "SELECT DISTINCT package\
+ \ FROM sources JOIN packages USING (package,version)\
+ \ JOIN changelog USING (package,version)\
+ \ JOIN translation USING (package)\
+ \ JOIN upstream USING (package)\
+ \ JOIN copyright USING (package)\
+ \"
+ return $ fromOnly <$> rows
+
+getDbAllTypes :: Text -> FsDb -> IO (Maybe (Source :. Package :. Translation :. FSDChangeLogEntry :. Upstream))
+getDbAllTypes pkgName (FsDb conn) = do
+ results <- query
+ conn
+ "SELECT sources.*,packages.*,translation.*,changelog.*,upstream.* \
+ \FROM sources JOIN packages USING (package,version)\
+ \ JOIN changelog USING (package,version)\
+ \ JOIN translation USING (package)\
+ \ JOIN upstream USING (package) \
+ \WHERE package = ?\
+ \" (Only pkgName)
+ return $ case results of
+ [source] -> Just source
+ otherwise -> Nothing
+
+getDbSource :: Text -> FsDb -> IO (Maybe Source)
+getDbSource pkgName (FsDb conn) = do
+ results <- query conn "SELECT * FROM sources WHERE package = ?" (Only pkgName)
+ return $ case results of
+ [source] -> Just source
+ otherwise -> Nothing
+
+getDbPackage :: Text -> FsDb -> IO (Maybe Package)
+getDbPackage pkgName (FsDb conn) = do
+ results <- query conn "SELECT * FROM packages WHERE package = ?" (Only pkgName)
+ return $ case results of
+ [package] -> Just package
+ otherwise -> Nothing
+
+getDbTranslation :: Text -> FsDb -> IO (Maybe Translation)
+getDbTranslation pkgName (FsDb conn) = do
+ results <- query conn "SELECT * FROM translation WHERE package = ?" (Only pkgName)
+ return $ case results of
+ [translation] -> Just translation
+ otherwise -> Nothing
+
+getDbFSDChangeLogEntry :: Text -> FsDb -> IO (Maybe FSDChangeLogEntry)
+getDbFSDChangeLogEntry pkgName (FsDb conn) = do
+ results <- query conn "SELECT * FROM changelog WHERE package = ?" (Only pkgName)
+ return $ case results of
+ [entry] -> Just entry
+ otherwise -> Nothing
+
+getDbUpstream :: Text -> FsDb -> IO (Maybe Upstream)
+getDbUpstream pkgName (FsDb conn) = do
+ results <- query conn "SELECT * FROM upstream WHERE package = ?" (Only pkgName)
+ return $ case results of
+ [upstream] -> Just upstream
+ otherwise -> Nothing
+
+getDbCopyright :: Text -> FsDb -> IO (Maybe Copyright)
+getDbCopyright pkgName (FsDb conn) = do
+ results <-
+ query
+ conn
+ "SELECT copyright,license,note FROM copyright WHERE package = ?"
+ (Only pkgName) ::
+ IO [LicenseInfo]
+ return $
+ if (null results) then Nothing else Just $ Copyright pkgName results
diff --git a/src/FSD/Download.hs b/src/FSD/Download.hs
new file mode 100644
index 0000000..3631ddc
--- /dev/null
+++ b/src/FSD/Download.hs
@@ -0,0 +1,118 @@
+{-
+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.Download where
+
+import System.FilePath
+import Control.Monad
+import Data.Function
+import Data.List
+import Data.Text (Text)
+import Data.Text qualified as T
+import System.Exit
+import System.Process
+import System.Random
+
+wgetCommand = "wget"
+
+wgetIndexFileFlags = "-O- 2>/dev/null"
+
+gunzipCommand = "gunzip"
+
+bunzip2Command = "bunzip2"
+
+wgetMetadataFlags = "-N -nv -x -c"
+
+sourcesUrl = "https://ftp.debian.org/debian/dists/stable/main/source/Sources.gz"
+
+packagesUrl = "https://ftp.debian.org/debian/dists/stable/main/binary-amd64/Packages.gz"
+
+translationUrl = "https://ftp.debian.org/debian/dists/stable/main/i18n/Translation-en.bz2"
+
+data MetadataType = MTChangelog | MTCopyright deriving Eq
+
+metadataUrlFile :: MetadataType -> Int -> String
+metadataUrlFile mtype i = toFilename mtype ++ "_urls_" ++ show i
+ where toFilename MTChangelog = "changelog"
+ toFilename MTCopyright = "copyright"
+
+wgetIndexFileCommand :: FilePath -> (String, String) -> String
+wgetIndexFileCommand outputDir (url, filename) =
+ wgetCommand ++ " " ++ wgetIndexFileFlags ++ " " ++ url ++ "|" ++ extractCommand ++ " >" ++ (outputDir </> filename) ++ " && echo Done: " ++ filename
+ where
+ extractCommand = if isSuffixOf ".gz" url then gunzipCommand else bunzip2Command
+
+downloadSources :: FilePath -> IO ExitCode
+downloadSources outputDir =
+ waitForProcess =<<
+ (runCommand $ wgetIndexFileCommand outputDir (sourcesUrl, "Sources"))
+
+downloadPackages :: FilePath -> IO ExitCode
+downloadPackages outputDir =
+ waitForProcess =<<
+ (runCommand $ wgetIndexFileCommand outputDir (packagesUrl, "Packages"))
+
+downloadTranslation :: FilePath -> IO ExitCode
+downloadTranslation outputDir =
+ waitForProcess =<<
+ (runCommand $
+ wgetIndexFileCommand outputDir (translationUrl, "Translation-en"))
+
+downloadMetadataFiles :: FilePath -> MetadataType -> Int -> IO [ProcessHandle]
+downloadMetadataFiles root mtype nWorkers =
+ sequence $
+ ( \i ->
+ runCommand
+ ( wgetCommand ++ " " ++ wgetMetadataFlags
+ ++ " -i " ++ (root </> metadataUrlFile mtype i)
+ ++ " -P " ++ root
+ ++ " && echo Done: worker " ++ show i
+ )
+ )
+ <$> [1 .. nWorkers]
+
+writeWgetListFiles :: FilePath -> MetadataType -> [Text] -> Int -> IO ()
+writeWgetListFiles outputDir mtype packages n = do
+ pairs <- zip [1 ..] . fmap T.unlines <$> mapM shuffle (replicate n urls)
+ mapM_ (\(i, list) ->
+ writeFile (outputDir </> metadataUrlFile mtype i)
+ (T.unpack list)) pairs
+ where
+ urls = metadataUrl mtype <$> packages
+
+shuffle :: [Text] -> IO [Text]
+shuffle xs =
+ fmap fst . sortBy (compare `on` snd) . zip xs
+ <$> replicateM n (randomRIO (0, n * n))
+ where
+ n = length xs
+
+metadataUrl :: MetadataType -> Text -> Text
+metadataUrl mtype pkgName =
+ "https://metadata.ftp-master.debian.org/changelogs/main/" <>
+ (if T.isPrefixOf "lib" pkgName
+ then T.take 4 pkgName else T.take 1 pkgName) <>
+ "/" <> pkgName <> "/" <> toFilename mtype
+ where
+ toFilename MTChangelog = "stable_changelog"
+ toFilename MTCopyright = "stable_copyright"
diff --git a/src/FSD/Package.hs b/src/FSD/Package.hs
new file mode 100644
index 0000000..8ccd852
--- /dev/null
+++ b/src/FSD/Package.hs
@@ -0,0 +1,61 @@
+{-
+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.Package where
+
+import Data.Generics
+import Data.Maybe
+import Data.Text (Text)
+import Data.Text qualified as T
+import Debian.Control
+import Text.Regex.TDFA
+import FSD.Types
+
+getTags :: Paragraph -> [Text]
+getTags para = case fieldValue "Tag" para of
+ Nothing -> []
+ Just tags ->
+ (T.splitOn ", " . T.pack . concat . lines) tags
+
+{-package version should be from Source field overriding Version field:
+Package: pandoc
+Source: pandoc (2.9.2.1-1)
+Version: 2.9.2.1-1+b1
+-}
+getPackage :: Paragraph -> Maybe Package
+getPackage para = do
+ package <- T.pack <$> fieldValue "Package" para
+ let homepage = T.pack <$> fieldValue "Homepage" para
+ let tags = getTags para
+ let srcVersion = extractSrcVersion =<< fieldValue "Source" para
+ version <- T.pack <$> orElse srcVersion (fieldValue "Version" para)
+ return $ Package package version homepage (Tags tags)
+ where
+ extractSrcVersion :: String -> Maybe String
+ extractSrcVersion source =
+ case source =~ (".*\\((.*)\\)$" :: String) :: [[String]] of
+ [[_, version]] -> Just version
+ _ -> Nothing
+
+getPackages :: Control -> [Package]
+getPackages = catMaybes . fmap getPackage . unControl
diff --git a/src/FSD/PackageInfo.hs b/src/FSD/PackageInfo.hs
new file mode 100644
index 0000000..959c225
--- /dev/null
+++ b/src/FSD/PackageInfo.hs
@@ -0,0 +1,70 @@
+{-
+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 #-}
+module FSD.PackageInfo where
+
+import Data.Generics
+import Data.Maybe
+import Data.Text qualified as T
+import Data.Text (Text)
+import Data.Char
+import Data.Time
+import FSD.Types
+
+makePackageInfo ::
+ Source ->
+ Package ->
+ Translation ->
+ FSDChangeLogEntry ->
+ Upstream ->
+ Copyright ->
+ IO (Maybe PackageInfo)
+makePackageInfo source package trans change upstream copyright =
+ if or
+ [ sPackage source /= pPackage package,
+ sPackage source /= tPackage trans,
+ sPackage source /= clPackage change,
+ sPackage source /= uPackage upstream,
+ sPackage source /= crPackage copyright,
+ sVersion source /= pVersion package,
+ sVersion source /= clVersion change
+ ]
+ then return Nothing
+ else do
+ time <- getCurrentTime
+ return $
+ Just
+ PackageInfo
+ { piPackage = sPackage source,
+ piVersion = sVersion source,
+ piTimestamp = time,
+ piFile = sFile source,
+ piHomepage = orElse (sHomepage source) (pHomepage package),
+ piTags = unTags $ pTags package,
+ piShortDesc = tShortDesc trans,
+ piFullDesc = tFullDesc trans,
+ piUpstreamName = uName upstream,
+ piContacts = uContacts upstream,
+ piSources = unSources $ uSources upstream,
+ piLicenses = crLicenses copyright,
+ piCLAuthor = clAuthor change,
+ piCLTimestamp = clTimestamp change
+ }
diff --git a/src/FSD/Source.hs b/src/FSD/Source.hs
new file mode 100644
index 0000000..751ac31
--- /dev/null
+++ b/src/FSD/Source.hs
@@ -0,0 +1,45 @@
+{-
+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.Source where
+
+import FSD.Control
+import Data.List.Extra
+import Data.Maybe
+import Data.Text qualified as T
+import Debian.Control
+import FSD.Types
+
+getSource :: Paragraph -> Maybe Source
+getSource para = do
+ package <- simpleFV <$> fieldValue "Package" para
+ version <- simpleFV <$> fieldValue "Version" para
+ fileLines <- lbListFV <$> fieldValue "Files" para
+ -- normally the 2nd file is the orig one
+ fileLine <- fileLines !? 2
+ file <- (T.splitOn " " fileLine) !? 2
+ let homepage = simpleFV <$> fieldValue "Homepage" para
+ return $ Source package version file homepage
+
+getSources :: Control -> [Source]
+getSources = catMaybes . fmap getSource . unControl
diff --git a/src/FSD/Translation.hs b/src/FSD/Translation.hs
new file mode 100644
index 0000000..d825baa
--- /dev/null
+++ b/src/FSD/Translation.hs
@@ -0,0 +1,41 @@
+{-
+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.Translation where
+
+import FSD.Control
+import Data.List.Extra
+import Data.Maybe
+import Data.Text (Text)
+import Data.Text qualified as T
+import Debian.Control
+import FSD.Types
+
+getTranslation :: Paragraph -> Maybe Translation
+getTranslation para = do
+ package <- T.pack <$> fieldValue "Package" para
+ (shortDesc, fullDesc) <- fSynFV <$> fieldValue "Description-en" para
+ return $ Translation package shortDesc fullDesc
+
+getTranslations :: Control -> [Translation]
+getTranslations = catMaybes . fmap getTranslation . unControl
diff --git a/src/FSD/Types.hs b/src/FSD/Types.hs
new file mode 100644
index 0000000..6ac6c12
--- /dev/null
+++ b/src/FSD/Types.hs
@@ -0,0 +1,248 @@
+{-
+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 #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module FSD.Types where
+
+import Data.Maybe
+import Data.Time
+import Data.Text (Text)
+import Data.Text qualified as T
+import Database.SQLite.Simple
+import Database.SQLite.Simple.FromField
+
+{- Source
+- obtained from dist/Sources.gz
+- sPackage, sVersion: key, package and version, also used for {{Entry|Version identifier, Version download and {{Import|Source link and Source packages
+- there's also Uploaders field in Source, but it is not as good as the changelog which is more precise on the version
+-}
+data Source = Source
+ {sPackage :: Text, sVersion :: Text, sFile :: Text, sHomepage :: Maybe Text}
+ deriving (Show)
+
+instance ToRow Source where
+ toRow (Source a b c d) = toRow (a, b, c, d)
+
+instance FromRow Source where
+ fromRow = Source <$> field <*> field <*> field <*> field
+
+{- Package
+- obtained from dist/Packages.gz
+- pPackage, pVersion: key, package and version
+ - comes from Package and Version
+- homepage: used for {{Entry|Homepage URL
+ - comes from Homepage
+ - also available in Sources.gz
+- tags: used for {{Entry|Computer languages (implementing lang)
+ - can also be used for use, works-with etc.
+-}
+
+data Package = Package
+ { pPackage :: Text,
+ pVersion :: Text,
+ pHomepage :: Maybe Text,
+ pTags :: Tags
+ }
+ deriving (Show)
+
+newtype Tags = Tags {unTags :: [Text]} deriving (Show, Eq)
+
+instance ToRow Package where
+ toRow (Package a b c d) = toRow (a, b, c, T.intercalate "," $ unTags d)
+
+instance FromRow Package where
+ fromRow = Package <$> field <*> field <*> field <*> field
+
+instance FromField Tags where
+ fromField f = Tags <$> T.splitOn "," <$> fromField f
+
+{- Translation
+- obtained from dist
+- tPackage: key, package name
+ - comes from Package
+- (shortDesc, fullDesc) are for {{Entry|Short description and {{Entry|Full description
+ - comes from Description-en.syn and .full (formatted text with syn)
+-}
+data Translation = Translation
+ { tPackage :: Text,
+ tShortDesc :: Text,
+ tFullDesc :: Text
+ }
+ deriving (Show)
+
+instance ToRow Translation where
+ toRow (Translation a b c) = toRow (a, b, c)
+
+instance FromRow Translation where
+ fromRow = Translation <$> field <*> field <*> field
+
+{- ChangeLog
+- obtained from metaftp
+- the latest changelog entry
+- clPacakge and clVersion are keys, ignores on mismatch
+- author is used for {{Project license|License verified by
+- timeStamp for {{Project license|License verified date
+-}
+data FSDChangeLogEntry = FSDChangeLogEntry
+ { clPackage :: Text,
+ clVersion :: Text,
+ clAuthor :: Text,
+ clTimestamp :: UTCTime
+ }
+ deriving (Show)
+
+instance ToRow FSDChangeLogEntry where
+ toRow (FSDChangeLogEntry a b c d) = toRow (a, b, c, d)
+
+instance FromRow FSDChangeLogEntry where
+ fromRow = FSDChangeLogEntry <$> field <*> field <*> field <*> field
+
+-- copyright types
+
+{-
+- upstreamName is used for {{Entry|Name
+ - stores upstream package name (canonical name);
+ - comes from Upstream-Name; defined to be name used by upstream;
+ - some copyright files use Upstream-Name for contacts (but not often), which is rather hard to detect ("Foo Library" and "John Doe" are of the same format"), so we take it at face value
+- contacts is used for {{Person|Real name and {{Person|Email with Role=contact
+ - stores contact name and email address;
+ - comes from Upstream-Contact (line-based list)
+ - may contain urls which are ignored
+- sources is used for {{Resource|Resource URL with {{Resource|Resource kind=Download
+ - stores resource urls with download kind;
+ - comes from Source (formatted text with no synopsis), in practice all in url form
+ - so we parse it as whitespace separated list of urls
+-}
+
+data Contact = Contact
+ { coName :: Maybe Text,
+ coEmail :: Text
+ }
+ deriving (Show)
+
+serializeContacts :: [Contact] -> Text
+serializeContacts = T.intercalate ";" . fmap serializeContact
+
+serializeContact :: Contact -> Text
+serializeContact (Contact name email) =
+ T.concat [(fromMaybe "" name), ",", email]
+
+deserializeContacts :: Text -> [Contact]
+deserializeContacts contacts =
+ if T.null contacts
+ then []
+ else catMaybes $ deserializeContact <$> T.splitOn ";" contacts
+
+deserializeContact :: Text -> Maybe Contact
+deserializeContact raw =
+ case T.splitOn "," raw of
+ [_, ""] -> Nothing
+ [name, email] ->
+ Just $ Contact (if T.null name then Nothing else Just name) email
+ otherwise -> Nothing
+
+data Upstream = Upstream
+ { uPackage :: Text,
+ uName :: Maybe Text,
+ uContacts :: [Contact],
+ uSources :: SourceUrls
+ }
+ deriving (Show)
+
+newtype SourceUrls = SourceUrls {unSources :: [Text]} deriving (Eq, Show)
+
+instance ToRow Upstream where
+ toRow (Upstream a b contacts sources) =
+ toRow
+ ( a,
+ b,
+ serializeContacts contacts,
+ T.intercalate "\n" $ unSources sources
+ )
+
+instance FromRow Upstream where
+ fromRow = Upstream <$> field <*> field <*> field <*> field
+
+instance FromField SourceUrls where
+ fromField f = SourceUrls <$> T.splitOn "\n" <$> fromField f
+
+instance FromField [Contact] where
+ fromField f = deserializeContacts <$> fromField f
+
+{- License Information
+- we need to filter out debian/* Files
+- copyright is used for {{Project license|License copyright
+ - comes from Files.Copyright and Header.Copyright (formatted text no syn)
+- license is used for {{Project license|License
+ - comes from Files.License.syn and Header.License.syn (formatted text with syn)
+ - we treat multi-licensing license as one (e.g. "GPL-2+ or MPL" is a valid license field)
+- note is used for {{Project license|License note
+ - comes from Files.License.full and Header.License.full (formatted text with syn), or in case of missing fulls, License.full (formatted text with syn) for matching syn
+-}
+data LicenseInfo = LicenseInfo
+ { lCopyright :: Maybe Text,
+ lLicense :: Text,
+ lNote :: Maybe Text
+ }
+ deriving (Show)
+
+instance FromRow LicenseInfo where
+ fromRow = LicenseInfo <$> field <*> field <*> field
+
+{- Obtained from copyright files
+- formatted as https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
+- nonformatted files are ignored
+-}
+data Copyright = Copyright
+ { crPackage :: Text,
+ crLicenses :: [LicenseInfo]
+ }
+ deriving (Show)
+
+data PackageInfo = PackageInfo
+ { piPackage :: Text,
+ piVersion :: Text,
+ piTimestamp :: UTCTime, -- time the PackageInfo is created
+ piFile :: Text,
+ piHomepage :: Maybe Text,
+ piTags :: [Text],
+ piShortDesc :: Text,
+ piFullDesc :: Text,
+ piUpstreamName :: Maybe Text,
+ piContacts :: [Contact],
+ piSources :: [Text],
+ piLicenses :: [LicenseInfo],
+ piCLAuthor :: Text,
+ piCLTimestamp :: UTCTime
+ }
+ deriving (Show)
+
+{- TODO
+- [X] refactor Copyright into CRHeader (with a chPackage) and CRLicense (with a crPackage)
+- refactor so that homepage comes from source overriding package
+- refactor so that shordesc from translations overriding source overriding package
+- refactor so that things get assembled into a big ass object writing to various entries
+- add a (Debian changelog author) to license verifier
+- make sure the db creation works as expected (especially primary key on conflict replace
+- utilise indexes in db
+-}
diff --git a/src/FSD/Wiki.hs b/src/FSD/Wiki.hs
new file mode 100644
index 0000000..78e43f0
--- /dev/null
+++ b/src/FSD/Wiki.hs
@@ -0,0 +1,156 @@
+{-
+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.Wiki (formatWikiEntry) where
+
+import Data.Maybe
+import Data.List.Extra
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Time
+import FSD.Types
+
+data WikiTemplate = WikiTemplate
+ { templateName :: Text,
+ templateParams :: [(Text, Text)]
+ }
+
+formatTemplate :: WikiTemplate -> Text
+formatTemplate (WikiTemplate name params) =
+ T.unlines $
+ (T.concat ["{{", name]) :
+ ( fmap
+ (\(key, val) -> T.concat ["|", key, "=", val])
+ params
+ )
+ ++ ["}}"]
+-- The main function that formats a PackageInfo to a wiki entry
+formatWikiEntry :: PackageInfo -> Text
+formatWikiEntry package =
+ formatWikiEntry' $
+ (wtEntry package) : (wtImport package) : wtLicenses package
+ ++ wtPersons package ++ wtResources package
+
+type WikiEntry = [WikiTemplate]
+
+formatWikiEntry' :: WikiEntry -> Text
+formatWikiEntry' = T.concat . fmap formatTemplate
+
+-- https://directory.fsf.org/wiki/Template:Entry
+wtEntry :: PackageInfo -> WikiTemplate
+wtEntry package =
+ WikiTemplate "Entry"
+ -- this may cause problems some times, like 0ad-data which is a
+ -- separate package from 0ad, but with the same upstream name (0ad),
+ -- and can cause overwrite of 0ad info
+ [ ("Name", fromMaybe (piPackage package) (piUpstreamName package)),
+ ("Short description", piShortDesc package),
+ ("Full description", piFullDesc package),
+ ("Homepage", fromMaybe "" $ piHomepage package),
+ ("Computer languages", formatImplLangs package),
+ ("Version identifier", piVersion package),
+ ("Version download", getDlUrl package),
+ ("Submitted by", "Debian import"),
+ ("Submitted date", T.pack $ show $ utctDay $ piTimestamp package)
+ ]
+
+formatImplLangs :: PackageInfo -> Text
+formatImplLangs package =
+ T.intercalate "," $ catMaybes $ getLang <$> tagList
+ where tags = piTags package
+ tagList = filter (\tag -> head tag == "implemented-in") (T.splitOn "::" <$> tags)
+ getLang xs = xs !? 1
+
+getDlUrl :: PackageInfo -> Text
+getDlUrl package =
+ T.concat
+ ["http://ftp.debian.org/debian/pool/main/"
+ , if T.isPrefixOf "lib" name then T.take 4 name else T.take 1 name
+ , "/", name, "/", file]
+ where
+ name = piPackage package
+ file = piFile package
+
+-- TODO
+-- https://directory.fsf.org/wiki/Template:Software_category
+{-
+{{Software category
+|Game=game::
+|Interface=interface::
+|Protocol=protocol::
+|Use=use::
+...
+}}
+-}
+
+-- https://directory.fsf.org/wiki/Template:Import
+makeLink :: Text -> Text
+makeLink name = T.concat ["http://packages.debian.org/stable/", name]
+
+wtImport :: PackageInfo -> WikiTemplate
+wtImport package =
+ WikiTemplate
+ "Import"
+ [("Source", "Debian"), ("Source link", makeLink $ piPackage package),
+ ("Date", T.pack $ show $ utctDay $ piTimestamp package)]
+
+-- https://directory.fsf.org/wiki/Template:Project_license
+wtLicenses :: PackageInfo -> [WikiTemplate]
+wtLicenses package =
+ wtLicense (piCLAuthor package)
+ (T.pack $ show $ utctDay $ piCLTimestamp package) <$>
+ (piLicenses package)
+
+wtLicense :: Text -> Text -> LicenseInfo -> WikiTemplate
+wtLicense author time info =
+ WikiTemplate
+ "Project license"
+ [ ("License", lLicense info),
+ ("License copyright", fromMaybe "" $ lCopyright info),
+ ("License verified by", author),
+ ("License verified date", time),
+ ("License note", fromMaybe "" $ lNote info)
+ ]
+
+-- https://directory.fsf.org/wiki/Template:Person
+data WTPerson = WTPerson
+ { wpName :: Text,
+ wpRole :: Text,
+ wpEmail :: Text
+ }
+
+wtPerson :: Contact -> WikiTemplate
+wtPerson (Contact name email) =
+ WikiTemplate
+ "Person"
+ [("Real name", fromMaybe "" name), ("Role", "contact"), ("Email", email)]
+
+wtPersons :: PackageInfo -> [WikiTemplate]
+wtPersons info = wtPerson <$> piContacts info
+
+-- https://directory.fsf.org/wiki/Template:Resource
+wtResources :: PackageInfo -> [WikiTemplate]
+wtResources package =
+ (\url -> WikiTemplate "Resource"
+ [("Resource kind", "Download"), ("Resource URL", url)]) <$>
+ piSources package
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..833c999
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,312 @@
+{-
+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 OverloadedStrings #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE TypeOperators #-}
+
+import System.Process hiding (runCommand)
+import Data.List.Extra
+import System.FilePath
+import FSD.ChangeLog
+import FSD.Download
+import FSD.Control
+import Control.Exception
+import Control.Monad
+import FSD.Copyright
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Maybe
+import Database.SQLite.Simple
+import FSD.Db
+import Debian.Changes
+import Debian.Control
+import Options.Applicative
+import FSD.Package
+import FSD.PackageInfo
+import FSD.Source
+import Text.Show.Pretty hiding (List)
+import FSD.Translation
+import FSD.Types
+import FSD.Wiki
+import System.IO
+
+main :: IO ()
+main = do
+ (options, command) <- execParser opts
+ runCommand options command
+ where
+ opts = info (progParser <**> helper)
+ ( fullDesc
+ <> progDesc "FSD import utility"
+ <> header "fsd - a tool to import from Debian and export to FSD entries.")
+
+runCommand :: Options -> Command -> IO ()
+runCommand opts cmd = withFsDb (database opts) $ \db ->
+ case cmd of
+ Init -> initConn db
+ Get target -> do
+ when (target == TAll || target == TSources) $
+ downloadSources (distDir opts) >> return ()
+ when (target == TAll || target == TPackages) $
+ downloadPackages (distDir opts) >> return ()
+ when (target == TAll || target == TTranslation) $
+ downloadTranslation (distDir opts) >> return ()
+ when (target == TAll || target == TChangelog) $
+ getMetadataFiles db (distDir opts) (nWorkers opts) MTChangelog
+ >> return ()
+ when (target == TAll || target == TCopyright) $
+ getMetadataFiles db (distDir opts) (nWorkers opts) MTCopyright
+ >> return ()
+ Import target -> do
+ when (target == TAll || target == TSources) $
+ readControl <$>
+ (readFile $ (distDir opts) </> "Sources") >>= insertSources db
+ when (target == TAll || target == TPackages) $
+ readControl <$>
+ (readFile $ (distDir opts) </> "Packages") >>= insertPackages db
+ when (target == TAll || target == TTranslation) $
+ readControl <$> (readFile $ (distDir opts) </> "Translation-en")
+ >>= insertTranslations db
+ when (target == TAll || target == TChangelog) $
+ insertChangeLogEntries db (distDir opts)
+ when (target == TAll || target == TCopyright) $
+ insertCopyUps db (distDir opts)
+ Export names ->
+ if null names then exportWikiAll db (exportDir opts) else
+ mapM_ (\name -> do
+ allTypes <- (getDbAllTypes (T.pack name) db)
+ when (isJust allTypes) $
+ exportWiki db (exportDir opts) (fromJust allTypes)) names
+ List -> T.unpack . T.unlines <$> getDbPkgNames db >>= putStr
+ otherwise -> error "Unimplemented"
+
+{- USAGE
+fsd init
+fsd get sources | packages | translation | changelog | copyright | all
+fsd import sources | packages | translation | changelog | copyright | all
+fsd export [pkgNames]
+fsd list
+fsd clean -- unimplemented
+fsd show [--debug] <pkgName> -- unimplemented
+-}
+
+data Options = Options
+ { database :: FilePath,
+ distDir :: FilePath,
+ nWorkers :: Int,
+ exportDir :: FilePath
+ }
+
+data Command
+ = Init -- consider creating directories during init
+ | Get Target
+ | Import Target
+ | Export [String]
+ | List
+ | Clean
+ | Show_ String
+
+data Target
+ = TAll
+ | TSources
+ | TPackages
+ | TTranslation
+ | TChangelog
+ | TCopyright
+ deriving Eq
+
+progParser :: Parser (Options, Command)
+progParser = (,) <$> optParser <*> cmdParser
+
+optParser :: Parser Options
+optParser
+ = Options
+ <$> strOption (long "database" <> short 'd' <> metavar "DATABASE"
+ <> value "./directory.db" <> showDefault
+ <> help "Database store of imported package info.")
+ <*> strOption (long "dist-dir" <> short 'm' <> metavar "DISTDIR"
+ <> value "./distfiles" <> showDefault
+ <> help "Root directory to files downloaded from debian.")
+ <*> option auto (long "nworkers" <> short 'n' <> metavar "NWORKERS"
+ <> value 4 <> showDefault
+ <> help "Number of wget workers for downloading changelog \
+ \and copyright files.")
+ <*> strOption (long "export-dir" <> short 'e' <> metavar "EXPORTDIR"
+ <> value "./wiki" <> showDefault
+ <> help "Directory to place the exported .wiki files.")
+
+cmdParser :: Parser Command
+cmdParser = hsubparser
+ $ command "init" (info (pure Init) $ progDesc "Initilise database")
+ <> command "get" (info (Get <$> targetParser) $ progDesc
+ "Download index and metadata files.")
+ <> command "import" (info (Import <$> targetParser) $ progDesc
+ "Import package info from local index and metadata files.")
+ <> command "export" (info (Export <$> many pkgNameParser) $ progDesc
+ "Export packages to .wiki files.")
+ <> command "list" (info (pure List) $ progDesc "List imported packages")
+
+target :: ReadM Target
+target = eitherReader $ \s -> case s of
+ "all" -> Right TAll
+ "sources" -> Right TSources
+ "packages" -> Right TPackages
+ "translation" -> Right TTranslation
+ "changelog" -> Right TChangelog
+ "copyright" -> Right TCopyright
+ otherwise -> Left "TARGET can be all, sources, packages, \
+ \translation, changelog or copyright"
+
+targetParser :: Parser Target
+targetParser = argument target (metavar "TARGET")
+
+pkgNameParser :: Parser String
+pkgNameParser = strArgument (metavar "PKGNAME")
+
+getMetadataFiles :: FsDb -> FilePath -> Int -> MetadataType -> IO [ProcessHandle]
+getMetadataFiles db root n mtype = do
+ names <- getDbPkgNames db
+ writeWgetListFiles root mtype names n
+ downloadMetadataFiles root mtype n
+
+insertSources :: FsDb -> Control -> IO ()
+insertSources db control = do
+ let sources = getSources control
+ putStr $ "Importing " ++ show (length sources) ++ " sources..."
+ hFlush stdout
+ mapM_ (insertSource db) sources
+ putStrLn "Done."
+
+insertPackages :: FsDb -> Control -> IO ()
+insertPackages db control = do
+ let packages = getPackages control
+ putStr $ "Importing " ++ show (length packages) ++ " packages..."
+ hFlush stdout
+ mapM_ (insertPackage db) packages
+ putStrLn "Done."
+
+insertTranslations :: FsDb -> Control -> IO ()
+insertTranslations db control = do
+ let translations = getTranslations control
+ putStr $ "Importing " ++ show (length translations) ++ " translations..."
+ hFlush stdout
+ mapM_ (insertTranslation db) translations
+ putStrLn "Done."
+
+insertChangeLogEntries :: FsDb -> FilePath -> IO ()
+insertChangeLogEntries db root = do
+ paths <- getChangeLogPaths root
+ putStr $ "Importing " ++ show (length paths) ++ " changelogs..."
+ hFlush stdout
+ mapM_ (\path -> do
+ change' <- (readChangeLog <$> readFile path)
+ when (isJust change') $
+ insertChangeLogEntry db $ fromJust change') paths
+
+getChangeLogPaths :: FilePath -> IO [FilePath]
+getChangeLogPaths root = do
+ lines <$>
+ readCreateProcess
+ (shell $ "find " ++ root ++ " -name 'stable_changelog' ") ""
+
+insertChangeLogEntry :: FsDb -> ChangeLogEntry -> IO ()
+insertChangeLogEntry db entry =
+ let entry' = convertChangeLogEntry entry in
+ when (isJust entry') (insertFSDChangeLogEntry db $ fromJust entry')
+
+insertCopyUps :: FsDb -> FilePath -> IO ()
+insertCopyUps db root = do
+ pairs <- getCopyrightPathsAndNames root
+ putStr $ "Importing " ++ show (length pairs) ++ " copyright files..."
+ hFlush stdout
+ mapM_ (\(name, path) ->
+ catch (readControl <$> readFile' path >>= insertCopyUp db name)
+ (\e ->
+ hPutStr stderr
+ ("Warning: error while processing " ++ path ++ ": " ++
+ show (e :: SomeException) ++ "\n"))
+ ) pairs
+
+getNameFromMetadataPath :: FilePath -> Maybe Text
+getNameFromMetadataPath path =
+ case split (=='/') path of
+ [] -> Nothing
+ [x] -> Nothing
+ xs -> Just $ T.pack $ last $ init xs
+
+getCopyrightPathsAndNames :: FilePath -> IO [(Text, FilePath)]
+getCopyrightPathsAndNames root = do
+ paths <- lines <$>
+ readCreateProcess
+ (shell $ "find " ++ root ++ " -name 'stable_copyright' ") ""
+ return $ catMaybes $ maybePair <$> paths
+ where
+ maybePair path = case getNameFromMetadataPath path of
+ Just name -> Just (name, path)
+ Nothing -> Nothing
+
+insertCopyUp :: FsDb -> Text -> Control -> IO ()
+insertCopyUp db package control = case parseCopyright package control of
+ Nothing -> return ()
+ Just (upstream, copyright) ->
+ insertUpstream db upstream >> insertCopyright db copyright
+
+exportWiki ::
+ FsDb -> FilePath ->
+ Source :. Package :. Translation :. FSDChangeLogEntry :. Upstream ->
+ IO ()
+exportWiki db dir (source :. package :. trans :. change :. upstream) = do
+ copyright <- getDbCopyright (sPackage source) db
+ wiki <- case copyright of
+ Nothing -> return Nothing
+ Just copyright' ->
+ fmap formatWikiEntry
+ <$> makePackageInfo source package trans change upstream copyright'
+ when (isJust wiki) $
+ writeFile (dir ++ "/" ++ (T.unpack $ sPackage source) ++ ".wiki")
+ (T.unpack $ fromJust wiki)
+
+exportWikiAll :: FsDb -> FilePath -> IO ()
+exportWikiAll db dir = do
+ allTypes <- getDbAll db
+ putStr $ "Exporting up to " ++ show (length allTypes) ++ " entries..."
+ hFlush stdout
+ mapM_ (exportWiki db dir) allTypes
+
+
+-- tests
+
+testSources =
+ getSources <$> readControl <$> (readFile "./distfiles/Sources-short") >>= pPrint
+
+testPackages =
+ getPackages <$> readControl <$> (readFile "./distfiles/Packages-short") >>= pPrint
+
+testTranslation =
+ getTranslations <$> readControl <$> (readFile "./distfiles/Translation-en-short") >>= pPrint
+
+testCopyright = do
+ result <- try (readFile' "./metadata.ftp-master.debian.org/changelogs/main/d/dbix-easy-perl/stable_copyright") :: IO (Either SomeException String)
+ either (\ex -> pPrint ex) (\content -> (pPrint . parseCopyright "dbix-easy-perl" . readControl) content) result
+
+testChangeLog :: IO ()
+testChangeLog = do
+ getChangeLogEntry <$> (readFile "./metadata.ftp-master.debian.org/changelogs/main/e/emacs/stable_changelog") >>= pPrint