module Main (main) where

import Control.Arrow
import Network.HTTP.Client.TLS (newTlsManager)
import Control.Exception (try, SomeException)
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except
import Data.Either
import Data.List
import qualified Distribution.Hackage.DB as DB
import Distribution.Text
import Distribution.Types.Version
import Network.Socket (withSocketsDo)
import Paths_codex (version)
import System.Console.AsciiProgress (displayConsoleRegions)
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.Process (shell, readCreateProcessWithExitCode)

import Codex
import Codex.Project
import Codex.Internal (Builder(..), hackagePathOf, readStackPath)
import Main.Config

-- TODO Add 'cache dump' to dump all tags in stdout (usecase: pipe to grep)
-- TODO Use a mergesort algorithm for `assembly`
-- TODO Better error handling and fine grained retry

retrying :: Int -> IO (Either a b) -> IO (Either [a] b)
retrying n x = retrying' n $ fmap (left (:[])) x where
  retrying' 0  x' = x'
  retrying' n' x' = retrying' (n' - 1) $ x' >>= \res -> case res of
    Left ls -> fmap (left (++ ls)) x'
    Right r -> return $ Right r

hashFile :: Codex -> FilePath
hashFile cx = hackagePath cx </> "codex.hash"

cleanCache :: (Builder, Codex) -> IO ()
cleanCache (bldr, cx) = do
  -- TODO Delete hash file!
  xs <- listDirectory hp
  ys <- builderOp bldr =<< traverseDirectories xs
  _  <- removeTagFiles $ concat ys
  return ()
  where
    hp = hackagePath cx
    safe = (try :: IO a -> IO (Either SomeException a))
    removeTagFiles = traverse (safe . removeFile) . fmap (</> "tags")
    traverseDirectories = fmap rights . traverse (safe . listDirectory)
    builderOp (Stack _) = traverseDirectories . concat
    builderOp Cabal = return

readCacheHash :: Codex -> IO (Maybe String)
readCacheHash cx = do
  fileExist <- doesFileExist $ hashFile cx
  if not fileExist then return Nothing else do
    content <- readFile $ hashFile cx
    return $ Just content

writeCacheHash :: Codex -> String -> IO ()
writeCacheHash cx = writeFile $ hashFile cx

update :: Bool -> Codex -> Builder -> IO ()
update force cx bldr = displayConsoleRegions $ do
  (mpid, dependencies, workspaceProjects') <- case bldr of
       Cabal -> do
         tb <- DB.hackageTarball
         resolveCurrentProjectDependencies bldr tb
       Stack _ -> resolveCurrentProjectDependencies bldr $ hackagePath cx
  projectHash <- computeCurrentProjectHash cx
  shouldUpdate <-
    if null workspaceProjects' then
      either (const True) id <$> (runExceptT $ isUpdateRequired cx dependencies projectHash)
    else return True

  if force || shouldUpdate then do
    let workspaceProjects = if currentProjectIncluded cx
          then workspaceProjects'
          else filter (("." /=) . workspaceProjectPath) workspaceProjects'
    fileExist <- doesFileExist tagsFile
    when fileExist $ removeFile tagsFile
    putStrLn ("Updating: " ++ displayPackages mpid workspaceProjects)
    s <- newTlsManager
    tick' <- newProgressBar' "Loading tags" (length dependencies)
    results <- traverse (retrying 3 . runExceptT . getTags tick' s) dependencies
    _       <- traverse print . concat $ lefts results
    res     <- runExceptT $ assembly bldr cx dependencies projectHash workspaceProjects tagsFile
    case res of
      Left e -> do
        print e
        exitFailure
      Right _ -> pure ()
  else
    putStrLn "Nothing to update."
  where
    tagsFile = tagsFileName cx
    hp = hackagePathOf bldr cx
    getTags tick' s i = status hp i >>= \x -> case x of
      Source Tagged   -> tick' >> return ()
      Source Untagged -> tags bldr cx i >> tick' >> getTags tick' s i
      Archive         -> extract hp i >> tick' >> getTags tick' s i
      Remote          -> liftIO $ either ignore return <=< runExceptT $ fetch s hp i >> tick' >> getTags tick' s i
        where
          ignore msg = do
            putStrLn $ concat ["codex: *warning* unable to fetch an archive for ", display i]
            putStrLn msg
            return ()
    displayPackages mpid workspaceProjects =
      case mpid of
        Just p -> display p
        Nothing ->
          unwords (fmap (display . workspaceProjectIdentifier) workspaceProjects)

help :: IO ()
help = putStrLn $
  unlines [ "Usage: codex [update] [cache clean] [set tagger [hasktags|ctags]] [set format [vim|emacs|sublime]]"
          , "             [--help]"
          , "             [--version]"
          , ""
          , " update                Synchronize the tags file in the current cabal project directory"
          , " update --force        Discard tags file hash and force regeneration"
          , " cache clean           Remove all `tags` file from the local hackage cache]"
          , " set tagger <tagger>   Update the `~/.codex` configuration file for the given tagger (hasktags|ctags)."
          , " set format <format>   Update the `~/.codex` configuration file for the given format (vim|emacs|sublime)."
          , ""
          , "By default `hasktags` will be used, and need to be in the `PATH`, the tagger command can be fully customized in `~/.codex`."
          , ""
          , "Note: codex will browse the parent directory for cabal projects and use them as dependency over hackage when possible." ]

main :: IO ()
main = withSocketsDo $ do
  cx    <- loadConfig
  args  <- getArgs
  run cx args where
    run cx ["cache", "clean"] = toBuilderConfig cx >>= cleanCache
    run cx ["update"]             = withConfig cx (update False)
    run cx ["update", "--force"]  = withConfig cx (update True)
    run cx ["set", "tagger", "ctags"]     = encodeConfig $ cx { tagsCmd = taggerCmd Ctags }
    run cx ["set", "tagger", "hasktags"]  = encodeConfig $ cx { tagsCmd = taggerCmd Hasktags }
    run cx ["set", "format", "emacs"]     = encodeConfig $ cx { tagsCmd = taggerCmd HasktagsEmacs, tagsFileHeader = False, tagsFileSorted = False, tagsFileName = "TAGS" }
    run cx ["set", "format", "sublime"]   = encodeConfig $ cx { tagsCmd = taggerCmd HasktagsExtended, tagsFileHeader = True, tagsFileSorted = True }
    run cx ["set", "format", "vim"]       = encodeConfig $ cx { tagsFileHeader = True, tagsFileSorted = True }
    run _  ["--version"] = putStrLn $ concat ["codex: ", display (mkVersion' version)]
    run _  ["--help"] = help
    run _  []         = help
    run _  args       = fail' $ concat ["codex: '", intercalate " " args,"' is not a codex command. See 'codex --help'."]

    toBuilderConfig cx' = checkConfig cx' >>= \state -> case state of
      TaggerNotFound  -> fail' $ "codex: tagger not found."
      Ready           -> do
        stackFileExists <- doesFileExist $ "." </> "stack.yaml"
        stackWorkExists <- doesDirectoryExist $ "." </> ".stack-work"
        if stackFileExists && stackWorkExists then do
            (ec, _, _) <- readCreateProcessWithExitCode (shell "which stack") ""
            case ec of
                ExitSuccess -> do
                    let opts = stackOpts cx'
                    globalPath <- readStackPath opts "stack-root"
                    binPath <- readStackPath opts "bin-path"
                    path <- getEnv "PATH"
                    setEnv "PATH" $ concat [path, ":", binPath]
                    return (Stack opts, cx' { hackagePath = globalPath </> "indices" </> "Hackage" })
                _ ->
                    return (Cabal, cx')
        else return (Cabal, cx')

    withConfig cx' f = do
      (bldr, cx) <- toBuilderConfig cx'
      cacheHash' <- readCacheHash cx
      case cacheHash' of
        Just cacheHash ->
            when (cacheHash /= codexHash cx) $ do
            putStrLn "codex: configuration has been updated, cleaning cache ..."
            cleanCache (bldr, cx)
        Nothing -> return ()
      res <- f cx bldr
      writeCacheHash cx $ codexHash cx
      return res

    fail' msg = do
      putStrLn $ msg
      exitWith (ExitFailure 1)