hub-1.0.0: Hub/Directory.hs
--
-- >>> 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