mirror of
https://github.com/GaloisInc/cryptol.git
synced 2024-11-28 09:23:04 +03:00
refine interrupt behavior
In order to prevent Ctrl-Cs in, e.g. Python from bringing down the server, there's now an option to swallow SIGINT when launching the server.
This commit is contained in:
parent
563efcc25b
commit
04d62ae221
@ -14,6 +14,7 @@
|
||||
{-# LANGUAGE ExtendedDefaultRules #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# OPTIONS_GHC -Wall -fno-warn-type-defaults #-}
|
||||
module Main where
|
||||
|
||||
@ -28,15 +29,16 @@ import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.ByteString.Lazy.Char8 as BSL
|
||||
import Data.Char
|
||||
import Data.IORef
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Word
|
||||
import Options.Applicative
|
||||
import System.Environment
|
||||
import System.Exit
|
||||
import System.FilePath
|
||||
import System.Posix.Signals
|
||||
import System.ZMQ4
|
||||
import Text.Read
|
||||
|
||||
@ -148,7 +150,7 @@ instance ToJSON RResult where
|
||||
data ControlMsg
|
||||
= CMConnect
|
||||
-- ^ Request a new Cryptol context and connection
|
||||
| CMInterrupt
|
||||
| CMInterrupt Word16
|
||||
-- ^ Request an interrupt of all current Cryptol contexts
|
||||
| CMExit
|
||||
-- ^ Request that the entire server shut down
|
||||
@ -160,7 +162,7 @@ instance FromJSON ControlMsg where
|
||||
tag <- o .: "tag"
|
||||
flip (withText "tag") tag $ \case
|
||||
"connect" -> return CMConnect
|
||||
"interrupt" -> return CMInterrupt
|
||||
"interrupt" -> CMInterrupt <$> o .: "port"
|
||||
"exit" -> return CMExit
|
||||
other -> return $ CMUnknown other
|
||||
|
||||
@ -192,7 +194,7 @@ server port =
|
||||
let addr = "tcp://127.0.0.1:" ++ show port
|
||||
putStrLn ("[cryptol-server] coming online at " ++ addr)
|
||||
bind rep addr
|
||||
workers <- newIORef Set.empty
|
||||
workers <- newIORef Map.empty
|
||||
let loop = do
|
||||
msg <- receive rep
|
||||
putStrLn "[cryptol-server] received message:"
|
||||
@ -207,16 +209,18 @@ server port =
|
||||
bind newRep "tcp://127.0.0.1:*"
|
||||
newAddr <- lastEndpoint newRep
|
||||
let portStr = reverse . takeWhile isDigit . reverse $ newAddr
|
||||
workerPort = read portStr
|
||||
putStrLn ("[cryptol-server] starting worker on interface " ++ newAddr)
|
||||
tid <- forkFinally (runRepl newRep) (removeCurrentWorker workers)
|
||||
addNewWorker workers tid
|
||||
reply rep $ CRConnect (read portStr)
|
||||
Right CMInterrupt -> do
|
||||
tid <- forkFinally (runRepl newRep) (removeWorker workers port)
|
||||
addNewWorker workers workerPort tid
|
||||
reply rep $ CRConnect workerPort
|
||||
Right (CMInterrupt port') -> do
|
||||
s <- readIORef workers
|
||||
-- TODO: only throw to the relevant worker; we'll need
|
||||
-- port number from request
|
||||
forM_ s $ \tid -> throwTo tid X.UserInterrupt
|
||||
reply rep $ CRInterrupted
|
||||
case Map.lookup port' s of
|
||||
Nothing -> reply rep $ CRBadMessage msg "invalid worker port"
|
||||
Just tid -> do
|
||||
throwTo tid X.UserInterrupt
|
||||
reply rep $ CRInterrupted
|
||||
Right CMExit -> do
|
||||
putStrLn "[cryptol-server] shutting down"
|
||||
reply rep $ CRExiting
|
||||
@ -234,14 +238,13 @@ reply rep msg = liftIO $ do
|
||||
BS.putStrLn bmsg
|
||||
send rep [] bmsg
|
||||
|
||||
addNewWorker :: IORef (Set ThreadId) -> ThreadId -> IO ()
|
||||
addNewWorker workers tid =
|
||||
atomicModifyIORef workers $ \s -> (Set.insert tid s, ())
|
||||
addNewWorker :: IORef (Map Word16 ThreadId) -> Word16 -> ThreadId -> IO ()
|
||||
addNewWorker workers port tid =
|
||||
atomicModifyIORef workers $ \s -> (Map.insert port tid s, ())
|
||||
|
||||
removeCurrentWorker :: IORef (Set ThreadId) -> a -> IO ()
|
||||
removeCurrentWorker workers _result = do
|
||||
tid <- myThreadId
|
||||
atomicModifyIORef workers $ \s -> (Set.delete tid s, ())
|
||||
removeWorker :: IORef (Map Word16 ThreadId) -> Word16 -> a -> IO ()
|
||||
removeWorker workers port _result =
|
||||
atomicModifyIORef workers $ \s -> (Map.delete port s, ())
|
||||
|
||||
runRepl :: Socket Rep -> IO ()
|
||||
runRepl rep = runREPL False $ do -- TODO: batch mode?
|
||||
@ -258,7 +261,7 @@ runRepl rep = runREPL False $ do -- TODO: batch mode?
|
||||
funHandles <- io $ newIORef (Map.empty, minBound :: FunHandle)
|
||||
let handle err = reply rep (RRInteractiveError err (show (pp err)))
|
||||
handleAsync :: X.AsyncException -> IO ()
|
||||
handleAsync _int = reply rep RROk
|
||||
handleAsync _int = reply rep RRInterrupted
|
||||
loop = liftBaseWith $ \run -> X.handle handleAsync $ run $ do
|
||||
msg <- io $ receive rep
|
||||
io $ putStrLn "[cryptol-worker] received message:"
|
||||
@ -354,13 +357,29 @@ withCapturedOutput m = do
|
||||
setPutStr old
|
||||
return (x, s)
|
||||
|
||||
data Server = Server { serverPort :: Word16
|
||||
, serverMaskSIGINT :: Bool }
|
||||
deriving Show
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
case args of
|
||||
[] -> server 5555
|
||||
[portStr] ->
|
||||
case readMaybe portStr of
|
||||
Just port -> server port
|
||||
Nothing -> server 5555
|
||||
_ -> error "port is the only allowed argument"
|
||||
main = execParser opts >>= mainWith
|
||||
where
|
||||
opts =
|
||||
info (helper <*> serverOpts)
|
||||
( fullDesc
|
||||
<> progDesc "Run Cryptol as a server via ZeroMQ and JSON"
|
||||
<> header "cryptol-server" )
|
||||
serverOpts =
|
||||
Server
|
||||
<$> option auto
|
||||
( long "port"
|
||||
<> short 'p'
|
||||
<> metavar "PORT"
|
||||
<> value 5555
|
||||
<> help "TCP port to bind" )
|
||||
<*> switch
|
||||
( long "mask-interrupts"
|
||||
<> help "Suppress interrupt signals" )
|
||||
mainWith Server {..} = do
|
||||
when serverMaskSIGINT $ void $ installHandler sigINT Ignore Nothing
|
||||
server serverPort
|
||||
|
@ -216,22 +216,24 @@ executable cryptol-server
|
||||
ghc-prof-options: -auto-all -prof -rtsopts
|
||||
if os(linux) && flag(static)
|
||||
ld-options: -static -pthread
|
||||
-- if flag(server)
|
||||
build-depends: aeson >= 0.10
|
||||
, aeson-pretty >= 0.7
|
||||
, base
|
||||
, base-compat
|
||||
, bytestring >= 0.10
|
||||
, containers
|
||||
, cryptol
|
||||
, filepath
|
||||
, monad-control
|
||||
, text
|
||||
, transformers
|
||||
, unordered-containers >= 0.2
|
||||
, zeromq4-haskell >= 0.6
|
||||
-- else
|
||||
-- buildable: False
|
||||
if flag(server)
|
||||
build-depends: aeson >= 0.10
|
||||
, aeson-pretty >= 0.7
|
||||
, base
|
||||
, base-compat
|
||||
, bytestring >= 0.10
|
||||
, containers
|
||||
, cryptol
|
||||
, filepath
|
||||
, monad-control
|
||||
, optparse-applicative
|
||||
, text
|
||||
, transformers
|
||||
, unix
|
||||
, unordered-containers >= 0.2
|
||||
, zeromq4-haskell >= 0.6
|
||||
else
|
||||
buildable: False
|
||||
|
||||
benchmark cryptol-bench
|
||||
type: exitcode-stdio-1.0
|
||||
|
@ -9,14 +9,14 @@
|
||||
{-# LANGUAGE Safe #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
module Cryptol.Utils.PP where
|
||||
module Cryptol.Utils.PP (module Cryptol.Utils.PP, (<>)) where
|
||||
|
||||
import Cryptol.Utils.Ident
|
||||
|
||||
import Control.DeepSeq.Generics
|
||||
import Control.Monad (mplus)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Monoid as M
|
||||
import Data.Monoid
|
||||
import Data.String (IsString(..))
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics (Generic)
|
||||
@ -36,7 +36,7 @@ instance NFData NameDisp where rnf = genericRnf
|
||||
instance Show NameDisp where
|
||||
show _ = "<NameDisp>"
|
||||
|
||||
instance M.Monoid NameDisp where
|
||||
instance Monoid NameDisp where
|
||||
mempty = EmptyNameDisp
|
||||
|
||||
mappend (NameDisp f) (NameDisp g) = NameDisp (\m n -> f m n `mplus` g m n)
|
||||
@ -70,7 +70,7 @@ fmtModName mn NotInScope = mn
|
||||
-- | Compose two naming environments, preferring names from the left
|
||||
-- environment.
|
||||
extend :: NameDisp -> NameDisp -> NameDisp
|
||||
extend = M.mappend
|
||||
extend = mappend
|
||||
|
||||
-- | Get the format for a name. When 'Nothing' is returned, the name is not
|
||||
-- currently in scope.
|
||||
@ -91,19 +91,23 @@ fixNameDisp disp (Doc f) = Doc (\ _ -> f disp)
|
||||
|
||||
newtype Doc = Doc (NameDisp -> PJ.Doc) deriving (Generic)
|
||||
|
||||
instance Monoid Doc where
|
||||
mempty = liftPJ PJ.empty
|
||||
mappend = liftPJ2 (PJ.<>)
|
||||
|
||||
instance NFData Doc where rnf = genericRnf
|
||||
|
||||
runDoc :: NameDisp -> Doc -> PJ.Doc
|
||||
runDoc names (Doc f) = f names
|
||||
|
||||
instance Show Doc where
|
||||
show d = show (runDoc M.mempty d)
|
||||
show d = show (runDoc mempty d)
|
||||
|
||||
instance IsString Doc where
|
||||
fromString = text
|
||||
|
||||
render :: Doc -> String
|
||||
render d = PJ.render (runDoc M.mempty d)
|
||||
render d = PJ.render (runDoc mempty d)
|
||||
|
||||
class PP a where
|
||||
ppPrec :: Int -> a -> Doc
|
||||
@ -197,9 +201,6 @@ liftPJ2 f (Doc a) (Doc b) = Doc (\e -> f (a e) (b e))
|
||||
liftSep :: ([PJ.Doc] -> PJ.Doc) -> ([Doc] -> Doc)
|
||||
liftSep f ds = Doc (\e -> f [ d e | Doc d <- ds ])
|
||||
|
||||
(<>) :: Doc -> Doc -> Doc
|
||||
(<>) = liftPJ2 (PJ.<>)
|
||||
|
||||
(<+>) :: Doc -> Doc -> Doc
|
||||
(<+>) = liftPJ2 (PJ.<+>)
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user