#include "gadts.h"
module Darcs.Repository.Prefs ( addToPreflist, getPreflist, setPreflist,
getGlobal, environmentHelpHome,
defaultrepo, setDefaultrepo,
getPrefval, setPrefval, changePrefval,
defPrefval,
writeDefaultPrefs,
boringRegexps, boringFileFilter, darcsdirFilter,
FileType(..), filetypeFunction,
getCaches,
binariesFileHelp, boringFileHelp,
globalCacheDir,
globalPrefsDirDoc,
) where
import System.IO.Error ( isDoesNotExistError )
import Control.Monad ( unless, when )
import Text.Regex ( Regex, mkRegex, matchRegex, )
import Data.Char ( toUpper )
import Data.Maybe ( isJust, fromMaybe, mapMaybe )
import Data.List ( nub, isPrefixOf, union, sortBy )
import System.Directory ( getAppUserDataDirectory, doesDirectoryExist, createDirectory, doesFileExist )
import Darcs.Lock( readBinFile, writeBinFile )
import System.FilePath.Posix ( (</>) )
import System.Environment ( getEnvironment )
import Darcs.Flags ( DarcsFlag( NoCache, NoSetDefault, DryRun, RemoteRepo ) )
import Darcs.RepoPath ( AbsolutePath, ioAbsolute, toFilePath, getCurrentDirectory )
import Darcs.Utils ( catchall, stripCr )
import Darcs.External ( gzFetchFilePS, Cachable( Cachable ) )
import qualified Data.ByteString.Char8 as BC ( unpack )
import qualified Data.ByteString as B ( empty )
import Darcs.Global ( darcsdir )
import Darcs.Repository.Cache ( Cache(..), CacheType(..), CacheLoc(..),
WritableOrNot(..), compareByLocality )
import Darcs.URL ( isFile )
writeDefaultPrefs :: IO ()
writeDefaultPrefs = do setPreflist "boring" defaultBoring
setPreflist "binaries" defaultBinaries
setPreflist "motd" []
defaultBoring :: [String]
defaultBoring = help ++
[ "",
"### compiler and interpreter intermediate files",
"# haskell (ghc) interfaces",
"\\.hi$", "\\.hi-boot$", "\\.o-boot$",
"# object files",
"\\.o$","\\.o\\.cmd$",
"# profiling haskell",
"\\.p_hi$", "\\.p_o$",
"# haskell program coverage resp. profiling info",
"\\.tix$", "\\.prof$",
"# fortran module files",
"\\.mod$",
"# linux kernel",
"\\.ko\\.cmd$","\\.mod\\.c$",
"(^|/)\\.tmp_versions($|/)",
"# *.ko files aren't boring by default because they might",
"# be Korean translations rather than kernel modules",
"# \\.ko$",
"# python, emacs, java byte code",
"\\.py[co]$", "\\.elc$","\\.class$",
"# objects and libraries; lo and la are libtool things",
"\\.(obj|a|exe|so|lo|la)$",
"# compiled zsh configuration files",
"\\.zwc$",
"# Common LISP output files for CLISP and CMUCL",
"\\.(fas|fasl|sparcf|x86f)$",
"",
"### build and packaging systems",
"# cabal intermediates",
"\\.installed-pkg-config",
"\\.setup-config",
"# standard cabal build dir, might not be boring for everybody",
"# ^dist(/|$)",
"# autotools",
"(^|/)autom4te\\.cache($|/)", "(^|/)config\\.(log|status)$",
"# microsoft web expression, visual studio metadata directories",
"\\_vti_cnf$",
"\\_vti_pvt$",
"# gentoo tools",
"\\.revdep-rebuild.*",
"# generated dependencies",
"^\\.depend$",
"",
"### version control systems",
"# cvs",
"(^|/)CVS($|/)","\\.cvsignore$",
"# cvs, emacs locks",
"^\\.#",
"# rcs",
"(^|/)RCS($|/)", ",v$",
"# subversion",
"(^|/)\\.svn($|/)",
"# mercurial",
"(^|/)\\.hg($|/)",
"# git",
"(^|/)\\.git($|/)",
"# bzr",
"\\.bzr$",
"# sccs",
"(^|/)SCCS($|/)",
"# darcs",
"(^|/)"++darcsdir++"($|/)", "(^|/)\\.darcsrepo($|/)",
"^\\.darcs-temp-mail$",
"-darcs-backup[[:digit:]]+$",
"# gnu arch",
"(^|/)(\\+|,)",
"(^|/)vssver\\.scc$",
"\\.swp$","(^|/)MT($|/)",
"(^|/)\\{arch\\}($|/)","(^|/).arch-ids($|/)",
"# bitkeeper",
"(^|/)BitKeeper($|/)","(^|/)ChangeSet($|/)",
"",
"### miscellaneous",
"# backup files",
"~$","\\.bak$","\\.BAK$",
"# patch originals and rejects",
"\\.orig$", "\\.rej$",
"# X server",
"\\..serverauth.*",
"# image spam",
"\\#", "(^|/)Thumbs\\.db$",
"# vi, emacs tags",
"(^|/)(tags|TAGS)$",
"#(^|/)\\.[^/]",
"# core dumps",
"(^|/|\\.)core$",
"# partial broken files (KIO copy operations)",
"\\.part$",
"# waf files, see http://code.google.com/p/waf/",
"(^|/)\\.waf-[[:digit:].]+-[[:digit:]]+($|/)",
"(^|/)\\.lock-wscript$",
"# mac os finder",
"(^|/)\\.DS_Store$" ]
where
help = map ("# "++) boringFileHelp
boringFileHelp :: [String]
boringFileHelp =
[ "This file contains a list of extended regular expressions, one per"
, "line. A file path matching any of these expressions will be filtered"
, "out during `darcs add', or when the `--look-for-adds' flag is passed"
, "to `darcs whatsnew' and `record'. The entries in " ++ globalPrefsDirDoc ++ "boring (if"
, "it exists) supplement those in this file."
, ""
, "Blank lines, and lines beginning with an octothorpe (#) are ignored."
, "See regex(7) for a description of extended regular expressions."
]
darcsdirFilter :: [FilePath] -> [FilePath]
darcsdirFilter = filter (not.isDarcsdir)
isDarcsdir :: FilePath -> Bool
isDarcsdir ('.':'/':f) = isDarcsdir f
isDarcsdir "." = True
isDarcsdir "" = True
isDarcsdir ".." = True
isDarcsdir "../" = True
isDarcsdir "_darcs" = True
isDarcsdir fp = "_darcs/" `isPrefixOf` fp
globalPrefsDir :: IO (Maybe FilePath)
globalPrefsDir = do
env <- getEnvironment
case lookup "DARCS_TESTING_PREFS_DIR" env of
Just d -> return (Just d)
Nothing -> fmap Just (getAppUserDataDirectory "darcs")
`catchall` (return Nothing)
globalPrefsDirDoc :: String
globalPrefsDirDoc =
#ifndef WIN32
"~/.darcs/"
#else
"%APPDATA%\\darcs\\"
#endif
environmentHelpHome :: ([String], [String])
environmentHelpHome = (["HOME", "APPDATA"], [
"Per-user preferences are set in $HOME/.darcs (on Unix) or",
"%APPDATA%/darcs (on Windows). This is also the default location of",
"the cache."])
getGlobal :: String -> IO [String]
getGlobal f = do
dir <- globalPrefsDir
case dir of
(Just d) -> getPreffile $ d </> f
Nothing -> return []
globalCacheDir :: IO (Maybe FilePath)
globalCacheDir = slash_cache `fmap` globalPrefsDir
where slash_cache = fmap (</> "cache")
boringRegexps :: IO [Regex]
boringRegexps = do
borefile <- defPrefval "boringfile" (darcsdir ++ "/prefs/boring")
bores <- getPrefLines borefile `catchall` return []
gbs <- getGlobal "boring"
return $ map mkRegex $ bores ++ gbs
boringFileFilter :: IO ([FilePath] -> [FilePath])
boringFileFilter = fmap actualBoringFileFilter boringRegexps
noncomments :: [String] -> [String]
noncomments ss = filter is_ok ss
where is_ok "" = False
is_ok ('#':_) = False
is_ok _ = True
getPrefLines :: FilePath -> IO [String]
getPrefLines f = (notconflicts . noncomments . map stripCr . lines)
`fmap` readBinFile f
where notconflicts = filter nc
startswith [] _ = True
startswith (x:xs) (y:ys) | x == y = startswith xs ys
startswith _ _ = False
nc l | startswith "v v v v v v v" l = False
nc l | startswith "*************" l = False
nc l | startswith "^ ^ ^ ^ ^ ^ ^" l = False
nc _ = True
actualBoringFileFilter :: [Regex] -> [FilePath] -> [FilePath]
actualBoringFileFilter regexps files = filter (not . boring . normalize) files
where boring file = isDarcsdir file ||
any (\regexp -> isJust $ matchRegex regexp file) regexps
normalize :: FilePath -> FilePath
normalize ('.':'/':f) = normalize f
normalize f = normalize_helper $ reverse f
where
normalize_helper ('/':rf) = normalize_helper rf
normalize_helper rf = reverse rf
data FileType = BinaryFile | TextFile
deriving (Eq)
defaultBinaries :: [String]
defaultBinaries = help ++
["\\.(" ++ e ++ "|" ++ map toUpper e ++ ")$" | e <- extensions ]
where extensions = ["a","bmp","bz2","doc","elc","exe","gif","gz","iso",
"jar","jpe?g","mng","mpe?g","p[nbgp]m","pdf","png",
"pyc","so","tar","tgz","tiff?","z","zip"]
help = map ("# "++) binariesFileHelp
binariesFileHelp :: [String]
binariesFileHelp =
["This file contains a list of extended regular expressions, one per",
"line. A file path matching any of these expressions is assumed to",
"contain binary data (not text). The entries in " ++ globalPrefsDirDoc ++ "binaries (if",
"it exists) supplement those in this file.",
"",
"Blank lines, and lines beginning with an octothorpe (#) are ignored.",
"See regex(7) for a description of extended regular expressions."]
filetypeFunction :: IO (FilePath -> FileType)
filetypeFunction = do
binsfile <- defPrefval "binariesfile" (darcsdir ++ "/prefs/binaries")
bins <- getPrefLines binsfile `catch`
(\e-> if isDoesNotExistError e then return [] else ioError e)
gbs <- getGlobal "binaries"
let regexes = map mkRegex (bins ++ gbs)
let isbin f = any (\r -> isJust $ matchRegex r f) regexes
ftf f = if isbin $ normalize f then BinaryFile else TextFile
in
return ftf
prefsDirectory :: IO (Maybe String)
prefsDirectory =
do darcs <- doesDirectoryExist darcsdir
return $ if darcs
then Just $ darcsdir ++ "/prefs/"
else Nothing
withPrefsDirectory :: (String -> IO ()) -> IO ()
withPrefsDirectory j = prefsDirectory >>= maybe (return ()) j
addToPreflist :: String -> String -> IO ()
addToPreflist p s = withPrefsDirectory $ \prefs -> do
hasprefs <- doesDirectoryExist prefs
unless hasprefs $ createDirectory prefs
pl <- getPreflist p
writeBinFile (prefs ++ p) $ unlines $ union [s] pl
getPreflist :: String -> IO [String]
getPreflist p = prefsDirectory >>= maybe (return []) (\prefs -> getPreffile $ prefs ++ p)
getPreffile :: FilePath -> IO [String]
getPreffile f = do
hasprefs <- doesFileExist f
if hasprefs
then getPrefLines f
else return []
setPreflist :: String -> [String] -> IO ()
setPreflist p ls = withPrefsDirectory $ \prefs -> do
haspref <- doesDirectoryExist prefs
when haspref $ writeBinFile (prefs ++ p) (unlines ls)
defPrefval :: String -> String -> IO String
defPrefval p d = fromMaybe d `fmap` getPrefval p
getPrefval :: String -> IO (Maybe String)
getPrefval p =
do pl <- getPreflist "prefs"
return $
case map snd $ filter ((==p).fst) $ map (break (==' ')) pl of
[val] ->
case words val of
[] -> Nothing
_ -> Just $ tail val
_ -> Nothing
setPrefval :: String -> String -> IO ()
setPrefval p v = do pl <- getPreflist "prefs"
setPreflist "prefs" $
filter ((/=p) . fst . break (==' ')) pl ++ [p++" "++v]
changePrefval :: String -> String -> String -> IO ()
changePrefval p f t =
do pl <- getPreflist "prefs"
ov <- getPrefval p
let newval = case ov of
Nothing -> t
Just old -> if old == f then t else old
setPreflist "prefs" $
filter ((/=p) . fst . break(==' ')) pl ++ [p++" "++newval]
defaultrepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
defaultrepo opts _ [] =
do let fixR r | isFile r = toFilePath `fmap` ioAbsolute r
| otherwise = return r
case [r | RemoteRepo r <- opts] of
[] -> do defrepo <- getPreflist "defaultrepo"
case defrepo of
[r] -> (:[]) `fmap` fixR r
_ -> return []
rs -> mapM fixR rs
defaultrepo _ _ r = return r
setDefaultrepo :: String -> [DarcsFlag] -> IO ()
setDefaultrepo r opts = do olddef <- getPreflist "defaultrepo"
let doit = null noSetDefault && greenLight
greenLight = wetRun
&& not rIsTmp
&& (olddef /= [r] || olddef == [])
if doit
then setPreflist "defaultrepo" [r]
else when (True `notElem` noSetDefault && greenLight) $ putStr . unlines $
[ "HINT: if you want to change the default remote repository to"
, " " ++ r ++ ","
, " quit now and issue the same command with the --set-default flag."
]
addToPreflist "repos" r
`catchall` return ()
where
wetRun = DryRun `notElem` opts
rIsTmp = r `elem` [x | RemoteRepo x <- opts]
noSetDefault = [x | NoSetDefault x <- opts]
getCaches :: [DarcsFlag] -> String -> IO Cache
getCaches opts repodir =
do here <- parsehs `fmap` getPreffile (darcsdir ++ "/prefs/sources")
there <- (parsehs . lines . BC.unpack) `fmap`
(gzFetchFilePS (repodir </> darcsdir </> "prefs/sources") Cachable
`catchall` return B.empty)
globalcachedir <- globalCacheDir
let globalcache = case (nocache,globalcachedir) of
(True,_) -> []
(_,Just d) -> [Cache Directory Writable d]
_ -> []
globalsources <- parsehs `fmap` getGlobal "sources"
thisdir <- getCurrentDirectory
let thisrepo = [Cache Repo Writable $ toFilePath thisdir]
let tempCache = nub $ thisrepo ++ globalcache ++ globalsources ++
here ++ [Cache Repo NotWritable repodir] ++ filterExternalSources there
return $ Ca $ sortBy compareByLocality tempCache
where
parsehs = mapMaybe readln . noncomments
readln l | "repo:" `isPrefixOf` l = Just (Cache Repo NotWritable (drop 5 l))
| nocache = Nothing
| "cache:" `isPrefixOf` l = Just (Cache Directory Writable (drop 6 l))
| "readonly:" `isPrefixOf` l = Just (Cache Directory NotWritable (drop 9 l))
| otherwise = Nothing
nocache = NoCache `elem` opts
filterExternalSources there = if isFile repodir
then
there
else
filter (not . isFile . cacheSource) there