{-# LANGUAGE OverloadedStrings, CPP, LambdaCase, TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module HsDev.Server.Commands (
	ServerCommand(..), ServerOpts(..), ClientOpts(..),
	Request(..),
	Msg, isLisp, msg, jsonMsg, lispMsg, encodeMessage, decodeMessage,
	sendCommand, runServerCommand,
	findPath,
	processRequest, processClient, processClientSocket,
	module HsDev.Server.Types
	) where

import Control.Concurrent.Async
import Control.Lens (set, view)
import Control.Monad
import Control.Monad.Catch (bracket, bracket_)
import Data.Aeson hiding (Result, Error)
import qualified Data.Aeson as A
import Data.Aeson.Encode.Pretty
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Maybe
import Network.Socket hiding (connect)
import System.Directory
import System.Exit
import System.IO
import qualified System.Log.Simple as Log

import GHC (getSessionDynFlags)

import Text.Format ((~~), (~%))
import Text.Format.Colored (coloredLine)

import HsDev.Server.Base
import HsDev.Server.Types
import HsDev.Error
import HsDev.Util
import HsDev.Version
import HsDev.PackageDb.Types (globalDb)
import HsDev.Tools.Ghc.Worker
import qualified HsDev.Tools.Ghc.System as System

#if mingw32_HOST_OS
import Data.List
import HsDev.Tools.Base (runTool_)
import System.Environment
import System.Win32.PowerShell (escape, quote, quoteDouble)
#else
import Control.Exception (SomeException, handle)
import System.Posix.Process
import System.Posix.IO
#endif

sendCommand :: ClientOpts -> Bool -> Command -> (Notification -> IO a) -> IO Result
sendCommand :: ClientOpts
-> Bool -> Command -> (Notification -> IO a) -> IO Result
sendCommand ClientOpts
copts Bool
noFile Command
c Notification -> IO a
onNotification = do
	Async Result
asyncAct <- IO Result -> IO (Async Result)
forall a. IO a -> IO (Async a)
async IO Result
sendReceive
	Either SomeException Result
res <- Async Result -> IO (Either SomeException Result)
forall a. Async a -> IO (Either SomeException a)
waitCatch Async Result
asyncAct
	case Either SomeException Result
res of
		Left SomeException
