diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 Anton Ekblad + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haste-app.cabal b/haste-app.cabal new file mode 100644 --- /dev/null +++ b/haste-app.cabal @@ -0,0 +1,79 @@ +name: haste-app +version: 0.1.0.0 +synopsis: Framework for type-safe, distributed web applications. +description: Framework for quick development of tierless web applications. +homepage: http://haste-lang.org +license: MIT +license-file: LICENSE +author: Anton Ekblad +maintainer: anton@ekblad.cc +-- copyright: +category: Web +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/valderman/haste-app.git + +flag haste + default: False + description: Package is being installed for Haste. + +library + exposed-modules: + Haste.App + other-modules: + Haste.App.Client, + Haste.App.Client.Type, + Haste.App.Protocol, + Haste.App.Protocol.Types, + Haste.App.Remote, + Haste.App.Routing, + Haste.App.Sandbox, + Haste.App.Sandbox.Internal, + Haste.App.Server, + Haste.App.Server.Type, + Haste.App.Transport, + Paths_haste_app + other-extensions: + CPP, + GeneralizedNewtypeDeriving, + UndecidableInstances, + ScopedTypeVariables, + TypeFamilies, + DataKinds, + TypeOperators, + PolyKinds, + FlexibleInstances, + StaticPointers, + MultiParamTypeClasses, + FlexibleContexts, + ConstraintKinds + + build-depends: + base >=4.8 && <4.9, + data-default >=0.7 && <0.8, + exceptions >=0.8 && <0.9, + mtl >=2.2 && <3, + transformers >=0.4 && <0.6, + haste-lib >=0.6 && <0.7, + haste-prim >=0.6 && <0.7, + containers >=0.5 && <0.6 + if !flag(haste) + build-depends: + bytestring >=0.10 && <0.11, + filepath >=1.4 && <1.5, + http-types >=0.9 && <0.10, + text >=1.2 && <1.3, + utf8-string >=1.0 && <1.1, + websockets >=0.8 && <0.10, + wai >=3.2 && <3.3, + wai-websockets >=3.0 && <3.1, + warp >=3.2 && <3.3 + hs-source-dirs: + src + ghc-options: + -Wall + default-language: + Haskell2010 diff --git a/src/Haste/App.hs b/src/Haste/App.hs new file mode 100644 --- /dev/null +++ b/src/Haste/App.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE TypeFamilies, CPP, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables #-} +module Haste.App + ( module GHC.StaticPtr, module Data.Proxy, module Haste, module Haste.Serialize + , module Haste.App.Sandbox + , Endpoint, Node (..), CIO, Mapping (..), Dispatch + , MonadConc (..), MonadIO (..), MonadReader (..), MonadClient (..), MonadError (..) + , Remote, Remotable, RunsOn, Import, remote, dispatch, dispatchTo, annotate + , RemotePtr, Client, Server, EnvServer, NodeConfig, ClientError (..) + , runApp, start, startLocal, invokeServer + , using, localNode, remoteNode, remoteEndpoint, native + ) where +import Control.Monad +import Control.Monad.Error +import Control.Monad.IO.Class +import Data.Proxy +import Data.Typeable +import Haste.Serialize +import Haste +import Haste.App.Remote +import Haste.App.Client +import Haste.App.Client.Type +import Haste.App.Protocol +import Haste.App.Routing as R +import Haste.Concurrent (MonadConc (..), CIO, concurrent) +import Haste.App.Sandbox hiding (callSandbox, createAppSandbox, initAppSandbox, isInSandbox) +import qualified Haste.App.Sandbox as Sbx (createAppSandbox, isInSandbox, initAppSandbox) +import Haste.App.Server + +#ifndef __HASTE__ +import Control.Concurrent (forkIO, threadDelay) +#endif + +import GHC.StaticPtr + +-- | A 'StaticPointer' to a remote import. +type RemotePtr dom = StaticPtr (Import dom) + +-- | Start a server of the given node when this server binary starts. +start :: forall m. Node m => Proxy m -> NodeConfig +#ifdef __HASTE__ +start p = do + case endpoint p of + LocalNode _ -> error "Please start local nodes using `startLocal'" + _ -> return () +#else +start p = do + case endpoint p of + WebSocket _ port -> do + env <- R.init p + liftIO $ serverLoop (NodeEnv env :: NodeEnv m) port + _ -> return () + +#endif + +startLocal :: forall m. (Perms m, Node m) => Proxy m -> NodeConfig +#ifdef __HASTE__ +startLocal p = do + inSandbox <- liftIO Sbx.isInSandbox + case endpoint p of + LocalNode _ + | inSandbox -> Sbx.initAppSandbox p + | otherwise -> Sbx.createAppSandbox p + _ -> return () +#else +startLocal _ = do + return () +#endif + +-- | Run a Haste.App application. On the client side, a thread is forked off +-- to run the client part in isolation. +-- On the server side, one connection handler thread is forked off for each +-- endpoint. To conserve system resources, it is recommended to build one +-- server-side binary for each intended endpoint, with a single endpoint +-- handler for each. However, it is perfectly possible to build a single +-- server-side binary to handle *all* endpoints, and run that binary on +-- multiple machines. +runApp :: [NodeConfig] -> Client () -> IO () +#ifdef __HASTE__ +runApp eps m = do + inSandbox <- Sbx.isInSandbox + concurrent $ do + sequence_ eps + unless inSandbox $ runClient m +#else +runApp eps _ = mapM_ (forkIO . concurrent) eps >> zzz + where zzz = threadDelay (30*60*1000000) >> zzz +#endif + +-- | Force the type of a monadic computation. Used to annotate inline remote +-- imports. +type RunsOn m = m () + +-- | Annotate a monadic computation with the node it's intended to run on. +-- This is often necessary when doing inline imports: +-- +-- reverse_ :: String -> Client String +-- reverse_ = dispatch $ static (remote $ \x -> do +-- annotate :: RunsOn Server +-- return (reverse x) +-- ) +-- +-- This is essentially a more readable way to say @return () :: Server ()@. +annotate :: Monad m => RunsOn m +annotate = return () + +-- | Convenience function to use inline remote blocks. +-- Since remote functions rely on static pointers, inline blocks must not have +-- any free variables. Instead, this function explicitly captures any free +-- variables and constructs an explicit closure. +-- +-- An example of usage: +-- > example :: Client () +-- > example = do +-- > name <- prompt "What's your name?" +-- > age <- prompt "What's your age?" +-- > using (name, age) $ static (remote $ \(name, age) -> do +-- > annotate :: RunsOn Server +-- > JSString.putStrLn (JSString.concat ["name is ", age, " years old"]) +-- > ) +using fv f = dispatch f fv + +-- | A local endpoint with a name derived from the fingerprint of the node +-- type. Guaranteed to be unique for each node. +localNode :: Typeable (m :: * -> *) => Proxy m -> Endpoint +localNode = LocalNode . show . typeRepFingerprint . typeRep + +-- | Create a web socket endpoint. +remoteEndpoint :: String -> Int -> Proxy (m :: * -> *) -> Endpoint +remoteEndpoint host port _ = remoteNode host port + +-- | Create a remote endpoint for use with 'dispatchTo'. +remoteNode :: String -> Int -> Endpoint +remoteNode = WebSocket + +-- | Mark an expression as only being available on native nodes; i.e. the ones +-- not built with Haste. This is useful to ensure certain parts of an +-- application do not leak onto untrusted clients, as well as minimizing the +-- amount of JavaScript code that needs to be shipped to users. +native :: a -> a +#ifdef __HASTE__ +native _ = error "expression only available on native nodes" +#else +native = id +#endif diff --git a/src/Haste/App/Client.hs b/src/Haste/App/Client.hs new file mode 100644 --- /dev/null +++ b/src/Haste/App/Client.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses #-} +module Haste.App.Client + ( Client, MonadClient (..) + , runClient + ) where +import Control.Monad ((<=<)) +import Haste.Serialize +import Haste.JSON +import Haste.Concurrent +import Haste.WebSockets +import qualified Haste.JSString as JSS (concat) +import Haste.App.Client.Type +import Haste.App.Transport +import Haste.App.Protocol +import Haste.App.Routing (Node (..)) +import Haste (toJSString) +import Haste.App.Sandbox (callSandbox) + +instance MonadClient Client where + remoteCall ep@(LocalNode{}) pkt n = do + liftCIO $ callSandbox n ep pkt + remoteCall ep@(WebSocket{}) pkt n = do + reply <- liftCIO $ do + (v, conf) <- mkConfig ep + Just ws <- wsOpen conf + wsSend ws pkt + reply <- (fromJSON <=< decodeJSON) <$> takeMVar v + wsClose ws + return reply + case reply of + Right (ServerReply _ reply) -> return reply + Right (ServerEx _ m) -> throwError $ ClientError m + Left e -> throwError $ ClientError (show e) + where + mkConfig (WebSocket host port) = do + v <- newEmptyMVar + return (v, WebSocketConfig + { wsOpenURL = JSS.concat ["ws://", toJSString host, ":", toJSString port] + , wsOnMessage = \_ x -> putMVar v x + }) diff --git a/src/Haste/App/Client/Type.hs b/src/Haste/App/Client/Type.hs new file mode 100644 --- /dev/null +++ b/src/Haste/App/Client/Type.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | The @Client@ monad type. +module Haste.App.Client.Type + ( MonadError (..), MonadConc (..), MonadEvent (..), MonadIO (..) + , Client, ClientError (..) + , runClient + ) where +import Haste.Concurrent (MonadConc (..), CIO, concurrent) +import Control.Monad.IO.Class (MonadIO) +import Haste.Events (MonadEvent (..)) + +import Control.Exception +import Control.Monad.Error +import Data.Typeable + +data ClientError = ClientError String + deriving (Typeable, Show) + +instance Error ClientError where + strMsg = ClientError + +instance (Error e, MonadConc m) => MonadConc (ErrorT e m) where + liftCIO = lift . liftCIO + fork m = lift $ fork $ do + Right x <- runErrorT m + return x + +instance MonadEvent Client where + mkHandler f = return $ \x -> concurrent $ do + void $ runClient $ f x + +runClient :: Client a -> CIO a +runClient (Client m) = do + res <- runErrorT m + case res of + Right x -> pure x + Left (ClientError e) -> error e + +-- | A client program running in the browser. +newtype Client a = Client {unClient :: ErrorT ClientError CIO a} + deriving (Functor, Applicative, Monad, MonadIO, MonadConc, MonadError ClientError) diff --git a/src/Haste/App/Protocol.hs b/src/Haste/App/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Haste/App/Protocol.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Haste.App client-server protocol. +module Haste.App.Protocol + ( module Haste.App.Protocol.Types + , ServerCall (..), ServerReply (..) + , ServerException (..), NetworkException (..) + ) where +import Control.Exception +import Control.Monad +import Data.Typeable +import GHC.StaticPtr +import Haste.Serialize +import Haste.JSON +import qualified Haste.Foreign as HF +import Haste.App.Protocol.Types +import GHC.Fingerprint.Type +import Data.Bits +import Data.Word +import Haste (JSString) + +-- | A method call to the server. +data ServerCall = ServerCall + { scNonce :: !Nonce + , scMethod :: !StaticKey + , scArgs :: ![JSON] + } + +-- | A reply to a ServerCall. +data ServerReply = ServerReply + { srNonce :: !Nonce + , srResult :: !JSON + } | ServerEx + { seNonce :: !Nonce + , seMessage :: !String + } deriving (Typeable, Show) + +-- | Throw a server exception to the client. +data ServerException = ServerException String + deriving (Typeable, Show) +instance Exception ServerException + +-- | Throw an exception when there's network trouble. +data NetworkException = NetworkException String + deriving (Typeable, Show) +instance Exception NetworkException + +instance Serialize ServerCall where + parseJSON x = do + tag <- x .: "tag" + case tag :: JSString of + "call" -> ServerCall <$> x .: "nonce" <*> x .: "method" <*> x .: "args" + _ -> fail $ "No such ServerCall constructor: " ++ show tag + toJSON (ServerCall n c as) = Dict + [ ("tag", "call") + , ("nonce", toJSON n) + , ("method", toJSON c) + , ("args", toJSON as) + ] + +instance Serialize ServerReply where + parseJSON x = do + t <- x .: "status" + case t :: JSString of + "error" -> ServerEx <$> x .: "nonce" <*> x .: "error" + "ok" -> ServerReply <$> x .: "nonce" <*> x .: "result" + toJSON (ServerReply n r) = Dict [("nonce", toJSON n), ("result", r), ("status", "ok")] + toJSON (ServerEx n m) = Dict [("nonce", toJSON n), ("error", toJSON m), ("status", "error")] + +instance Serialize Word64 where + parseJSON x = do + lo <- x .: "lo" :: Parser Double + hi <- x .: "hi" :: Parser Double + return $ round lo .|. shiftL (round hi) 32 + toJSON x = Dict + [ ("lo", toJSON (fromIntegral (x .&. 0xffffffff) :: Double)) + , ("hi", toJSON (fromIntegral (shiftR x 32 .&. 0xffffffff) :: Double)) + ] + +instance Serialize Fingerprint where + parseJSON x = Fingerprint <$> x .: "lo" <*> x .: "hi" + toJSON (Fingerprint lo hi) = Dict + [ ("lo", toJSON lo) + , ("hi", toJSON hi) + ] + diff --git a/src/Haste/App/Protocol/Types.hs b/src/Haste/App/Protocol/Types.hs new file mode 100644 --- /dev/null +++ b/src/Haste/App/Protocol/Types.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE RankNTypes, GADTs #-} +-- | Types for the Haste.App protocol. +module Haste.App.Protocol.Types where +import Haste.Events (Recipient (..)) +import Data.Int +import Haste.Concurrent (CIO) + +type Nonce = Int32 + +data SomeRecipient where + SomeRecipient :: Recipient a => a -> SomeRecipient + +instance Recipient SomeRecipient where + postMessage (SomeRecipient r) = postMessage r + +-- | Location of a Haste.App server. +data Endpoint + = WebSocket + { -- * Host on which clients can expect to reach this endpoint. + wsEndpointHost :: !String + -- * Port on which the endpoint will listen to connections from clients. + , wsEndpointPort :: !Int + } + | LocalNode + { -- | Name by which to identify a local endpoint. + localNodeIdent :: !String + } deriving (Eq, Ord, Show) + +-- | A server node startup configuration. +type NodeConfig = CIO () diff --git a/src/Haste/App/Remote.hs b/src/Haste/App/Remote.hs new file mode 100644 --- /dev/null +++ b/src/Haste/App/Remote.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE TypeFamilies, + ScopedTypeVariables, + FlexibleInstances, + MultiParamTypeClasses, + FlexibleContexts, + DefaultSignatures, + TypeOperators, + ConstraintKinds #-} +module Haste.App.Remote where +import Haste.Serialize +import Haste.JSON +import qualified Haste.JSString as S +import Haste.Concurrent +import Data.Proxy + +import GHC.StaticPtr +import Haste.App.Client +import Haste.App.Protocol +import Haste.App.Routing as Routing +import Haste.App.Sandbox +import Haste.App.Transport + +newtype Import dom = Import (Routing.Env (Affinity dom) -> [JSON] -> CIO JSON) + +-- | The affinity, i.e. node type, of a function. +type family Affinity a where + Affinity (a -> b) = Affinity b + Affinity (m a) = m + +-- | The result type of a function on some node. +type family Res a where + Res (a -> b) = Res b + Res (m a) = a + +-- | The Haskell equivalent type of a domain-specific function. +type family HaskF c a where + HaskF c (a -> b) = (a -> HaskF c b) + HaskF c (m a) = c (Hask m a) + +-- | Any types @m@, @cli@ and @dom@ such that @cli@ is a function in the +-- client monad, @m@ is the type of the server node, and @dom@ is a server +-- computation that is type-compatible with @cli@. +type Dispatch dom cli = + ( Node (Affinity dom) + , Allowed (Affinity dom) (Affinity cli) + , Remotable cli + , HaskF (Affinity cli) dom ~ cli + ) + +-- | Any function type @dom@ which can be exported from a node to another. +type Export dom = + ( Remote (Affinity dom) dom + , Serialize (Hask (Affinity dom) (Res dom)) + ) + +-- | A client-side frontend for a 'Remote' function. +class Remotable a where + -- | Plumbing for turning a 'StaticKey' into a remote function, callable on + -- the client. + dispatch' :: Endpoint -> StaticKey -> [JSON] -> a + +instance {-# OVERLAPPING #-} (Serialize a, Remotable b) => Remotable (a -> b) where + dispatch' ep k xs x = dispatch' ep k (toJSON x : xs) + +instance (MonadClient cli, Serialize a) => Remotable (cli a) where + dispatch' ep k xs = do + Right x <- fromJSON <$> call ep k (reverse xs) + return x + +-- | A function that may act as a server-side callback. That is, one where all +-- arguments and return values are serializable. +class (Affinity dom ~ m) => Remote m dom where + -- | Serializify a function so it may be called remotely. + blob :: dom -> [JSON] -> Routing.Env m -> CIO (Hask m (Res dom)) + +instance (Serialize a, Remote m b) => Remote m (a -> b) where + blob f (x:xs) env = + case fromJSON x of + Right x' -> blob (f x') xs env + _ -> error $ "JSON decoding failed: " ++ show x + blob _ _ _ = error "impossible: too few arguments" + +instance (Affinity (m a) ~ m, Mapping m a, Res (m a) ~ a) => Remote m (m a) where + blob m _ env = invoke env m + +call :: MonadClient from => Endpoint -> StaticKey -> [JSON] -> from JSON +call ep k xs = do + n <- getNonce + remoteCall ep (encodeJSON $ toJSON $ (ServerCall n k xs)) n + +-- | Serializify any function of type @a -> ... -> b@ into a corresponding +-- function of type @[JSON] -> Server JSON@, with the same semantics. +-- This allows the function to be called remotely via a static pointer. +remote :: forall dom. Export dom => dom -> Import dom +remote f = Import $ \env xs -> + toJSON <$> (blob f xs env :: CIO (Hask (Affinity dom) (Res dom))) + +-- | Turn a static pointer to a serializified function into a client-side +-- function which, when fully applied, is executed on the server. +-- +-- The full, somewhat unwieldy, incantation to import a server-side +-- function @f@ to the client reads: +-- +-- > dispatch $ static (remote f) +-- +-- Of course, the dispatch may be used as part of the invocation, rather than +-- definition, of the import instead: +-- +-- > f' = static (remote f) +-- > main = runApp $ dispatch f' x0 x1 ... +dispatch :: forall cli dom. Dispatch dom cli => StaticPtr (Import dom) -> cli +dispatch f = dispatch' ep (staticKey f) [] + where ep = endpoint (Proxy :: Proxy (Affinity dom)) + +-- | Like 'dispatch', but makes a direct call to the server, and overrides +-- the its default endpoint. The server node must be directly attached to +-- the client making the call. +dispatchTo :: Dispatch dom cli => Endpoint -> StaticPtr (Import dom) -> cli +dispatchTo ep f = dispatch' ep (staticKey f) [] diff --git a/src/Haste/App/Routing.hs b/src/Haste/App/Routing.hs new file mode 100644 --- /dev/null +++ b/src/Haste/App/Routing.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE UndecidableInstances, + ScopedTypeVariables, + TypeFamilies, + FlexibleInstances, + MultiParamTypeClasses, + FlexibleContexts, + GeneralizedNewtypeDeriving, + CPP, + DefaultSignatures #-} +-- | Type-level routing of requests from clients to servers attached to a +-- network and back again. +module Haste.App.Routing + ( Node (..), NodeEnv (..), MonadReader (..), Mapping (..) + , Server, EnvServer, invokeServer, localEndpoint + ) where +import Control.Monad.Reader +import Data.Default +import Data.Proxy +import Haste.Serialize -- for serialization +import Haste.JSON +import Haste.App.Protocol +import Haste.Concurrent (MonadConc (..), CIO) +import Haste (JSString, fromJSStr) +import Haste.App.Client.Type (Client) -- for default Parent type instance +import Haste.App.Server.Type +import Haste.App.Transport (MonadClient) +import GHC.StaticPtr +import GHC.Exts (Constraint) + +-- for default Endpoint instance +import Data.Typeable +import Data.Char +import Data.Word (Word16) +import Haste (getLocationHostName) +import System.IO.Unsafe +import System.IO (hPutStrLn, stderr) + +-- * Defining and calling servers + +-- | A server node in the network. +-- To define a new node @N@, the following must be provided: +-- +-- * The type of the node's environment. This may be omitted if the node +-- has no environment, in which case it defaults to @()@. +-- +-- * A function @endpoint@, which describes how to physically reach +-- the node; this may be omitted if the node is reachable via WebSockets +-- on the same host name as the client program is served from. +-- In this case, the port of the endpoint is determined by the hash of +-- the node's @TypeRep@. +-- +-- * A function @init@, which initializes the node's environment and +-- performs any server-side initialization. This may be omitted if +-- @Env m@ is an instance of 'Default' and no other server-side setup +-- is needed. +-- +-- * At least one instance of 'Mapping'. This can be omitted if @N@ is +-- a case of 'EnvServer'. +-- +-- Thus, the minimal declaration to create a new node with +-- some environment @MyEnv@ would be: +-- +-- > type MyNode = EnvNode MyEnv +-- > instance Node MyNode where +-- > type Env MyNode = MyEnv +-- +-- If a stateful node is desired rather than one with an environment, this +-- can be accomplishe using, for instance, @IORef@s: +-- +-- > type MyNode = EnvNode (IORef MySt) +-- > instance Node MyNode where +-- > type Env MyNode = IORef MySt +-- > init _ = liftIO $ newIORef initialState +-- +-- A stateful node which is not a case of @EnvServer@ requires slightly more +-- boilerplate: +-- +-- > newtype MyNode a = MyNode (EnvServer (IORef MySt) a) +-- > deriving (Functor, Applicative, Monad, MonadIO, MonadReader (IORef MySt)) +-- > +-- > instance Mapping MyNode a where +-- > invoke env (MyNode m) = invokeServer env m +-- > +-- > instance Node MyNode where +-- > type Env MyNode = IORef MySt +-- > init _ = liftIO $ newIORef initialState +class Node (m :: * -> *) where + -- | Environment type of node. Defaults to @()@. + type Env m :: * + type Env m = () + + -- | The type class describing all clients that may make calls to this node. + -- By default, any 'MonadClient' may call a node. + type Allowed m (c :: * -> *) :: Constraint + type Allowed m c = () + + -- | The location at which the node can be reached. + endpoint :: Proxy m -> Endpoint + default endpoint :: Typeable m => Proxy m -> Endpoint + endpoint p = unsafePerformIO $ do + let node = show $ typeRep p + w16 = djb2 node + port = fromIntegral w16 `rem` (65535-1024) + 1024 +#ifdef __HASTE__ + host <- fromJSStr <$> getLocationHostName +#else + hPutStrLn stderr $ "selecting port " ++ show port ++ " for node " ++ node + let host = "" +#endif + return $ WebSocket (if "" == host then "localhost" else host) port + where + -- | DJB2 hash function + djb2 :: String -> Word16 + djb2 = go 5381 + where + go n (c:s) = go (n*33 + (fromIntegral $ ord c)) s + go n _ = n + + -- | Initialization for the given node. + init :: Proxy m -> CIO (Env m) + default init :: Default (Env m) => Proxy m -> CIO (Env m) + init _ = return def + +-- | A mapping from node return values to Haskell values. +-- This is useful when making nodes out of e.g. DSLs where the DSL-internal +-- type is not what the Haskell host program gets back from running it. +-- One instance of this is @opaleye@, another is @aplite@. +-- +-- Most nodes will only need a single instance: +-- +-- > instance Mapping MyNode a where +-- > invoke env node = invokeMyNode env node +-- +-- This instance is already provided for all nodes of type 'EnvServer'. +class Mapping (m :: * -> *) a where + type Hask m a + type Hask m a = a + + -- | Run a DSL computation which returns an @a@ on the DSL level, + -- corresponding to @Map m a@ on the Haskell level. + invoke :: Env m -> m a -> CIO (Hask m a) + default invoke :: (m ~ EnvServer (Env m), Hask m a ~ a) => Env m -> m a -> CIO a + invoke = invokeServer + +-- | Node environment tagged with its type, to avoid having to pass a Proxy +-- around to identify the type of the node. +newtype NodeEnv m = NodeEnv {unNE :: Env m} + +instance (t ~ Env (EnvServer t)) => Mapping (EnvServer t) a diff --git a/src/Haste/App/Sandbox.hs b/src/Haste/App/Sandbox.hs new file mode 100644 --- /dev/null +++ b/src/Haste/App/Sandbox.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE GADTs, OverloadedStrings, ScopedTypeVariables, GeneralizedNewtypeDeriving, TypeOperators #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-} +-- | Sandboxed FFI for Haste.App. +module Haste.App.Sandbox + ( invokeSandbox, dependOn, withDepends + , Perms (..), CustomSandbox, Sandbox, module Sbx + , callSandbox, createAppSandbox, initAppSandbox, isInSandbox + ) where +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Reader +import Data.Default +import Data.Proxy +import Data.Typeable +import GHC.StaticPtr +import Haste +import Haste.Concurrent +import Haste.Events +import Haste.Foreign +import Haste.JSON +import Haste.Serialize +import Haste.App.Protocol +import Haste.App.Routing +import Haste.App.Sandbox.Internal +import qualified Haste.App.Sandbox.Internal as Sbx + hiding (createSandbox, withSandbox, isInSandbox) + +-- For dynamically loading JS dependencies. +import Haste.DOM.JSString + +registerSbx :: String -> Window -> IO () +registerSbx = ffi "(function(name,sbx){window['__haste_app_sbx'][name] = sbx;})" + +lookupSbx :: String -> IO (Maybe Window) +lookupSbx = ffi "(function(name){return window['__haste_app_sbx'][name];})" + +initSbxRegistry :: IO () +initSbxRegistry = ffi "(function(){if(!window['__haste_app_sbx']) {window['__haste_app_sbx'] = {};};})" + +-- | Returns @True@ if run from a sandbox which has already been initialized, +-- otherwise @False@. Also marks the sandbox as initialized. +initialized :: IO Bool +initialized = ffi "(function(){\ + \var prev = !!window['__haste_app_sbx_inited'];\ + \window['__haste_app_sbx_inited'] = true;\ + \return prev;\ + \})" + +-- | Called in sandbox to report to host that it's done loading dependencies. +doneLoadingDeps :: IO () +doneLoadingDeps = ffi "(function(){parent.postMessage(__haste_prog_id,'*');})" + +-- | Create a Haste.App sandbox and set it up to listen to requests. +-- Only used internally, to start 'LocalNode' nodes. Called OUTSIDE sandbox +-- only. +createAppSandbox :: forall c m env. + (Perms m, Node m) + => Proxy m + -> CIO () +createAppSandbox p = do + Just sbx <- createSandbox (perms p) + awaitLoadingDeps + liftIO $ do + initSbxRegistry + registerSbx ident sbx + where + awaitLoadingDeps = do + v <- newEmptyMVar + pid <- getProgramId + h <- window `onEvent` Message $ \msg -> do + md <- liftIO $ fromAny (messageData msg) + when (md == pid) $ putMVar v () + takeMVar v + unregisterHandler h + LocalNode ident = endpoint p + +-- | Initialize a sandbox. Called INSIDE the sandbox only. +initAppSandbox :: (Perms m, Node m) => Proxy m -> CIO () +initAppSandbox p = do + alreadyInited <- liftIO initialized + unless alreadyInited $ do + _ <- initSandbox =<< Haste.App.Routing.init p + liftIO $ doneLoadingDeps + return () + where + initSandbox env = do + window `onEvent` Message $ \msg -> do + mess <- liftIO $ fromAny (messageData msg) + case fromJSON =<< decodeJSON mess of + Right (ServerCall n m a) -> handleCall (messageSource msg) env n m a + Left _ -> return () + + handleCall parent env nonce method args = do + mm <- liftIO $ unsafeLookupStaticPtr method + case mm of + Just m -> do + result <- deRefStaticPtr m env args + postMessage parent $ encodeJSON $ toJSON $ ServerReply + { srNonce = nonce + , srResult = result + } + Nothing -> do + postMessage parent $ encodeJSON $ toJSON $ + ServerEx nonce $ "no such method: " ++ show method + + +-- | Send a 'ServerCall' to a sandbox and wait for a reply. +callSandbox :: Nonce -> Endpoint -> JSString -> CIO JSON +callSandbox nonce (LocalNode ident) outgoing = do + msbx <- liftIO $ lookupSbx ident + case msbx of + Nothing -> error $ "no such sandbox: " ++ ident + Just sbx -> do + v <- newEmptyMVar + h <- window `onEvent` Message $ \msg -> do + m <- liftIO $ fromAny (messageData msg) + case fromJSON =<< decodeJSON m of + Right (ServerReply n result) | nonce == n -> do + preventDefault + putMVar v result + _ -> do + return () + postMessage sbx outgoing + res <- takeMVar v + unregisterHandler h + return res + +-- | A standard sandbox, with no environment and no extra permissions. +type Sandbox = CustomSandbox AllowNone () + +class Perms m where + perms :: Proxy (m :: * -> *) -> JSString + +instance Permission perms => Perms (CustomSandbox perms env t) where + perms _ = showPermissions (Proxy :: Proxy perms) + +-- | A node executing in a sandboxed iframe. The permissions of the sandbox +-- are given by the @perm@ type argument; see 'Permission' for details. +newtype CustomSandbox perm env t a = Sandbox (EnvServer env a) + deriving (Functor, Applicative, Monad, MonadIO, MonadConc, MonadReader env) + +-- | Invoke a sandboxed computation. Use for @Mapping Sandbox@ instances. +-- However, in pretty much all circumstances, the provided @Mapping@ instance +-- should be the only one needed for any sandbox. +invokeSandbox :: env -> CustomSandbox perm env t a -> CIO a +invokeSandbox env (Sandbox m) = invokeServer env m + +-- | Initialize a sandbox by loading the given dependencies and then running +-- the given initialization function. Dependencies are loaded in order, +-- in case some of them depend on each other. +-- Use this for the @init@ method when creating @Node@ instances for +-- sandboxes: +-- +-- > instance Node (Sandbox SomePermissions SomeEnv) where +-- > init = initializeStuff `withDepends` ["http://.../script.js", ...] +-- > ... +withDepends :: CIO env -> [URL] -> Proxy (m :: * -> *) -> CIO env +withDepends extraInit deps _ = do + v <- newEmptyMVar + addScript v deps + takeMVar v + where + addScript v (url:us) = do + e <- newElem "script" + appendChild documentBody e + e `onEvent` Load $ \_ -> addScript v us + setProp e "src" url + addScript v _ = do + extraInit >>= putMVar v + +-- | Initialize a sandbox by loading the given dependencies and then returning +-- the default value for the sandbox' environment. +dependOn :: Default env => [URL] -> Proxy (m :: * -> *) -> CIO env +dependOn deps = pure def `withDepends` deps + +instance env ~ Env (CustomSandbox perm env t) => Mapping (CustomSandbox perm env t) a where + invoke = invokeSandbox diff --git a/src/Haste/App/Sandbox/Internal.hs b/src/Haste/App/Sandbox/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Haste/App/Sandbox/Internal.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE OverloadedStrings, TypeOperators, ScopedTypeVariables #-} +-- | Mid-level sandbox utilities. +module Haste.App.Sandbox.Internal + ( createSandbox, withSandbox, isInSandbox + , showPermissions + , Permission, AllowForms, AllowModals, AllowOrientationLock + , AllowPointerLock, AllowPopups, AllowPopupsEscapeSandbox, AllowPresentation + , AllowTopNavigation, AllowAll, AllowNone + ) where +import Control.Monad +import Data.Proxy +import Haste +import Haste.Concurrent +import Haste.DOM.JSString +import Haste.Events +import Haste.Foreign +import qualified Haste.JSString as S + +-- | Sandbox restrictions that can be relaxed. +-- @allow-scripts@ is always set, and @allow-same-origin@ is disallowed since +-- it would effectively render the sandbox pointless. +data AllowNone +data AllowForms +data AllowModals +data AllowOrientationLock +data AllowPointerLock +data AllowPopups +data AllowPopupsEscapeSandbox +data AllowPresentation +data AllowTopNavigation +data a :+: b +type AllowAll + = AllowForms :+: AllowModals :+: AllowOrientationLock :+: AllowPointerLock + :+: AllowPopups :+: AllowPopupsEscapeSandbox :+: AllowPresentation + :+: AllowTopNavigation + +-- | All permissions that can be given to a sandboxed program. +-- Programs can be strung together using the @:+:@ type-level operator: +-- > AllowModals :+: AllowPopups :+: AllowTopNavigation +class Permission a where + -- | Turn a @Permission@ into the equivalent sandbox attribute. + showPerm :: Proxy a -> JSString + +-- | Turn the given permissions into a space-separated list for use with +-- the @sandbox@ DOM attribute. +showPermissions :: Permission a => Proxy a -> JSString +showPermissions p = + case showPerm p of + ps | S.null ps -> "allow-scripts" + | otherwise -> "allow-scripts " `S.append` ps + +instance Permission AllowNone where showPerm _ = "" +instance Permission AllowForms where showPerm _ = "allow-forms" +instance Permission AllowModals where showPerm _ = "allow-modals" +instance Permission AllowOrientationLock where showPerm _ = "allow-orientation-lock" +instance Permission AllowPointerLock where showPerm _ = "allow-pointer-lock" +instance Permission AllowPopups where showPerm _ = "allow-popups" +instance Permission AllowPopupsEscapeSandbox where showPerm _ = "allow-popups-to-escape-sandbox" +instance Permission AllowPresentation where showPerm _ = "allow-presentation" +instance Permission AllowTopNavigation where showPerm _ = "allow-top-navigation" +instance (Permission a, Permission b) => Permission (a :+: b) where + showPerm _ = S.concat + [ showPerm (Proxy :: Proxy a) + , " " + , showPerm (Proxy :: Proxy b) + ] + +-- | Low-level sandbox creation. Creates an iframe element with the sandbox +-- attribute set to the appropriate value given the list of permissions. +-- Also generates boilerplate code to tell the JS program that is's in fact +-- running in a Haste sandbox. +mkSandbox :: JSString -> IO (Elem, Window) +mkSandbox perms = do + js <- getProgramJS + f <- newElem "iframe" `with` + [ "srcdoc" =: S.concat [bootstrap, prog js] + , style "display" =: "none" + , "sandbox" =: perms + ] + appendChild documentBody f + maybe (error "impossible") (\w -> (f,w)) <$> getContentWindow f + where + bootstrap = S.concat + [ "