{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE TypeApplications #-}
module GitHUD.Daemon.Runner (
    runDaemon
    ) where

import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar (MVar, readMVar, newMVar, swapMVar)
import qualified Control.Exception as E
import Control.Monad (when, forever, void, unless)
import qualified Data.ByteString.UTF8 as BSU
import Data.Maybe (fromMaybe)
import System.Directory (removeFile)
import System.Exit (exitFailure)
import System.Posix.Daemon (brutalKill, isRunning, runDetached, Redirection(DevNull, ToFile))
import System.Posix.Files (fileExist)

import GitHUD.Config.Types
import GitHUD.Daemon.Network
import GitHUD.Debug
import GitHUD.Git.Command

runDaemon :: Config
          -> Maybe String
          -> IO ()
runDaemon :: Config -> Maybe String -> IO ()
runDaemon = Int -> Config -> Maybe String -> IO ()
tryRunDaemon Int
5

tryRunDaemon :: Int
             -> Config
             -> Maybe String
             -> IO ()
tryRunDaemon :: Int -> Config -> Maybe String -> IO ()
tryRunDaemon Int
attempt Config
config Maybe String
mArg = do
  let pathToPoll :: String
pathToPoll = (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"/" Maybe String
mArg)
  -- If there are exception trying to access the pid file or the socket,
  -- we just kill the process and start again
  Either SomeException ()
success <- forall a.
Exception SomeException =>
IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
E.try @E.SomeException (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ do
    Config -> String -> String -> IO ()
ensureDaemonRunning Config
config String
socketFile String
pathToPoll
    String -> String -> IO ()
sendOnSocket String
socketFile String
pathToPoll
  Int -> Either SomeException () -> IO ()
forall a b. Show a => Int -> Either a b -> IO ()
restartIfNeeded Int
attempt Either SomeException ()
success
  where
    socketFile :: String
socketFile = Config -> String
confGithuddSocketFilePath Config
config
    pidFilePath :: String
pidFilePath = Config -> String
confGithuddPidFilePath Config
config
    restartIfNeeded :: Int -> Either a b -> IO ()
restartIfNeeded Int
0 Either a b
_ = IO Any -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO Any
forall a. IO a
exitFailure
    restartIfNeeded Int
_ (Right b
_) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    restartIfNeeded Int
attempt (Left a
e) = do
      String -> IO ()
debugOnStderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
e
      String -> IO ()
debugOnStderr String
"Error on client. Restarting daemon"
      IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
E.try @E.SomeException (String -> IO ()
brutalKill String
pidFilePath)   -- ignore possible errors
      Int -> IO ()
threadDelay Int
100_000
      Bool
pidFileExists <- String -> IO Bool
fileExist String
pidFilePath
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
pidFileExists (String -> IO ()
removeFile String
pidFilePath)
      Int -> Config -> Maybe String -> IO ()
tryRunDaemon (Int
attempt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Config
config Maybe String
mArg

ensureDaemonRunning :: Config
                    -> FilePath
                    -> FilePath
                    -> IO ()
ensureDaemonRunning :: Config -> String -> String -> IO ()
ensureDaemonRunning Config
config String
socketPath String
pathToPoll = do
  Bool
running <- String -> IO Bool
isRunning String
pidFilePath
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
running (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Redirection -> IO ()
removeLogFile Redirection
stdoutFile
    Maybe String -> Redirection -> IO () -> IO ()
runDetached (String -> Maybe String
forall a. a -> Maybe a
Just String
pidFilePath) Redirection
stdoutFile (Int -> String -> String -> IO ()
daemon Int
delaySec String
pathToPoll String
socketPath)
    Int -> IO ()
threadDelay Int
100_000     -- Give the daemon some time to start
  where
    stdoutFile :: Redirection
stdoutFile = Config -> Redirection
confGithuddLogFilePath Config
config
    pidFilePath :: String
pidFilePath = Config -> String
confGithuddPidFilePath Config
config
    delaySec :: Int
delaySec = Config -> Int
confGithuddSleepSeconds Config
config

removeLogFile :: Redirection
              -> IO ()
removeLogFile :: Redirection -> IO ()
removeLogFile Redirection
DevNull = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
removeLogFile (ToFile String
file) = do
    Bool
debugFileExists <- String -> IO Bool
fileExist String
file
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugFileExists (String -> IO ()
removeFile String
file)

daemon :: Int
       -> FilePath
       -> FilePath
       -> IO ()
daemon :: Int -> String -> String -> IO ()
daemon Int
delaySec String
path String
socket = do
  MVar String
pathToPoll <- String -> IO (MVar String)
forall a. a -> IO (MVar a)
newMVar String
path
  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ String -> MVar String -> IO ()
socketServer String
socket MVar String
pathToPoll
  IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> MVar String -> IO ()
fetcher Int
delaySec MVar String
pathToPoll

socketServer :: FilePath
             -> MVar String
             -> IO ()
socketServer :: String -> MVar String -> IO ()
socketServer String
socketPath MVar String
mvar = do
  Either SomeException ()
success <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
E.try @E.SomeException (String -> (String -> IO String) -> IO ()
forall m. String -> (String -> IO m) -> IO ()
receiveOnSocket String
socketPath String -> IO String
withMessage)
  Either SomeException () -> IO ()
forall a b. Show a => Either a b -> IO ()
restartIfNeeded Either SomeException ()
success
    where
      withMessage :: String -> IO String
withMessage = MVar String -> String -> IO String
forall a. MVar a -> a -> IO a
swapMVar MVar String
mvar
      restartIfNeeded :: Either a b -> IO ()
restartIfNeeded (Right b
_) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      restartIfNeeded (Left a
e) = do
        String -> IO ()
debug String
"Error on server. Restarting socket"
        String -> IO ()
debug (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
e
        Int -> IO ()
threadDelay Int
100_000
        String -> MVar String -> IO ()
socketServer String
socketPath MVar String
mvar

fetcher :: Int
        -> MVar String
        -> IO ()
fetcher :: Int -> MVar String -> IO ()
fetcher Int
delaySec MVar String
mvar = do
  String
path <- MVar String -> IO String
forall a. MVar a -> IO a
readMVar MVar String
mvar
  String -> IO ()
gitCmdFetch String
path
  Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
delaySec Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1_000_000
  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()