Permalink
Browse files

Switch to using Cabal's CLI API

Still things to be done to transition complete, especially amongst flags.
  • Loading branch information...
kolmodin committed Aug 31, 2008
1 parent 81b7cfd commit a1730ad8fde165eeb8a0ae460b721956923d9f54
Showing with 607 additions and 471 deletions.
  1. +0 −121 Action.hs
  2. +19 −32 Bash.hs
  3. +29 −31 Cache.hs
  4. +18 −26 Config.hs
  5. +51 −46 Diff.hs
  6. +10 −4 Error.hs
  7. +16 −20 GenerateEbuild.hs
  8. +302 −111 Main.hs
  9. +90 −0 Merge.hs
  10. +34 −39 Overlays.hs
  11. +20 −24 Status.hs
  12. +0 −2 hackport.cabal
  13. +18 −15 { → unused}/Fetch.hs
View
121 Action.hs
@@ -1,121 +0,0 @@
-module Action where
-
-import Config
-import Error
-
-import Control.Monad.State
-import Control.Monad.Error
-import Network.URI (parseURI)
-import System.IO
-import System.Environment
-
-type HPAction = ErrorT HackPortError (StateT HPState IO)
-
-data HPState = HPState
- { config :: Config
- , indention :: Int
- }
-
-verbose :: HPAction a -> (String,a->String) -> HPAction a
-verbose action (premsg,postmsg) = do
- echoIndent
- echo premsg
- flush
- res <- indent action
- 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
-
--- | Prints a string iff in debug output mode
-whisper :: String -> HPAction ()
-whisper str = do
- cfg <- getCfg
- case verbosity cfg of
- Debug -> echoLn str
- _ -> return ()
-
-getCfg :: HPAction Config
-getCfg = gets config
-
-setOverlayPath :: Maybe String -> HPAction ()
-setOverlayPath mt = modify $ \hps ->
- hps { config = (config hps) { overlayPath = mt } }
-
-setPortagePath :: Maybe String -> HPAction ()
-setPortagePath mt = modify $ \hps ->
- hps { config = (config hps) { portagePath = mt } }
-
-lessIndent :: HPAction ()
-lessIndent = modify $ \s -> s { indention = indention s - 1 }
-
-moreIndent :: HPAction ()
-moreIndent = modify $ \s -> s { indention = indention s + 1 }
-
-echoIndent :: HPAction ()
-echoIndent = do
- ind <- gets indention
- 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 (opts,opmode) -> do
- cfg <- foldM optionToConfig defaultConfig opts
- modify $ \s -> s { config = cfg }
- return opmode
-
-optionToConfig :: Config -> HackPortOptions -> HPAction Config
-optionToConfig cfg opt = case opt of
- OverlayPath str -> return cfg { overlayPath = Just str }
- PortagePath str -> return cfg { portagePath = Just str }
- Server str -> case parseURI str of
- Nothing -> throwError (InvalidServer str)
- Just uri -> return cfg { server = uri }
- TempDir str -> return cfg { tmp = str }
- Verbosity str -> case parseVerbosity str of
- Nothing -> throwError (UnknownVerbosityLevel str)
- Just verb -> return cfg { verbosity=verb }
- Help -> return cfg
- RefreshCache -> return cfg { refreshCache = True }
-
-performHPAction :: HPAction a -> IO (Either HackPortError a)
-performHPAction action =
- evalStateT (runErrorT action) (HPState defaultConfig 0)
View
51 Bash.hs
@@ -6,40 +6,27 @@ import System.Directory
import System.IO
import System.Exit
-import Action
-import Config
import Error
-getSystemPortdir :: HPAction String
+getSystemPortdir :: IO String
getSystemPortdir = do
- dir <- runBash "source /etc/make.conf;echo -n $PORTDIR"
- case dir of
- "" -> return "/usr/portage"
- _ -> return dir
+ dir <- runBash "source /etc/make.conf;echo -n $PORTDIR"
+ case dir of
+ "" -> return "/usr/portage"
+ _ -> return dir
-getPortdir :: HPAction String
-getPortdir = do
- cfg <- getCfg
- case portagePath cfg of
- Just dir -> return dir
- Nothing -> do
- sys <- getSystemPortdir
- setPortagePath (Just sys)
- return sys
-
-runBash ::
- String -> -- ^ The command line
- HPAction String -- ^ The command-line's output
+runBash :: String -- ^ The command line
+ -> IO String -- ^ The command-line's output
runBash command = do
- 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 _ -> throwError $ BashError errors
- ExitSuccess -> return result
+ mpath <- findExecutable "bash"
+ bash <- maybe (throwEx 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
+ case exitCode of
+ ExitFailure _ -> throwEx (BashError errors)
+ ExitSuccess -> return result
View
@@ -1,8 +1,6 @@
module Cache where
-import Action
import CacheFile
-import Config
import Error
import Index
import P2
@@ -19,14 +17,15 @@ import Network.HTTP (Request(..), RequestMethod(GET), simpleHTTP, rspBody)
import qualified Data.ByteString.Lazy as L
import System.Time
import System.FilePath
-import Control.Monad.Error(throwError)
import Control.Monad.Writer
-import Control.Monad (unless)
-import System.Directory (doesFileExist,createDirectoryIfMissing)
+import System.Directory (createDirectoryIfMissing)
import qualified Data.Map as Map
--- | A long time. Used in checkCacheDate
+-- cabal
+import Distribution.Verbosity
+
+-- | A long time
alarmingLongTime :: TimeDiff
alarmingLongTime = TimeDiff
{ tdYear = 0
@@ -38,35 +37,34 @@ alarmingLongTime = TimeDiff
, tdPicosec = 0
}
-cacheURI :: URI -> URI
-cacheURI uri = uri {uriPath = uriPath uri </> indexFile}
+updateCache :: Verbosity -> URI -> IO ()
+updateCache verbose uri = do
+ path <- getOverlayPath verbose
+ let cache = cacheURI uri
+ res <- simpleHTTP (Request cache GET [] "") -- `sayNormal` ("Fetching cache from "++show cache++"...",const "done.")
+ case res of
+ Left err -> throwEx (ConnectionFailed (show cache) (show err))
+ Right resp -> do
+ createDirectoryIfMissing False (path </> hackportDir)
+ Prelude.writeFile (cacheFile path) (rspBody resp)
+ where
+ cacheURI :: URI -> URI
+ cacheURI uri = uri {uriPath = uriPath uri </> indexFile}
-updateCache :: HPAction ()
-updateCache = do
- path <- getOverlayPath
- cfg <- getCfg
- let cache = cacheURI $ server cfg
- res <- (liftIO $ simpleHTTP (Request cache GET [] "")) `sayNormal` ("Fetching cache from "++show cache++"...",const "done.")
- case res of
- Left err -> throwError (ConnectionFailed (show cache) (show err))
- Right resp -> liftIO $ do
- createDirectoryIfMissing False (path </> hackportDir)
- Prelude.writeFile (cacheFile path) (rspBody resp)
-readCache :: FilePath -> HPAction Index
+readCache :: FilePath -> IO Index
readCache portdir = do
- let cachePath = cacheFile portdir
- exists <- liftIO $ doesFileExist cachePath
- unless exists $ do
- info "No cache file present, attempting to update..."
- updateCache
- str <- liftIO $ L.readFile cachePath
- return $ readIndex str
+ let cachePath = cacheFile portdir
+ -- TODO: re-implement
+ -- exists <- doesFileExist cachePath
+ -- unless exists $ do
+ -- info "No cache file present, attempting to update..."
+ -- updateCache
+ str <- L.readFile cachePath
+ return (readIndex str)
-readDefaultCache :: HPAction Index
-readDefaultCache = do
- overlayPath <- getOverlayPath
- readCache overlayPath
+readDefaultCache :: Verbosity -> IO Index
+readDefaultCache verbose = getOverlayPath verbose >>= readCache
indexToPortage :: Index -> Portage -> (Portage, [String])
indexToPortage index port = second nub . runWriter $ do
View
@@ -16,20 +16,12 @@ data HackPortOptions
data OperationMode
= List String
| Merge String
- | DiffTree DiffMode
+ -- | DiffTree DiffMode
| Update
| ShowHelp
| Status String
| MakeEbuild String
-data DiffMode
- = ShowAll
- | ShowMissing
- | ShowAdditions
- | ShowNewer
- | ShowCommon
- deriving Eq
-
data Config = Config
{ overlayPath ::Maybe String
, portagePath ::Maybe String
@@ -78,25 +70,25 @@ parseConfig opts = let
"merge":[] -> Left "Need a package's name and version to merge it.\n"
"merge":package:[] -> Right (Merge package)
"merge":_:rest -> Left ("'merge' takes 1 argument("++show ((length rest)+1)++" given).\n")
- "list":[] -> Right (List "")
- "list":package:[] -> Right (List package)
- "list":rest -> Left ("'list' takes at most one argument ("++show (length rest)++" given).\n")
- "diff":[] -> Right (DiffTree ShowAll)
- "diff":"all":[] -> Right (DiffTree ShowAll)
- "diff":"missing":[] -> Right (DiffTree ShowMissing)
- "diff":"additions":[] -> Right (DiffTree ShowAdditions)
- "diff":"newer":[] -> Right (DiffTree ShowNewer)
- "diff":"common":[] -> Right (DiffTree ShowCommon)
- "diff":arg:[] -> Left ("Unknown argument to diff: '" ++ arg ++ "'. Use all,missing,additions,newer or common.\n")
- "diff":_:xs -> Left ("'diff' takes one argument("++show ((length xs)+1)++" given).\n")
+ -- "list":[] -> Right (List "")
+ -- "list":package:[] -> Right (List package)
+ -- "list":rest -> Left ("'list' takes at most one argument ("++show (length rest)++" given).\n")
+ -- "diff":[] -> Right (DiffTree ShowAll)
+ -- "diff":"all":[] -> Right (DiffTree ShowAll)
+ -- "diff":"missing":[] -> Right (DiffTree ShowMissing)
+ -- "diff":"additions":[] -> Right (DiffTree ShowAdditions)
+ -- "diff":"newer":[] -> Right (DiffTree ShowNewer)
+ -- "diff":"common":[] -> Right (DiffTree ShowCommon)
+ -- "diff":arg:[] -> Left ("Unknown argument to diff: '" ++ arg ++ "'. Use all,missing,additions,newer or common.\n")
+ -- "diff":_:xs -> Left ("'diff' takes one argument("++show ((length xs)+1)++" given).\n")
"update":[] -> Right Update
"update":rest -> Left ("'update' takes zero arguments("++show (length rest)++" given).\n")
- "status":[] -> Right (Status "")
- "status":"toportage":[] -> Right (Status "toportage")
- "status":xs-> Left ("invalid argument(s) to 'status': " ++ show xs)
- "make-ebuild":[] -> Left "Need .cabal file to make ebuild."
- "make-ebuild":package:[] -> Right (MakeEbuild package)
- "make-ebuild":_:rest -> Left ("'make-ebuild' takes 1 argument("++show ((length rest)+1)++" given).\n")
+ -- "status":[] -> Right (Status "")
+ -- "status":"toportage":[] -> Right (Status "toportage")
+ -- "status":xs-> Left ("invalid argument(s) to 'status': " ++ show xs)
+ -- "make-ebuild":[] -> Left "Need .cabal file to make ebuild."
+ -- "make-ebuild":package:[] -> Right (MakeEbuild package)
+ -- "make-ebuild":_:rest -> Left ("'make-ebuild' takes 1 argument("++show ((length rest)+1)++" given).\n")
[] -> Right ShowHelp
_ -> Left "Unknown opertation mode\n"
Oops, something went wrong.

0 comments on commit a1730ad

Please sign in to comment.