{-# LANGUAGE OverloadedStrings #-}
module Keter.Cli
    ( launchCli
    , CliStates(..)
    ) where

import Keter.Types.Common
import Keter.AppManager
import Control.Concurrent (forkFinally)
import qualified Control.Exception as E
import Control.Monad (unless, forever, void, when)
import qualified Data.ByteString as S
import Network.Socket
import Network.Socket.ByteString (recv, sendAll)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Options.Applicative
import Data.Foldable
import GHC.Conc

data Commands = CmdListRunningApps
              | CmdExit

data CliStates = MkCliStates
  { CliStates -> AppManager
csAppManager :: !AppManager
  , CliStates -> LogMessage -> IO ()
csLog        :: !(LogMessage -> IO ())
  , CliStates -> Port
csPort       :: !Port
  }

launchCli :: CliStates -> IO ()
launchCli :: CliStates -> IO ()
launchCli CliStates
states = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
withSocketsDo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    AddrInfo
addr <- ServiceName -> IO AddrInfo
resolve (ServiceName -> IO AddrInfo) -> ServiceName -> IO AddrInfo
forall a b. (a -> b) -> a -> b
$ Port -> ServiceName
forall a. Show a => a -> ServiceName
show (Port -> ServiceName) -> Port -> ServiceName
forall a b. (a -> b) -> a -> b
$ CliStates -> Port
csPort CliStates
states
    IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (AddrInfo -> IO Socket
open AddrInfo
addr) Socket -> IO ()
close ((Socket -> IO ()) -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
x -> do
                                    CliStates -> LogMessage -> IO ()
csLog CliStates
states (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ AddrInfo -> LogMessage
BindCli AddrInfo
addr
                                    CliStates -> Socket -> IO ()
forall b. CliStates -> Socket -> IO b
loop CliStates
states Socket
x
commandParser :: Parser Commands
commandParser :: Parser Commands
commandParser = Mod CommandFields Commands -> Parser Commands
forall a. Mod CommandFields a -> Parser a
hsubparser (Mod CommandFields Commands -> Parser Commands)
-> Mod CommandFields Commands -> Parser Commands
forall a b. (a -> b) -> a -> b
$
  [Mod CommandFields Commands] -> Mod CommandFields Commands
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [
  ServiceName -> ParserInfo Commands -> Mod CommandFields Commands
forall a. ServiceName -> ParserInfo a -> Mod CommandFields a
command ServiceName
"exit"
    (Parser Commands -> InfoMod Commands -> ParserInfo Commands
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Commands -> Parser Commands
forall (f :: * -> *) a. Applicative f => a -> f a
pure Commands
CmdExit)
      (ServiceName -> InfoMod Commands
forall a. ServiceName -> InfoMod a
progDesc ServiceName
"List all ports"))
  ,
  ServiceName -> ParserInfo Commands -> Mod CommandFields Commands
forall a. ServiceName -> ParserInfo a -> Mod CommandFields a
command ServiceName
"apps"
      (Parser Commands -> InfoMod Commands -> ParserInfo Commands
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Commands -> Parser Commands
forall (f :: * -> *) a. Applicative f => a -> f a
pure Commands
CmdListRunningApps)
        (ServiceName -> InfoMod Commands
forall a. ServiceName -> InfoMod a
progDesc ServiceName
"Exit the program"))
  ]

resolve :: ServiceName -> IO AddrInfo
resolve :: ServiceName -> IO AddrInfo
resolve ServiceName
port = do
        let hints :: AddrInfo
hints = AddrInfo
defaultHints {
                addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_PASSIVE]
              , addrSocketType :: SocketType
addrSocketType = SocketType
Stream
              }
        AddrInfo
addr:[AddrInfo]
_ <- Maybe AddrInfo
-> Maybe ServiceName -> Maybe ServiceName -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) Maybe ServiceName
forall a. Maybe a
Nothing (ServiceName -> Maybe ServiceName
forall a. a -> Maybe a
Just ServiceName
port)
        AddrInfo -> IO AddrInfo
forall (m :: * -> *) a. Monad m => a -> m a
return AddrInfo
addr

open :: AddrInfo -> IO Socket
open :: AddrInfo -> IO Socket
open AddrInfo
addr = do
    Socket
sock <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
addr) (AddrInfo -> SocketType
addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
addr)
    Socket -> SocketOption -> Port -> IO ()
setSocketOption Socket
sock SocketOption
ReuseAddr Port
1
    -- If the prefork technique is not used,
    -- set CloseOnExec for the security reasons.
    Socket -> (ProtocolNumber -> IO ()) -> IO ()
forall r. Socket -> (ProtocolNumber -> IO r) -> IO r
withFdSocket Socket
sock ((ProtocolNumber -> IO ()) -> IO ())
-> (ProtocolNumber -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ProtocolNumber -> IO ()
setCloseOnExecIfNeeded
    Socket -> SockAddr -> IO ()
bind Socket
sock (AddrInfo -> SockAddr
addrAddress AddrInfo
addr)
    Socket -> Port -> IO ()
listen Socket
sock Port
10
    Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock

loop :: CliStates -> Socket -> IO b
loop :: CliStates -> Socket -> IO b
loop CliStates
states Socket
sock = IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO b) -> IO () -> IO b
forall a b. (a -> b) -> a -> b
$ do
    (Socket
conn, SockAddr
peer) <- Socket -> IO (Socket, SockAddr)
accept Socket
sock
    CliStates -> LogMessage -> IO ()
