n2o-web (empty) → 0.11.0

raw patch · 7 files changed

+366/−0 lines, 7 filesdep +attoparsecdep +basedep +base64-bytestringsetup-changed

Dependencies added: attoparsec, base, base64-bytestring, bert, binary, bytestring, case-insensitive, containers, fmt, n2o, n2o-protocols, network, text, websockets

Files

LICENSE +30/−0
README.md +0/−0
Setup.hs +2/−0
n2o-web.cabal +43/−0
src/Network/N2O/Web.hs +26/−0
src/Network/N2O/Web/Http.hs +147/−0
src/Network/N2O/Web/WebSockets.hs +118/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Marat Khafizov (c) 2018
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Marat Khafizov nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

+ Setup.hs view

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

+ n2o-web.cabal view

@@ -0,0 +1,43 @@+name:           n2o-web
+version:        0.11.0
+description:    Poor man's WebSocket and HTTP static servers.
+homepage:       https://github.com/xafizoff/n2o-hs#readme
+bug-reports:    https://github.com/xafizoff/n2o-hs/issues
+author:         Marat Khafizov
+maintainer:     xafizoff@gmail.com
+copyright:      2018 Marat Khafizov (c)
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+cabal-version:  >= 1.10
+extra-source-files:  README.md
+synopsis:       N2O adapter for WebSockets
+category:       Network, N2O, Web
+
+source-repository head
+  type: git
+  location: https://github.com/xafizoff/n2o-hs
+
+library
+  exposed-modules: Network.N2O.Web
+                 , Network.N2O.Web.Http
+                 , Network.N2O.Web.WebSockets
+  other-modules:
+      Paths_n2o_web
+  hs-source-dirs:
+      src
+  build-depends: base >= 4.7 && < 5
+               , n2o == 0.11.0
+               , n2o-protocols == 0.11.0
+               , websockets >= 0.12.5
+               , network >= 2.6
+               , text >= 1.2
+               , bytestring >= 0.10
+               , binary >= 0.5
+               , bert >= 1.2
+               , attoparsec >= 0.13.2
+               , case-insensitive >= 1.2
+               , containers >= 0.5
+               , fmt >= 0.1.6
+               , base64-bytestring >= 1.0
+  default-language: Haskell2010

+ src/Network/N2O/Web.hs view

@@ -0,0 +1,26 @@+{-|
+Module      : Network.N2O.Web
+Description : Static HTTP Server and Bridge for WebSockets
+Copyright   : (c) Marat Khafizov, 2018
+License     : BSD-3
+Maintainer  : xafizoff@gmail.com
+Stability   : experimental
+Portability : not portable
+
+This package provides a simple static HTTP server and adapter
+for WebSockets to the N2O Protocol Loop.
+
+Disclaimer: an HTTP server is not for production use. Please consider
+to use more robust static server like NGinx or something like
+
+* https://hackage.haskell.org/package/wai-websockets
+* https://hackage.haskell.org/package/websockets-snap
+
+-}
+module Network.N2O.Web
+ ( module Network.N2O.Web.WebSockets
+ , module Network.N2O.Web.Http
+ ) where
+
+import Network.N2O.Web.WebSockets
+import Network.N2O.Web.Http

+ src/Network/N2O/Web/Http.hs view

