{- 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 ..]