diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ +.hub .project dist build @@ -5,4 +6,4 @@ *~ *.hi *.o -.hub +PACKAGE_ME diff --git a/.hub b/.hub deleted file mode 100644 --- a/.hub +++ /dev/null @@ -1,1 +0,0 @@ -hub diff --git a/.project b/.project deleted file mode 100644 --- a/.project +++ /dev/null @@ -1,11 +0,0 @@ - - - hub - - - - - - - - diff --git a/Hub/CommandLine.hs b/Hub/CommandLine.hs new file mode 100644 --- /dev/null +++ b/Hub/CommandLine.hs @@ -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) diff --git a/Hub/Commands.hs b/Hub/Commands.hs new file mode 100644 --- /dev/null +++ b/Hub/Commands.hs @@ -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) [drc|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] diff --git a/Hub/Directory.hs b/Hub/Directory.hs new file mode 100644 --- /dev/null +++ b/Hub/Directory.hs @@ -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 (dirsdir) (garbage hmesdir) + + trash sdir = removeR (dirsdir) + +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 + diff --git a/Hub/Directory/Allocate.hs b/Hub/Directory/Allocate.hs new file mode 100644 --- /dev/null +++ b/Hub/Directory/Allocate.hs @@ -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 diff --git a/Hub/Discover.hs b/Hub/Discover.hs new file mode 100644 --- /dev/null +++ b/Hub/Discover.hs @@ -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 diff --git a/Hub/FilePaths.hs b/Hub/FilePaths.hs new file mode 100644 --- /dev/null +++ b/Hub/FilePaths.hs @@ -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 diff --git a/Hub/Help.hs b/Hub/Help.hs new file mode 100644 --- /dev/null +++ b/Hub/Help.hs @@ -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 diff --git a/Hub/HelpText.hs b/Hub/HelpText.hs new file mode 100644 --- /dev/null +++ b/Hub/HelpText.hs @@ -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 []" + , "" + , " 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 [|-]" + , "" + , " (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 is specified then 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 [|-]" + , "" + , " 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 //" + , " in a hub command to refer to the current hub. " + , "" + , "hub info []" + , "" + , " 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 []" + , "" + , " 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 []" + , "" + , " 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 []" + , "" + , " 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 []" + , "" + , " 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 init [-s] [] " + , "" + , " The first form creates a new user hub with some unique name __h" + , " 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 . If " + , " 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 [] " + , "" + , " Set the comment string for a user hub." + , "" + , " (See 'hub set' on how to set the current hub.)" + , "" + , "hub cp [] " + , "" + , " Duplicate (or the current hib) in ." + , " " + , " (See 'hub set' on how to set the current hub.)" + , "" + , "hub mv [] " + , "" + , " Rename user hub (or the current hub) to ." + , " " + , " (See 'hub set' on how to set the current hub.)" + , "" + , "hub rm " + , "" + , " Delete user hub ." + , "" + , "hub swap [] " + , "" + , " Swap the contents of user hub (or the current hub) with" + , " user hub ." + , " " + , " (See 'hub set' on how to set the current hub.)" + , "" + , "hub list []" + , "" + , " List the packages belonging to a hub (calls 'ghc-pkg list')." + , "" + , " (See 'hub set' on how to set the current hub.)" + , "" + , "hub check []" + , "" + , " 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 ..." + , "" + , " Equivalent to: hub install-into ^ ... " + , "" + , "hub install-into ..." + , "" + , " Uses 'cabal install' to install the named packages into a user" + , " hub." + , "" + , " (See 'hub set' on how to set the current hub.)" + , "" + , "hub erase ..." + , "" + , " Equivalent to: hub esase-from ^ ... " + , "" + , "hub erase-from [-f] ..." + , "" + , " 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 []" + , " " + , " Save out the configuration of the hub onto standard output." + , "" + , " (See 'hub set' on how to set the current hub.)" + , "" + , "hub load []" + , "" + , " 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 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] []" + , "" + , " 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.)" + ] diff --git a/Hub/Hub.hs b/Hub/Hub.hs new file mode 100644 --- /dev/null +++ b/Hub/Hub.hs @@ -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 + diff --git a/Hub/Oops.hs b/Hub/Oops.hs new file mode 100644 --- /dev/null +++ b/Hub/Oops.hs @@ -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 diff --git a/Hub/PackageDB.hs b/Hub/PackageDB.hs new file mode 100644 --- /dev/null +++ b/Hub/PackageDB.hs @@ -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 + + diff --git a/Hub/Parse.hs b/Hub/Parse.hs new file mode 100644 --- /dev/null +++ b/Hub/Parse.hs @@ -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 $ + [ "" + , printf " %s" $ string2xml comnt + , printf " %s" $ string2xml hcbin + , printf " %s" $ string2xml tlbin + ] ++ + [ printf " %s" $ string2xml glbdb + ] ++ + [ printf " %s" $ string2xml usrgh | Just usrgh<-[mb_usrgh] + ] ++ + [ printf " %s" $ string2xml usrdb | Just usrdb<-[mb_usrdb] + ] ++ + [ printf " %s" lks | not $ null lks + ] ++ + [ "" + ] + + 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 ..." + +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 " 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 " 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 " 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 " 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 " 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 " 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 " 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) ++ ";" diff --git a/Hub/Poss.hs b/Hub/Poss.hs new file mode 100644 --- /dev/null +++ b/Hub/Poss.hs @@ -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 diff --git a/Hub/Prog.hs b/Hub/Prog.hs new file mode 100644 --- /dev/null +++ b/Hub/Prog.hs @@ -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] ] + diff --git a/Hub/SaveLoad.hs b/Hub/SaveLoad.hs new file mode 100644 --- /dev/null +++ b/Hub/SaveLoad.hs @@ -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 diff --git a/Hub/System.hs b/Hub/System.hs new file mode 100644 --- /dev/null +++ b/Hub/System.hs @@ -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 diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -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