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

import Keter.Common
import Keter.Context
import Keter.AppManager
import Control.Concurrent (forkFinally)
import qualified Control.Exception as E
import Control.Monad (unless, forever, void, when)
import Control.Monad.IO.Class    (MonadIO, liftIO)
import Control.Monad.IO.Unlift   (withRunInIO)
import Control.Monad.Trans.Class (MonadTrans, lift)
import Control.Monad.Logger
import Control.Monad.Reader      (ask)
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 -> Port
csPort       :: !Port
  }

launchCli :: KeterM CliStates ()
launchCli :: KeterM CliStates ()
launchCli = do
  MkCliStates{Port
AppManager
csPort :: Port
csAppManager :: AppManager
csPort :: CliStates -> Port
csAppManager :: CliStates -> AppManager
..} <- KeterM CliStates CliStates
forall r (m :: * -> *). MonadReader r m => m r
ask
  KeterM CliStates ThreadId -> KeterM CliStates ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (KeterM CliStates ThreadId -> KeterM CliStates ())
-> KeterM CliStates ThreadId -> KeterM CliStates ()
forall a b. (a -> b) -> a -> b
$ ((forall a. KeterM CliStates a -> IO a) -> IO ThreadId)
-> KeterM CliStates ThreadId
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM CliStates a -> IO a) -> IO ThreadId)
 -> KeterM CliStates ThreadId)
-> ((forall a. KeterM CliStates a -> IO a) -> IO ThreadId)
-> KeterM CliStates ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM CliStates a -> IO a
rio -> 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 <- String -> IO AddrInfo
resolve (String -> IO AddrInfo) -> String -> IO AddrInfo
forall a b. (a -> b) -> a -> b
$ Port -> String
forall a. Show a => a -> String
show Port
csPort
        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 -> KeterM CliStates () -> IO ()
forall a. KeterM CliStates a -> IO a
rio (KeterM CliStates () -> IO ()) -> KeterM CliStates () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            $Port
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM CliStates ()
(Text -> KeterM CliStates ())
-> (Text -> Text) -> Text -> KeterM CliStates ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo (Text -> KeterM CliStates ()) -> Text -> KeterM CliStates ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Bound cli to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> AddrInfo -> String
forall a. Show a => a -> String
show AddrInfo
addr
            Socket -> KeterM CliStates ()
forall b. Socket -> KeterM CliStates b
loop 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 [
  String -> ParserInfo Commands -> Mod CommandFields Commands
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"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)
      (String -> InfoMod Commands
forall a. String -> InfoMod a
progDesc String
"List all ports"))
  ,
  String -> ParserInfo Commands -> Mod CommandFields Commands
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"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)
        (String -> InfoMod Commands
forall a. String -> InfoMod a
progDesc String
"Exit the program"))
  ]

resolve :: ServiceName -> IO AddrInfo
resolve :: String -> IO AddrInfo
resolve String
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 String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) Maybe String
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
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 :: Socket -> KeterM CliStates b
loop :: forall b. Socket -> KeterM CliStates b
loop Socket
sock = KeterM CliStates () -> KeterM CliStates b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (KeterM CliStates () -> KeterM CliStates b)
-> KeterM CliStates () -> KeterM CliStates b
forall a b. (a -> b) -> a -> b
$ do
    (Socket
conn, SockAddr
peer) <- IO (Socket, SockAddr) -> KeterM CliStates (Socket, SockAddr)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Socket, SockAddr) -> KeterM CliStates (Socket, SockAddr))
-> IO (Socket, SockAddr) -> KeterM CliStates (Socket, SockAddr)
forall a b. (a -> b) -> a -> b
$ Socket -> IO (Socket, SockAddr)
accept Socket
sock
    $Port
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> KeterM CliStates ()
(Text -> KeterM CliStates ())
-> (Text -> Text) -> Text -> KeterM CliStates ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo (Text -> KeterM CliStates ()) -> Text -> KeterM CliStates ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"CLI Connection from " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SockAddr -> String
forall a. Show a => a -> String
show SockAddr
peer
    KeterM CliStates ThreadId -> KeterM CliStates ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (KeterM CliStates ThreadId -> KeterM CliStates ())
-> KeterM CliStates ThreadId -> KeterM CliStates ()
forall a b. (a -> b) -> a -> b
$ ((forall a. KeterM CliStates a -> IO a) -> IO ThreadId)
-> KeterM CliStates ThreadId
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. KeterM CliStates a -> IO a) -> IO ThreadId)
 -> KeterM CliStates ThreadId)
