socketson (empty) → 0.1.0.0
raw patch · 12 files changed
+627/−0 lines, 12 filesdep +DRBGdep +aesondep +basesetup-changed
Dependencies added: DRBG, aeson, base, base64-bytestring, bytestring, cereal, crypto-api, data-default, either, errors, http-types, leveldb-haskell, lifted-base, mtl, network, socketson, text, transformers, transformers-base, wai, wai-websockets, warp, websockets
Files
- LICENSE +8/−0
- Setup.hs +2/−0
- doc/sample/Main.hs +60/−0
- doc/sample/client/Main.hs +41/−0
- socketson.cabal +81/−0
- src/Network/Socketson.hs +56/−0
- src/Network/Socketson/Internal/Utils.hs +46/−0
- src/Network/Socketson/Protocol.hs +205/−0
- src/Network/Socketson/ProtocolException.hs +22/−0
- src/Network/Socketson/Report.hs +21/−0
- src/Network/Socketson/ServerState.hs +43/−0
- src/Network/Socketson/SessionStore.hs +42/−0
+ LICENSE view
@@ -0,0 +1,8 @@+The MIT License (MIT)+Copyright (c) 2016 (Philipp Pfeiffer, hax-f)++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ doc/sample/Main.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Network.Socketson+import Network.Socketson.Protocol++import Data.Aeson (ToJSON (..), FromJSON (..), object, (.=), (.:), Value (..))+import Data.List (isPrefixOf)+import Control.Monad.Trans.Either++import System.Environment (getArgs)++-- from server perspective:+-- outgoing object+data SObject = SObject Int String++instance ToJSON SObject where+ toJSON (SObject i s) = object [ "int" .= i, "str" .= s ]+++-- incoming object+data RObject = RObject String++instance FromJSON RObject where+ parseJSON (Object v) = RObject <$>+ v .: "str"++type SessionData = Int++{- We implement the following protocol:++ Incoming objects (sent by client): RObject, { "str" : <some string> }+ Outgoing objects (sent to client): SObject, { "str" : <same string>, "int" : <counter> }++where `<counter>` gets increment each time an object was received (on server side). This is realized via session data.++If `RObject "quit"` (on server side) is received, a close request gets sent.++If `RObject ("error":e)` is received, an user error with description `e` is thrown on server side (i.e. reported).++-}+protocolFunction :: (Maybe SessionData -> RObject -> EitherT String IO (Maybe SessionData, Reaction SObject))+protocolFunction msd (RObject str) =+ let n = case msd of+ Nothing -> 0+ Just i -> i + 1+ sobj = SObject n str+ in case str of+ "quit" -> return (Just n, Close)+ e | "error:" `isPrefixOf` e -> left (drop 6 e)+ | otherwise -> return (Just n, Send sobj)+++main :: IO ()+main =+ do as <- getArgs+ case as of+ [port, path] -> do putStrLn $ "starting socketson at " ++ port+ socketson path 2 (read port) protocolFunction+ _ -> putStrLn "usage: socketson-sample <port> <path for session storage>"
+ doc/sample/client/Main.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings #-}+module Main+ ( main+ ) where+++--------------------------------------------------------------------------------+import Control.Concurrent (forkIO)+import Control.Monad (forever, unless)+import Network.Socket (withSocketsDo)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.ByteString as B+import qualified Network.WebSockets as WS++import System.Environment (getArgs)+--------------------------------------------------------------------------------+app :: WS.ClientApp ()+app conn = do+ putStrLn "Connected!"++ -- Fork a thread that writes WS data to stdout+ _ <- forkIO $ forever $ do+ msg <- WS.receiveData conn :: IO B.ByteString+ print msg++ -- Read from stdin and write to WS+ let loop = do+ line <- T.getLine+ unless (T.null line) $ WS.sendTextData conn line >> loop++ loop+ WS.sendClose conn ("Bye!" :: T.Text)+++--------------------------------------------------------------------------------+main :: IO ()+main = do as <- getArgs+ case as of+ [port] -> withSocketsDo $ WS.runClient "localhost" (read port) "/open?id=sample-client" app+ _ -> putStrLn "usage: socketson-sample-client <port>"
+ socketson.cabal view
@@ -0,0 +1,81 @@+name: socketson+version: 0.1.0.0+synopsis: A small websocket backend provider.+description: socketson is technically a small websocket server with a predefined protocol with the intention to be run a backend.+homepage: https://github.com/aphorisme/socketson+license: MIT+license-file: LICENSE+author: Philipp Pfeiffer+maintainer: pfiff@hax-f.net+-- copyright:+category: Network+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ exposed-modules: Network.Socketson+ , Network.Socketson.Protocol+ , Network.Socketson.ProtocolException+ , Network.Socketson.Report+ , Network.Socketson.ServerState+ , Network.Socketson.SessionStore+ , Network.Socketson.Internal.Utils+ -- other-modules:+ -- other-extensions:+ build-depends: base >=4.7 && <5+ -- string stuff:+ , bytestring >= 0.10.4+ , text >= 1.2.2+ , base64-bytestring >= 1.0+ -- session key generator:+ , crypto-api >= 0.13+ , DRBG >= 0.5+ -- network, websockets, etc:+ , websockets >= 0.9.6+ , wai-websockets >= 3.0+ , wai >= 3.2+ , warp >= 3.2+ , http-types >= 0.9+ -- json parsing:+ , aeson >= 0.9.0+ -- persistent store:+ , leveldb-haskell >= 0.6.3+ , cereal >= 0.4.1+ , data-default >= 0.5.3+ -- monads, transformers + utils:+ , either >= 4.4+ , errors >= 2.1+ , lifted-base >= 0.2.3.6+ , transformers >= 0.4+ , transformers-base >= 0.4.4+ , mtl >= 2.2.1+ hs-source-dirs: src+ default-language: Haskell2010++executable socketson-sample+ main-is: Main.hs++ build-depends: base >= 4.7 && <5+ , aeson >= 0.9.0+ , socketson >= 0.1.0+ , either >= 4.4++ hs-source-dirs: doc/sample++ default-language: Haskell2010+++executable socketson-sample-client+ main-is: Main.hs++ build-depends: base >= 4.7 && <5+ , socketson >= 0.1.0+ , network >= 2.6+ , websockets >= 0.9.6+ , bytestring >= 0.10.4+ , text >= 1.2.2++ hs-source-dirs: doc/sample/client++ default-language: Haskell2010
+ src/Network/Socketson.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.Socketson where++-- data:+import Data.Aeson (ToJSON, FromJSON)+import Data.Serialize (Serialize)+import qualified Data.Text as T+-- wai, websockets, etc:+import Network.Wai.Handler.WebSockets (websocketsOr)+import Network.Wai.Handler.Warp (run)+import Network.Wai (responseLBS, Application)+import Network.WebSockets (defaultConnectionOptions)+import Network.HTTP.Types (status400)+-- intern:+import Network.Socketson.Protocol+import Network.Socketson.Report+import Network.Socketson.ServerState+-- concurent:+import Control.Concurrent.MVar+-- monads/transformers:+import Control.Monad.Trans.Either+++{-| The warp-wai 'Application', based upon the socketson protocol. It is a 'ServerApp' which got lifted into a wai 'Application' with the `wai-websockets` handler. 'app' is basically 'socketsonapp' with a fall back, if a http request comes which isn't a websocket one.+-}+app :: (ToJSON sobj, FromJSON rcv, Serialize sessd)+ => MVar ServerState+ -> (Maybe sessd -> rcv -> EitherT String IO (Maybe sessd, Reaction sobj))+ -> Application+app mstate pf = websocketsOr defaultConnectionOptions (socketsonapp mstate pf) backupApp+ where+ backupApp :: Application+ backupApp _ respond = respond $ responseLBS status400 [] "Not a WebSocket request"+++{-| 'socketson' starts a warp-wai websockets server, based on the socketson protocol and given protocol function.++ socketson pathToSessionStore maxAllowedClients port protocolFunction+-}+socketson :: (ToJSON sobj, FromJSON rcv, Serialize sessd)+ => FilePath+ -- ^ path to session store+ -> Int+ -- ^ number of maximal connected clients+ -> Int+ -- ^ port where socketson listens+ -> (Maybe sessd -> rcv -> EitherT String IO (Maybe sessd, Reaction sobj))+ -- ^ protocol function+ -> IO ()+socketson fp maxcl port pf =+ do st <- newState fp maxcl+ mstate <- newMVar st+ eitherT (\e -> putStrLn $ "report failed: " ++ show e)+ (\_ -> return ())+ (report "<global>" (Info High $ "Socketson listens at ws://localhost:" `T.append` T.pack (show port)))+ run port (app mstate pf)
+ src/Network/Socketson/Internal/Utils.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE FlexibleContexts #-}+module Network.Socketson.Internal.Utils where+++-- transformer stuff:+import Data.Either.Combinators (mapLeft)+import Control.Monad.Base (MonadBase (..), liftBase)+import Control.Monad.Trans.Either (EitherT (..), left, right, runEitherT, bracketEitherT, hoistEither, bimapEitherT)+import Control.Monad.IO.Class (liftIO)+import Control.Exception (try, Exception (..))+-- concurrent:+import Control.Concurrent.MVar.Lifted+-- intern:+import Network.Socketson.ProtocolException++tryT :: Exception e => IO a -> EitherT e IO a+tryT m = do mx <- liftIO $ try m+ hoistEither mx++-- | 'tryTWS' catches 'WS.ConnectionException' and puts them into the 'EitherT ProtocolException IO' monad.+tryTWS :: IO a -> EitherT ProtocolException IO a+tryTWS m = do mx <- liftIO $ try m+ case mapLeft ConnectionException mx of+ Left e -> left e+ Right x -> right x++embed :: MonadBase m (EitherT a m) => m (Either a b) -> EitherT a m b+embed meith =+ do eith <- liftBase meith+ hoistEither eith++mapLeftT :: (Functor m) => (e -> e') -> EitherT e m a -> EitherT e' m a+mapLeftT f = bimapEitherT f id++withMVarT :: MVar a -> (a -> EitherT ProtocolException IO b) -> EitherT ProtocolException IO b+withMVarT mvar =+ bracketEitherT (readMVar mvar)+ (putMVar mvar)++modifyMVarT :: MVar a -> (a -> EitherT ProtocolException IO (a, b)) -> EitherT ProtocolException IO b+modifyMVarT mvar mf = embed $+ modifyMVar mvar (\var ->+ do meith <- runEitherT (mf var)+ case meith of+ Left e -> return (var, Left e)+ Right (var', x) -> return (var', Right x) )
+ src/Network/Socketson/Protocol.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.Socketson.Protocol where++-- data:+import Data.Aeson (FromJSON, ToJSON,+ eitherDecode, encode)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as B64+import Data.Serialize (Serialize (..))+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT++-- either transformer stuff:+import Control.Error.Util (note)+import Control.Monad.Error.Class+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Either+import Data.Either.Combinators++-- websockets:+import qualified Network.WebSockets as WS+-- types:+import qualified Network.HTTP.Types.URI as HT+-- concurrent:+import Control.Concurrent.MVar.Lifted+-- exception:+import Control.Exception (catch, finally, throw)+-- monad:+import Control.Monad+-- intern:+import Network.Socketson.Internal.Utils+import Network.Socketson.ProtocolException+import Network.Socketson.Report+import Network.Socketson.ServerState+import Network.Socketson.SessionStore+-- random:+import Crypto.Random+import Crypto.Random.DRBG+++++++++-- | Possible reactions to an incoming data object and current session data.+data Reaction a =+ Send a+ | Close+ | None++socketsonapp :: (ToJSON sobj, FromJSON rcv, Serialize sessd)+ => MVar ServerState+ -- ^ global server state as an mvar.+ -> (Maybe sessd -> rcv -> EitherT String IO (Maybe sessd, Reaction sobj))+ -- ^ protocl function.+ -> WS.ServerApp+socketsonapp mstate pf pcon =+ eitherT (\e -> return ())+ (\_ -> return ())+ (do { n <- _appT mstate pf pcon; report n (Info Low "Exit app thread.") } `catchError` (report "global" . Error) )+ where+ _appT mstate pf pcon =+ do+ -------------+ -- Handshake:+ (nick, skey, mData, con) <- modifyMVarT mstate $+ \state -> do (_nick, _skey, _mData, _mGen, _con) <- handshake state pcon+ return (_updateState state _mGen, (_nick, _skey, _mData, _con))+ report nick (Info Middle "Accepted connection.")++ ----------------+ -- protocol loop: (WebSockets signals the close request via exceptions; so we handle exceptions already inline.)+ liftIO $ _loop mstate nick con skey mData pf+ report nick (Info Middle "Loop escaped, client disconnected.")+ -------------+ return nick++ {- The protocol loop exits if an exception happens. We invoke it again, if the exception just needs to get reported. If the exception was a close request (or any which implicates a disconnect), we disconnect the connection and change state. -}+ _loop mstate nick con skey mData pf =+ eitherT+ (\e -> case e of+ ConnectionException WS.ConnectionClosed -> _disconnect mstate con nick False -- close internally+ ConnectionException (WS.CloseRequest _ _) -> _disconnect mstate con nick True -- send close+ e -> do { runEitherT $ report nick (Error e); _loop mstate nick con skey mData pf } )-- error reported. Continue loop.+ (\_ -> _disconnect mstate con nick True)+ (protocolLoop mstate nick con skey mData pf)+++ _disconnect mstate con nick friendly =+ do runEitherT (report nick (Info Low "Closing connection ... "))+ when friendly $ WS.sendClose con ("Close connection to socketson." :: BS.ByteString)+ modifyMVar_ mstate $ \state -> return $ decClients state+++ _updateState :: ServerState -> Maybe CtrDRBG -> ServerState+ _updateState state mg =+ case mg of+ Just g -> incClients state { randomGen = g }+ Nothing -> incClients state+++{-| Every communication starts with one of two possible handshakes:++ 1. open a new session,+ 2. restore an existing session.++A handshake produces (or retrieves)++ - identifier of client,+ - session key,+ - maybe session data,+ - maybe a iterated random generator and+ - a connection handle.++A handshake may fail on:++ 1. No capacity, too many clients are connected already.+ 2. No session exists for given session key.+ 3. Failure while generating a new session key.+ 4. Invalid request path.+++-}+handshake :: (Serialize a) => ServerState+ -> WS.PendingConnection+ -> EitherT ProtocolException IO (T.Text, BS.ByteString, Maybe a, Maybe CtrDRBG, WS.Connection)+handshake state pcon =+ do hoistEither $ checkCapacity state+ case HT.decodePath (WS.requestPath (WS.pendingRequest pcon)) of+ -- open request:+ (["open"], [("id", Just ident')]) ->+ let ident = T.decodeUtf8 ident' in+ do (skey, g) <- hoistEither (genSessionKey state)+ con <- establish pcon skey+ return (ident, skey, Nothing, Just g, con)+ -- restore request:+ ("restore" : [skey'], [("id", Just ident')]) ->+ let skey = T.encodeUtf8 skey'+ ident = T.decodeUtf8 ident' in+ do sessD <- restoreSessionData state skey+ con <- establish pcon skey+ return (ident, skey, Just sessD, Nothing, con)+ -- invalid request:+ _ -> left InvalidRequestPath+ where+ checkCapacity :: ServerState -> Either ProtocolException ()+ checkCapacity state =+ unless (existsCapacity state) $ Left TooManyClientsConnected++ genSessionKey :: ServerState -> Either ProtocolException (BS.ByteString, CtrDRBG)+ genSessionKey state =+ mapLeft (CannotGenerateRandomNumber . show) (genBytes 1024 $ randomGen state)++ establish :: WS.PendingConnection -> BS.ByteString -> EitherT ProtocolException IO WS.Connection+ establish pcon skey =+ let skey' = B64.encode skey+ in do con <- liftIO $ WS.acceptRequest pcon+ liftIO $ WS.forkPingThread con 30+ liftIO $ WS.sendBinaryData con skey'+ return con+++++{-| After a successful handshake, the communication goes into the 'protocolLoop'. It stays in the loop until an exception happens. Since an exception might be just a signal (WebSockets throws exceptions if the client wants to close the connection), we handle some of them already in 'socketsonapp'.++For more information on what the protocol loop does, look at the `README.md`.+-}+protocolLoop :: (ToJSON sobj, FromJSON rcv, Serialize sessd)+ => MVar ServerState+ -> T.Text+ -> WS.Connection+ -> BS.ByteString+ -> Maybe sessd+ -> (Maybe sessd -> rcv -> EitherT String IO (Maybe sessd, Reaction sobj))+ -> EitherT ProtocolException IO ()+protocolLoop mstate nick con skey sessionData pf =+ do report nick (Info Low "Waiting for incoming object ...")+ rcvObj <- recvObject con+ report nick (Info Low "Received object.")+ -- ^ receive JSON string and decode it into object.+ (sessd, react) <- mapLeftT UserException $ pf sessionData rcvObj+ -- ^ apply the protocol function and return new session data and reaction.+ case sessd of+ Just sdata' -> liftIO (withMVar mstate $ \state -> saveSessionData state skey sdata')+ _ -> return ()+ -- ^ save the new session data.+ case react of -- decide on reaction:+ None -> protocolLoop mstate nick con skey sessd pf+ Send encObj -> do { sndObject con encObj; protocolLoop mstate nick con skey sessd pf }+ Close -> return ()+ where+ recvObject :: (FromJSON rcv) => WS.Connection -> EitherT ProtocolException IO rcv+ recvObject con =+ do recv <- tryTWS $ WS.receiveData con+ hoistEither $ mapLeft CannotParseRecvObject (eitherDecode recv)++ sndObject :: (ToJSON sobj) => WS.Connection -> sobj -> EitherT ProtocolException IO ()+ sndObject con msg = let emsg = encode msg+ tmsg = LT.toStrict $ LT.decodeUtf8 emsg+ in tryTWS $ WS.sendBinaryData con emsg
+ src/Network/Socketson/ProtocolException.hs view
@@ -0,0 +1,22 @@+module Network.Socketson.ProtocolException where+++-- data:+import Data.Typeable+import qualified Data.ByteString as BS+-- exceptions:+import Control.Exception+-- websocket:+import qualified Network.WebSockets as WS++data ProtocolException = CannotParseRecvObject String+ | CannotGenerateRandomNumber String+ | TooManyClientsConnected+ | InvalidSessionKey BS.ByteString+ | InvalidRequestPath+ | SessionStoreCorruptAt BS.ByteString String+ | ConnectionException WS.ConnectionException+ | UserException String+ deriving (Show, Typeable)++instance Exception ProtocolException where
+ src/Network/Socketson/Report.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.Socketson.Report where++--+import Control.Monad.Trans.Either+import Control.Monad.IO.Class (liftIO)+-- data:+import qualified Data.Text as T+import qualified Data.Text.IO as T+-- intern:+import Network.Socketson.ProtocolException++data Priority = Low | Middle | High deriving (Eq, Ord, Show)++data ReportType = Error ProtocolException+ | Info Priority T.Text++-- | Simple report function. Just puts to console; future plans involve priorities and log files.+report :: T.Text -> ReportType -> EitherT ProtocolException IO ()+report nick (Error err) = liftIO (T.putStrLn $ T.unwords ["Error @ <", nick, ">:", T.pack $ show err])+report nick (Info _ s) = liftIO (T.putStrLn $ T.unwords ["Info @<", nick, ">:", s])
+ src/Network/Socketson/ServerState.hs view
@@ -0,0 +1,43 @@+module Network.Socketson.ServerState where++-- mvar:+-- import Control.Concurrent.MVar+-- random numbers:+import Crypto.Random.DRBG++-- | The inner state of the `socketson` service.+data ServerState =+ ServerState { storePath :: FilePath+ -- ^ path to the session data storage+ , maxClients :: Int+ -- ^ number of maximal allowed clients+ , connectedClients :: Int+ -- ^ number of connected clients+ , randomGen :: CtrDRBG+ -- ^ the random generator, used for generating session keys.+ }++{-| Opens a new server state with given parameters. Initializes a fresh random number generator to generate session keys.++ newState pathToSessionStore maxClients+-}+newState :: FilePath -> Int -> IO ServerState+newState fp maxcl =+ do --plock <- newMVar fp+ g <- newGenIO :: IO CtrDRBG+ return (ServerState fp maxcl 0 g)++------+-- utility++-- | Increments the number of connected clients.+incClients :: ServerState -> ServerState+incClients st = st { connectedClients = connectedClients st + 1 }++-- | Decrements the number of connected clients.+decClients :: ServerState -> ServerState+decClients st = st { connectedClients = connectedClients st - 1 }++-- | Checks if there is still capacity for clients to connect.+existsCapacity :: ServerState -> Bool+existsCapacity st = (maxClients st - connectedClients st) > 0
+ src/Network/Socketson/SessionStore.hs view
@@ -0,0 +1,42 @@+module Network.Socketson.SessionStore where++-- intern:+import Network.Socketson.ServerState+import Network.Socketson.ProtocolException+-- mvar:+import Control.Concurrent.MVar+-- data:+import qualified Data.Serialize as BIN+import qualified Data.ByteString as BS+import Data.Default+-- leveldb:+import Database.LevelDB+-- either transformer:+import Control.Monad.Trans.Either+import Data.Either.Combinators (mapLeft)++{-----------------+ Session Store++ Stores session data in a levelDB, hashed under generated session keys. The handle gets generated whenever work has to be done; the path to the levelDB files are needed.+-}++{-| Saves given session data (which can be anything which is serializable) under given key, based on the given server state.++ saveSessionData serverState key sessionData+-}+saveSessionData :: (BIN.Serialize a) => ServerState -> BS.ByteString -> a -> IO ()+saveSessionData state key dat =+ runResourceT (do db <- open (storePath state) defaultOptions { createIfMissing = True }+ put db def key (BIN.encode dat) )++++{-| Restores session data which was saved in the session store before, saved under given key, wrapped in a 'Maybe' monad. Returns 'Nothing' if no data was found under given key. -}+restoreSessionData :: (BIN.Serialize a) => ServerState -> BS.ByteString -> EitherT ProtocolException IO a+restoreSessionData state key =+ do res <- runResourceT (do db <- open (storePath state) defaultOptions { createIfMissing = True }+ get db def key)+ case res of+ Just x -> hoistEither $ mapLeft (SessionStoreCorruptAt key) (BIN.decode x)+ Nothing -> left (InvalidSessionKey key)