haste-app (empty) → 0.1.0.0

raw patch · 15 files changed

+1151/−0 lines, 15 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, data-default, exceptions, filepath, haste-lib, haste-prim, http-types, mtl, text, transformers, utf8-string, wai, wai-websockets, warp, websockets

Files

• LICENSE +20/−0
• Setup.hs +2/−0
• haste-app.cabal +79/−0
• src/Haste/App.hs +144/−0
• src/Haste/App/Client.hs +40/−0
• src/Haste/App/Client/Type.hs +41/−0
• src/Haste/App/Protocol.hs +85/−0
• src/Haste/App/Protocol/Types.hs +30/−0
• src/Haste/App/Remote.hs +119/−0
• src/Haste/App/Routing.hs +149/−0
• src/Haste/App/Sandbox.hs +177/−0
• src/Haste/App/Sandbox/Internal.hs +116/−0
• src/Haste/App/Server.hs +86/−0
• src/Haste/App/Server/Type.hs +31/−0
• src/Haste/App/Transport.hs +32/−0

@@ -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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

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

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

@@ -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+          })

@@ -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)

@@ -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)+    ]+  

@@ -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 ()

@@ -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) []

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

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

@@ -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+      [ "<script>"+      , "window['__haste_program_is_sandboxed'] = true;"+      , "<", "/script>"+      ]+    prog (Left url) = S.concat ["<script src=\"", url, "\"><", "/script>"]+    prog (Right js) = S.concat ["<script>", js, "<", "/script>"]++-- | Create a sandbox iframe with the given permissions,+--   then run the given callback after it finishes loading.+withSandbox :: JSString -> (Maybe Window -> IO ()) -> IO ()+withSandbox perms go = do+    local <- isInSandbox+    if local then+        go Nothing+      else do+        (e, w) <- mkSandbox perms+        void $ e `onEvent` Load $ \_ -> go (Just w)++-- | Create a sandbox with the given permissions.+--   This function works similarly to UNIX @fork@: it will return in *both*+--   the sandbox and the host program. In the sandbox it returns @Nothing@, and+--   in the host program it returns the window object that may be used to+--   communicate with the sandbox. Setting up message event listeners in the+--   responsibility of the users, in the sandbox as well as in the host program.+createSandbox :: MonadConc m => JSString -> m (Maybe Window)+createSandbox perms = liftCIO $ do+  v <- newEmptyMVar+  liftIO $ withSandbox perms (concurrent . putMVar v)+  takeMVar v++-- | Is the program running in a sandbox?+isInSandbox :: IO Bool+isInSandbox = ffi "(function(){return self['__haste_program_is_sandboxed'];})"