e -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ HsDevError -> Result
Error (HsDevError -> Result) -> HsDevError -> Result
forall a b. (a -> b) -> a -> b
$ String -> HsDevError
OtherError (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
		Right Result
r -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
	where
		sendReceive :: IO Result
sendReceive = do
			String
curDir <- IO String
getCurrentDirectory
			Maybe ByteString
input <- if ClientOpts -> Bool
clientStdin ClientOpts
copts
				then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString
L.getContents
				else Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ String -> ByteString
toUtf8 (String -> ByteString) -> Maybe String -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
forall a. Maybe a
Nothing -- arg "data" copts
			let
				parseData :: L.ByteString -> IO Value
				parseData :: ByteString -> IO Value
parseData ByteString
cts = case ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
cts of
					Left String
err -> String -> IO ()
putStrLn (String
"Invalid data: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err) IO () -> IO Value -> IO Value
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Value
forall a. IO a
exitFailure
					Right Value
v -> Value -> IO Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
			Maybe Value
_ <- (ByteString -> IO Value) -> Maybe ByteString -> IO (Maybe Value)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ByteString -> IO Value
parseData Maybe ByteString
input -- FIXME: Not used!

			Socket
s <- ConnectionPort -> IO Socket
makeSocket (ClientOpts -> ConnectionPort
clientPort ClientOpts
copts)
			Socket -> String -> ConnectionPort -> IO ()
connectSocket Socket
s String
"127.0.0.1" (ClientOpts -> ConnectionPort
clientPort ClientOpts
copts)
			IO Handle
-> (Handle -> IO ()) -> (Handle -> IO Result) -> IO Result
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (Socket -> IOMode -> IO Handle
socketToHandle Socket
s IOMode
ReadWriteMode) Handle -> IO ()
hClose ((Handle -> IO Result) -> IO Result)
-> (Handle -> IO Result) -> IO Result
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
				Handle -> ByteString -> IO ()
L.hPutStrLn Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Message Request -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Message Request -> ByteString) -> Message Request -> ByteString
forall a b. (a -> b) -> a -> b
$ Maybe String -> Request -> Message Request
forall a1. Maybe String -> a1 -> Message a1
Message Maybe String
forall a. Maybe a
Nothing (Request -> Message Request) -> Request -> Message Request
forall a b. (a -> b) -> a -> b
$ Command -> String -> Bool -> Int -> Bool -> Request
Request Command
c String
curDir Bool
noFile (ClientOpts -> Int
clientTimeout ClientOpts
copts) (ClientOpts -> Bool
clientSilent ClientOpts
copts)
				Handle -> IO ()
hFlush Handle
h
				Handle -> IO Result
peekResponse Handle
h

		peekResponse :: Handle -> IO Result
peekResponse Handle
h = do
			ByteString
resp <- Handle -> IO ByteString
hGetLineBS Handle
h
			Handle -> ByteString -> IO Result
parseResponse Handle
h ByteString
resp

		parseResponse :: Handle -> ByteString -> IO Result
parseResponse Handle
h ByteString
str = case ByteString -> Either String (Message Response)
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
str of
			Left String
e -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ HsDevError -> Result
Error (HsDevError -> Result) -> HsDevError -> Result
forall a b. (a -> b) -> a -> b
$ String -> String -> HsDevError
ResponseError (Format
"can't parse: {}" Format -> String -> String
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ String
e) (ByteString -> String
fromUtf8 ByteString
str)
			Right (Message Maybe String
_ Response
r) -> do
				Response Either Notification Result
r' <- Response -> IO Response
unMmap Response
r
				case Either Notification Result
r' of
					Left Notification
n -> Notification -> IO a
onNotification Notification
n IO a -> IO Result -> IO Result
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO Result
peekResponse Handle
h
					Right Result
res -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
res

runServerCommand :: ServerCommand -> IO ()
runServerCommand :: ServerCommand -> IO ()
runServerCommand (Version Bool
showCompiler)
	| Bool
showCompiler = do
		GhcWorker
w <- LogT IO GhcWorker -> IO GhcWorker
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => LogT m a -> m a
Log.noLog LogT IO GhcWorker
forall (m :: * -> *). MonadLog m => m GhcWorker
ghcWorker
		String
compVer <- GhcWorker
-> MGhcT SessionConfig (First DynFlags) (LogT IO) String
-> IO String
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
Worker m -> m a -> IO a
inWorker GhcWorker
w (MGhcT SessionConfig (First DynFlags) (LogT IO) String
 -> IO String)
-> MGhcT SessionConfig (First DynFlags) (LogT IO) String
-> IO String
forall a b. (a -> b) -> a -> b
$ do
			SessionType -> PackageDbStack -> [String] -> GhcM ()
workerSession SessionType
SessionGhc PackageDbStack
globalDb []
			DynFlags
df <- MGhcT SessionConfig (First DynFlags) (LogT IO) DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
			String -> MGhcT SessionConfig (First DynFlags) (LogT IO) String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> MGhcT SessionConfig (First DynFlags) (LogT IO) String)
-> String -> MGhcT SessionConfig (First DynFlags) (LogT IO) String
forall a b. (a -> b) -> a -> b
$ String -> BuildInfo -> String
System.formatBuildPath String
"{compiler}-{version}" (DynFlags -> BuildInfo
System.buildInfo DynFlags
df)
		String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
$cabalVersion String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
compVer
		GhcWorker -> IO ()
forall (m :: * -> *). Worker m -> IO ()
joinWorker GhcWorker
w
	| Bool
otherwise = String -> IO ()
putStrLn String
$cabalVersion
runServerCommand (Start ServerOpts
sopts) = do
#if mingw32_HOST_OS
	let
		args = "run" : serverOptsArgs sopts
	myExe <- getExecutablePath
	curDir <- getCurrentDirectory
	let
		-- one escape for start-process and other for callable process
		-- seems, that start-process just concats arguments into one string
		-- start-process foo 'bar baz' ⇒ foo bar baz -- not expected
		-- start-process foo '"bar baz"' ⇒ foo "bar baz" -- ok
		biescape = escape quote . escape quoteDouble
		script = "try {{ start-process {process} {args} -WindowStyle Hidden -WorkingDirectory {dir} }} catch {{ $_.Exception, $_.InvocationInfo.Line }}"
			~~ ("process" ~% escape quote myExe)
			~~ ("args" ~% intercalate ", " (map biescape args))
			~~ ("dir" ~% escape quote curDir)
	_ <- runTool_ "powershell" [
		"-NoProfile",
		"-Command",
		script]
	putStrLn $ "Server started at port {}" ~~ serverPort sopts
