hub 0.0 → 1.0.0
raw patch · 35 files changed
+3833/−48 lines, 35 filesdep +arraydep +fgldep +utf8-stringdep −haskell98dep ~basedep ~hexpatbinary-added
Dependencies added: array, fgl, utf8-string
Dependencies removed: haskell98
Dependency ranges changed: base, hexpat
Files
- .gitignore +2/−1
- .hub +0/−1
- .project +0/−11
- Hub/CommandLine.hs +184/−0
- Hub/Commands.hs +274/−0
- Hub/Directory.hs +491/−0
- Hub/Directory/Allocate.hs +37/−0
- Hub/Discover.hs +72/−0
- Hub/FilePaths.hs +56/−0
- Hub/Help.hs +68/−0
- Hub/HelpText.hs +210/−0
- Hub/Hub.hs +196/−0
- Hub/Oops.hs +52/−0
- Hub/PackageDB.hs +275/−0
- Hub/Parse.hs +291/−0
- Hub/Poss.hs +29/−0
- Hub/Prog.hs +63/−0
- Hub/SaveLoad.hs +112/−0
- Hub/System.hs +201/−0
- Makefile +26/−0
- README +12/−0
- Version.hs +20/−0
- build-hub.har +11/−0
- help.txt +205/−0
- hub.cabal +94/−34
- hub.hs +73/−1
- man/Makefile +19/−0
- man/bin/fixup.sh +28/−0
- man/hub-1.txt +526/−0
- man/hub-5.txt +120/−0
- man/hub.1.gz binary
- man/hub.5.gz binary
- man/manpage-base.xsl +35/−0
- man/manpage-normal.xsl +13/−0
- prep.hs +38/−0
.gitignore view
@@ -1,3 +1,4 @@+.hub .project dist build@@ -5,4 +6,4 @@ *~ *.hi *.o-.hub+PACKAGE_ME
− .hub
@@ -1,1 +0,0 @@-hub
− .project
@@ -1,11 +0,0 @@-<?xml version="1.0" encoding="UTF-8"?>-<projectDescription>- <name>hub</name>- <comment></comment>- <projects>- </projects>- <buildSpec>- </buildSpec>- <natures>- </natures>-</projectDescription>
+ Hub/CommandLine.hs view
@@ -0,0 +1,184 @@+--+-- >>> Hub.CommandLine <<<+--+-- This module parses the command line.+--+-- (c) 2011-2012 Chris Dornan+++module Hub.CommandLine+ ( commandLine+ , CommandLine(..)+ ) where++import Text.Printf+import Control.Monad+import System.Environment+import System.FilePath+import qualified Data.Map as Map+import Hub.Help+import Hub.Oops+import Hub.Prog+import Hub.Hub+import Hub.Directory+import Hub.Discover+import Hub.PackageDB+++commandLine :: IO CommandLine+commandLine =+ do as <- getArgs+ mb <- prog as+ mb' <- maybe (hub_dispatch as) (return.Just) mb+ case mb' of+ Nothing -> return $ HelpCL True usage+ Just cl -> return cl+++data CommandLine+ = ProgCL Hub (Prog,[String])+ | HelpCL Bool String -- False => help, True => usage+ | VrsnCL+ | DfltCL+ | StDfCL Hub+ | RsDfCL+ | LsCL Bool Bool -- -a -q+ | GetCL+ | SetCL Hub+ | UnsetCL+ | NameCL Hub+ | InfoCL Hub+ | LockCL Hub+ | UnlockCL Hub+ | PathCL Hub+ | XmlCL Hub+ | InitCL Hub HubName Bool -- -s+ | CommentCL Hub String+ | CpCL Hub HubName+ | MvCL Hub HubName+ | RmCL Hub+ | SwapCL Hub HubName+ | GcCL+ | ListCL Hub+ | CheckCL Hub+ | SaveCL Hub+ | LoadCL HubName+ | VerifyCL Hub Bool -- -s+ | InstallCL Hub [PkgNick]+ | EraseCL Hub [PkgNick] Bool -- -f+ deriving (Show)++++prog, hub_dispatch :: [String] -> IO (Maybe CommandLine)++prog as =+ do pn <- getProgName+ let (_,p_s) = splitFileName pn+ case Map.lookup p_s progMap of+ Nothing -> return Nothing+ Just prg ->+ do hub <- discover Nothing+ return $ Just $ ProgCL hub (prg,as)+++hub_dispatch as = case as of+ ["--help" ] -> return $ Just $ HelpCL False helpText+ ["help" ] -> return $ Just $ HelpCL False helpText+ ["--help",cd ] -> help cd >>= \hlp -> return $ Just $ HelpCL False hlp+ ["help" ,cd ] -> help cd >>= \hlp -> return $ Just $ HelpCL False hlp+ ["--version" ] -> return $ Just VrsnCL+ ["version" ] -> return $ Just VrsnCL+ ["--usage" ] -> return $ Just $ HelpCL False usage+ ["usage" ] -> return $ Just $ HelpCL False usage+ ["default" ] -> return $ Just $ DfltCL+ ["default" ,"-" ] -> return $ Just $ RsDfCL+ ["default" ,hn ] -> discover (Just hn) >>= \ hub -> return $ Just $ StDfCL hub+ ["ls" ] -> return $ Just $ LsCL False False+ ["ls","-a" ] -> return $ Just $ LsCL True False+ ["ls","-q" ] -> return $ Just $ LsCL False True+ ["ls","-a","-q" ] -> return $ Just $ LsCL True True+ ["ls","-q","-a" ] -> return $ Just $ LsCL True True+ ["set" ] -> return $ Just $ GetCL+ ["set" ,"-" ] -> return $ Just $ UnsetCL+ ["set" ,hn ] -> discover (Just hn) >>= \ hub -> return $ Just $ SetCL hub+ ["name" ] -> discover Nothing >>= \ hub -> return $ Just $ NameCL hub+ ["info" ] -> discover Nothing >>= \ hub -> return $ Just $ InfoCL hub+ ["info" ,hn ] -> discover (Just hn) >>= \ hub -> return $ Just $ InfoCL hub+ ["lock" ] -> discover Nothing >>= \ hub -> return $ Just $ LockCL hub+ ["lock" ,hn ] -> discover (Just hn) >>= \ hub -> return $ Just $ LockCL hub+ ["unlock" ] -> discover Nothing >>= \ hub -> return $ Just $ UnlockCL hub+ ["unlock" ,hn ] -> discover (Just hn) >>= \ hub -> return $ Just $ UnlockCL hub+ ["path" ] -> discover Nothing >>= \ hub -> return $ Just $ PathCL hub+ ["path" ,hn ] -> discover (Just hn) >>= \ hub -> return $ Just $ PathCL hub+ ["xml" ] -> discover Nothing >>= \ hub -> return $ Just $ XmlCL hub+ ["xml" ,hn ] -> discover (Just hn) >>= \ hub -> return $ Just $ XmlCL hub+ ["init" ] -> hub_uniq Nothing >>= \(hub,hn') -> return $ Just $ InitCL hub hn' True+ ["init","-n" ] -> hub_uniq Nothing >>= \(hub,hn') -> return $ Just $ InitCL hub hn' True+ ["init","-n" ,hn ] -> hub_uniq (Just hn) >>= \(hub,hn') -> return $ Just $ InitCL hub hn' True+ ["init","-s" ,hn' ] -> hub_pair Nothing hn' >>= \ hub -> return $ Just $ InitCL hub hn' True+ ["init","-s" ,hn,hn' ] -> hub_pair (Just hn) hn' >>= \ hub -> return $ Just $ InitCL hub hn' True+ ["init" ,hn' ] -> hub_pair Nothing hn' >>= \ hub -> return $ Just $ InitCL hub hn' False+ ["init" ,hn,hn' ] -> hub_pair (Just hn) hn' >>= \ hub -> return $ Just $ InitCL hub hn' False+ ["comment" ,cmt ] -> discover Nothing >>= \ hub -> return $ Just $ CommentCL hub cmt+ ["comment" ,hn,cmt ] -> discover (Just hn) >>= \ hub -> return $ Just $ CommentCL hub cmt+ ["cp" ,hn' ] -> hub_pair Nothing hn' >>= \ hub -> return $ Just $ CpCL hub hn'+ ["cp" ,hn,hn' ] -> hub_pair (Just hn) hn' >>= \ hub -> return $ Just $ CpCL hub hn'+ ["mv" ,hn' ] -> hub_pair Nothing hn' >>= \ hub -> return $ Just $ MvCL hub hn'+ ["mv" ,hn,hn' ] -> hub_pair (Just hn) hn' >>= \ hub -> return $ Just $ MvCL hub hn'+ ["rm" ,hn' ] -> discover (Just hn') >>= \ hub -> return $ Just $ RmCL hub+ ["swap" ,hn' ] -> hub_swap Nothing hn' >>= \ hub -> return $ Just $ SwapCL hub hn'+ ["swap" ,hn,hn' ] -> hub_swap (Just hn) hn' >>= \ hub -> return $ Just $ SwapCL hub hn'+ ["gc" ] -> return $ Just $ GcCL+ ["list" ] -> discover Nothing >>= \ hub -> return $ Just $ ListCL hub+ ["list" ,hn ] -> discover (Just hn) >>= \ hub -> return $ Just $ ListCL hub+ ["check" ] -> discover Nothing >>= \ hub -> return $ Just $ CheckCL hub+ ["check" ,hn ] -> discover (Just hn) >>= \ hub -> return $ Just $ CheckCL hub+ ["save" ] -> discover Nothing >>= \ hub -> return $ Just $ SaveCL hub+ ["save" ,hn ] -> discover (Just hn) >>= \ hub -> return $ Just $ SaveCL hub+ ["load" ] -> dscvr_nm Nothing >>= \ hn' -> return $ Just $ LoadCL hn'+ ["load" ,hn' ] -> return $ Just $ LoadCL hn'+ ["verify","-s" ] -> discover Nothing >>= \ hub -> return $ Just $ VerifyCL hub True+ ["verify","-s" ,hn ] -> discover (Just hn) >>= \ hub -> return $ Just $ VerifyCL hub True+ ["verify" ] -> discover Nothing >>= \ hub -> return $ Just $ VerifyCL hub False+ ["verify" ,hn ] -> discover (Just hn) >>= \ hub -> return $ Just $ VerifyCL hub False+ "install" :p:ps -> hub_pks Nothing p ps >>= \(hub,pkns) -> return $ Just $ InstallCL hub pkns+ "install-into" :hn :p:ps -> hub_pks (Just hn) p ps >>= \(hub,pkns) -> return $ Just $ InstallCL hub pkns+ "erase": "-f" :p:ps -> hub_pks Nothing p ps >>= \(hub,pkns) -> return $ Just $ EraseCL hub pkns True+ "erase-from":"-f":hn :p:ps -> hub_pks (Just hn) p ps >>= \(hub,pkns) -> return $ Just $ EraseCL hub pkns True+ "erase" :p:ps -> hub_pks Nothing p ps >>= \(hub,pkns) -> return $ Just $ EraseCL hub pkns False+ "erase-from" :hn :p:ps -> hub_pks (Just hn) p ps >>= \(hub,pkns) -> return $ Just $ EraseCL hub pkns False+ _ -> return Nothing+++hub_uniq :: Maybe HubName -> IO (Hub,HubName)+hub_uniq mb =+ do hub <- discover mb+ (,) hub `fmap` allocHub++hub_pair, hub_swap :: Maybe HubName -> HubName -> IO Hub+hub_pair = hub_pair' False+hub_swap = hub_pair' True++hub_pair' :: Bool -> Maybe HubName -> HubName -> IO Hub+hub_pair' sw mb_hn hn' =+ do hub <- discover mb_hn+ let hn = name__HUB hub+ _ <- checkHubName [UsrHK,GlbHK] hn+ _ <- checkHubName [UsrHK ] hn'+ when (hn==hn') $+ oops HubO $ printf "%s: same source and destination" hn'+ when sw $+ userHubExists hn'+ when (not sw) $+ userHubAvailable hn'+ return hub++dscvr_nm :: Maybe HubName -> IO HubName+dscvr_nm mb = name__HUB `fmap` discover mb++hub_pks :: Maybe HubName -> String -> [String] -> IO (Hub,[PkgNick])+hub_pks mb p ps =+ do hub <- discover mb+ pkns <- mapM parsePkgNick (p:ps)+ return (hub,pkns)
+ Hub/Commands.hs view
@@ -0,0 +1,274 @@+--+-- >>> Hub.Commands <<<+--+-- This module provides the routines the Main dispatcher calls fater analysing+-- the CommandLine AST.+--+-- (c) 2011-2012 Chris Dornan+++module Hub.Commands+ ( _prog+ , _default+ , _default_hub+ , _ls+ , _get+ , _set+ , _unset+ , _name+ , _info+ , _lock+ , _unlock+ , _path+ , _xml+ , _init+ , _comment+ , _cp+ , _mv+ , _rm+ , _swap+ , _gc+ , _list+ , _check+ , _load+ , _save+ , _verify+ , _install+ , _erase+ ) where++import Data.Char+import Control.Monad+import System.FilePath+import System.Directory+import Text.Printf+import Hub.FilePaths+import Hub.Oops+import Hub.System+import Hub.Prog+import Hub.Hub+import Hub.PackageDB+import Hub.Directory+import Hub.Parse+import Hub.Discover+import Hub.SaveLoad++++_prog :: Hub -> Prog -> [String] -> IO ()+_prog = execProg HubO (EE InheritRS InheritRS []) FullMDE+++_default :: IO ()+_default = defaultGlobalHubName >>= putStrLn++_default_hub :: Maybe Hub -> IO ()+_default_hub Nothing = fileExists defaultHubPath >>= \ex -> when ex $ removeFile defaultHubPath+_default_hub (Just hub) = is_global hub >> writeAFile defaultHubPath (name__HUB hub)++is_global :: Hub -> IO ()+is_global hub = when (kind__HUB hub/=GlbHK) $+ oops HubO $ printf "%s: not a global hub" $name__HUB hub+++_ls :: Bool -> Bool -> IO ()+_ls af qf =+ do hns <- lsHubs [UsrHK,GlbHK]+ hubs <- mapM (discover . Just) $ filter chk hns+ putStr $ unlines $ [ fmt nm co lk | hub<-hubs,+ let nm = name__HUB hub,+ let co = commntHUB hub,+ let lk = if lockedHUB hub then "L" else " " ]+ where+ chk ('_':'_':_) = af+ chk _ = True++ fmt nm co lk = case qf of+ True -> nm+ False -> printf "%-20s %s -- %s" nm lk co++_get :: IO ()+_get =+ do yup <- fileExists ".hub"+ case yup of+ False -> putStrLn "No hub set for this directory"+ True ->+ do hn <- trim `fmap` readAFile ".hub"+ _ <- checkHubName [UsrHK,GlbHK] hn+ putStrLn hn++_set :: Hub -> IO ()+_set hub = writeAFile ".hub" $ name__HUB hub ++ "\n"++_unset :: IO ()+_unset =+ do yup <- fileExists ".hub"+ case yup of+ False -> putStrLn "No hub set for this directory"+ True -> removeFile ".hub"++_name :: Hub -> IO ()+_name hub = putStrLn $ name__HUB hub++_info :: Hub -> IO ()+_info hub = putStr $ unlines $+ [ printf "%-23s%s" (name++hs++lk) cmt ] +++ [ printf " GHC : %s" hc | Just hc <- [bin2toolchain hc_bin] ] +++ [ printf " Haskell Platform : %s" hp | Just hp <- [db2platform glb_db] ] +++ [ printf " Tools : %s" hc_bin ] +++ [ " Package DBs" | True ] +++ [ printf " global : %-50s (%s)" glb_db gh | True ] +++ [ printf " user : %-50s (%s)" usr_db uh | Just usr_db <- [mb_ud], True ]+ where+ hs = case sourceHUB hub of+ ClHS -> " "+ EvHS -> " [ENV] "+ DrHS -> " [DIR] "+ DsHS -> " [SYS] "+ lk = case lockedHUB hub of+ True -> "[LOCKED] "+ False -> " "+ gh = case usr_ghHUB hub of+ Nothing -> name+ Just hn -> hn+ uh = name+ cmt = if null cmt0 then "" else "-- " ++ cmt0+ name = name__HUB hub+ cmt0 = commntHUB hub+ hc_bin = hc_binHUB hub+ glb_db = glb_dbHUB hub+ mb_ud = usr_dbHUB hub++_lock :: Hub -> IO ()+_lock hub = lock True hub++_unlock :: Hub -> IO ()+_unlock hub = lock False hub++lock :: Bool -> Hub -> IO ()+lock lck hub =+ case usr_dbHUB hub of+ Nothing -> oops HubO msg+ Just dr ->+ do cs <- filter isc `fmap` getDirectoryContents dr+ lockFileDir True lck dr+ mapM_ (lockFileDir False lck) [dr</>c|c<-cs]+ dump lk_hub+ where+ isc fp = case reverse fp of+ 'f':'n':'o':'c':'.':_ -> True+ 'e':'h':'c':'a':'c':_ -> True+ _ -> False++ lk_hub = hub { usr___HUB = fmap lk' $ usr___HUB hub }++ lk' uhb = uhb { lockedUHB = lck }++ msg = printf "%s: cannot (un)lock a global hub" $ name__HUB hub++_path :: Hub -> IO ()+_path hub = putStrLn $ path__HUB hub++_xml :: Hub -> IO ()+_xml hub = readAFile (path__HUB hub) >>= putStr++_init :: Hub -> HubName -> Bool -> IO ()+_init hub0 hn sf =+ do hub <- createHub' False hub0 hn sf+ when sf $ _set hub++_comment :: Hub -> String -> IO ()+_comment hub cmt = dump $ hub { commntHUB = cmt }++_cp :: Hub -> HubName -> IO ()+_cp hub hn = createHub True hub hn++_mv :: Hub -> HubName -> IO ()+_mv hub hn = renameHub hub hn++_rm :: Hub -> IO ()+_rm = deleteHub++_swap :: Hub -> HubName -> IO ()+_swap hub1 hn2 =+ do hub2 <- discover $ Just hn2+ swapHub hub1 hub2++_gc :: IO ()+_gc = gcDefaultDirectory discover VerboseGCM++_list :: Hub -> IO ()+_list hub = execP HubO (EE InheritRS InheritRS []) FullMDE hub Ghc_pkgP ["list"]++_check :: Hub -> IO ()+_check hub = execP HubO (EE InheritRS InheritRS []) FullMDE hub Ghc_pkgP ["check"]++_save :: Hub -> IO ()+_save = save++_load :: HubName -> IO ()+_load hn =+ do _ <- checkHubName [UsrHK] hn+ thr <- doesHubExist hn+ mb <- case thr of+ True -> Just `fmap` discover (Just hn)+ False -> return Nothing+ pd <- load hn mb False+ let hub = hubPD pd+ sps = surPD pd+ mps = msgPD pd+ aps = allPD pd+ case sps of+ [] -> return ()+ _:_ -> _erase hub sps True+ case sps++mps of+ [] -> return ()+ _:_ -> _install hub aps++_verify :: Hub -> Bool -> IO ()+_verify hub sf =+ do _ <- checkHubName [UsrHK] $ name__HUB hub+ pd <- load (name__HUB hub) (Just hub) True+ let sps = surPD pd+ mps = msgPD pd+ case (sf,sps) of+ (True,_:_) -> oops_sm "surplus" sps+ _ -> return ()+ case mps of+ [] -> return ()+ _:_ -> oops_sm "missing" mps+ where+ oops_sm adj ps = oops HubO $ adj ++ " packages: " +++ unwords (map prettyPkgNick ps)++_install :: Hub -> [PkgNick] -> IO ()+_install hub pkns =+ do notLocked hub+ execP HubO (EE InheritRS InheritRS []) FullMDE hub CabalP+ ("install":map prettyPkgNick pkns)++_erase :: Hub -> [PkgNick] -> Bool -> IO ()+_erase hub pkns0 ff =+ do notLocked hub+ (pkns,d_pkns) <- eraseClosure hub pkns0+ putStr "Packages requested to be deleted:\n"+ putStr $ unlines $ map fmt pkns+ putStr "Dependent packages also to be deleted:\n"+ putStr $ unlines $ map fmt d_pkns+ go <- case ff of+ True ->+ return True+ False ->+ do putStr "Would you like to delete these packages? [n]\n"+ yn <- getLine+ return $ map toLower yn `elem` ["y","yes"]+ case go of+ True ->+ do mapM_ unreg $ pkns ++ d_pkns+ putStr "package(s) deleted.\n"+ False -> putStrLn "No modules deleted."+ where+ fmt pkn = " " ++ prettyPkgNick pkn++ unreg pkn = execP HubO (EE InheritRS DiscardRS []) UserMDE hub+ Ghc_pkgP ["unregister",prettyPkgNick pkn]
+ Hub/Directory.hs view
@@ -0,0 +1,491 @@+--+-- >>> Hub.Directory <<<+--+-- All user hubs are managed in ~/.hubrc, the 'directory'. This module tries+-- to abstract the messy details.+--+-- (c) 2011-2012 Chris Dornan+++module Hub.Directory+ ( initDirectory+ , userHubExists+ , userHubAvailable+ , hubExists+ , doesHubExist+ , isUserHub+ , userHubPath+ , globalHubPath+ , defaultGlobalHubName+ , lsHubs+ , bin2toolchain+ , db2platform+ , allocHub+ , createHub+ , createHub'+ , renameHub+ , deleteHub+ , swapHub+ , notLocked+ , defaultDirectoryPath+ , GCMode(..)+ , gcDefaultDirectory+ ) where+++import qualified Control.Exception as E+import Control.Monad+import Data.List+import qualified Data.Map as Map+import System.IO+import System.FilePath+import System.Directory+import System.Environment+import Text.Printf+import Text.Regex+import Hub.FilePaths+import Hub.Oops+import Hub.System+import Hub.Prog+import Hub.Hub+import Hub.Parse+import Hub.PackageDB+++-- ensure the default directory structure in user's home directory+-- is initialised++initDirectory :: IO ()+initDirectory =+ do (hub,lib) <- user_hub_dirs+ createDirectoryIfMissing True hub+ createDirectoryIfMissing True lib+++-- check that a hub name denotes a named user hub that either+-- exists (userHubExists) or or has not been created (userHubAvailable)++userHubExists, userHubAvailable :: HubName -> IO ()++userHubExists hn =+ do _ <- checkHubName [UsrHK] hn+ hubExists hn++userHubAvailable hn =+ do _ <- checkHubName [UsrHK] hn+ iuh <- isUserHub hn+ case iuh of+ True -> oops PrgO $ printf "%s: hub already in use" hn+ False -> return ()++-- check that the named hub exists++++hubExists :: HubName -> IO ()+hubExists hn =+ do ok <- doesHubExist hn+ case ok of+ True -> return ()+ False -> oops PrgO $ printf "%s: no such hub" hn++doesHubExist :: HubName -> IO Bool+doesHubExist hn =+ do hf <- case isHubName hn of+ Just GlbHK -> return $ globalHubPath hn+ Just UsrHK -> userHubPath hn+ Nothing -> oops PrgO $ printf "%s: bad hub name"+ fileExists hf++-- test whether a user hub exists++isUserHub :: HubName -> IO Bool+isUserHub hn = userHubPath hn >>= fileExists++-- generate the path of the Hub XML config file file for a+-- user hub (userHubPath) and global hub (globalHubPath)++userHubPath :: HubName -> IO FilePath+userHubPath hn = (\(h_fp,_,_)->h_fp) `fmap` user_hub_paths hn++globalHubPath :: HubName -> FilePath+globalHubPath hn = globalHubDir </> hn2fp hn+++-- get the default global hub name++defaultGlobalHubName :: IO HubName+defaultGlobalHubName = sel+ [ usr_df -- user-spec default+ , dro_df -- O/S distro default (may not be installed)+ , sys_df -- Hub system default (may not be installed)+ , lhp_df -- looks like the latest H.P. (guess)+ , lst_df -- lexigographical maximum+ ]+ where+ sel [] = oops PrgO "no global hubs!"+ sel (p:ps) =+ do ei <- tryIO $ trim `fmap` p+ case ei of+ Left _ -> sel ps+ Right hn ->+ do ex <- fileExists $ globalHubPath hn+ case ex of+ True -> return hn+ False -> sel ps++ usr_df = trim `fmap` readAFile defaultHubPath++ dro_df = trim `fmap` readAFile distroDefaultHubPath++ sys_df = trim `fmap` readAFile sysDefaultHubPath++ lhp_df = mx_fr $ gmatch hp_hub_re++ lst_df = mx_fr $ const True++ mx_fr p = (filter p `fmap` lsHubs [GlbHK]) >>= mx++ mx [] = ioError $ userError "Hub.Hub: internal error"+ mx (x:xs) = return $ foldl max x xs++ hp_hub_re = mk_re "20[0-9][0-9]\\.[0-9]\\.[0-9]\\.[0-9]"++-- list hubs++lsHubs :: [HubKind] -> IO [HubName]+lsHubs hks = concat `fmap` mapM ls (sort hks)+ where+ ls GlbHK = ls_glb_hubs+ ls UsrHK = ls_usr_hubs++-- convert 'bin' and 'db' paths to corresponding toolchai8ns and platforms++bin2toolchain, db2platform :: FilePath -> Maybe String+bin2toolchain = match $ mk_re hcBinREs+db2platform = match $ mk_re hpDbREs++-- allocate, create/copy, rename, delete and swap hubs++allocHub :: IO HubName+allocHub =+ do (hd,_) <- user_hub_dirs+ alloc `fmap` getDirectoryContents hd+ where+ alloc gns = printf "__h%03d" $+ (1+) $ maximum $ -1:[ i | Just i<-map prs gns ]++ prs fp = case reverse fp of+ 'l':'m':'x':'.':t -> prs' $ reverse t+ _ -> Nothing+++ prs' :: String -> Maybe Int+ prs' ('_':'_':'h':t) = readMB t+ prs' _ = Nothing++createHub :: Bool -> Hub -> HubName -> IO ()+createHub cp hub0 hn = const () `fmap` createHub' cp hub0 hn False++createHub' :: Bool -> Hub -> HubName -> Bool -> IO Hub+createHub' cp hub0 hn sf =+ do userHubAvailable hn+ (h_fp,lib,db) <- user_hub_paths hn+ createDirectoryIfMissing True lib+ case cp of+ True ->+ do db0 <- hub_user_db hub0+ cpFileDir db0 db+ False ->+ pkg_init hub0 db+ dy <- defaultDirectoryPath+ let gh = maybe (name__HUB hub0) id $ usr_ghHUB hub0+ lk = lockedHUB hub0+ hub1 = hub0 { name__HUB = hn+ , kind__HUB = UsrHK+ , path__HUB = h_fp+ , usr___HUB = Just $ UHB dy gh db lk+ }+ hub <- defaultComment sf hub1+ dump hub+ return hub++defaultComment :: Bool -> Hub -> IO Hub+defaultComment sf hub =+ case sf of+ True ->+ do cwd <- getCurrentDirectory+ return $ hub { commntHUB = cwd }+ False ->+ return $ hub { commntHUB = "" }++renameHub :: Hub -> HubName -> IO ()+renameHub hub0 hn =+ do not_global hub0+ notLocked hub0+ lib0 <- hub_user_lib hub0+ (h_fp,lib,db) <- user_hub_paths hn+ mvFileDir lib0 lib+ removeFile $ path__HUB hub0+ let f uhb = uhb { usr_dbUHB=db }+ hub = hub0 { name__HUB=hn+ , path__HUB=h_fp+ , usr___HUB=fmap f $ usr___HUB hub0+ }+ dump hub++deleteHub :: Hub -> IO ()+deleteHub hub =+ do not_global hub+ notLocked hub+ (h_fp,lib,_) <- user_hub_paths $ name__HUB hub+ removeFile h_fp+ removeRF lib++swapHub :: Hub -> Hub -> IO ()+swapHub hub1 hub2 =+ do _ <- not_global hub1+ _ <- not_global hub2+ (_,lib1,_) <- user_hub_paths (name__HUB hub1)+ (_,lib2,_) <- user_hub_paths (name__HUB hub2)+ let hub1' = hub1 {name__HUB=name__HUB hub2,path__HUB=path__HUB hub2,usr___HUB=usr___HUB hub2}+ hub2' = hub2 {name__HUB=name__HUB hub1,path__HUB=path__HUB hub1,usr___HUB=usr___HUB hub1}+ dump hub1'+ dump hub2'+ swap_files lib1 lib2++notLocked :: Hub -> IO ()+notLocked hub =+ case lockedHUB hub of+ True -> oops HubO $ printf "%s: this hub is locked" $ name__HUB hub+ False -> return ()++-- return the path of the default directory++defaultDirectoryPath :: IO FilePath+defaultDirectoryPath = home >>= \hme -> return $ printf "%s/.hubrc" hme++heap_dir :: FilePath -> FilePath+heap_dir = printf "%s/.hubrc/heap"++-- GC the default directory++data GCMode = DebugGCM | VerboseGCM | QuietGCM+ deriving (Show)++gcDefaultDirectory :: (Maybe HubName->IO Hub) -> GCMode -> IO ()+gcDefaultDirectory discover gcm =+ do hns <- lsHubs [ hk | hk<-[minBound..maxBound], hk/=GlbHK ]+ hubs <- mapM discover $ map Just hns+ dirs <- concat `fmap` mapM importLibraryDirs hubs+ hdir <- heap_dir `fmap` home+ hcts <- getDirectoryContents hdir+ let hnds = Map.fromList [ (nd,()) | Just nd <- map readMB hcts ]+ l_hnds = dirs2heap_node_set hdir dirs+ g_hnds = hnds `Map.difference` l_hnds+ --putStrLn $ printf "---hnds---\n%s\n----------\n\n" $ show hnds+ --putStrLn $ printf "--l_hnds--\n%s\n----------\n\n" $ show l_hnds+ --putStrLn $ printf "--g_hnds--\n%s\n----------\n\n" $ show g_hnds+ --putStrLn $ printf "---hdir---\n%s\n----------\n\n" $ show hdir+ --putStrLn $ printf "---dirs---\n%s\n----------\n\n" $ show dirs+ case gcm of+ DebugGCM -> hPutStrLn stderr $ printf "GC: %s" $ unwords $ map show $ Map.keys g_hnds+ VerboseGCM -> hPutStrLn stderr $ printf "GC: %d nodes collected" $ Map.size g_hnds+ QuietGCM -> return ()+ collect hdir $ map show $ Map.keys g_hnds++++--+-- GC Helpers+--++collect :: FilePath -> [FilePath] -> IO ()+collect dir sdirs = mapM_ clct sdirs+ where+ clct = case True of+ True -> stash+ False -> trash++ stash sdir =+ do hme <- home+ createDirectoryIfMissing False $ garbage hme+ mvFileDir (dir</>sdir) (garbage hme</>sdir)++ trash sdir = removeR (dir</>sdir)++dirs2heap_node_set :: FilePath -> [FilePath] -> Map.Map Int ()+dirs2heap_node_set hdir dirs =+ Map.fromList [ (nd,()) | Just nd<-map (dir2heap_node hdir) dirs ]++dir2heap_node :: FilePath -> FilePath -> Maybe Int+dir2heap_node hdir dir =+ case hdir `isPrefixOf` dir of+ True -> readMB nd_s+ False -> Nothing+ where+ nd_s = takeWhile (not . isPathSeparator) $+ dropWhile isPathSeparator $ drop (length hdir) dir++readMB :: Read a => String -> Maybe a+readMB str =+ case [ x | (x,t)<-reads str, ("","")<-lex t ] of+ [x] -> Just x+ _ -> Nothing++++--+-- Directory Structure+--+-- (see also 'defaultDirectoryPath', 'allocateDefaultDirectory' and+-- gcDefaultDirectory above)+--+++package_config :: FilePath+package_config = "package.config"++user_lib :: FilePath -> HubName -> FilePath+user_lib hme hn = printf "%s/.hubrc/lib/%s" hme hn++garbage :: FilePath -> FilePath+garbage = printf "%s/.hubrc/garbage"++db_re :: String -> Regex+db_re hme = mk_re $ printf "%s/.hubrc/lib/([^/]*)/%s/?" hme package_config++hn2fp :: HubName -> FilePath+hn2fp = (++ ".xml")++fp2hn :: FilePath -> Maybe HubName+fp2hn = match xml_fn_re++xml_fn_re :: Regex+xml_fn_re = mk_re "(.*)\\.xml"++++--+-- Listing Hubs+--+++ls_glb_hubs :: IO [HubName]+ls_glb_hubs = (sort . chk) `fmap` getDirectoryContents globalHubDir+ where+ chk fps = [ hn | fp<-fps, Just hn<-[fp2hn fp], isHubName hn==Just GlbHK ]++ls_usr_hubs :: IO [HubName]+ls_usr_hubs =+ do dp <- fst `fmap` user_hub_dirs+ (sort . chk) `fmap` getDirectoryContents dp+ where+ chk fps = [ hn | fp<-fps, Just hn<-[fp2hn fp], isHubName hn==Just UsrHK ]++++--+-- invoking ghc-pkg+--++pkg_init :: Hub -> FilePath -> IO ()+pkg_init hub fp =+ execP HubO (EE InheritRS InheritRS []) FullMDE hub Ghc_pkgP ["init",fp]+++user_hub_paths :: HubName -> IO (FilePath,FilePath,FilePath)+user_hub_paths hn =+ do (hub,lib) <- user_hub_dirs+ let h_l = lib </> hn+ return (hub </> hn2fp hn, h_l, h_l </> package_config)++user_hub_dirs :: IO (FilePath,FilePath)+user_hub_dirs =+ do hme <- home+ let hub = printf "%s/.hubrc/hub" hme+ lib = printf "%s/.hubrc/lib" hme+ return (hub,lib)++hub_user_lib :: Hub -> IO FilePath+hub_user_lib hub =+ do hme <- home+ db <- hub_user_db hub+ case match (db_re hme) db of+ Just hn | hn==name__HUB hub+ -> return $ user_lib hme hn+ _ -> oops PrgO "hub has non-standard user-database path"++hub_user_db :: Hub -> IO FilePath+hub_user_db hub =+ case usr_dbHUB hub of+ Nothing -> oops PrgO "no user DB speceified for this hub"+ Just db -> return db+++--+-- Swapping Files+--++swap_files :: FilePath -> FilePath -> IO ()+swap_files fp fp' = swap_files'' fp fp' $ oops PrgO++--swap_files' :: FilePath -> FilePath -> IO () -> IO ()+--swap_files' fp fp' tdy = swap_files'' fp fp' $ \err -> tdy >> oops PrgO err++swap_files'' :: FilePath -> FilePath -> (String->IO ()) -> IO ()+swap_files'' fp fp' h = catchIO (sw_files fp fp') $ \_ -> h err+ where+ err = printf "Failed to swap %s and %s (permissions?)" fp fp'++sw_files :: FilePath -> FilePath -> IO ()+sw_files fp_1 fp_2 =+ do fp_t <- mk_tmp 0 fp_1+ mvFileDir fp_1 fp_t+ mvFileDir fp_2 fp_1+ mvFileDir fp_t fp_2++mk_tmp :: Int -> FilePath -> IO FilePath+mk_tmp i fp =+ do yup <- fileDirExists fp'+ case yup of+ True -> mk_tmp (i+1) fp+ False -> return fp'+ where+ fp' = printf "%s-%d" fp i++++--+-- Ensure Hub is not Global+--+++not_global :: Hub -> IO ()+not_global hub = when (kind__HUB hub==GlbHK) $+ oops HubO $ printf "%s: is a global hub" $name__HUB hub++++--+-- Get HOME Environment Variable+--+++home :: IO FilePath+home = catchIO (getEnv "HOME") $ \_ -> return "/"++++--+-- 'try' and 'catch' specialised for IO+--+++tryIO :: IO a -> IO (Either IOError a)+tryIO = E.try+++catchIO :: IO a -> (IOError->IO a) -> IO a+catchIO = E.catch+
+ Hub/Directory/Allocate.hs view
@@ -0,0 +1,37 @@+--+-- >>> Hub.Directory.Allocate <<<+--+-- This module logically belongs to HUb.Directory and would be placed there+-- except doing so would establish an import sysle between Hub.Hub and+-- Hub.Directory through Hub.Parse.+--+-- (c) 2011-2012 Chris Dornan+++module Hub.Directory.Allocate+ ( allocate+ ) where++import qualified Control.Exception as E+import Text.Printf+import System.Directory+import System.Environment+import Hub.System+++-- allocate a library directory from the heap in the (default) directory++allocate :: IO FilePath+allocate =+ do hme <- home+ createDirectoryIfMissing True $ printf "%s/.hubrc/heap" hme+ i <- inc $ printf "%s/.hubrc/heap/counter.txt" hme+ let pth = printf "%s/.hubrc/heap/%d" hme i+ createDirectoryIfMissing True pth+ return pth++home :: IO FilePath+home = catchIO (getEnv "HOME") $ \_ -> return "/"++catchIO :: IO a -> (IOError->IO a) -> IO a+catchIO = E.catch
+ Hub/Discover.hs view
@@ -0,0 +1,72 @@+--+-- >>> Hub.Discover <<<+--+-- 'discover' works out the default hub.+--+-- (c) 2011-2012 Chris Dornan+++module Hub.Discover+ ( discover+ ) where++import qualified Control.Exception as E+import System.Directory+import System.FilePath+import System.Environment+import Hub.System+import Hub.Oops+import Hub.Hub+import Hub.Parse+import Hub.Directory++++discover :: Maybe HubName -> IO Hub+discover Nothing = which_hub >>= read_hub+discover (Just hn) | hn=="^" = discover Nothing+ | otherwise = read_hub (ClHS,hn)+++read_hub :: (HubSource,HubName) -> IO Hub+read_hub (hs,hn) =+ do hk <- checkHubName [minBound..maxBound] hn+ hubExists hn+ hf <- case isHubName hn==Just GlbHK of+ True -> return $ globalHubPath hn+ False -> userHubPath hn+ dy <- defaultDirectoryPath+ parse hs dy hn hf hk++which_hub :: IO (HubSource,HubName)+which_hub =+ do ei <- tryIO $ getEnv "HUB"+ (hs,hn) <- case ei of+ Left _ -> dir_which_hub+ Right s -> env_which_hub s+ _ <- checkHubName [UsrHK,GlbHK] hn+ return (hs,hn)++env_which_hub :: String -> IO (HubSource,HubName)+env_which_hub str =+ case str of+ "--dir" -> dir_which_hub+ "--global" -> (,) DsHS `fmap` defaultGlobalHubName+ _ -> return $ (EvHS,trim str)++dir_which_hub :: IO (HubSource,HubName)+dir_which_hub =+ do ds <- (reverse.splitDirectories) `fmap` getCurrentDirectory+ w_h ds+ where+ w_h [] = (,) DsHS `fmap` defaultGlobalHubName+ w_h (d:ds) = catchIO (here (d:ds)) (\_ -> w_h ds)++ here r_ds = ((,) DrHS . trim) `fmap`+ readAFile (joinPath $ reverse $ ".hub":r_ds)++tryIO :: IO a -> IO (Either IOError a)+tryIO = E.try++catchIO :: IO a -> (IOError->IO a) -> IO a+catchIO = E.catch
+ Hub/FilePaths.hs view
@@ -0,0 +1,56 @@+--+-- >>> Hub.FilePaths <<<+--+-- This module abstracts the layout of /usr/hs -- the system hub area.+--+-- (c) 2011-2012 Chris Dornan+++module Hub.FilePaths where++import Text.Printf+import Text.Regex+import Data.Maybe+++hubLib, sysVersion, distroDefaultHubPath, sysDefaultHubPath,+ defaultHubPath, globalHubDir,+ toolsBin, hubGccBin, hubBinutilsBin :: FilePath++hcBinREs, globalHubREs, hpDbREs :: String++hubLib = "/usr/hs/lib"+sysVersion = "/usr/hs/lib/version.txt"+distroDefaultHubPath = "/usr/hs/lib/distro-default.hub"+sysDefaultHubPath = "/usr/hs/lib/sys-default.hub"+defaultHubPath = "/usr/hs/lib/the-default.hub"+globalHubDir = "/usr/hs/hub"+toolsBin = "/usr/hs/tools"+hubGccBin = "/usr/hs/gcc/bin"+hubBinutilsBin = "/usr/hs/binutils/bin"++hcBinREs = "/usr/hs/ghc/([a-zA-Z0-9_.-]+)/bin"+globalHubREs = "/usr/hs/db/([^/]+)\\.d"+hpDbREs = "/usr/hs/db/("++hp_re++")(\\.d)?"+++hp_re :: String+hp_re = "20[0-9][0-9]\\.[0-9]\\.[0-9]\\.[0-9](-[a-z0-9]*)?"++++--+-- Regular Expression Utilities+--+++mk_re :: String -> Regex+mk_re re_str = mkRegexWithOpts (printf "^%s$" re_str) False True++gmatch :: Regex -> String -> Bool+gmatch re st = isJust $ matchRegex re st++match :: Regex -> String -> Maybe String+match re st = case matchRegex re st of+ Just (se:_) -> Just se+ _ -> Nothing
+ Hub/Help.hs view
@@ -0,0 +1,68 @@+--+-- >>> Hub.Help <<<+--+-- This module provides an interface to the help text 'help.txt',+-- Haskell-encoded in Hub.HelpText.+--+-- (c) 2011-2012 Chris Dornan+++module Hub.Help+ ( help+ , helpText+ , usage+ ) where++import Data.Maybe+import Text.Printf+import Text.Regex+import Hub.HelpText+import Hub.Oops+++help :: String -> IO String+help "" = return helpText+help "--usage" = dd_help `fmap` help "usage"+help "--help" = dd_help `fmap` help "help"+help "--version" = dd_help `fmap` help "version"+help cd =+ case sc_help cd $ lines helpText of+ Nothing -> oops HubO $ printf "%s: hub command not recognised" cd+ Just hlp -> return hlp++dd_help :: String -> String+dd_help ('h':'u':'b':' ':t) = "hub --" ++ t+dd_help hlp = hlp++sc_help :: String -> [String] -> Maybe String+sc_help _ [] = Nothing+sc_help cd (ln:lns) =+ case is_help_hdr cd ln of+ True -> Just $ unlines $ ln : hdr ++ takeWhile is_help_bdy lns'+ False -> sc_help cd lns+ where+ (hdr,lns') = span (is_help_hdr cd) lns++is_help_hdr :: String -> String -> Bool+is_help_hdr cmd = match $ mk_re $ printf "hub %s.*" cmd++is_help_bdy :: String -> Bool+is_help_bdy = not . match not_help_bd_re++not_help_bd_re :: Regex+not_help_bd_re = mk_re "hub.*"++++usage :: String+usage = unlines $ filter is_hdr $ lines helpText+ where+ is_hdr ('h':'u':'b':' ':_) = True+ is_hdr _ = False+++mk_re :: String -> Regex+mk_re re_str = mkRegexWithOpts (printf "^%s$" re_str) False True++match :: Regex -> String -> Bool+match re = isJust . matchRegex re
+ Hub/HelpText.hs view
@@ -0,0 +1,210 @@+module Hub.HelpText(helpText) where++helpText :: String+helpText = unlines+ [ " Hub Help Page"+ , " "+ , " hub --usage is an aliase for the 'hub usage' command"+ , " hub --help is an aliase for the 'hub help' command"+ , " hub --version is an aliase for the 'hub version' command"+ , ""+ , "hub usage"+ , ""+ , " List the syntax of all the hub commands."+ , ""+ , "hub help [<hub-command>]"+ , ""+ , " List the help for a command or all commands if none specified."+ , ""+ , " See \"hub usage\" for a command-syntax summary."+ , ""+ , "hub version"+ , ""+ , " List the version information."+ , ""+ , "hub default [<g-hub>|-]"+ , ""+ , " (Needs to be run as root.)"+ , " "+ , " If no arguments are given then this command lists the the default global"+ , " hub for the system (i.e., the default global hub used to set up each"+ , " user's 'home' hub)."+ , " "+ , " If a global hub <g-hub> is specified then <g-hub> will become the"+ , " default global hub."+ , " "+ , " If a '-' is specified then any older default settings are discarded and"+ , " the system default re-established."+ , ""+ , "hub ls [-a] [-q]"+ , ""+ , " List the user hubs belonging to the logged in user and all of the"+ , " global hubs. If -a is specified then all hubs are listed, otherwise"+ , " the hidden hub (those starting with \"__\") are ommitted. Normally the"+ , " locked status and any comments associated with the hub are displayed,"+ , " but these will be ommitted if the -q flag is given."+ , ""+ , "hub set [<hub>|-]"+ , ""+ , " Set the 'current' hub for a directory and its sub-directories."+ , " "+ , " The HUB environment variable can be set to a hub name to override this"+ , " setting."+ , " "+ , " '^' can genereally be specified in place of <hub>/<g-hub>/<u-hub>"+ , " in a hub command to refer to the current hub. "+ , ""+ , "hub info [<hub>]"+ , ""+ , " Describe a hub. (See 'hub set' on how to set the current hub.)"+ , " "+ , " (See 'hub set' on how to set the current hub.)"+ , ""+ , "hub lock [<hub>]"+ , ""+ , " Lock a hub so that it can not be removed or renamed or have packages"+ , " added or removed."+ , ""+ , " (See 'hub set' on how to set the current hub.)"+ , ""+ , "hub unlock [<hub>]"+ , ""+ , " Remove the lock from a hub."+ , ""+ , " (See 'hub lock' on locking a hub and 'hub set' on how to set the current hub.)"+ , ""+ , "hub name"+ , ""+ , " List the name of the current hub."+ , " "+ , " (See 'hub set' on how to set the current hub.)"+ , ""+ , "hub path [<hub>]"+ , ""+ , " List the path of the XML file defining the named or current hub."+ , " "+ , " (See 'hub set' on how to set the current hub.)"+ , ""+ , "hub xml [<hub>]"+ , ""+ , " List the contents of the XML file defining the named or current hub."+ , " "+ , " (See 'hub set' on how to set the current hub.)"+ , ""+ , "hub init [-n [<hub>]]"+ , "hub init [-s] [<hub>] <u-hub'>"+ , ""+ , " The first form creates a new user hub with some unique name __h<num>"+ , " and associates the current working directory with the new hub. If"+ , " a hub is specified then that determines the global hub for the new"+ , " hub otherwise the current defaulkt hub is used."+ , " "+ , " The second from creates the new named user hub <u-hub'>. If <hub>"+ , " is specified then the global hub for the new hub is determined by"+ , " this hub otherwise the default hub is used. Iff --set is specified"+ , " the hub associated with the current directory is set to the new hub."+ , " "+ , " (See 'hub set' on how to set the current hub.)"+ , ""+ , "hub comment [<u-hub>] <comment-string>"+ , ""+ , " Set the comment string for a user hub."+ , ""+ , " (See 'hub set' on how to set the current hub.)"+ , ""+ , "hub cp [<u-hub>] <u-hub'>"+ , ""+ , " Duplicate <u-hub> (or the current hib) in <u-hub'>."+ , " "+ , " (See 'hub set' on how to set the current hub.)"+ , ""+ , "hub mv [<u-hub>] <u-hub'>"+ , ""+ , " Rename user hub <u-hub> (or the current hub) to <u-hub'>."+ , " "+ , " (See 'hub set' on how to set the current hub.)"+ , ""+ , "hub rm <u-hub>"+ , ""+ , " Delete user hub <u-hub>."+ , ""+ , "hub swap [<u-hub>] <u-hub'>"+ , ""+ , " Swap the contents of user hub <u-hub> (or the current hub) with"+ , " user hub <u-hub'>."+ , " "+ , " (See 'hub set' on how to set the current hub.)"+ , ""+ , "hub list [<hub>]"+ , ""+ , " List the packages belonging to a hub (calls 'ghc-pkg list')."+ , ""+ , " (See 'hub set' on how to set the current hub.)"+ , ""+ , "hub check [<hub>]"+ , ""+ , " Check the packages belonging to a hub are coherent "+ , " (calls 'ghc-pkg check')."+ , ""+ , " (See 'hub set' on how to set the current hub.)"+ , ""+ , "hub install <pkg-name> ..."+ , ""+ , " Equivalent to: hub install-into ^ <pkg-name> ... "+ , ""+ , "hub install-into <u-hub> <pkg-name> ..."+ , ""+ , " Uses 'cabal install' to install the named packages into a user"+ , " hub."+ , ""+ , " (See 'hub set' on how to set the current hub.)"+ , ""+ , "hub erase <pkg-name> ..."+ , ""+ , " Equivalent to: hub esase-from ^ <pkg-name> ... "+ , ""+ , "hub erase-from [-f] <u-hub> <pkg-name> ..."+ , ""+ , " Run the garbage collector on the user hubs to reclaim library code"+ , " that is no longer referenced by them. (The directories aren't removed"+ , " from the file system, but moved from `~/.hubrc/heap` to"+ , " `~/.hubrc/garbage` for manual removal.) "+ , ""+ , " (See 'hub set' on how to set the current hub.)"+ , ""+ , "hub gc"+ , ""+ , " Run the garbage collector to reclaim library code that is no longer"+ , " referenced by the hubs."+ , ""+ , "hub save [<u-hub>]"+ , " "+ , " Save out the configuration of the hub onto standard output."+ , ""+ , " (See 'hub set' on how to set the current hub.)"+ , ""+ , "hub load [<u-hub>]"+ , ""+ , " Load the hub from standard input. If the named hub doesn't"+ , " exist then the hub is created with the global hub specified by the"+ , " archive. If <u-hub> does exist then it is checked that it is using the"+ , " global hub specified and if necessary removed and recreated referencing"+ , " the right global hub."+ , " "+ , " Any surplus packages not mentioned in the archive are then removed."+ , " "+ , " Finally any packages missing from the hub listed in the archive are"+ , " installed with cabal-install."+ , ""+ , " (See 'hub set' on how to set the current hub.)"+ , ""+ , "hub verify [-s] [<u-hub>]"+ , ""+ , " Check that the named hub (or the default hub) uses the global hub"+ , " specified in the archive and that it contains all of the packages"+ , " at the versions specified by the archive. If -s is specified"+ , " then check that the hub contains no packages other than those specified"+ , " by the archive."+ , ""+ , " (See 'hub set' on how to set the current hub.)"+ ]
+ Hub/Hub.hs view
@@ -0,0 +1,196 @@+--+-- >>> Hub.hub <<<+--+-- This module provdes the central Hub abstraction. As the primary purpose+-- of a hub is to execute programs in a controlled environment it includes+-- the 'exec' utilities for setting up the PATH, GHC_PACKAGE_PATH and munging+-- cabal's command-line arguments, etc.+--+-- (c) 2011-2012 Chris Dornan+++module Hub.Hub+ ( Hub(..)+ , UsrHub(..)+ , HubName+ , HubKind(..)+ , HubSource(..)+ , prettyHubKind+ , checkHubName+ , isHubName+ , hubUserPackageDBPath+ , usr_ghHUB+ , usr_dbHUB+ , lockedHUB+ , Mode(..)+ , execP+ , execProg+ ) where++import Data.Char+import Text.Printf+import System.Exit+import System.FilePath+import System.Environment+import Hub.FilePaths+import Hub.System+import Hub.Directory.Allocate+import Hub.Oops+import Hub.Prog+++data Hub = HUB+ { sourceHUB :: HubSource+ , name__HUB :: HubName+ , kind__HUB :: HubKind+ , path__HUB :: FilePath+ , commntHUB :: String+ , hc_binHUB :: FilePath+ , tl_binHUB :: FilePath+ , glb_dbHUB :: FilePath+ , usr___HUB :: Maybe UsrHub+ } deriving (Show)++data UsrHub = UHB+ { dir___UHB :: FilePath+ , glb_hnUHB :: HubName+ , usr_dbUHB :: FilePath+ , lockedUHB :: Bool+ } deriving (Show)+++type HubName = String++data HubKind+ = GlbHK -- global hub+ | UsrHK -- user hub+ deriving (Eq,Ord,Bounded,Enum,Show)++data HubSource+ = ClHS -- hub sepcified on command line+ | EvHS -- hub specified by environment variable+ | DrHS -- hub specified by a directory marker+ | DsHS -- hub specified by system default+ deriving (Show)++prettyHubKind :: HubKind -> String+prettyHubKind GlbHK = "global"+prettyHubKind UsrHK = "user"++checkHubName :: [HubKind] -> HubName -> IO HubKind+checkHubName hks hn =+ case isHubName hn of+ Nothing -> oops PrgO $ printf "%s is not a valid hub name" hn+ Just hk | hk `elem` hks -> return hk+ | otherwise -> oops PrgO $ printf "%s is a %s hub" hn $ prettyHubKind hk++isHubName :: HubName -> Maybe HubKind+isHubName hn =+ case hn of+ c:cs | all hubname_c cs -> fst_hubname_c c+ _ -> Nothing++hubUserPackageDBPath :: Hub -> IO FilePath+hubUserPackageDBPath hub =+ case usr___HUB hub of+ Nothing -> oops PrgO $ printf "%s: not a user hub" $ name__HUB hub+ Just uhb -> return $ usr_dbUHB uhb++usr_ghHUB :: Hub -> Maybe FilePath+usr_ghHUB = fmap glb_hnUHB . usr___HUB++usr_dbHUB :: Hub -> Maybe FilePath+usr_dbHUB = fmap usr_dbUHB . usr___HUB++lockedHUB :: Hub -> Bool+lockedHUB hub = maybe False lockedUHB $ usr___HUB hub++data Mode = FullMDE | UserMDE++execP :: Oops -> ExecEnv -> Mode -> Hub -> P -> [String] -> IO ()+execP o ee0 mde hub p args0 = execProg o ee0 mde hub (p2prog p) args0++execProg :: Oops -> ExecEnv -> Mode -> Hub -> Prog -> [String] -> IO ()+execProg o ee0 mde hub prog args0 =+ do case (mde,usr___HUB hub) of+ (UserMDE,Nothing) -> oops o "user hub expected"+ _ -> return ()+ (exe,args,tdy) <- mk_prog hub prog args0+ pth0 <- getEnv "PATH"+ let ee = ee0 { extendEnvtEE = hub_env mde hub pth0 ++ extendEnvtEE ee0 }+ ec <- exec ee exe args+ case tdy of+ Nothing -> return ()+ Just hd -> tidyDir hd+ case ec of+ ExitSuccess -> return ()+ ExitFailure n -> oops o $ printf "%s failure (return code=%d)" exe n+++--+-- Executing Programmes+--++mk_prog :: Hub -> Prog -> [String] -> IO (FilePath,[String],Maybe FilePath)+mk_prog hub prog as0 =+ do (as,tdy) <- case (hk/=GlbHK,enmPROG prog,as0) of+ (True,CabalP,"configure":as') -> ci "configure" as'+ (True,CabalP,"install" :as') -> ci "install" as'+ (True,CabalP,"upgrade" :as') -> ci "upgrade" as'+ _ -> return (as0,Nothing)+ return (exe,as,tdy)+ where+ exe = case typPROG prog of+ HcPT -> hc_binHUB hub </> nmePROG prog+ TlPT -> tl_binHUB hub </> nmePROG prog++ hk = kind__HUB hub++ ci cmd as' =+ do hd <- allocate+ db <- hubUserPackageDBPath hub+ let _ld = "--libdir=" ++ hd+ _pd = "--package-db=" ++ db+ return ( cmd : _ld : _pd : as', Just hd )++hub_env :: Mode -> Hub -> String -> [(String,String)]+hub_env mde hub pth0 = concat+ [ [ (,) "HUB" hnm ]+ , [ (,) "PATH" pth | is_usr ]+ , [ (,) "GHC_PACKAGE_PATH" ppt | is_usr ]+ ]+ where+ is_usr = hk /= GlbHK++ pth = printf "%s:%s:%s" hubGccBin hubBinutilsBin pth0++ ppt = case mb_usr of+ Nothing -> glb+ Just uhb -> case mde of+ UserMDE -> udb+ FullMDE -> printf "%s:%s" udb glb+ where+ udb = usr_dbUHB uhb++ hnm = name__HUB hub+ hk = kind__HUB hub+ mb_usr = usr___HUB hub+ glb = glb_dbHUB hub+++--+-- Validating Hub Names+--++fst_hubname_c :: Char -> Maybe HubKind+fst_hubname_c c | glb_first_hub_name_c c = Just GlbHK+ | usr_first_hub_name_c c = Just UsrHK+ | otherwise = Nothing++hubname_c :: Char -> Bool+hubname_c c = c `elem` "_-." || isAlpha c || isDigit c++glb_first_hub_name_c, usr_first_hub_name_c :: Char -> Bool+glb_first_hub_name_c c = isDigit c+usr_first_hub_name_c c = c `elem` "_." || isAlpha c+
+ Hub/Oops.hs view
@@ -0,0 +1,52 @@+--+-- >>> Hub.Oops <<<+--+-- This module generates the error messages. It has to be careful with the+-- context as the user my have invokled 'ghc' or 'cabal' (say) only for the+-- hub tool, acting as a wrapper, to encounter a problem in determing the+-- right tool and context to invoke.+--+-- (c) 2011-2012 Chris Dornan+++module Hub.Oops+ ( Oops(..)+ , oops+ , trim+ ) where++import Data.Char+import System.IO+import System.Exit+import System.Environment+import System.FilePath+import Text.Printf+++data Oops+ = HubO -- the hub command itself was invoked explicitly+ | PrgO -- some other context: probably ghc, cabal, etc+ deriving (Show)++oops :: Oops -> String -> IO a+oops o0 msg =+ do pn <- getProgName+ as <- getArgs+ let o = refineO (snd $ splitFileName pn) o0+ ar = case as of+ a:_ -> a+ _ -> "*no program*"+ hPutStr stderr $ err pn ar o+ exitWith $ ExitFailure 1+ where+ err pn ar o =+ case o of+ HubO -> printf "%s %s: %s\n" pn ar msg+ PrgO -> printf "%s (hub wrapper): %s\n" pn msg++refineO :: String -> Oops -> Oops+refineO "hub" _ = HubO+refineO _ o = o++trim :: String -> String+trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
+ Hub/PackageDB.hs view
@@ -0,0 +1,275 @@+--+-- >>> Hub.PackageDB <<<+--+-- Sometimes the hub has to tangle with the Package DB format (mostly hub+-- erase): this package provides the tools.+--+-- (c) 2011-2012 Chris Dornan+++module Hub.PackageDB+ ( PkgNick(..)+ , PkgName+ , PkgVrsn+ , PkgHash+ , iden2nick+ , parsePkgNick+ , parsePkgNick'+ , prettyPkgNick+ , eraseClosure+ , importLibraryDirs+ , PkgIden(..)+ , Package(..)+ , packageDB++ , DepGraph(..)+ , dep_graph+ ) where++import Data.Char+import Data.List+import Data.Array+import qualified Data.Map as Map+import Data.Graph.Inductive+import Text.Printf+import System.Directory+import Hub.System+import Hub.Oops+import Hub.Prog+import Hub.Hub++++-- Package as identified on the CL++data PkgNick = PKN+ { namePKN :: PkgName+ , vrsnPKN :: Maybe PkgVrsn+ } deriving (Eq,Ord,Show)++-- Fully qualified package as referenced in a package configuration file.++data PkgIden = PKI+ { namePKI :: PkgName+ , vrsnPKI :: PkgVrsn+ , idenPKI :: PkgHash+ } deriving (Eq,Ord,Show)++type PkgName = String+type PkgVrsn = String+type PkgHash = String+++iden2nick :: PkgIden -> PkgNick+iden2nick pki = PKN (namePKI pki) (Just $ vrsnPKI pki)+++eraseClosure :: Hub -> [PkgNick] -> IO ([PkgNick],[PkgNick])+eraseClosure hub pkns =+ do pdb <- packageDB hub+ pkis <- mapM (resolve_pkg_nick pdb) pkns+ return (map pki2pkn pkis,map pki2pkn $ erase_deps pdb pkis)++importLibraryDirs :: Hub -> IO [FilePath]+importLibraryDirs hub =+ do pdb <- packageDB hub+ return $ usort $ concat $ map dirs $ Map.elems pdb+ where+ dirs pkg = import_dirsPKG pkg ++ library_dirsPKG pkg++parsePkgNick :: String -> IO PkgNick+parsePkgNick s = maybe fl return $ parsePkgNick' s+ where+ fl = oops HubO $ printf "%s: invalid package name" s++parsePkgNick' :: String -> Maybe PkgNick+parsePkgNick' s =+ case is_val of+ True | is_vr -> Just $ PKN nm (Just vr)+ | otherwise -> Just $ PKN s Nothing+ False -> Nothing+ where+ is_val = case s of+ [] -> False+ c:cs -> fval_c c && all sval_c cs++ is_vr = not (null nm) && not (null vr) && all vr_c vr++ nm = reverse r_nm+ vr = reverse r_vr++ r_nm = cl_d rst2+ (r_vr,rst2) = break ('-'==) $ reverse s++ cl_d ('-':t) = t+ cl_d x = x++ vr_c '.' = True+ vr_c c = isDigit c++ fval_c c = isAlpha c || c=='_'+ sval_c c = isAlpha c || isDigit c || c `elem` "-_.=+#~"++prettyPkgNick :: PkgNick -> String+prettyPkgNick pkn =+ case vrsnPKN pkn of+ Nothing -> namePKN pkn+ Just vr -> printf "%s-%s" (namePKN pkn) vr++pki2pkn :: PkgIden -> PkgNick+pki2pkn pki = PKN (namePKI pki) (Just(vrsnPKI pki))+++--+-- Calculating the Erase Dependencies+--++erase_deps :: PackageDB -> [PkgIden] -> [PkgIden]+erase_deps pdb pkis = map v2pki $ (\\ vs) $ usort $ concat $ map (pre gr) vs+ where+ vs = [ v | Just v<-map pki2mbv pkis ]+ pki2mbv = flip Map.lookup $ assgnDG dg+ v2pki = (arrayDG dg!)+ gr = trc $ graphDG dg+ dg = dep_graph pdb++usort :: Ord a => [a] -> [a]+usort = foldr no_dups [] . sort+ where+ no_dups x [] = [x]+ no_dups x (x':xs) = if x==x' then x:xs else x:x':xs+++--+-- Building the Dependency Graph+--++data DepGraph = DG+ { assgnDG :: Map.Map PkgIden Int+ , arrayDG :: Array Int PkgIden+ , graphDG :: Gr PkgIden ()+ } deriving (Show)++dep_graph :: PackageDB -> DepGraph+dep_graph pdb = DG asgn arry (mkGraph ndes edgs)+ where+ ndes = map (\(x,y)->(y,x)) $ Map.toList asgn++ edgs = [ (x',y',()) | (x,y)<-deps,+ Just x'<-[Map.lookup x asgn],+ Just y'<-[Map.lookup y asgn] ]++ deps = [ (idPKG pkg,dep) | pkg<-Map.elems pdb, dep<-dependsPKG pkg ]++ arry = listArray (0,Map.size asgn-1) $ Map.keys asgn++ asgn = Map.fromList $ zip (sort $ Map.keys pdb) [0..]+++--+-- Resolving Package Nicks into Package Ids+--++resolve_pkg_nick :: PackageDB -> PkgNick -> IO PkgIden+resolve_pkg_nick pdb pkn =+ case match_pkg_nick pdb pkn of+ [] -> oops HubO $ printf "%s: does not match any user packages in the hub" $ prettyPkgNick pkn+ [pki] -> return pki+ _ -> oops HubO $ printf "%s: matches multiple user packages in the hub" $ prettyPkgNick pkn++match_pkg_nick :: PackageDB -> PkgNick -> [PkgIden]+match_pkg_nick pdb pkn =+ [ pki | pki <- Map.keys pdb,+ namePKN pkn==namePKI pki+ && maybe True (==vrsnPKI pki) (vrsnPKN pkn)]+++--+-- Reconstructing the Package DB+--++type PackageDB = Map.Map PkgIden Package++data Package = PKG+ { idPKG :: PkgIden+ , import_dirsPKG :: [FilePath]+ , library_dirsPKG :: [FilePath]+ , dependsPKG :: [PkgIden]+ } deriving (Show)++packageDB :: Hub -> IO PackageDB+packageDB hub =+ do cts <- package_dump hub+ return $ packages [ package $ record rec | rec<-records cts ]++package_dump :: Hub -> IO String+package_dump hub =+ do tf <- tmpFile "pkg-dump.txt"+ let ee = EE (RedirctRS tf) DiscardRS []+ execP HubO ee UserMDE hub Ghc_pkgP ["dump"]+ ct <- readAFile tf+ removeFile tf+ return ct++packages :: [Package] -> Map.Map PkgIden Package+packages pkgs = Map.fromList [(idPKG pkg,pkg) | pkg<-pkgs ]++package :: Map.Map String [String] -> Package+package mp = PKG+ (s2pr (lu "id" sgl))+ (lu "import-dirs" lst)+ (lu "library-dirs" lst)+ (lu "depends" prs)+ where+ lu ky f = f $ Map.lookup ky mp++ sgl Nothing = ""+ sgl (Just lns) = trim $ unlines lns++ lst Nothing = []+ lst (Just lns) = map trim lns++ prs Nothing = []+ prs (Just lns) = map (s2pr . trim) lns++s2pr :: String -> PkgIden+s2pr s = PKI (reverse r_nm) (reverse r_vr) (reverse r_hs)+ where+ r_nm = cl_d rst2+ (r_vr,rst2) = break ('-'==) $ cl_d rst1+ (r_hs,rst1) = break ('-'==) $ reverse s++ cl_d ('-':t) = t+ cl_d x = x++records :: String -> [[String]]+records cts = rec [] $ lines cts+ where+ rec acc [] = [ reverse acc | not $ null acc ]+ rec acc (ln:lns) =+ case ln of+ "" -> rec acc lns+ _ | ln=="---" -> reverse acc:rec [] lns+ | otherwise -> rec (ln:acc) lns++record :: [String] -> Map.Map String [String]+record lns = Map.fromList $ fields lns++fields :: [String] -> [(String,[String])]+fields [] = []+fields (ln:lns) = (tag,rst:cnt):fields lns'+ where+ (tag,rst) = case words ln of+ [] -> ("","")+ w:ws -> (cln w,unwords ws)++ (cnt,lns') = span chk lns++ chk [] = False+ chk (c:_) = isSpace c++ cln tg = case reverse tg of+ ':':r_tg -> reverse r_tg+ _ -> tg++
+ Hub/Parse.hs view
@@ -0,0 +1,291 @@+--+-- >>> Hub.Parse <<<+--+-- This module parses the hub XML file to produce a Hub, and the inverse,+-- dumping a Hub into XML.+--+-- (c) 2011-2012 Chris Dornan+++module Hub.Parse+ ( parse+ , dump+ , PSt(..) -- kill warnings+ ) where++import Data.Char+import Text.Printf+import qualified Data.ByteString as B+import qualified Text.XML.Expat.Annotated as X+import Hub.Poss+import Hub.Oops+import Hub.Hub+import Hub.FilePaths++++parse :: HubSource -> FilePath -> HubName -> FilePath -> HubKind -> IO Hub+parse hs dy hn hf hk =+ do cts <- B.readFile hf+ case parse' cts of+ YUP tr -> case check hs dy hn hf hk tr of+ NOPE er -> fail_err hn hf er+ YUP hb -> return hb+ NOPE er -> fail_err hn hf er++dump :: Hub -> IO ()+dump hub = B.writeFile path xml_bs+ where+ xml_bs = B.pack $ map (toEnum.fromEnum) xml++ xml = unlines $+ [ "<hub>"+ , printf " <comnt>%s</comnt>" $ string2xml comnt+ , printf " <hcbin>%s</hcbin>" $ string2xml hcbin+ , printf " <tlbin>%s</tlbin>" $ string2xml tlbin+ ] +++ [ printf " <glbdb>%s</glbdb>" $ string2xml glbdb+ ] +++ [ printf " <usrgh>%s</usrgh>" $ string2xml usrgh | Just usrgh<-[mb_usrgh]+ ] +++ [ printf " <usrdb>%s</usrdb>" $ string2xml usrdb | Just usrdb<-[mb_usrdb]+ ] +++ [ printf " <lockd>%s</lockd>" lks | not $ null lks+ ] +++ [ "</hub>"+ ]++ lks = if lk then "rmie" else ""++ mb_usrgh = fmap glb_hnUHB mb_uh+ mb_usrdb = fmap usr_dbUHB mb_uh+ lk = maybe False lockedUHB mb_uh++ path = path__HUB hub+ comnt = commntHUB hub+ hcbin = hc_binHUB hub+ tlbin = tl_binHUB hub+ glbdb = glb_dbHUB hub+ mb_uh = usr___HUB hub+++fail_err :: HubName -> FilePath -> Err -> IO a+fail_err _ hf er = oops PrgO rs+ where+ rs = printf "%s:%d:%d %s" hf ln (cn+1) es++ ln = X.xmlLineNumber lc+ cn = X.xmlColumnNumber lc++ X.XMLParseError es lc = er++type Loc = X.XMLParseLocation++type Err = X.XMLParseError++type Tag = String++type Node = X.LNode Tag String++tx_err :: Loc -> String -> Err+tx_err _ = err loc0++err :: Loc -> String -> Err+err = flip X.XMLParseError++loc0 :: Loc+loc0 = X.XMLParseLocation 1 0 0 0++parse' :: B.ByteString -> Poss Err Node+parse' = ei2ps . X.parse' X.defaultParseOptions++check :: HubSource -> FilePath -> HubName -> FilePath -> HubKind -> Node -> Poss Err Hub+check hs dy hn hf hk (X.Element "hub" [] ns lc) =+ final hs dy hk $ foldl chk (YUP $ start hn hf lc) ns+ where+ chk (NOPE er) _ = NOPE er+ chk (YUP st) nd = foldr (trial st nd) (NOPE $ unrecognised st nd)+ [ chk_wspce+ , chk_comnt+ , chk_hcbin+ , chk_tlbin+ , chk_glbdb+ , chk_usrdb+ , chk_usrgh+ , chk_lockd+ -- depracated (no warnings yet)+ , chk_hpbin+ , chk_cibin+ ]+check _ _ _ _ _ _ = NOPE $ err loc0 "expected simple <hub>...</hub>"++data PSt = ST+ { handlST :: HubName+ , hpathST :: FilePath+ , locwfST :: Loc+ , comntST :: Maybe String+ , hcbinST :: Maybe FilePath+ , tlbinST :: Maybe FilePath+ , glbdbST :: Maybe FilePath+ , usrghST :: Maybe FilePath+ , usrdbST :: Maybe FilePath+ , lockdST :: Maybe Bool+ } deriving (Show)++start :: HubName -> FilePath -> Loc -> PSt+start hn fp lc =+ ST hn fp lc Nothing Nothing Nothing Nothing Nothing Nothing Nothing++final :: HubSource -> FilePath -> HubKind -> Poss Err PSt -> Poss Err Hub+final _ _ _ (NOPE er) = NOPE er+final hs dy hk (YUP st) =+ do co <- get_co+ hc <- get_hc+ tl <- get_tl+ gl <- get_gl+ mb_pr <- case (mb_ur,mb_gh) of+ (Just ur,Nothing) -> (Just . ((,) ur)) `fmap` calc_gh gl+ (Just ur,Just gh) -> return $ Just (ur,gh)+ (Nothing,_ ) -> return Nothing+ return $ HUB hs hn hk hf co hc tl gl $ fmap mk_uhb mb_pr+ where+ get_co = maybe (YUP "" ) YUP mb_co+ get_hc = maybe (NOPE hc_err ) YUP mb_hc+ get_tl = maybe (YUP $ toolsBin) YUP mb_tl+ get_gl = maybe (NOPE gl_err ) YUP mb_gl++ hc_err = err lc "Hub doesn't specify a GHC bin directory"+ gl_err = err lc "Hub doesn't specify a global package directory"++ mk_uhb = \(ur,gh) -> UHB dy gh ur $ maybe False id mb_lk++ calc_gh gl =+ case match (mk_re globalHubREs) gl of+ Just gh | isHubName gh == Just GlbHK -> return gh+ _ -> NOPE $ err loc0 msg+ where+ msg = "Could not derive the global hub name from the "+ ++ "filepath of the global package databse"++ ST hn hf lc mb_co mb_hc mb_tl mb_gl mb_gh mb_ur mb_lk = st++trial :: PSt -> Node -> (PSt -> Node -> Maybe(Poss Err PSt)) -> Poss Err PSt -> Poss Err PSt+trial st nd f ps = maybe ps id $ f st nd++unrecognised :: PSt -> Node -> Err+unrecognised _ (X.Element tg _ _ lc) = err lc $ printf "<%s> not recognised" tg+unrecognised st (X.Text tx ) = err lc $ printf "unexpected text: %s" tx+ where+ lc = locwfST st++chk_comnt, chk_wspce, chk_hcbin, chk_tlbin,+ chk_glbdb, chk_usrgh, chk_usrdb,+ chk_hpbin, chk_cibin, chk_lockd :: PSt -> Node -> Maybe(Poss Err PSt)++chk_wspce st nd =+ case nd of+ X.Element _ _ _ _ -> Nothing+ X.Text txt | all isSpace txt -> Just $ YUP st+ | otherwise -> Just $ NOPE $ tx_err lc txt_er+ where+ lc = locwfST st+ txt_er = "unexpected top-level text"++chk_comnt st0 nd = simple_node True st0 nd "comnt" chk+ where+ chk st lc arg =+ case comntST st of+ Nothing -> YUP (st{comntST=Just arg})+ Just _ -> NOPE $ err lc "<comnt> respecified"++chk_hcbin st0 nd = simple_node False st0 nd "hcbin" chk+ where+ chk st lc arg =+ case hcbinST st of+ Nothing -> YUP (st{hcbinST=Just arg})+ Just _ -> NOPE $ err lc "<hcbin> respecified"++chk_tlbin st0 nd = simple_node False st0 nd "tlbin" chk+ where+ chk st lc arg =+ case tlbinST st of+ Nothing -> YUP (st{tlbinST=Just arg})+ Just _ -> NOPE $ err lc "<cibin> re-specified"++chk_glbdb st0 nd = simple_node False st0 nd "glbdb" chk+ where+ chk st lc arg =+ case glbdbST st of+ Nothing -> YUP (st{glbdbST=Just arg})+ Just _ -> NOPE $ err lc "<glbdb> respecified"++chk_usrgh st0 nd = simple_node False st0 nd "usrgh" chk+ where+ chk st lc arg =+ case usrghST st of+ Nothing -> YUP (st{usrghST=Just arg})+ Just _ -> NOPE $ err lc "<usrgh> respecified"++chk_usrdb st0 nd = simple_node False st0 nd "usrdb" chk+ where+ chk st lc arg =+ case usrdbST st of+ Nothing -> YUP (st{usrdbST=Just arg})+ Just _ -> NOPE $ err lc "<usrdb> respecified"++chk_lockd st0 nd = simple_node False st0 nd "lockd" chk+ where+ chk st lc arg =+ case lockdST st of+ Nothing -> YUP (st{lockdST=Just $ not $ all isSpace arg})+ Just _ -> NOPE $ err lc "<lockd> respecified"++-- deprecated (pre-0.3) constructions++chk_hpbin st0 nd = simple_node False st0 nd "hpbin" $ \st _ _ -> YUP st++chk_cibin st0 nd = simple_node False st0 nd "cibin" $ \st _ _ -> YUP st+++simple_node :: Bool -> PSt -> Node -> Tag -> (PSt->Loc->String->Poss Err PSt)+ -> Maybe (Poss Err PSt)+simple_node ev st (X.Element tg' as ks lc) tg cont+ | tg==tg' = Just $+ do chk_as+ txt <- chk_ks+ cont (st {locwfST=lc}) lc txt+ | otherwise = Nothing+ where+ chk_as = case as of+ [] -> return ()+ _:_ -> NOPE $ err lc ats_er++ chk_ks = case [ () | X.Element _ _ _ _<-ks ] of+ [] -> chk_nl+ _:_ -> NOPE $ err lc txt_er++ chk_nl = case all_tx of+ [] | not ev -> NOPE $ err lc emp_er+ _ -> chk_ls++ chk_ls = case all (/='\n') all_tx of+ True -> return all_tx+ False -> NOPE $ err lc lns_er++ all_tx = trim $ concat $ [ txt | X.Text txt<-ks ]+ ats_er = printf "<%s> takes no attributes" tg+ txt_er = printf "<%s> takes simple text" tg+ emp_er = printf "<%s> shouldn't be empty" tg+ lns_er = printf "<%s> should be on a single line" tg+simple_node _ _ (X.Text _) _ _+ = Nothing++string2xml :: String -> String+string2xml = concatMap fixChar+ where+ fixChar '<' = "<"+ fixChar '>' = ">"+ fixChar '&' = "&"+ fixChar '"' = """+ fixChar c | ord c < 0x80 = [c]+ fixChar c = "&#" ++ show (ord c) ++ ";"
+ Hub/Poss.hs view
@@ -0,0 +1,29 @@+--+-- >>> Hub.Poss <<<+--+-- This module reestablishes an unvandalised monadic Either type.+--+-- (c) 2011-2012 Chris Dornan+++module Hub.Poss+ ( Poss(..)+ , poss+ , ei2ps+ ) where++data Poss e a = NOPE e | YUP a+ deriving (Show)+instance Monad (Poss e) where+ (>>=) ps f = poss NOPE f ps+ return = YUP++instance Functor (Poss e) where+ fmap f p = poss NOPE (YUP . f) p++poss :: (e->b) -> (a->b) -> Poss e a -> b+poss n _ (NOPE e) = n e+poss _ y (YUP x) = y x++ei2ps :: Either e a -> Poss e a+ei2ps = either NOPE YUP
+ Hub/Prog.hs view
@@ -0,0 +1,63 @@+--+-- >>> Hub.Prog <<<+--+-- This module records the other programs that hub is managing -- generally+-- the programs that come with a Haskell Plaform: the GHC tools, cabal and+-- a few others.+--+-- (c) 2011-2012 Chris Dornan+++module Hub.Prog+ ( Prog(..)+ , ProgType(..)+ , P(..)+ , p2prog+ , progMap+ ) where++import qualified Data.Map as Map+++data Prog = PROG+ { enmPROG :: P+ , nmePROG :: String+ , typPROG :: ProgType+ } deriving (Show)++data ProgType = HcPT | TlPT+ deriving (Show)+data P+ = GhcP+ | GhciP+ | Ghc_pkgP+ | Hp2psP+ | HpcP+ | Hsc2hsP+ | RunghcP+ | RunhaskellP+ | CabalP+ | AlexP+ | HappyP+ | HaddockP+ deriving (Eq,Ord,Bounded,Enum,Show)++p2prog :: P -> Prog+p2prog p =+ case p of+ GhcP -> PROG p "ghc" HcPT+ GhciP -> PROG p "ghci" HcPT+ Ghc_pkgP -> PROG p "ghc-pkg" HcPT+ HaddockP -> PROG p "haddock" HcPT+ Hp2psP -> PROG p "hp2ps" HcPT+ HpcP -> PROG p "hpc" HcPT+ Hsc2hsP -> PROG p "hsc2hs" HcPT+ RunghcP -> PROG p "runghc" HcPT+ RunhaskellP -> PROG p "runhaskell" HcPT+ CabalP -> PROG p "cabal" TlPT+ AlexP -> PROG p "alex" TlPT+ HappyP -> PROG p "happy" TlPT++progMap :: Map.Map String Prog+progMap = Map.fromList [ (nmePROG pg,pg) | pg<-map p2prog [minBound..maxBound] ]+
+ Hub/SaveLoad.hs view
@@ -0,0 +1,112 @@+--+-- >>> Hub.SaveLoad <<<+--+-- This module saves the hub configuration in an archive type and loads+-- an archive file, performing some analysis on the target Hub to be loaded+-- (if there is one).+--+-- (c) 2011-2012 Chris Dornan+++module Hub.SaveLoad+ ( save+ , PkgDiffs(..)+ , load+ ) where++import Data.Char+import qualified Data.Map as Map+import Data.List+import Hub.Oops+import Hub.Hub+import Hub.Directory+import Hub.Discover+import Hub.PackageDB+++-- Generates the archive on the standard output.++save :: Hub -> IO ()+save hub =+ do pdb <- packageDB hub+ let cts = unlines $ hdr : map (prettyPkgNick . iden2nick) (Map.keys pdb)+ putStr cts+ where+ hdr = "^=" ++ maybe (name__HUB hub) glb_hnUHB (usr___HUB hub)++data PkgDiffs = PD { hubPD :: Hub, surPD, msgPD, allPD :: [PkgNick] }+ deriving (Show)++-- Takes the name of the hub to be loaded, the existing hub (if it exists)+-- an a flag indicating whether the hub is bing loaded or verified, and+-- reads in the archive from the standard input and returns the new+-- and the packages it is missing and the packages to be added.+--+-- * If it is not passed a hub then it creates a new one.+--+-- * If it is passed a hub which does not have the right global database+-- then it will remove and recreate the hub with the right global databse+-- if loading or generate an error if verifying.++load :: HubName -> Maybe Hub -> Bool -> IO PkgDiffs+load hn mb_hub0 vy =+ do mb_prs <- parse_input+ (gh,nks) <- case mb_prs of+ Nothing -> oops HubO $ "parse error"+ Just pr -> return pr+ mb_hub <-+ case mb_hub0 of+ Nothing -> return Nothing+ Just hub ->+ case usr___HUB hub of+ Just uhb | gh==glb_hnUHB uhb -> return $ Just hub+ | not vy -> r_noth $ deleteHub hub+ _ -> oops HubO mm_msg+ g_hub <- discover $ Just gh+ hub <- case mb_hub of+ Nothing -> createHub' False g_hub hn False+ Just hub -> return hub+ nks0 <- (map iden2nick . Map.keys) `fmap` packageDB hub+ return $ PD hub (nks0\\nks) (nks\\nks0) nks+ where+ r_noth = fmap (const Nothing)+ mm_msg = "global hub mismatch"++parse_input :: IO (Maybe (HubName,[PkgNick]))+parse_input =+ do cts <- getContents+ return $ parse_har cts++parse_har :: String -> Maybe (HubName,[PkgNick])+parse_har cts =+ do (gh,r) <- hdr_p $ pp cts+ (,) gh `fmap` bdy_p r++hdr_p :: [String] -> Maybe (HubName,[String])+hdr_p [] = Nothing+hdr_p (ln:lns) =+ case words ln of+ ['^':'=':hn]+ | isHubName hn == Just GlbHK+ -> Just (hn,lns)+ _ -> Nothing++bdy_p :: [String] -> Maybe [PkgNick]+bdy_p [] = Just []+bdy_p (ln:lns) =+ case words ln of+ [w] | Just nk <- parsePkgNick' w ->+ do nks <- bdy_p lns+ return $ nk:nks+ _ -> Nothing++pp :: String -> [String]+pp = filter (not . all isSpace) . map sc . lines+ where+ sc ln = foldr cmt "" ln++ cmt '#' _ = ""+ cmt '-' t = case t of+ '-':_ -> ""+ _ -> '-':t+ cmt c t = c:t
+ Hub/System.hs view
@@ -0,0 +1,201 @@+--+-- >>> Hub.System <<<+--+-- This module contains all of the O/S-specific utilities. it should currently+-- work for Posix systems. Getting a Windows hub port should be a matter of+-- porting this module.+--+-- (c) 2011-2012 Chris Dornan+++module Hub.System+ ( tmpFile+ , setEnv+ , fileExists+ , fileDirExists+ , removeR+ , removeRF+ , cpFileDir+ , mvFileDir+ , symLink+ , inc+ , tidyDir+ , ExecEnv(..)+ , RedirectStream(..)+ , exec+ , readAFile+ , writeAFile+ , lockFileDir+ ) where++import System.IO+import System.Exit+import Control.Monad+import qualified Control.Exception as E+import System.Directory+import System.Posix.Env+import System.Posix.Files+import System.Posix.Process+import System.Posix.IO+import Text.Printf+import qualified Data.ByteString.UTF8 as U+import qualified Data.ByteString as B+import qualified Data.Map as Map+import System.Process+import Hub.Oops+++dev_null :: FilePath+dev_null = "/dev/null"+++tmpFile :: FilePath -> IO FilePath+tmpFile fn =+ do pid <- getProcessID+ return $ printf "/tmp/hub-%d-%s" (fromIntegral pid :: Int) fn++fileExists :: FilePath -> IO Bool+fileExists fp = flip E.catch (hdl_ioe False) $+ do st <- getFileStatus fp+ return $ isRegularFile st++fileDirExists :: FilePath -> IO Bool+fileDirExists fp = flip E.catch (hdl_ioe False) $+ do st <- getFileStatus fp+ return $ isRegularFile st || isDirectory st++removeR :: FilePath -> IO ()+removeR fp =+ do ec <- rawSystem "rm" ["-r",fp]+ case ec of+ ExitSuccess -> return ()+ ExitFailure n -> oops PrgO $+ printf "rm failure (return code=%d)" n++removeRF :: FilePath -> IO ()+removeRF fp =+ do ec <- rawSystem "rm" ["-rf",fp]+ case ec of+ ExitSuccess -> return ()+ ExitFailure n -> oops PrgO $+ printf "rm failure (return code=%d)" n++cpFileDir :: FilePath -> FilePath -> IO ()+cpFileDir fp fp' =+ do ec <- rawSystem "cp" ["-a",fp,fp']+ case ec of+ ExitSuccess -> return ()+ ExitFailure n -> oops PrgO $+ printf "cp failure (return code=%d)" n++mvFileDir :: FilePath -> FilePath -> IO ()+mvFileDir fp fp' =+ do ec <- rawSystem "mv" [fp,fp']+ case ec of+ ExitSuccess -> return ()+ ExitFailure n -> oops PrgO $+ printf "mv failure (return code=%d)" n+++symLink :: FilePath -> FilePath -> IO ()+symLink = createSymbolicLink+++inc :: FilePath -> IO Int+inc fp =+ do fd <- openFd fp ReadWrite (Just stdFileMode) defaultFileFlags+ -- putStrLn "acquiring lock"+ waitToSetLock fd (WriteLock,AbsoluteSeek,0,0)+ --putStrLn "lock acquired"+ i <- rd_i fd+ _ <- fdSeek fd AbsoluteSeek 0+ _ <- fdWrite fd $ show $ i+1+ closeFd fd+ return i+ where+ rd_i fd =+ do (s,_) <- E.catch (fdRead fd 64) (hdl_ioe ("",0))+ return $ maybe 0 id $ readMB s++tidyDir :: FilePath -> IO ()+tidyDir dp = flip E.catch (hdl_ioe ()) $+ do e <- all dots `fmap` getDirectoryContents dp+ when e $ removeDirectory dp+ where+ dots "." = True+ dots ".." = True+ dots _ = False++readMB :: Read a => String -> Maybe a+readMB str =+ case [ x | (x,t)<-reads str, ("","")<-lex t ] of+ [x] -> Just x+ _ -> Nothing++lockFileDir :: Bool -> Bool -> FilePath -> IO ()+lockFileDir dir lck fp = setFileMode fp m+ where+ m = case lck of+ True ->+ case dir of+ True -> u [r ,x]+ False -> r+ False ->+ case dir of+ True -> u [r,w,x]+ False -> u [r,w ]++ r = u [ownerReadMode ,groupReadMode ,otherReadMode ]+ w = u [ownerWriteMode ]+ x = u [ownerExecuteMode,groupExecuteMode,otherExecuteMode]++ u = foldr unionFileModes nullFileMode++hdl_ioe :: a -> IOError -> IO a+hdl_ioe x _ = return x+++data ExecEnv = EE+ { redirctOutEE :: RedirectStream+ , redirctErrEE :: RedirectStream+ , extendEnvtEE :: [(String,String)]+ } deriving (Show)++data RedirectStream+ = InheritRS+ | DiscardRS+ | RedirctRS FilePath+ deriving (Show)++exec :: ExecEnv -> FilePath -> [String] -> IO ExitCode+exec ee pr as =+ do so <- get_ss $ redirctOutEE ee+ se <- get_ss $ redirctErrEE ee+ ev <- get_ev $ extendEnvtEE ee+ let cp = (proc pr as) { std_out = so, std_err = se, env=ev }+ (_,_,_,ph) <- createProcess cp+ ex <- waitForProcess ph+ clse so+ clse se+ return ex+ where+ get_ss InheritRS = return Inherit+ get_ss DiscardRS = get_ss (RedirctRS dev_null)+ get_ss (RedirctRS fp) = UseHandle `fmap` openFile fp WriteMode++ clse (UseHandle h) = hClose h+ clse _ = return ()++ get_ev [] = return Nothing+ get_ev bs =+ do bs0 <- getEnvironment+ let st = Map.fromList bs+ f (nm,_) = not $ Map.member nm st+ --putStrLn $ printf "---\n%s\n---\n\n" $ show (bs ++ filter f bs0)+ return $ Just $ bs ++ filter f bs0++readAFile :: FilePath -> IO String+readAFile fp = U.toString `fmap` B.readFile fp++writeAFile :: FilePath -> String -> IO ()+writeAFile fp = B.writeFile fp . U.fromString
+ Makefile view
@@ -0,0 +1,26 @@+OD = dist/build/hub+ID = /usr/hs/bin+HC = mkdir -p $(OD); ghc -XHaskell2010 --make -O1 -outputdir build -Wall+VR = $(shell runghc Version)+CM = "for building Hub ($(VR))" +OP = '\nNo hub on path: ensure hub-src.har or hub.cabal packages are installed\n\n' ++all: hub++hub: prep+ $(HC) -o $(OD)/hub hub.hs++prep:+ hub load build-hub <build-hub.har || printf $(OP)+ hub comment build-hub $(CM) || true+ hub set build-hub || true+ runhaskell prep++install:+ install -D $(OD)/hub $(DESTDIR)$(ID)/hub+ install -D man/hub.1.gz $(DESTDIR)/usr/share/man/man1/hub.1.gz+ install -D man/hub.5.gz $(DESTDIR)/usr/share/man/man5/hub.5.gz++clean:+ cabal clean+ rm -rf build
+ README view
@@ -0,0 +1,12 @@+This package provides a utility for multiplexing multiple+GHC and Haskell Platform installations, the installation+being selected by environment variable or a hidden configuraton+file or in the current working directory or one of its parents.++Thye utility also allows users to build sandboxes (called hubs)+which may link to one of the the GHC installtions installed on+the local system, and extend them with packages private to the hub.++Utilities are also provided for erasing packages from an hub and+annotating, duplicating, renaming, locking, archiving and recovering+hubs.
+ Version.hs view
@@ -0,0 +1,20 @@+--+-- >>> Version <<<+--+-- Keeper of the version information.+--+-- (c) 2011-2012 Chris Dornan+++module Version+ ( version+ , main+ ) where+++version :: String+version = "1.0.0"+++main :: IO ()+main = putStrLn version
+ build-hub.har view
@@ -0,0 +1,11 @@+^=7.4.1+List-0.4.2+fgl-5.4.2.4+hexpat-0.20.1+mtl-2.1.1+regex-base-0.93.2+regex-compat-0.95.1+regex-posix-0.95.2+text-0.11.2.1+transformers-0.3.0.0+utf8-string-0.3.7
+ help.txt view
@@ -0,0 +1,205 @@+ Hub Help Page+ + hub --usage is an aliase for the 'hub usage' command+ hub --help is an aliase for the 'hub help' command+ hub --version is an aliase for the 'hub version' command++hub usage++ List the syntax of all the hub commands.++hub help [<hub-command>]++ List the help for a command or all commands if none specified.++ See "hub usage" for a command-syntax summary.++hub version++ List the version information.++hub default [<g-hub>|-]++ (Needs to be run as root.)+ + If no arguments are given then this command lists the the default global+ hub for the system (i.e., the default global hub used to set up each+ user's 'home' hub).+ + If a global hub <g-hub> is specified then <g-hub> will become the+ default global hub.+ + If a '-' is specified then any older default settings are discarded and+ the system default re-established.++hub ls [-a] [-q]++ List the user hubs belonging to the logged in user and all of the+ global hubs. If -a is specified then all hubs are listed, otherwise+ the hidden hub (those starting with "__") are ommitted. Normally the+ locked status and any comments associated with the hub are displayed,+ but these will be ommitted if the -q flag is given.++hub set [<hub>|-]++ Set the 'current' hub for a directory and its sub-directories.+ + The HUB environment variable can be set to a hub name to override this+ setting.+ + '^' can genereally be specified in place of <hub>/<g-hub>/<u-hub>+ in a hub command to refer to the current hub. ++hub info [<hub>]++ Describe a hub. (See 'hub set' on how to set the current hub.)+ + (See 'hub set' on how to set the current hub.)++hub lock [<hub>]++ Lock a hub so that it can not be removed or renamed or have packages+ added or removed.++ (See 'hub set' on how to set the current hub.)++hub unlock [<hub>]++ Remove the lock from a hub.++ (See 'hub lock' on locking a hub and 'hub set' on how to set the current hub.)++hub name++ List the name of the current hub.+ + (See 'hub set' on how to set the current hub.)++hub path [<hub>]++ List the path of the XML file defining the named or current hub.+ + (See 'hub set' on how to set the current hub.)++hub xml [<hub>]++ List the contents of the XML file defining the named or current hub.+ + (See 'hub set' on how to set the current hub.)++hub init [-n [<hub>]]+hub init [-s] [<hub>] <u-hub'>++ The first form creates a new user hub with some unique name __h<num>+ and associates the current working directory with the new hub. If+ a hub is specified then that determines the global hub for the new+ hub otherwise the current defaulkt hub is used.+ + The second from creates the new named user hub <u-hub'>. If <hub>+ is specified then the global hub for the new hub is determined by+ this hub otherwise the default hub is used. Iff --set is specified+ the hub associated with the current directory is set to the new hub.+ + (See 'hub set' on how to set the current hub.)++hub comment [<u-hub>] <comment-string>++ Set the comment string for a user hub.++ (See 'hub set' on how to set the current hub.)++hub cp [<u-hub>] <u-hub'>++ Duplicate <u-hub> (or the current hib) in <u-hub'>.+ + (See 'hub set' on how to set the current hub.)++hub mv [<u-hub>] <u-hub'>++ Rename user hub <u-hub> (or the current hub) to <u-hub'>.+ + (See 'hub set' on how to set the current hub.)++hub rm <u-hub>++ Delete user hub <u-hub>.++hub swap [<u-hub>] <u-hub'>++ Swap the contents of user hub <u-hub> (or the current hub) with+ user hub <u-hub'>.+ + (See 'hub set' on how to set the current hub.)++hub list [<hub>]++ List the packages belonging to a hub (calls 'ghc-pkg list').++ (See 'hub set' on how to set the current hub.)++hub check [<hub>]++ Check the packages belonging to a hub are coherent + (calls 'ghc-pkg check').++ (See 'hub set' on how to set the current hub.)++hub install <pkg-name> ...++ Equivalent to: hub install-into ^ <pkg-name> ... ++hub install-into <u-hub> <pkg-name> ...++ Uses 'cabal install' to install the named packages into a user+ hub.++ (See 'hub set' on how to set the current hub.)++hub erase <pkg-name> ...++ Equivalent to: hub esase-from ^ <pkg-name> ... ++hub erase-from [-f] <u-hub> <pkg-name> ...++ Run the garbage collector on the user hubs to reclaim library code+ that is no longer referenced by them. (The directories aren't removed+ from the file system, but moved from `~/.hubrc/heap` to+ `~/.hubrc/garbage` for manual removal.) ++ (See 'hub set' on how to set the current hub.)++hub gc++ Run the garbage collector to reclaim library code that is no longer+ referenced by the hubs.++hub save [<u-hub>]+ + Save out the configuration of the hub onto standard output.++ (See 'hub set' on how to set the current hub.)++hub load [<u-hub>]++ Load the hub from standard input. If the named hub doesn't+ exist then the hub is created with the global hub specified by the+ archive. If <u-hub> does exist then it is checked that it is using the+ global hub specified and if necessary removed and recreated referencing+ the right global hub.+ + Any surplus packages not mentioned in the archive are then removed.+ + Finally any packages missing from the hub listed in the archive are+ installed with cabal-install.++ (See 'hub set' on how to set the current hub.)++hub verify [-s] [<u-hub>]++ Check that the named hub (or the default hub) uses the global hub+ specified in the archive and that it contains all of the packages+ at the versions specified by the archive. If -s is specified+ then check that the hub contains no packages other than those specified+ by the archive.++ (See 'hub set' on how to set the current hub.)
hub.cabal view
@@ -1,36 +1,96 @@-Name: hub-Version: 0.0-Copyright: Chris Dornan, 2011-Maintainer: Chris Dornan <chris@chrisdornan.com>-Author: Chris Dornan <chris@chrisdornan.com>-License: BSD3-License-file: LICENSE-Synopsis: A utility for multiplexing multiple GHC installations-Description: This package provides a utility for multiplexing multiple- GHC and Haskell Platform installations, the installation- being selected by configuraton file or environment- variable.-Stability: Alpha-Category: Development, Distribution-Homepage: https://github.com/cdornan/hub-Build-type: Simple-Cabal-version: >= 1.6+Name: hub+Version: 1.0.0+Copyright: Chris Dornan, 2011-2012+Maintainer: Chris Dornan <chris@chrisdornan.com>+Author: Chris Dornan <chris@chrisdornan.com>+License: BSD3+License-file: LICENSE+Synopsis: For multiplexing GHC installations and providing+ development sandboxes+Description: This package provides a utility for multiplexing + multiple GHC and Haskell Platform installations, + each selected by an environment variable or a work-tree+ configuration file.+ .+ The package also provides flexible development sandboxes + (aka /hubs/) into which packages can be installed+ and subsequently erased. Command are provided for+ (re)naming, sharing, replicating, swapping, archiving,+ locking and removing hubs. E.g.,+ .+ > hub init+ .+ will create a hub based on the default GHC installation + and associate the current directory with it. Any use+ of /cabal/ or the GHC tools within this directory or it's+ descendants will work with correct tool chain and the+ private user-package database belonging to the hub. + .+ The following would (i) download 'hexpat' (ii) install it+ in a named 'hexpat-test' hub connected to the /2011.2.0.1/+ Haskell Platform, (iii) build the 'hexpat' test suite + with the same hub, and (iv) finally run the test suite.+ .+ >cabal unpack hexpat+ >cd hexpat-*+ >hub init -s 2011.2.0.1 hexpat-test+ >cabal install+ >cd test+ >cabal install --bindir=.+ >./testsuite + .+ This same 'hexpat-test' hub can be shared with other+ work trees.+ .+ The tool is intended to be provided as part of a+ distribution (like the /JustHub/ Enterprise Linux+ distribution) but it can be configured with existing+ stock GHC installations without too much effort. Once+ installed and configured the hub command inter-operates+ seamlessly with the GHC tools (/ghc/, /ghci/, /ghc-pkg/,+ etc.) and /Cabal-install/.+ .+ For installation instructions, introductory material,+ FAQs, etc., see the home page http:\/\/justhub.org.+ +Stability: Beta+Category: Development, Distribution+Homepage: https://justhub.org+Build-type: Simple+Cabal-version: >= 1.10 -Source-repository head- type: git- location: git@github.com:cdornan/hub.git+Source-repository head+ type: git+ location: git@github.com:cdornan/hub.git -Executable hub- Main-is: hub.hs- Build-depends: base >= 4.0 && < 4.5,- hexpat == 0.19.*,- regex-compat,- containers,- unix,- filepath,- directory,- process,- bytestring,- haskell98- GHC-options: -Wall- Extensions: CPP+Executable hub+ Main-is: hub.hs+ Build-depends: base >= 4.0 && < 5,+ hexpat >= 0.19,+ regex-compat,+ containers,+ unix,+ filepath,+ directory,+ process,+ bytestring,+ fgl,+ utf8-string,+ array+ Other-modules: Hub.CommandLine+ Hub.Commands+ Hub.SaveLoad+ Hub.Directory+ Hub.Discover+ Hub.FilePaths+ Hub.Help+ Hub.HelpText+ Hub.Hub+ Hub.Oops+ Hub.PackageDB+ Hub.Parse+ Hub.Prog+ Hub.System+ Hub.Poss+ GHC-options: -Wall+ Default-language: Haskell2010
hub.hs view
@@ -1,2 +1,74 @@+--+-- >>> Main <<<+--+-- Main driver for the hub tool (see the README for details).+--+-- (c) 2011-2012 Chris Dornan+++module Main(main) where++import Control.Monad+import System.IO+import System.Exit+import Text.Printf+import Hub.System+import Hub.FilePaths+import Hub.Directory+import Hub.CommandLine+import Hub.Commands+import qualified Version as V++ main :: IO ()-main = putStrLn "watch this space"+main =+ do cl <- commandLine+ case cl of+ HelpCL _ _ -> return ()+ VrsnCL -> return ()+ _ -> initDirectory+ case cl of+ ProgCL hub (prg,as) -> _prog hub prg as+ HelpCL err hlp -> _help err hlp+ VrsnCL -> _vrsn+ DfltCL -> _default+ StDfCL hub -> _default_hub $ Just hub+ RsDfCL -> _default_hub Nothing+ LsCL af qf -> _ls af qf+ GetCL -> _get+ SetCL hub -> _set hub+ UnsetCL -> _unset+ NameCL hub -> _name hub+ InfoCL hub -> _info hub+ LockCL hub -> _lock hub+ UnlockCL hub -> _unlock hub+ PathCL hub -> _path hub+ XmlCL hub -> _xml hub+ InitCL hub hn set -> _init hub hn set+ CommentCL hub cmt -> _comment hub cmt+ CpCL hub hn -> _cp hub hn+ MvCL hub hn -> _mv hub hn+ RmCL hub -> _rm hub+ SwapCL hub hn -> _swap hub hn+ GcCL -> _gc+ ListCL hub -> _list hub+ CheckCL hub -> _check hub+ SaveCL hub -> _save hub+ LoadCL hn -> _load hn+ VerifyCL hub sf -> _verify hub sf+ InstallCL hub pkns -> _install hub pkns+ EraseCL hub pkns ef -> _erase hub pkns ef+++_help :: Bool -> String -> IO ()+_help False hlp = putStr hlp+_help True hlp = hPutStrLn stderr hlp >> exitWith (ExitFailure 1)++_vrsn :: IO ()+_vrsn =+ do putStr $ printf "hub %s\n" V.version+ ex <- fileExists sysVersion+ when ex $+ readAFile sysVersion >>= putStr++
+ man/Makefile view
@@ -0,0 +1,19 @@+all: hub.1.gz hub.5.gz++%.gz: %+ gzip -c $< >$@++%.html: %.xml+ xmlto -m manpage-normal.xsl html $^+ mv index.html $@++%.1: %-1.xml+ xmlto -m manpage-normal.xsl man $^+ bin/fixup.sh $@++%.5: %-5.xml+ xmlto -m manpage-normal.xsl man $^+ bin/fixup.sh $@++%.xml: %.txt+ asciidoc -b docbook -d manpage $^
+ man/bin/fixup.sh view
@@ -0,0 +1,28 @@+#!/bin/bash++set -e++if [ $# -ne 1 ]; then+ echo" usage: $0 <file>"+ exit 1+fi++file=$1++if [ ! -f ${file} ]; then+ echo ${file}: not found+ exit 1+fi++if [ -f ${file}.tmp ]; then+ echo ${file}.tmp: in use+ exit 1+fi++version=$(cd .. && runghc Version)++mv ${file} ${file}.tmp++cat ${file}.tmp | sed -e 's/\[FIXME: manual\]/User Commands/' -e "s/\\[FIXME: source\\]/Hub ${version}/" >${file}++rm ${file}.tmp
+ man/hub-1.txt view
@@ -0,0 +1,526 @@+hub(1)+======++NAME+----+hub - manage Haskell hubs (for selecting toolchains, libraries and sandboxes)+++SYNOPSIS+--------++----+ hub usage+ hub help [<hub-command>]+ hub version+ hub default [<g-hub>|-]+ hub ls [-a] [-q]+ hub set [<hub>|-]+ hub info [<hub>]+ hub lock [<hub>]+ hub unlock [<hub>]+ hub name+ hub path [<hub>]+ hub xml [<hub>]+ hub init [-n [<hub>]]+ hub init [-s] [<hub>] <u-hub'>+ hub comment [<u-hub>] <comment-string>+ hub cp [<u-hub>] <u-hub'>+ hub mv [<u-hub>] <u-hub'>+ hub rm <u-hub>+ hub swap [<u-hub>] <u-hub'>+ hub list [<hub>]+ hub check [<hub>]+ hub install <pkg-name> ...+ hub install-into <u-hub> <pkg-name> ...+ hub erase <pkg-name> ...+ hub erase-from [-f] <u-hub> <pkg-name> ...+ hub gc+ hub save [<u-hub>]+ hub load [<u-hub>]+ hub verify [-s] [<u-hub>]+----++DESCRIPTION+-----------++The hub tool (i) integrates multiple releases of the Glasgow+Haskell Compiler into a single installation with a simple+mechanism for selecting between the installations and (ii)+provides a sandbox mechanism, allowing users to install+packages on a per-project basis.++The tool organizes compilation contexts around so-called "hubs"+which contain their own GHC package databases. A global hub+is shared among all users on the system and is typically installed+with the system package utility (e.g., 'yum' or 'apt') from+a public repository. Each global hubs is associated with a+single global package database.++User hubs belong to individual users, point at a global hub and+own a user package database into which the user can install packages+with 'cabal' and 'ghc'.++A directory will typically be statically associated with a hub.+Invoking 'cabal' and 'ghc within such a directory (or any of its+sub-directories) will select the appropriate version of GHC+(as determined by the hub configuration) and will set up the+tools to work with package database that is private to that+hub.++This is perhaps best illustrated by a sample session:+-----+ hub init -n 7.0.4 # create new hub based on GHC-7.0.4+ # and associate the current directory with it+ cabal install SHA # install the latest version of the SHA package+ # in the user package database of the hub+ ghci crypto.hs # load crypto.hs into 'ghci', which may make use of+ # the GHC-7.0.4 core packages and the SHA+ # package and any of its dependent packages.+-----+(This assumes GHC-7.0.4 is already installed; if not it may need to be+installed first with, for example 'yum install ghc-7.0.4-hub'.)++Each hub is named. We didn't specify a name for the new hub in the above+example so a new unused name like '__h006' will have been chosen. It could+be renamed to something more distinctive and then associated with another work+tree.+-----+ hub mv __h006 crypto # rename hub to something more memorable+ hub set crypto # remember to re-associate the current directory+ # with the newly-named hub+ cd ~/digest # switch to another work tree+ hub set crypto # associate it with the crypto hub+-----+Now both work trees will be associated with the 'crypto' hub and any changes+made to it -- adding or removing packages -- will be reflected in the GHC+compilation context of both work trees.+ +To list all of the hub available to a user use+-----+ hub ls+-----+The listing won't include any hubs with names that start with '__'. To see+these in the listing use.+-----+ hub ls -a+-----++To find out more about an individual hub use+-----+ hub info crypto+-----++Note that global hub names start with a digit (e.g., '7.0.4',+'2011.4.0.0') and user hub names start with a letter or underscore+(e.g., 'crypto', '__h006').++As well as the directory context, the 'HUB' environment variable can+be used to select the context for Haskell toolkit command. E.g.,+-----+ HUB=2011.2.0.1 ghc-pkg list+-----+If the HUB environment variable is set it will always take precedence over+any directory settings.++To copy, rename, remove, swap, (un)lock, save, verify or load+a hub then use the 'hub cp', 'hub mv', 'hub rm', 'hub swap',+'hub lock', 'hub unlock', 'hub save', 'hub verify' or 'hub load',+respectively (see below).++If you have acquired the hub tool by installing the hub package+everything should be set up for you. Otherwise, you will have to+install the hub binary on your execution path under its own name ('hub')+and under the name of each of the standard GHC tools ('ghc', 'ghci',+'ghc-pkg', etc., and 'cabal') you want it to manage. (This is usually+managed by installing the hub program into a directory (like `/usr/hs/bin`)+and creating links from 'ghc', 'ghci', 'ghc-pkg', 'cabal', etc. to the+'hub' program.) ++To add a new global hub you will have to install an xml file in+`/usr/hs/hub (see hub(5) for details of the format of this file). Each+global hub configuration must specify where the compiler tools+are located.+++COMMANDS+--------+++`hub usage`::++ Lists the syntax of all the hub commands.+++`hub help [<hub-command>]`::++ Lists the help for a command or all commands if none+ specified. See "hub usage" for a command-syntax summary.+++`hub version`::++ Lists the version information.+++`hub default [<g-hub>|-]`::++ (Needs to be run as root.) If no arguments are given then this+ command lists the the default global hub for the system (i.e.,+ the default global hub used to set up each user's 'home' hub). If+ a global hub <g-hub> is specified then <g-hub> will become the+ default global hub. If a '-' is specified then any older default+ settings are discarded and the system default re-established.+++`hub ls [-a] [-q]`::++ List the user hubs belonging to the logged in user and all of the+ global hubs. If -a is specified then all hubs are listed, otherwise+ the hidden hub (those starting with "__") are ommitted. Normally the+ locked status and any comments associated with the hub are displayed,+ but these will be ommitted if the -q flag is given.+++`hub set [<hub>|-]`::++ Set the 'current' hub for a directory and its sub-directories.+ The HUB environment variable can be set to a hub name to override+ this setting.+++`hub info [<hub>]`::++ Describe a hub. (See 'hub set' on how to set the current hub.)+++`hub lock [<hub>]`::++ Lock a hub so that it can not be removed or renamed or have packages+ added or removed.+++`hub unlock [<hub>]`::++ Remove the lock from a hub (see `hub lock` above).+++`hub name`::++ List the name of the current hub. (See 'hub set' on how to set+ the current hub.)+++`hub path [<hub>]`::++ List the path of the XML file defining the named or current+ hub.+++`hub xml [<hub>]`::++ List the contents of the XML file defining the named or current+ hub.+++`hub init [-n [<hub>]]`::++ (See also 'hub init [-s]' below.) Create a new user hub with some+ unique name __h<num> and associates the current working directory with+ the new hub. If a hub is specified then that determines the global+ hub for the new hub otherwise the current default hub is used.+++`hub init [-s] [<hub>] <u-hub'>`::++ (See also 'hub init -n' above.) Create the new named user hub <u-hub'>.+ If <hub> is specified then the global hub for the new hub is determined by+ this hub otherwise the default hub is used. Iff -s is specified+ the hub associated with the current directory is set to the new hub.+++`hub cp [<u-hub>] <u-hub'>`::++ Duplicate <u-hub> (or the current hub) in+ <u-hub'>. (See 'hub set' on how to set the current hub.)+++`hub mv [<u-hub>] <u-hub'>`::++ Renames user hub <u-hub> (or the current hub) to <u-hub'>. (See+ 'hub set' on how to set the current hub.)+++`hub rm <u-hub>`::++ Deletes user hub <hub>.+++`hub swap [<u-hub>] <u-hub'>`::++ Swaps the contents of user hub <u-hub> (or the current hub) with+ user hub <u-hub'>.+++`hub list [<hub>]`::++ List the packages belonging to a hub (calls 'ghc-pkg list').+++`hub check [<hub>]`::++ Check the packages belonging to a hub are coherent + (calls 'ghc-pkg check').+++`hub install <pkg-name>`... ::++ Equivalent to: hub install-into ^ <pkg-name> ...+++`hub install-into <u-hub> <pkg-name>`... ::++ Uses 'cabal install' to install the named packages into the named+ hub (or the current hub). (See 'hub set' on how to set the current hub.)+++`hub erase <pkg-name>`... ::++ Equivalent to: hub erase-from ^ <pkg-name> ...+++`hub erase-from <u-hub> <pkg-name>`...::++ Determine all of the packages dependent on the list of named packaqes+ in the hub, lists them and offers to remove them from the hub (by+ invoking 'ghc-pkg unregister'). (See 'hub set' on how to set the+ current hub.)+++`hub gc`::++ Run the garbage collector on the user hubs to reclaim library code+ that is no longer referenced by them. (The directories aren't removed+ from the file system, but moved from `~/.hubrc/heap` to+ `~/.hubrc/garbage` for manual removal.)++`hub save [<u-hub>]`::++ Save out the configuration of the hub onto standard output.+ (See 'hub set' on how to set the current hub.)+++`hub load [<u-hub>]`::++ Load the hub from standard input. (i) If the named hub doesn't+ exist then the hub is created with the global hub specified by the+ archive; but If <u-hub> does exist then it is checked that it is using+ the global hub specified and if necessary removed and recreated+ referencing the right global hub. (ii) Any surplus packages not+ mentioned in the archive are then removed. (iii) Finally any packages+ missing from the hub listed in the archive are installed with+ `cabal-install`.+++`hub verify [-s] [<u-hub>]`::++ Check that the named hub (or the default hub) uses the global hub+ specified in the archive and that it contains all of the packages+ at the versions specified by the archive. If -s is specified+ then check that the hub contains no packages other than those specified+ by the archive.+++EXAMPLE 1+---------++List the packages in the (installed) 2011.2.0.1 Haskell Platform:++----+ HUB=2011.2.0.1 ghc-pkg list+----++or equivalently,++----+ hub list 2011.2.0.1+----+++EXAMPLE 2+---------++Create a new hub based on the default hub, attach it to the current directory+and install the latest edition of `hexpat` into it.++----+ hub init+ cabal install hexpat+----+++EXAMPLE 3+---------++Duplicates the contents of hub `foo` into hub `bar`+and installs the SHA package into it.++----+ hub cp foo bar+ hub install-into bar SHA+----+++EXAMPLE 4+---------++Unpacks `GLUT-2.1.2.1` and runs one of its example programs using the+(installed) Haskell Platform 2011.2.0.1.++----+ cabal unpack GLUT-2.1.2.1+ HUB=2011.2.0.1 runhaskell GLUT-2.1.2.1/examples/BOGLGP/Chapter01/Simple.hs+----+++EXAMPLE 5+---------++Install the `SHA` package into `my-test` and lock the hub against it being +removed, renamed or having packages added or removed.+----+ hub install-into my-test SHA+ hub lock my-test+----+++EXAMPLE 6+---------++Remove the `text` package from the current hub, performs a garbage collection+of the user hubs and check all of the package databases for consistency+(assumes `bash`).++----+ hub erase text+ hub gc+ for h in $(hub ls -a -q); do hub check ${h}; done+----+++EXAMPLE 7+---------++Archive the current hub into precious.har.++----+ hub save >precious.har+---- +++EXAMPLE 8+---------++(i) Load hub precious from `precsious.har`, creating the hub and erasing and+installing packages as necessary; doing nothing if the hub already exists+in the correct configuration. (ii) Configure the current work tree to use+`precious`. (iii) Use `precious` to compile `golum.hs`.++----+ hub load precious <precious.har+ hub set precious+ ghc --make golum.hs+---- +++++ENVIRONMENT VARIABLES+---------------------++`HUB`::++ This environment variable determines the hub that the hub+ wrapper will use while invoking a compiler tool. If it is not+ set then the .hub file (set by `hub set`) in the current+ directory or one its parent directories is used to determine+ the 'current' hub. If no parent directory defines the current+ hub then the default global hub is used (see the `hub default`+ command). The `HUB` environment variable overrides all of+ these so it is best left unset in interactive sessions unless+ you really want to force a single hub to be used regardless of+ work tree configuration.+++FILES+-----++`.hub`::++ Lists the name of the hub for the current directory+ and it's subdirectories.++`~/.hubrc/hub/<u-hub>.xml`::++ Contains the hub-spefification file for user hub <u-hub>.++`~/.hubrc/lib/<u-hub>/package.config`::++ Contains the package database for user hub <u-hub>.++`~/.hubrc/heap`::++ Contains directories containing the library files for the+ packages installed in the user hubs.++`~/.hubrc/garbage`::++ Contains directories removed from `~/.hubrc/heap` by the garbage collector.++`/usr/hs/bin`::+ The standard location for the 'hub' program and the rest of+ the Haskell tools (as links to the 'hub' program) -- this directory+ should be put on the PATH if the tools aren't installed in /usr/bin.++`/usr/hs/hub/<g-hub>.xml`::++ XML configuration file for global hub <g-hub>.++`/usr/hs/db`::++ Standard location for the package databases for system hubs.++`/usr/hs/ghc/<version>`::++ Standard location for GHC <version> installation.++`/usr/hs/hp/<version>`::++ Standard installation locations for Haskell Platform <version>.+++SEE ALSO+--------++hub(5)::++ Describes the format of the XML configuration files used to+ configure the user and global hubs.+++http://justhub.org::++ The home page of the JustHub distribution contains+ introductory material and links to wikis and articles.+++BUGS+----++The Hub issue tracker is at https://github.com/haskell-hub/hub-src/issues.++++AUTHOR+------+Chris Dornan <chris@chrisdornan.com>
+ man/hub-5.txt view
@@ -0,0 +1,120 @@+hub(5)+======+++NAME+----+hub - syntax of XML files used to configure Haskell hubs+++SYNOPSIS+--------++A Hub configuration file is an XML file that always contains a+`<hub>` node, which will contain a '<comnt>', `<hcbin>`, '<tlbin>' and+`<glbdb>` sub-nodes.++If (and only if) the file is configuring a user hub, it will also have a+`<usrgh>` and `<usrdb>` sub-nodes and possibly a `<lockd>` sub-node.+++DESCRIPTION+-----------++`<comnt>`::++ Brief single-line of text describing the hub.++`<hcbin>`::++ The path of the `bin` directory containing the `ghc` tools+ to be used with the hub.+ +`<tlbin>`::+ + The path of directory containing the generic tools (especially `cabal`)+ to be used with the hub.++`<glbdb>`::++ The path of the global package database to be used with the+ hub.++`<usrgh>`::+ + The name of the global hub associated with this user hub (present for+ user hubs only).++`<usrdb>`::++ The path of the user package database to be used with the+ hub (present for user hubs only).++`<lockd>`::++ The presence of this node signifies that the hub is locked. If it is+ present it should contain the string "rmie". (Only user hubs can+ be locked.)+++EXAMPLE 1+---------++Hub configuration file for global hub `2011.2.0.1`:++----+ <hub>+ <comnt>Haskell Platform 2011.2.0.1</comnt>+ <hcbin>/usr/hs/ghc/7.0.3/bin</hcbin>+ <glbdb>/usr/hs/db/2011.2.0.1.d</glbdb>+ </hub>+----+++EXAMPLE 2+---------++Hub configuration file for hub `home`, a user hub based+on the global hub `7.4.1`:++----+ <hub>+ <comnt>Hub for building the hub tool</comnt>+ <hcbin>/usr/hs/ghc/7.4.1/bin</hcbin>+ <tlbin>/usr/hs/tools</tlbin>+ <usrgh>7.4.1</usrgh>+ <glbdb>/usr/hs/db/7.4.1.d</glbdb>+ <usrdb>/home/chris/.hubrc/lib/hub-src/package.config</usrdb>+ </hub>+----+++FILES+-----++`~/.hubrc/hub/<u-hub>.xml`::++ Contains the hub-spefification file for user hub <u-hub>.++`/usr/hs/hub/<g-hub>.xml`::++ XML configuration file for global hub <g-hub>.+++SEE ALSO+--------++hub(1)::++ The hub command for managing and configuring user hubs.+++http://justhub.org::++ The home page of the JustHub distribution contains+ introductory material and links to wikis and articles.+++AUTHOR+------+Chris Dornan <chris@chrisdornan.com>
+ man/hub.1.gz view
binary file changed (absent → 5370 bytes)
+ man/hub.5.gz view
binary file changed (absent → 1445 bytes)
+ man/manpage-base.xsl view
@@ -0,0 +1,35 @@+<!-- manpage-base.xsl:+ special formatting for manpages rendered from asciidoc+docbook -->+<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform"+ version="1.0">++<!-- these params silence some output from xmlto -->+<xsl:param name="man.output.quietly" select="1"/>+<xsl:param name="refentry.meta.get.quietly" select="1"/>++<!-- convert asciidoc callouts to man page format;+ git.docbook.backslash and git.docbook.dot params+ must be supplied by another XSL file or other means -->+<xsl:template match="co">+ <xsl:value-of select="concat(+ $git.docbook.backslash,'fB(',+ substring-after(@id,'-'),')',+ $git.docbook.backslash,'fR')"/>+</xsl:template>+<xsl:template match="calloutlist">+ <xsl:value-of select="$git.docbook.dot"/>+ <xsl:text>sp </xsl:text>+ <xsl:apply-templates/>+ <xsl:text> </xsl:text>+</xsl:template>+<xsl:template match="callout">+ <xsl:value-of select="concat(+ $git.docbook.backslash,'fB',+ substring-after(@arearefs,'-'),+ '. ',$git.docbook.backslash,'fR')"/>+ <xsl:apply-templates/>+ <xsl:value-of select="$git.docbook.dot"/>+ <xsl:text>br </xsl:text>+</xsl:template>++</xsl:stylesheet>
+ man/manpage-normal.xsl view
@@ -0,0 +1,13 @@+<!-- manpage-normal.xsl:+ special settings for manpages rendered from asciidoc+docbook+ handles anything we want to keep away from docbook-xsl 1.72.0 -->+<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform"+ version="1.0">++<xsl:import href="manpage-base.xsl"/>++<!-- these are the normal values for the roff control characters -->+<xsl:param name="git.docbook.backslash">\</xsl:param>+<xsl:param name="git.docbook.dot" >.</xsl:param>++</xsl:stylesheet>
+ prep.hs view
@@ -0,0 +1,38 @@+--+-- >>> Main (prep) <<<+--+-- This program 'Haskelises' the hub help text.+--+-- (c) 2011-2012 Chris Dornan+++module Main(main) where++import System.Locale+import Data.Time+import Text.Printf+++main :: IO ()+main =+ do cts <- readFile "help.txt"+ writeFile "Hub/HelpText.hs" $ mk_text_mod "Hub.HelpText" "helpText" cts++mk_text_mod :: String -> String -> String -> String+mk_text_mod mn fn cts =+ case lines cts of+ [] -> error "that is strange, the text file is empty"+ ln:lns -> unlines $ pre ln ++ foldr mdl pst lns+ where+ pre ln = [ printf "module %s(%s) where" mn fn+ , ""+ , printf "%s :: String" fn+ , printf "%s = unlines" fn+ , printf " [ %s" $ show ln+ ]++ mdl ln t = [ printf " , %s" $ show ln+ ] ++ t++ pst = [ " ]"+ ]