@@ -0,0 +1,147 @@+{-# LANGUAGE LambdaCase, RecordWildCards #-}
+{- | Naive implementation of HTTP server
+TODO:
+* graceful exit
+-}
+module Network.N2O.Web.Http ( runServer ) where
+
+import Control.Concurrent
+import Control.Exception (catch, finally, SomeException(..), bracket, try)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as C
+import Network.Socket hiding (recv, send)
+import Network.Socket.ByteString
+import Network.N2O.Types
+import Network.N2O.Protocols.Types
+import Network.N2O.Core
+import Network.N2O.Web.WebSockets
+import Prelude hiding (takeWhile)
+import Data.Attoparsec.ByteString hiding (try)
+import Data.CaseInsensitive
+import qualified Network.WebSockets as WS
+
+data HttpConf = HttpConf
+
+data Resp = Resp
+  { respCode :: Int
+  , respHead :: [Header]
+  , respBody :: BS.ByteString
+  } deriving (Show)
+
+mkResp = Resp { respCode = 200, respHead = [], respBody = BS.empty }
+
+runServer :: String -> Int -> Context N2OProto a -> IO ()
+runServer host port cx =
+  withSocketsDo $ do
+    addr <- resolve host (show port)
+    bracket (open addr) close (acceptConnections HttpConf cx)
+  where
+    resolve host port = do
+      let hints = defaultHints {addrSocketType = Stream, addrFlags = [AI_PASSIVE]}
+      addr:_ <- getAddrInfo (Just hints) (Just host) (Just port)
+      return addr
+    open addr = do
+      sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+      setSocketOption sock ReuseAddr 1
+      bind sock (addrAddress addr)
+      listen sock 10
+      return sock
+
+acceptConnections :: HttpConf -> Context N2OProto a -> Socket -> IO ()
+acceptConnections conf cx sock = do
+  (handle, host_addr) <- accept sock
+  forkIO (catch
+            (talk conf cx handle host_addr `finally` close handle)
+            (\e@(SomeException _) -> print e))
+  acceptConnections conf cx sock
+
+talk :: HttpConf -> Context N2OProto a -> Socket -> SockAddr -> IO ()
+talk conf cx sock addr = do
+  bs <- recv sock 4096
+  let either = parseReq bs
+  case either of
+    Left resp -> sendResp conf sock resp
+    Right req ->
+      if needUpgrade req
+        then do
+          pending <- mkPending WS.defaultConnectionOptions sock req
+          wsApp cx {cxReq = req} pending
+        else fileResp (preparePath $ C.unpack $ reqPath req) (sendResp conf sock)
+  where
+    preparePath ('/':path) = path
+    preparePath path = path
+
+status = \case
+  200 -> "OK"
+  400 -> "Bad Request"
+  404 -> "Not Found"
+  500 -> "Internal Server Eror"
+  _   -> ""
+
+calcLen resp@Resp{..} = (C.pack "Content-Length", C.pack $ show $ BS.length respBody) : respHead
+
+sendResp :: HttpConf -> Socket -> Resp -> IO ()
+sendResp conf sock resp@Resp {..} = do
+  let headers = fmap (\(k, v) -> k <> C.pack ": " <> v <> C.pack "\r\n") (calcLen resp)
+      cmd = C.pack "HTTP/1.1 " <> C.pack (show respCode) <> C.pack " " <> C.pack (status respCode) <> C.pack "\r\n"
+      x = cmd : headers
+      y = x ++ [C.pack "\r\n", respBody]
+  send sock (mconcat y)
+  return ()
+
+fileResp :: FilePath -> (Resp -> IO ()) -> IO ()
+fileResp path respond = do
+  res <- try (BS.readFile path)
+  let (status, content) = case res of
+                            Left e@(SomeException _) -> (404, C.pack "File Not Found")
+                            Right content -> (200, content)
+  respond $ mkResp {respCode = status, respBody = content}
+
+parseReq :: BS.ByteString -> Either Resp Req
+parseReq bs = case parseOnly reqParser bs of
+                Left _ -> Left $ mkResp {respCode = 400}
+                Right req -> Right req
+
+needUpgrade :: Req -> Bool
+needUpgrade req =
+  case getHeader (C.pack "upgrade") (reqHead req) of
+    Nothing -> False
+    Just h -> mk (snd h) == mk (C.pack "websocket")
+
+isKeepAlive :: Req -> Bool
+isKeepAlive req =
+  case getHeader (C.pack "connection") (reqHead req) of
+    Nothing -> False
+    Just h -> mk (snd h) == mk (C.pack "keep-alive")
+
+getHeader :: BS.ByteString -> [Header] -> Maybe Header
+getHeader _ [] = Nothing
+getHeader k (h:hs)
+  | mk k == mk (fst h) = Just h
+  | otherwise = getHeader k hs
+
+crlf = (||) <$> (==10) <*> (==13)
+isSpace = (== 32)
+
+reqParser :: Parser Req
+reqParser = do
+    cmd <- takeWhile1 $ not.isSpace
+    skipWhile isSpace
+    path <- takeWhile1 $ not.isSpace
+    skipWhile isSpace
+    ver <- takeWhile1 $ not.crlf
+    skipWhile crlf
+    headers <- many' headerParser
+    skipWhile crlf
+    takeByteString
+    endOfInput
+    return $ mkReq {reqMeth = cmd, reqPath = path, reqVers = ver, reqHead = headers }
+
+headerParser :: Parser (BS.ByteString, BS.ByteString)
+headerParser = do
+    name <- takeWhile1 (\b -> b /= 58 && b /= 10 && b /= 13)
+    skip (== 58)
+    skipWhile isSpace
+    val <- takeWhile1 $ not.crlf
+    skipWhile crlf
+    return (name, val)

+ src/Network/N2O/Web/WebSockets.hs view

@@ -0,0 +1,118 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}++module Network.N2O.Web.WebSockets+  ( wsApp+  , mkPending+  ) where++import Control.Exception (catch, finally)+import Control.Monad (forM_, forever, mapM_)+import Data.BERT+import qualified Data.Binary as B+import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as LC8+import Data.CaseInsensitive (mk)+import Data.IORef+import qualified Data.Map.Strict as MW+import qualified Data.Map.Strict as M+import qualified Data.Text.Lazy as T+import Data.Text.Lazy.Encoding+import Network.N2O.Core+import Network.N2O.Protocols.Types as Proto+import Network.N2O.Types+import Network.Socket (Socket)+import qualified Network.WebSockets as WS+import qualified Network.WebSockets.Connection as WSConn+import qualified Network.WebSockets.Stream as WSStream++wsApp :: Context N2OProto a -> WS.ServerApp+wsApp cx pending = do+  let path = WS.requestPath $ WS.pendingRequest pending+      cx1 = cx {cxReq = mkReq {reqPath = path}}+      handlers = cxMiddleware cx1+      applyHandlers hs ctx =+        case hs of+          [] -> ctx+          (h:hs') -> applyHandlers hs' (h ctx)+      cx2 = applyHandlers handlers cx1+  conn <- WS.acceptRequest pending+  ref <- newIORef cx2+  WS.forkPingThread conn 30+  listen conn ref++-- | Make pending WS request from N2O request
+mkPending :: WS.ConnectionOptions -> Socket -> Req -> IO WS.PendingConnection+mkPending opts sock req = do+  stream <- WSStream.makeSocketStream sock+  let requestHead =+        WS.RequestHead+          { WS.requestPath = reqPath req+          , WS.requestSecure = False+          , WS.requestHeaders = fmap (\(k, v) -> (mk k, v)) (reqHead req)+          }+  return+    WSConn.PendingConnection+      { WSConn.pendingOptions = opts+      , WSConn.pendingRequest = requestHead+      , WSConn.pendingOnAccept = \_ -> return ()+      , WSConn.pendingStream = stream+      }++listen :: WS.Connection -> State N2OProto a -> IO ()+listen conn ref =+  do pid <- receiveN2O conn ref+     cx@Context {cxProtos = protos} <- readIORef ref+     forever $ do+       message <- WS.receiveDataMessage conn+       case message of+         WS.Text "PING" _ -> WS.sendTextData conn ("PONG" :: T.Text)+         WS.Binary bin ->+           case B.decodeOrFail bin of+             Right (_, _, term) ->+               case fromBert term of+                 Just msg -> do+                   reply <- runN2O (protoRun msg protos) ref+                   process conn reply+                 _ -> return ()+             _ -> return ()+         _ -> error "Unknown message"+     `finally` do+    cx@Context {cxProtos = protos} <- readIORef ref+    runN2O (protoRun (N2ONitro Done) protos) ref+    return ()++process conn reply =+  case reply of+    Reply a -> WS.sendBinaryData conn (B.encode $ toBert a)+    _ -> error "Unknown response type"++receiveN2O conn ref = do+  message <- WS.receiveDataMessage conn+  cx@Context {cxProtos = protos} <- readIORef ref+  case message of+    WS.Binary _ -> error "Protocol violation: expected text message"+    WS.Text "" _ -> error "Protocol violation: got empty text"+    WS.Text bs _ ->+      case LC8.stripPrefix "N2O," bs of+        Just pid -> do+          reply <- runN2O (protoRun (N2ONitro $ Proto.Init pid) protos) ref+          process conn reply+          return pid+        _ -> error "Protocol violation"++-- | Convert Binary Erlang Terms (BERT) to the 'N2OProto' specification
+fromBert :: Term -> Maybe (N2OProto a)+fromBert (TupleTerm [AtomTerm "init", BytelistTerm pid]) =+  Just $ N2ONitro (Proto.Init pid)+fromBert (TupleTerm [AtomTerm "pickle", BinaryTerm source, BinaryTerm pickled, ListTerm linked]) =+  Just $ N2ONitro (Pickle source pickled (convert linked))+  where+    convert [] = M.empty+    convert (TupleTerm [AtomTerm k, BytelistTerm v]:vs) =+      M.insert (C8.pack k) v (convert vs)+fromBert _ = Nothing++toBert :: N2OProto a -> Term+toBert (Io eval dat) =+  TupleTerm [AtomTerm "io", BytelistTerm eval, BytelistTerm dat]