commit bd2cfe2dc2d1bc8ca5e6b44efe04ffb01b2b3d76 Author: Evgenii Akentev Date: Wed Sep 25 19:31:45 2019 +0300 Public release diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..f6bf791 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +dist +dist-newstyle +.ghc.environment.* diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/benchmark/Benchmark.hs b/benchmark/Benchmark.hs new file mode 100644 index 0000000..2a77043 --- /dev/null +++ b/benchmark/Benchmark.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Concurrent +import Control.Monad +import Control.Monad.Trans +import Data.List.NonEmpty as NE +import Data.Time +import Database.Hazelcast.Rest as Hazelcast +import Text.Printf + +nRequests, nClients :: Int +nRequests = 100000 +nClients = 50 + + +main :: IO () +main = do + ---------------------------------------------------------------------- + -- Preparation + -- + let pingKey = mkMapPath "mapName" "PING" + + let + connInfo = Hazelcast.defaultConnectInfo + { connectHosts = NE.fromList + [ HazelcastHost "localhost" 5701 ] + } + conn <- connect connInfo + runHazelcast conn $ do + _ <- Hazelcast.insert pingKey "PONG" + return () + + ---------------------------------------------------------------------- + -- Spawn clients + -- + start <- newEmptyMVar + done <- newEmptyMVar + replicateM_ nClients $ forkIO $ do + runHazelcast conn $ forever $ do + action <- liftIO $ takeMVar start + action + liftIO $ putMVar done () + + let + timeAction name nActions action = do + startT <- getCurrentTime + -- each clients runs ACTION nRepetitions times + let nRepetitions = nRequests `div` nClients `div` nActions + replicateM_ nClients $ putMVar start (replicateM_ nRepetitions action) + replicateM_ nClients $ takeMVar done + stopT <- getCurrentTime + let + deltaT = realToFrac $ diffUTCTime stopT startT + -- the real # of reqs send. We might have lost some due to 'div'. + actualReqs = nRepetitions * nActions * nClients + rqsPerSec = fromIntegral actualReqs / deltaT :: Double + putStrLn $ printf "%-15s %4dx%4dx%2d %10.2f Req/s" + (name :: String) nActions nRepetitions nClients rqsPerSec + + ---------------------------------------------------------------------- + -- Benchmarks + -- + timeAction "get" 1 $ do + r <- Hazelcast.lookup pingKey + unless (r == ReplyOk "PONG") $ error $ "bad hazelcast reply: " ++ show r + return () + + timeAction "get 1" 1 $ do + _ <- Hazelcast.lookupMany (replicate 1 pingKey) + return () + + timeAction "get 50" 50 $ do + _ <- Hazelcast.lookupMany (replicate 50 pingKey) + return () + + timeAction "get 100" 100 $ do + _ <- Hazelcast.lookupMany (replicate 100 pingKey) + return () + + timeAction "get 1000" 1000 $ do + _ <- Hazelcast.lookupMany (replicate 1000 pingKey) + return () + + timeAction "put" 1 $ do + _ <- Hazelcast.insert pingKey "DONG" + return () diff --git a/hazelcast-rest.cabal b/hazelcast-rest.cabal new file mode 100644 index 0000000..b69132d --- /dev/null +++ b/hazelcast-rest.cabal @@ -0,0 +1,36 @@ +name: hazelcast-rest +version: 0.1.0.0 +synopsis: Client library for the Hazelcast utilizing REST protocol +license: BSD3 +author: Typeable.io contributors +maintainer: makeit@typeable.io +category: Database +build-type: Simple +cabal-version: >=1.10 + +library + build-depends: base >=4.10 && <5 + , bytestring >=0.10.8 + , base64-bytestring + , http-client >=0.5 + , http-types >=0.9 + , mtl >=2.2 + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: Database.Hazelcast.Rest + , Database.Hazelcast.Rest.Cluster + , Database.Hazelcast.Rest.Core + , Database.Hazelcast.Rest.Internal + , Database.Hazelcast.Rest.Map + ghc-options: -Wall + +benchmark hazelcast-benchmark + type: exitcode-stdio-1.0 + hs-source-dirs: benchmark + default-language: Haskell2010 + main-is: Benchmark.hs + build-depends: base >=4.10 && <5 + , hazelcast-rest + , mtl >=2.2 + , time + ghc-options: -O2 -Wall -rtsopts diff --git a/src/Database/Hazelcast/Rest.hs b/src/Database/Hazelcast/Rest.hs new file mode 100644 index 0000000..58bc664 --- /dev/null +++ b/src/Database/Hazelcast/Rest.hs @@ -0,0 +1,7 @@ +module Database.Hazelcast.Rest + ( module X + ) where + +import Database.Hazelcast.Rest.Core as X +import Database.Hazelcast.Rest.Internal as X +import Database.Hazelcast.Rest.Map as X diff --git a/src/Database/Hazelcast/Rest/Cluster.hs b/src/Database/Hazelcast/Rest/Cluster.hs new file mode 100644 index 0000000..0ddae58 --- /dev/null +++ b/src/Database/Hazelcast/Rest/Cluster.hs @@ -0,0 +1,29 @@ +{-| + +Module provides type representing Hazelcast cluster and function to select a +host using Round-robin algorithm. + +-} + +module Database.Hazelcast.Rest.Cluster + ( ClusterInfo(..) + , roundRobinHost + ) where + +import Data.IORef +import Database.Hazelcast.Rest.Internal + +-- | 'ClusterInfo' represents Hazelcast cluster. +newtype ClusterInfo = ClusterInfo (IORef [HazelcastHost]) + +-- | Select host from cluster using Round-robin algorithm. +roundRobinHost :: ClusterInfo -> IO HazelcastHost +roundRobinHost (ClusterInfo ref) = atomicModifyIORef' ref rotateHosts + +-- | Return current head host in list and rotate list of hosts. +rotateHosts + :: [HazelcastHost] + -> ([HazelcastHost], HazelcastHost) +rotateHosts hosts = (rotate hosts, head hosts) + where + rotate l = zipWith const (drop 1 $ cycle l) l diff --git a/src/Database/Hazelcast/Rest/Core.hs b/src/Database/Hazelcast/Rest/Core.hs new file mode 100644 index 0000000..cfcca73 --- /dev/null +++ b/src/Database/Hazelcast/Rest/Core.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-| + +Module provides Hazelcast monad and functions for opening connection and +sending requests. + +-} + + +module Database.Hazelcast.Rest.Core + ( connect + , HazelcastEnv(..) + , Hazelcast(..) + , MonadHazelcast(..) + , runHazelcast + , sendRequest + , sendRequests + , defaultConnectInfo + -- reexport + , Internal.Reply(..) + , Internal.ConnectInfo(..) + , Internal.HazelcastHost(..) + ) where + +import Control.Monad.Reader +import Data.IORef +import qualified Data.List.NonEmpty as NE +import Database.Hazelcast.Rest.Cluster +import Database.Hazelcast.Rest.Internal as Internal +import qualified Network.HTTP.Client as HTTP + + +-- | Open connection with Hazelcast using connection information. +connect :: ConnectInfo -> IO HazelcastEnv +connect ConnectInfo{..} = do + let + ss = HTTP.defaultManagerSettings + { HTTP.managerConnCount = connectMaxConnections + , HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro + $ connectTimeoutSeconds * 1000000 + } + manager <- HTTP.newManager ss + clusterInfo <- ClusterInfo <$> newIORef (NE.toList connectHosts) + pure (HazelcastEnv manager clusterInfo) + +-- | 'HazelcastEnv' provides opened connection and cluster information. +data HazelcastEnv = HazelcastEnv + { henvConnection :: HTTP.Manager + , henvClusterInfo :: ClusterInfo + } + +-- | 'Hazelcast' type is a wrapper around ReaderT monad contains 'HazelcastEnv' +-- type to read. +newtype Hazelcast a = Hazelcast + { unHazelcast :: ReaderT HazelcastEnv IO a + } deriving (Monad, MonadIO, Functor, Applicative) + +-- | 'MonadHazelcast' provides function to lift Hazelcast type to another. +class Monad m => MonadHazelcast m where + liftHazelcast :: Hazelcast a -> m a + +instance MonadHazelcast Hazelcast where + liftHazelcast = id + +-- | Hazelcast monad runner. +runHazelcast :: HazelcastEnv -> Hazelcast a -> IO a +runHazelcast hEnv (Hazelcast hazelcast) = + runReaderT hazelcast hEnv + +-- | Send HTTP request to Hazelcast using 'MonadHazelcast'. +sendRequest + :: (MonadHazelcast m) + => HTTP.Request + -> m Reply +sendRequest r = + liftHazelcast . Hazelcast $ do + m <- asks henvConnection + c <- asks henvClusterInfo + HazelcastHost{..} <- liftIO $ roundRobinHost c + let + req = r + { HTTP.host = hostAddr + , HTTP.port = fromIntegral hostPort } + liftIO $ Internal.sendHttpRequest m req + +-- | Send many HTTP requests to Hazelcast using 'MonadHazelcast'. +sendRequests + :: (MonadHazelcast m, Traversable t) + => t HTTP.Request + -> m (t Reply) +sendRequests rqs = + liftHazelcast . Hazelcast $ do + m <- asks henvConnection + c <- asks henvClusterInfo + HazelcastHost{..} <- liftIO $ roundRobinHost c + let + modifyReq r = r + { HTTP.host = hostAddr + , HTTP.port = fromIntegral hostPort } + liftIO $ traverse (Internal.sendHttpRequest m . modifyReq) rqs + +-- | Default Hazelcast connection information. +defaultConnectInfo :: ConnectInfo +defaultConnectInfo = ConnectInfo + { connectHosts = NE.fromList [HazelcastHost "localhost" 5701] + , connectMaxConnections = 50 + , connectTimeoutSeconds = 10 + } diff --git a/src/Database/Hazelcast/Rest/Internal.hs b/src/Database/Hazelcast/Rest/Internal.hs new file mode 100644 index 0000000..1e4e22e --- /dev/null +++ b/src/Database/Hazelcast/Rest/Internal.hs @@ -0,0 +1,50 @@ +{-| + +Module contains types and functions required for connection with Hazelcast. + +-} + +module Database.Hazelcast.Rest.Internal where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BS.L +import qualified Data.List.NonEmpty as NE +import Data.Word +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Types as HTTP + +-- | Type represents Hazelcast host. +data HazelcastHost = HazelcastHost + { hostAddr :: BS.ByteString + , hostPort :: Word16 + } + +-- | Type represents connection information. +data ConnectInfo = ConnectInfo + { connectHosts :: NE.NonEmpty HazelcastHost + , connectMaxConnections :: Int + , connectTimeoutSeconds :: Int + } + +-- | Type provides possible Hazelcast responses. +data Reply + = ReplyOk BS.L.ByteString + | ReplyEmpty + | ReplyError Int + deriving (Eq, Show) + +-- | Send HTTP request to Hazelcast. +sendHttpRequest + :: HTTP.Manager + -> HTTP.Request + -> IO Reply +sendHttpRequest m req = + readReply <$> HTTP.httpLbs req m + +-- | Read status code from Hazelcast response and depending on status code +-- returns one of Reply constructor. +readReply :: HTTP.Response BS.L.ByteString -> Reply +readReply r = case HTTP.statusCode (HTTP.responseStatus r) of + 204 -> ReplyEmpty + 200 -> ReplyOk $ HTTP.responseBody r + x -> ReplyError x diff --git a/src/Database/Hazelcast/Rest/Map.hs b/src/Database/Hazelcast/Rest/Map.hs new file mode 100644 index 0000000..9ce4bfd --- /dev/null +++ b/src/Database/Hazelcast/Rest/Map.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| + +Module contaions high-level functions for working with Hazelcast. + +-} + + +module Database.Hazelcast.Rest.Map + ( Path + , mkMapPath + , insert + , lookup + , lookupMany + , delete + , getRq + , postRq + , deleteRq + ) where + +import qualified Data.ByteString as BS +import Data.ByteString.Base64.URL +import Database.Hazelcast.Rest.Core as Core +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Types as HTTP +import Prelude hiding (lookup) + +-- | Type represents url-safe (only valid url characters) path. +newtype Path = Path { unPath :: BS.ByteString } + deriving (Show) + +-- | Construct url-safe path. There is no map name encoding because it +-- may be set in hazelcast config file and after encoding nonexistent map name +-- can be obtained. +mkMapPath + :: BS.ByteString -- ^ map name should not contain invalid url characters + -> BS.ByteString + -> Path +mkMapPath mapName key = Path $ BS.concat + [ "/hazelcast/rest/maps/" + , mapName + , "/" + , encode key] + +-- | Insert value by path to Hazelcast. +insert :: MonadHazelcast m => Path -> BS.ByteString -> m Reply +insert (Path path) body = Core.sendRequest (postRq path body) + +-- | Find value by path in Hazelcast. +lookup :: MonadHazelcast m => Path -> m Reply +lookup (Path path) = Core.sendRequest (getRq path) + +-- | Find values by paths in Hazelcast. +lookupMany + :: (MonadHazelcast m, Traversable t) + => t Path + -> m (t Reply) +lookupMany paths = Core.sendRequests qs + where + qs = fmap (getRq . unPath) paths + +-- | Delete value by path in Hazelcast. +delete :: MonadHazelcast m => Path -> m Reply +delete (Path path) = Core.sendRequest (deleteRq path) + +-- | Form GET request to Hazelcast. +getRq :: BS.ByteString -> HTTP.Request +getRq path = HTTP.defaultRequest + { HTTP.method = HTTP.methodGet + , HTTP.path = path + , HTTP.requestVersion = HTTP.http11 + , HTTP.requestHeaders = [(HTTP.hAccept, "*/*")] + } + +-- | Form POST request to Hazelcast. +postRq :: BS.ByteString -> BS.ByteString -> HTTP.Request +postRq path body = HTTP.defaultRequest + { HTTP.method = HTTP.methodPost + , HTTP.path = path + , HTTP.requestVersion = HTTP.http11 + , HTTP.requestHeaders = + [ (HTTP.hAccept, "*/*") + , (HTTP.hContentType, "text/plain") ] + , HTTP.requestBody = HTTP.RequestBodyBS body + } + +-- | Form DELETE request to Hazelcast. +deleteRq :: BS.ByteString -> HTTP.Request +deleteRq path = HTTP.defaultRequest + { HTTP.method = HTTP.methodDelete + , HTTP.path = path + , HTTP.requestVersion = HTTP.http11 + , HTTP.requestHeaders = [ (HTTP.hAccept, "*/*") ] + }