Public release

.gitignore

@@ -0,0 +1,3 @@
+dist
+dist-newstyle
+.ghc.environment.*

Setup.hs

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

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 ()

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

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

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

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
+  }

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

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, "*/*") ]
+  }