diff --git a/mbug.cabal b/mbug.cabal --- a/mbug.cabal +++ b/mbug.cabal @@ -1,88 +1,88 @@ --- This file has been generated from package.yaml by hpack version 0.28.2. --- --- see: https://github.com/sol/hpack --- --- hash: b33e31546f0bfe98b914770fbdde88baf6e998a04048d923660069706267a9ea - -name: mbug -version: 1.2 -synopsis: download bugs mailboxes -description: See readme at https://gitlab.com/iu-guest/mbug -category: Debian -homepage: https://gitlab.com/iu-guest/mbug -author: Dmitry Bogatov -maintainer: KAction@gnu.org -copyright: 2018 Dmitry Bogatov -license: GPL-3 -license-file: LICENSE -build-type: Simple -cabal-version: >= 1.10 +cabal-version: >=1.10 +name: mbug +version: 1.3 +license: GPL-3 +license-file: LICENSE +copyright: 2018 Dmitry Bogatov +maintainer: KAction@gnu.org +author: Dmitry Bogatov +homepage: https://gitlab.com/iu-guest/mbug +synopsis: download bugs mailboxes +description: + See readme at https://gitlab.com/iu-guest/mbug +category: Debian +build-type: Simple extra-source-files: README.md flag devel - description: Enable -Werror GHC flag. Use only during development! - manual: True - default: False + description: + Enable -Werror GHC flag. Use only during development! + default: False + manual: True library - exposed-modules: - MBug.Main - MBug.Data.Bug - MBug.Data.FolderMH - MBug.Options - MBug.Scrape - MBug.Cache - MBug.MH - Data.Maybe.Extended - Text.HTML.Scalpel.Core.Extended - other-modules: - Data.Text.Compat - Options.Applicative.Compat - Paths_mbug - hs-source-dirs: - src - build-depends: - base >=4.9 && <5 - , bytestring ==0.10.* - , directory ==1.3.* - , extra >=1.5 && <1.7 - , formatting >=6.0 && <6.4 - , http-client ==0.5.* - , http-client-tls ==0.3.* - , optparse-applicative >=0.13 && <0.15 - , process >=1.4 && <1.7 - , scalpel-core ==0.5.* - , tagsoup ==0.14.* - , text ==1.2.* - , time >=1.6 && <1.9 - , xdg-basedir ==0.2.* - if flag(devel) - ghc-options: -Wall -Wextra -Werror -Wincomplete-patterns -Wunused-imports - default-language: Haskell2010 + exposed-modules: + MBug.Main + MBug.Data.Bug + MBug.Data.FolderMH + MBug.Options + MBug.Scrape + MBug.Cache + MBug.MH + Data.Maybe.Extended + Text.HTML.Scalpel.Core.Extended + hs-source-dirs: src + other-modules: + Data.Text.Compat + Options.Applicative.Compat + Paths_mbug + default-language: Haskell2010 + build-depends: + base >=4.9 && <5, + bytestring ==0.10.*, + directory ==1.3.*, + extra >=1.5 && <1.7, + formatting >=6.0 && <6.4, + http-client ==0.5.*, + http-client-tls ==0.3.*, + mtl >=2.2.2 && <2.3, + optparse-applicative >=0.13 && <0.15, + process >=1.4 && <1.7, + scalpel-core ==0.5.*, + tagsoup ==0.14.*, + text ==1.2.*, + time >=1.6 && <1.9, + xdg-basedir ==0.2.* + + if flag(devel) + ghc-options: -Wall -Wextra -Werror -Wincomplete-patterns + -Wunused-imports executable mbug - main-is: mbug.hs - other-modules: - Paths_mbug - hs-source-dirs: - bin - build-depends: - base >=4.9 && <5 - , bytestring ==0.10.* - , directory ==1.3.* - , extra >=1.5 && <1.7 - , formatting >=6.0 && <6.4 - , http-client ==0.5.* - , http-client-tls ==0.3.* - , mbug - , optparse-applicative >=0.13 && <0.15 - , process >=1.4 && <1.7 - , scalpel-core ==0.5.* - , tagsoup ==0.14.* - , text ==1.2.* - , time >=1.6 && <1.9 - , xdg-basedir ==0.2.* - if flag(devel) - ghc-options: -Wall -Wextra -Werror -Wincomplete-patterns -Wunused-imports - default-language: Haskell2010 + main-is: mbug.hs + hs-source-dirs: bin + other-modules: + Paths_mbug + default-language: Haskell2010 + build-depends: + base >=4.9 && <5, + bytestring ==0.10.*, + directory ==1.3.*, + extra >=1.5 && <1.7, + formatting >=6.0 && <6.4, + http-client ==0.5.*, + http-client-tls ==0.3.*, + mbug -any, + mtl >=2.2.2 && <2.3, + optparse-applicative >=0.13 && <0.15, + process >=1.4 && <1.7, + scalpel-core ==0.5.*, + tagsoup ==0.14.*, + text ==1.2.*, + time >=1.6 && <1.9, + xdg-basedir ==0.2.* + + if flag(devel) + ghc-options: -Wall -Wextra -Werror -Wincomplete-patterns + -Wunused-imports diff --git a/src/MBug/Main.hs b/src/MBug/Main.hs --- a/src/MBug/Main.hs +++ b/src/MBug/Main.hs @@ -4,6 +4,8 @@ module MBug.Main (main) where import Control.Monad (mapM, mapM_, (>=>)) +import Control.Monad.Reader (ReaderT, runReaderT, ask) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Extra (whenM) import qualified Data.ByteString.Lazy as BL import Data.Text (Text) @@ -11,6 +13,7 @@ import Data.Text.Encoding (encodeUtf8) import MBug.Cache (cachedIO, cachedIO_) import MBug.Data.Bug (Bug (..)) +import MBug.Data.FolderMH (FolderMH(..)) import qualified MBug.MH as MH import MBug.Options (Options (..), options, showFolderMH) import MBug.Scrape (parseBugs) @@ -29,8 +32,9 @@ , removeDirectoryRecursive ) import System.Process (callProcess) -import Formatting (sformat, formatToString, (%)) -import Formatting.Formatters (int, string) +import Text.Read (readMaybe) +import Formatting (fprint, sformat, formatToString, (%)) +import Formatting.Formatters (int, string, stext) -- | 'Request' value, representing Debian Bugs System. Adjust 'path' and -- 'query' as needed. @@ -58,27 +62,69 @@ -- | Download mbox of given bug, store it in file and return path to -- that file. -downloadMBox :: Manager -> Bug -> IO FilePath -downloadMBox manager (Bug {..}) = fmap fst $ cachedIO label requested +downloadMBox :: Manager -> Int -> IO FilePath +downloadMBox manager nnn = fmap fst $ cachedIO label requested where - label = T.pack . show $ _number - requested = fmap responseBody $ httpLbs (mboxRequest _number) manager + label = T.pack . show $ nnn + requested = fmap responseBody $ httpLbs (mboxRequest nnn) manager +-- | Dowload mailbox, corresponding to bug of given name and +-- incorporate it into specified folder in MH storage. +incorporate :: FolderMH -> Int -> ReaderT Manager IO () +incorporate folder nnn = do + manager <- ask + liftIO $ do + let fmt = string % "/bug" % int + folder' = showFolderMH folder + destination = formatToString fmt folder' nnn + mbox <- downloadMBox manager nnn + let args = ["-silent", "-file", mbox, destination] + callProcess "/usr/bin/mh/inc" args + +-- | Return list of 'Bug's, matching specified search query. +listBugs :: Text -> ReaderT Manager IO [Bug] +listBugs q = do + manager <- ask + liftIO $ act =<< (parseBugs <$> cachedResponse manager q) + where + act = \case + Nothing -> error "please report to maintainer how to reproduce it." + Just x -> pure x + +-- | Remove MH folder and all its subfolders. Unfortunately, rmf(1) +-- utility is not designed to handle this case, so this function is +-- implemented by manipulating file system directory directly, beyond +-- mh(7) toolkit. +cleanFolderMH :: (MonadIO m) => FolderMH -> m () +cleanFolderMH folder = liftIO $ do + path <- MH.resolve folder + whenM (doesDirectoryExist path) $ + removeDirectoryRecursive path + +-- | Incorporate specified 'Bug' with fancy visual clues on stdout. +incorporateBug :: FolderMH -> Bug -> ReaderT Manager IO () +incorporateBug folder Bug{..} = do + let fmt = "[#" % int % "] " % stext % "... " + before = fprint fmt _number _subject + after = fprint "ok\n" + liftIO before + incorporate folder _number + liftIO after + main :: IO () main = do Options {..} <- options manager <- newTlsManager - response <- cachedResponse manager _query - case parseBugs response of - Nothing -> putStrLn "error! please report to maintainer how to reproduce it." - Just [] -> putStrLn "no bugs found. Nothing to do." - Just bugs -> do - let download bug = do mbox <- downloadMBox manager bug - pure (bug, mbox) - incorporate (Bug {..}, mbox) = - let destination = formatToString (string%"/bug"%int) (showFolderMH _folder) _number - in callProcess "/usr/bin/mh/inc" - ["-silent", "-file", mbox, destination] - MH.resolve _folder >>= \path -> whenM (doesDirectoryExist path) - (removeDirectoryRecursive path) - (mapM download >=> mapM_ incorporate) bugs + flip runReaderT manager $ + case readMaybe (T.unpack _query) of + Just nnn -> do + liftIO $ fprint ("Incorporating #" % int % "... ") nnn + cleanFolderMH _folder + incorporate _folder nnn + liftIO $ fprint "ok\n" + Nothing -> + listBugs _query >>= \case + [] -> liftIO $ putStrLn "no bugs found. Nothing to do." + bugs -> do + cleanFolderMH _folder + mapM_ (incorporateBug _folder) bugs