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.Applicative
import Control.Concurrent
import Control.Concurrent.Async
import Control.Lens (set, traverseOf, view, over, Lens', Lens, _1, _2, _Left)
import Control.Monad
import Control.Monad.Catch (bracket, finally)
import Data.Aeson hiding (Result, Error)
import Data.Aeson.Encode.Pretty
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 Network.Socket hiding (connect)
import qualified Network.Socket as Net hiding (send)
import qualified Network.Socket.ByteString as Net (send)
import qualified Network.Socket.ByteString.Lazy as Net (getContents)
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import qualified System.Log.Simple as Log
import Control.Concurrent.Util
import qualified Control.Concurrent.FiniteChan as F
import Data.Lisp
import Text.Format ((~~), (~%))
import System.Directory.Paths
import qualified HsDev.Client.Commands as Client
import qualified HsDev.Database.Async as DB
import HsDev.Server.Base
import HsDev.Server.Types
import HsDev.Tools.Base (runTool_)
import HsDev.Error
import HsDev.Util
import HsDev.Version
#if mingw32_HOST_OS
import Data.Aeson.Types hiding (Result, Error)
import Data.Char
import Data.List
import System.Environment
import System.Win32.FileMapping.Memory (withMapFile, readMapFile)
import System.Win32.FileMapping.NamePool
import System.Win32.PowerShell (escape, quote, quoteDouble)
#else
import Control.Exception (SomeException, handle)
import System.Posix.Process
import System.Posix.Files (removeLink)
import System.Posix.IO
#endif
sendCommand :: ClientOpts -> Bool -> Command -> (Notification -> IO a) -> IO Result
sendCommand copts noFile c onNotification = do
asyncAct <- async sendReceive
res <- waitCatch asyncAct
case res of
Left e -> return $ Error $ OtherError (show e)
Right r -> return r
where
sendReceive = do
curDir <- getCurrentDirectory
input <- if clientStdin copts
then Just <$> L.getContents
else return $ toUtf8 <$> Nothing
let
parseData :: L.ByteString -> IO Value
parseData cts = case eitherDecode cts of
Left err -> putStrLn ("Invalid data: " ++ err) >> exitFailure
Right v -> return v
_ <- traverse parseData input
s <- makeSocket (clientPort copts)
addr' <- inet_addr "127.0.0.1"
Net.connect s (sockAddr (clientPort copts) addr')
bracket (socketToHandle s ReadWriteMode) hClose $ \h -> do
L.hPutStrLn h $ encode $ Message Nothing $ Request c curDir noFile (clientTimeout copts) (clientSilent copts)
hFlush h
peekResponse h
peekResponse h = do
resp <- hGetLineBS h
parseResponse h resp
parseResponse h str = case eitherDecode str of
Left e -> return $ Error $ ResponseError ("can't parse: {}" ~~ e) (fromUtf8 str)
Right (Message _ r) -> do
Response r' <- unMmap r
case r' of
Left n -> onNotification n >> peekResponse h
Right res -> return res
runServerCommand :: ServerCommand -> IO ()
runServerCommand Version = putStrLn $cabalVersion
runServerCommand (Start sopts) = do
#if mingw32_HOST_OS
let
args = "run" : serverOptsArgs sopts
myExe <- getExecutablePath
curDir <- getCurrentDirectory
let
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)
r <- runTool_ "powershell" [
"-Command",
script]
if all isSpace r
then putStrLn $ "Server started at port {}" ~~ serverPort sopts
else mapM_ putStrLn [
"Failed to start server",
"\tCommand: {}" ~~ script,
"\tResult: {}" ~~ r]
#else
let
forkError :: SomeException -> IO ()
forkError e = putStrLn $ "Failed to start server: {}" ~~ show e
proxy :: IO ()
proxy = do
_ <- createSession
_ <- forkProcess serverAction
exitImmediately ExitSuccess
serverAction :: IO ()
serverAction = do
mapM_ closeFd [stdInput, stdOutput, stdError]
nullFd <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags
mapM_ (dupTo nullFd) [stdInput, stdOutput, stdError]
closeFd nullFd
runServerCommand (Run sopts)
handle forkError $ do
_ <- forkProcess proxy
putStrLn $ "Server started at port {}" ~~ serverPort sopts
#endif
runServerCommand (Run sopts) = runServer sopts $ do
q <- liftIO $ newQSem 0
clientChan <- liftIO F.newChan
session <- getSession
_ <- liftIO $ async $ withSession session $ Log.scope "listener" $ flip finally serverExit $
bracket (liftIO $ makeSocket (serverPort sopts)) (liftIO . close) $ \s -> do
liftIO $ do
setSocketOption s ReuseAddr 1
addr' <- inet_addr "127.0.0.1"
bind s (sockAddr (serverPort sopts) addr')
listen s maxListenQueue
forever $ logAsync (Log.sendLog Log.Fatal . fromString) $ logIO "exception: " (Log.sendLog Log.Error . fromString) $ do
Log.sendLog Log.Trace "accepting connection..."
liftIO $ signalQSem q
(s', addr') <- liftIO $ accept s
Log.sendLog Log.Trace $ "accepted {}" ~~ show addr'
void $ liftIO $ forkIO $ withSession session $ Log.scope (T.pack $ show addr') $
logAsync (Log.sendLog Log.Fatal . fromString) $ logIO "exception: " (Log.sendLog Log.Error . fromString) $
flip finally (liftIO $ close s') $
bracket (liftIO newEmptyMVar) (liftIO . (`putMVar` ())) $ \done -> do
me <- liftIO myThreadId
let
timeoutWait = withSession session $ do
notDone <- liftIO $ isEmptyMVar done
when notDone $ do
Log.sendLog Log.Trace $ "waiting for {} to complete" ~~ show addr'
waitAsync <- liftIO $ async $ do
threadDelay 1000000
killThread me
liftIO $ void $ waitCatch waitAsync
liftIO $ F.putChan clientChan timeoutWait
processClientSocket (show addr') s'
Log.sendLog Log.Trace "waiting for starting accept thread..."
liftIO $ waitQSem q
liftIO $ putStrLn $ "Server started at port {}" ~~ serverPort sopts
Log.sendLog Log.Info $ "server started at port {}" ~~ serverPort sopts
Log.sendLog Log.Trace "waiting for accept thread..."
serverWait
Log.sendLog Log.Trace "accept thread stopped"
liftIO $ unlink (serverPort sopts)
askSession sessionDatabase >>= liftIO . DB.readAsync >>= writeCache sopts
Log.sendLog Log.Trace "waiting for clients..."
liftIO (F.stopChan clientChan) >>= sequence_
Log.sendLog Log.Info "server stopped"
runServerCommand (Stop copts) = runServerCommand (Remote copts False Exit)
runServerCommand (Connect copts) = do
curDir <- getCurrentDirectory
s <- makeSocket $ clientPort copts
addr' <- inet_addr "127.0.0.1"
Net.connect s $ sockAddr (clientPort copts) addr'
bracket (socketToHandle s ReadWriteMode) hClose $ \h -> forM_ [(1 :: Integer)..] $ \i -> ignoreIO $ do
input' <- hGetLineBS stdin
case decodeMsg input' of
Left em -> L.putStrLn $ encodeMessage $ set msg (Message Nothing $ responseError $ OtherError "invalid command") em
Right m -> do
L.hPutStrLn h $ encodeMessage $ set msg (Message (Just $ show i) $ Request (view msg m) curDir True (clientTimeout copts) False) m
waitResp h
where
waitResp h = do
resp <- hGetLineBS h
parseResp h resp
parseResp h str = case decodeMessage str of
Left em -> putStrLn $ "Can't decode response: {}" ~~ view msg em
Right m -> do
Response r' <- unMmap $ view (msg . message) m
putStrLn $ "{id}: {response}"
~~ ("id" ~% fromMaybe "_" (view (msg . messageId) m))
~~ ("response" ~% fromUtf8 (encodeMsg $ set msg (Response r') m))
case unResponse (view (msg . message) m) of
Left _ -> waitResp h
_ -> return ()
runServerCommand (Remote copts noFile c) = sendCommand copts noFile c printValue >>= printResult where
printValue :: ToJSON a => a -> IO ()
printValue = L.putStrLn . encodeValue
printResult :: Result -> IO ()
printResult (Result r) = printValue r
printResult e = printValue e
encodeValue :: ToJSON a => a -> L.ByteString
encodeValue = if clientPretty copts then encodePretty else encode
findPath :: MonadIO m => CommandOptions -> FilePath -> m FilePath
findPath copts f = liftIO $ canonicalizePath (normalise f') where
f'
| isRelative f = commandOptionsRoot copts </> f
| otherwise = f
type Msg a = (Bool, a)
isLisp :: Lens' (Msg a) Bool
isLisp = _1
msg :: Lens (Msg a) (Msg b) a b
msg = _2
jsonMsg :: a -> Msg a
jsonMsg = (,) False
lispMsg :: a -> Msg a
lispMsg = (,) True
decodeMsg :: FromJSON a => ByteString -> Either (Msg String) (Msg a)
decodeMsg bstr = over _Left decodeType' decodeMsg' where
decodeType'
| isLisp' = lispMsg
| otherwise = jsonMsg
decodeMsg' = (lispMsg <$> decodeLisp bstr) <|> (jsonMsg <$> eitherDecode bstr)
isLisp' = fromMaybe False $ mplus (try' eitherDecode False) (try' decodeLisp True)
try' :: (ByteString -> Either String Value) -> Bool -> Maybe Bool
try' f l = either (const Nothing) (const $ Just l) $ f bstr
encodeMsg :: ToJSON a => Msg a -> ByteString
encodeMsg m
| view isLisp m = encodeLisp $ view msg m
| otherwise = encode $ view msg m
decodeMessage :: FromJSON a => ByteString -> Either (Msg String) (Msg (Message a))
decodeMessage = decodeMsg
encodeMessage :: ToJSON a => Msg (Message a) -> ByteString
encodeMessage = encodeMsg
processRequest :: SessionMonad m => CommandOptions -> Command -> m Result
processRequest copts c = do
c' <- paths (findPath copts) c
s <- getSession
withSession s $ Client.runClient copts $ Client.runCommand c'
processClient :: SessionMonad m => String -> F.Chan ByteString -> (ByteString -> IO ()) -> m ()
processClient name rchan send' = do
Log.sendLog Log.Info "connected"
respChan <- liftIO newChan
liftIO $ void $ forkIO $ getChanContents respChan >>= mapM_ (send' . encodeMessage)
linkVar <- liftIO $ newMVar $ return ()
s <- getSession
exit <- askSession sessionExit
let
answer :: SessionMonad m => Msg (Message Response) -> m ()
answer m = do
unless (isNotification $ view (msg . message) m) $
Log.sendLog Log.Trace $ "responsed << {}" ~~ ellipsis (fromUtf8 (encode $ view (msg . message) m))
liftIO $ writeChan respChan m
where
ellipsis :: String -> String
ellipsis str
| length str < 100 = str
| otherwise = take 100 str ++ "..."
reqs <- liftIO $ F.readChan rchan
flip finally (disconnected linkVar) $
forM_ reqs $ \req' -> do
Log.sendLog Log.Trace $ "received >> {}" ~~ fromUtf8 req'
case decodeMessage req' of
Left em -> do
Log.sendLog Log.Warning $ "Invalid request {}" ~~ fromUtf8 req'
answer $ set msg (Message Nothing $ responseError $ RequestError "invalid request" $ fromUtf8 req') em
Right m -> void $ liftIO $ forkIO $ withSession s $ Log.scope (T.pack name) $ Log.scope "req" $
Log.scope (T.pack $ fromMaybe "_" (view (msg . messageId) m)) $ do
resp' <- flip (traverseOf (msg . message)) m $ \(Request c cdir noFile tm silent) -> do
let
onNotify n
| silent = return ()
| otherwise = traverseOf (msg . message) (const $ mmap' noFile (Response $ Left n)) m >>= answer
Log.sendLog Log.Trace $ "requested >> {}" ~~ fromUtf8 (encode c)
resp <- liftIO $ fmap (Response . Right) $ handleTimeout tm $ hsdevLiftIO $ withSession s $
processRequest
CommandOptions {
commandOptionsRoot = cdir,
commandOptionsNotify = withSession s . onNotify,
commandOptionsLink = void (swapMVar linkVar exit),
commandOptionsHold = forever (F.getChan rchan) }
c
mmap' noFile resp
answer resp'
where
handleTimeout :: Int -> IO Result -> IO Result
handleTimeout 0 = id
handleTimeout tm = fmap (fromMaybe $ Error $ OtherError "timeout") . timeout 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' _ r = return r
disconnected :: SessionMonad m => MVar (IO ()) -> m ()
disconnected var = do
Log.sendLog Log.Info "disconnected"
liftIO $ join $ takeMVar var
processClientSocket :: SessionMonad m => String -> Socket -> m ()
processClientSocket name s = do
recvChan <- liftIO F.newChan
liftIO $ void $ forkIO $ finally
(Net.getContents s >>= mapM_ (F.putChan recvChan) . L.lines)
(F.closeChan recvChan)
processClient name recvChan (sendLine s)
where
sendLine :: Socket -> ByteString -> IO ()
sendLine sock bs = sendAll sock $ L.toStrict $ L.snoc bs '\n'
sendAll :: Socket -> BS.ByteString -> IO ()
sendAll sock bs
| BS.null bs = return ()
| otherwise = do
sent <- Net.send sock bs
when (sent > 0) $ sendAll sock (BS.drop sent bs)
#if mingw32_HOST_OS
data MmapFile = MmapFile String
instance ToJSON MmapFile where
toJSON (MmapFile f) = object ["file" .= f]
instance FromJSON MmapFile where
parseJSON = withObject "file" $ \v -> MmapFile <$> v .:: "file"
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
threadDelay 10000000)
(\_ -> liftIO $ void $ tryPutMVar rvar r)
takeMVar rvar
where
msg' = encode r
#endif
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 r = return r
makeSocket :: ConnectionPort -> IO Socket
makeSocket (NetworkPort _) = socket AF_INET Stream defaultProtocol
makeSocket (UnixPort _) = socket AF_UNIX Stream defaultProtocol
sockAddr :: ConnectionPort -> HostAddress -> SockAddr
sockAddr (NetworkPort p) addr = SockAddrInet (fromIntegral p) addr
sockAddr (UnixPort s) _ = SockAddrUnix s
unlink :: ConnectionPort -> IO ()
unlink (NetworkPort _) = return ()
#if mingw32_HOST_OS
unlink (UnixPort _) = return ()
#else
unlink (UnixPort s) = removeLink s
#endif