diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2016, Sannsyn AS + +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. 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/library/Solr/HTTPRequestEncoder.hs b/library/Solr/HTTPRequestEncoder.hs new file mode 100644 --- /dev/null +++ b/library/Solr/HTTPRequestEncoder.hs @@ -0,0 +1,121 @@ +module Solr.HTTPRequestEncoder where + +import Solr.Prelude +import qualified Data.ByteString.Lazy +import qualified Data.ByteString.Char8 +import qualified Data.CaseInsensitive +import qualified JSONEncoder +import qualified Network.HTTP.Client +import qualified ByteString.TreeBuilder + + +encoder_request :: Request a -> a -> Network.HTTP.Client.Request +encoder_request (Request (Op impl)) input = + appEndo (impl input) init + where + init = + either (error . show) id $ + Network.HTTP.Client.parseUrl "http://www" + + +newtype Request a = + Request (Op (Endo Network.HTTP.Client.Request) a) + deriving (Contravariant, Divisible, Decidable, Semigroup, Monoid) + +request_body :: Body a -> Request a +request_body (Body impl) = + Request $ + Op $ + \input -> + Endo $ + \request -> + request { + Network.HTTP.Client.requestBody = (impl input) + } + +request_method :: ByteString -> Request a +request_method method = + Request $ + Op $ + const $ + Endo $ + \request -> + request { + Network.HTTP.Client.method = method + } + +request_header :: ByteString -> ByteString -> Request a +request_header name value = + Request $ + Op $ + const $ + Endo $ + \request -> + request { + Network.HTTP.Client.requestHeaders = + (Data.CaseInsensitive.mk name, value) : + Network.HTTP.Client.requestHeaders request + } + +request_url :: ByteString -> Request a +request_url url = + Request $ + Op $ + const $ + Endo $ + case parsedRequestMaybe of + Just parsedRequest -> + \request -> + request { + Network.HTTP.Client.secure = + Network.HTTP.Client.secure parsedRequest, + Network.HTTP.Client.host = + Network.HTTP.Client.host parsedRequest, + Network.HTTP.Client.port = + Network.HTTP.Client.port parsedRequest, + Network.HTTP.Client.path = + Network.HTTP.Client.path parsedRequest, + Network.HTTP.Client.queryString = + Network.HTTP.Client.queryString parsedRequest + } + Nothing -> id + where + parsedRequestMaybe = + Network.HTTP.Client.parseUrl $ + Data.ByteString.Char8.unpack $ + url + + +newtype Body a = + Body (a -> Network.HTTP.Client.RequestBody) + +instance Contravariant Body where + {-# INLINE contramap #-} + contramap f (Body impl) = + Body (\input -> impl (f input)) + +body_unit :: Body () +body_unit = + Body $ + const $ + Network.HTTP.Client.RequestBodyBS mempty + +body_json :: JSONEncoder.Value a -> Body a +body_json spec = + Body $ + \input -> + Network.HTTP.Client.RequestBodyLBS $ + ByteString.TreeBuilder.toLazyByteString $ + JSONEncoder.run spec input + + +-- * Specific +------------------------- + +request_postJSON :: ByteString -> JSONEncoder.Value a -> Request a +request_postJSON url jsonEncoder = + request_url url <> + request_method "POST" <> + request_header "content-type" "application/json" <> + request_body (body_json jsonEncoder) + diff --git a/library/Solr/HTTPResponseDecoder.hs b/library/Solr/HTTPResponseDecoder.hs new file mode 100644 --- /dev/null +++ b/library/Solr/HTTPResponseDecoder.hs @@ -0,0 +1,45 @@ +module Solr.HTTPResponseDecoder +( + json, + okay, + module HTTPResponseDecoder, +) +where + +import Solr.Prelude +import HTTPResponseDecoder +import qualified Data.ByteString.Lazy +import qualified JSONIncrementalDecoder + + +response :: Matcher ByteString () -> Matcher Int () -> Matcher Data.ByteString.Lazy.ByteString a -> Response a +response contentTypeMatcher statusCodeMatcher bodyMatcher = + fmap snd $ + headAndBody head body + where + head = + statusCode statusCodeMatcher *> + headers (header "content-type" contentTypeMatcher) + body = + bodyLazyBytes bodyMatcher + +statusIsOkay :: Matcher Int () +statusIsOkay = + equals 200 + +contentTypeIsJSON :: Matcher ByteString () +contentTypeIsJSON = + equals "application/json" + +jsonBodyMatcher :: JSONIncrementalDecoder.Value a -> Matcher Data.ByteString.Lazy.ByteString a +jsonBodyMatcher spec = + converts (JSONIncrementalDecoder.valueToLazyByteStringToEither spec) + +json :: JSONIncrementalDecoder.Value a -> Response a +json spec = + response whatever statusIsOkay (jsonBodyMatcher spec) + +okay :: Response () +okay = + response whatever statusIsOkay whatever + diff --git a/library/Solr/Parameters.hs b/library/Solr/Parameters.hs new file mode 100644 --- /dev/null +++ b/library/Solr/Parameters.hs @@ -0,0 +1,84 @@ +-- | +-- For details see . +module Solr.Parameters +( + builderEncoder_parameters, + Parameters, + parameters_select, + Select, + select_q, + select_start, + select_rows, +) +where + +import Solr.Prelude +import qualified Network.URI.Encode +import qualified ByteString.TreeBuilder + + +builderEncoder_parameters :: Parameters a -> a -> ByteString.TreeBuilder.Builder +builderEncoder_parameters (Parameters (Op impl)) = + \input -> + fold $ + intersperse "&" $ + fmap pairMapping $ + impl input [] + where + pairMapping (name, value) = + if ByteString.TreeBuilder.length value == 0 + then name + else name <> "=" <> value + + +newtype Parameters a = + Parameters (Op ([(ByteString.TreeBuilder.Builder, ByteString.TreeBuilder.Builder)] -> [(ByteString.TreeBuilder.Builder, ByteString.TreeBuilder.Builder)]) a) + deriving (Contravariant, Divisible, Decidable, Semigroup, Monoid) + +{-# INLINE parameters_parameter #-} +parameters_parameter :: Parameters (ByteString.TreeBuilder.Builder, ByteString.TreeBuilder.Builder) +parameters_parameter = + Parameters $ + Op $ + \(name, value) -> + (:) (name, value) + +{-# INLINE parameters_select #-} +parameters_select :: Select a -> Parameters a +parameters_select (Select spec) = + spec + + +-- | +-- Select parameters encoder. +newtype Select a = + Select (Parameters a) + deriving (Contravariant, Divisible, Decidable, Semigroup, Monoid) + +-- | +-- The actual search-query. +-- See . +{-# INLINE select_q #-} +select_q :: Select Text +select_q = + Select $ + contramap (ByteString.TreeBuilder.byteString . Network.URI.Encode.encodeTextToBS) $ + contramap (\x -> ("q", x)) $ + parameters_parameter + +{-# INLINE select_start #-} +select_start :: Select Int +select_start = + Select $ + contramap (ByteString.TreeBuilder.asciiIntegral) $ + contramap (\x -> ("start", x)) $ + parameters_parameter + +{-# INLINE select_rows #-} +select_rows :: Select Int +select_rows = + Select $ + contramap (ByteString.TreeBuilder.asciiIntegral) $ + contramap (\x -> ("rows", x)) $ + parameters_parameter + diff --git a/library/Solr/Prelude.hs b/library/Solr/Prelude.hs new file mode 100644 --- /dev/null +++ b/library/Solr/Prelude.hs @@ -0,0 +1,46 @@ +module Solr.Prelude +( + module Exports, +) +where + + +-- base-prelude +------------------------- +import BasePrelude as Exports hiding (First(..), Last(..), (<>)) + +-- transformers +------------------------- +import Control.Monad.IO.Class as Exports +import Control.Monad.Trans.Class as Exports +import Control.Monad.Trans.Except as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) +import Control.Monad.Trans.Maybe as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) +import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) +import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) +import Control.Monad.Trans.Writer.Strict as Exports + +-- contravariant +------------------------- +import Data.Functor.Contravariant as Exports +import Data.Functor.Contravariant.Divisible as Exports + +-- profunctors +------------------------- +import Data.Profunctor.Unsafe as Exports + +-- semigroup +------------------------- +import Data.Semigroup as Exports + +-- matcher +------------------------- +import Matcher as Exports hiding (run) + +-- bytestring +------------------------- +import Data.ByteString as Exports (ByteString) + +-- text +------------------------- +import Data.Text as Exports (Text) + diff --git a/library/Solr/Request.hs b/library/Solr/Request.hs new file mode 100644 --- /dev/null +++ b/library/Solr/Request.hs @@ -0,0 +1,241 @@ +-- | +-- Request declaration DSL. +module Solr.Request +( + -- * Request + Request(..), + request_select, + request_count, + request_update, + -- * Encoders + Encoder_Select, + encoder_select_query, + encoder_select_filter, + encoder_select_offset, + encoder_select_limit, + Encoder_Update, + encoder_update_add, + encoder_update_delete, + Encoder_Add, + encoder_add_doc, + encoder_add_boost, + encoder_add_overwrite, + encoder_add_commitWithin, + Encoder_Delete, + encoder_delete_id, + encoder_delete_query, + encoder_delete_commitWithin, + -- * Decoders + Decoder_Select, + decoder_select_response, + Decoder_Response, + decoder_response_numFound, + decoder_response_docs, + Decoder_Docs, + decoder_docs_doc, +) +where + +import Solr.Prelude +import qualified Solr.HTTPResponseDecoder +import qualified Solr.HTTPRequestEncoder +import qualified Solr.Parameters +import qualified JSONEncoder +import qualified JSONIncrementalDecoder + + +-- | +-- Solr request specification. +data Request a b = + Request + !(ByteString -> Solr.HTTPRequestEncoder.Request a) + !(Solr.HTTPResponseDecoder.Response b) + +instance Functor (Request a) where + {-# INLINE fmap #-} + fmap f (Request requestEncoderProducer responseDecoder) = + Request requestEncoderProducer (fmap f responseDecoder) + +instance Profunctor Request where + {-# INLINE dimap #-} + dimap f1 f2 (Request requestEncoderProducer responseDecoder) = + Request ((fmap . contramap) f1 requestEncoderProducer) (fmap f2 responseDecoder) + + +request_select :: Encoder_Select a -> Decoder_Select b -> Request a b +request_select selectEncoder selectDecoder = + Request requestEncoderProducer responseDecoder + where + requestEncoderProducer baseURL = + Solr.HTTPRequestEncoder.request_postJSON url jsonEncoder + where + url = + baseURL <> "/select/?wt=json" + jsonEncoder = + encoder_value_select selectEncoder + responseDecoder = + Solr.HTTPResponseDecoder.json $ + decoder_value_select $ + selectDecoder + +request_count :: Request Text Int +request_count = + request_select encoder decoder + where + encoder = + encoder_select_query <> + contramap (const 0) encoder_select_limit + decoder = + decoder_select_response $ + decoder_response_numFound + +request_update :: Encoder_Update a -> Request a () +request_update updateEncoder = + Request requestEncoderProducer responseDecoder + where + requestEncoderProducer baseURL = + Solr.HTTPRequestEncoder.request_postJSON url jsonEncoder + where + url = + baseURL <> "/update/?commit=true" + jsonEncoder = + encoder_value_update updateEncoder + responseDecoder = + Solr.HTTPResponseDecoder.okay + + + + +encoder_value_select :: Encoder_Select a -> JSONEncoder.Value a +encoder_value_select (Encoder_Select spec) = + JSONEncoder.object spec + +encoder_value_update :: Encoder_Update a -> JSONEncoder.Value a +encoder_value_update (Encoder_Update spec) = + JSONEncoder.object spec + + +-- q = query +-- fq = filter +-- fl = JSONEncoder.fields +-- start = offset +-- rows = limit +-- sort = sort +newtype Encoder_Select a = + Encoder_Select (JSONEncoder.Object a) + deriving (Contravariant, Divisible, Decidable, Semigroup, Monoid) + +encoder_select_query :: Encoder_Select Text +encoder_select_query = + Encoder_Select (JSONEncoder.field "query" JSONEncoder.string) + +encoder_select_filter :: Encoder_Select [Text] +encoder_select_filter = + Encoder_Select (JSONEncoder.field "filter" (JSONEncoder.array (JSONEncoder.homo foldl' JSONEncoder.string))) + +encoder_select_offset :: Encoder_Select Int +encoder_select_offset = + Encoder_Select (JSONEncoder.field "offset" JSONEncoder.number_integral) + +encoder_select_limit :: Encoder_Select Int +encoder_select_limit = + Encoder_Select (JSONEncoder.field "limit" JSONEncoder.number_integral) + + + +newtype Encoder_Update a = + Encoder_Update (JSONEncoder.Object a) + deriving (Contravariant, Divisible, Decidable, Semigroup, Monoid) + +encoder_update_add :: Encoder_Add a -> Encoder_Update a +encoder_update_add (Encoder_Add spec) = + Encoder_Update (JSONEncoder.field "add" (JSONEncoder.object spec)) + +encoder_update_delete :: Encoder_Delete a -> Encoder_Update a +encoder_update_delete (Encoder_Delete spec) = + Encoder_Update (JSONEncoder.field "delete" (JSONEncoder.object spec)) + + +newtype Encoder_Add a = + Encoder_Add (JSONEncoder.Object a) + deriving (Contravariant, Divisible, Decidable, Semigroup, Monoid) + +encoder_add_doc :: JSONEncoder.Value a -> Encoder_Add a +encoder_add_doc spec = + Encoder_Add (JSONEncoder.field "doc" spec) + +encoder_add_boost :: Encoder_Add Double +encoder_add_boost = + Encoder_Add (JSONEncoder.field "boost" (contramap realToFrac JSONEncoder.number_scientific)) + +encoder_add_overwrite :: Encoder_Add Bool +encoder_add_overwrite = + Encoder_Add (JSONEncoder.field "overwrite" JSONEncoder.boolean) + +-- | +-- Specifies the amount of milliseconds (10^-3). +encoder_add_commitWithin :: Encoder_Add Int +encoder_add_commitWithin = + Encoder_Add (JSONEncoder.field "commitWithin" JSONEncoder.number_integral) + + +newtype Encoder_Delete a = + Encoder_Delete (JSONEncoder.Object a) + deriving (Contravariant, Divisible, Decidable, Semigroup, Monoid) + +encoder_delete_id :: Encoder_Delete Text +encoder_delete_id = + Encoder_Delete (JSONEncoder.field "id" JSONEncoder.string) + +encoder_delete_query :: Encoder_Delete Text +encoder_delete_query = + Encoder_Delete (JSONEncoder.field "query" JSONEncoder.string) + +-- | +-- Specifies the amount of milliseconds (10^-3). +encoder_delete_commitWithin :: Encoder_Delete Int +encoder_delete_commitWithin = + Encoder_Delete (JSONEncoder.field "commitWithin" JSONEncoder.number_integral) + + +-- * Decoders +------------------------- + +decoder_value_select :: Decoder_Select a -> JSONIncrementalDecoder.Value a +decoder_value_select (Decoder_Select spec) = + JSONIncrementalDecoder.objectLookup spec + + +newtype Decoder_Select a = + Decoder_Select (JSONIncrementalDecoder.ObjectLookup a) + deriving (Functor, Applicative) + +decoder_select_response :: Decoder_Response a -> Decoder_Select a +decoder_select_response (Decoder_Response spec) = + Decoder_Select (JSONIncrementalDecoder.atKey "response" (JSONIncrementalDecoder.objectLookup spec)) + + +-- | +-- JSON decoder in the context of the \"response\" schema. +newtype Decoder_Response a = + Decoder_Response (JSONIncrementalDecoder.ObjectLookup a) + deriving (Functor, Applicative) + +decoder_response_numFound :: Decoder_Response Int +decoder_response_numFound = + Decoder_Response $ + JSONIncrementalDecoder.atKey "numFound" JSONIncrementalDecoder.numberAsInt + +decoder_response_docs :: Decoder_Docs a -> Decoder_Response a +decoder_response_docs (Decoder_Docs spec) = + Decoder_Response (JSONIncrementalDecoder.atKey "docs" (JSONIncrementalDecoder.arrayElements spec)) + + +newtype Decoder_Docs a = + Decoder_Docs (JSONIncrementalDecoder.ArrayElements a) + deriving (Functor, Applicative, Alternative, Monad, MonadPlus) + +decoder_docs_doc :: JSONIncrementalDecoder.Value a -> Decoder_Docs a +decoder_docs_doc spec = + Decoder_Docs (JSONIncrementalDecoder.element spec) + diff --git a/library/Solr/Session.hs b/library/Solr/Session.hs new file mode 100644 --- /dev/null +++ b/library/Solr/Session.hs @@ -0,0 +1,50 @@ +module Solr.Session +( + Session, + request, + -- * Execution + Error(..), + run, +) +where + +import Solr.Prelude +import qualified Network.HTTP.Client +import qualified Data.ByteString.Lazy +import qualified Data.ByteString +import qualified Solr.Request +import qualified Solr.HTTPRequestEncoder +import qualified HTTPResponseDecoder + + +newtype Session a = + Session (ReaderT Env (ExceptT Error IO) a) + deriving (Functor, Applicative, Monad, MonadIO) + +type Env = + (ByteString, Network.HTTP.Client.Manager) + +data Error = + Error_Decoding !Text | + Error_Transport !Network.HTTP.Client.HttpException + deriving (Show) + +run :: Session a -> ByteString -> Network.HTTP.Client.Manager -> IO (Either Error a) +run (Session impl) baseURL httpManager = + runExceptT (runReaderT impl (baseURL, httpManager)) + +request :: Solr.Request.Request a b -> a -> Session b +request (Solr.Request.Request encoderProducer decoder) input = + Session $ + ReaderT $ + \(baseURL, httpManager) -> + ExceptT $ + fmap (either (Left . Error_Transport) (either (Left . Error_Decoding) Right)) $ + try $ + Network.HTTP.Client.withResponse (request baseURL) httpManager $ + responseDecoder + where + request baseURL = + Solr.HTTPRequestEncoder.encoder_request (encoderProducer baseURL) input + responseDecoder = + HTTPResponseDecoder.run decoder diff --git a/solr.cabal b/solr.cabal new file mode 100644 --- /dev/null +++ b/solr.cabal @@ -0,0 +1,69 @@ +name: + solr +version: + 0.2.1.5 +synopsis: + A minimal Solr client library +homepage: + https://github.com/sannsyn/solr +bug-reports: + https://github.com/sannsyn/solr/issues +author: + Nikita Volkov +maintainer: + Nikita Volkov +copyright: + (c) 2016, Sannsyn AS +license: + MIT +license-file: + LICENSE +build-type: + Simple +cabal-version: + >=1.10 + + +source-repository head + type: + git + location: + git://github.com/sannsyn/solr.git + + +library + hs-source-dirs: + library + default-extensions: + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-language: + Haskell2010 + other-modules: + Solr.Prelude + Solr.HTTPResponseDecoder + Solr.HTTPRequestEncoder + Solr.Parameters + exposed-modules: + Solr.Session + Solr.Request + build-depends: + -- networking: + http-response-decoder >= 0.2 && < 0.3, + http-client >= 0.4.27 && < 0.5, + uri-encode >= 1.5 && < 2, + -- json: + json-encoder >= 0.1.5 && < 0.2, + json-incremental-decoder >= 0.1.0.1 && < 0.2, + -- data: + bytestring-tree-builder >= 0.2.5 && < 0.3, + bytestring >= 0.10 && < 0.11, + text >= 1 && < 2, + case-insensitive >= 1.2 && < 2, + -- general: + matcher >= 0.1.1 && < 0.2, + semigroups >= 0.18 && < 0.19, + profunctors >= 5.2 && < 6, + contravariant >= 1.4 && < 2, + transformers >= 0.4 && < 0.6, + base-prelude < 2 +