Permalink
Browse files

Changing program layout to a monadic state transformer

  • Loading branch information...
der_eq@freenet.de
der_eq@freenet.de committed Oct 2, 2005
1 parent 6655a42 commit 4cfa22eafe21ea30d67f83c301fa59176718c162
Showing with 261 additions and 198 deletions.
  1. +84 −0 HackPort/Action.hs
  2. +29 −24 HackPort/Bash.hs
  3. +7 −4 HackPort/Cache.hs
  4. +5 −1 HackPort/Config.hs
  5. +9 −4 HackPort/Error.hs
  6. +30 −36 HackPort/GenerateEbuild.hs
  7. +54 −64 HackPort/Main.hs
  8. +20 −18 HackPort/Portage.hs
  9. +22 −18 HackPort/TarUtils.hs
  10. +0 −28 HackPort/Verbosity.hs
  11. +1 −1 HackPort/hackport.cabal
View
@@ -0,0 +1,84 @@
+module Action where
+
+import Config
+import Error
+
+import Control.Monad.State
+import Control.Monad.Error
+import System.IO
+import System.Environment
+
+type HPAction = ErrorT HackPortError (StateT (Config,Int) IO)
+
+verbose :: HPAction a -> (String,a->String) -> HPAction a
+verbose action (premsg,postmsg) = do
+ echoIndent
+ echo premsg
+ flush
+ res <- indent action
+ echoIndent
+ echoLn (postmsg res)
+ return res
+
+sayNormal :: HPAction a -> (String,a->String) -> HPAction a
+sayNormal action strs = do
+ cfg <- getCfg
+ case verbosity cfg of
+ Silent -> action
+ _ -> action `verbose` strs
+
+sayDebug :: HPAction a -> (String,a->String) -> HPAction a
+sayDebug action strs = do
+ cfg <- getCfg
+ case verbosity cfg of
+ Debug -> action `verbose` strs
+ _ -> action
+
+info :: String -> HPAction ()
+info str = do
+ cfg <- getCfg
+ case verbosity cfg of
+ Silent -> return ()
+ _ -> echoLn str
+
+getCfg :: HPAction Config
+getCfg = get >>= return.fst
+
+lessIndent :: HPAction ()
+lessIndent = get >>= \(cfg,ind)->put (cfg,ind-1)
+
+moreIndent :: HPAction ()
+moreIndent = get >>= \(cfg,ind)->put (cfg,ind+1)
+
+echoIndent :: HPAction ()
+echoIndent = get >>= \(_,ind)->echo (replicate ind '\t')
+
+indent :: HPAction a -> HPAction a
+indent action = do
+ moreIndent
+ res <- action
+ lessIndent
+ return res
+
+echo :: String -> HPAction ()
+echo str = liftIO $ hPutStr stderr str
+
+flush :: HPAction ()
+flush = liftIO (hFlush stderr)
+
+echoLn :: String -> HPAction ()
+echoLn str = echoIndent >> echo str >> liftIO (hPutChar stderr '\n')
+
+loadConfig :: HPAction OperationMode
+loadConfig = do
+ args <- liftIO getArgs
+ case parseConfig args of
+ Left errmsg -> throwError (ArgumentError errmsg)
+ Right (cfg,opmode) -> get >>= \(_,ind) -> put (cfg,ind) >> return opmode
+
+performHPAction :: HPAction a -> IO ()
+performHPAction action = do
+ res <- evalStateT (runErrorT action) (defaultConfig,0)
+ case res of
+ Left err -> hPutStr stderr (hackPortShowError err)
+ Right _ -> return ()
View
@@ -1,51 +1,56 @@
module Bash where
-import Control.Exception
+import Control.Monad.Trans
+import Control.Monad.Error
import System.Process
import System.Directory
import System.IO
import System.Exit
+
+import Action
import Error
-getOverlay :: IO String
+getOverlay :: HPAction String
getOverlay = do
overlays <- getOverlays
case overlays of
- [] -> throwDyn NoOverlay
+ [] -> throwError NoOverlay
[x] -> return x
mul -> search mul
where
+ search :: [String] -> HPAction String
search mul = do
- let loop [] = throwDyn $ MultipleOverlays mul
- loop (x:xs) = do
- found <- doesFileExist (x ++ "/.hackagecache.xml")
+ let loop [] = throwError $ MultipleOverlays mul
+ loop (x:xs) = (do
+ found <- liftIO (doesFileExist (x ++ "/.hackagecache.xml"))
+ `sayDebug` ("Checking '"++x++"'...",\res->if res then "found.\n" else "not found.")
if found
then return x
- else loop xs
- putStrLn "There are several overlays in your /etc/make.conf"
- putStr $ unlines $ map (" * " ++) mul
- putStrLn "Looking for one with a HackPort cache..."
+ else loop xs)
+ info "There are several overlays in your /etc/make.conf"
+ mapM (\x->info (" * " ++x)) mul
+ info "Looking for one with a HackPort cache..."
overlay <- loop mul
- putStrLn ("I choose " ++ overlay ++
- "\nOverride my decision with hackport -p /my/overlay")
+ info ("I choose " ++ overlay)
+ info "Override my decision with hackport -p /my/overlay"
return overlay
-getOverlays :: IO [String]
+getOverlays :: HPAction [String]
getOverlays = runBash "source /etc/make.conf;echo -n $PORTDIR_OVERLAY" >>= (return.words)
runBash ::
String -> -- ^ The command line
- IO String -- ^ The command-line's output
+ HPAction String -- ^ The command-line's output
runBash command = do
- mpath <- findExecutable "bash"
- bash <- maybe (throwDyn BashNotFound) return mpath
- (inp,outp,err,pid) <- runInteractiveProcess bash ["-c",command] Nothing Nothing
- hClose inp
- result <- hGetContents outp
- errors <- hGetContents err
- length result `seq` hClose outp
- length errors `seq` hClose err
- exitCode <- waitForProcess pid
+ mpath <- liftIO $ findExecutable "bash"
+ bash <- maybe (throwError BashNotFound) return mpath
+ (inp,outp,err,pid) <- liftIO $ runInteractiveProcess bash ["-c",command] Nothing Nothing
+ liftIO $ hClose inp
+ result <- liftIO $ hGetContents outp
+ errors <- liftIO $ hGetContents err
+ length result `seq` liftIO (hClose outp)
+ length errors `seq` liftIO (hClose err)
+ exitCode <- liftIO $ waitForProcess pid
case exitCode of
- ExitFailure err -> throwDyn $ BashError errors
+ ExitFailure err -> throwError $ BashError errors
ExitSuccess -> return result
View
@@ -2,6 +2,8 @@ module Cache where
import MaybeRead
import Error
+import Action
+
import Text.XML.HaXml.Haskell2Xml
import Text.XML.HaXml.Pretty
import Text.XML.HaXml.Types
@@ -11,6 +13,7 @@ import Data.Version
import Network.Hackage.Client
import System.IO
import Control.Exception
+import Control.Monad.Error
import Prelude hiding(catch)
thisVersion=Version { versionBranch=[0,1],versionTags=[] }
@@ -31,13 +34,13 @@ getCacheFromServer serv = do
writeCache :: FilePath -> Cache -> IO ()
writeCache path cache = writeFile path (show (document (cacheToXML cache)))
-readCache :: FilePath -> IO Cache
+readCache :: FilePath -> HPAction Cache
readCache path = do
- file <- readFile path `catch` const (throwDyn InvalidCache)
+ file <- liftIO (readFile path) `catchError` const (throwError InvalidCache)
case xmlParse' path file of
- Left str -> throwDyn InvalidCache
+ Left str -> throwError InvalidCache
Right doc -> case cacheFromXML doc of
- Nothing -> throwDyn InvalidCache
+ Nothing -> throwError InvalidCache
Just res -> return res
cacheToXML :: Cache -> Document
View
@@ -6,7 +6,6 @@ import Text.Regex
import Distribution.Package
import Error
-import Verbosity
import MaybeRead
data HackPortOptions
@@ -36,6 +35,11 @@ data Config = Config
, verbosity ::Verbosity
}
+data Verbosity
+ = Debug
+ | Normal
+ | Silent
+
packageRegex = mkRegex "^(.*?)-([0-9].*)$"
defaultConfig :: Config
View
@@ -3,9 +3,12 @@ module Error where
import Data.Typeable
import Distribution.Package
+import Control.Monad.Error
+import Control.Exception
data HackPortError
- = ConnectionFailed String
+ = ArgumentError String
+ | ConnectionFailed String String
| PackageNotFound (Either String PackageIdentifier)
| InvalidTarballURL String String
| InvalidSignatureURL String String
@@ -25,11 +28,13 @@ data HackPortError
| InvalidCache
deriving (Typeable)
+instance Error HackPortError
+
type HackPortResult a = Either
-hackPortShowError :: String -> HackPortError -> String
-hackPortShowError server err = case err of
- ConnectionFailed reason -> "Connection to hackage server '"++server++"' failed: "++reason
+hackPortShowError :: HackPortError -> String
+hackPortShowError err = case err of
+ ConnectionFailed server reason -> "Connection to hackage server '"++server++"' failed: "++reason
PackageNotFound pkg -> "Package '"++(either id showPackageId pkg)++"' not found on server."
InvalidTarballURL url reason -> "Error while downloading tarball '"++url++"': "++reason
InvalidSignatureURL url reason -> "Error while downloading signature '"++url++"': "++reason
View
@@ -1,58 +1,52 @@
module GenerateEbuild where
+import Action
import Cabal2Ebuild
import Fetch
import TarUtils
+import Config
import Error
-import Verbosity
import Prelude hiding (catch)
+import Control.Monad.Trans
+import Control.Monad.Error
import Control.Exception
---import Network.Hackage.Client as Hackage
import Distribution.PackageDescription
import Distribution.Package
import System.Directory
-mergeEbuild :: Verbosity -> FilePath -> String -> EBuild -> IO ()
-mergeEbuild verb target category ebuild = do
- let edir = target++"/"++category++"/"++(name ebuild)
+mergeEbuild :: FilePath -> EBuild -> HPAction ()
+mergeEbuild target ebuild = do
+ cfg <- getCfg
+ let edir = target++"/"++(portageCategory cfg)++"/"++(name ebuild)
let epath = edir++"/"++(name ebuild)++"-"++(version ebuild)++".ebuild"
- createDirectoryIfMissing True edir
- `sayDebug` ("Creating '"++edir++"'... ",const "done.\n")
- writeFile epath (showEBuild ebuild)
- `sayNormal` ("Merging to '"++epath++"'... ",const "done.\n")
- where
- sayNormal = verboseNormal verb
- sayDebug = verboseDebug verb
+ liftIO (createDirectoryIfMissing True edir)
+ `sayDebug` ("Creating '"++edir++"'... ",const "done.")
+ liftIO (writeFile epath (showEBuild ebuild))
+ `sayNormal` ("Merging to '"++epath++"'... ",const "done.")
hackage2ebuild ::
- Verbosity -> -- ^ verbosity level
- FilePath -> -- ^ the tar executable
- FilePath -> -- ^ a temp path to store the tarball
- Bool -> -- ^ gpg verify the package?
(PackageIdentifier,String,String) -> -- ^ the package
- IO EBuild
-hackage2ebuild verb tarCommand store verify (pkg,tarball,sig) = do
- tarballPath <- (if verify then (do
- (tarPath,sigPath) <- downloadFileVerify store tarball sig
+ HPAction EBuild
+hackage2ebuild (pkg,tarball,sig) = do
+ cfg <- getCfg
+ tarballPath <- (if verify cfg then liftIO (do
+ (tarPath,sigPath) <- downloadFileVerify (tmp cfg) tarball sig
removeFile sigPath
- return tarPath) else downloadTarball store tarball)
- `sayNormal` ("Downloading tarball from '"++tarball++"' to '"++store++"'... ",const "done.\n")
- tarType <- maybe (removeFile tarballPath >> throwDyn (UnknownCompression tarball)) return (tarballGetType tarballPath)
- `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")
+ return tarPath) else liftIO (downloadTarball (tmp cfg) tarball))
+ `sayNormal` ("Downloading tarball from '"++tarball++"' to '"++(tmp cfg)++"'... ",const "done.")
+ tarType <- maybe (liftIO (removeFile tarballPath) >> throwError (UnknownCompression tarball)) return (tarballGetType tarballPath)
+ `sayDebug` ("Guessing compression type of tarball... ",const "done.")
+ filesInTarball <- tarballGetFiles (tarCommand cfg) tarballPath tarType
+ `sayDebug` ("Getting list of files from tarball... ",const "done.")
+ `catchError` (\x->liftIO (removeFile tarballPath) >> throwError x)
+ (cabalDir,cabalName) <- maybe (throwError $ NoCabalFound tarball) return (findCabal filesInTarball)
+ `sayDebug` ("Trying to find cabal file... ",\(dir,name)->"Found cabal file '"++name++"' in '"++dir++"'.")
+ cabalFile <- tarballExtractFile tarballPath tarType (cabalDir++"/"++cabalName)
+ `sayDebug` ("Extracting cabal file... ",const "done.")
packageDescription <- case parseDescription cabalFile of
- ParseFailed err -> throwDyn $ CabalParseFailed cabalName (showError err)
+ ParseFailed err -> throwError $ CabalParseFailed cabalName (showError err)
ParseOk descr -> return descr
- `sayDebug` ("Parsing '"++cabalName++"'... ",const "done.\n")
+ `sayDebug` ("Parsing '"++cabalName++"'... ",const "done.")
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}
- where
- sayNormal = verboseNormal verb
- sayDebug = verboseDebug verb
Oops, something went wrong.

0 comments on commit 4cfa22e

Please sign in to comment.