hdevtools-0.1.8.0: src/Client.hs

module Client
    ( getServerStatus
    , stopServer
    , serverCommand
    ) where

import           Control.Exception (bracket, tryJust)
import           Control.Monad     (guard)
import           Daemonize         (daemonize)
import           Network.Socket    (Family (AF_UNIX), SockAddr (SockAddrUnix),
                                    SocketType (Stream), connect,
                                    defaultProtocol, socket, socketToHandle)
import           Server            (createListenSocket, startServer)
import           System.Exit       (exitFailure, exitWith)
import           System.IO         (Handle, IOMode (ReadWriteMode), hClose,
                                    hFlush, hGetLine, hPrint, hPutStrLn, stderr)
import           System.IO.Error   (isDoesNotExistError)
import           Types             (ClientDirective (..), Command (..),
                                    CommandExtra (..), ServerDirective (..))
import           Util              (readMaybe)

connectSocket :: FilePath -> IO Handle
connectSocket sock = do
  s <- socket AF_UNIX Stream defaultProtocol
  connect s (SockAddrUnix sock)
  socketToHandle s ReadWriteMode

getServerStatus :: FilePath -> IO ()
getServerStatus sock =
    bracket (connectSocket sock) hClose $ \h -> do
      hPrint h SrvStatus
      hFlush h
      startClientReadLoop h

stopServer :: FilePath -> IO ()
stopServer sock = do
    bracket (connectSocket sock) hClose $ \h -> do
      hPrint h SrvExit
      hFlush h
      startClientReadLoop h

serverCommand :: FilePath -> Command -> CommandExtra -> IO ()
serverCommand sock cmd cmdExtra = do
    r <- tryJust (guard . isDoesNotExistError) (connectSocket sock)
    case r of
        Right h -> do
            hPrint h (SrvCommand cmd cmdExtra)
            hFlush h
            startClientReadLoop h
        Left _ -> do
            s <- createListenSocket sock
            daemonize False $ startServer sock (Just s) cmdExtra
            serverCommand sock cmd cmdExtra

startClientReadLoop :: Handle -> IO ()
startClientReadLoop h = do
    msg <- hGetLine h
    let clientDirective = readMaybe msg
    case clientDirective of
        Just (ClientStdout out) -> putStrLn out >> startClientReadLoop h
        Just (ClientStderr err) -> hPutStrLn stderr err >> startClientReadLoop h
        Just (ClientExit exitCode) -> hClose h >> exitWith exitCode
        Just (ClientUnexpectedError err) -> hClose h >> unexpectedError err
        Nothing -> do
            hClose h
            unexpectedError $
                "The server sent an invalid message to the client: " ++ show msg

unexpectedError :: String -> IO ()
unexpectedError err = do
    hPutStrLn stderr banner
    hPutStrLn stderr err
    hPutStrLn stderr banner
    exitFailure
    where banner = replicate 78 '*'