{-# LANGUAGE OverloadedStrings #-}

-- | A module for easily creating reliable deploy processes for Haskell
-- applications.
module System.Hapistrano
       ( Config(..)
       , ReleaseFormat(..)

       , activateRelease
       , currentPath
       , defaultSuccessHandler
       , defaultErrorHandler
       , directoryExists
       , isReleaseString
       , pathToRelease
       , pushRelease
       , readCurrentLink
       , restartServerCommand
       , rollback
       , runRC
       , runBuild

       ) where

import Control.Monad.Reader (ReaderT(..), ask)


import System.Hapistrano.Types
  (Config(..), FailureResult, Hapistrano, Release, ReleaseFormat(..))

import Control.Monad (unless, void)
import System.Exit (ExitCode(..), exitWith)

import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.Either ( left
                                  , right
                                  , eitherT )

import Data.Char (isNumber)
import Data.List (intercalate, sortBy, isInfixOf)
import Data.Time (getCurrentTime)
import Data.Time.Format (formatTime)
import Data.Time.Locale.Compat (defaultTimeLocale)
import System.FilePath.Posix (joinPath, splitPath)
import System.IO (hPutStrLn, stderr)
import System.Process (readProcessWithExitCode)

import qualified System.IO as IO
import qualified System.Process as Process

-- | Does basic project setup for a project, including making sure
-- some directories exist, and pushing a new release directory with the
-- SHA1 or branch specified in the configuration.
pushRelease :: Hapistrano Release
pushRelease = setupDirs >> ensureRepositoryPushed >> updateCacheRepo >>
              cleanReleases >> cloneToRelease >>= setReleaseRevision

-- | Switches the current symlink to point to the release specified in
-- the configuration. Maybe used in either deploy or rollback cases.
activateRelease :: Release -> Hapistrano String
activateRelease rel = removeCurrentSymlink >> symlinkCurrent rel

-- | Runs the deploy, along with an optional success or failure function.
runRC :: ((Int, String) -> ReaderT Config IO a) -- ^ Error handler
      -> (a -> ReaderT Config IO a)             -- ^ Success handler
      -> Config                  -- ^ Hapistrano deployment configuration
      -> Hapistrano a            -- ^ The remote command to run
      -> IO a
runRC errorHandler successHandler config command =
    runReaderT (eitherT errorHandler successHandler command) config

-- | Default method to run on deploy failure. Emits a failure message
-- and exits with a status code of 1.
defaultErrorHandler :: FailureResult -> ReaderT Config IO ()
defaultErrorHandler res =
  liftIO $ hPutStrLn stderr
  ("Deploy failed with (status, message): " ++ show res)
  >> exitWith (ExitFailure 1)

-- | Default method to run on deploy success.
defaultSuccessHandler :: a -> ReaderT Config IO ()
defaultSuccessHandler _ =
  liftIO $ putStrLn "Deploy completed successfully."


-- | Creates necessary directories for the hapistrano project. Should
-- only need to run the first time the project is deployed on a given
-- system.
setupDirs :: Hapistrano ()
setupDirs = do
  conf <- ask

  mapM_ (runCommand (host conf))
    ["mkdir -p " ++ releasesPath conf, "mkdir -p " ++ cacheRepoPath conf]

directoryExists :: Maybe String -> FilePath -> IO Bool
directoryExists hst path = do
  let (command, args) = case hst of
        Just h  -> ("ssh", [h, "ls", path])
        Nothing -> ("ls", [path])

  (code, _, _) <- readProcessWithExitCode command args ""

  return $ case code of
    ExitSuccess   -> True
    ExitFailure _ -> False

-- | Runs the given command either locally or on the local machine.
runCommand :: Maybe String -- ^ The host on which to run the command
           -> String -- ^ The command to run, either on the local or remote host
           -> Hapistrano String

runCommand Nothing command = execShellCommand command
runCommand (Just server) command =
  execCommand $ unwords ["ssh", server, command]

execShellCommand :: String -> Hapistrano String
execShellCommand command = do
  liftIO $ putStrLn ("Executing: " ++ command)
  let process = Process.shell command
  (_, Just outHandle, Just errHandle, processHandle) <-
    liftIO $
      Process.createProcess process { Process.std_err = Process.CreatePipe
                                    , Process.std_in = Process.CreatePipe
                                    , Process.std_out = Process.CreatePipe
                                    }
  exitCode <- liftIO $ Process.waitForProcess processHandle
  case exitCode of
    ExitFailure code -> do
      err <- liftIO $ IO.hGetContents errHandle
      left (code, trim err)
    ExitSuccess -> do
      out <- liftIO $ IO.hGetContents outHandle
      unless (null out) (liftIO $ putStrLn ("Output: " ++ out))
      right (trim out)

execCommand :: String -> Hapistrano String
execCommand cmd = do
  let wds         = words cmd
      (cmd', args) = (head wds, tail wds)

  liftIO $ putStrLn $ "Executing: " ++ cmd

  (code, stdout, err) <- liftIO $ readProcessWithExitCode cmd' args ""

  case code of
    ExitSuccess -> do
      unless (null stdout) (liftIO $ putStrLn $ "Output: " ++ stdout)

      right $ trim stdout

    ExitFailure int -> left (int, trim err)

-- | Returns a timestamp in the default format for build directories.
currentTimestamp :: ReleaseFormat -> IO String
currentTimestamp format = do
  curTime <- getCurrentTime
  return $ formatTime defaultTimeLocale fstring curTime

  where fstring = case format of
          Short -> "%Y%m%d%H%M%S"
          Long  -> "%Y%m%d%H%M%S%q"

-- | Returns the FilePath pointed to by the current symlink.
readCurrentLink :: Hapistrano FilePath -- ^ The target of the symlink in the Hapistrano monad
readCurrentLink = do
  conf <- ask
  runCommand (host conf) $ "readlink " ++ currentPath (deployPath conf)

-- ^ Trims any newlines from the given String
trim :: String -- ^ String to have trailing newlines stripped
     -> String -- ^ String with trailing newlines removed
trim = reverse . dropWhile (== '\n') . reverse

-- | Ensure that the initial bare repo exists in the repo directory. Idempotent.
ensureRepositoryPushed :: Hapistrano String
ensureRepositoryPushed = do
  conf <- ask
  res  <-
    liftIO $ directoryExists (host conf) $ joinPath [cacheRepoPath conf, "refs"]

  if res
    then right "Repo already existed"
    else createCacheRepo

-- | Returns the full path of the folder containing all of the release builds.
releasesPath :: Config -> FilePath
releasesPath conf = joinPath [deployPath conf, "releases"]

-- | Figures out the most recent release if possible.
detectPrevious :: [String] -- ^ The releases in `releases` path
               -> Hapistrano String -- ^ The previous release in the Hapistrano monad
detectPrevious rs =
  case biggest rs of
    Nothing -> left (1, "No previous releases detected!")
    Just rls -> right rls

-- | Activates the previous detected release.
rollback :: Hapistrano String -- ^ The current Release in the Hapistrano monad
rollback = previousReleases >>= detectPrevious >>= activateRelease

-- | Clones the repository to the next releasePath timestamp. Makes a new
-- timestamp if one doesn't yet exist in the HapistranoState. Returns the
-- timestamp of the release that we cloned to.
cloneToRelease :: Hapistrano Release -- ^ The newly-cloned Release, in the Hapistrano monad
cloneToRelease = do
  conf <- ask
  rls  <- liftIO $ currentTimestamp (releaseFormat conf)

  void $ runCommand (host conf) $ "git clone " ++ cacheRepoPath conf ++
    " " ++ joinPath [ releasesPath conf, rls ]

  return rls


-- | Returns the full path to the git repo used for cache purposes on the
-- target host filesystem.
cacheRepoPath :: Config -- ^ The Hapistrano configuration
              -> FilePath -- ^ The full path to the git cache repo used for speeding up deploys
cacheRepoPath conf = joinPath [deployPath conf, "repo"]

-- | Returns the full path to the current symlink.
currentPath :: FilePath -- ^ The full path of the deploy folder root
            -> FilePath -- ^ The full path to the `current` symlink
currentPath depPath = joinPath [depPath, "current"]

-- | Take the release timestamp from the end of a filepath.
pathToRelease :: FilePath -- ^ The entire FilePath to a Release directory
              -> Release -- ^ The Release number.
pathToRelease = last . splitPath

-- | Returns a list of Strings representing the currently deployed releases.
releases :: Hapistrano [Release] -- ^ A list of all found Releases on the target host
releases = do
  conf <- ask
  res  <- runCommand (host conf) $ "find " ++ releasesPath conf ++
          " -type d -maxdepth 1"

  right $
    filter (isReleaseString (releaseFormat conf)) . map pathToRelease $
    lines res

previousReleases :: Hapistrano [Release] -- ^ All non-current releases on the target host
previousReleases = do
  rls            <- releases
  currentRelease <- readCurrentLink

  let currentRel = (head . lines . pathToRelease) currentRelease
  return $ filter (< currentRel) rls

releasePath :: Config -> Release -> FilePath
releasePath conf rls = joinPath [releasesPath conf, rls]

-- | Given a list of release strings, takes the last four in the sequence.
-- Assumes a list of folders that has been determined to be a proper release
-- path.
oldReleases :: Config -> [Release] -> [FilePath]
oldReleases conf rs = map mergePath toDelete
  where sorted             = sortBy (flip compare) rs
        toDelete           = drop 4 sorted
        mergePath = releasePath conf

-- | Removes releases older than the last five to avoid filling up the target
-- host filesystem.
cleanReleases :: Hapistrano [String] -- ^ Deleted Release directories
cleanReleases = do
  conf        <- ask
  allReleases <- releases

  let deletable = oldReleases conf allReleases

  if null deletable
    then do
      liftIO $ putStrLn "There are no old releases to prune."
      return []

    else do
      _ <- runCommand (host conf) $ "rm -rf -- " ++ unwords deletable
      return deletable

-- | Returns a Bool indicating if the given String is in the proper release
-- format.
isReleaseString :: ReleaseFormat -- ^ Format of Release directories
                -> String -- ^ String to check against Release format
                -> Bool -- ^ Whether the given String adheres to the specified Release format
isReleaseString format s = all isNumber s && length s == releaseLength
  where releaseLength = case format of
          Short -> 14
          Long  -> 26

-- | Creates the git repository that is used on the target host for
-- cache purposes.
createCacheRepo :: Hapistrano String -- ^ Output of the git command used to create the bare cache repo
createCacheRepo = do
  conf <- ask

  runCommand (host conf) $ "git clone --bare " ++ repository conf ++ " " ++
    cacheRepoPath conf

-- | Returns the full path of the symlink pointing to the current
-- release.
currentSymlinkPath :: Config -> FilePath
currentSymlinkPath conf = joinPath [deployPath conf, "current"]

currentTempSymlinkPath :: Config -> FilePath
currentTempSymlinkPath conf = joinPath [deployPath conf, "current_tmp"]

-- | Removes the current symlink in preparation for a new release being
-- activated.
removeCurrentSymlink :: Hapistrano ()
removeCurrentSymlink = do
  conf <- ask

  void $ runCommand (host conf) $ "rm -rf " ++ currentSymlinkPath conf

-- | Determines whether the target host OS is Linux
targetIsLinux :: Hapistrano Bool
targetIsLinux = do
  conf <- ask
  res <- runCommand (host conf) "uname"

  right $ "Linux" `isInfixOf` res

-- | Runs a command to restart a server if a command is provided.
restartServerCommand :: Hapistrano String
restartServerCommand = do
  conf <- ask

  case restartCommand conf of
    Nothing -> return "No command given for restart action."
    Just cmd -> runCommand (host conf) cmd

-- | Runs a build script if one is provided.
runBuild :: Release -> Hapistrano Release
runBuild rel = do
  conf <- ask

  case buildScript conf of
    Nothing ->
      liftIO $ putStrLn "No build script specified, skipping build step."

    Just scr -> do
      fl <- liftIO $ readFile scr
      buildRelease rel $ lines fl

  right rel

-- | Returns the best 'mv' command for a symlink given the target platform.
mvCommand :: Bool   -- ^ Whether the target host is Linux
          -> String -- ^ The best mv command for a symlink on the platform
mvCommand True  = "mv -Tf"
mvCommand False = "mv -f"

-- | Creates a symlink to the current release.
lnCommand ::
  String    -- ^ The path of the new release
  -> String -- ^ The temporary symlink target for the release
  -> String -- ^ A command to create the temporary symlink
lnCommand rlsPath symlinkPath = unwords ["ln -s", rlsPath, symlinkPath]

-- | Creates a symlink to the directory indicated by the release timestamp.
-- hapistrano does this by creating a temporary symlink and doing an atomic
-- mv (1) operation to activate the new release.
symlinkCurrent :: Release -> Hapistrano String
symlinkCurrent rel = do
  conf <- ask

  isLnx <- targetIsLinux

  let tmpLnCmd =
        lnCommand (releasePath conf rel) (currentTempSymlinkPath conf)

  _ <- runCommand (host conf) tmpLnCmd

  runCommand (host conf) $ unwords [ mvCommand isLnx
                                   , currentTempSymlinkPath conf
                                   , currentSymlinkPath conf ]


-- | Updates the git repo used as a cache in the target host filesystem.
updateCacheRepo :: Hapistrano ()
updateCacheRepo = do
  conf <- ask

  void $ runCommand (host conf) $ intercalate " && "
    [ "cd " ++ cacheRepoPath conf
    , "git fetch origin +refs/heads/*:refs/heads/*" ]

-- | Sets the release to the correct revision by resetting the
-- head of the git repo.
setReleaseRevision :: Release -> Hapistrano Release
setReleaseRevision rel = do
  conf <- ask

  liftIO $ putStrLn "Setting revision in release path."

  void $ runCommand (host conf) $ intercalate " && "
    [ "cd " ++ releasePath conf rel
    , "git fetch --all"
    , "git reset --hard " ++ revision conf
    ]

  return rel

-- | Returns a command that builds this application. Sets the context
-- of the build by switching to the release directory before running
-- the script.
buildRelease :: Release  -- ^ The Release to build
             -> [String] -- ^ Commands to be run. List intercalated
                         -- with "&&" so that failure aborts the
                         -- sequence.
             -> Hapistrano ()
buildRelease rel commands = do
  conf <- ask
  let cdCmd = "cd " ++ releasePath conf rel
  void $ runCommand (host conf) $ intercalate " && " $ cdCmd : commands


-- | A safe version of the `maximum` function in Data.List.
biggest :: Ord a => [a] -> Maybe a
biggest rls =
  case sortBy (flip compare) rls of
    []  -> Nothing
    r:_ -> Just r