@@ -0,0 +1,86 @@+{-# LANGUAGE CPP, OverloadedStrings #-}+module Haste.App.Server (serverLoop) where+import Haste.App.Transport+import Haste.App.Server.Type+import Data.Typeable++#ifdef __HASTE__+serverLoop _ _ = pure undefined+instance Typeable a => MonadClient (EnvServer a) where+  remoteCall _ _ _ = pure undefined+#else+import Control.Concurrent+import Control.Monad.Catch+import Control.Monad ((>=>))+import qualified Data.ByteString.Lazy as BSL+import Data.ByteString.Lazy.UTF8+import GHC.StaticPtr+import Unsafe.Coerce+import Network.WebSockets as WS+import Haste.Serialize+import Haste.JSON+import Haste (JSString, fromJSStr, toJSString)+import Haste.App.Protocol+import Haste.App.Routing (NodeEnv (..))+import Haste.Concurrent (CIO, concurrent, liftIO)++import Network.HTTP.Types+import Network.Wai+import Network.Wai.Handler.Warp as W+import Network.Wai.Handler.Warp.Internal as W (settingsPort)+import Network.Wai.Handler.WebSockets++import Control.Exception (SomeException (..))+import qualified Control.Exception as CE (catch, throwIO)++instance MonadThrow CIO where+  throwM = unsafeCoerce . CE.throwIO+instance MonadCatch CIO where+  catch m h = unsafeCoerce $ CE.catch (unsafeCoerce m) (unsafeCoerce . h)++-- | Run the server event loop for a single endpoint.+serverLoop :: NodeEnv m -> Int -> IO ()+serverLoop env port = do+    run port $ websocketsOr defaultConnectionOptions handleWS handleHttp+  where+    handleWS = acceptRequest >=> clientLoop++    clientLoop c = do+      msg <- toJSString . toString <$> receiveData c+      _ <- forkIO $ handlePacket env c msg+      clientLoop c++    handleHttp _ resp = do+      resp $ responseLBS status404 [] "WebSockets only"++handlePacket :: NodeEnv m -> Connection -> JSString -> IO ()+handlePacket env c msg = do+  case decodeJSON msg >>= fromJSON of+    Right (ServerCall nonce method args) -> handleCall env c nonce method args+    _                                    -> error "invalid server call"++-- | Handle a call to this specific node. Note that the method itself is+--   executed in the CIO monad by the handler.+handleCall :: NodeEnv m -> Connection -> Nonce -> StaticKey -> [JSON] -> IO ()+handleCall (NodeEnv env) c nonce method args = concurrent $ do+  mm <- liftIO $ unsafeLookupStaticPtr method+  case mm of+    Just m -> do+      result <- try $ deRefStaticPtr m env args+      let reply = case result of+            Right r                -> ServerReply nonce r+            Left (SomeException e) -> ServerEx nonce (show e)+      liftIO $ sendTextData c $ fromString $ fromJSStr $ encodeJSON $ toJSON reply+    _ -> do+      error $ "no such method: " ++ show method++instance Typeable a => MonadClient (EnvServer a) where+  remoteCall (WebSocket h p) msg n = liftIO $ do+    WS.runClient h p "/" $ \ c' -> do+      sendTextData c' (fromString $ fromJSStr msg)+      reply <- toJSString . toString <$> receiveData c'+      case decodeJSON reply >>= fromJSON of+        Right (ServerReply n' msg) -> return msg+        Right (ServerEx _ msg)     -> throwM (ServerException msg)+        Left e                     -> throwM (NetworkException $ show e)+#endif

@@ -0,0 +1,31 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}+-- | Base type for Haste.App native servers.+module Haste.App.Server.Type where+import Control.Monad.IO.Class+import Control.Monad.Reader+import Data.Proxy+import Data.Typeable+import Haste.Concurrent+import Haste.App.Protocol.Types++-- | A server type, providing the base for more advanced, custom servers.+--   In order to make a simple single-server application, creating an+--   appropriate instance of 'Node' for 'Server' is all that's needed.+type Server = EnvServer ()++-- | Invoke a standard server. This is the 'invoke' method when+--   creating 'Node' instances for @EnvServer@.+invokeServer :: e -> EnvServer e a -> CIO a+invokeServer env = flip runReaderT env . runEnvS++-- | A local endpoint using its type fingerprint as its identifier.+localEndpoint :: Typeable m => Proxy m -> Endpoint+localEndpoint = LocalNode . show . typeRepFingerprint . typeRep++-- | A server type with an environment.+newtype EnvServer e a = EnvS {runEnvS :: ReaderT e CIO a}+  deriving (Functor, Applicative, Monad, MonadIO, MonadConc, MonadReader e)++instance MonadConc (ReaderT e CIO) where+  liftCIO = lift . liftCIO+  fork m = lift . fork . runReaderT m =<< ask

@@ -0,0 +1,32 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- | Data transport handling for a nodes capable of acting as clients.+module Haste.App.Transport+  ( MonadClient (..)+  , getNonce+  ) where+import Control.Monad.IO.Class+import Data.IORef+import Data.Proxy+import Data.Typeable+import Haste.JSON (JSON)+import Haste.Concurrent (MonadConc)+import qualified Haste.JSString as S+import System.IO.Unsafe+import Haste.App.Protocol++{-# NOINLINE nonceRef #-}+nonceRef :: IORef Nonce+nonceRef = unsafePerformIO $ newIORef 0++-- | Get a nonce that's guaranteed to be unique per physical machine, modulo+--   overflow. By extension, this means that the nonce is guaranteed to be+--   unique per node as well.+getNonce :: MonadIO m => m Nonce+getNonce = liftIO $ atomicModifyIORef' nonceRef $ \n -> (n+1, n)++class (Typeable m, MonadConc m) => MonadClient m where+  -- | Invoke a remote function: send the RPC call over the network and wait for+  --   the response to get back.+  --   The message received from the server will be a 'ServerReply'. Instances+  --   of this class must return the JSON within that reply.+  remoteCall :: Endpoint -> S.JSString -> Nonce -> m JSON