{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
module Foreign.JavaScript.Types where
import Control.Concurrent.STM
( STM
, TMVar
, TQueue
, TVar
)
import Control.DeepSeq
( NFData (..)
, force
)
import Data.Aeson
( toJSON
, (.=)
, (.:)
)
import Data.ByteString.Char8
( ByteString
)
import Data.Map
( Map
)
import Data.String
( fromString
)
import Data.Text
( Text
)
import Data.Typeable
( Typeable
)
import Snap.Core
( Cookie(..)
)
import System.IO
( stderr
)
import qualified Control.Concurrent.STM as STM
import qualified Control.Exception as E
import qualified Data.Aeson as JSON
import qualified Data.ByteString.Char8 as BS (hPutStrLn)
import qualified Data.Map as Map
import Control.Concurrent.MVar
import Foreign.RemotePtr
data Config = Config
{ Config -> Maybe Int
jsPort :: Maybe Int
, Config -> Maybe ByteString
jsAddr :: Maybe ByteString
, Config -> Maybe [Char]
jsCustomHTML :: Maybe FilePath
, Config -> Maybe [Char]
jsStatic :: Maybe FilePath
, Config -> ByteString -> IO ()
jsLog :: ByteString -> IO ()
, Config -> Bool
jsWindowReloadOnDisconnect :: Bool
, Config -> CallBufferMode
jsCallBufferMode :: CallBufferMode
, Config -> Maybe ConfigSSL
jsUseSSL :: Maybe ConfigSSL
}
data ConfigSSL = ConfigSSL
{ ConfigSSL -> ByteString
jsSSLBind :: ByteString
, ConfigSSL -> [Char]
jsSSLCert :: FilePath
, ConfigSSL -> Bool
jsSSLChainCert :: Bool
, ConfigSSL -> [Char]
jsSSLKey :: FilePath
, ConfigSSL -> Int
jsSSLPort :: Int
}
defaultPort :: Int
defaultPort :: Int
defaultPort = Int
8023
defaultAddr :: ByteString
defaultAddr :: ByteString
defaultAddr = ByteString
"127.0.0.1"
defaultConfig :: Config
defaultConfig :: Config
defaultConfig = 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 [Char]
jsCustomHTML = Maybe [Char]
forall a. Maybe a
Nothing
, jsStatic :: Maybe [Char]
jsStatic = Maybe [Char]
forall a. Maybe a
Nothing
, jsLog :: ByteString -> IO ()
jsLog = Handle -> ByteString -> IO ()
BS.hPutStrLn Handle
stderr
, jsCallBufferMode :: CallBufferMode
jsCallBufferMode = CallBufferMode
FlushOften
, jsUseSSL :: Maybe ConfigSSL
jsUseSSL = Maybe ConfigSSL
forall a. Maybe a
Nothing
}
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 :: Filepaths
newFilepaths :: Filepaths
newFilepaths = (Integer
0, Map ByteString ([Char], [Char])
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
$c== :: ClientMsg -> ClientMsg -> Bool
== :: ClientMsg -> ClientMsg -> Bool
$c/= :: ClientMsg -> ClientMsg -> Bool
/= :: ClientMsg -> ClientMsg -> Bool
Eq, Int -> ClientMsg -> ShowS
[ClientMsg] -> ShowS
ClientMsg -> [Char]
(Int -> ClientMsg -> ShowS)
-> (ClientMsg -> [Char])
-> ([ClientMsg] -> ShowS)
-> Show ClientMsg
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClientMsg -> ShowS
showsPrec :: Int -> ClientMsg -> ShowS
$cshow :: ClientMsg -> [Char]
show :: ClientMsg -> [Char]
$cshowList :: [ClientMsg] -> ShowS
showList :: [ClientMsg] -> ShowS
Show)
instance JSON.FromJSON ClientMsg where
parseJSON :: Value -> Parser ClientMsg
parseJSON (JSON.Object Object
msg) = do
Coupon
tag <- Object
msg Object -> Key -> Parser Coupon
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"tag"
case (Coupon
tag :: Text) of
Coupon
"Event" -> Coupon -> Value -> ClientMsg
Event (Coupon -> Value -> ClientMsg)
-> Parser Coupon -> Parser (Value -> ClientMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
msg Object -> Key -> Parser Coupon
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name") Parser (Value -> ClientMsg) -> Parser Value -> Parser ClientMsg
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
msg Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"arguments")
Coupon
"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 -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"contents")
Coupon
"Exception" -> [Char] -> ClientMsg
Exception ([Char] -> ClientMsg) -> Parser [Char] -> Parser ClientMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
msg Object -> Key -> Parser [Char]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"contents")
Coupon
"Quit" -> ClientMsg -> Parser ClientMsg
forall a. a -> Parser a
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
JSON.Error [Char]
s ->
[Char] -> STM ClientMsg
forall a. HasCallStack => [Char] -> a
error ([Char] -> STM ClientMsg) -> [Char] -> STM ClientMsg
forall a b. (a -> b) -> a -> b
$ [Char]
"Foreign.JavaScript: Error parsing client message " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> [Char]
show [Char]
s
JSON.Success ClientMsg
x
-> ClientMsg -> STM ClientMsg
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
$c== :: ServerMsg -> ServerMsg -> Bool
== :: ServerMsg -> ServerMsg -> Bool
$c/= :: ServerMsg -> ServerMsg -> Bool
/= :: ServerMsg -> ServerMsg -> Bool
Eq,Int -> ServerMsg -> ShowS
[ServerMsg] -> ShowS
ServerMsg -> [Char]
(Int -> ServerMsg -> ShowS)
-> (ServerMsg -> [Char])
-> ([ServerMsg] -> ShowS)
-> Show ServerMsg
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerMsg -> ShowS
showsPrec :: Int -> ServerMsg -> ShowS
$cshow :: ServerMsg -> [Char]
show :: ServerMsg -> [Char]
$cshowList :: [ServerMsg] -> ShowS
showList :: [ServerMsg] -> ShowS
Show)
instance NFData ServerMsg where
rnf :: ServerMsg -> ()
rnf (RunEval [Char]
x) = [Char] -> ()
forall a. NFData a => a -> ()
rnf [Char]
x
rnf (CallEval [Char]
x) = [Char] -> ()
forall a. NFData a => a -> ()
rnf [Char]
x
rnf (Debug [Char]
x) = [Char] -> ()
forall a. NFData a => a -> ()
rnf [Char]
x
rnf (ServerMsg
Timestamp ) = ()
instance JSON.ToJSON ServerMsg where
toJSON :: ServerMsg -> Value
toJSON (Debug [Char]
x) =
[Pair] -> Value
JSON.object [ Key
"tag" Key -> Coupon -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Char] -> Coupon
t [Char]
"Debug", Key
"contents" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Char] -> Value
forall a. ToJSON a => a -> Value
toJSON [Char]
x]
toJSON ServerMsg
Timestamp =
[Pair] -> Value
JSON.object [ Key
"tag" Key -> Coupon -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Char] -> Coupon
t [Char]
"Timestamp" ]
toJSON (RunEval [Char]
x) =
[Pair] -> Value
JSON.object [ Key
"tag" Key -> Coupon -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Char] -> Coupon
t [Char]
"RunEval", Key
"contents" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Char] -> Value
forall a. ToJSON a => a -> Value
toJSON [Char]
x]
toJSON (CallEval [Char]
x) =
[Pair] -> Value
JSON.object [ Key
"tag" Key -> Coupon -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Char] -> Coupon
t [Char]
"CallEval", Key
"contents" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Char] -> Value
forall a. ToJSON a => a -> Value
toJSON [Char]
x]
t :: String -> Text
t :: [Char] -> Coupon
t [Char]
s = [Char] -> Coupon
forall a. IsString a => [Char] -> a
fromString [Char]
s
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 [Char]
err) = [Char] -> ShowS
showString ([Char] -> ShowS) -> [Char] -> ShowS
forall a b. (a -> b) -> a -> b
$ [Char]
"JavaScript error: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
err
type Event = (Coupon, JSON.Value)
type HsEvent = RemotePtr (JSON.Value -> IO ())
quit :: Event
quit :: Event
quit = (Coupon
"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 -> [Char] -> IO ()
runEval :: String -> IO ()
, Window -> [Char] -> IO Value
callEval :: String -> IO JSON.Value
, Window -> TMVar ShowS
wCallBuffer :: TMVar (String -> String)
, Window -> TVar CallBufferMode
wCallBufferMode :: TVar CallBufferMode
, Window -> IO ()
timestamp :: IO ()
, Window -> [Char] -> 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 <- Coupon -> () -> Vendor () -> IO (RemotePtr ())
forall a. Coupon -> a -> Vendor a -> IO (RemotePtr a)
newRemotePtr Coupon
"" () (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
TMVar ShowS
b1 <- ShowS -> IO (TMVar ShowS)
forall a. a -> IO (TMVar a)
STM.newTMVarIO ShowS
forall a. a -> a
id
TVar CallBufferMode
b2 <- CallBufferMode -> IO (TVar CallBufferMode)
forall a. a -> IO (TVar a)
STM.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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Server
-> [Cookie]
-> ([Char] -> IO ())
-> ([Char] -> IO Value)
-> TMVar ShowS
-> TVar CallBufferMode
-> IO ()
-> ([Char] -> IO ())
-> (IO () -> IO ())
-> RemotePtr ()
-> Vendor (Value -> IO ())
-> Vendor JSPtr
-> Window
Window Server
forall a. HasCallStack => a
undefined [] [Char] -> IO ()
forall {b}. b -> IO ()
nop [Char] -> IO Value
forall a. HasCallStack => a
undefined TMVar ShowS
b1 TVar CallBufferMode
b2 (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) [Char] -> 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 a b. IO (a -> b) -> IO a -> IO b
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 -> Coupon
unsJSPtr :: Coupon }
type JSObject = RemotePtr JSPtr
data NewJSObject = NewJSObject