module Foreign.JavaScript.Types where
import Control.Applicative
import Control.Concurrent.STM as STM
import Control.Concurrent.Chan as Chan
import Control.Concurrent.MVar
import Control.DeepSeq
import Data.Aeson as JSON
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS (hPutStrLn)
import Data.IORef
import Data.Map as Map
import Data.String
import Data.Text
import System.IO (stderr)
import Foreign.RemotePtr
data Config = Config
{ jsPort :: Maybe Int
, jsAddr :: Maybe ByteString
, jsCustomHTML :: Maybe FilePath
, jsStatic :: Maybe FilePath
, jsLog :: ByteString -> IO ()
}
defaultPort :: Int
defaultPort = 8023
defaultAddr :: ByteString
defaultAddr = "127.0.0.1"
defaultConfig :: Config
defaultConfig = Config
{ jsPort = Nothing
, jsAddr = Nothing
, jsCustomHTML = Nothing
, jsStatic = Nothing
, jsLog = BS.hPutStrLn stderr
}
data Comm = Comm
{ commIn :: TQueue JSON.Value
, commOut :: TQueue JSON.Value
, commClose :: IO ()
}
writeComm :: Comm -> JSON.Value -> STM ()
writeComm c = STM.writeTQueue (commOut c)
readComm :: Comm -> STM JSON.Value
readComm c = STM.readTQueue (commIn c)
data ClientMsg
= Event Coupon JSON.Value
| Result JSON.Value
| Quit
deriving (Eq, Show)
instance FromJSON ClientMsg where
parseJSON (Object msg) = do
tag <- msg .: "tag"
case (tag :: Text) of
"Event" ->
Event <$> (msg .: "name") <*> (msg .: "arguments")
"Result" ->
Result <$> (msg .: "contents")
"Quit" ->
return Quit
readClient :: Comm -> STM ClientMsg
readClient c = do
msg <- readComm c
case JSON.fromJSON msg of
Error s -> error $ "Foreign.JavaScript: Error parsing client message " ++ show s
Success x -> return x
data ServerMsg
= RunEval String
| CallEval String
| Debug String
deriving (Eq,Show)
instance NFData ServerMsg where
rnf (RunEval x) = rnf x
rnf (CallEval x) = rnf x
rnf (Debug x) = rnf x
instance ToJSON ServerMsg where
toJSON (Debug x) = object [ "tag" .= t "Debug" , "contents" .= toJSON x]
toJSON (RunEval x) = object [ "tag" .= t "RunEval" , "contents" .= toJSON x]
toJSON (CallEval x) = object [ "tag" .= t "CallEval", "contents" .= toJSON x]
t s = fromString s :: Text
writeServer :: Comm -> ServerMsg -> STM ()
writeServer c = writeComm c . toJSON . force
data Consistency = Consistent | Inconsistent
type Event = (Coupon, JSON.Value, Consistency)
type HsEvent = RemotePtr (JSON.Value -> IO ())
quit :: Event
quit = ("quit", JSON.Null, Consistent)
data Window = Window
{ runEval :: String -> IO ()
, callEval :: String -> IO JSON.Value
, debug :: String -> IO ()
, onDisconnect :: IO () -> IO ()
, wRoot :: RemotePtr ()
, wEventHandlers :: Vendor (JSON.Value -> IO ())
, wJSObjects :: Vendor JSPtr
}
newPartialWindow :: IO Window
newPartialWindow = do
ptr <- newRemotePtr "" () =<< newVendor
let nop = const $ return ()
Window nop undefined nop nop ptr <$> newVendor <*> newVendor
root :: Window -> RemotePtr ()
root = wRoot
newtype JSPtr = JSPtr { unsJSPtr :: Coupon }
type JSObject = RemotePtr JSPtr