{-# LANGUAGE CPP, OverloadedStrings, CPP, PatternGuards, TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module HsDev.Server.Base (
	initLog, runServer, Server,
	setupServer, shutdownServer,
	startServer, startServer_, stopServer, withServer, withServer_, inServer, clientCommand, parseCommand, readCommand,
	sendServer, sendServer_,
	findPath,
	processRequest, processClient, processClientSocket,

	unMmap, makeSocket, bindSocket, connectSocket,

	module HsDev.Server.Types,
	module HsDev.Server.Message
	) where

import Control.Concurrent
import Control.Concurrent.Async
import qualified Control.Concurrent.Chan as C
import Control.Lens (set, traverseOf, view)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Loops
import Control.Monad.Reader
import Control.Monad.Catch (bracket_, bracket, finally)
import Data.Aeson hiding (Result, Error)
import Data.Default
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Maybe
import Data.String (fromString)
import qualified Data.Text as T (pack)
import Data.Time.Clock.POSIX
import Options.Applicative (info, progDesc)
import System.Log.Simple hiding (Level(..), Message)
import qualified System.Log.Simple.Base as Log (level_)
import qualified System.Log.Simple as Log
import qualified Network.HTTP.Client as HTTP
import Network.Socket hiding (bindSocket)
import qualified Network.Socket.ByteString.Lazy as Net (getContents, sendAll)
import System.FilePath
import System.IO
import Text.Format ((~~))

import Control.Concurrent.Util
import qualified Control.Concurrent.FiniteChan as F
import Data.LookupTable
import Data.Maybe.JustIf
import System.Directory.Paths
import qualified System.Directory.Watcher as Watcher

import qualified HsDev.Client.Commands as Client
import qualified HsDev.Database.SQLite as SQLite
import HsDev.Error
import qualified HsDev.Database.Update as Update
import HsDev.Inspect (getDefines)
import HsDev.Tools.Ghc.Worker hiding (Session)
import HsDev.Server.Types
import HsDev.Server.Message
import HsDev.Symbols.Location (ModuleLocation(..), globalDb)
import qualified HsDev.Watcher as W
import HsDev.Util

#if mingw32_HOST_OS
import Data.Aeson.Types hiding (Result, Error)
import System.Win32.FileMapping.Memory (withMapFile, readMapFile)
import System.Win32.FileMapping.NamePool
#else
import System.Posix.Files (removeLink)
#endif

-- | Inits log chan and returns functions (print message, wait channel)
initLog :: ServerOpts -> IO SessionLog
initLog :: ServerOpts -> IO SessionLog
initLog ServerOpts
sopts = do
	Chan Message
msgs <- IO (Chan Message)
forall a. IO (Chan a)
C.newChan
	Log
l <- LogConfig -> [LogHandler] -> IO Log
newLog ([(Component, Level)] -> LogConfig
logCfg [(Component
"", Text -> Level
Log.level_ (Text -> Level) -> (ServerOpts -> Text) -> ServerOpts -> Level
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (ServerOpts -> String) -> ServerOpts -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerOpts -> String
serverLogLevel (ServerOpts -> Level) -> ServerOpts -> Level
forall a b. (a -> b) -> a -> b
$ ServerOpts
sopts)]) ([LogHandler] -> IO Log) -> [LogHandler] -> IO Log
forall a b. (a -> b) -> a -> b
$ [[LogHandler]] -> [LogHandler]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
		[LogHandler
logHandler | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ServerOpts -> Bool
serverSilent ServerOpts
sopts],
		[Chan Message -> LogHandler
chaner Chan Message
msgs],
		[Converter Text -> Consumer Text -> LogHandler
forall a. Converter a -> Consumer a -> LogHandler
handler Converter Text
forall r. FormatResult r => Converter r
text (String -> Consumer Text
file String
f) | String
f <- Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList (ServerOpts -> Maybe String
serverLog ServerOpts
sopts)]]
	let
		listenLog :: IO [Message]
listenLog = Chan Message -> IO (Chan Message)
forall a. Chan a -> IO (Chan a)
C.dupChan Chan Message
msgs IO (Chan Message) -> (Chan Message -> IO [Message]) -> IO [Message]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Chan Message -> IO [Message]
forall a. Chan a -> IO [a]
C.getChanContents
	SessionLog -> IO SessionLog
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionLog -> IO SessionLog) -> SessionLog -> IO SessionLog
forall a b. (a -> b) -> a -> b
$ Log -> IO [Message] -> IO () -> SessionLog
SessionLog Log
l IO [Message]
listenLog (Log -> IO ()
forall (m :: * -> *). MonadIO m => Log -> m ()
stopLog Log
l)
	where
		logHandler :: LogHandler
logHandler
			| ServerOpts -> Bool
serverLogNoColor ServerOpts
sopts = Converter Text -> Consumer Text -> LogHandler
forall a. Converter a -> Consumer a -> LogHandler
handler Converter Text
forall r. FormatResult r => Converter r
text Consumer Text
console
			| Bool
otherwise = Converter Formatted -> Consumer Formatted -> LogHandler
forall a. Converter a -> Consumer a -> LogHandler
handler Converter Formatted
forall r. FormatResult r => Converter r
text Consumer Formatted
coloredConsole

-- | Run server
runServer :: ServerOpts -> ServerM IO () -> IO ()
runServer :: ServerOpts -> ServerM IO () -> IO ()
runServer ServerOpts
sopts ServerM IO ()
act = IO SessionLog
-> (SessionLog -> IO ()) -> (SessionLog -> IO ()) -> IO ()
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (ServerOpts -> IO SessionLog
initLog ServerOpts
sopts) SessionLog -> IO ()
sessionLogWait ((SessionLog -> IO ()) -> IO ()) -> (SessionLog -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SessionLog
slog -> (Maybe (Watcher Watched) -> IO ()) -> IO ()
forall a b. (Maybe (Watcher a) -> IO b) -> IO b
maybeWithWatcher ((Maybe (Watcher Watched) -> IO ()) -> IO ())
-> (Maybe (Watcher Watched) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe (Watcher Watched)
mwatcher -> Log -> LogT IO () -> IO ()
forall (m :: * -> *) a. Log -> LogT m a -> m a
withLog (SessionLog -> Log
sessionLogger SessionLog
slog) (LogT IO () -> IO ()) -> LogT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
	QSem
waitSem <- IO QSem -> LogT IO QSem
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO QSem -> LogT IO QSem) -> IO QSem -> LogT IO QSem
forall a b. (a -> b) -> a -> b
$ Int -> IO QSem
newQSem Int
0
	Connection
sqlDb <- IO Connection -> LogT IO Connection
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Connection -> LogT IO Connection)
-> IO Connection -> LogT IO Connection
forall a b. (a -> b) -> a -> b
$ String -> IO Connection
SQLite.initialize (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
SQLite.sharedMemory (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ ServerOpts -> Maybe String
serverDbFile ServerOpts
sopts)
	Chan (IO ())
clientChan <- IO (Chan (IO ())) -> LogT IO (Chan (IO ()))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Chan (IO ()))
forall a. IO (Chan a)
F.newChan
#if mingw32_HOST_OS
	mmapPool <- Just <$> liftIO (createPool "hsdev")
#endif
	GhcWorker
ghcw <- LogT IO GhcWorker
forall (m :: * -> *). MonadLog m => m GhcWorker
ghcWorker
	IO () -> LogT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LogT IO ()) -> IO () -> LogT IO ()
forall a b. (a -> b) -> a -> b
$ GhcWorker
-> MGhcT SessionConfig (First DynFlags) (LogT IO) () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
Worker m -> m a -> IO a
inWorker GhcWorker
ghcw (MGhcT SessionConfig (First DynFlags) (LogT IO) () -> IO ())
-> MGhcT SessionConfig (First DynFlags) (LogT IO) () -> IO ()
forall a b. (a -> b) -> a -> b
$ PackageDbStack
-> [String] -> MGhcT SessionConfig (First DynFlags) (LogT IO) ()
tmpSession PackageDbStack
globalDb []
	[(String, String)]
