module Transient.Move(
Cloud(..),runCloudIO, runCloudIO',local,onAll,lazy, loggedc, lliftIO,localIO,
listen, Transient.Move.connect, connect', fullStop,
wormhole, teleport, copyData,
beamTo, forkTo, streamFrom, callTo, runAt, atRemote,
clustered, mclustered,
newMailbox, putMailbox,getMailbox,cleanMailbox,
#ifndef ghcjs_HOST_OS
setBuffSize, getBuffSize,
#endif
createNode, createWebNode, createNodeServ, getMyNode, getNodes,
addNodes, shuffleNodes,
getWebServerNode, Node(..), nodeList, Connection(..), Service(),
isBrowserInstance, Prefix(..), addPrefix
,defConnection
) where
import Transient.Base
import Transient.Internals(IDynamic(..),killChildren,getCont,runCont,EventF(..),LogElem(..),Log(..)
,onNothing,RemoteStatus(..),getCont,StateIO,readsPrec')
import Transient.Logged
import Transient.Indeterminism(choose)
import Transient.EVars
import Data.Typeable
import Control.Applicative
#ifndef ghcjs_HOST_OS
import Network
import Network.Info
import qualified Data.IP as IP
import qualified Network.Socket as NS
import qualified Network.BSD as BSD
import qualified Network.WebSockets as NWS(RequestHead(..))
import qualified Network.WebSockets.Connection as WS
import Network.WebSockets.Stream hiding(parse)
import qualified Data.ByteString as B (ByteString,concat)
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy.Internal as BLC
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BS
import Network.Socket.ByteString as SBS(send,sendMany,sendAll,recv)
import qualified Network.Socket.ByteString.Lazy as SBSL
import Data.CaseInsensitive(mk)
import Data.Char(isSpace)
#else
import JavaScript.Web.WebSocket
import qualified JavaScript.Web.MessageEvent as JM
import GHCJS.Prim (JSVal)
import GHCJS.Marshal(fromJSValUnchecked)
import qualified Data.JSString as JS
import JavaScript.Web.MessageEvent.Internal
import GHCJS.Foreign.Callback.Internal (Callback(..))
import qualified GHCJS.Foreign.Callback as CB
import Data.JSString (JSString(..), pack)
#endif
import qualified Data.Text as T
import Control.Monad.State
import System.IO
import Control.Exception
import Data.Maybe
import Unsafe.Coerce
import Control.Monad
import System.IO.Unsafe
import Control.Concurrent.STM as STM
import Control.Concurrent.MVar
import Data.Monoid
import qualified Data.Map as M
import Data.List (nub,(\\),find, insert)
import Data.IORef
import System.IO
import Control.Concurrent
import System.Random
import Data.Dynamic
import Data.String
#ifdef ghcjs_HOST_OS
type HostName = String
newtype PortID = PortNumber Int deriving (Read, Show, Eq, Typeable)
#endif
data Node= Node{ nodeHost :: HostName
, nodePort :: Int
, connection :: MVar Pool
, nodeServices :: [Service]
}
deriving (Typeable)
instance Ord Node where
compare node1 node2= compare (nodeHost node1,nodePort node1)(nodeHost node2,nodePort node2)
newtype Cloud a= Cloud {runCloud ::TransIO a} deriving (Functor,Applicative,Monoid,Alternative, Monad, MonadState EventF)
local :: Loggable a => TransIO a -> Cloud a
local = Cloud . logged
runCloudIO :: Cloud a -> IO a
runCloudIO (Cloud mx)= keep mx
runCloudIO' :: Cloud a -> IO a
runCloudIO' (Cloud mx)= keep' mx
onAll :: TransIO a -> Cloud a
onAll = Cloud
lazy :: TransIO a -> Cloud a
lazy mx= onAll $ getCont >>= \st -> Transient $
return $ unsafePerformIO $ runStateT (runTrans mx) st >>= return .fst
loggedc :: Loggable a => Cloud a -> Cloud a
loggedc (Cloud mx)= Cloud $ logged mx
lliftIO :: Loggable a => IO a -> Cloud a
lliftIO= local . liftIO
localIO :: Loggable a => IO a -> Cloud a
localIO= lliftIO
fullStop :: Cloud stop
fullStop= onAll $ setData WasRemote >> stop
beamTo :: Node -> Cloud ()
beamTo node = wormhole node teleport
forkTo :: Node -> Cloud ()
forkTo node= beamTo node <|> return()
callTo :: Loggable a => Node -> Cloud a -> Cloud a
callTo node remoteProc=
wormhole node $ atRemote remoteProc
atRemote proc= loggedc $ do
teleport
r <- Cloud $ runCloud proc <** setData WasRemote
teleport
return r
runAt :: Loggable a => Node -> Cloud a -> Cloud a
runAt= callTo
msend :: Loggable a => Connection -> StreamData a -> TransIO ()
#ifndef ghcjs_HOST_OS
msend (Connection _(Just (Node2Node _ sock _)) _ _ blocked _ _ ) r= do
r <- liftIO $ do
withMVar blocked $
const $ do
SBS.send sock $ BC.pack (show r)
return Nothing
`catch` (\(e::SomeException) -> return $ Just e)
case r of
Nothing -> return()
juste -> finish juste
msend (Connection _(Just (Node2Web sconn)) _ _ blocked _ _) r=liftIO $
withMVar blocked $ const $ WS.sendTextData sconn $ BS.pack (show r)
#else
msend (Connection _ (Just (Web2Node sconn)) _ _ blocked _ _) r= liftIO $
withMVar blocked $ const $ JavaScript.Web.WebSocket.send (JS.pack $ show r) sconn
#endif
msend (Connection _ Nothing _ _ _ _ _ ) _= error "msend out of wormhole context"
mread :: Loggable a => Connection -> TransIO (StreamData a)
#ifdef ghcjs_HOST_OS
mread (Connection _ (Just (Web2Node sconn)) _ _ _ _ _)= wsRead sconn
wsRead :: Loggable a => WebSocket -> TransIO a
wsRead ws= do
dat <- react (hsonmessage ws) (return ())
case JM.getData dat of
JM.StringData str -> return (read' $ JS.unpack str)
JM.BlobData blob -> error " blob"
JM.ArrayBufferData arrBuffer -> error "arrBuffer"
wsOpen :: JS.JSString -> TransIO WebSocket
wsOpen url= do
ws <- liftIO $ js_createDefault url
react (hsopen ws) (return ())
return ws
foreign import javascript safe
"window.location.hostname"
js_hostname :: JSVal
foreign import javascript safe
"(function(){var res=window.location.href.split(':')[2];if (res === undefined){return 80} else return res.split('/')[0];})()"
js_port :: JSVal
foreign import javascript safe
"$1.onmessage =$2;"
js_onmessage :: WebSocket -> JSVal -> IO ()
getWebServerNode :: TransIO Node
getWebServerNode = liftIO $
createNode <$> (fromJSValUnchecked js_hostname)
<*> (fromIntegral <$> (fromJSValUnchecked js_port :: IO Int))
hsonmessage ::WebSocket -> (MessageEvent ->IO()) -> IO ()
hsonmessage ws hscb= do
cb <- makeCallback MessageEvent hscb
js_onmessage ws cb
foreign import javascript safe
"$1.onopen =$2;"
js_open :: WebSocket -> JSVal -> IO ()
newtype OpenEvent = OpenEvent JSVal deriving Typeable
hsopen :: WebSocket -> (OpenEvent ->IO()) -> IO ()
hsopen ws hscb= do
cb <- makeCallback OpenEvent hscb
js_open ws cb
makeCallback :: (JSVal -> a) -> (a -> IO ()) -> IO JSVal
makeCallback f g = do
Callback cb <- CB.syncCallback1 CB.ContinueAsync (g . f)
return cb
foreign import javascript safe
"new WebSocket($1)" js_createDefault :: JS.JSString -> IO WebSocket
#else
mread (Connection _(Just (Node2Node _ _ _)) _ _ blocked _ _ ) = parallelReadHandler
mread (Connection node (Just (Node2Web sconn )) bufSize events blocked _ _)=
parallel $ do
s <- WS.receiveData sconn
return . read' $ BS.unpack s
getWebServerNode :: TransIO Node
getWebServerNode = getMyNode
#endif
read' s= case readsPrec' 0 s of
[(x,"")] -> x
_ -> error $ "reading " ++ s
wormhole :: Loggable a => Node -> Cloud a -> Cloud a
wormhole node (Cloud comp) = local $ Transient $ do
moldconn <- getData :: StateIO (Maybe Connection)
mclosure <- getData :: StateIO (Maybe Closure)
logdata@(Log rec log fulLog) <- getData `onNothing` return (Log False [][])
mynode <- runTrans getMyNode
if not rec
then runTrans $ (do
conn <- mconnect node
setData conn{calling= True}
#ifdef ghcjs_HOST_OS
addPrefix
#endif
comp )
<*** do when (isJust moldconn) . setData $ fromJust moldconn
when (isJust mclosure). setData $ fromJust mclosure
else do
let conn = fromMaybe (error "wormhole: no connection in remote node") moldconn
setData $ conn{calling= False}
runTrans $ comp
<*** do
when (isJust mclosure) . setData $ fromJust mclosure
#ifndef ghcjs_HOST_OS
type JSString= String
pack= id
#endif
newtype Prefix= Prefix JSString deriving(Read,Show)
addPrefix= Transient $ do
r <- liftIO $ replicateM 5 (randomRIO ('a','z'))
setData $ Prefix $ pack r
return $ Just ()
teleport :: Cloud ()
teleport = do
local $ Transient $ do
cont <- get
Log rec log fulLog <- getData `onNothing` return (Log False [][])
if not rec
then do
conn@Connection{closures= closures,calling= calling} <- getData
`onNothing` error "teleport: No connection defined: use wormhole"
Closure closRemote <- getData `onNothing` return (Closure 0 )
let closLocal = sum $ map (\x-> case x of Wait-> 1000; _ -> 1) fulLog
liftIO $ modifyMVar_ closures $ \map -> return $ M.insert closLocal (fulLog,cont) map
let tosend= reverse $ if closRemote==0 then fulLog else log
runTrans $ msend conn $ SMore (closRemote,closLocal, tosend )
setData $ if (not calling) then WasRemote else WasParallel
return Nothing
else do
delData WasRemote
return (Just ())
copyData def = do
r <- local getSData <|> return def
onAll $ setData r
return r
streamFrom :: Loggable a => Node -> Cloud (StreamData a) -> Cloud (StreamData a)
streamFrom = callTo
mclose :: Connection -> IO ()
#ifndef ghcjs_HOST_OS
mclose (Connection _
(Just (Node2Node _ sock _ )) _ _ _ _ _)= NS.sClose sock
mclose (Connection node
(Just (Node2Web sconn ))
bufSize events blocked _ _)=
WS.sendClose sconn ("closemsg" :: BS.ByteString)
#else
mclose (Connection _ (Just (Web2Node sconn)) _ _ blocked _ _)=
JavaScript.Web.WebSocket.close Nothing Nothing sconn
#endif
mconnect :: Node -> TransIO Connection
mconnect node@(Node _ _ _ _ )= do
nodes <- getNodes
let fnode = filter (==node) nodes
case fnode of
[] -> addNodes [node] >> mconnect node
[Node host port pool _] -> do
plist <- liftIO $ readMVar pool
case plist of
handle:_ -> do
delData $ Closure undefined
return handle
_ -> do
my <- getMyNode
Connection{comEvent= ev} <- getSData <|> error "connect: listen not set for this node"
#ifndef ghcjs_HOST_OS
conn <- liftIO $ do
let size=8192
sock <- connectTo' size host $ PortNumber $ fromIntegral port
let conn= (defConnection 8100){myNode=my,comEvent= ev,connData= Just $ Node2Node u sock (error $ "addr: outgoing connection")}
SBS.send sock "CLOS a b\n\n"
return conn
#else
conn <- do
ws <- connectToWS host $ PortNumber $ fromIntegral port
let conn= (defConnection 8100){comEvent= ev,connData= Just $ Web2Node ws}
return conn
#endif
liftIO $ modifyMVar_ pool $ \plist -> return $ conn:plist
putMailbox "connections" (conn,node)
delData $ Closure undefined
return conn
where u= undefined
#ifndef ghcjs_HOST_OS
connectTo' bufSize hostname (PortNumber port) = do
proto <- BSD.getProtocolNumber "tcp"
bracketOnError
(NS.socket NS.AF_INET NS.Stream proto)
(sClose)
(\sock -> do
NS.setSocketOption sock NS.RecvBuffer bufSize
NS.setSocketOption sock NS.SendBuffer bufSize
he <- BSD.getHostByName hostname
NS.connect sock (NS.SockAddrInet port (BSD.hostAddress he))
return sock
)
#else
connectToWS h (PortNumber p) =
wsOpen $ JS.pack $ "ws://"++ h++ ":"++ show p
#endif
#ifndef ghcjs_HOST_OS
callTo' :: (Show a, Read a,Typeable a) => Node -> Cloud a -> Cloud a
callTo' node remoteProc= do
mynode <- local getMyNode
beamTo node
r <- remoteProc
beamTo mynode
return r
#endif
type Blocked= MVar ()
type BuffSize = Int
data ConnectionData=
#ifndef ghcjs_HOST_OS
Node2Node{port :: PortID
,socket ::Socket
,remoteNode :: NS.SockAddr
}
| Node2Web{webSocket :: WS.Connection}
#else
Web2Node{webSocket :: WebSocket}
#endif
data Connection= Connection{myNode :: Node
,connData :: Maybe(ConnectionData)
,bufferSize :: BuffSize
,comEvent :: IORef (M.Map T.Text (EVar Dynamic))
,blocked :: Blocked
,calling :: Bool
,closures :: MVar (M.Map Int ([LogElem], EventF))}
deriving Typeable
newMailbox :: T.Text -> TransIO ()
newMailbox name= do
Connection{comEvent= mv} <- getData `onNothing` errorMailBox
ev <- newEVar
liftIO $ atomicModifyIORef mv $ \mailboxes -> (M.insert name ev mailboxes,())
putMailbox :: Typeable a => T.Text -> a -> TransIO ()
putMailbox name dat= do
Connection{comEvent= mv} <- getData `onNothing` errorMailBox
mbs <- liftIO $ readIORef mv
let mev = M.lookup name mbs
case mev of
Nothing ->newMailbox name >> putMailbox name dat
Just ev -> writeEVar ev $ toDyn dat
errorMailBox= error "MailBox: No connection open.Use wormhole"
getMailbox name= do
Connection{comEvent= mv} <- getData `onNothing` errorMailBox
mbs <- liftIO $ readIORef mv
let mev = M.lookup name mbs
case mev of
Nothing ->newMailbox name >> getMailbox name
Just ev ->do
d <- readEVar ev
case fromDynamic d of
Nothing -> empty
Just x -> return x
cleanMailbox :: Typeable a => T.Text -> a -> TransIO ()
cleanMailbox name witness= do
Connection{comEvent= mv} <- getData `onNothing` error "getMailBox: accessing network events out of listen"
mbs <- liftIO $readIORef mv
let mev = M.lookup name mbs
case mev of
Nothing -> return()
Just ev -> do cleanEVar ev
liftIO $ atomicModifyIORef mv $ \mbs -> (M.delete name mbs,())
defConnection :: Int -> Connection
defConnection size=
Connection (createNode "program" 0) Nothing size
(error "defConnection: accessing network events out of listen")
(unsafePerformIO $ newMVar ())
False (unsafePerformIO $ newMVar M.empty)
#ifndef ghcjs_HOST_OS
setBuffSize :: Int -> TransIO ()
setBuffSize size= Transient $ do
conn<- getData `onNothing` return (defConnection 8192)
setData $ conn{bufferSize= size}
return $ Just ()
getBuffSize=
(do getSData >>= return . bufferSize) <|> return 8192
listen :: Node -> Cloud ()
listen (node@(Node _ port _ _ )) = onAll $ do
addThreads 1
setData $ Log False [] []
conn' <- getSData <|> return (defConnection 8192)
ev <- liftIO $ newIORef M.empty
let conn= conn'{myNode=node, comEvent=ev}
setData conn
addNodes [node]
mlog <- listenNew (fromIntegral port) conn <|> listenResponses
execLog mlog
listenNew port conn= do
sock <- liftIO . listenOn $ PortNumber port
let bufSize= bufferSize conn
liftIO $ do NS.setSocketOption sock NS.RecvBuffer bufSize
NS.setSocketOption sock NS.SendBuffer bufSize
(sock,addr) <- waitEvents $ NS.accept sock
initFinish
onFinish $ const $ do
return()
let Connection{closures=closures}= conn
liftIO $ modifyMVar_ closures $ const $ return M.empty
(method,uri, headers) <- receiveHTTPHead sock
case method of
"CLOS" ->
do
setData $ conn{connData=Just (Node2Node (PortNumber port) sock addr)}
parallelReadHandler
_ -> do
sconn <- httpMode (method, uri, headers) sock
setData conn{connData= Just (Node2Web sconn )}
killOnFinish $ parallel $ do
msg <- WS.receiveData sconn
return . read $ BC.unpack msg
#endif
listenResponses= do
(conn, node) <- getMailbox "connections"
setData conn
#ifndef ghcjs_HOST_OS
case conn of
Connection _(Just (Node2Node _ sock _)) _ _ _ _ _ -> do
input <- liftIO $ SBSL.getContents sock
setData $ (ParseContext (error "SHOULD NOT READ 2") input :: ParseContext BS.ByteString)
#endif
initFinish
onFinish $ const $ do
liftIO $ putStrLn "removing node: ">> print node
nodes <- getNodes
setNodes $ nodes \\ [node]
let Connection{closures=closures}= conn
liftIO $ modifyMVar_ closures $ const $ return M.empty
killOnFinish $ mread conn
type IdClosure= Int
data Closure= Closure IdClosure
execLog mlog = Transient $ do
case mlog of
SError e -> do
runTrans $ finish $ Just e
return Nothing
SDone -> runTrans(finish Nothing) >> return Nothing
SMore r -> process r False
SLast r -> process r True
where
process (closl,closr,log) deleteClosure= do
Connection {closures=closures} <- getData `onNothing` error "Listen: myNode not set"
if closl== 0 then do
setData $ Log True log $ reverse log
setData $ Closure closr
return $ Just ()
else do
mcont <- liftIO $ modifyMVar closures $ \map ->
return (if deleteClosure then
M.delete closl map
else map, M.lookup closl map)
case mcont of
Nothing -> error ("received non existent closure: " ++ show closl)
Just (fulLog,cont) -> liftIO $ runStateT (do
let nlog= reverse log ++ fulLog
setData $ Log True log nlog
setData $ Closure closr
runCont cont) cont
return Nothing
#ifdef ghcjs_HOST_OS
listen node = onAll $ do
addNodes [node]
events <- liftIO $ newIORef M.empty
let conn= (defConnection 8192){myNode=node,comEvent=events}
setData conn
r <- listenResponses
execLog r
#endif
type Pool= [Connection]
type Package= String
type Program= String
type Service= (Package, Program)
emptyPool :: MonadIO m => m (MVar Pool)
emptyPool= liftIO $ newMVar []
createNodeServ :: HostName -> Integer -> [Service] -> Node
createNodeServ h p svs= Node h ( fromInteger p) (unsafePerformIO emptyPool) svs
createNode :: HostName -> Integer -> Node
createNode h p= createNodeServ h p []
createWebNode :: Node
createWebNode= Node "webnode" ( fromInteger 0) (unsafePerformIO emptyPool)
[("webnode","")]
instance Eq Node where
Node h p _ _ ==Node h' p' _ _= h==h' && p==p'
instance Show Node where
show (Node h p _ servs )= show (h,p, servs)
instance Read Node where
readsPrec _ s=
let r= readsPrec' 0 s
in case r of
[] -> []
[((h,p,ss),s')] -> [(Node h p empty
( ss),s')]
where
empty= unsafePerformIO emptyPool
nodeList :: TVar [Node]
nodeList = unsafePerformIO $ newTVarIO []
deriving instance Ord PortID
errorMyNode f= error $ f ++ ": Node not set. initialize it with connect, listen, initNode..."
getMyNode :: TransIO Node
getMyNode = do
Connection{myNode= node} <- getSData <|> errorMyNode "getMyNode" :: TransIO Connection
return node
getNodes :: MonadIO m => m [Node]
getNodes = liftIO $ atomically $ readTVar nodeList
addNodes :: [Node] -> TransIO ()
addNodes nodes= do
my <- getMyNode
liftIO . atomically $ do
prevnodes <- readTVar nodeList
writeTVar nodeList $ my: (( nub $ nodes ++ prevnodes) \\[my])
setNodes nodes= liftIO $ atomically $ writeTVar nodeList $ nodes
shuffleNodes :: MonadIO m => m [Node]
shuffleNodes= liftIO . atomically $ do
nodes <- readTVar nodeList
let nodes'= tail nodes ++ [head nodes]
writeTVar nodeList nodes'
return nodes'
clustered :: Loggable a => Cloud a -> Cloud a
clustered proc= callNodes (<|>) empty proc
mclustered :: (Monoid a, Loggable a) => Cloud a -> Cloud a
mclustered proc= callNodes (<>) mempty proc
callNodes op init proc= loggedc $ do
nodes <- local getNodes
let nodes' = filter (not . isWebNode) nodes
foldr op init $ map (\node -> runAt node proc) nodes'
where
isWebNode Node {nodeServices=srvs}
| ("webnode","") `elem` srvs = True
| otherwise = False
connect :: Node -> Node -> Cloud ()
#ifndef ghcjs_HOST_OS
connect node remotenode = do
listen node <|> return ()
connect' remotenode
connect' remotenode= do
nodes <- local $ getNodes
local $ liftIO $ putStrLn $ "connecting to: "++ show remotenode
newNodes <- runAt remotenode $ do
local $ do
conn@(Connection _(Just (Node2Node _ _ _)) _ _ _ _ _) <- getSData <|>
error ("connect': need to be connected to a node: use wormhole/connect/listen")
let nodeConnecting= head nodes
liftIO $ modifyMVar_ (connection nodeConnecting) $ const $ return [conn]
onFinish . const $ do
liftIO $ putStrLn "removing node: ">> print nodeConnecting
nodes <- getNodes
setNodes $ nodes \\ [nodeConnecting]
return nodes
mclustered . local . addNodes $ nodes
local $ do
allNodes <- getNodes
liftIO $ putStrLn "Known nodes: " >> print allNodes
return allNodes
let n = newNodes \\ nodes
when (not $ null n) $ mclustered $ local $ do
liftIO $ putStrLn "New nodes: " >> print n
addNodes n
local $ do
addNodes nodes
nodes <- getNodes
liftIO $ putStrLn "Known nodes: " >> print nodes
#else
connect _ _= empty
connect' _ = empty
#endif
#ifndef ghcjs_HOST_OS
readFrom :: Socket
-> IO BS.ByteString
readFrom sock = loop where
loop = unsafeInterleaveIO $ do
s <- SBS.recv sock 4098
if BC.null s
then return BLC.Empty
else BLC.Chunk s `liftM` loop
toStrict= B.concat . BS.toChunks
httpMode (method,uri, headers) conn = do
if isWebSocketsReq headers
then liftIO $ do
stream <- makeStream
(do
bs <- SBS.recv conn 4096
return $ if BC.null bs then Nothing else Just bs)
(\mbBl -> case mbBl of
Nothing -> return ()
Just bl -> SBS.sendMany conn (BL.toChunks bl) >> return())
let
pc = WS.PendingConnection
{ WS.pendingOptions = WS.defaultConnectionOptions
, WS.pendingRequest = NWS.RequestHead uri headers False
, WS.pendingOnAccept = \_ -> return ()
, WS.pendingStream = stream
}
sconn <- WS.acceptRequest pc
WS.forkPingThread sconn 30
return sconn
else do
let uri'= BC.tail $ uriPath uri
file= if BC.null uri' then "index.html" else uri'
content <- liftIO $ BL.readFile ( "./static/out.jsexe/"++ BC.unpack file)
`catch` (\(e:: SomeException) ->
return "Not found file: index.html<br/> please compile with ghcjs<br/> ghcjs program.hs -o static/out")
n <- liftIO $ SBS.sendMany conn $ ["HTTP/1.0 200 OK\nContent-Type: text/html\nConnection: close\nContent-Length: " <> BC.pack (show $ BL.length content) <>"\n\n"] ++
(BL.toChunks content )
empty
where
uriPath = BC.dropWhile (/= '/')
isWebSocketsReq = not . null
. filter ( (== mk "Sec-WebSocket-Key") . fst)
data ParseContext a = IsString a => ParseContext (IO a) a deriving Typeable
receiveHTTPHead s = do
input <- liftIO $ SBSL.getContents s
setData $ (ParseContext (error "request truncated. Maybe the browser program does not match the server one. \nRecompile the program again with ghcjs <prog> -o static/out") input
::ParseContext BS.ByteString)
(method, uri, vers) <- (,,) <$> getMethod <*> getUri <*> getVers
headers <- many $ (,) <$> (mk <$> getParam) <*> getParamValue
return (method, toStrict uri, headers)
where
getMethod= getString
getUri= getString
getVers= getString
getParam= do
dropSpaces
r <- tTakeWhile (\x -> x /= ':' && not (endline x))
if BS.null r || r=="\r" then empty else dropChar >> return(toStrict r)
getParamValue= toStrict <$> ( dropSpaces >> tTakeWhile (\x -> not (endline x)))
dropSpaces= parse $ \str ->((),BS.dropWhile isSpace str)
dropChar= parse $ \r -> ((), BS.tail r)
endline c= c== '\n' || c =='\r'
readStream :: Read a => BS.ByteString -> [StreamData a]
readStream s= readStream1 $ BS.unpack s
where
readStream1 s=
let [(x,r)] = reads s
in x : readStream1 r
parallelReadHandler :: Loggable a => TransIO (StreamData a)
parallelReadHandler= do
ParseContext readit str <- getSData <|> error "parallelReadHandler: ParseContext not found"
:: (TransIO (ParseContext BS.ByteString))
r <- killOnFinish $ choose $ readStream str
return r
getString= do
dropSpaces
tTakeWhile (not . isSpace)
tTakeWhile :: (Char -> Bool) -> TransIO BS.ByteString
tTakeWhile cond= parse (BS.span cond)
parse :: Monoid b => (BS.ByteString -> (b, BS.ByteString)) -> TransIO b
parse split= do
ParseContext readit str <- getSData
<|> error "parse: ParseContext not found"
:: TransIO (ParseContext BS.ByteString)
if str == mempty
then do
str3 <- liftIO readit
setData $ ParseContext readit str3
if str3== mempty then empty else parse split
else if BS.take 2 str =="\n\n" then do setData $ ParseContext readit (BS.drop 2 str) ; empty
else if BS.take 4 str== "\r\n\r\n" then do setData $ ParseContext readit (BS.drop 4 str) ; empty
else do
let (ret,str3) = split str
setData $ ParseContext readit str3
if str3== mempty
then return ret <> (parse split <|> return mempty)
else return ret
#endif
#ifdef ghcjs_HOST_OS
isBrowserInstance= True
#else
isBrowserInstance= False
#endif