#else
	let
		forkError :: SomeException -> IO ()
		forkError :: SomeException -> IO ()
forkError SomeException
e  = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Format
"Failed to start server: {}" Format -> String -> String
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ SomeException -> String
forall a. Show a => a -> String
show SomeException
e

		proxy :: IO ()
		proxy :: IO ()
proxy = do
			ProcessGroupID
_ <- IO ProcessGroupID
createSession
			ProcessGroupID
_ <- IO () -> IO ProcessGroupID
forkProcess IO ()
serverAction
			ExitCode -> IO ()
exitImmediately ExitCode
ExitSuccess

		serverAction :: IO ()
		serverAction :: IO ()
serverAction = do
			(Fd -> IO ()) -> [Fd] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Fd -> IO ()
closeFd [Fd
stdInput, Fd
stdOutput, Fd
stdError]
			Fd
nullFd <- String -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd String
"/dev/null" OpenMode
ReadWrite Maybe FileMode
forall a. Maybe a
Nothing OpenFileFlags
defaultFileFlags
			(Fd -> IO Fd) -> [Fd] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Fd -> Fd -> IO Fd
dupTo Fd
nullFd) [Fd
stdInput, Fd
stdOutput, Fd
stdError]
			Fd -> IO ()
closeFd Fd
nullFd
			ServerCommand -> IO ()
