cryptol-2.3.0: cryptol-server/Main.hs
-- |
-- Module : $Header$
-- Copyright : (c) 2015-2016 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
--
-- Alpha version of a Cryptol server that communicates via JSON over
-- ZeroMQ. This API is highly unstable and extremely likely to change
-- in the near future.
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wall -fno-warn-type-defaults #-}
module Main where
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Control
import qualified Control.Exception as X
import Data.Aeson
import Data.Aeson.Encode.Pretty
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.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
import qualified Cryptol.Eval.Value as E
import Cryptol.REPL.Command
import Cryptol.REPL.Monad
import Cryptol.Symbolic (ProverResult(..))
import qualified Cryptol.Testing.Concrete as Test
import qualified Cryptol.TypeCheck.AST as T
import qualified Cryptol.ModuleSystem as M
import Cryptol.Utils.PP hiding ((<>))
import Cryptol.Aeson ()
import Prelude ()
import Prelude.Compat
data RCommand
= RCEvalExpr Text
| RCApplyFun FunHandle E.Value
| RCTypeOf Text
| RCSetOpt Text Text
| RCCheck Text
| RCExhaust Text
| RCProve Text
| RCSat Text
| RCLoadPrelude
| RCLoadModule FilePath
| RCDecls
| RCUnknownCmd Text
| RCExit
instance FromJSON RCommand where
parseJSON = withObject "RCommand" $ \o -> do
tag <- o .: "tag"
flip (withText "tag") tag $ \case
"evalExpr" -> RCEvalExpr <$> o .: "expr"
"applyFun" -> RCApplyFun <$> o .: "handle" <*> o .: "arg"
"typeOf" -> RCTypeOf <$> o .: "expr"
"setOpt" -> RCSetOpt <$> o .: "key" <*> o .: "value"
"check" -> RCCheck <$> o .: "expr"
"exhaust" -> RCExhaust <$> o .: "expr"
"prove" -> RCProve <$> o .: "expr"
"sat" -> RCSat <$> o .: "expr"
"loadPrelude" -> return RCLoadPrelude
"loadModule" -> RCLoadModule . T.unpack <$> o .: "filePath"
"browse" -> return RCDecls
"exit" -> return RCExit
unknown -> return (RCUnknownCmd unknown)
newtype FunHandle = FH Int
deriving (Eq, Ord, Enum, Bounded, Show)
instance ToJSON FunHandle where
toJSON (FH i) = toJSON i
instance FromJSON FunHandle where
parseJSON v = FH <$> parseJSON v
data RResult
= RRValue E.Value
| RRFunValue FunHandle T.Type
| RRType T.Schema String -- pretty-printed type
| RRDecls M.IfaceDecls
| RRCheck [Test.TestReport]
| RRExhaust [Test.TestReport]
| RRSat [[E.Value]]
-- ^ A list of satisfying assignments. Empty list means unsat, max
-- length determined by @satNum@ interpreter option
| RRProve (Maybe [E.Value])
-- ^ Counterexample if invalid or 'Nothing' if valid
| RRProverError String
| RRInteractiveError REPLException String -- pretty-printed exception
| RRUnknownCmd Text
| RRBadMessage BS.ByteString String
| RROk
| RRInterrupted
instance ToJSON RResult where
toJSON = \case
RRValue v -> object
[ "tag" .= "value", "value" .= v ]
RRFunValue fh t -> object
[ "tag" .= "funValue", "handle" .= fh, "type" .= t ]
RRType s pps -> object
[ "tag" .= "type", "value" .= s, "pp" .= pps ]
RRDecls ifds -> object
[ "tag" .= "decls", "decls" .= ifds ]
RRCheck out -> object
[ "tag" .= "check", "testReport" .= out ]
RRExhaust out -> object
[ "tag" .= "exhaust", "testReport" .= out ]
RRSat out -> object
[ "tag" .= "sat", "assignments" .= out ]
RRProve out -> object
[ "tag" .= "prove", "counterexample" .= out ]
RRProverError msg -> object
[ "tag" .= "proverError", "message" .= msg ]
RRInteractiveError err pps -> object
[ "tag" .= "interactiveError", "error" .= err, "pp" .= pps ]
RRUnknownCmd txt -> object
[ "tag" .= "unknownCommand", "command" .= txt ]
RRBadMessage msg err -> object
[ "tag" .= "badMessage", "message" .= BS.unpack msg, "error" .= err ]
RROk -> object
[ "tag" .= "ok" ]
RRInterrupted -> object
[ "tag" .= "interrupted" ]
data ControlMsg
= CMConnect
-- ^ Request a new Cryptol context and connection
| CMInterrupt Word16
-- ^ Request an interrupt of all current Cryptol contexts
| CMExit
-- ^ Request that the entire server shut down
| CMUnknown Text
-- ^ Unknown message
instance FromJSON ControlMsg where
parseJSON = withObject "ControlMsg" $ \o -> do
tag <- o .: "tag"
flip (withText "tag") tag $ \case
"connect" -> return CMConnect
"interrupt" -> CMInterrupt <$> o .: "port"
"exit" -> return CMExit
other -> return $ CMUnknown other
data ControlReply
= CRConnect Word16
-- ^ Return the port for a new connection
| CRInterrupted
-- ^ Acknowledge receipt of an interrupt command
| CRExiting
-- ^ Acknowledge receipt of an exit command
| CRBadMessage BS.ByteString String
-- ^ Acknowledge receipt of an ill-formed control message
instance ToJSON ControlReply where
toJSON = \case
CRConnect port -> object
[ "tag" .= "connect", "port" .= port ]
CRInterrupted -> object
[ "tag" .= "interrupted" ]
CRExiting -> object
[ "tag" .= "exiting" ]
CRBadMessage msg err -> object
[ "tag" .= "badMessage", "message" .= BS.unpack msg, "error" .= err ]
server :: Word16 -> IO ()
server port =
withContext $ \ctx ->
withSocket ctx Rep $ \rep -> do
let addr = "tcp://127.0.0.1:" ++ show port
putStrLn ("[cryptol-server] coming online at " ++ addr)
bind rep addr
workers <- newIORef Map.empty
let loop = do
msg <- receive rep
putStrLn "[cryptol-server] received message:"
case decodeStrict msg of
Nothing -> BS.putStrLn msg
Just js -> BSL.putStrLn (encodePretty (js :: Value))
case eitherDecodeStrict msg of
Left err -> reply rep $ CRBadMessage msg err
Right CMConnect -> do
putStrLn "[cryptol-server] handling new incoming connection"
newRep <- socket ctx Rep
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) (removeWorker workers port)
addNewWorker workers workerPort tid
reply rep $ CRConnect workerPort
Right (CMInterrupt port') -> do
s <- readIORef workers
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
exitSuccess
Right (CMUnknown cmd) -> do
putStrLn ("[cryptol-server] unknown control command: " ++ T.unpack cmd)
reply rep $ CRBadMessage msg "unknown control command"
loop
loop
reply :: (ToJSON a, MonadIO m) => Socket Rep -> a -> m ()
reply rep msg = liftIO $ do
let bmsg = BS.concat . BSL.toChunks . encodePretty $ msg
putStrLn "[cryptol-server] sending response:"
BS.putStrLn bmsg
send rep [] bmsg
addNewWorker :: IORef (Map Word16 ThreadId) -> Word16 -> ThreadId -> IO ()
addNewWorker workers port tid =
atomicModifyIORef workers $ \s -> (Map.insert port 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?
mCryptolPath <- io $ lookupEnv "CRYPTOLPATH"
case mCryptolPath of
Nothing -> return ()
Just path -> prependSearchPath path'
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
-- Windows paths search from end to beginning
where path' = reverse (splitSearchPath path)
#else
where path' = splitSearchPath path
#endif
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 RRInterrupted
loop = liftBaseWith $ \run -> X.handle handleAsync $ run $ do
msg <- io $ receive rep
io $ putStrLn "[cryptol-worker] received message:"
case decodeStrict msg of
Nothing -> io $ BS.putStrLn msg
Just js -> io $ BSL.putStrLn (encodePretty (js :: Value))
flip catch handle $ case eitherDecodeStrict msg of
Left cmdErr -> reply rep (RRBadMessage msg cmdErr)
Right rc -> case rc of
RCEvalExpr txt -> do
expr <- replParseExpr (T.unpack txt)
(val, ty) <- replEvalExpr expr
case val of
E.VFun f -> do
fh <- io $ atomicModifyIORef' funHandles $ \(m, fh) ->
let m' = Map.insert fh f m
fh' = succ fh
in ((m', fh'), fh)
reply rep (RRFunValue fh ty)
_ -> reply rep (RRValue val)
RCApplyFun fh arg -> do
(m, _) <- io $ readIORef funHandles
case Map.lookup fh m of
Nothing -> reply rep (RRBadMessage "invalid function handle" (show fh))
Just f -> do
case f arg of
E.VFun g -> do
gh <- io $ atomicModifyIORef' funHandles $ \(m', gh) ->
let m'' = Map.insert gh g m'
gh' = succ gh
in ((m'', gh'), gh)
-- TODO: bookkeeping to track the type of this value
reply rep (RRFunValue gh T.tZero)
val -> reply rep (RRValue val)
RCTypeOf txt -> do
expr <- replParseExpr (T.unpack txt)
(_expr, _def, sch) <- replCheckExpr expr
reply rep (RRType sch (show (pp sch)))
RCSetOpt key val -> do
setOptionCmd (T.unpack key ++ "=" ++ T.unpack val)
reply rep RROk
RCCheck expr -> do
reports <- qcCmd QCRandom (T.unpack expr)
reply rep (RRCheck reports)
RCExhaust expr -> do
reports <- qcCmd QCExhaust (T.unpack expr)
reply rep (RRExhaust reports)
RCProve expr -> do
result <- onlineProveSat False (T.unpack expr) Nothing
case result of
AllSatResult [cex] ->
reply rep (RRProve (Just (map (\(_,_,v) -> v) cex)))
ThmResult _ ->
reply rep (RRProve Nothing)
ProverError err ->
reply rep (RRProverError err)
_ ->
reply rep (RRProverError "unexpected prover result")
RCSat expr -> do
result <- onlineProveSat True (T.unpack expr) Nothing
case result of
AllSatResult sas ->
reply rep (RRSat (map (map (\(_,_,v) -> v)) sas))
ThmResult _ ->
reply rep (RRSat [])
ProverError err ->
reply rep (RRProverError err)
_ ->
reply rep (RRProverError "unexpected prover result")
RCLoadPrelude -> do
loadPrelude
reply rep RROk
RCLoadModule fp -> do
loadCmd fp
reply rep RROk
RCDecls -> do
(decls, _namingEnv, _nameDisp) <- getFocusedEnv
reply rep (RRDecls decls)
RCUnknownCmd cmd -> reply rep (RRUnknownCmd cmd)
RCExit -> do
reply rep RROk
io $ close rep
io $ putStrLn "[cryptol-worker] shutting down"
void $ forever loop
withCapturedOutput :: REPL a -> REPL (a, String)
withCapturedOutput m = do
old <- getPutStr
buf <- io $ newIORef ""
setPutStr $ \s -> modifyIORef' buf (++ s)
x <- m
s <- io $ readIORef buf
setPutStr old
return (x, s)
data Server = Server { serverPort :: Word16
, serverMaskSIGINT :: Bool }
deriving Show
main :: IO ()
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