{-# LANGUAGE CPP                 #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Devel
    ( devel
    , DevelOpts(..)
    , defaultDevelOpts
    ) where


import qualified Distribution.Compiler                 as D
import qualified Distribution.ModuleName               as D
import qualified Distribution.PackageDescription       as D
import qualified Distribution.PackageDescription.Parse as D
import qualified Distribution.Simple.Configure         as D
import qualified Distribution.Simple.Program           as D
import qualified Distribution.Simple.Utils             as D
import qualified Distribution.Verbosity                as D

import           Control.Applicative                   ((<$>), (<*>))
import           Control.Concurrent                    (forkIO, threadDelay)
import           Control.Concurrent.MVar               (MVar, newEmptyMVar,
                                                        takeMVar, tryPutMVar)
import qualified Control.Exception                     as Ex
import           Control.Monad                         (forever, unless, void,
                                                        when)
import           Control.Monad.IO.Class                (liftIO)
import           Control.Monad.Trans.State             (evalStateT, get)
import qualified Data.IORef                            as I

import           Data.Char                             (isNumber, isUpper)
import qualified Data.List                             as L
import qualified Data.Map                              as Map
import           Data.Maybe                            (fromMaybe)
import qualified Data.Set                              as Set

import           System.Directory
import           System.Environment                    (getEnvironment)
import           System.Exit                           (ExitCode (..),
                                                        exitFailure,
                                                        exitSuccess)
import           System.FilePath                       (dropExtension,
                                                        splitDirectories,
                                                        takeExtension, (</>))
import           System.FSNotify
import           System.IO                             (Handle)
import           System.IO.Error                       (isDoesNotExistError)
import           System.Posix.Types                    (EpochTime)
import           System.PosixCompat.Files              (getFileStatus,
                                                        modificationTime)
import           System.Process                        (ProcessHandle,
                                                        createProcess, env,
                                                        getProcessExitCode,
                                                        proc, readProcess,
                                                        system,
                                                        terminateProcess)
import           System.Timeout                        (timeout)

import           Build                                 (getDeps, isNewerThan,
                                                        recompDeps)
import           GhcBuild                              (buildPackage,
                                                        getBuildFlags, getPackageArgs)

import qualified Config                                as GHC
import           Data.Conduit.Network                  (HostPreference (HostIPv4),
                                                        bindPort)
import           Network                               (withSocketsDo)
import           Network.HTTP.Conduit                  (def, newManager)
import           Network.HTTP.ReverseProxy             (ProxyDest (ProxyDest),
                                                        waiProxyToSettings, wpsTimeout, wpsOnExc)
import           Network.HTTP.Types                    (status200)
import           Network.Socket                        (sClose)
import           Network.Wai                           (responseLBS)
import           Network.Wai.Handler.Warp              (run)
import           SrcLoc                                (Located)

lockFile :: DevelOpts -> FilePath
lockFile _opts =  "yesod-devel/devel-terminate"

writeLock :: DevelOpts -> IO ()
writeLock opts = do
    createDirectoryIfMissing True "yesod-devel"
    writeFile (lockFile opts) ""
    createDirectoryIfMissing True "dist" -- for compatibility with old devel.hs
    writeFile "dist/devel-terminate" ""

removeLock :: DevelOpts -> IO ()
removeLock opts = do
    removeFileIfExists (lockFile opts)
    removeFileIfExists "dist/devel-terminate"  -- for compatibility with old devel.hs

data DevelOpts = DevelOpts
      { isCabalDev   :: Bool
      , forceCabal   :: Bool
      , verbose      :: Bool
      , eventTimeout :: Int -- negative value for no timeout
      , successHook  :: Maybe String
      , failHook     :: Maybe String
      , buildDir     :: Maybe String
      , develPort    :: Int
      , proxyTimeout :: Int
      } deriving (Show, Eq)

getBuildDir :: DevelOpts -> String
getBuildDir opts = fromMaybe "dist" (buildDir opts)

defaultDevelOpts :: DevelOpts
defaultDevelOpts = DevelOpts False False False (-1) Nothing Nothing Nothing 3000 10

cabalProgram :: DevelOpts -> FilePath
cabalProgram opts | isCabalDev opts = "cabal-dev"
                  | otherwise       = "cabal"

-- | Run a reverse proxy from port 3000 to 3001. If there is no response on
-- 3001, give an appropriate message to the user.
reverseProxy :: DevelOpts -> I.IORef Int -> IO ()
reverseProxy opts iappPort = do
    manager <- newManager def
    let loop = forever $ do
            run (develPort opts) $ waiProxyToSettings
                (const $ do
                    appPort <- liftIO $ I.readIORef iappPort
                    return $ Right $ ProxyDest "127.0.0.1" appPort)
                def
                    { wpsOnExc = onExc
                    , wpsTimeout = Just (1000000 * proxyTimeout opts)
                    }
                manager
            putStrLn "Reverse proxy stopped, but it shouldn't"
            threadDelay 1000000
            putStrLn "Restarting reverse proxy"
    loop `Ex.onException` exitFailure
  where
    onExc _ _ = return $ responseLBS
        status200
        [ ("content-type", "text/html")
        , ("Refresh", "1")
        ]
        "<h1>App not ready, please refresh</h1>"

checkPort :: Int -> IO Bool
checkPort p = do
    es <- Ex.try $ bindPort p HostIPv4
    case es of
        Left (_ :: Ex.IOException) -> return False
        Right s -> do
            sClose s
            return True

getPort :: Int -> IO Int
getPort p = do
    avail <- checkPort p
    if avail then return p else getPort (succ p)

devel :: DevelOpts -> [String] -> IO ()
devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do
    avail <- checkPort $ develPort opts
    unless avail $ error "devel port unavailable"
    iappPort <- getPort 17834 >>= I.newIORef
    _ <- forkIO $ reverseProxy opts iappPort
    checkDevelFile
    writeLock opts

    putStrLn "Yesod devel server. Press ENTER to quit"
    _ <- forkIO $ do
      filesModified <- newEmptyMVar
      watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ()))
      evalStateT (mainOuterLoop iappPort filesModified) Map.empty
    _ <- getLine
    writeLock opts
    exitSuccess
  where
    bd = getBuildDir opts

    -- outer loop re-reads the cabal file
    mainOuterLoop iappPort filesModified = do
      ghcVer <- liftIO ghcVersion
      cabal  <- liftIO $ D.findPackageDesc "."
      gpd    <- liftIO $ D.readPackageDescription D.normal cabal
      ldar   <- liftIO lookupLdAr
      (hsSourceDirs, _) <- liftIO $ checkCabalFile gpd
      liftIO $ removeFileIfExists (bd </> "setup-config")
      c <- liftIO $ configure opts passThroughArgs
      if c then do
             -- these files contain the wrong data after the configure step,
             -- remove them to force a cabal build first
             liftIO $ mapM_ removeFileIfExists [ "yesod-devel/ghcargs.txt"
                                               , "yesod-devel/arargs.txt"
                                               , "yesod-devel/ldargs.txt"
                                               ]
             rebuild <- liftIO $ mkRebuild ghcVer cabal opts ldar
             mainInnerLoop iappPort hsSourceDirs filesModified cabal rebuild
           else do
             liftIO (threadDelay 5000000)
             mainOuterLoop iappPort filesModified

    -- inner loop rebuilds after files change
    mainInnerLoop iappPort hsSourceDirs filesModified cabal rebuild = go
       where
         go = do
           _ <- recompDeps hsSourceDirs
           list <- liftIO $ getFileList hsSourceDirs [cabal]
           success <- liftIO rebuild
           pkgArgs <- liftIO (ghcPackageArgs opts)
           let devArgs = pkgArgs ++ ["devel.hs"]
           let loop list0 = do
                   (haskellFileChanged, list1) <- liftIO $
                       watchForChanges filesModified hsSourceDirs [cabal] list0 (eventTimeout opts)
                   anyTouched <- recompDeps hsSourceDirs
                   unless (anyTouched || haskellFileChanged) $ loop list1
           if not success
             then liftIO $ do
                   putStrLn "Build failure, pausing..."
                   runBuildHook $ failHook opts
             else do
                   liftIO $ runBuildHook $ successHook opts
                   liftIO $ removeLock opts
                   liftIO $ putStrLn
                            $ if verbose opts then "Starting development server: runghc " ++ L.unwords devArgs
                                              else "Starting development server..."
                   env0 <- liftIO getEnvironment

                   -- get a new port for the new process to listen on
                   appPort <- liftIO $ I.readIORef iappPort >>= getPort . (+ 1)
                   liftIO $ I.writeIORef iappPort appPort

                   (_,_,_,ph) <- liftIO $ createProcess (proc "runghc" devArgs)
                        { env = Just $ ("PORT", show appPort) : ("DISPLAY_PORT", show $ develPort opts) : env0
                        }
                   derefMap <- get
                   watchTid <- liftIO . forkIO . try_ $ flip evalStateT derefMap $ do
                      loop list
                      liftIO $ do
                         putStrLn "Stopping development server..."
                         writeLock opts
                         threadDelay 1000000
                         putStrLn "Terminating development server..."
                         terminateProcess ph
                   ec <- liftIO $ waitForProcess' ph
                   liftIO $ putStrLn $ "Exit code: " ++ show ec
                   liftIO $ Ex.throwTo watchTid (userError "process finished")
           loop list
           n <- liftIO $ cabal `isNewerThan` (bd </> "setup-config")
           if n then mainOuterLoop iappPort filesModified else go

