{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
module Foreign.JavaScript.Types where
import Control.Applicative
import qualified Control.Exception as E
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 Data.Typeable
import Snap.Core (Cookie(..))
import System.IO (stderr)
import Foreign.RemotePtr
data Config = Config
{ Config -> Maybe Int
jsPort :: Maybe Int
, Config -> Maybe ByteString
jsAddr :: Maybe ByteString
, Config -> Maybe FilePath
jsCustomHTML :: Maybe FilePath
, Config -> Maybe FilePath
jsStatic :: Maybe FilePath
, Config -> ByteString -> IO ()
jsLog :: ByteString -> IO ()
, Config -> Bool
jsWindowReloadOnDisconnect :: Bool
, Config -> CallBufferMode
jsCallBufferMode :: CallBufferMode
}
defaultPort :: Int
defaultPort :: Int
defaultPort = Int
8023
defaultAddr :: ByteString
defaultAddr :: ByteString
defaultAddr = ByteString
"127.0.0.1"
defaultConfig :: Config
defaultConfig :: Config
defaultConfig = Config :: Maybe Int
-> Maybe ByteString
-> Maybe FilePath
-> Maybe FilePath
-> (ByteString -> IO ())
-> Bool
-> CallBufferMode
-> Config
Config
{ jsPort :: Maybe Int
jsPort = Maybe Int
forall a. Maybe a
Nothing
, jsAddr :: Maybe ByteString
jsAddr = Maybe ByteString
forall a. Maybe a
Nothing
, jsWindowReloadOnDisconnect :: Bool
jsWindowReloadOnDisconnect = Bool
True
, jsCustomHTML :: Maybe FilePath
jsCustomHTML = Maybe FilePath
forall a. Maybe a
Nothing
, jsStatic :: Maybe FilePath
jsStatic = Maybe FilePath
forall a. Maybe a
Nothing
, jsLog :: ByteString -> IO ()
jsLog = Handle -> ByteString -> IO ()
BS.hPutStrLn Handle
stderr
, jsCallBufferMode :: CallBufferMode
jsCallBufferMode = CallBufferMode
FlushOften
}
type URI = String
type MimeType = String
data Server = Server
{ Server -> MVar Filepaths
sFiles :: MVar Filepaths
, Server -> MVar Filepaths
sDirs :: MVar Filepaths
, Server -> ByteString -> IO ()
sLog :: ByteString -> IO ()
}
type Filepaths = (Integer, Map ByteString (FilePath, MimeType))
newFilepaths :: (Integer, Map k a)
newFilepaths = (Integer
0, Map k a
forall k a. Map k a
Map.empty)
data Comm = Comm
{ Comm -> TQueue Value
commIn :: TQueue JSON.Value
, Comm -> TQueue Value
commOut :: TQueue JSON.Value
, Comm -> TVar Bool
commOpen :: TVar Bool
, Comm -> IO ()
commClose :: IO ()
}
writeComm :: Comm -> JSON.Value -> STM ()
writeComm :: Comm -> Value -> STM ()
writeComm Comm
c = TQueue Value -> Value -> STM ()
forall a. TQueue a -> a -> STM ()
STM.writeTQueue (Comm -> TQueue Value
commOut Comm
c)
readComm :: Comm -> STM JSON.Value
readComm :: Comm -> STM Value
readComm Comm
c = TQueue Value -> STM Value
forall a. TQueue a -> STM a
STM.readTQueue (Comm -> TQueue Value
commIn Comm
c)
data ClientMsg
= Event Coupon JSON.Value
| Result JSON.Value
| Exception String
| Quit
deriving (ClientMsg -> ClientMsg -> Bool
(ClientMsg -> ClientMsg -> Bool)
-> (ClientMsg -> ClientMsg -> Bool) -> Eq ClientMsg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClientMsg -> ClientMsg -> Bool
$c/= :: ClientMsg -> ClientMsg -> Bool
== :: ClientMsg -> ClientMsg -> Bool
$c== :: ClientMsg -> ClientMsg -> Bool
Eq, Int -> ClientMsg -> ShowS
[ClientMsg] -> ShowS
ClientMsg -> FilePath
(Int -> ClientMsg -> ShowS)
-> (ClientMsg -> FilePath)
-> ([ClientMsg] -> ShowS)
-> Show ClientMsg
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ClientMsg] -> ShowS
$cshowList :: [ClientMsg] -> ShowS
show :: ClientMsg -> FilePath
$cshow :: ClientMsg -> FilePath
showsPrec :: Int -> ClientMsg -> ShowS
$cshowsPrec :: Int -> ClientMsg -> ShowS
Show)
instance FromJSON ClientMsg where
parseJSON :: Value -> Parser ClientMsg
parseJSON (Object Object
msg) = do
Text
tag <- Object
msg Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"tag"
case (Text
tag :: Text) of
Text
"Event" -> Text -> Value -> ClientMsg
Event (Text -> Value -> ClientMsg)
-> Parser Text -> Parser (Value -> ClientMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
msg Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"name") Parser (Value -> ClientMsg) -> Parser Value -> Parser ClientMsg
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
msg Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"arguments")
Text
"Result" -> Value -> ClientMsg
Result (Value -> ClientMsg) -> Parser Value -> Parser ClientMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
msg Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"contents")
Text
"Exception" -> FilePath -> ClientMsg
Exception (FilePath -> ClientMsg) -> Parser FilePath -> Parser ClientMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
msg Object -> Text -> Parser FilePath
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"contents")
Text
"Quit" -> ClientMsg -> Parser ClientMsg
forall (m :: * -> *) a. Monad m => a -> m a
return ClientMsg
Quit
readClient :: Comm -> STM ClientMsg
readClient :: Comm -> STM ClientMsg
readClient Comm
c = do
Value
msg <- Comm -> STM Value
readComm Comm
c
case Value -> Result ClientMsg
forall a. FromJSON a => Value -> Result a
JSON.fromJSON Value
msg of
Error FilePath
s -> FilePath -> STM ClientMsg
forall a. HasCallStack => FilePath -> a
error (FilePath -> STM ClientMsg) -> FilePath -> STM ClientMsg
forall a b. (a -> b) -> a -> b
$ FilePath
"Foreign.JavaScript: Error parsing client message " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> FilePath
show FilePath
s
Success ClientMsg
x -> ClientMsg -> STM ClientMsg
forall (m :: * -> *) a. Monad m => a -> m a
return ClientMsg
x
data ServerMsg
= RunEval String
| CallEval String
| Debug String
| Timestamp
deriving (ServerMsg -> ServerMsg -> Bool
(ServerMsg -> ServerMsg -> Bool)
-> (ServerMsg -> ServerMsg -> Bool) -> Eq ServerMsg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ServerMsg -> ServerMsg -> Bool
$c/= :: ServerMsg -> ServerMsg -> Bool
== :: ServerMsg -> ServerMsg -> Bool
$c== :: ServerMsg -> ServerMsg -> Bool
Eq,Int -> ServerMsg -> ShowS
[ServerMsg] -> ShowS
ServerMsg -> FilePath
(Int -> ServerMsg -> ShowS)
-> (ServerMsg -> FilePath)
-> ([ServerMsg] -> ShowS)
-> Show ServerMsg
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ServerMsg] -> ShowS
$cshowList :: [ServerMsg] -> ShowS
show :: ServerMsg -> FilePath
$cshow :: ServerMsg -> FilePath
showsPrec :: Int -> ServerMsg -> ShowS
$cshowsPrec :: Int -> ServerMsg -> ShowS
Show)
instance NFData ServerMsg where
rnf :: ServerMsg -> ()
rnf (RunEval FilePath
x) = FilePath -> ()
forall a. NFData a => a -> ()
rnf FilePath
x
rnf (CallEval FilePath
x) = FilePath -> ()
forall a. NFData a => a -> ()
rnf FilePath
x
rnf (Debug FilePath
x) = FilePath -> ()
forall a. NFData a => a -> ()
rnf FilePath
x
rnf (ServerMsg
Timestamp ) = ()
instance ToJSON ServerMsg where
toJSON :: ServerMsg -> Value
toJSON (Debug FilePath
x) = [Pair] -> Value
object [ Text
"tag" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= FilePath -> Text
t FilePath
"Debug" , Text
"contents" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= FilePath -> Value
forall a. ToJSON a => a -> Value
toJSON FilePath
x]
toJSON (ServerMsg
Timestamp ) = [Pair] -> Value
object [ Text
"tag" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= FilePath -> Text
t FilePath
"Timestamp" ]
toJSON (RunEval FilePath
x) = [Pair] -> Value
object [ Text
"tag" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= FilePath -> Text
t FilePath
"RunEval" , Text
"contents" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= FilePath -> Value
forall a. ToJSON a => a -> Value
toJSON FilePath
x]
toJSON (CallEval FilePath
x) = [Pair] -> Value
object [ Text
"tag" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= FilePath -> Text
t FilePath
"CallEval", Text
"contents" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= FilePath -> Value
forall a. ToJSON a => a -> Value
toJSON FilePath
x]
t :: FilePath -> Text
t FilePath
s = FilePath -> Text
forall a. IsString a => FilePath -> a
fromString FilePath
s :: Text
writeServer :: Comm -> ServerMsg -> STM ()
writeServer :: Comm -> ServerMsg -> STM ()
writeServer Comm
c = Comm -> Value -> STM ()
writeComm Comm
c (Value -> STM ()) -> (ServerMsg -> Value) -> ServerMsg -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerMsg -> Value
forall a. ToJSON a => a -> Value
toJSON (ServerMsg -> Value)
-> (ServerMsg -> ServerMsg) -> ServerMsg -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerMsg -> ServerMsg
forall a. NFData a => a -> a
force
data JavaScriptException = JavaScriptException String deriving Typeable
instance E.Exception JavaScriptException
instance Show JavaScriptException where
showsPrec :: Int -> JavaScriptException -> ShowS
showsPrec Int
_ (JavaScriptException FilePath
err) = FilePath -> ShowS
showString (FilePath -> ShowS) -> FilePath -> ShowS
forall a b. (a -> b) -> a -> b
$ FilePath
"JavaScript error: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
err
type Event = (Coupon, JSON.Value)
type HsEvent = RemotePtr (JSON.Value -> IO ())
quit :: Event
quit :: Pair
quit = (Text
"quit", Value
JSON.Null)
data CallBufferMode
= NoBuffering
| BufferRun
| FlushOften
| FlushPeriodically
flushPeriod :: Int
flushPeriod = Int
300 :: Int
type EventLoop = Server -> RequestInfo -> Comm -> IO ()
type RequestInfo = [Cookie]
data Window = Window
{ Window -> Server
getServer :: Server
, Window -> [Cookie]
getCookies :: [Cookie]
, Window -> FilePath -> IO ()
runEval :: String -> IO ()
, Window -> FilePath -> IO Value
callEval :: String -> IO JSON.Value
, Window -> TVar ShowS
wCallBuffer :: TVar (String -> String)
, Window -> TVar CallBufferMode
wCallBufferMode :: TVar CallBufferMode
, Window -> IO ()
timestamp :: IO ()
, Window -> FilePath -> IO ()
debug :: String -> IO ()
, Window -> IO () -> IO ()
onDisconnect :: IO () -> IO ()
, Window -> RemotePtr ()
wRoot :: RemotePtr ()
, Window -> Vendor (Value -> IO ())
wEventHandlers :: Vendor (JSON.Value -> IO ())
, Window -> Vendor JSPtr
wJSObjects :: Vendor JSPtr
}
newPartialWindow :: IO Window
newPartialWindow :: IO Window
newPartialWindow = do
RemotePtr ()
ptr <- Text -> () -> Vendor () -> IO (RemotePtr ())
forall a. Text -> a -> Vendor a -> IO (RemotePtr a)
newRemotePtr Text
"" () (Vendor () -> IO (RemotePtr ()))
-> IO (Vendor ()) -> IO (RemotePtr ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Vendor ())
forall a. IO (Vendor a)
newVendor
TVar ShowS
b1 <- ShowS -> IO (TVar ShowS)
forall a. a -> IO (TVar a)
newTVarIO ShowS
forall a. a -> a
id
TVar CallBufferMode
b2 <- CallBufferMode -> IO (TVar CallBufferMode)
forall a. a -> IO (TVar a)
newTVarIO CallBufferMode
NoBuffering
let nop :: b -> IO ()
nop = IO () -> b -> IO ()
forall a b. a -> b -> a
const (IO () -> b -> IO ()) -> IO () -> b -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Server
-> [Cookie]
-> (FilePath -> IO ())
-> (FilePath -> IO Value)
-> TVar ShowS
-> TVar CallBufferMode
-> IO ()
-> (FilePath -> IO ())
-> (IO () -> IO ())
-> RemotePtr ()
-> Vendor (Value -> IO ())
-> Vendor JSPtr
-> Window
Window Server
forall a. HasCallStack => a
undefined [] FilePath -> IO ()
forall b. b -> IO ()
nop FilePath -> IO Value
forall a. HasCallStack => a
undefined TVar ShowS
b1 TVar CallBufferMode
b2 (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) FilePath -> IO ()
forall b. b -> IO ()
nop IO () -> IO ()
forall b. b -> IO ()
nop RemotePtr ()
ptr (Vendor (Value -> IO ()) -> Vendor JSPtr -> Window)
-> IO (Vendor (Value -> IO ())) -> IO (Vendor JSPtr -> Window)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Vendor (Value -> IO ()))
forall a. IO (Vendor a)
newVendor IO (Vendor JSPtr -> Window) -> IO (Vendor JSPtr) -> IO Window
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Vendor JSPtr)
forall a. IO (Vendor a)
newVendor
root :: Window -> RemotePtr ()
root :: Window -> RemotePtr ()
root = Window -> RemotePtr ()
wRoot
newtype JSPtr = JSPtr { JSPtr -> Text
unsJSPtr :: Coupon }
type JSObject = RemotePtr JSPtr
data NewJSObject = NewJSObject