defs <- IO [(String, String)] -> LogT IO [(String, String)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getDefines

	Session
session <- IO Session -> LogT IO Session
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Session -> LogT IO Session) -> IO Session -> LogT IO Session
forall a b. (a -> b) -> a -> b
$ (Session -> IO Session) -> IO Session
forall a. (a -> IO a) -> IO a
fixIO ((Session -> IO Session) -> IO Session)
-> (Session -> IO Session) -> IO Session
forall a b. (a -> b) -> a -> b
$ \Session
sess -> do
		let
			setFileCts :: Text -> Maybe b -> IO ()
setFileCts Text
fpath Maybe b
Nothing = IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ()) -> IO (Async ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Session -> ServerM IO (Async ()) -> IO (Async ())
forall (m :: * -> *) a. Session -> ServerM m a -> m a
withSession Session
sess (ServerM IO (Async ()) -> IO (Async ()))
-> ServerM IO (Async ()) -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ ServerM IO () -> ServerM IO (Async ())
forall (m :: * -> *) a.
SessionMonad m =>
ServerM IO a -> m (Async a)
postSessionUpdater (ServerM IO () -> ServerM IO (Async ()))
-> ServerM IO () -> ServerM IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
				Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> ServerM IO ()) -> Text -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ Format
"dropping file contents for {}" Format -> Text -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Text
fpath
				Query -> Only Text -> ServerM IO ()
forall q (m :: * -> *).
(ToRow q, SessionMonad m) =>
Query -> q -> m ()
SQLite.execute Query
"delete from file_contents where file = ?;" (Text -> Only Text
forall a. a -> Only a
SQLite.Only Text
fpath)
			setFileCts Text
fpath (Just b
cts) = do
				POSIXTime
tm <- IO POSIXTime
getPOSIXTime
				Session -> ServerM IO () -> IO ()
forall (m :: * -> *) a. Session -> ServerM m a -> m a
withSession Session
sess (ServerM IO () -> IO ()) -> ServerM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
					[Only Bool]
notChanged <- Query -> (b, Text) -> ServerM IO [Only Bool]
forall q r (m :: * -> *).
(ToRow q, FromRow r, SessionMonad m) =>
Query -> q -> m [r]
SQLite.query @_ @(SQLite.Only Bool) Query
"select contents == ? from file_contents where file = ?;" (b
cts, Text
fpath)
					let
						notChanged' :: Bool
notChanged' = (Only Bool -> Bool) -> [Only Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Only Bool -> Bool
forall a. Only a -> a
SQLite.fromOnly [Only Bool]
notChanged
					ServerM IO (Async ()) -> ServerM IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ServerM IO (Async ()) -> ServerM IO ())
-> ServerM IO (Async ()) -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ ServerM IO () -> ServerM IO (Async ())
forall (m :: * -> *) a.
SessionMonad m =>
ServerM IO a -> m (Async a)
postSessionUpdater (ServerM IO () -> ServerM IO (Async ()))
-> ServerM IO () -> ServerM IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
						Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> ServerM IO ()) -> Text -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ Format
"setting file contents for {} with mtime = {}" Format -> Text -> Format
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ Text
fpath Format -> String -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ POSIXTime -> String
forall a. Show a => a -> String
show POSIXTime
tm
						Query -> (Text, b, Double) -> ServerM IO ()
forall q (m :: * -> *).
(ToRow q, SessionMonad m) =>
Query -> q -> m ()
SQLite.execute Query
"insert or replace into file_contents (file, contents, mtime) values (?, ?, ?);" (Text
fpath, b
cts, (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (POSIXTime -> Rational
forall a. Real a => a -> Rational
toRational POSIXTime
tm) :: Double))
						ServerM IO (Maybe (Watcher Watched))
-> (Watcher Watched -> ServerM IO ()) -> ServerM IO ()
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m b) -> m ()
whenJustM ((Session -> Maybe (Watcher Watched))
-> ServerM IO (Maybe (Watcher Watched))
forall (m :: * -> *) a. SessionMonad m => (Session -> a) -> m a
askSession Session -> Maybe (Watcher Watched)
sessionWatcher) ((Watcher Watched -> ServerM IO ()) -> ServerM IO ())
-> (Watcher Watched -> ServerM IO ()) -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ \Watcher Watched
watcher -> Bool -> ServerM IO () -> ServerM IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
notChanged' (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> ServerM IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerM IO ()) -> IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$
							Chan (Watched, Event) -> (Watched, Event) -> IO ()
forall a. Chan a -> a -> IO ()
writeChan (Watcher Watched -> Chan (Watched, Event)
forall a. Watcher a -> Chan (a, Event)
W.watcherChan Watcher Watched
watcher) (Watched
W.WatchedModule, EventType -> String -> POSIXTime -> Event
W.Event EventType
W.Modified (Getting String Text String -> Text -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String Text String
Lens' Text String
path Text
fpath) POSIXTime
tm)

		Worker (ServerM IO)
