{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
module Foreign.JavaScript.Types where

import qualified Control.Exception       as E
import           Control.Concurrent.STM  as STM
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.Map                as Map
import           Data.String
import           Data.Text
import           Data.Typeable
import           Snap.Core                       (Cookie(..))
import           System.IO                       (stderr)

import Foreign.RemotePtr

{-----------------------------------------------------------------------------
    Server Configuration -- Static
------------------------------------------------------------------------------}
-- NOTE: Unfortunately, Haddock currently does not create documentation for
-- record fields when the constructor is not exported.
-- That's why we copy & paste it in the documentation for the data type.
{- | Static configuration for a "Foreign.JavaScript" server.

This is a record type which has the following fields:

* @jsPort :: Maybe Int@

    Port number.
    @Nothing@ means that the port number is read from the environment variable @PORT@.
    Alternatively, port @8023@ is used if this variable is not set.

* @jsAddr :: Maybe ByteString@

    Bind address.
    @Nothing@ means that the bind address is read from the environment variable @ADDR@.
    Alternatively, address @127.0.0.1@ is used if this variable is not set.

* @jsCustomHTML :: Maybe FilePath@

    Custom HTML file to replace the default one.

* @jsStatic :: Maybe FilePath@

    Directory that is served under @/static@.

* @jsLog :: ByteString -> IO ()@

    Function to print a single log message.

* @jsWindowReloadOnDisconnect :: Bool@

    Reload the browser window if the connection to the server was dropped accidentally,
    for instance because the computer was put to sleep and awoken again.

* @jsCallBufferMode :: CallBufferMode@

    The initial 'CallBufferMode' to use for 'runFunction'.
    It can be changed at any time with 'setCallBufferMode'.

* @jsUseSSLBind :: Maybe ConfigSSL@

    Whether to serve on a HTTPS connection instead of HTTP for improved security.

    * 'Just' with a 'ConfigSSL' to serve on HTTPS.
        Note that this will fail silently unless the @snap-server@ package
        has been compiled with the @openssl@ flag enabled.

    * 'Nothing' to serve on HTTP.

(For reasons of forward compatibility, the constructor is not exported.)

-}
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
    }

{- | Static configuration for the SSL version of the "Foreign.JavaScript" server.

This is a record type which has the following fields:

* @jsSSLBind :: ByteString@

    Bind address.

* @jsSSLCert :: FilePath@

    Path to SSL certificate file. Example: @cert.pem@.

* @jsSSLChainCert :: Bool@

    If it is SSL chain certificate file.

* @jsSSLKey :: FilePath@

    Path to SSL key file. Example: @key.pem@.

* @jsSSLPort :: ByteString@

    Port number. Example: 443.

-}

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"

-- | Default configuration.
--
-- Port from environment variable or @8023@, listening on @localhost@,
-- no custom HTML, no static directory,
-- logging to stderr,
-- do reload on disconnect,
-- __buffer FFI calls__.
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
    }

{-----------------------------------------------------------------------------
    Server Configuration -- Dynamic
------------------------------------------------------------------------------}
-- | URI type.
--
-- FIXME: Use the correct type from "Network.URI"
type URI = String

-- | MIME type.
type MimeType = String

-- | Representation of a "Foreign.JavaScript" server.
--
-- Can be used for dynamic configuration, e.g. serving additional files.
data Server = Server
    { Server -> MVar Filepaths
sFiles :: MVar Filepaths
    , Server -> MVar Filepaths
sDirs  :: MVar Filepaths
    , Server -> ByteString -> IO ()
sLog   :: ByteString -> IO () -- function for logging
    }
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)

{-----------------------------------------------------------------------------
    Communication channel
------------------------------------------------------------------------------}
-- | Bidirectional communication channel.
data Comm = Comm
    { Comm -> TQueue Value
commIn    :: TQueue JSON.Value    -- ^ Read from channel.
    , Comm -> TQueue Value
commOut   :: TQueue JSON.Value    -- ^ Write into channel.
    , Comm -> TVar Bool
commOpen  :: TVar   Bool          -- ^ Indicate whether the channel is still open.
    , Comm -> IO ()
commClose :: IO ()                -- ^ Close the channel.
    }

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)