runServerCommand (ServerOpts -> ServerCommand
Run ServerOpts
sopts)

	(SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO ()
forkError (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
		ProcessGroupID
_ <- IO () -> IO ProcessGroupID
forkProcess IO ()
proxy
		String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Format
"Server started at port {}" Format -> ConnectionPort -> String
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ ServerOpts -> ConnectionPort
serverPort ServerOpts
sopts
#endif
runServerCommand (Run ServerOpts
sopts) = ServerOpts -> ServerM IO () -> IO ()
runServer ServerOpts
sopts (ServerM IO () -> IO ()) -> ServerM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerM IO () -> ServerM IO () -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
bracket_ (ServerOpts -> ServerM IO ()
setupServer ServerOpts
sopts) (ServerOpts -> ServerM IO ()
shutdownServer ServerOpts
sopts) (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ () -> ServerM IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runServerCommand (Stop ClientOpts
copts) = ServerCommand -> IO ()
runServerCommand (ClientOpts -> Bool -> Command -> ServerCommand
Remote ClientOpts
copts Bool
False Command
Exit)
runServerCommand (Connect ClientOpts
copts) = do
	String
curDir <- IO String
getCurrentDirectory
	Socket
s <- ConnectionPort -> IO Socket
makeSocket (ConnectionPort -> IO Socket) -> ConnectionPort -> IO Socket
forall a b. (a -> b) -> a -> b
$ ClientOpts -> ConnectionPort
clientPort ClientOpts
copts
	Socket -> String -> ConnectionPort -> IO ()
connectSocket Socket
s String
"127.0.0.1" (ClientOpts -> ConnectionPort
clientPort ClientOpts
copts)
	IO Handle -> (Handle -> IO ()) -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (Socket -> IOMode -> IO Handle
socketToHandle Socket
s IOMode
ReadWriteMode) Handle -> IO ()
hClose ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> [Integer] -> (Integer -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Integer
1 :: Integer)..] ((Integer -> IO ()) -> IO ()) -> (Integer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Integer
i -> IO () -> IO ()
forall (m :: * -> *). MonadCatch m => m () -> m ()
ignoreIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
		ByteString
input' <- Handle -> IO ByteString
hGetLineBS Handle
stdin
		case ByteString -> Either (Msg String) (Msg Command)
forall a. FromJSON a => ByteString -> Either (Msg String) (Msg a)
decodeMsg ByteString
input' of
			Left Msg String
em -> ByteString -> IO ()
L.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Msg (Message Response) -> ByteString
forall a. ToJSON a => Msg (Message a) -> ByteString
encodeMessage (Msg (Message Response) -> ByteString)
-> Msg (Message Response) -> ByteString
forall a b. (a -> b) -> a -> b
$ ASetter
  (Msg String) (Msg (Message Response)) String (Message Response)
-> Message Response -> Msg String -> Msg (Message Response)
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (Msg String) (Msg (Message Response)) String (Message Response)
forall a b. Lens (Msg a) (Msg b) a b
msg (Maybe String -> Response -> Message Response
forall a1. Maybe String -> a1 -> Message a1
Message Maybe String
forall a. Maybe a
Nothing (Response -> Message Response) -> Response -> Message Response
forall a b. (a -> b) -> a -> b
$ HsDevError -> Response
responseError (HsDevError -> Response) -> HsDevError -> Response
forall a b. (a -> b) -> a -> b
$ String -> HsDevError
OtherError String
"invalid command") Msg String
em
			Right Msg Command
m -> do
				Handle -> ByteString -> IO ()
L.hPutStrLn Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Msg (Message Request) -> ByteString
forall a. ToJSON a => Msg (Message a) -> ByteString
encodeMessage (Msg (Message Request) -> ByteString)
-> Msg (Message Request) -> ByteString
forall a b. (a -> b) -> a -> b
$ ASetter
  (Msg Command) (Msg (Message Request)) Command (Message Request)
-> Message Request -> Msg Command -> Msg (Message Request)
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (Msg Command) (Msg (Message Request)) Command (Message Request)
forall a b. Lens (Msg a) (Msg b) a b
msg (Maybe String -> Request -> Message Request
forall a1. Maybe String -> a1 -> Message a1
Message (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
i) (Request -> Message Request) -> Request -> Message Request
forall a b. (a -> b) -> a -> b
$ Command -> String -> Bool -> Int -> Bool -> Request
Request (Getting Command (Msg Command) Command -> Msg Command -> Command
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Command (Msg Command) Command
forall a b. Lens (Msg a) (Msg b) a b
msg Msg Command
m) String
curDir Bool
True (ClientOpts -> Int
clientTimeout ClientOpts
copts) Bool
False) Msg Command
m
				Handle -> IO ()
waitResp Handle
h
	where
		waitResp :: Handle -> IO ()
waitResp Handle
h = do
			ByteString
resp <- Handle -> IO ByteString
hGetLineBS Handle
h
			Handle -> ByteString -> IO ()
parseResp Handle
h ByteString
resp

		parseResp :: Handle -> ByteString -> IO ()
parseResp Handle
h ByteString
str = case ByteString -> Either (Msg String) (Msg (Message Response))
forall a.
FromJSON a =>
ByteString -> Either (Msg String) (Msg (Message a))
decodeMessage ByteString
str of
			Left Msg String
em -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Format
"Can't decode response: {}" Format -> String -> String
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Getting String (Msg String) String -> Msg String -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String (Msg String) String
forall a b. Lens (Msg a) (Msg b) a b
msg Msg String
em
			Right Msg (Message Response)
m -> do
				Response Either Notification Result
r' <- Response -> IO Response
unMmap (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ Getting Response (Msg (Message Response)) Response
-> Msg (Message Response) -> Response
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Message Response -> Const Response (Message Response))
-> Msg (Message Response)
-> Const Response (Msg (Message Response))
forall a b. Lens (Msg a) (Msg b) a b
msg ((Message Response -> Const Response (Message Response))
 -> Msg (Message Response)
 -> Const Response (Msg (Message Response)))
-> ((Response -> Const Response Response)
    -> Message Response -> Const Response (Message Response))
-> Getting Response (Msg (Message Response)) Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Response -> Const Response Response)
-> Message Response -> Const Response (Message Response)
forall a1 a2. Lens (Message a1) (Message a2) a1 a2
message) Msg (Message Response)
m
				String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Format
"{id}: {response}"
					Format -> FormatArg -> Format
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ (String
"id" String -> String -> FormatArg
forall a. Formattable a => String -> a -> FormatArg
~% String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"_" (Getting (Maybe String) (Msg (Message Response)) (Maybe String)
-> Msg (Message Response) -> Maybe String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Message Response -> Const (Maybe String) (Message Response))
-> Msg (Message Response)
-> Const (Maybe String) (Msg (Message Response))
forall a b. Lens (Msg a) (Msg b) a b
msg ((Message Response -> Const (Maybe String) (Message Response))
 -> Msg (Message Response)
 -> Const (Maybe String) (Msg (Message Response)))
-> ((Maybe String -> Const (Maybe String) (Maybe String))
    -> Message Response -> Const (Maybe String) (Message Response))
-> Getting (Maybe String) (Msg (Message Response)) (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String -> Const (Maybe String) (Maybe String))
-> Message Response -> Const (Maybe String) (Message Response)
forall a1. Lens' (Message a1) (Maybe String)
messageId) Msg (Message Response)
m))
					Format -> FormatArg -> String
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ (String
"response" String -> String -> FormatArg
forall a. Formattable a => String -> a -> FormatArg
~% ByteString -> String
fromUtf8 (Msg Response -> ByteString
forall a. ToJSON a => Msg a -> ByteString
encodeMsg (Msg Response -> ByteString) -> Msg Response -> ByteString
forall a b. (a -> b) -> a -> b
$ ASetter
  (Msg (Message Response)) (Msg Response) (Message Response) Response
-> Response -> Msg (Message Response) -> Msg Response
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (Msg (Message Response)) (Msg Response) (Message Response) Response
forall a b. Lens (Msg a) (Msg b) a b
msg (Either Notification Result -> Response
Response Either Notification Result
r') Msg (Message Response)
m))
				case Response -> Either Notification Result
unResponse (Getting Response (Msg (Message Response)) Response
-> Msg (Message Response) -> Response
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Message Response -> Const Response (Message Response))
-> Msg (Message Response)
-> Const Response (Msg (Message Response))
forall a b. Lens (Msg a) (Msg b) a b
msg ((Message Response -> Const Response (Message Response))
 -> Msg (Message Response)
 -> Const Response (Msg (Message Response)))
-> ((Response -> Const Response Response)
    -> Message Response -> Const Response (Message Response))
-> Getting Response (Msg (Message Response)) Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Response -> Const Response Response)
-> Message Response -> Const Response (Message Response)
forall a1 a2. Lens (Message a1) (Message a2) a1 a2
message) Msg (Message Response)
m) of
					Left Notification