uw <- (ServerM IO () -> IO ())
-> (ServerM IO () -> ServerM IO ())
-> (ServerM IO () -> ServerM IO ())
-> IO (Worker (ServerM IO))
forall (m :: * -> *).
MonadIO m =>
(m () -> IO ())
-> (m () -> m ()) -> (m () -> m ()) -> IO (Worker m)
startWorker (Session -> ServerM IO () -> IO ()
forall (m :: * -> *) a. Session -> ServerM m a -> m a
withSession Session
sess (ServerM IO () -> IO ())
-> (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a. SessionMonad m => m a -> m a
withSqlConnection) ServerM IO () -> ServerM IO ()
forall a. a -> a
id ServerM IO () -> ServerM IO ()
forall (m :: * -> *). (MonadLog m, MonadCatch m) => m () -> m ()
logAll
		LookupTable (Maybe Text) (Environment, FixitiesTable)
resolveEnvTable <- IO (LookupTable (Maybe Text) (Environment, FixitiesTable))
forall k (m :: * -> *) v. (Ord k, MonadIO m) => m (LookupTable k v)
newLookupTable
		Manager
httpManager <- ManagerSettings -> IO Manager
HTTP.newManager ManagerSettings
HTTP.defaultManagerSettings

		Session -> IO Session
forall (m :: * -> *) a. Monad m => a -> m a
return (Session -> IO Session) -> Session -> IO Session
forall a b. (a -> b) -> a -> b
$ Connection
-> String
-> SessionLog
-> Maybe (Watcher Watched)
-> (Text -> Maybe Text -> IO ())
-> GhcWorker
-> Worker (ServerM IO)
-> LookupTable (Maybe Text) (Environment, FixitiesTable)
-> Manager
-> IO ()
-> IO ()
-> Chan (IO ())
-> [(String, String)]
-> Session
Session
			Connection
sqlDb
			(String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
SQLite.sharedMemory (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ ServerOpts -> Maybe String
serverDbFile ServerOpts
sopts)
			SessionLog
slog
			Maybe (Watcher Watched)
mwatcher
			Text -> Maybe Text -> IO ()
forall b. ToField b => Text -> Maybe b -> IO ()
setFileCts
#if mingw32_HOST_OS
			mmapPool
#endif
			GhcWorker
ghcw
			Worker (ServerM IO)
uw
			LookupTable (Maybe Text) (Environment, FixitiesTable)
resolveEnvTable
			Manager
httpManager
			(do
				Log -> LogT IO () -> IO ()
forall (m :: * -> *) a. Log -> LogT m a -> m a
withLog (SessionLog -> Log
sessionLogger SessionLog
slog) (LogT IO () -> IO ()) -> LogT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Level -> Text -> LogT IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace Text
"stopping server"
				QSem -> IO ()
signalQSem QSem
waitSem)
			(QSem -> IO ()
waitQSem QSem
waitSem)
			Chan (IO ())
clientChan
			[(String, String)]
defs

	()
_ <- IO () -> LogT IO ()
forall (m :: * -> *). MonadIO m => IO () -> m ()
fork (IO () -> LogT IO ()) -> IO () -> LogT IO ()
forall a b. (a -> b) -> a -> b
$ do
		Async ()
emptyTask <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
		MVar (Async ())
updaterTask <- Async () -> IO (MVar (Async ()))
forall a. a -> IO (MVar a)
newMVar Async ()
emptyTask
		MVar [(Watched, Event)]
tasksVar <- [(Watched, Event)] -> IO (MVar [(Watched, Event)])
forall a. a -> IO (MVar a)
newMVar []
		Maybe (Watcher Watched) -> (Watcher Watched -> IO ()) -> IO ()
forall (m :: * -> *) a b.
Applicative m =>
Maybe a -> (a -> m b) -> m ()
whenJust Maybe (Watcher Watched)
mwatcher ((Watcher Watched -> IO ()) -> IO ())
-> (Watcher Watched -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Watcher Watched
watcher -> Watcher Watched -> ([(Watched, Event)] -> IO ()) -> IO ()
forall a. Watcher a -> ([(a, Event)] -> IO ()) -> IO ()
Update.onEvents_ Watcher Watched
watcher (([(Watched, Event)] -> IO ()) -> IO ())
-> ([(Watched, Event)] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[(Watched, Event)]
evs -> Session -> ServerM IO () -> IO ()
forall (m :: * -> *) a. Session -> ServerM m a -> m a
withSession Session
session (ServerM IO () -> IO ()) -> ServerM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
			ServerM IO Result -> ServerM IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ServerM IO Result -> ServerM IO ())
-> ServerM IO Result -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ CommandOptions -> ClientM IO () -> ServerM IO Result
forall a (m :: * -> *).
(ToJSON a, ServerMonadBase m) =>
CommandOptions -> ClientM m a -> ServerM m Result
Client.runClient CommandOptions
forall a. Default a => a
def (ClientM IO () -> ServerM IO Result)
-> ClientM IO () -> ServerM IO Result
forall a b. (a -> b) -> a -> b
$ ([(Watched, Event)] -> IO ())
-> MVar (Async ())
-> MVar [(Watched, Event)]
-> [(Watched, Event)]
-> ClientM IO ()
Update.processEvents (Session -> ServerM IO () -> IO ()
forall (m :: * -> *) a. Session -> ServerM m a -> m a
withSession Session
session (ServerM IO () -> IO ())
-> ([(Watched, Event)] -> ServerM IO ())
-> [(Watched, Event)]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a. SessionMonad m => ServerM IO a -> m a
inSessionUpdater (ServerM IO () -> ServerM IO ())
-> ([(Watched, Event)] -> ServerM IO ())
-> [(Watched, Event)]
-> ServerM IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerM IO Result -> ServerM IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ServerM IO Result -> ServerM IO ())
-> ([(Watched, Event)] -> ServerM IO Result)
-> [(Watched, Event)]
-> ServerM IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandOptions -> ClientM IO () -> ServerM IO Result
forall a (m :: * -> *).
(ToJSON a, ServerMonadBase m) =>
CommandOptions -> ClientM m a -> ServerM m Result
Client.runClient CommandOptions
forall a. Default a => a
def (ClientM IO () -> ServerM IO Result)
-> ([(Watched, Event)] -> ClientM IO ())
-> [(Watched, Event)]
-> ServerM IO Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateOptions -> [(Watched, Event)] -> ClientM IO ()
Update.applyUpdates UpdateOptions
forall a. Default a => a
def) MVar (Async ())
updaterTask MVar [(Watched, Event)]
tasksVar [(Watched, Event)]
evs
	IO () -> LogT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LogT IO ()) -> IO () -> LogT IO ()
forall a b. (a -> b) -> a -> b
$ ReaderT Session IO () -> Session -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ServerM IO () -> ReaderT Session IO ()
forall (m :: * -> *) a. ServerM m a -> ReaderT Session m a
runServerM (ServerM IO () -> ReaderT Session IO ())
-> ServerM IO () -> ReaderT Session IO ()
forall a b. (a -> b) -> a -> b
$ (ServerM IO ()
forall (m :: * -> *). SessionMonad m => m ()
watchDb ServerM IO () -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ServerM IO ()
act) ServerM IO () -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` ServerM IO ()
closeSession) Session
session
	where
		maybeWithWatcher :: (Maybe (Watcher a) -> IO b) -> IO b
maybeWithWatcher Maybe (Watcher a) -> IO b
fn
			| ServerOpts -> Bool
serverWatchFS ServerOpts
sopts = (Watcher a -> IO b) -> IO b
forall a b. (Watcher a -> IO b) -> IO b
Watcher.withWatcher (Maybe (Watcher a) -> IO b
fn (Maybe (Watcher a) -> IO b)
-> (Watcher a -> Maybe (Watcher a)) -> Watcher a -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Watcher a -> Maybe (Watcher a)
forall a. a -> Maybe a
Just)
			| Bool
otherwise = Maybe (Watcher a) -> IO b
fn Maybe (Watcher a)
forall a. Maybe a
Nothing
		closeSession :: ServerM IO ()
closeSession = do
			(Session -> Worker (ServerM IO))
-> ServerM IO (Worker (ServerM IO))
forall (m :: * -> *) a. SessionMonad m => (Session -> a) -> m a
askSession Session -> Worker (ServerM IO)
sessionUpdater ServerM IO (Worker (ServerM IO))
-> (Worker (ServerM IO) -> ServerM IO ()) -> ServerM IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> ServerM IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerM IO ())
-> (Worker (ServerM IO) -> IO ())
-> Worker (ServerM IO)
-> ServerM IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Worker (ServerM IO) -> IO ()
forall (m :: * -> *). Worker m -> IO ()
joinWorker
			Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Info Text
"updater worker stopped"
			(Session -> GhcWorker) -> ServerM IO GhcWorker
forall (m :: * -> *) a. SessionMonad m => (Session -> a) -> m a
askSession Session -> GhcWorker
sessionGhc ServerM IO GhcWorker
-> (GhcWorker -> ServerM IO ()) -> ServerM IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> ServerM IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerM IO ())
-> (GhcWorker -> IO ()) -> GhcWorker -> ServerM IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhcWorker -> IO ()
forall (m :: * -> *). Worker m -> IO ()
joinWorker
			Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Info Text
"ghc worker stopped"
			(Session -> Connection) -> ServerM IO Connection
forall (m :: * -> *) a. SessionMonad m => (Session -> a) -> m a
askSession Session -> Connection
sessionSqlDatabase ServerM IO Connection
-> (Connection -> ServerM IO ()) -> ServerM IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> ServerM IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerM IO ())
-> (Connection -> IO ()) -> Connection -> ServerM IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> IO ()
SQLite.close
			Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Info Text
"sql connection closed"


-- | Set initial watch: package-dbs, projects and standalone sources
watchDb :: SessionMonad m => m ()
watchDb :: m ()
watchDb = do
	m (Maybe (Watcher Watched)) -> (Watcher Watched -> m ()) -> m ()
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m b) -> m ()
whenJustM ((Session -> Maybe (Watcher Watched)) -> m (Maybe (Watcher Watched))
forall (m :: * -> *) a. SessionMonad m => (Session -> a) -> m a
askSession Session -> Maybe (Watcher Watched)
sessionWatcher) ((Watcher Watched -> m ()) -> m ())
-> (Watcher Watched -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Watcher Watched
w -> do
		-- TODO: Implement watching package-dbs
		[Only Text]
cabals <- Query -> m [Only Text]
forall r (m :: * -> *).
(FromRow r, SessionMonad m) =>
Query -> m [r]
SQLite.query_ Query
"select cabal from projects;"
		[Project]
projects <- (Only Text -> m Project) -> [Only Text] -> m [Project]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Text -> m Project
forall (m :: * -> *). SessionMonad m => Text -> m Project
SQLite.loadProject (Text -> m Project)
-> (Only Text -> Text) -> Only Text -> m Project
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only Text -> Text
forall a. Only a -> a
SQLite.fromOnly) [Only Text]
cabals
		IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (Project -> IO ()) -> [Project] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Project
proj -> Watcher Watched -> Project -> [String] -> IO ()
W.watchProject Watcher Watched
w Project
proj []) [Project]
projects

		[Only Text]
files <- Query -> m [Only Text]
forall r (m :: * -> *).
(FromRow r, SessionMonad m) =>
Query -> m [r]
SQLite.query_ Query
"select file from modules where file is not null and cabal is null;"
		IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (Only Text -> IO ()) -> [Only Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(SQLite.Only Text
f) -> Watcher Watched -> ModuleLocation -> IO ()
W.watchModule Watcher Watched
w (Text -> Maybe Project -> ModuleLocation
FileModule Text
f Maybe Project
forall a. Maybe a
Nothing)) [Only Text]
files

type Server = Worker (ServerM IO)

-- | Start listening for incoming connections
setupServer :: ServerOpts -> ServerM IO ()
setupServer :: ServerOpts -> ServerM IO ()
setupServer ServerOpts
sopts = do
	QSem
q <- IO QSem -> ServerM IO QSem
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO QSem -> ServerM IO QSem) -> IO QSem -> ServerM IO QSem
forall a b. (a -> b) -> a -> b
$ Int -> IO QSem
newQSem Int
0
	Chan (IO ())
clientChan <- (Session -> Chan (IO ())) -> ServerM IO (Chan (IO ()))
forall (m :: * -> *) a. SessionMonad m => (Session -> a) -> m a
askSession Session -> Chan (IO ())
sessionClients
	Session
session <- ServerM IO Session
forall (m :: * -> *). SessionMonad m => m Session
getSession
	Async Any
_ <- IO (Async Any) -> ServerM IO (Async Any)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async Any) -> ServerM IO (Async Any))
-> IO (Async Any) -> ServerM IO (Async Any)
forall a b. (a -> b) -> a -> b
$ IO Any -> IO (Async Any)
forall a. IO a -> IO (Async a)
async (IO Any -> IO (Async Any)) -> IO Any -> IO (Async Any)
forall a b. (a -> b) -> a -> b
$ Session -> ServerM IO Any -> IO Any
forall (m :: * -> *) a. Session -> ServerM m a -> m a
withSession Session
session (ServerM IO Any -> IO Any) -> ServerM IO Any -> IO Any
forall a b. (a -> b) -> a -> b
$ Text -> ServerM IO Any -> ServerM IO Any
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"listener" (ServerM IO Any -> ServerM IO Any)
-> ServerM IO Any -> ServerM IO Any
forall a b. (a -> b) -> a -> b
$ (ServerM IO Any -> ServerM IO () -> ServerM IO Any)
-> ServerM IO () -> ServerM IO Any -> ServerM IO Any
forall a b c. (a -> b -> c) -> b -> a -> c
flip ServerM IO Any -> ServerM IO () -> ServerM IO Any
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally ServerM IO ()
forall (m :: * -> *). SessionMonad m => m ()
serverExit (ServerM IO Any -> ServerM IO Any)
-> ServerM IO Any -> ServerM IO Any
forall a b. (a -> b) -> a -> b
$
		ServerM IO Socket
-> (Socket -> ServerM IO ())
-> (Socket -> ServerM IO Any)
-> ServerM IO Any
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (IO Socket -> ServerM IO Socket
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Socket -> ServerM IO Socket) -> IO Socket -> ServerM IO Socket
forall a b. (a -> b) -> a -> b
$ ConnectionPort -> IO Socket
makeSocket (ServerOpts -> ConnectionPort
serverPort ServerOpts
sopts)) (IO () -> ServerM IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerM IO ())
-> (Socket -> IO ()) -> Socket -> ServerM IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> IO ()
close) ((Socket -> ServerM IO Any) -> ServerM IO Any)
-> (Socket -> ServerM IO Any) -> ServerM IO Any
forall a b. (a -> b) -> a -> b
$ \Socket
s -> do
			IO () -> ServerM IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerM IO ()) -> IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ do
				Socket -> SocketOption -> Int -> IO ()
setSocketOption Socket
s SocketOption
ReuseAddr Int
1
				Socket -> String -> ConnectionPort -> IO ()
bindSocket Socket
s String
"127.0.0.1" (ServerOpts -> ConnectionPort
serverPort ServerOpts
sopts)
				Socket -> Int -> IO ()
listen Socket
s Int
maxListenQueue
			ServerM IO () -> ServerM IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (ServerM IO () -> ServerM IO Any)
-> ServerM IO () -> ServerM IO Any
forall a b. (a -> b) -> a -> b
$ (String -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
(String -> m ()) -> m () -> m ()
logAsync (Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Fatal (Text -> ServerM IO ())
-> (String -> Text) -> String -> ServerM IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString) (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ String
-> (String -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *).
MonadCatch m =>
String -> (String -> m ()) -> m () -> m ()
logIO String
"exception: " (Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Error (Text -> ServerM IO ())
-> (String -> Text) -> String -> ServerM IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString) (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ do
				Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace Text
"accepting connection..."
				IO () -> ServerM IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerM IO ()) -> IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ QSem -> IO ()
signalQSem QSem
q
				(Socket
s', SockAddr
addr') <- IO (Socket, SockAddr) -> ServerM IO (Socket, SockAddr)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Socket, SockAddr) -> ServerM IO (Socket, SockAddr))
-> IO (Socket, SockAddr) -> ServerM IO (Socket, SockAddr)
forall a b. (a -> b) -> a -> b
$ Socket -> IO (Socket, SockAddr)
accept Socket
s
				Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> ServerM IO ()) -> Text -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ Format
"accepted {}" Format -> String -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ SockAddr -> String
forall a. Show a => a -> String
show SockAddr
addr'
				IO () -> ServerM IO ()
forall (m :: * -> *). MonadIO m => IO () -> m ()
fork (IO () -> ServerM IO ()) -> IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ Session -> ServerM IO () -> IO ()
forall (m :: * -> *) a. Session -> ServerM m a -> m a
withSession Session
session (ServerM IO () -> IO ()) -> ServerM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SockAddr -> String
forall a. Show a => a -> String
show SockAddr
addr') (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$
					(String -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
(String -> m ()) -> m () -> m ()
logAsync (Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Fatal (Text -> ServerM IO ())
-> (String -> Text) -> String -> ServerM IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString) (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ String
-> (String -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *).
MonadCatch m =>
String -> (String -> m ()) -> m () -> m ()
logIO String
"exception: " (Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Error (Text -> ServerM IO ())
-> (String -> Text) -> String -> ServerM IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString) (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$
						(ServerM IO () -> ServerM IO () -> ServerM IO ())
-> ServerM IO () -> ServerM IO () -> ServerM IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ServerM IO () -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (IO () -> ServerM IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerM IO ()) -> IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> IO ()
close Socket
s') (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$
							ServerM IO (MVar ())
-> (MVar () -> ServerM IO ())
-> (MVar () -> ServerM IO ())
-> ServerM IO ()
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (IO (MVar ()) -> ServerM IO (MVar ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar) (IO () -> ServerM IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerM IO ())
-> (MVar () -> IO ()) -> MVar () -> ServerM IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
`putMVar` ())) ((MVar () -> ServerM IO ()) -> ServerM IO ())
-> (MVar () -> ServerM IO ()) -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ \MVar ()
done -> do
								ThreadId
me <- IO ThreadId -> ServerM IO ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ThreadId
myThreadId
								let
									timeoutWait :: IO ()
timeoutWait = Session -> ServerM IO () -> IO ()
forall (m :: * -> *) a. Session -> ServerM m a -> m a
withSession Session
session (ServerM IO () -> IO ()) -> ServerM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
										Bool
notDone <- IO Bool -> ServerM IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ServerM IO Bool) -> IO Bool -> ServerM IO Bool
forall a b. (a -> b) -> a -> b
$ MVar () -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar MVar ()
done
										Bool -> ServerM IO () -> ServerM IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
notDone (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ do
											Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> ServerM IO ()) -> Text -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ Format
"waiting for {} to complete" Format -> String -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ SockAddr -> String
forall a. Show a => a -> String
show SockAddr
addr'
											Async ()
waitAsync <- IO (Async ()) -> ServerM IO (Async ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ()) -> ServerM IO (Async ()))
-> IO (Async ()) -> ServerM IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
												Int -> IO ()
threadDelay Int
1000000
												ThreadId -> IO ()
killThread ThreadId
me
											IO () -> ServerM IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerM IO ()) -> IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException ()) -> IO ())
-> IO (Either SomeException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Async () -> IO (Either SomeException ())
forall a. Async a -> IO (Either SomeException a)
waitCatch Async ()
waitAsync
								IO () -> ServerM IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerM IO ()) -> IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Chan (IO ()) -> IO () -> IO Bool
forall a. Chan a -> a -> IO Bool
F.sendChan Chan (IO ())
clientChan IO ()
timeoutWait
								String -> Socket -> ServerM IO ()
forall (m :: * -> *). SessionMonad m => String -> Socket -> m ()
processClientSocket (SockAddr -> String
forall a. Show a => a -> String
show SockAddr
addr') Socket
s'

	Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace Text
"waiting for starting accept thread..."
	IO () -> ServerM IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerM IO ()) -> IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ QSem -> IO ()
waitQSem QSem
q
	String
-> (String -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *).
MonadCatch m =>
String -> (String -> m ()) -> m () -> m ()
logIO String
"error writing to stdout: " (Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Error (Text -> ServerM IO ())
-> (String -> Text) -> String -> ServerM IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString) (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> ServerM IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerM IO ()) -> IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ 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
	Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Info (Text -> ServerM IO ()) -> Text -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ Format
"Server started at port {}" Format -> ConnectionPort -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ ServerOpts -> ConnectionPort
serverPort ServerOpts
sopts

-- | Shutdown server
shutdownServer :: ServerOpts -> ServerM IO ()
shutdownServer :: ServerOpts -> ServerM IO ()
shutdownServer ServerOpts
sopts = do
	Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace Text
"waiting for accept thread..."
	ServerM IO ()
forall (m :: * -> *). SessionMonad m => m ()
serverWait
	Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace Text
"accept thread stopped"
	IO () -> ServerM IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ServerM IO ()) -> IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ ConnectionPort -> IO ()
unlink (ServerOpts -> ConnectionPort
serverPort ServerOpts
sopts)
	Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace Text
"waiting for clients..."
	ServerM IO ()
forall (m :: * -> *). SessionMonad m => m ()
serverWaitClients
	Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Info Text
"server stopped"

startServer :: ServerOpts -> IO Server
startServer :: ServerOpts -> IO (Worker (ServerM IO))
startServer ServerOpts
sopts = (ServerM IO () -> IO ())
-> (ServerM IO () -> ServerM IO ())
-> (ServerM IO () -> ServerM IO ())
-> IO (Worker (ServerM IO))
forall (m :: * -> *).
MonadIO m =>
(m () -> IO ())
-> (m () -> m ()) -> (m () -> m ()) -> IO (Worker m)
startWorker (ServerOpts -> ServerM IO () -> IO ()
runServer ServerOpts
sopts) (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 ()
forall (m :: * -> *). (MonadLog m, MonadCatch m) => m () -> m ()
logAll

-- Tiny version with no network stuff
startServer_ :: ServerOpts -> IO Server
startServer_ :: ServerOpts -> IO (Worker (ServerM IO))
startServer_ ServerOpts
sopts = (ServerM IO () -> IO ())
-> (ServerM IO () -> ServerM IO ())
-> (ServerM IO () -> ServerM IO ())
-> IO (Worker (ServerM IO))
forall (m :: * -> *).
MonadIO m =>
(m () -> IO ())
-> (m () -> m ()) -> (m () -> m ()) -> IO (Worker m)
startWorker (ServerOpts -> ServerM IO () -> IO ()
runServer ServerOpts
sopts) ServerM IO () -> ServerM IO ()
forall a. a -> a
id ServerM IO () -> ServerM IO ()
forall (m :: * -> *). (MonadLog m, MonadCatch m) => m () -> m ()
logAll

stopServer :: Server -> IO ()
stopServer :: Worker (ServerM IO) -> IO ()
stopServer Worker (ServerM IO)
s = Worker (ServerM IO) -> [String] -> IO Result
sendServer_ Worker (ServerM IO)
s [String
"exit"] IO Result -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Worker (ServerM IO) -> IO ()
forall (m :: * -> *). Worker m -> IO ()
joinWorker Worker (ServerM IO)
s

withServer :: ServerOpts -> (Server -> IO a) -> IO a
withServer :: ServerOpts -> (Worker (ServerM IO) -> IO a) -> IO a
withServer ServerOpts
sopts = IO (Worker (ServerM IO))
-> (Worker (ServerM IO) -> IO ())
-> (Worker (ServerM IO) -> IO a)
-> IO a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (ServerOpts -> IO (Worker (ServerM IO))
startServer ServerOpts
sopts) Worker (ServerM IO) -> IO ()
stopServer

withServer_ :: ServerOpts -> (Server -> IO a) -> IO a
withServer_ :: ServerOpts -> (Worker (ServerM IO) -> IO a) -> IO a
withServer_ ServerOpts
sopts = IO (Worker (ServerM IO))
-> (Worker (ServerM IO) -> IO ())
-> (Worker (ServerM IO) -> IO a)
-> IO a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (ServerOpts -> IO (Worker (ServerM IO))
startServer_ ServerOpts
sopts) Worker (ServerM IO) -> IO ()
stopServer

inServer :: Server -> ServerM IO a -> IO a
inServer :: Worker (ServerM IO) -> ServerM IO a -> IO a
inServer = Worker (ServerM IO) -> ServerM IO a -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
Worker m -> m a -> IO a
inWorker

clientCommand :: CommandOptions -> Command -> ServerM IO Result
clientCommand :: CommandOptions -> Command -> ServerM IO Result
clientCommand CommandOptions
copts Command
c = do
	Command
c' <- IO Command -> ServerM IO Command
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Command -> ServerM IO Command)
-> IO Command -> ServerM IO Command
forall a b. (a -> b) -> a -> b
$ Command -> IO Command
forall a. Paths a => a -> IO a
canonicalize Command
c
	CommandOptions -> ClientM IO Value -> ServerM IO Result
forall a (m :: * -> *).
(ToJSON a, ServerMonadBase m) =>
CommandOptions -> ClientM m a -> ServerM m Result
Client.runClient CommandOptions
copts (Command -> ClientM IO Value
forall (m :: * -> *).
ServerMonadBase m =>
Command -> ClientM m Value
Client.runCommand Command
c')

parseCommand :: [String] -> Either String Command
parseCommand :: [String] -> Either String Command
parseCommand = String -> ParserInfo Command -> [String] -> Either String Command
forall a. String -> ParserInfo a -> [String] -> Either String a
parseArgs String
"hsdev" (Parser Command -> InfoMod Command -> ParserInfo Command
forall a. Parser a -> InfoMod a -> ParserInfo a
info Parser Command
forall a. FromCmd a => Parser a
cmdP (String -> InfoMod Command
forall a. String -> InfoMod a
progDesc String
"hsdev tool"))

readCommand :: [String] -> Command
readCommand :: [String] -> Command
readCommand = (String -> Command)
-> (Command -> Command) -> Either String Command -> Command
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Command
forall a. HasCallStack => String -> a
error Command -> Command
forall a. a -> a
id (Either String Command -> Command)
-> ([String] -> Either String Command) -> [String] -> Command
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Either String Command
parseCommand

sendServer :: Server -> CommandOptions -> [String] -> IO Result
sendServer :: Worker (ServerM IO) -> CommandOptions -> [String] -> IO Result
sendServer Worker (ServerM IO)
srv CommandOptions
copts [String]
args = case [String] -> Either String Command
parseCommand [String]
args of
	Left String
e -> HsDevError -> IO Result
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> IO Result) -> HsDevError -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> String -> HsDevError
RequestError String
e ([String] -> String
unwords [String]
args)
	Right Command
c -> Worker (ServerM IO) -> ServerM IO Result -> IO Result
forall a. Worker (ServerM IO) -> ServerM IO a -> IO a
inServer Worker (ServerM IO)
srv (CommandOptions -> Command -> ServerM IO Result
clientCommand CommandOptions
copts Command
c)

sendServer_ :: Server -> [String] -> IO Result
sendServer_ :: Worker (ServerM IO) -> [String] -> IO Result
sendServer_ Worker (ServerM IO)
srv = Worker (ServerM IO) -> CommandOptions -> [String] -> IO Result
sendServer Worker (ServerM IO)
srv CommandOptions
forall a. Default a => a
def

chaner :: C.Chan Log.Message -> Consumer Log.Message
chaner :: Chan Message -> LogHandler
chaner Chan Message
ch = (Message -> IO ()) -> LogHandler
forall (m :: * -> *) a. Monad m => a -> m a
return ((Message -> IO ()) -> LogHandler)
-> (Message -> IO ()) -> LogHandler
forall a b. (a -> b) -> a -> b
$ Chan Message -> Message -> IO ()
forall a. Chan a -> a -> IO ()
C.writeChan Chan Message
ch

findPath :: MonadIO m => CommandOptions -> FilePath -> m FilePath
findPath :: CommandOptions -> String -> m String
findPath CommandOptions
copts String
f = IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. Paths a => a -> IO a
canonicalize (String -> String
normalise String
f') where
	f' :: String
f' = Text -> String -> String
forall a. Paths a => Text -> a -> a
absolutise (String -> Text
fromFilePath (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ CommandOptions -> String
commandOptionsRoot CommandOptions
copts) String
f

-- | Process request, notifications can be sent during processing
processRequest :: SessionMonad m => CommandOptions -> Command -> m Result
processRequest :: CommandOptions -> Command -> m Result
processRequest CommandOptions
copts Command
c = do
	Command
c' <- (String -> m String) -> Command -> m Command
forall a. Paths a => Traversal' a String
paths (CommandOptions -> String -> m String
forall (m :: * -> *).
MonadIO m =>
CommandOptions -> String -> m String
findPath CommandOptions
copts) Command
c
	Session
s <- m Session
forall (m :: * -> *). SessionMonad m => m Session
getSession
	Session -> ServerM m Result -> m Result
forall (m :: * -> *) a. Session -> ServerM m a -> m a
withSession Session
s (ServerM m Result -> m Result) -> ServerM m Result -> m Result
forall a b. (a -> b) -> a -> b
$ CommandOptions -> ClientM m Value -> ServerM m Result
forall a (m :: * -> *).
(ToJSON a, ServerMonadBase m) =>
CommandOptions -> ClientM m a -> ServerM m Result
Client.runClient CommandOptions
copts (ClientM m Value -> ServerM m Result)
-> ClientM m Value -> ServerM m Result
forall a b. (a -> b) -> a -> b
$ Command -> ClientM m Value
forall (m :: * -> *).
ServerMonadBase m =>
Command -> ClientM m Value
Client.runCommand Command
c'

-- | Process client, listen for requests and process them
processClient :: SessionMonad m => String -> F.Chan ByteString -> (ByteString -> IO ()) -> m ()
processClient :: String -> Chan ByteString -> (ByteString -> IO ()) -> m ()
processClient String
name Chan ByteString
rchan ByteString -> IO ()
send' = do
	Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Info Text
"connected"
	Chan (Msg (Message Response))
respChan <- IO (Chan (Msg (Message Response)))
-> m (Chan (Msg (Message Response)))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Chan (Msg (Message Response)))
forall a. IO (Chan a)
newChan
	IO () -> m ()
forall (m :: * -> *). MonadIO m => IO () -> m ()
fork (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Chan (Msg (Message Response)) -> IO [Msg (Message Response)]
forall a. Chan a -> IO [a]
getChanContents Chan (Msg (Message Response))
respChan IO [Msg (Message Response)]
-> ([Msg (Message Response)] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Msg (Message Response) -> IO ())
-> [Msg (Message Response)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ByteString -> IO ()
send' (ByteString -> IO ())
-> (Msg (Message Response) -> ByteString)
-> Msg (Message Response)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg (Message Response) -> ByteString
forall a. ToJSON a => Msg (Message a) -> ByteString
encodeMessage)
	MVar (IO ())
linkVar <- IO (MVar (IO ())) -> m (MVar (IO ()))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar (IO ())) -> m (MVar (IO ())))
-> IO (MVar (IO ())) -> m (MVar (IO ()))
forall a b. (a -> b) -> a -> b
$ IO () -> IO (MVar (IO ()))
forall a. a -> IO (MVar a)
newMVar (IO () -> IO (MVar (IO ()))) -> IO () -> IO (MVar (IO ()))
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
	Session
s <- m Session
forall (m :: * -> *). SessionMonad m => m Session
getSession
	IO ()
exit <- (Session -> IO ()) -> m (IO ())
forall (m :: * -> *) a. SessionMonad m => (Session -> a) -> m a
askSession Session -> IO ()
sessionExit
	let
		answer :: SessionMonad m => Msg (Message Response) -> m ()
		answer :: Msg (Message Response) -> m ()
answer Msg (Message Response)
m = do
			Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Response -> Bool
isNotification (Response -> Bool) -> Response -> Bool
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 a a2. Lens (Message a) (Message a2) a a2
message) Msg (Message Response)
m) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
				Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"responsed << {}" Format -> String -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ String -> String
ellipsis (ByteString -> String
fromUtf8 (Response -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Response -> ByteString) -> Response -> ByteString
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 a a2. Lens (Message a) (Message a2) a a2
message) Msg (Message Response)
m))
			IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Chan (Msg (Message Response)) -> Msg (Message Response) -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (Msg (Message Response))
respChan Msg (Message Response)
m
			where
				ellipsis :: String -> String
				ellipsis :: String -> String
ellipsis String
str
					| String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
100 = String
str
					| Bool
otherwise = Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
100 String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"..."

	(m () -> m () -> m ()) -> m () -> m () -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip m () -> m () -> m ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (MVar (IO ()) -> m ()
forall (m :: * -> *). SessionMonad m => MVar (IO ()) -> m ()
disconnected MVar (IO ())
linkVar) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
		m (Maybe ByteString) -> (ByteString -> m ()) -> m ()
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m b) -> m ()
whileJust_ (IO (Maybe ByteString) -> m (Maybe ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> m (Maybe ByteString))
-> IO (Maybe ByteString) -> m (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Chan ByteString -> IO (Maybe ByteString)
forall a. Chan a -> IO (Maybe a)
F.getChan Chan ByteString
rchan) ((ByteString -> m ()) -> m ()) -> (ByteString -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ByteString
req' -> do
			Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"received >> {}" Format -> String -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ ByteString -> String
fromUtf8 ByteString
req'
			case ByteString -> Either (Msg String) (Msg (Message Request))
forall a.
FromJSON a =>
ByteString -> Either (Msg String) (Msg (Message a))
decodeMessage ByteString
req' of
				Left Msg String
em -> do
					Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Warning (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Format
"Invalid request {}" Format -> String -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ ByteString -> String
fromUtf8 ByteString
req'
					Msg (Message Response) -> m ()
forall (m :: * -> *).
SessionMonad m =>
Msg (Message Response) -> m ()
answer (Msg (Message Response) -> m ()) -> Msg (Message Response) -> m ()
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 a. Maybe String -> a -> Message a
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 -> String -> HsDevError
RequestError String
"invalid request" (String -> HsDevError) -> String -> HsDevError
forall a b. (a -> b) -> a -> b
$ ByteString -> String
fromUtf8 ByteString
req') Msg String
em
				Right Msg (Message Request)
m -> IO () -> m ()
forall (m :: * -> *). MonadIO m => IO () -> m ()
fork (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Session -> ServerM IO () -> IO ()
forall (m :: * -> *) a. Session -> ServerM m a -> m a
withSession Session
s (ServerM IO () -> IO ()) -> ServerM IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope (String -> Text
T.pack String
name) (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ Text -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope Text
"req" (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$
					Text -> ServerM IO () -> ServerM IO ()
forall (m :: * -> *) a.
(MonadLog m, HasCallStack) =>
Text -> m a -> m a
Log.scope (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"_" (Getting (Maybe String) (Msg (Message Request)) (Maybe String)
-> Msg (Message Request) -> Maybe String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Message Request -> Const (Maybe String) (Message Request))
-> Msg (Message Request)
-> Const (Maybe String) (Msg (Message Request))
forall a b. Lens (Msg a) (Msg b) a b
msg ((Message Request -> Const (Maybe String) (Message Request))
 -> Msg (Message Request)
 -> Const (Maybe String) (Msg (Message Request)))
-> ((Maybe String -> Const (Maybe String) (Maybe String))
    -> Message Request -> Const (Maybe String) (Message Request))
-> Getting (Maybe String) (Msg (Message Request)) (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String -> Const (Maybe String) (Maybe String))
-> Message Request -> Const (Maybe String) (Message Request)
forall a. Lens' (Message a) (Maybe String)
messageId) Msg (Message Request)
m)) (ServerM IO () -> ServerM IO ()) -> ServerM IO () -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ do
						Msg (Message Response)
resp' <- ((Request -> ServerM IO Response)
 -> Msg (Message Request) -> ServerM IO (Msg (Message Response)))
-> Msg (Message Request)
-> (Request -> ServerM IO Response)
-> ServerM IO (Msg (Message Response))
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((Request -> ServerM IO Response)
 -> Msg (Message Request) -> ServerM IO (Msg (Message Response)))
-> (Request -> ServerM IO Response)
-> Msg (Message Request)
-> ServerM IO (Msg (Message Response))
forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
traverseOf ((Message Request -> ServerM IO (Message Response))
-> Msg (Message Request) -> ServerM IO (Msg (Message Response))
forall a b. Lens (Msg a) (Msg b) a b
msg ((Message Request -> ServerM IO (Message Response))
 -> Msg (Message Request) -> ServerM IO (Msg (Message Response)))
-> ((Request -> ServerM IO Response)
    -> Message Request -> ServerM IO (Message Response))
-> (Request -> ServerM IO Response)
-> Msg (Message Request)
-> ServerM IO (Msg (Message Response))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Request -> ServerM IO Response)
-> Message Request -> ServerM IO (Message Response)
forall a a2. Lens (Message a) (Message a2) a a2
message)) Msg (Message Request)
m ((Request -> ServerM IO Response)
 -> ServerM IO (Msg (Message Response)))
-> (Request -> ServerM IO Response)
-> ServerM IO (Msg (Message Response))
forall a b. (a -> b) -> a -> b
$ \(Request Command
c String
cdir Bool
noFile Int
tm Bool
silent) -> do
							let
								onNotify :: Notification -> m ()
onNotify Notification
n
									| Bool
silent = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
									| Bool
otherwise = LensLike
  m (Msg (Message Request)) (Msg (Message Response)) Request Response
-> LensLike
     m (Msg (Message Request)) (Msg (Message Response)) Request Response
forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
traverseOf ((Message Request -> m (Message Response))
-> Msg (Message Request) -> m (Msg (Message Response))
forall a b. Lens (Msg a) (Msg b) a b
msg ((Message Request -> m (Message Response))
 -> Msg (Message Request) -> m (Msg (Message Response)))
-> ((Request -> m Response)
    -> Message Request -> m (Message Response))
-> LensLike
     m (Msg (Message Request)) (Msg (Message Response)) Request Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Request -> m Response) -> Message Request -> m (Message Response)
forall a a2. Lens (Message a) (Message a2) a a2
message) (m Response -> Request -> m Response
forall a b. a -> b -> a
const (m Response -> Request -> m Response)
-> m Response -> Request -> m Response
forall a b. (a -> b) -> a -> b
$ Bool -> Response -> m Response
forall (m :: * -> *).
SessionMonad m =>
Bool -> Response -> m Response
mmap' Bool
noFile (Either Notification Result -> Response
Response (Either Notification Result -> Response)
-> Either Notification Result -> Response
forall a b. (a -> b) -> a -> b
$ Notification -> Either Notification Result
forall a b. a -> Either a b
Left Notification
n)) Msg (Message Request)
m m (Msg (Message Response))
-> (Msg (Message Response) -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Msg (Message Response) -> m ()
forall (m :: * -> *).
SessionMonad m =>
Msg (Message Response) -> m ()
answer
							Level -> Text -> ServerM IO ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Trace (Text -> ServerM IO ()) -> Text -> ServerM IO ()
forall a b. (a -> b) -> a -> b
$ Format
"requested >> {}" Format -> String -> Text
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ ByteString -> String
fromUtf8 (Command -> ByteString
forall a. ToJSON a => a -> ByteString
encode Command
c)
							Response
resp <- IO Response -> ServerM IO Response
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Response -> ServerM IO Response)
-> IO Response -> ServerM IO Response
forall a b. (a -> b) -> a -> b
$ (Result -> Response) -> IO Result -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either Notification Result -> Response
Response (Either Notification Result -> Response)
-> (Result -> Either Notification Result) -> Result -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Either Notification Result
forall a b. b -> Either a b
Right) (IO Result -> IO Response) -> IO Result -> IO Response
forall a b. (a -> b) -> a -> b
$ Int -> IO Result -> IO Result
handleTimeout Int
tm (IO Result -> IO Result) -> IO Result -> IO Result
forall a b. (a -> b) -> a -> b
$ IO Result -> IO Result
forall (m :: * -> *) a. MonadCatch m => m a -> m a
hsdevLiftIO (IO Result -> IO Result) -> IO Result -> IO Result
forall a b. (a -> b) -> a -> b
$ Session -> ServerM IO Result -> IO Result
forall (m :: * -> *) a. Session -> ServerM m a -> m a
withSession Session
s (ServerM IO Result -> IO Result) -> ServerM IO Result -> IO Result
forall a b. (a -> b) -> a -> b
$
								CommandOptions -> Command -> ServerM IO Result
forall (m :: * -> *).
SessionMonad m =>
CommandOptions -> Command -> m Result
processRequest
									CommandOptions :: String
-> (Notification -> IO ()) -> IO () -> IO () -> CommandOptions
CommandOptions {
										commandOptionsRoot :: String
commandOptionsRoot = String
cdir,
										commandOptionsNotify :: Notification -> IO ()
commandOptionsNotify = Session -> ServerM IO () -> IO ()
forall (m :: * -> *) a. Session -> ServerM m a -> m a
withSession Session
s (ServerM IO () -> IO ())
-> (Notification -> ServerM IO ()) -> Notification -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Notification -> ServerM IO ()
forall (m :: * -> *). SessionMonad m => Notification -> m ()
onNotify,
										commandOptionsLink :: IO ()
commandOptionsLink = IO (IO ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MVar (IO ()) -> IO () -> IO (IO ())
forall a. MVar a -> a -> IO a
swapMVar MVar (IO ())
linkVar IO ()
exit),
										commandOptionsHold :: IO ()
commandOptionsHold = IO (Maybe ByteString) -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Chan ByteString -> IO (Maybe ByteString)
forall a. Chan a -> IO (Maybe a)
F.getChan Chan ByteString
rchan) }
									Command
c
							Bool -> Response -> ServerM IO Response
forall (m :: * -> *).
SessionMonad m =>
Bool -> Response -> m Response
mmap' Bool
noFile Response
resp
						Msg (Message Response) -> ServerM IO ()
forall (m :: * -> *).
SessionMonad m =>
Msg (Message Response) -> m ()
answer Msg (Message Response)
resp'
	where
		handleTimeout :: Int -> IO Result -> IO Result
		handleTimeout :: Int -> IO Result -> IO Result
handleTimeout Int
0 = IO Result -> IO Result
forall a. a -> a
id
		handleTimeout Int
tm = (Maybe Result -> Result) -> IO (Maybe Result) -> IO Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Result -> Maybe Result -> Result
forall a. a -> Maybe a -> a
fromMaybe (Result -> Maybe Result -> Result)
-> Result -> Maybe Result -> 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 String
"timeout") (IO (Maybe Result) -> IO Result)
-> (IO Result -> IO (Maybe Result)) -> IO Result -> IO Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO Result -> IO (Maybe Result)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
tm

		mmap' :: SessionMonad m => Bool -> Response -> m Response
#if mingw32_HOST_OS
		mmap' False r = do
			mpool <- askSession sessionMmapPool
			case mpool of
				Just pool -> liftIO $ mmap pool r
				Nothing -> return r
#endif
		mmap' :: Bool -> Response -> m Response
mmap' Bool
_ Response
r = Response -> m Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
r

		-- Call on disconnected, either no action or exit command
		disconnected :: SessionMonad m => MVar (IO ()) -> m ()
		disconnected :: MVar (IO ()) -> m ()
disconnected MVar (IO ())
var = do
			Level -> Text -> m ()
forall (m :: * -> *). MonadLog m => Level -> Text -> m ()
Log.sendLog Level
Log.Info Text
"disconnected"
			IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar (IO ()) -> IO (IO ())
forall a. MVar a -> IO a
takeMVar MVar (IO ())
var

-- | Process client by socket
processClientSocket :: SessionMonad m => String -> Socket -> m ()
processClientSocket :: String -> Socket -> m ()
processClientSocket String
name Socket
s = do
	Chan ByteString
recvChan <- IO (Chan ByteString) -> m (Chan ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Chan ByteString)
forall a. IO (Chan a)
F.newChan
	IO () -> m ()
forall (m :: * -> *). MonadIO m => IO () -> m ()
fork (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally
		(Socket -> IO ByteString
Net.getContents Socket
s IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ByteString -> IO Bool) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Chan ByteString -> ByteString -> IO Bool
forall a. Chan a -> a -> IO Bool
F.sendChan Chan ByteString
recvChan) ([ByteString] -> IO ())
-> (ByteString -> [ByteString]) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.lines)
		(Chan ByteString -> IO ()
forall a. Chan a -> IO ()
F.closeChan Chan ByteString
recvChan)
	String -> Chan ByteString -> (ByteString -> IO ()) -> m ()
forall (m :: * -> *).
SessionMonad m =>
String -> Chan ByteString -> (ByteString -> IO ()) -> m ()
processClient String
name Chan ByteString
recvChan (Socket -> ByteString -> IO ()
sendLine Socket
s)
	where
		sendLine :: Socket -> ByteString -> IO ()
		sendLine :: Socket -> ByteString -> IO ()
sendLine Socket
sock ByteString
bs = Socket -> ByteString -> IO ()
Net.sendAll Socket
sock (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Char -> ByteString
L.snoc ByteString
bs Char
'\n'

#if mingw32_HOST_OS
newtype MmapFile = MmapFile String

instance ToJSON MmapFile where
	toJSON (MmapFile f) = object ["file" .= f]

instance FromJSON MmapFile where
	parseJSON = withObject "file" $ \v -> MmapFile <$> v .:: "file"

-- | Push message to mmap and return response which points to this mmap
mmap :: Pool -> Response -> IO Response
mmap mmapPool r
	| L.length msg' <= 1024 = return r
	| otherwise = do
		rvar <- newEmptyMVar
		_ <- forkIO $ flip finally (tryPutMVar rvar r) $ void $ withName mmapPool $ \mmapName -> runExceptT $ catchError
			(withMapFile mmapName (L.toStrict msg') $ liftIO $ do
				_ <- tryPutMVar rvar $ result $ MmapFile mmapName
				-- give 10 seconds for client to read data
				threadDelay 10000000)
			(\_ -> liftIO $ void $ tryPutMVar rvar r)
		takeMVar rvar
	where
		msg' = encode r
#endif

-- | If response points to mmap, get its contents and parse
unMmap :: Response -> IO Response
#if mingw32_HOST_OS
unMmap (Response (Right (Result v)))
	| Just (MmapFile f) <- parseMaybe parseJSON v = do
		cts <- runExceptT (fmap L.fromStrict (readMapFile f))
		case cts of
			Left _ -> return $ responseError $ ResponseError "can't read map view of file" f
			Right r' -> case eitherDecode r' of
				Left e' -> return $ responseError $ ResponseError ("can't parse response: {}" ~~ e') (fromUtf8 r')
				Right r'' -> return r''
#endif
unMmap :: Response -> IO Response
unMmap Response
r = Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
r

makeSocket :: ConnectionPort -> IO Socket
makeSocket :: ConnectionPort -> IO Socket
makeSocket (NetworkPort Int
_) = Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_INET SocketType
Stream ProtocolNumber
defaultProtocol
makeSocket (UnixPort String
_) = Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_UNIX SocketType
Stream ProtocolNumber
defaultProtocol

bindSocket :: Socket -> String -> ConnectionPort -> IO ()
bindSocket :: Socket -> String -> ConnectionPort -> IO ()
bindSocket Socket
s String
_ (UnixPort String
p) = Socket -> SockAddr -> IO ()
bind Socket
s (String -> SockAddr
SockAddrUnix String
p)
bindSocket Socket
s String
host (NetworkPort Int
p) = do
	AddrInfo
sockAddr':[AddrInfo]
_ <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (String -> Maybe String
forall a. a -> Maybe a
Just String
host) (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
p)
	Socket -> SockAddr -> IO ()
bind Socket
s (AddrInfo -> SockAddr
addrAddress AddrInfo
sockAddr')
	where
		hints :: AddrInfo
hints = AddrInfo
defaultHints { addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_NUMERICHOST], addrSocketType :: SocketType
addrSocketType = SocketType
Stream }

connectSocket :: Socket -> String -> ConnectionPort -> IO ()
connectSocket :: Socket -> String -> ConnectionPort -> IO ()
connectSocket Socket
s String
_ (UnixPort String
p) = Socket -> SockAddr -> IO ()
connect Socket
s (String -> SockAddr
SockAddrUnix String
p)
connectSocket Socket
s String
host (NetworkPort Int
p) = do
	AddrInfo
sockAddr':[AddrInfo]
_ <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (String -> Maybe String
forall a. a -> Maybe a
Just String
host) (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
p)
	Socket -> SockAddr -> IO ()
connect Socket
s (AddrInfo -> SockAddr
addrAddress AddrInfo
sockAddr')
	where
		hints :: AddrInfo
hints = AddrInfo
defaultHints { addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_NUMERICHOST], addrSocketType :: SocketType
addrSocketType = SocketType
Stream }

unlink :: ConnectionPort -> IO ()
unlink :: ConnectionPort -> IO ()
unlink (NetworkPort Int
_) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#if mingw32_HOST_OS
unlink (UnixPort _) = return ()
#else
unlink (UnixPort String
s) = String -> IO ()
removeLink String
s
#endif