diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 312 |
1 files changed, 312 insertions, 0 deletions
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 |