_ -> Handle -> IO ()
waitResp Handle
h
					Either Notification Result
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runServerCommand (Remote ClientOpts
copts Bool
noFile c :: Command
c@(Listen Maybe String
_)) = ClientOpts
-> Bool -> Command -> (Notification -> IO ()) -> IO Result
forall a.
ClientOpts
-> Bool -> Command -> (Notification -> IO a) -> IO Result
sendCommand ClientOpts
copts Bool
noFile Command
c Notification -> IO ()
printLog IO Result -> (Result -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Result -> IO ()
noResult where
	printLog :: Notification -> IO ()
	printLog :: Notification -> IO ()
printLog (Notification Value
v) = case Value -> Result Message
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
		A.Error String
_ -> String -> IO ()
putStrLn String
"incorrect notification"
		A.Success Message
m -> Formatted -> IO ()
coloredLine (Formatted -> IO ()) -> (Message -> Formatted) -> Message -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Formatted
forall r. FormatResult r => Converter r
Log.text (Message -> IO ()) -> Message -> IO ()
forall a b. (a -> b) -> a -> b
$ Message
m
	noResult :: Result -> IO ()
	noResult :: Result -> IO ()
noResult Result
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runServerCommand (Remote ClientOpts
copts Bool
noFile Command
c) = ClientOpts
-> Bool -> Command -> (Notification -> IO ()) -> IO Result
forall a.
ClientOpts
-> Bool -> Command -> (Notification -> IO a) -> IO Result
sendCommand ClientOpts
copts Bool
noFile Command
c Notification -> IO ()
forall a. ToJSON a => a -> IO ()
printValue IO Result -> (Result -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Result -> IO ()
printResult where
	printValue :: ToJSON a => a -> IO ()
	printValue :: a -> IO ()
printValue = ByteString -> IO ()
L.putStrLn (ByteString -> IO ()) -> (a -> ByteString) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
encodeValue
	printResult :: Result -> IO ()
	printResult :: Result -> IO ()
printResult (Result Value
r) = Value -> IO ()
forall a. ToJSON a => a -> IO ()
printValue Value
r
	printResult Result
e = Result -> IO ()
forall a. ToJSON a => a -> IO ()
printValue Result
e
	encodeValue :: ToJSON a => a -> L.ByteString
	encodeValue :: a -> ByteString
encodeValue = if ClientOpts -> Bool
clientPretty ClientOpts
copts then a -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty else a -> ByteString
forall a. ToJSON a => a -> ByteString
encode