{-# 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
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. KeterM CliStates a -> IO a
rio -> IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ 
    forall a. IO a -> IO a
withSocketsDo forall a b. (a -> b) -> a -> b
$ do
        AddrInfo
addr <- String -> IO AddrInfo
resolve forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Port
csPort
        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 forall a b. (a -> b) -> a -> b
$ \Socket
x -> forall a. KeterM CliStates a -> IO a
rio forall a b. (a -> b) -> a -> b
$ do
            $Port
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
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 forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"Bound cli to " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show AddrInfo
addr
            forall b. Socket -> KeterM CliStates b
loop Socket
x

commandParser :: Parser Commands
commandParser :: Parser Commands
commandParser = forall a. Mod CommandFields a -> Parser a
hsubparser forall a b. (a -> b) -> a -> b
$
  forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [
  forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"exit"
    (forall a. Parser a -> InfoMod a -> ParserInfo a
info (forall (f :: * -> *) a. Applicative f => a -> f a
pure Commands
CmdExit)
      (forall a. String -> InfoMod a
progDesc String
"List all ports"))
  ,
  forall a. String -> ParserInfo a -> Mod CommandFields a
command String
"apps"
      (forall a. Parser a -> InfoMod a -> ParserInfo a
info (forall (f :: * -> *) a. Applicative f => a -> f a
pure Commands
CmdListRunningApps)
        (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 (forall a. a -> Maybe a
Just AddrInfo
hints) forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just String
port)
        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.
    forall r. Socket -> (ProtocolNumber -> IO r) -> IO r
withFdSocket Socket
sock 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
    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 = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
    (Socket
conn, SockAddr
peer) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 -> 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 forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"CLI Connection from " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SockAddr
peer
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. KeterM CliStates a -> IO a
rio -> 
        forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (forall a. KeterM CliStates a -> IO a
rio 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
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
  Text
txt <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ AppManager -> STM Text
renderApps AppManager
csAppManager 
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Socket -> ByteString -> IO ()
sendAll Socket
conn forall a b. (a -> b) -> a -> b
$ Text -> ByteString
T.encodeUtf8 Text
txt forall a. Semigroup a => a -> a -> a
<> ByteString
"\n"

talk :: Socket -> KeterM CliStates ()
talk :: Socket -> KeterM CliStates ()
talk Socket
conn = do
    ByteString
msg <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Socket -> Port -> IO ByteString
recv Socket
conn Port
1024
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
msg) forall a b. (a -> b) -> a -> b
$ do
      case ByteString -> Either UnicodeException Text
T.decodeUtf8' ByteString
msg of
        Left UnicodeException
exception -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Socket -> ByteString -> IO ()
sendAll Socket
conn (ByteString
"decode error: " forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
T.encodeUtf8 (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show UnicodeException
exception))
        Right Text
txt -> do
          let res :: ParserResult Commands
res = forall a. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
execParserPure ParserPrefs
defaultPrefs (forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser Commands
commandParser forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> forall a. Parser (a -> a)
helper)
                                                (forall a. InfoMod a
fullDesc forall a. Semigroup a => a -> a -> a
<> forall a. String -> InfoMod a
header String
"server repl" forall a. Semigroup a => a -> a -> a
<> 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 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 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Socket -> KeterM CliStates ()
listRunningApps Socket
conn
            (Success (Commands
CmdExit   )) -> Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Socket -> ByteString -> IO ()
sendAll Socket
conn ByteString
"bye\n")
            (CompletionInvoked CompletionResult
x) -> Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ 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 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Socket -> ByteString -> IO ()
sendAll Socket
conn (Text -> ByteString
T.encodeUtf8 (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ ParserFailure ParserHelp -> String -> (String, ExitCode)
renderFailure ParserFailure ParserHelp
failure String
"") forall a. Semigroup a => a -> a -> a
<> ByteString
"\n"))
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isLoop forall a b. (a -> b) -> a -> b
$ Socket -> KeterM CliStates ()
talk Socket
conn