1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | A version of REPL that interacts through a websocket.
module Minilang.REPL.Net where
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar
( newTVarIO, readTVarIO, writeTVar, TVar )
import Control.Monad.Catch ( MonadThrow(..), MonadCatch(..) )
import Control.Monad.State
( MonadIO(..),
MonadTrans(..),
MonadState,
StateT(StateT),
evalStateT,
gets )
import Data.Aeson
( ToJSON,
eitherDecode,
encode,
object,
(.=),
)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LBS
import Data.Either (fromRight)
import Data.Map as Map ( Map )
import Data.Serialize
( getLazyByteString,
getWord64be,
putLazyByteString,
putWord64be,
Serialize(..) )
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Minilang.Log ( LoggerEnv(logInfo) )
import Minilang.REPL.Pure (render)
import Minilang.REPL.Run (runREPL)
import Minilang.REPL.Types
( initialREPL, In(In), MonadREPL(..), Out, REPLEnv )
import Network.Wai (Application)
import Network.Wai.Handler.WebSockets ( websocketsOr )
import qualified Network.WebSockets as WS
-- | Configuration of the WS server
data ServerConfig = ServerConfig
{ -- | The host/IP to listen on. If 0.0.0.0, then the server listens
configHost :: String,
-- | The port to listen on. If 0, a random port will be assigned.
configPort :: Int
}
deriving (Eq, Show)
data NetEnv = NetEnv
{ connection :: WS.Connection,
logger :: LoggerEnv IO,
repl :: TVar REPLEnv
-- , storage :: FileStorage
}
newtype Net m a = Net {runNet :: StateT NetEnv m a}
deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MonadState NetEnv)
instance Serialize In where
put out = do
let bs = encode out
putWord64be (fromIntegral $ LBS.length bs)
putLazyByteString bs
get = do
len <- getWord64be
bs <- getLazyByteString (fromIntegral len)
case eitherDecode bs of
Right out -> pure out
Left err -> fail err
-- doStore :: In -> Net IO (Either Text ())
-- doStore out = do
-- fs <- gets storage
-- res <- liftIO $ store fs (pure $ Right out) handleStorageResult
-- case res of
-- WriteSucceed _ -> pure $ Right ()
-- err -> pure $ Left (pack $ show err)
-- where
-- handleStorageResult (Right (WriteSucceed _)) = pure $ Right ()
-- handleStorageResult (Right err) = pure $ Left $ pack $ show err
-- handleStorageResult (Left err) = pure $ Left $ pack err
netLog :: (ToJSON a) => a -> Net IO ()
netLog logEntry = gets logger >>= liftIO . flip logInfo logEntry
instance MonadREPL (Net IO) where
input = do
inp <- gets connection >>= lift . wsReceive
-- res <- doStore inp
-- case res of
-- Right () -> netLog (object ["action" .= ("input" :: Text), "content" .= inp])
-- Left txt -> netLog (object ["action" .= ("storageError" :: Text), "content" .= txt])
netLog (object ["action" .= ("input" :: Text), "content" .= inp])
pure inp
output a = do
gets connection >>= lift . wsSend a
netLog
( object
[ "action" .= ("output" :: Text),
"content" .= a,
"rendered" .= render a
]
)
prompt = pure ()
getEnv = gets repl >>= lift . readTVarIO
setEnv e' = gets repl >>= lift . atomically . flip writeTVar e'
-- TODO what does this mean? perhaps it coiuld be used to load some
-- virtual files edited by user in their env?
load = const (pure (Right ""))
instance (MonadThrow m) => MonadThrow (Net m) where
throwM = lift . throwM
instance (MonadCatch m) => MonadCatch (Net m) where
Net m `catch` f = Net $ m `catch` \e -> runNet (f e)
-- instance TypeChecker (Net IO) where
-- emit (CheckD ev) = gets logger >>= \env -> liftIO $ logInfo env ev
-- emit _ = pure ()
wsReceive :: WS.Connection -> IO In
wsReceive cnx =
fromRight (In "") . eitherDecode <$> WS.receiveData cnx
wsSend :: Out -> WS.Connection -> IO ()
wsSend out cnx =
WS.sendBinaryData cnx (encode out)
safeDecodeUtf8 :: ByteString -> Text
safeDecodeUtf8 = decodeUtf8With lenientDecode
clientHandler :: LoggerEnv IO -> TVar (Map ByteString (TVar REPLEnv)) -> WS.PendingConnection -> IO ()
clientHandler loggerEnv envs cnx = do
let path = WS.requestPath $ WS.pendingRequest cnx
logInfo loggerEnv $ object ["action" .= ("StartedREPL" :: Text), "path" .= safeDecodeUtf8 path]
conn <- WS.acceptRequest cnx
-- storageFile <- mkStorageFile path
-- withStorage storageFile $ \fileStorage -> do
replEnv <- newREPLEnv
WS.withPingThread conn 30 (pure ()) $
evalStateT (runNet runREPL) (NetEnv conn loggerEnv replEnv)
where
newREPLEnv = newTVarIO initialREPL
-- findOrCreateREPL :: (H.Store IO store) => store -> ByteString -> IO (TVar REPLEnv)
-- findOrCreateREPL storageFile path = do
-- (env, shouldLoad) <- atomically $ do
-- envMaps <- readTVar envs
-- (newEnv, shouldLoad) <- case Map.lookup path envMaps of
-- Nothing -> newTVar initialREPL >>= \v -> pure (v, True)
-- Just e -> pure (e, False)
-- writeTVar envs (Map.insert path newEnv envMaps)
-- pure (newEnv, shouldLoad)
-- -- FIXME there is a race condition here
-- if shouldLoad
-- then replay storageFile env
-- else pure env
-- mkStorageFile path = do
-- let f = takeFileName (unpack (safeDecodeUtf8 path))
-- dir <- getCurrentDirectory
-- pure $ defaultOptions {storageFilePath = dir </> f}
-- replay :: (H.Store IO store) => store -> TVar REPLEnv -> IO (TVar REPLEnv)
-- replay storage envVar = do
-- res <- H.load storage
-- case res of
-- LoadSucceed coms -> do
-- atomically $ do
-- env <- readTVar envVar
-- let newEnv = withInputs env coms
-- writeTVar envVar (purerREPL newEnv)
-- logInfo loggerEnv $
-- object
-- [ "action" .= ("Loaded" :: Text),
-- "numCommands" .= length coms
-- ]
-- pure envVar
-- err -> do
-- logInfo loggerEnv $ object ["action" .= ("ErrorLoading" :: Text), "error" .= pack (show err)]
-- pure envVar
runNetREPL :: LoggerEnv IO -> TVar (Map ByteString (TVar REPLEnv)) -> Application -> Application
runNetREPL loggerEnv envs = websocketsOr WS.defaultConnectionOptions (clientHandler loggerEnv envs)
|
