--  Copyright (C) 2002-2003 David Roundy
--
--  This program is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2, or (at your option)
--  any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program; see the file COPYING.  If not, write to
--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
--  Boston, MA 02110-1301, USA.


{-# LANGUAGE CPP #-}

#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 Prelude hiding ( catch )

import System.IO.Error ( isDoesNotExistError )
import Control.Exception ( catch )
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" []

{-# NOINLINE defaultBoring #-}
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

-- | The path of the global preference directory; @~/.darcs@ on Unix,
-- and @%APPDATA%/darcs@ on Windows.
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)

-- | The relative path of the global preference directory; @~/.darcs@ on Unix,
-- and @%APPDATA%/darcs@ on Windows. This is used for online documentation.
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

-- | From a list of paths, filter out any that are within @_darcs@ or
-- match a boring regexp.
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)

{-# NOINLINE defaultBinaries #-}
-- | The lines that will be inserted into @_darcs/prefs/binaries@ when
-- @darcs init@ is run.  Hence, a list of comments, blank lines and
-- regular expressions (ERE dialect).
--
-- Note that while this matches .gz and .GZ, it will not match .gZ,
-- i.e. it is not truly case insensitive.
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

-- this avoids a circular dependency with Repository
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 $
                                      -- the nuance here is that we should only notify when the
                                      -- reason we're not setting default is the --no-set-default
                                      -- flag, not the various automatic show stoppers
                                      [ "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 () -- we don't care if this fails!
 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
