chevalier-common (empty) → 0.6.0
raw patch · 6 files changed
+291/−0 lines, 6 filesdep +basedep +bifunctorsdep +bytestringsetup-changed
Dependencies added: base, bifunctors, bytestring, cereal, locators, mtl, network, network-uri, protobuf, text, unordered-containers, vaultaire-common, zeromq4-haskell
Files
- LICENSE +27/−0
- Setup.hs +2/−0
- chevalier-common.cabal +47/−0
- lib/Chevalier/Client.hs +53/−0
- lib/Chevalier/Types.hs +68/−0
- lib/Chevalier/Util.hs +94/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2014, Anchor+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 the {organization} nor the names of its+ 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 HOLDER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ chevalier-common.cabal view
@@ -0,0 +1,47 @@+cabal-version: >=1.10+name: chevalier-common+version: 0.6.0+synopsis: Query interface for Chevalier+description: Provides common types and a ZeroMQ query interface for Chevalier.+license: BSD3+license-file: LICENSE+author: Anchor Engineering <engineering@anchor.com.au>+maintainer: Anchor Engineering <engineering@anchor.com.au>+copyright: © 2014-2015 Anchor Systems, Pty Ltd and Others+category: Other+tested-with: GHC == 7.8.3+stability: experimental++build-type: Simple++source-repository head+ type: git+ location: git@github.com:anchor/chevalier-common.git++flag network-uri+ description: Get Network.URI from the network-uri package+ default: True++library+ hs-source-dirs: lib+ default-language: Haskell2010++ exposed-modules: Chevalier.Types,+ Chevalier.Util,+ Chevalier.Client++ if flag(network-uri)+ build-depends: network-uri >= 2.6, network >= 2.6+ else+ build-depends: network-uri < 2.6, network < 2.6+ build-depends: base >=4.7 && <4.8,+ bifunctors,+ protobuf,+ text,+ locators,+ cereal,+ bytestring,+ unordered-containers,+ mtl,+ zeromq4-haskell,+ vaultaire-common
+ lib/Chevalier/Client.hs view
@@ -0,0 +1,53 @@+module Chevalier.Client(+ getSourceDict,+ getAddresses,+ getAddresses'+) where++import Control.Monad.Trans+import Data.Bifunctor+import Data.Either+import Data.List+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Network.URI+import qualified System.ZMQ4 as Z++import Vaultaire.Types+import Chevalier.Util+import Chevalier.Types++getSourceDict :: MonadIO m => URI -> Origin -> Address -> m (Maybe SourceDict)+getSourceDict uri org addr = do+ resp <- runChevalier uri org $ buildRequestFromAddress addr+ return $ fmap snd $ find ((==addr) . fst) resp++-- | Take one key-value pair and return matched addresses and+-- sourcedicts.+getAddresses :: MonadIO m => URI -> Origin -> (String, String) -> m [(Address, SourceDict)]+getAddresses uri org = getAddresses' uri org . (: [])++-- | Take multiple key-value pairs and return matched addresses and+-- sourcedicts.+getAddresses' :: MonadIO m => URI -> Origin -> [(String, String)] -> m [(Address, SourceDict)]+getAddresses' uri org tags =+ runChevalier uri org $ buildRequestFromPairs $ packTags tags+ where+ packTags = map (bimap T.pack T.pack)++runChevalier :: MonadIO m => URI -> Origin -> SourceRequest -> m [(Address, SourceDict)]+runChevalier uri origin req = do+ resp <- liftIO sendrecv+ return $ either (error . show)+ (rights . map convertSource)+ (decodeResponse resp)+ where+ sendrecv =+ Z.withContext (\ctx ->+ Z.withSocket ctx Z.Req (\sock -> do+ Z.connect sock $ show uri+ Z.send sock [Z.SendMore] $ encodeOrigin origin+ Z.send sock [] $ encodeRequest req+ Z.receive sock))+ encodeOrigin (Origin x) = encodeUtf8 $ T.pack $ show x
+ lib/Chevalier/Types.hs view
@@ -0,0 +1,68 @@+--+-- Copyright © 2014 Anchor Systems, Pty Ltd and Others+--+-- The code in this file, and the program it is a part of, is+-- made available to you by its authors as open source software:+-- you can redistribute it and/or modify it under the terms of+-- the 3-clause BSD licence.+--++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}++module Chevalier.Types where++import Control.Concurrent+import Control.Exception+import Data.Int (Int64)+import Data.ProtocolBuffers hiding (field)+import Data.Text (Text)+import qualified Data.Text.Lazy as LT+import Data.Typeable+import Data.Word (Word64)+import GHC.Generics (Generic)++-- A request to the chevalier thread to search for a source by a single keyword+data SourceQuery = SourceQuery+ { sourceRequest :: [SourceTag]+ , sourceAddress :: Text+ , sourcePage :: Integer+ , pageSize :: Integer+ , sourceOrigin :: Text+ , sourceResponse :: MVar (Either SomeException [LT.Text]) }++-- Custom Exceptions+data ChevalierException = BurstDecodeFailure String+ | ChevalierFailure Text+ deriving (Show, Typeable)+instance Exception ChevalierException++-- Protobufs follow++data SourceTag = SourceTag+ { field :: Required 1 (Value Text)+ , value :: Required 2 (Value Text)+ } deriving (Generic, Eq, Show)+instance Encode SourceTag+instance Decode SourceTag++data SourceRequest = SourceRequest+ { requestTags :: Repeated 1 (Message SourceTag)+ , startPage :: Optional 2 (Value Int64)+ , sourcesPerPage :: Optional 3 (Value Int64)+ , addressKey :: Optional 6 (Value (Fixed Word64))+ } deriving (Generic, Eq, Show)+instance Encode SourceRequest++data SourceResponse = ChevalierResponse+ { sources :: Repeated 1 (Message Source)+ , chevalierError :: Optional 2 (Value Text)+ } deriving (Generic, Eq, Show)+instance Decode SourceResponse++data Source = Source+ { tags :: Repeated 1 (Message SourceTag)+ , address :: Required 3 (Value (Fixed Word64))+ } deriving (Generic, Eq, Show)+instance Decode Source
+ lib/Chevalier/Util.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE+ OverloadedStrings+ , RecordWildCards+ #-}++module Chevalier.Util where++import qualified Data.ByteString as S+import Data.HashMap.Strict(fromList)+import Data.Locator+import Data.Monoid+import Data.ProtocolBuffers hiding (field)+import Data.Serialize+import Data.Text(splitOn, unpack, append, Text)++import Chevalier.Types+import Vaultaire.Types++-- |Building SourceRequests++buildRequestFromQuery :: SourceQuery -> SourceRequest+buildRequestFromQuery (SourceQuery tags address page page_size _ _) =+ SourceRequest+ { requestTags = putField tags+ , startPage = putField $ Just $ fromIntegral page+ , sourcesPerPage = putField $ Just $ fromIntegral page_size+ , addressKey = putField address'+ }+ where+ address' = case address of+ "*" -> Nothing+ a -> Just $ fromIntegral $ fromBase62 $ unpack a++-- strict+buildTag :: Text -> Text -> SourceTag+buildTag key value = SourceTag+ (putField key)+ (putField value)+buildRequestFromPairs :: [(Text, Text)] -> SourceRequest+buildRequestFromPairs = buildRequestFromTags . map (uncurry buildTag)+++-- fuzzy+buildFuzzyRequestTag :: Text -> Text -> SourceTag+buildFuzzyRequestTag key value = SourceTag+ (putField key)+ (putField $ "*" <> value <> "*")+buildFuzzyRequestFromPairs :: [(Text, Text)] -> SourceRequest+buildFuzzyRequestFromPairs = buildRequestFromTags . map (uncurry buildFuzzyRequestTag)++-- wild+buildWildcardTag :: Text -> SourceTag+buildWildcardTag value = SourceTag+ (putField "*")+ (putField $ "*" <> value <> "*")+buildWildRequestFromPairs :: [(Text, Text)] -> SourceRequest+buildWildRequestFromPairs = buildRequestFromTags . map (buildWildcardTag . snd)+++wildcardQuery :: [Text] -> SourceRequest+wildcardQuery = buildRequestFromTags . map buildWildcardTag++decodeTag :: SourceTag -> (Text, Text)+decodeTag (SourceTag key value) = (getField key, getField value)++buildRequestFromTags :: [SourceTag] -> SourceRequest+buildRequestFromTags tags =+ SourceRequest (putField tags) (putField Nothing) (putField Nothing) (putField Nothing)++buildRequestFromAddress :: Address -> SourceRequest+buildRequestFromAddress (Address address) =+ SourceRequest (putField []) (putField Nothing) (putField Nothing) (putField $ Just $ fromIntegral $ address)++-- |Converts a Chevalier Source into a Vaultaire (Address, SourceDict) tuple+convertSource :: Source -> Either String (Address, SourceDict)+convertSource Source{..} =+ either+ Left+ (\sd -> Right (Address . fromIntegral $ getField address, sd))+ (makeSourceDict $ fromList $ map decodeTag $ getField tags)++-- |Encodes a SourceRequest into its wire format+encodeRequest :: SourceRequest -> S.ByteString+encodeRequest = runPut . encodeMessage++-- |Decodes a wire format SourceResponse into a list of Sources+decodeResponse :: S.ByteString -> Either ChevalierException [Source]+decodeResponse bs =+ case runGet decodeMessage bs of+ Left err -> Left $ BurstDecodeFailure err+ Right decoded ->+ case getField $ chevalierError decoded of+ Just err -> Left $ ChevalierFailure err+ Nothing -> Right $ getField (sources decoded)