hark-0.2: src/hark.hs
{-----------------------------------------------------------------
(c) 2008-2009 Markus Dittrich
This program is free software; you can redistribute it
and/or modify it under the terms of the GNU General Public
License Version 3 as published by the Free Software Foundation.
This program 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 General Public License Version 3 for more details.
You should have received a copy of the GNU General Public
License along with this program; if not, write to the Free
Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
--------------------------------------------------------------------}
-- | hark is a tool for querying installed packages on a Gentoo
-- Linux system
-- imports
import qualified Data.ByteString.Char8 as BC(pack)
import Prelude
import System.Directory(doesFileExist, setCurrentDirectory)
import System.Exit(exitWith, ExitCode(..))
-- local imports
import Drivers.Depend(search_for_depends)
import Drivers.Content(display_package_contents,
display_binary_package_contents, display_etc_package_contents,
display_doc_package_contents, display_include_package_contents,
display_library_package_contents, display_share_package_contents)
import Drivers.Owner(display_file_owner)
import Drivers.SearchPackage(search_for_packages_detailed,
search_for_packages_short)
import Drivers.Use(search_for_use_all, search_for_use_used)
import Helpers.Common(find_package_paths, get_categories,
strip_category)
import Helpers.FileIO(dataBaseDir)
import Helpers.PrettyPrint(Color(..), putColorStr, putColorStrLn)
import Parsers.CommandLine(ArgOrder(..), defaultOptions, getArgs,
getOpt, Query(..), options, Options(..), show_usage, usageInfo)
--import Debug.Trace
-- | main driver routine
main :: IO ()
main =
-- parse command line
getArgs
>>= \args ->
let
( actions, nonOpts, _) = getOpt RequireOrder options args
in
foldl (>>=) ( return defaultOptions ) actions
>>= \opts ->
-- assign command line options
let
Options { theQuery = request } = opts
in
-- retrieve all categories from database
get_categories dataBaseDir
>>= \categories -> setCurrentDirectory dataBaseDir
-- check for supplied patterns and then call the
-- appropriate handler if any patterns given, otherwise abort
-- FIXME: For now we only call the handler for the first
-- pattern supplied on the command line even if
-- more are given. Should we instead loop over them
-- all on at a time?
>> if null nonOpts
then (putColorStrLn Red $ "\nERROR: No pattern supplied.\n")
>> show_usage opts
>> return ()
else
case request of
None -> show_usage opts >> return ()
UseAll -> handle_use_all categories (head nonOpts)
UseUsed -> handle_use_used categories (head nonOpts)
_ -> handle_path_request request categories
(head nonOpts)
-- | main request handler dealing with request to show
-- packages that have a certain USE flag
handle_use_all :: [FilePath] -> String -> IO ()
handle_use_all categories useFlag =
message "packages that have" ("IUSE = " ++ useFlag)
>> search_for_use_all categories (BC.pack useFlag)
-- | main request handler dealing with request to show
-- packages that have and were emerged with a certain
-- USE flag
handle_use_used :: [FilePath] -> String -> IO ()
handle_use_used categories useFlag =
message "packages that were emerge with" ("USE = " ++ useFlag)
>> search_for_use_used categories (BC.pack useFlag)
-- | main request handler dealing with requests involving
-- some type of category/package name type request.
-- Dispatches the proper routine depending on the user request
handle_path_request :: Query -> [FilePath] -> String -> IO ()
handle_path_request request categories pattern =
-- if the user supplied a full category/name
-- entry we strip the category and search only
-- the relevant subdirectory for efficiency
let
(strippedPattern, strippedPaths) = strip_category pattern
categories
in
-- dispatch on user selection
case request of
-- quick search for package; no need to make sure that the
-- requested package exists since we're searching
SearchShort -> message "package(s) matching" pattern
>> search_for_packages_short (BC.pack strippedPattern)
strippedPaths
-- detailed search for package; no need to make sure that the
-- requested package exists since we're searching
SearchDetailed -> message "package(s) matching" pattern
>> search_for_packages_detailed (BC.pack strippedPattern)
strippedPaths
-- display package owning a particular file
Owner -> message "package owning" pattern
-- check if the user supplied path exists, if so, try
-- to find a match
>> doesFileExist pattern
>>= \isFile ->
case isFile of
False -> putColorStrLn Cyan $ "ERROR: " ++ pattern
++ "is not a file"
True -> display_file_owner pattern categories
-- dispatch on options that require unique filename
_ -> find_package_paths strippedPattern strippedPaths
>>= \result ->
case length result of
0 -> print_no_match
1 -> dispatch_unique_request categories request
pattern (head result)
_ -> print_multiple_pkg_error result
-- | dispatch on options that require a unique file path
dispatch_unique_request :: [FilePath] -> Query -> String
-> FilePath -> IO ()
dispatch_unique_request paths request pattern targetPath =
case request of
-- search for dependent packages (for all use flags)
DependUsed -> message "(USEd) dependencies of" pattern
>> search_for_depends targetPath paths True
-- search for dependent packages (for "used" use flags)
DependAll -> message "(USEd) dependencies of" pattern
>> search_for_depends targetPath paths False
-- display full content belonging to a package
Contents -> message "files installed by" pattern
>> display_package_contents targetPath
-- display binaries belonging to a package
BinContents -> message "binary files installed by" pattern
>> display_binary_package_contents targetPath
-- display docs belonging to a package
DocContents -> message "doc files installed by" pattern
>> display_doc_package_contents targetPath
-- display etc content belonging to a package
EtcContents -> message "etc files installed by" pattern
>> display_etc_package_contents targetPath
-- display all include files belonging to a package
IncludeContents -> message "include files installed by" pattern
>> display_include_package_contents targetPath
-- display all libraries belonging to a package
LibContents -> message "library files installed by" pattern
>> display_library_package_contents targetPath
-- display all content in share belonging to a package
ShareContents -> message "library files installed by" pattern
>> display_share_package_contents targetPath
-- default action
_ -> putStrLn $ usageInfo "Usage: hark [options]\n" options
-- | helper functions for printing status messages
message :: String -> String -> IO ()
message string pattern =
(putColorStr Magenta $ "\n*** Searching for " ++ string ++ " ")
>> (putColorStr Yellow $ pattern)
>> (putColorStr Magenta $ " ***\n")
-- | helper function for printing no matches
print_no_match :: IO ()
print_no_match = (putColorStrLn Red $ "\nERROR: No match found.\n")
>> (exitWith $ ExitFailure 1)
-- | helper function for printing multiple matches
print_multiple_pkg_error :: [FilePath] -> IO ()
print_multiple_pkg_error paths =
(putColorStr Red "WARNING: ")
>> (putStrLn "Search pattern matches multiple packages.")
>> (putStr "\t Please unambiguate via a category, version ")
>> (putStrLn "or slot.\n")
>> (mapM_ (putStrLn . (++) "\t " ) paths)
>> (exitWith $ ExitFailure 1)