Permalink
Browse files

Less ugly debug method

  • Loading branch information...
der_eq@freenet.de
der_eq@freenet.de committed Sep 21, 2005
1 parent 980982a commit 263875af2fa9296f5246c8a043616cddb2432c14
Showing with 70 additions and 27 deletions.
  1. +4 −4 HackPort/Error.hs
  2. +24 −8 HackPort/GenerateEbuild.hs
  3. +10 −5 HackPort/Main.hs
  4. +17 −6 HackPort/Query.hs
  5. +15 −4 HackPort/Verbosity.hs
View
@@ -6,7 +6,7 @@ import Distribution.Package
data HackPortError
= ConnectionFailed String
- | PackageNotFound
+ | PackageNotFound String
| InvalidTarballURL String String
| InvalidSignatureURL String String
| VerificationFailed String String
@@ -25,10 +25,10 @@ data HackPortError
type HackPortResult a = Either
-hackPortShowError :: String -> Maybe PackageIdentifier -> HackPortError -> String
-hackPortShowError server package err = case err of
+hackPortShowError :: String -> HackPortError -> String
+hackPortShowError server err = case err of
ConnectionFailed reason -> "Connection to hackage server '"++server++"' failed: "++reason
- PackageNotFound -> "Package '"++(maybe "" show package)++"' not found on server"
+ PackageNotFound pkg -> "Package '"++pkg++"' not found on server."
InvalidTarballURL url reason -> "Error while downloading tarball '"++url++"': "++reason
InvalidSignatureURL url reason -> "Error while downloading signature '"++url++"': "++reason
VerificationFailed file signature -> "Error while checking signature('"++signature++"') of '"++file++"'"
View
@@ -18,30 +18,46 @@ mergeEbuild verb target category ebuild = do
let edir = target++"/"++category++"/"++(name ebuild)
let epath = edir++"/"++(name ebuild)++"-"++(version ebuild)++".ebuild"
createDirectoryIfMissing True edir
- writeFile epath (showEBuild ebuild) `sayNormal` ("Merging to '"++epath++"'\n")
+ `sayDebug` ("Creating '"++edir++"'... ",const "done.\n")
+ writeFile epath (showEBuild ebuild)
+ `sayNormal` ("Merging to '"++epath++"'... ",const "done.\n")
where
sayNormal = verboseNormal verb
+ sayDebug = verboseDebug verb
-hackage2ebuild ::
+hackage2ebuild ::
+ Verbosity -> -- ^ verbosity level
FilePath -> -- ^ the tar executable
String -> -- ^ the hackage server
FilePath -> -- ^ a temp path to store the tarball
Bool -> -- ^ gpg verify the package?
PackageIdentifier -> -- ^ the package
IO EBuild
-hackage2ebuild tarCommand server store verify pkg = do
- resolvedPackage <- Hackage.getPkgLocation server pkg `catch` (\x->throwDyn $ ConnectionFailed (show x))
+hackage2ebuild verb tarCommand server store verify pkg = do
+ resolvedPackage <- Hackage.getPkgLocation server pkg
+ `sayDebug` ("Getting package location from '"++server++"'... ",maybe "\n" (\(tar,sig)->"Found tarball '"++tar++"' and signature '"++sig++"'\n"))
+ `catch` (\x->throwDyn $ ConnectionFailed (show x))
(tarball,sig) <- maybe (throwDyn PackageNotFound) return resolvedPackage
- tarballPath <- if verify then (do
+ tarballPath <- (if verify then (do
(tarPath,sigPath) <- downloadFileVerify store tarball sig
removeFile sigPath
- return tarPath) else downloadTarball store tarball
+ return tarPath) else downloadTarball store tarball)
+ `sayDebug` ("Downloading tarball to '"++store++"'... ",const "done.\n")
tarType <- maybe (removeFile tarballPath >> throwDyn (UnknownCompression tarball)) return (tarballGetType tarballPath)
- filesInTarball <- tarballGetFiles tarCommand tarballPath tarType `catch` (\x->removeFile tarballPath >> throw x)
+ `sayDebug` ("Guessing compression type of tarball... ",const "done.\n")
+ filesInTarball <- tarballGetFiles tarCommand tarballPath tarType
+ `sayDebug` ("Getting list of files from tarball... ",const "done.\n")
+ `catch` (\x->removeFile tarballPath >> throw x)
(cabalDir,cabalName) <- maybe (throwDyn $ NoCabalFound tarball) return (findCabal filesInTarball)
+ `sayDebug` ("Trying to find cabal file... ",\(dir,name)->"Found cabal file '"++name++"' in '"++dir++"'.\n")
cabalFile <- tarballExtractFile tarCommand tarballPath tarType (cabalDir++"/"++cabalName)
+ `sayDebug` ("Extracting cabal file... ",const "done.\n")
packageDescription <- case parseDescription cabalFile of
ParseFailed err -> throwDyn $ CabalParseFailed cabalName (showError err)
ParseOk descr -> return descr
+ `sayDebug` ("Parsing '"++cabalName++"'... ",const "done.\n")
let ebuild=cabal2ebuild (packageDescription{pkgUrl=tarball}) --we don't trust the cabal file as we just successfully downloaded the tarbal somewhere
- return $ ebuild {cabalPath=Just cabalDir}
+ return ebuild {cabalPath=Just cabalDir}
+ where
+ sayNormal = verboseNormal verb
+ sayDebug = verboseDebug verb
View
@@ -6,6 +6,8 @@ import Distribution.Package
import Data.Version
import Control.Exception
import Data.Typeable
+import System.IO
+
import Error
import Query
import GenerateEbuild
@@ -16,23 +18,23 @@ import Verbosity
listAll :: Config -> IO ()
listAll cfg = do
- pkgs <- getPackages (server cfg)
+ pkgs <- getPackages (verbosity cfg) (server cfg)
putStr (unlines pkgs)
query :: Config -> String -> IO ()
query cfg name = do
- pkgvers <- getPackageVersions (server cfg) name
+ pkgvers <- getPackageVersions (verbosity cfg) (server cfg) name
putStr (unlines (map showVersion pkgvers))
merge :: Config -> String -> String -> IO ()
merge cfg name vers = do
portTree <- case portageTree cfg of
- Nothing -> getOverlay `sayDebug` "Guessing overlay from /etc/make.conf...\n"
+ Nothing -> getOverlay `sayDebug` ("Guessing overlay from /etc/make.conf... ",\tree->"Found '"++tree++"'\n")
Just tree -> return tree
case parseVersion' vers of
Nothing -> putStr ("Error: couldn't parse version number '"++vers++"'\n")
Just realvers -> do
- ebuild <- hackage2ebuild (tarCommand cfg) (server cfg) (tmp cfg) (verify cfg) (PackageIdentifier {pkgName=name,pkgVersion=realvers})
+ ebuild <- hackage2ebuild (verbosity cfg) (tarCommand cfg) (server cfg) (tmp cfg) (verify cfg) (PackageIdentifier {pkgName=name,pkgVersion=realvers})
mergeEbuild (verbosity cfg) portTree (portageCategory cfg) ebuild
where
sayDebug = verboseDebug (verbosity cfg)
@@ -49,4 +51,7 @@ main = do
ShowHelp -> hackageUsage
ListAll -> listAll config
Query pkg -> query config pkg
- Merge pkg vers -> merge config pkg vers) `catchDyn` (\x->putStr ((hackPortShowError (server config) Nothing x)++"\n"))
+ Merge pkg vers -> merge config pkg vers) `catchDyn` (\x->report (hackPortShowError (server config) x))
+ where
+ report err = hPutStr stderr (err++"\n")
+
View
@@ -1,5 +1,9 @@
module Query where
+import Verbosity
+import Error
+
+import Control.Exception
import Network.Hackage.Client
import Distribution.Package
import Data.Version
@@ -10,13 +14,20 @@ parseVersion' :: String -> Maybe Version
parseVersion' str = maybe Nothing (\x->Just (fst x)) (find (\(_,rest)->null rest) (parser str)) where
parser = readP_to_S parseVersion
-getPackageVersions :: String -> String -> IO [Version]
-getPackageVersions server name = do
- pkgs <- listPackages server
+getPackageVersions :: Verbosity -> String -> String -> IO [Version]
+getPackageVersions verb server name = do
+ pkgs <- listPackages server `sayDebug` ("Getting package list from '"++server++"'... ",const "done.\n")
let foundpkgs = filter (\(pkg,_,_,_)->pkgName pkg == name) pkgs
- return $ map (\(pkg,_,_,_)->pkgVersion pkg) foundpkgs
+ case foundpkgs of
+ [] -> throwDyn (PackageNotFound name)
+ _ -> return $ map (\(pkg,_,_,_)->pkgVersion pkg) foundpkgs
+ where
+ sayDebug = verboseDebug verb
-getPackages :: String -> IO [String]
-getPackages server = do
+getPackages :: Verbosity -> String -> IO [String]
+getPackages verb server = do
pkgs <- listPackages server
+ `sayDebug` ("Getting package list from '"++server++"'... ",const "done.\n")
return $ nub $ map (\(pkg,_,_,_)->pkgName pkg) pkgs
+ where
+ sayDebug = verboseDebug verb
View
@@ -1,17 +1,28 @@
module Verbosity where
+import System.IO
+
data Verbosity
= Debug
| Normal
| Silent
-verboseNormal :: Verbosity -> IO a -> String -> IO a
+verboseNormal :: Verbosity -> IO a -> (String,a->String) -> IO a
verboseNormal verb action msg = case verb of
Silent -> action
- _ -> putStr msg >> action
+ _ -> verbose action msg
-verboseDebug :: Verbosity -> IO a -> String -> IO a
+verboseDebug :: Verbosity -> IO a -> (String,a->String) -> IO a
verboseDebug verb action msg = case verb of
Silent -> action
Normal -> action
- _ -> putStr msg >> action
+ _ -> verbose action msg
+
+verbose :: IO a -> (String,a->String) -> IO a
+verbose action (premsg,postmsg) = do
+ hPutStr stderr premsg
+ hFlush stderr
+ res <- action
+ hPutStr stderr (postmsg res)
+ hFlush stderr
+ return res

0 comments on commit 263875a

Please sign in to comment.