Colin Woodbury avatar Colin Woodbury committed 1f4235d Merge

Merge branch 'dev'

Comments (0)

Files changed (10)

 -}
 
 {- POMODOROS
+Oct. 30 => X
 Oct. 21 => X
 -}
 
 import Aura.MakePkg
 import Aura.Pacman
 import Utilities
-import Internet
 import Shell
 import Zero
 import Bash
 -- The global settings as set by the user with command-line flags.
 data Settings = Settings { environmentOf   :: Environment
                          , langOf          :: Language
+                         , pacman          :: Pacman
                          , ignoredPkgsOf   :: [String]
                          , cachePathOf     :: FilePath
                          , logFilePathOf   :: FilePath
 type MaybePaths = Maybe [FilePath]
 
 -- Expects files like: /var/cache/pacman/pkg/*.pkg.tar.xz
-installPkgFiles :: [String] -> [FilePath] -> IO ExitCode
-installPkgFiles pacOpts files = pacman $ ["-U"] ++ pacOpts ++ files
+installPkgFiles :: Settings -> [String] -> [FilePath] -> IO ExitCode
+installPkgFiles ss pacOpts files = pacman ss $ ["-U"] ++ pacOpts ++ files
 
 -- All building occurs within temp directories in the package cache.
 buildPackages :: Settings -> [AURPkg] -> IO MaybePaths
 isInstalled :: String -> IO Bool
 isInstalled pkg = pacmanSuccess ["-Qq",pkg]
 
-isNotInstalled :: String -> IO Bool
-isNotInstalled pkg = pacmanFailure ["-Qq",pkg]
-
-isRepoPkg :: String -> IO Bool
-isRepoPkg pkg = pacmanSuccess ["-Si",pkg]
-
 -- Beautiful.
 filterAURPkgs :: [String] -> IO [String]
 filterAURPkgs pkgs = aurInfoLookup pkgs ?>>= return . map nameOf . fromRight
     where pkgs' = "^(" ++ prep pkgs ++ ")$"
           prep  = concat . intersperse "|"
 
--- A package is an AUR package if it's PKGBUILD exists on the Arch website.
--- Requires internet access.
-isAURPkg :: String -> IO Bool
-isAURPkg = doesUrlExist . getPkgbuildUrl
-
-isntAURPkg :: String -> IO Bool
-isntAURPkg pkg = not `liftM` isAURPkg pkg
-
--- A package is a virtual package if it has a provider.
-isVirtualPkg :: String -> IO Bool
-isVirtualPkg pkg = getProvidingPkg pkg ?>> return True
-
-countInstalledPackages :: IO Int
-countInstalledPackages = (length . lines) `liftM` pacmanOutput ["-Qsq"]
-
 getOrphans :: IO [String]
 getOrphans = lines `liftM` pacmanOutput ["-Qqdt"]
 
-removePkgs :: [String] -> [String] -> IO ExitCode
-removePkgs [] _         = returnSuccess
-removePkgs pkgs pacOpts = pacman $ ["-Rsu"] ++ pkgs ++ pacOpts
+removePkgs :: Settings -> [String] -> [String] -> IO ExitCode
+removePkgs _ [] _          = returnSuccess
+removePkgs ss pkgs pacOpts = pacman ss $ ["-Rsu"] ++ pkgs ++ pacOpts
 
 -------
 -- MISC  -- Too specific for `Utilities.hs`
 
 divideByPkgType :: [String] -> IO ([String],[String],[String])
 divideByPkgType pkgs = do
-  aurPkgNames  <- filterAURPkgs namesOnly
-  repoPkgNames <- filterRepoPkgs $ namesOnly \\ aurPkgNames
+  repoPkgNames <- filterRepoPkgs namesOnly
+  aurPkgNames  <- filterAURPkgs $ namesOnly \\ repoPkgNames
   let aurPkgs  = filter (flip elem aurPkgNames . splitName) pkgs
       repoPkgs = filter (flip elem repoPkgNames . splitName) pkgs
       others   = (pkgs \\ aurPkgs) \\ repoPkgs

Aura/Languages.hs

 --------------------------
 -- AurConnection functions
 --------------------------
-aurPkgInfoFields :: Language -> [String]
-aurPkgInfoFields English  = [ "Name","Version","AUR Status","Project URL"
-                            ,"AUR URL","License", "Votes","Description" ]
-aurPkgInfoFields Japanese = [ "名前","バージョン","パッケージ状態"
-                            , "プロジェクト","パッケージページ","ライセンス"
-                            ,"投票数","概要" ]
-aurPkgInfoFields Polish   = [ "Nazwa","Wersja","Status w AUR","URL Projektu"
-                            , "URL AUR", "Licencja","Głosy","Opis" ]
-aurPkgInfoFields Croatian = [ "Ime","Verzija","AUR Stanje","URL Projekta"
-                            , "AUR URL","Licenca","Glasovi","Opis" ]
-aurPkgInfoFields Swedish  = [ "Namn","Version","AUR Status","Projekt URL"
-                            , "AUR URL","Licens","Röster","Beskrivning"]
-aurPkgInfoFields German   = [ "Name","Version","AUR Status","Projekt URL"
-                            , "AUR URL","Lizenz","Stimmen","Beschreibung"]
-aurPkgInfoFields Spanish  = [ "Nombre","Versión","Estado en AUR","URL del proyecto"
-                            ,"URL en AUR","Licencia", "Votos","Descripción" ]
+infoFields :: Language -> [String]
+infoFields English  = [ "Repository","Name","Version","AUR Status"
+                      , "Project URL","AUR URL","License", "Votes"
+                      , "Description" ]
+infoFields Japanese = [ "リポジトリ","名前","バージョン","パッケージ状態"
+                      , "プロジェクト","パッケージページ","ライセンス"
+                      , "投票数","概要" ]
+infoFields Polish   = [ "Repository","Nazwa","Wersja","Status w AUR"
+                      , "URL Projektu","URL AUR", "Licencja","Głosy","Opis" ]
+infoFields Croatian = [ "Repository","Ime","Verzija","AUR Stanje"
+                      , "URL Projekta","AUR URL","Licenca","Glasovi","Opis" ]
+infoFields Swedish  = [ "Repository","Namn","Version","AUR Status"
+                      , "Projekt URL","AUR URL","Licens","Röster"
+                      , "Beskrivning"]
+infoFields German   = [ "Repository","Name","Version","AUR Status"
+                      , "Projekt URL","AUR URL","Lizenz","Stimmen"
+                      , "Beschreibung"]
+infoFields Spanish  = [ "Repository","Nombre","Versión","Estado en AUR"
+                      , "URL del proyecto","URL en AUR","Licencia", "Votos"
+                      , "Descripción" ]
 
 outOfDateMsg :: Language -> Bool -> String
 outOfDateMsg English  True  = red "Out of Date!"
-module Aura.MakePkg where
-
 {-
 
 Copyright 2012 Colin Woodbury <colingw@gmail.com>
 
 -}
 
+module Aura.MakePkg where
+
 -- System Libraries
 import Text.Regex.PCRE ((=~))
 import System.Exit (ExitCode)
               String -> IO (ExitCode,FilePath,String)
 makepkgGen f user = do
   (exitStatus,out,err) <- f command opts
-  contents <- ls "."  -- I don't like this relative path.
+  contents <- pwd >>= ls
   let pkgFiles = filter (\file -> (file =~ ".pkg.tar.xz")) contents
       pkgName  = if null pkgFiles then "" else head pkgFiles
   return $ (exitStatus,pkgName,err ++ "\n" ++ out)
 import Utilities 
 import Shell
 
-type Arg = String
+type ShellArg = String
+type Pacman   = [String] -> IO ExitCode
+
+defaultCmd :: String
+defaultCmd = "pacman"
 
 pacmanConfFile :: FilePath
 pacmanConfFile = "/etc/pacman.conf"
 defaultLogFile :: FilePath
 defaultLogFile = "/var/log/pacman.log"
 
-pacman :: [Arg] -> IO ExitCode
-pacman args = hFlush stdout >> shellCmd "pacman" args
-
--- Slight evil-doing permitted here.
-pacman' :: [Arg] -> IO ()
-pacman' args = pacman args >> return ()
+pacmanCmd :: String -> [ShellArg] -> IO ExitCode
+pacmanCmd cmd args = hFlush stdout >> shellCmd cmd args
 
 -- Runs pacman without producing any output.
-pacmanQuiet :: [Arg] -> IO (ExitCode,String,String)
+pacmanQuiet :: [ShellArg] -> IO (ExitCode,String,String)
 pacmanQuiet args = quietShellCmd' "pacman" args
 
 -- Did a pacman process succeed?
-pacmanSuccess :: [Arg] -> IO Bool
+pacmanSuccess :: [ShellArg] -> IO Bool
 pacmanSuccess args = (didProcessSucceed . tripleFst) `liftM` pacmanQuiet args
 
-pacmanFailure :: [Arg] -> IO Bool
-pacmanFailure args = not `liftM` pacmanSuccess args
-
 -- Performs a pacmanQuiet and returns only the stdout.
-pacmanOutput :: [Arg] -> IO String
+pacmanOutput :: [ShellArg] -> IO String
 pacmanOutput args = tripleSnd `liftM` pacmanQuiet args
 
-syncDatabase :: [Arg] -> IO ExitCode
-syncDatabase pacOpts = pacman $ ["-Sy"] ++ pacOpts
+syncDatabase :: Pacman -> [ShellArg] -> IO ExitCode
+syncDatabase pacman pacOpts = pacman $ ["-Sy"] ++ pacOpts
 
 -- This takes the filepath of the package cache as an argument.
 packageCacheContents :: FilePath -> IO [String]
 packageCacheContents c = filter dots `liftM` ls c
     where dots p = p `notElem` [".",".."]
 
+getPacmanCmd :: Environment -> Pacman
+getPacmanCmd env = case getEnvVar "PACMAN" env of
+                     Nothing  -> pacmanCmd defaultCmd
+                     Just cmd -> pacmanCmd cmd
+
 getPacmanConf :: IO String
 getPacmanConf = readFile pacmanConfFile
 
 GENERAL
 -------
-Protected package files? In a .conf file?
-You could give a list of regexes for packages that you never want deleted.
-When a `-Cc` comes along they wouldn't be deleted.
-
-What of the license has to be present in the source code?
-
-Calls to pacman should check for the `$PACMAN` var.
-
 When outputing repo dependencies, show what repo they're from?
 
 Move aura to haskell-http.
 
-With colours:
-- Repo is purple.
-- Package name should be white.
-
 In `divideByPkgType`, change order to get for Repo packages first.
 
 OPTIONS TO IMPLEMENT
 # Maintainer: Colin Woodbury <colingw@gmail.com>
 _hkgname=aura
 pkgname=aura
-pkgver=1.0.2.2
+pkgver=1.0.3.0
 pkgrel=1
 pkgdesc="A package manager for Arch Linux and the AUR written in Haskell."
 url="https://github.com/fosskers/aura"
 makedepends=('ghc' 'haskell-regex-base' 'haskell-regex-pcre' 'haskell-json'
              'haskell-curl')
 depends=('gmp' 'pacman')
+optdepends=('pacman-color: For coloured pacman output in Aura.')
 options=('strip')
 source=(https://github.com/downloads/fosskers/aura/${_hkgname}-${pkgver}.tar.gz)
-md5sums=('8dafa7078e1d3647d5ea81d575a41249')
+md5sums=('fee06e42e1363b33a144f22e2c51449b')
 build() {
     cd ${srcdir}/${_hkgname}-${pkgver}
     runhaskell Setup configure --prefix=/usr --docdir=/usr/share/doc/${pkgname} -O
 tripleThrd :: (a,b,c) -> c
 tripleThrd (_,_,c) = c
 
-tupTrip :: c -> (a,b) -> (a,b,c)
-tupTrip c (a,b) = (a,b,c)
-
 -- Replaces a (p)attern with a (t)arget in a line if possible.
 replaceByPatt :: [Pattern] -> String -> String
 replaceByPatt [] line = line
 searchLines :: Regex -> [String] -> [String]
 searchLines pat allLines = filter (\line -> line =~ pat) allLines
 
-wordsLines :: String -> [String]
-wordsLines xs = lines xs >>= words
-
 notNull :: [a] -> Bool
 notNull = not . null
 
 name:                aura
 
-version:             1.0.2.2
+version:             1.0.3.0
 
 synopsis:            A package manager for Arch Linux and the AUR, written in Haskell.
 
 -}
 
 {- POMODOROS
-2012 Oct 16 - XXX
+2012 Oct 30 => X
+2012 Oct 16 => XXX
 -}
 
 --                       -
 --                       -
 
 auraVersion :: String
-auraVersion = "1.0.2.2"
+auraVersion = "1.0.3.0"
 
 main :: IO a
 main = do
   environment <- getEnvironment
   return $ Settings { environmentOf   = environment
                     , langOf          = lang
+                    , pacman          = getPacmanCmd environment
                     , ignoredPkgsOf   = getIgnoredPkgs confFile
                     , cachePathOf     = getCachePath confFile
                     , logFilePathOf   = getLogFilePath confFile
     (Orphans:fs) ->
         case fs of
           []        -> displayOrphans ss input
-          [Abandon] -> ss |$| (getOrphans >>= flip removePkgs pacOpts)
+          [Abandon] -> ss |$| (getOrphans >>= \ps -> removePkgs ss ps pacOpts)
           badFlags  -> scoldAndFail ss executeOptsMsg1
     [ViewConf]  -> viewConfFile
     [Languages] -> displayOutputLanguages ss
     [Help]      -> printHelpMsg ss pacOpts
     [Version]   -> getVersionInfo >>= animateVersionMsg ss
-    pacmanFlags -> pacman $ pacOpts ++ input ++ hijackedFlags
+    pacmanFlags -> pacman ss $ pacOpts ++ input ++ hijackedFlags
     where hijackedFlags = reconvertFlags flags hijackedFlagMap
           
 --------------------
 -}
 installPackages :: Settings -> [String] -> [String] -> IO ExitCode
 installPackages _ _ [] = returnSuccess
-installPackages settings pacOpts pkgs = do
-  let toInstall = pkgs \\ ignoredPkgsOf settings
+installPackages ss pacOpts pkgs = do
+  let toInstall = pkgs \\ ignoredPkgsOf ss
       ignored   = pkgs \\ toInstall
-      lang      = langOf settings
+      lang      = langOf ss
   reportIgnoredPackages lang ignored
   (forPacman,aurPkgNames,nonPkgs) <- divideByPkgType toInstall
   reportNonPackages lang nonPkgs
   aurPackages <- mapM makeAURPkg aurPkgNames
-  notify settings installPackagesMsg5
-  results     <- getDepsToInstall settings aurPackages
+  notify ss installPackagesMsg5
+  results     <- getDepsToInstall ss aurPackages
   case results of
     Left errors -> do
       printList red noColour (installPackagesMsg1 lang) errors
       let repoPkgs    = nub $ pacmanDeps ++ forPacman
           pkgsAndOpts = pacOpts ++ repoPkgs
       reportPkgsToInstall lang repoPkgs aurDeps aurPackages 
-      okay <- optionalPrompt (mustConfirm settings) (installPackagesMsg3 lang)
+      okay <- optionalPrompt (mustConfirm ss) (installPackagesMsg3 lang)
       if not okay
-         then scoldAndFail settings installPackagesMsg4
+         then scoldAndFail ss installPackagesMsg4
          else do
-           unless (null repoPkgs) (pacman' $ ["-S","--asdeps"] ++ pkgsAndOpts)
-           mapM_ (buildAndInstallDep settings pacOpts) aurDeps
-           pkgFiles <- buildPackages settings aurPackages
+           unless (null repoPkgs) $ do
+                 pacman ss (["-S","--asdeps"] ++ pkgsAndOpts) >> return ()
+           mapM_ (buildAndInstallDep ss pacOpts) aurDeps
+           pkgFiles <- buildPackages ss aurPackages
            case pkgFiles of
-             Just pfs -> installPkgFiles pacOpts pfs
-             Nothing  -> scoldAndFail settings installPackagesMsg6
+             Just pfs -> installPkgFiles ss pacOpts pfs
+             Nothing  -> scoldAndFail ss installPackagesMsg6
 
 buildAndInstallDep :: Settings -> [String] -> AURPkg -> IO ExitCode
-buildAndInstallDep settings pacOpts pkg =
-  buildPackages settings [pkg] ?>>=
-  installPkgFiles (["--asdeps"] ++ pacOpts) . fromJust
+buildAndInstallDep ss pacOpts pkg =
+  buildPackages ss [pkg] ?>>=
+  installPkgFiles ss (["--asdeps"] ++ pacOpts) . fromJust
                
 upgradeAURPkgs :: Settings -> [String] -> [String] -> IO ExitCode
-upgradeAURPkgs settings pacOpts pkgs = do
-  notify settings upgradeAURPkgsMsg1
+upgradeAURPkgs ss pacOpts pkgs = do
+  notify ss upgradeAURPkgsMsg1
   foreignPkgs <- filter (\(n,_) -> notIgnored n) `liftM` getForeignPackages
   (aurInfoLookup $ map fst foreignPkgs) ?>>= \pkgInfoEither -> do
     let pkgInfo   = fromRight pkgInfoEither
         aurPkgs   = filter (\(n,_) -> n `elem` map nameOf pkgInfo) foreignPkgs
         toUpgrade = filter isntMostRecent $ zip pkgInfo (map snd aurPkgs)
-    notify settings upgradeAURPkgsMsg2
+    notify ss upgradeAURPkgsMsg2
     if null toUpgrade
-       then warn settings upgradeAURPkgsMsg3
-       else reportPkgsToUpgrade (langOf settings) $ map prettify toUpgrade
-    installPackages settings pacOpts $ (map (nameOf . fst) toUpgrade) ++ pkgs
-      where notIgnored p   = splitName p `notElem` ignoredPkgsOf settings
+       then warn ss upgradeAURPkgsMsg3
+       else reportPkgsToUpgrade (langOf ss) $ map prettify toUpgrade
+    installPackages ss pacOpts $ (map (nameOf . fst) toUpgrade) ++ pkgs
+      where notIgnored p   = splitName p `notElem` ignoredPkgsOf ss
             prettify (p,v) = nameOf p ++ " : " ++ v ++ " => " ++ latestVerOf p
 
 aurPkgInfo :: Settings -> [String] -> IO ExitCode
           paddedFields     = map (\x -> postPad x ws longestField) fields
           ws               = whitespace $ langOf ss
           longestField     = maximum $ map length fields
-          fields           = aurPkgInfoFields $ langOf ss
-          entries          = [ nameOf info
+          fields           = infoFields $ langOf ss
+          entries          = [ magenta "aur"
+                             , nameOf info
                              , latestVerOf info
                              , outOfDateMsg (langOf ss) $ isOutOfDate info
-                             , projectURLOf info
+                             , cyan $ projectURLOf info
                              , aurURLOf info
                              , licenseOf info
                              , votesOf info
     returnSuccess
 
 renderSearchResult :: String -> PkgInfo -> String
-renderSearchResult reg info = yellow "aur/" ++ n ++ " " ++ v ++ "\n    " ++ d
-    where c cs = case cs =~ ("(?i)" ++ reg) of (b,m,a) -> b ++ cyan m ++ a
+renderSearchResult r info = magenta "aur/" ++ n ++ " " ++ v ++ "\n    " ++ d
+    where c cs = case cs =~ ("(?i)" ++ r) of (b,m,a) -> b ++ cyan m ++ a
           n = c $ nameOf info
           d = c $ descriptionOf info
           v | isOutOfDate info = red $ latestVerOf info
 
 syncAndContinue :: Settings -> ([Flag],[String],[String]) -> IO ExitCode
 syncAndContinue settings (flags,input,pacOpts) = do
-  _ <- syncDatabase pacOpts
+  _ <- syncDatabase (pacman settings) pacOpts
   executeOpts settings (AURInstall:flags,input,pacOpts)  -- This is Evil.
 
 removeMakeDeps :: Settings -> ([Flag],[String],[String]) -> IO ExitCode
     orphansAfter <- getOrphans
     let makeDeps = orphansAfter \\ orphansBefore
     unless (null makeDeps) $ notify settings removeMakeDepsAfterMsg1
-    removePkgs makeDeps pacOpts
+    removePkgs settings makeDeps pacOpts
 
 --------------------
 -- WORKING WITH `-C`
   return reals ?>> do
     cache   <- packageCacheContents cachePath
     choices <- mapM (getDowngradeChoice ss cache) reals
-    pacman $ ["-U"] ++ map (cachePath </>) choices
+    pacman ss $ ["-U"] ++ map (cachePath </>) choices
       where cachePath = cachePathOf ss
                
 getDowngradeChoice :: Settings -> [String] -> String -> IO String
 cleanCache :: Settings -> Int -> IO ExitCode
 cleanCache ss toSave
     | toSave < 0  = scoldAndFail ss cleanCacheMsg1
-    | toSave == 0 = warn ss cleanCacheMsg2 >> pacman ["-Scc"]
+    | toSave == 0 = warn ss cleanCacheMsg2 >> pacman ss ["-Scc"]
     | otherwise   = do
         warn ss $ flip cleanCacheMsg3 toSave
         okay <- optionalPrompt (mustConfirm ss) (cleanCacheMsg4 $ langOf ss)
 displayOrphans ss pkgs = adoptPkg ss pkgs
 
 adoptPkg :: Settings -> [String] -> IO ExitCode
-adoptPkg ss pkgs = ss |$| (pacman $ ["-D","--asexplicit"] ++ pkgs)
+adoptPkg ss pkgs = ss |$| (pacman ss $ ["-D","--asexplicit"] ++ pkgs)
 
 ----------
 -- REPORTS
   pacmanHelp <- getPacmanHelpMsg
   putStrLn $ getHelpMsg settings pacmanHelp
   returnSuccess
-printHelpMsg _ pacOpts = pacman $ pacOpts ++ ["-h"]
+printHelpMsg settings pacOpts = pacman settings $ pacOpts ++ ["-h"]
 
 getHelpMsg :: Settings -> [String] -> String
 getHelpMsg settings pacmanHelpMsg = concat $ intersperse "\n" allMessages
 Aura Changelog
 ==============
 
+1.0.3.0
+-------
+- Support for `pacman-color` added.
+
 1.0.2.2
 -------
 - Fixed parsing bug in `Bash`.
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.