{-----------------------------------------------------------------------------
    Communication protocol
------------------------------------------------------------------------------}
-- | Messages received from the JavaScript client.
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 FromJSON ClientMsg where
    parseJSON :: Value -> Parser ClientMsg
parseJSON (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
        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
        Success ClientMsg
x -> ClientMsg -> STM ClientMsg
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ClientMsg
x

-- | Messages sent by the Haskell server.
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 ToJSON ServerMsg where
    toJSON :: ServerMsg -> Value
toJSON (Debug    [Char]
x) = [Pair] -> Value
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
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
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
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

{- Note [ServerMsg strictness]

The type `ServerMsg` may contain components that evalute to _|_, and
an exception will be thrown when we try to send one of those to the browser.

However, we have to make sure that the exception is thrown
in the thread that constructed the message, not in the thread that
handles the actual communication with the client.

That's why we have to use the function
`Control.DeepSeq.deepseq` to make sure that any exception
is thrown before handing the message over to another thread.

Since exceptions in pure code do not have a precise ordering relative
to exceptions in IO code, evaluating the pure value
also helps with ensuring that the exception is raised before
any subsequent IO exception; this makes it easier to pinpoint
the root cause for library users.

-}


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

{-----------------------------------------------------------------------------
    Window & Event Loop
------------------------------------------------------------------------------}
-- | An event sent from the browser window to the server.
type Event        = (Coupon, JSON.Value)

-- | An event handler that can be passed to the JavaScript client.
type HsEvent      = RemotePtr (JSON.Value -> IO ())

quit :: Event
quit :: Event
quit = (Coupon
"quit", Value
JSON.Null)

-- | Specification of how JavaScript functions should be called.
data CallBufferMode
    = NoBuffering
    -- ^ When 'runFunction' is used to call a JavaScript function,
    -- immediately send a message to the browser window to execute
    -- said function.
    | BufferRun
    -- ^ When 'runFunction' is used to call a JavaScript function,
    -- hold back any message to the server.
    -- All JavaScript functions that are held back in this way
    -- are combined into a single message,
    -- which is finally sent whenever 'callFunction' or
    -- 'flushCallBuffer' are used, or an exported Haskell function is called.
    | FlushOften
    -- ^ The same as 'BufferRun', but this mode indicates
    -- client libraries and programs are encouraged to flush the buffer more often
    -- to simplify usage. Users may choose 'BufferRun' instead if they want more control
    -- over flushing the buffer.
    | FlushPeriodically
    -- ^ The same as 'BufferRun', except that the buffer will also be flushed
    -- every 300ms.

flushPeriod :: Int
flushPeriod = Int
300 :: Int

-- | Action that the server will run when a browser window connects.
type EventLoop   = Server -> RequestInfo -> Comm -> IO ()
type RequestInfo = [Cookie]

-- | Representation of a browser window.
data Window = Window
    { Window -> Server
getServer      :: Server
    -- ^ Server that the browser window communicates with.
    , Window -> [Cookie]
getCookies     :: [Cookie]
    -- ^ Cookies that the browser window has sent to the server when connecting.

    , 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 ()
    -- ^ Print a timestamp and the time difference to the previous one
    -- in the JavaScript console.
    , Window -> [Char] -> IO ()
debug          :: String -> IO ()
    -- ^ Send a debug message to the JavaScript console.
    , Window -> IO () -> IO ()
onDisconnect   :: IO () -> IO ()
    -- ^ Register an action to be performed when the client disconnects.
    , 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)
newTMVarIO 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 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

-- | For the purpose of controlling garbage collection,
-- every 'Window' as an associated 'RemotePtr' that is alive
-- as long as the external JavaScript connection is alive.
root :: Window -> RemotePtr ()
root :: Window -> RemotePtr ()
root = Window -> RemotePtr ()
wRoot

{-----------------------------------------------------------------------------
    Marshalling
------------------------------------------------------------------------------}
newtype JSPtr = JSPtr { JSPtr -> Coupon
unsJSPtr :: Coupon }

-- | A mutable JavaScript object.
type JSObject = RemotePtr JSPtr

-- | A mutable JavaScript object that has just been created.
-- This a dummy type used for additional type safety.
data NewJSObject = NewJSObject