diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/chevalier-common.cabal b/chevalier-common.cabal new file mode 100644 --- /dev/null +++ b/chevalier-common.cabal @@ -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 +maintainer: Anchor Engineering +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 diff --git a/lib/Chevalier/Client.hs b/lib/Chevalier/Client.hs new file mode 100644 --- /dev/null +++ b/lib/Chevalier/Client.hs @@ -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 diff --git a/lib/Chevalier/Types.hs b/lib/Chevalier/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Chevalier/Types.hs @@ -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 diff --git a/lib/Chevalier/Util.hs b/lib/Chevalier/Util.hs new file mode 100644 --- /dev/null +++ b/lib/Chevalier/Util.hs @@ -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)