DisTract-0.2.5: src/DisTractInstaller.hs
{- DisTract ------------------------------------------------------\
| |
| Copyright (c) 2007, Matthew Sackman (matthew@wellquite.org) |
| |
| DisTract is freely distributable under the terms of a 3-Clause |
| BSD-style license. For details, see the DisTract web site: |
| http://distract.wellquite.org/ |
| |
\-----------------------------------------------------------------}
{-# LANGUAGE TemplateHaskell, ForeignFunctionInterface #-}
{-# OPTIONS_GHC -fforce-recomp #-}
module Main
(main)
where
import Foreign
import Foreign.C
import System.Environment
import System.Installer
import System.IO
import System.Directory
import System.FilePath
import System.Console.GetOpt
import System.Process
import Data.List
import qualified Data.Map as M
import Control.Monad
import Control.Monad.Instances
import DisTract.Config
import DisTract.Utils
import DisTract.Types
import DisTract.Layout
import DisTract.Monotone.Interaction
import DisTract.Monotone.Types
$(installBinariesFunc "installDisTractBinary"
[("NewBug",
"dist/build/DisTractNewBug/DisTractNewBug"),
("ModifyBug",
"dist/build/DisTractModifyBug/DisTractModifyBug"),
("UpdateFormatAllBugs",
"dist/build/DisTractUpdateFormatAllBugs/DisTractUpdateFormatAllBugs"),
("UpdateFormatBug",
"dist/build/DisTractUpdateFormatBug/DisTractUpdateFormatBug"),
("SortBugs",
"dist/build/DisTractSortBugs/DisTractSortBugs"),
("FormatNew",
"dist/build/DisTractFormatNew/DisTractFormatNew")
])
$(installBinariesFunc "installDisTractField"
[("Title",
"./scripts/defaultFields/Title"),
("Status",
"./scripts/defaultFields/Status"),
("Milestone",
"./scripts/defaultFields/Milestone"),
("Reporter",
"./scripts/defaultFields/Reporter"),
("Created",
"./scripts/defaultFields/Created"),
("Assigned",
"./scripts/defaultFields/Assigned")
])
$(installBinariesFunc "installDisTractHTMLLib"
[("Bug", "./html/lib/DisTractBug.js"),
("Run", "./html/lib/DisTractRun.js"),
("JSON", "./html/lib/json.js"),
("Markdown", "./html/lib/markdown.js"),
("Prototype", "./html/lib/prototype.js"),
("Sortable", "./html/lib/sortable.js"),
("Style", "./html/lib/style.css"),
("Unordered", "./html/lib/unordered.png"),
("Asc", "./html/lib/asc.png"),
("Desc", "./html/lib/desc.png")
])
data OptionFlag = Version
| DB
| Key
| Branch
deriving (Eq, Ord, Enum, Show)
options :: [OptDescr (OptionFlag, String)]
options
= [ Option ['v'] ["version"] (NoArg (Version, "")) "Show version."
, Option ['d'] ["db"] (ReqArg ((,) DB) "DB Path") "Set path to monotone database to use."
, Option ['k'] ["key"] (ReqArg ((,) Key) "Signing Key") "Set key for signatures."
, Option ['b'] ["branch"] (ReqArg ((,) Branch) "Base Branch") "Set base branch."
]
optionsUsage :: String
optionsUsage = usageInfo header options
where
header = "Usage: DisTractInstall [Option..] Path"
parseOptions :: IO (M.Map OptionFlag String, [String])
parseOptions = do { args <- getArgs
; case getOpt RequireOrder options args of
(opts, remaining, []) ->
return (M.fromList . sort $ opts, remaining)
(_,_,errs) ->
ioError . userError $ concat errs ++ optionsUsage
}
validateOption :: M.Map OptionFlag String -> Bool -> Config ->
OptionFlag -> IO Config
validateOption optsMap updating config DB
= do { dbPath <- if isAbsolute dbPath'
then return dbPath'
else do { cwd <- getCurrentDirectory
; return $ combine cwd dbPath'
}
; let config' = config { mtnDb = dbPath }
; exists <- doesFileExist dbPath
; case exists of
False -> mtnInitDB config'
_ -> return ()
; return config'
}
where
dbPath' = M.findWithDefault defaultDB DB optsMap
defaultDB = if updating
then mtnDb config
else combine base "db.mtn"
base = baseDir config
validateOption optsMap updating config Key
= do { (_, privateKeys) <- mtnLsKeys config
; defaultKey' <- case privateKeys of
((PrivateKey k _):_) -> return k
_ -> ioError . userError $
"Unable to find any private keys.\n" ++
optionsUsage
; let defaultKey = if updating then user config else defaultKey'
; let key = M.findWithDefault defaultKey Key optsMap
; case any (keyMatch key) privateKeys of
True -> return $ config { user = key }
False -> ioError . userError $ "Cannot find private key for '" ++
key ++ "'\n" ++ optionsUsage
}
where
keyMatch :: String -> Key -> Bool
keyMatch key (PrivateKey k _) = k == key
keyMatch _ _ = False
validateOption optsMap updating config Branch
= do { (bugsBranch, prefsBranch) <-
if updating && M.notMember Branch optsMap
then do { bb <- mtnFindCurrentBranch config bugsPath
; pb <- mtnFindCurrentBranch config prefsPath
; return (bb, pb)
}
else return (bugsBranch', prefsBranch')
; setupBranchOrCheckOutOrUpdate config updating bugsBranch bugsPath >>=
populateBugs config
; setupBranchOrCheckOutOrUpdate config updating prefsBranch prefsPath >>=
writePrefs config
; return config
}
where
defaultBranch = "DisTract"
branchBase = M.findWithDefault defaultBranch Branch optsMap
bugsBranch' = branchBase ++ ".bugs"
prefsBranch' = branchBase ++ ".prefs." ++ ( user config )
bugsPath = bugsDir base
prefsPath = prefsDir base
base = baseDir config
validateOption _ _ config Version = return config
setupBranchOrCheckOutOrUpdate :: Config -> Bool -> String -> FilePath ->
IO Bool
setupBranchOrCheckOutOrUpdate config updating branch dir
= do { existsBranch <- mtnDoesBranchExist config branch
; if existsBranch
then do { existsDir <- doesDirectoryExist fullPath
; if existsDir && updating
then do { branch' <- mtnFindCurrentBranch config dir
; if branch' /= branch
then error $ "Need to have branch " ++
branch ++ " in " ++ fullPath ++
" but directory already exists and contains branch " ++
branch' ++ ". Aborting."
else mtnUpdate config dir Nothing
}
else mtnCheckOutBranch config base branch dir
; return False
}
else do { mtnSetupBranch config branch dir
; return True
}
}
where
base = baseDir config
fullPath = combine base dir
writePrefs :: Config -> Bool -> IO ()
writePrefs config newBranch
= do { writeFileStrict configPath configText
; if newBranch
then do { writeFileStrict ignorePath ignoreText
; mtnAdd config prefsPath [".mtn-ignore"]
; mtnCommit config prefsPath "Adding .mtn-ignore" []
; return ()
}
else return ()
}
where
prefsPath = prefsDir base
configPath = combine prefsPath "config"
base = baseDir config
configText = "mtn=" ++ (mtnExecutable config) ++
"\ndb=" ++ (mtnDb config) ++
"\nverbose=" ++ (show . verbose $ config) ++
logConfig
logConfig = case logger config of
StdOutLog -> ""
(FileLog path) -> "\nlog=" ++ path
ignorePath = combine prefsPath ".mtn-ignore"
ignoreText = "^config$"
populateBugs :: Config -> Bool -> IO ()
populateBugs _ False = return ()
populateBugs config True
= do { writeFileStrict ignorePath ignoreText
; installAllFields fieldsPath
; mtnAddUnknownFiles config bugsPath
; mtnCommit config bugsPath "Adding .mtn-ignore and fields." []
; return ()
}
where
bugsPath = bugsDir base
base = baseDir config
ignorePath = combine bugsPath ".mtn-ignore"
ignoreText = "^bug-"
fieldsPath = combine bugsPath "fields"
invokeFormatNew :: Config -> IO ()
invokeFormatNew config
= runExecutable config "DisTractFormatNew"
invokeSortBugs :: Config -> IO ()
invokeSortBugs config
= runExecutable config "DisTractSortBugs"
invokeUpdateFormatAllBugs :: Config -> IO ()
invokeUpdateFormatAllBugs config
= runExecutable config "DisTractUpdateFormatAllBugs"
runExecutable :: Config -> String -> IO ()
runExecutable config execName
= do { (_, outH, errH, procH) <- runInteractiveProcess
execPath [base]
(Just base)
Nothing
; out <- hGetContents outH
; err <- hGetContents errH
; waitForProcess procH
; log "stdout" out
; log "stderr" err
}
where
base = baseDir config
binPath = binDir base
execPath = combine binPath execName
log = logWithPrefix . logger $ config
main :: IO ()
main = do { (optionFlagsMap, remaining) <- parseOptions
; case M.lookup Version optionFlagsMap of
Nothing -> doInstall optionFlagsMap remaining
_ -> putStrLn $ package_name ++ ": Version " ++ package_version
}
doInstall :: M.Map OptionFlag String -> [String] -> IO ()
doInstall optionFlagsMap remaining
= do { (base, configBase, updating) <-
case remaining of
[] -> ioError . userError $ "No Path supplied.\n" ++ optionsUsage
(path:rest) ->
do { exists <- doesDirectoryExist path
; (base, configBase) <-
case exists of
True -> do { putStrLn $ "Path " ++ path ++
" already exists, upgrading."
; configBase <- buildConfigFromArgs remaining
; return (path, configBase)
}
False -> do { createDirectory path
; configBase <- defaultConfig path []
; version <- mtnFindVersion configBase
; let configBase' = configBase { mtnVersion = version, args = rest }
; return (path, configBase')
}
; return (base, configBase, exists)
}
; config <- foldM (validateOption optionFlagsMap updating)
configBase [DB ..]
; createAllSubDirs base
; installAllBinaries (binDir base)
; installAllHTMLLibs (combine (htmlDir base) "lib")
; invokeFormatNew config
; invokeUpdateFormatAllBugs config
; invokeSortBugs config
}
createAllSubDirs :: FilePath -> IO ()
createAllSubDirs base = mapM_ (createDirectoryIfMissing False .
combine base)
["bin","html",combine "html" "lib"]
installAllBinaries :: FilePath -> IO ()
installAllBinaries binDir
= do { mapM_ (flip installDisTractBinary binDir)
[Installer_installDisTractBinary_NewBug ..]
; binaries <- getDirectoryContents binDir
; mapM_ makeExecutables binaries
}
where
makeExecutables :: FilePath -> IO ()
makeExecutables file
= do { isFile <- doesFileExist fullPath
; if isFile
then setPermissions fullPath perm
else return ()
}
where
fullPath = combine binDir file
perm = Permissions { readable = True,
writable = True,
executable = True,
searchable = False
}
-- these are in mtn so should only be installed on a new branch
installAllFields :: FilePath -> IO ()
installAllFields fieldsDir
= do { createDirectory fieldsDir
; mapM_ (flip installDisTractField fieldsDir)
[Installer_installDisTractField_Title ..]
}
installAllHTMLLibs :: FilePath -> IO ()
installAllHTMLLibs libsDir
= mapM_ (flip installDisTractHTMLLib libsDir)
[Installer_installDisTractHTMLLib_Bug ..]