runBuildHook :: Maybe String -> IO ()
runBuildHook (Just s) = do
             ret <- system s
             case ret of
                  ExitFailure _ -> putStrLn ("Error executing hook: " ++ s)
                  _             -> return ()
runBuildHook Nothing = return ()

{-
   run `cabal configure' with our wrappers
-}
configure :: DevelOpts -> [String] -> IO Bool
configure opts extraArgs =
  checkExit =<< (createProcess $ proc (cabalProgram opts)
                                ([ "configure"
                                 , "-flibrary-only"
                                 , "-fdevel"
                                 , "--disable-library-profiling"
                                 , "--with-ld=yesod-ld-wrapper"
                                 , "--with-ghc=yesod-ghc-wrapper"
                                 , "--with-ar=yesod-ar-wrapper"
                                 , "--with-hc-pkg=ghc-pkg"
                                 ] ++ extraArgs)
               )

removeFileIfExists :: FilePath -> IO ()
removeFileIfExists file = removeFile file `Ex.catch` handler
    where
      handler :: IOError -> IO ()
      handler e | isDoesNotExistError e = return ()
                | otherwise             = Ex.throw e

mkRebuild :: String -> FilePath -> DevelOpts -> (FilePath, FilePath) -> IO (IO Bool)
mkRebuild ghcVer cabalFile opts (ldPath, arPath)
  | GHC.cProjectVersion /= ghcVer =
       failWith "Yesod has been compiled with a different GHC version, please reinstall"
  | forceCabal opts               = return (rebuildCabal opts)
  | otherwise                     = do
      return $ do
        ns <- mapM (cabalFile `isNewerThan`)
           [ "yesod-devel/ghcargs.txt", "yesod-devel/arargs.txt", "yesod-devel/ldargs.txt" ]
        if or ns
          then rebuildCabal opts
          else do
            bf <- getBuildFlags
            rebuildGhc bf ldPath arPath


rebuildGhc :: [Located String] -> FilePath -> FilePath -> IO Bool
rebuildGhc bf ld ar = do
  putStrLn "Rebuilding application... (using GHC API)"
  buildPackage bf ld ar

rebuildCabal :: DevelOpts -> IO Bool
rebuildCabal opts = do
  putStrLn $ "Rebuilding application... (using " ++ cabalProgram opts ++ ")"
  checkExit =<< createProcess (proc (cabalProgram opts) args)
    where
      args | verbose opts = [ "build" ]
           | otherwise    = [ "build", "-v0" ]

try_ :: forall a. IO a -> IO ()
try_ x = (Ex.try x :: IO (Either Ex.SomeException a)) >> return ()

type FileList = Map.Map FilePath EpochTime

getFileList :: [FilePath] -> [FilePath] -> IO FileList
getFileList hsSourceDirs extraFiles = do
    (files, deps) <- getDeps hsSourceDirs
    let files' = extraFiles ++ files ++ map fst (Map.toList deps)
    fmap Map.fromList $ flip mapM files' $ \f -> do
        efs <- Ex.try $ getFileStatus f
        return $ case efs of
            Left (_ :: Ex.SomeException) -> (f, 0)
            Right fs -> (f, modificationTime fs)

-- | Returns @True@ if a .hs file changed.
watchForChanges :: MVar () -> [FilePath] -> [FilePath] -> FileList -> Int -> IO (Bool, FileList)
watchForChanges filesModified hsSourceDirs extraFiles list t = do
    newList <- getFileList hsSourceDirs extraFiles
    if list /= newList
      then do
        let haskellFileChanged = not $ Map.null $ Map.filterWithKey isHaskell $
                Map.differenceWith compareTimes newList list `Map.union`
                Map.differenceWith compareTimes list newList
        return (haskellFileChanged, newList)
      else timeout (1000000*t) (takeMVar filesModified) >>
           watchForChanges filesModified hsSourceDirs extraFiles list t
  where
    compareTimes x y
        | x == y = Nothing
        | otherwise = Just x

    isHaskell filename _ = takeExtension filename `elem` [".hs", ".lhs", ".hsc", ".cabal"]

checkDevelFile :: IO ()
checkDevelFile = do
  e <- doesFileExist "devel.hs"
  unless e $ failWith "file devel.hs not found"

checkCabalFile :: D.GenericPackageDescription -> IO ([FilePath], D.Library)
checkCabalFile gpd = case D.condLibrary gpd of
    Nothing -> failWith "incorrect cabal file, no library"
    Just ct ->
      case lookupDevelLib gpd ct of
        Nothing   ->
          failWith "no development flag found in your configuration file. Expected a 'library-only' flag or the older 'devel' flag"
        Just dLib -> do
           let hsSourceDirs = D.hsSourceDirs . D.libBuildInfo $ dLib
           fl <- getFileList hsSourceDirs []
           let unlisted = checkFileList fl dLib
           unless (null unlisted) $ do
                putStrLn "WARNING: the following source files are not listed in exposed-modules or other-modules:"
                mapM_ putStrLn unlisted
           when (D.fromString "Application" `notElem` D.exposedModules dLib) $
                putStrLn "WARNING: no exposed module Application"
           return (hsSourceDirs, dLib)

failWith :: String -> IO a
failWith msg = do
    putStrLn $ "ERROR: " ++ msg
    exitFailure

checkFileList :: FileList -> D.Library -> [FilePath]
checkFileList fl lib = filter isUnlisted . filter isSrcFile $ sourceFiles
  where
    al = allModules lib
    -- a file is only a possible 'module file' if all path pieces start with a capital letter
    sourceFiles = filter isSrcFile . map fst . Map.toList $ fl
    isSrcFile file = let dirs = filter (/=".") $ splitDirectories file
                     in  all (isUpper . head) dirs && (takeExtension file `elem` [".hs", ".lhs"])
    isUnlisted file = not (toModuleName file `Set.member` al)
    toModuleName = L.intercalate "." . filter (/=".") . splitDirectories . dropExtension

allModules :: D.Library -> Set.Set String
allModules lib = Set.fromList $ map toString $ D.exposedModules lib ++ (D.otherModules . D.libBuildInfo) lib
    where
      toString = L.intercalate "." . D.components

ghcVersion :: IO String
ghcVersion = fmap getNumber $ readProcess "runghc" ["--numeric-version", "0"] []
    where
      getNumber = filter (\x -> isNumber x || x == '.')

ghcPackageArgs :: DevelOpts -> IO [String]
ghcPackageArgs opts = getBuildFlags >>= getPackageArgs (buildDir opts)

lookupDevelLib :: D.GenericPackageDescription -> D.CondTree D.ConfVar c a -> Maybe a
lookupDevelLib gpd ct | found     = Just (D.condTreeData ct)
                      | otherwise = Nothing
  where
    flags = map (unFlagName . D.flagName) $ D.genPackageFlags gpd
    unFlagName (D.FlagName x) = x
    found = any (`elem` ["library-only", "devel"]) flags

-- location of `ld' and `ar' programs
lookupLdAr :: IO (FilePath, FilePath)
lookupLdAr = do
  mla <- lookupLdAr'
  case mla of
    Nothing -> failWith "Cannot determine location of `ar' or `ld' program"
    Just la -> return la

lookupLdAr' :: IO (Maybe (FilePath, FilePath))
lookupLdAr' = do
  (_, pgmc) <- D.configCompiler (Just D.GHC) Nothing Nothing D.defaultProgramConfiguration D.silent
  pgmc' <- D.configureAllKnownPrograms D.silent pgmc
  return $ (,) <$> look D.ldProgram pgmc' <*> look D.arProgram pgmc'
     where
       look pgm pdb = fmap D.programPath (D.lookupProgram pgm pdb)

-- | nonblocking version of @waitForProcess@
waitForProcess' :: ProcessHandle -> IO ExitCode
waitForProcess' pid = go
  where
    go = do
      mec <- getProcessExitCode pid
      case mec of
        Just ec -> return ec
        Nothing -> threadDelay 100000 >> go

-- | wait for process started by @createProcess@, return True for ExitSuccess
checkExit :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO Bool
checkExit (_,_,_,h) = (==ExitSuccess) <$> waitForProcess' h