diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,4 @@ +# Revision history for simple-query + +## 0.1 -- 2020-08-18 +- initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2020, Jens Petersen + +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 Jens Petersen nor the names of other + 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 +OWNER 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,15 @@ +# simple-query + +Very thin layer over http-conduit for simpler web API queries. + +See the Network.HTTP.Query documentation for more details. + +## Examples + +A few projects use http-query already: + +- https://github.com/juhp/bodhi-hs +- https://github.com/juhp/copr-hs +- https://github.com/juhp/pagure-hs +- https://github.com/juhp/pdc-hs +- https://github.com/juhp/fbrnch diff --git a/http-query.cabal b/http-query.cabal new file mode 100644 --- /dev/null +++ b/http-query.cabal @@ -0,0 +1,46 @@ +name: http-query +version: 0.1.0 +synopsis: Simple http queries +description: + Simple web API queries to JSON. +license: BSD3 +license-file: LICENSE +author: Jens Petersen +maintainer: Jens Petersen +copyright: 2020 Jens Petersen +category: Web +homepage: https://github.com/juhp/http-query +bug-reports: https://github.com/juhp/http-query/issues +build-type: Simple +extra-doc-files: README.md + ChangeLog.md +cabal-version: 1.18 + +source-repository head + type: git + location: https://github.com/juhp/http-query.git + +library + build-depends: base < 5 + , aeson + , bytestring + , network-uri + , http-conduit + , text + exposed-modules: Network.HTTP.Query + hs-source-dirs: src + + ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + if impl(ghc >= 8.2) + ghc-options: -fhide-source-paths + if impl(ghc >= 8.4) + ghc-options: -Wmissing-export-lists + -Wpartial-fields + + default-language: Haskell2010 diff --git a/src/Network/HTTP/Query.hs b/src/Network/HTTP/Query.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Query.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE CPP #-} + +{-| +A small library for querying a Web API. + +@ +{-# LANGUAGE OverloadedStrings #-} + +import Network.HTTP.Query + +main = do + let api = "http://www.example.com/api/1" + endpoint = api +/+ "search" + res <- webAPIQuery endpoint $ makeKey "q" "needle" + case lookupKey "results" res of + Nothing -> putStrLn "Result not found" + Just results -> print results +@ +-} + +module Network.HTTP.Query ( + Query, + QueryItem, + maybeKey, + makeKey, + makeItem, + (+/+), + webAPIQuery, + lookupKey, + lookupKeyEither, + lookupKey' + ) where + +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson.Types +#if !MIN_VERSION_http_conduit(2,3,3) +import Data.ByteString (ByteString) +#endif +import qualified Data.ByteString.Char8 as B +import Data.Text (Text) +import Network.HTTP.Client.Conduit +import Network.HTTP.Simple +import Network.URI + +#if !MIN_VERSION_http_conduit(2,3,1) +type Query = [(ByteString, Maybe ByteString)] +#endif +#if !MIN_VERSION_http_conduit(2,3,3) +type QueryItem = (ByteString, Maybe ByteString) +#endif + +-- | Maybe create a query key +maybeKey :: String -> Maybe String -> Query +maybeKey _ Nothing = [] +maybeKey k mval = [(B.pack k, fmap B.pack mval)] + +-- | Make a singleton key-value Query +makeKey :: String -> String -> Query +makeKey k val = [(B.pack k, Just (B.pack val))] + +-- | Make a key-value QueryItem +makeItem :: String -> String -> QueryItem +makeItem k val = (B.pack k, Just (B.pack val)) + +-- | Combine two path segments with a slash +-- +-- > "abc" +/+ "def" == "abc/def" +-- > "abc/" +/+ "def" == "abc/def" +-- > "abc" +/+ "/def" == "abc/def" +infixr 5 +/+ +(+/+) :: String -> String -> String +"" +/+ s = s +s +/+ "" = s +s +/+ t | last s == '/' = s ++ t + | head t == '/' = s ++ t +s +/+ t = s ++ '/' : t + +-- | Low-level web api query +webAPIQuery :: (MonadIO m, FromJSON a) + => String -- ^ url of endpoint + -> Query -- ^ query options + -> m a -- ^ returned json +webAPIQuery url params = + case parseURI url of + Nothing -> error $ "Cannot parse uri: " ++ url + Just uri -> + let req = setRequestQueryString params $ requestFromURI_ uri + in getResponseBody <$> httpJSON req + +-- | Look up key in object +lookupKey :: FromJSON a => Text -> Object -> Maybe a +lookupKey k = parseMaybe (.: k) + +-- | Like lookupKey but returns error message if not found +lookupKeyEither :: FromJSON a => Text -> Object -> Either String a +lookupKeyEither k = parseEither (.: k) + +-- | Like lookupKey but raises an error if no key found +lookupKey' :: FromJSON a => Text -> Object -> a +lookupKey' k = + either error id . parseEither (.: k)