{-# LANGUAGE CPP                 #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell   #-}
module Devel
    ( devel
    , DevelOpts(..)
    , DevelTermOpt(..)
    , 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           Control.Concurrent.Async              (race_)
import qualified Control.Exception                     as Ex
import           Control.Monad                         (forever, unless, void,
                                                        when, forM)
import           Control.Monad.IO.Class                (liftIO)
import           Control.Monad.Trans.State             (evalStateT, get)
import qualified Data.IORef                            as I

import qualified Data.ByteString.Lazy                  as LB
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.Streaming.Network                (bindPortTCP)
import           Network                               (withSocketsDo)
import           Network.HTTP.Conduit                  (conduitManagerSettings, newManager)
import           Data.Default.Class                    (def)
#if MIN_VERSION_http_client(0,4,7)
import           Network.HTTP.Client                   (managerSetProxy, noProxy)
#endif
import           Network.HTTP.ReverseProxy             (ProxyDest (ProxyDest),
                                                        waiProxyToSettings, wpsTimeout, wpsOnExc)
import qualified Network.HTTP.ReverseProxy             as ReverseProxy
import           Network.HTTP.Types                    (status200, status503)
import           Network.Socket                        (sClose)
import           Network.Wai                           (responseLBS, requestHeaders)
import           Network.Wai.Parse                     (parseHttpAccept)
import           Network.Wai.Handler.Warp              (run, defaultSettings, setPort)
import           Network.Wai.Handler.WarpTLS           (runTLS, tlsSettingsMemory)
import           SrcLoc                                (Located)
import           Data.FileEmbed        (embedFile)

lockFile :: FilePath
lockFile =  "yesod-devel/devel-terminate"

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

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

data DevelTermOpt = TerminateOnEnter | TerminateOnlyInterrupt
     deriving (Show, Eq)
     
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
      , develTlsPort :: Int
      , proxyTimeout :: Int
      , useReverseProxy :: Bool
      , terminateWith :: DevelTermOpt

      -- Support for GHC_PACKAGE_PATH wrapping
      , develConfigOpts :: [String]
      , develEnv :: Maybe [(String, String)]
      } deriving (Show, Eq)

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

defaultDevelOpts :: DevelOpts
defaultDevelOpts = DevelOpts
    { isCabalDev   = False
    , forceCabal   = False
    , verbose      = False
    , eventTimeout = -1
    , successHook  = Nothing
    , failHook     = Nothing
    , buildDir     = Nothing
    , develPort    = 3000
    , develTlsPort = 3443
    , proxyTimeout = 10
    , useReverseProxy = True
    , terminateWith = TerminateOnEnter
    }

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
#if MIN_VERSION_http_client(0,4,7)
    manager <- newManager $ managerSetProxy noProxy conduitManagerSettings
#else
    manager <- newManager conduitManagerSettings
#endif
    let refreshHtml = LB.fromChunks $ return $(embedFile "refreshing.html")
    let onExc _ req
            | maybe False (("application/json" `elem`) . parseHttpAccept)
                (lookup "accept" $ requestHeaders req) =
                    return $ responseLBS status503
                        [ ("Retry-After", "1")
                        ]
                        "{\"message\":\"Recompiling\"}"
            | otherwise = return $ responseLBS status200
                [ ("content-type", "text/html")
                , ("Refresh", "1")
                ]
                refreshHtml

    let proxyApp = waiProxyToSettings
                (const $ do
                    appPort <- liftIO $ I.readIORef iappPort
                    return $
                        ReverseProxy.WPRProxyDest
                        $ ProxyDest "127.0.0.1" appPort)
                def
                    { wpsOnExc = \e req f -> onExc e req >>= f
                    , wpsTimeout =
                        if proxyTimeout opts == 0
                            then Nothing
                            else Just (1000000 * proxyTimeout opts)
                    }
                manager
        runProxyTls port app = do
          let cert = $(embedFile "certificate.pem")
              key = $(embedFile "key.pem")
              tlsSettings = tlsSettingsMemory cert key
          runTLS tlsSettings (setPort port defaultSettings) app
        httpProxy = run (develPort opts) proxyApp
        httpsProxy = runProxyTls (develTlsPort opts) proxyApp
    putStrLn "Application can be accessed at:\n"
    putStrLn $ "http://127.0.0.1:" ++ show (develPort opts)
    putStrLn $ "https://127.0.0.1:" ++ show (develTlsPort opts)
    putStrLn $ "If you wish to test https capabilities, you should set the following variable:"
    putStrLn $ "  export APPROOT=https://127.0.0.1:" ++ show (develTlsPort opts)
    putStrLn ""
    loop (race_ httpProxy httpsProxy) `Ex.catch` \e -> do
        print (e :: Ex.SomeException)
        exitFailure
        Ex.throwIO e -- heh, just for good measure
  where
    loop proxies = forever $ do
        void proxies
        putStrLn $ "Reverse proxy stopped, but it shouldn't"
        threadDelay 1000000
        putStrLn $ "Restarting reverse proxies"

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

getPort :: DevelOpts -> Int -> IO Int
getPort opts _ 
  | not (useReverseProxy opts) = return $ develPort opts
getPort _ p0 =
    loop p0
  where
    loop p = do
        avail <- checkPort p
        if avail then return p else loop (succ p)

unlessM :: Monad m => m Bool -> m () -> m ()
unlessM c a = c >>= \res -> unless res a

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

    let (terminator, after) = case terminateWith opts of
          TerminateOnEnter ->
              ("Press ENTER", void getLine)
          TerminateOnlyInterrupt ->  -- run for one year
              ("Interrupt", threadDelay $ 1000 * 1000 * 60 * 60 * 24 * 365)


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

    -- outer loop re-reads the cabal file
    mainOuterLoop develHsPath iappPort filesModified = do
      ghcVer <- liftIO ghcVersion
#if MIN_VERSION_Cabal(1,20,0)
      cabal  <- liftIO $ D.tryFindPackageDesc "."
#else
      cabal  <- liftIO $ D.findPackageDesc "."
#endif
      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 develHsPath iappPort hsSourceDirs filesModified cabal rebuild
           else do
             liftIO (threadDelay 5000000)
             mainOuterLoop develHsPath iappPort filesModified

    -- inner loop rebuilds after files change
    mainInnerLoop develHsPath 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 ++ [develHsPath]
           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 "\x1b[1;31mBuild failure, pausing...\x1b[0m"
                   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 opts . (+ 1)
                   liftIO $ I.writeIORef iappPort appPort

                   (_,_,_,ph) <- liftIO $ createProcess (proc "runghc" devArgs)
                        { env = Just $ Map.toList
                                     $ Map.insert "PORT" (show appPort)
                                     $ Map.insert "DISPLAY_PORT" (show $ develPort opts)
                                     $ Map.fromList 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 develHsPath 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"
                                 , "--disable-tests"
                                 , "--disable-benchmarks"
                                 , "-fdevel"
                                 , "--disable-library-profiling"
                                 , "--with-ld=yesod-ld-wrapper"
                                 , "--with-ghc=yesod-ghc-wrapper"
                                 , "--with-ar=yesod-ar-wrapper"
                                 , "--with-hc-pkg=ghc-pkg"
                                 ] ++ develConfigOpts opts ++ extraArgs
               ) { env = develEnv opts }

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 yesod-bin"
  | forceCabal opts               = return (rebuildCabal opts)
  | otherwise                     =
      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)
        { env = develEnv opts
        }
    where
      args | verbose opts = [ "build" ]
           | otherwise    = [ "build", "-v0" ]

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

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 $ forM 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 FilePath
checkDevelFile =
    loop paths
  where
    paths = ["app/devel.hs", "devel.hs", "src/devel.hs"]

    loop [] = failWith $ "file devel.hs not found, checked: " ++ show paths
    loop (x:xs) = do
        e <- doesFileExist x
        if e
            then return x
            else loop xs

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 ("Application" `notElem` (map (last . D.components) $ 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 (not . isSetup) . 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

    isSetup "Setup.hs" = True
    isSetup "./Setup.hs" = True
    isSetup "Setup.lhs" = True
    isSetup "./Setup.lhs" = True
    isSetup _ = False

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
#if MIN_VERSION_Cabal(1,22,0)
  (_, _, pgmc) <- D.configCompilerEx (Just D.GHC) Nothing Nothing D.defaultProgramConfiguration D.silent
#else
  (_, pgmc) <- D.configCompiler (Just D.GHC) Nothing Nothing D.defaultProgramConfiguration D.silent
#endif
  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