module Haste.App.Monad (
Remotable,
App, Server, Sessions, SessionID, Remote (..), Done (..),
AppCfg, def, mkConfig, cfgURL, cfgPort,
liftServerIO, forkServerIO, remote, getAppConfig,
runApp, (<.>), getSessionID, getActiveSessions, onSessionEnd
) where
import Control.Applicative
import Control.Monad (ap)
import Control.Monad.IO.Class
import Haste.Binary
import Haste.Binary.Types
import qualified Data.Map as M
import qualified Data.Set as S
import Haste.App.Protocol
import Data.Word
import Control.Concurrent (ThreadId)
import Data.IORef
import Data.Default
import System.IO.Unsafe
#ifndef __HASTE__
import Haste.Binary.Types
import Control.Concurrent (forkIO)
import Haste.Prim (toJSStr, fromJSStr)
import Network.WebSockets as WS
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.UTF8 as BU
import Control.Exception
import System.Random
import Data.List (foldl')
import Data.String
#endif
data AppCfg = AppCfg {
cfgURL :: String,
cfgPort :: Int,
cfgSessionEndHandlers :: [SessionID -> Server ()]
}
instance Default AppCfg where
def = mkConfig "ws://localhost:24601" 24601
mkConfig :: String -> Int -> AppCfg
mkConfig url port = AppCfg {
cfgURL = url,
cfgPort = port,
cfgSessionEndHandlers = []
}
type SessionID = Word64
type Sessions = S.Set SessionID
type Method = [Blob] -> SessionID -> IORef Sessions -> IO Blob
type Exports = M.Map CallID Method
newtype Done = Done (IO ())
#ifdef __HASTE__
data Remote a = Remote CallID [Blob]
#else
data Remote a = Remote
#endif
hasteAppRunning :: IORef Bool
hasteAppRunning = unsafePerformIO $ newIORef False
(<.>) :: Binary a => Remote (a -> b) -> a -> Remote b
#ifdef __HASTE__
(Remote cid args) <.> arg = Remote cid (encode arg:args)
#else
_ <.> _ = Remote
#endif
newtype App a = App {
unA :: AppCfg
-> IORef Sessions
-> CallID
-> Exports
-> IO (a, CallID, Exports, AppCfg)
}
instance Monad App where
return x = App $ \c _ cid exports -> return (x, cid, exports, c)
(App m) >>= f = App $ \cfg sessions cid exports -> do
res <- m cfg sessions cid exports
case res of
(x, cid', exports', cfg') -> unA (f x) cfg' sessions cid' exports'
instance Functor App where
fmap f m = m >>= return . f
instance Applicative App where
(<*>) = ap
pure = return
liftServerIO :: IO a -> App (Server a)
#ifdef __HASTE__
liftServerIO _ = return Server
#else
liftServerIO m = App $ \cfg _ cid exports -> do
x <- m
return (return x, cid, exports, cfg)
#endif
forkServerIO :: Server () -> App (Server ThreadId)
#ifdef __HASTE__
forkServerIO _ = return Server
#else
forkServerIO (Server m) = App $ \cfg sessions cid exports -> do
tid <- forkIO $ m 0 sessions
return (return tid, cid, exports, cfg)
#endif
class Remotable a where
serializify :: a -> [Blob] -> (SessionID -> IORef Sessions -> IO Blob)
instance Binary a => Remotable (Server a) where
#ifdef __HASTE__
serializify _ _ = undefined
#else
serializify (Server m) _ = \sid ss -> fmap encode (m sid ss)
#endif
instance (Binary a, Remotable b) => Remotable (a -> b) where
#ifdef __HASTE__
serializify _ _ = undefined
#else
serializify f (x:xs) = serializify (f $! fromEither $ decode (toBD x)) xs
where
toBD (Blob x) = BlobData x
fromEither (Right val) = val
fromEither (Left e) = error $ "Unable to deserialize data: " ++ e
serializify _ _ = error "The impossible happened in serializify!"
#endif
remote :: Remotable a => a -> App (Remote a)
#ifdef __HASTE__
remote _ = App $ \c _ cid _ ->
return (Remote cid [], cid+1, undefined, c)
#else
remote s = App $ \c _ cid exports ->
return (Remote, cid+1, M.insert cid (serializify s) exports, c)
#endif
onSessionEnd :: (SessionID -> Server ()) -> App ()
#ifdef __HASTE__
onSessionEnd _ = return ()
#else
onSessionEnd s = App $ \cfg _ cid exports -> return $
((), cid, exports, cfg {cfgSessionEndHandlers = s:cfgSessionEndHandlers cfg})
#endif
getAppConfig :: App AppCfg
getAppConfig = App $ \cfg _ cid exports -> return (cfg, cid, exports, cfg)
runApp :: AppCfg -> App Done -> IO ()
runApp cfg (App s) = do
running <- atomicModifyIORef hasteAppRunning $ \r -> (True, r)
if running
then do
error "runApp is single-entry!"
else do
#ifdef __HASTE__
(Done client, _, _, _) <- s cfg undefined 0 undefined
client
#else
sessions <- newIORef S.empty
(_, _, exports, cfg') <- s cfg sessions 0 M.empty
serverEventLoop cfg' sessions exports
#endif
#ifndef __HASTE__
serverEventLoop :: AppCfg -> IORef Sessions -> Exports -> IO ()
serverEventLoop cfg sessions exports = do
WS.runServer "0.0.0.0" (cfgPort cfg) $ \pending -> do
conn <- acceptRequest pending
sid <- randomRIO (1, 0xFFFFFFFFFFFFFFFF)
atomicModifyIORef sessions $ \s -> (S.insert sid s, ())
clientLoop sid sessions conn
where
cleanup :: Connection -> SessionID -> IORef Sessions -> IO ()
cleanup conn deadsession sref = do
let f next m = unS (m deadsession) deadsession sref >> next
foldl' f (return ()) (cfgSessionEndHandlers cfg)
atomicModifyIORef sref $ \cs -> (S.delete deadsession cs, ())
let Blob bs = encode $ ServerException "Session ended"
sendTextData conn bs
clientLoop :: SessionID -> IORef Sessions -> Connection -> IO ()
clientLoop sid sref c = finally go (cleanup c sid sref)
where
go = do
msg <- receiveData c
forkIO $ do
case decode (BlobData msg) of
Right (ServerCall nonce method args)
| Just m <- M.lookup method exports -> do
result <- m args sid sref
let Blob bs = encode $ ServerReply {
srNonce = nonce,
srResult = result
}
sendBinaryData c bs
_ -> do
error $ "Got bad method call: " ++ show msg
go
#endif
#ifdef __HASTE__
data Server a = Server
#else
newtype Server a = Server {unS :: SessionID -> IORef Sessions -> IO a}
#endif
instance Functor Server where
#ifdef __HASTE__
fmap _ _ = Server
#else
fmap f (Server m) = Server $ \sid ss -> f <$> m sid ss
#endif
instance Applicative Server where
(<*>) = ap
pure = return
instance Monad Server where
#ifdef __HASTE__
return _ = Server
_ >>= _ = Server
#else
return x = Server $ \_ _ -> return x
(Server m) >>= f = Server $ \sid ss -> do
Server m' <- f <$> m sid ss
m' sid ss
#endif
instance MonadIO Server where
#ifdef __HASTE__
liftIO _ = Server
#else
liftIO m = Server $ \_ _ -> m
#endif
instance MonadBlob Server where
#ifndef __HASTE__
getBlobData (Blob bd) = return $ BlobData bd
getBlobText' (Blob bd) = return $ fromString $ BU.toString $ BS.concat $ BSL.toChunks bd
#else
getBlobData _ = Server
getBlobText' _ = Server
#endif
getSessionID :: Server SessionID
#ifdef __HASTE__
getSessionID = Server
#else
getSessionID = Server $ \sid _ -> return sid
#endif
getActiveSessions :: Server Sessions
#ifdef __HASTE__
getActiveSessions = Server
#else
getActiveSessions = Server $ \_ ss -> readIORef ss
#endif