-> ((forall a. KeterM CliStates a -> IO a) -> IO ThreadId)
-> KeterM CliStates ThreadId
forall a b. (a -> b) -> a -> b
$ \forall a. KeterM CliStates a -> IO a
rio -> 
        IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (KeterM CliStates () -> IO ()
forall a. KeterM CliStates a -> IO a
rio (KeterM CliStates () -> IO ()) -> KeterM CliStates () -> IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> KeterM CliStates ()
talk Socket
conn) (\Either SomeException ()
_ -> Socket -> IO ()
close Socket
conn)

listRunningApps :: Socket -> KeterM CliStates ()
listRunningApps :: Socket -> KeterM CliStates ()
listRunningApps Socket
conn = do
  MkCliStates{Port
AppManager
csPort :: Port
csAppManager :: AppManager
csPort :: CliStates -> Port
csAppManager :: CliStates -> AppManager
..} <- KeterM CliStates CliStates
forall r (m :: * -> *). MonadReader r m => m r
ask
  Text
txt <- IO Text -> KeterM CliStates Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> KeterM CliStates Text)
-> IO Text -> KeterM CliStates Text
forall a b. (a -> b) -> a -> b
$ 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
csAppManager 
  IO () -> KeterM CliStates ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM CliStates ()) -> IO () -> KeterM CliStates ()
forall a b. (a -> b) -> a -> b
$ 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 :: Socket -> KeterM CliStates ()
talk :: Socket -> KeterM CliStates ()
talk Socket
conn = do
    ByteString
msg <- IO ByteString -> KeterM CliStates ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> KeterM CliStates ByteString)
-> IO ByteString -> KeterM CliStates ByteString
forall a b. (a -> b) -> a -> b
$ Socket -> Port -> IO ByteString
recv Socket
conn Port
1024
    Bool -> KeterM CliStates () -> KeterM CliStates ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
msg) (KeterM CliStates () -> KeterM CliStates ())
-> KeterM CliStates () -> KeterM CliStates ()
forall a b. (a -> b) -> a -> b
$ do
      case ByteString -> Either UnicodeException Text
T.decodeUtf8' ByteString
msg of
        Left UnicodeException
exception -> IO () -> KeterM CliStates ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> KeterM CliStates ()) -> IO () -> KeterM CliStates ()
forall a b. (a -> b) -> a -> b
$ Socket -> ByteString -> IO ()
sendAll Socket
conn (ByteString
"decode error: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
T.encodeUtf8 (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
exception))
        Right Text
txt -> do
          let res :: ParserResult Commands
res = ParserPrefs
-> ParserInfo Commands -> [String] -> ParserResult Commands
forall a. ParserPrefs -> ParserInfo a -> [String] -> 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
<> String -> InfoMod Commands
forall a. String -> InfoMod a
header String
"server repl" InfoMod Commands -> InfoMod Commands -> InfoMod Commands
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod Commands
forall a. String -> InfoMod a
progDesc (
                        String
"repl for inspecting program state. You can connect to a socket and ask predefined questions")) ) (Text -> String
T.unpack (Text -> String) -> [Text] -> [String]
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 -> KeterM CliStates () -> KeterM CliStates Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Socket -> KeterM CliStates ()
listRunningApps Socket
conn
            (Success (Commands
CmdExit   )) -> Bool
False Bool -> KeterM CliStates () -> KeterM CliStates Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IO () -> KeterM CliStates ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Socket -> ByteString -> IO ()
sendAll Socket
conn ByteString
"bye\n")
            (CompletionInvoked CompletionResult
x) -> Bool
True Bool -> KeterM CliStates () -> KeterM CliStates Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IO () -> KeterM CliStates ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Socket -> ByteString -> IO ()
sendAll Socket
conn ByteString
"completion ignored \n")
            Failure ParserFailure ParserHelp
failure        ->
              Bool
True Bool -> KeterM CliStates () -> KeterM CliStates Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IO () -> KeterM CliStates ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Socket -> ByteString -> IO ()
sendAll Socket
conn (Text -> ByteString
T.encodeUtf8 (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ (String, ExitCode) -> String
forall a b. (a, b) -> a
fst ((String, ExitCode) -> String) -> (String, ExitCode) -> String
forall a b. (a -> b) -> a -> b
$ ParserFailure ParserHelp -> String -> (String, ExitCode)
renderFailure ParserFailure ParserHelp
failure String
"") ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n"))
          Bool -> KeterM CliStates () -> KeterM CliStates ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isLoop (KeterM CliStates () -> KeterM CliStates ())
-> KeterM CliStates () -> KeterM CliStates ()
forall a b. (a -> b) -> a -> b
$ Socket -> KeterM CliStates ()
talk Socket
conn