path: root/src/Main.hs

{-
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