csLog CliStates
states (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ SockAddr -> LogMessage
ReceivedCliConnection SockAddr
peer
    IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (CliStates -> Socket -> IO ()
talk CliStates
states Socket
conn) (\Either SomeException ()
_ -> Socket -> IO ()
close Socket
conn)

listRunningApps :: CliStates -> Socket -> IO ()
listRunningApps :: CliStates -> Socket -> IO ()
listRunningApps CliStates
states Socket
conn = do
  Text
txt <- STM Text -> IO Text
forall a. STM a -> IO a
atomically (STM Text -> IO Text) -> STM Text -> IO Text
forall a b. (a -> b) -> a -> b
$ AppManager -> STM Text
renderApps (AppManager -> STM Text) -> AppManager -> STM Text
forall a b. (a -> b) -> a -> b
$ CliStates -> AppManager
csAppManager CliStates
states
  Socket -> ByteString -> IO ()
sendAll Socket
conn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
txt ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n"

talk :: CliStates -> Socket -> IO ()
talk :: CliStates -> Socket -> IO ()
talk CliStates
states Socket
conn = do
    ByteString
msg <- Socket -> Port -> IO ByteString
recv Socket
conn Port
1024
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
msg) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      case ByteString -> Either UnicodeException Text
T.decodeUtf8' ByteString
msg of
        Left UnicodeException
exception -> Socket -> ByteString -> IO ()
sendAll Socket
conn (ByteString
"decode error: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
T.encodeUtf8 (ServiceName -> Text
T.pack (ServiceName -> Text) -> ServiceName -> Text
forall a b. (a -> b) -> a -> b
$ UnicodeException -> ServiceName
forall a. Show a => a -> ServiceName
show UnicodeException
exception))
        Right Text
txt -> do
          let res :: ParserResult Commands
res = ParserPrefs
-> ParserInfo Commands -> [ServiceName] -> ParserResult Commands
forall a.
ParserPrefs -> ParserInfo a -> [ServiceName] -> ParserResult a
execParserPure ParserPrefs
defaultPrefs (Parser Commands -> InfoMod Commands -> ParserInfo Commands
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser Commands
commandParser Parser Commands -> Parser (Commands -> Commands) -> Parser Commands
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (Commands -> Commands)
forall a. Parser (a -> a)
helper)
                                                (InfoMod Commands
forall a. InfoMod a
fullDesc InfoMod Commands -> InfoMod Commands -> InfoMod Commands
forall a. Semigroup a => a -> a -> a
<> ServiceName -> InfoMod Commands
forall a. ServiceName -> InfoMod a
header ServiceName
"server repl" InfoMod Commands -> InfoMod Commands -> InfoMod Commands
forall a. Semigroup a => a -> a -> a
<> ServiceName -> InfoMod Commands
forall a. ServiceName -> InfoMod a
progDesc (
                        ServiceName
"repl for inspecting program state. You can connect to a socket and ask predefined questions")) ) (Text -> ServiceName
T.unpack (Text -> ServiceName) -> [Text] -> [ServiceName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> [Text]
T.words Text
txt)
          Bool
isLoop <- case ParserResult Commands
res of
            (Success (Commands
CmdListRunningApps)) -> Bool
True Bool -> IO () -> IO Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ CliStates -> Socket -> IO ()
listRunningApps CliStates
states Socket
conn
            (Success (Commands
CmdExit   )) -> Bool
False Bool -> IO () -> IO Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Socket -> ByteString -> IO ()
sendAll Socket
conn ByteString
"bye\n"
            (CompletionInvoked CompletionResult
x) -> Bool
True Bool -> IO () -> IO Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Socket -> ByteString -> IO ()
sendAll Socket
conn ByteString
"completion ignored \n"
            Failure ParserFailure ParserHelp
failure        ->
              Bool
True Bool -> IO () -> IO Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Socket -> ByteString -> IO ()
sendAll Socket
conn (Text -> ByteString
T.encodeUtf8 (ServiceName -> Text
T.pack (ServiceName -> Text) -> ServiceName -> Text
forall a b. (a -> b) -> a -> b
$ (ServiceName, ExitCode) -> ServiceName
forall a b. (a, b) -> a
fst ((ServiceName, ExitCode) -> ServiceName)
-> (ServiceName, ExitCode) -> ServiceName
forall a b. (a -> b) -> a -> b
$ ParserFailure ParserHelp -> ServiceName -> (ServiceName, ExitCode)
renderFailure ParserFailure ParserHelp
failure ServiceName
"") ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n")
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isLoop (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CliStates -> Socket -> IO ()
talk CliStates
states Socket
conn