diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,8 @@ +# req-url-extra + +## v0.1.0.0 + +* Provides `toUrlHttp` and `toUrlHttps` to convert from [`URI`][modern-uri] to [`Url`][req] + +[modern-uri]: https://hackage.haskell.org/package/modern-uri +[req]: https://hackage.haskell.org/package/req diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2018 Richard Cook + +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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,60 @@ +# `req-url-extra` + +[![Travis branch](https://img.shields.io/travis/rcook/req-url-extra/master.svg)](https://travis-ci.org/rcook/req-url-extra) +[![Hackage](https://img.shields.io/hackage/v/req-url-extra.svg)](http://hackage.haskell.org/package/req-url-extra) +[![GitHub license](https://img.shields.io/badge/license-MIT-blue.svg)](https://raw.githubusercontent.com/rcook/req-url-extra/master/LICENSE) + +This package provides helper functions to make working with `Url` from [Req][req] easier. + +## Dev guide + +This project can be built using the [Stack][stack] build tool. + +### Clone repository + +``` +git clone https://github.com/rcook/req-url-extra.git +``` + +### Build + +``` +stack build +``` + +### Test + +``` +stack test +``` + +### Upload package + +``` +stack upload . +``` + +### Upload documentation + +I use my [`upload-haddocks`][upload-haddocks] tool which requires a functioning installation of Python and pip: + +``` +pip install --user upload-haddocks +upload-haddocks +``` + +## Releases + +[View change log for more information][change-log] + +## Licence + +[MIT License][licence] + +Copyright © 2018, Richard Cook. + +[change-log]: CHANGELOG.md +[licence]: LICENSE +[req]: https://hackage.haskell.org/package/req +[stack]: http://haskellstack.org/ +[upload-haddocks]: https://github.com/rcook/upload-haddocks diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,10 @@ +-------------------------------------------------- +-- Copyright (C) 2018, All rights reserved. +-------------------------------------------------- + +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/lib/Network/HTTP/Req/Url/Extra.hs b/lib/Network/HTTP/Req/Url/Extra.hs new file mode 100644 --- /dev/null +++ b/lib/Network/HTTP/Req/Url/Extra.hs @@ -0,0 +1,18 @@ +{-| +Module : Network.HTTP.Req.Url.Extra +Description : Functions for working with Req 'Url' +Copyright : (C) Richard Cook, 2018 +Licence : MIT +Maintainer : rcook@rcook.org +Stability : stable +Portability : portable + +This package provides helper functions to make working with 'Url' from + easier. +-} + +module Network.HTTP.Req.Url.Extra + ( module Network.HTTP.Req.Url.Extra.URI + ) where + +import Network.HTTP.Req.Url.Extra.URI diff --git a/lib/Network/HTTP/Req/Url/Extra/URI.hs b/lib/Network/HTTP/Req/Url/Extra/URI.hs new file mode 100644 --- /dev/null +++ b/lib/Network/HTTP/Req/Url/Extra/URI.hs @@ -0,0 +1,47 @@ +{-| +Module : Network.HTTP.Req.Url.Extra.URI +Description : Functions for converting 'URI' to 'Url' +Copyright : (C) Richard Cook, 2018 +Licence : MIT +Maintainer : rcook@rcook.org +Stability : stable +Portability : portable + +This module provides functions to convert from 'URI' (defined in +) to 'Url' +defined in . +-} + +{-# LANGUAGE DataKinds #-} + +module Network.HTTP.Req.Url.Extra.URI + ( toUrlHttp + , toUrlHttps + ) where + +import Network.HTTP.Req (Option, Scheme(..), Url, parseUrlHttp, parseUrlHttps) +import Text.URI (URI, renderBs) + +-- | 'toUrlHttp' converts an instance of 'URI' to an instance of 'Url' and +-- 'Option'. If the @URI@ is not a valid @http@ URI, then this function +-- will return 'Nothing'. +-- +-- This function parses scheme, host and path, returned as part of 'Url', +-- and optional query parameters, returned in 'Option'. It does not parse +-- method name or authentication info from the given 'URI'. +toUrlHttp :: + URI -- ^ URI + -> Maybe (Url 'Http, Option scheme) -- ^ Combination of 'Url' and 'Option', 'Nothing' on failure +toUrlHttp = parseUrlHttp . renderBs + +-- | 'toUrlHttp' converts an instance of 'URI' to an instance of 'Url' and +-- 'Option'. If the @URI@ is not a valid @https@ URI, then this function +-- will return 'Nothing'. +-- +-- This function parses scheme, host and path, returned as part of 'Url', +-- and optional query parameters, returned in 'Option'. It does not parse +-- method name or authentication info from the given 'URI'. +toUrlHttps :: + URI -- ^ URI + -> Maybe (Url 'Https, Option scheme) -- ^ Combination of 'Url' and 'Option', 'Nothing' on failure +toUrlHttps = parseUrlHttps . renderBs diff --git a/req-url-extra.cabal b/req-url-extra.cabal new file mode 100644 --- /dev/null +++ b/req-url-extra.cabal @@ -0,0 +1,76 @@ + +name: req-url-extra +version: 0.1.0.0 +synopsis: Provides URI/URL helper functions for use with Req +description: This package provides helper functions for use with URIs and URLs in Req. +homepage: https://github.com/rcook/req-url-extra#readme +bug-reports: https://github.com/rcook/req-url-extra/issues +license: MIT +license-file: LICENSE +author: Richard Cook +maintainer: rcook@rcook.org +copyright: 2018 Richard Cook +category: Network, Web +build-type: Simple +cabal-version: >= 1.18 +extra-doc-files: CHANGELOG.md + , README.md + +source-repository head + type: git + location: https://github.com/rcook/req-url-extra.git + +library + default-language: Haskell2010 + hs-source-dirs: lib + ghc-options: -W + -Wall + -Werror=incomplete-patterns + -Werror=missing-methods + -fwarn-unused-imports + build-depends: base >= 4.7 && < 5 + , modern-uri + , req + exposed-modules: Network.HTTP.Req.Url.Extra + other-modules: Network.HTTP.Req.Url.Extra.URI + +executable sample + default-language: Haskell2010 + hs-source-dirs: sample + main-is: Main.hs + ghc-options: -threaded + -rtsopts + -with-rtsopts=-N + -W + -Wall + -Werror=incomplete-patterns + -Werror=missing-methods + -fwarn-unused-imports + build-depends: aeson + , base >= 4.7 && < 5 + , data-default-class + , modern-uri + , req + , req-url-extra + , text + +test-suite req-url-extra-test + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + ghc-options: -threaded + -rtsopts + -with-rtsopts=-N + -W + -Wall + -Werror=incomplete-patterns + -Werror=missing-methods + -fwarn-unused-imports + other-modules: URISpec + build-depends: base >= 4.7 && < 5 + , hspec + , modern-uri + , req + , req-url-extra + diff --git a/sample/Main.hs b/sample/Main.hs new file mode 100644 --- /dev/null +++ b/sample/Main.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Main (main) where + +import Data.Aeson (Value) +import Data.Default.Class (def) +import Network.HTTP.Req (GET(..), NoReqBody(..), jsonResponse, req, responseBody, runReq) +import Network.HTTP.Req.Url.Extra (toUrlHttps) +import Text.URI.QQ (uri) + +main :: IO () +main = do + let Just (url, opts) = toUrlHttps [uri|https://httpbin.org/get?a=value0&a=value1&b=value3#fragment|] + v <- runReq def $ req GET url NoReqBody jsonResponse opts + print (responseBody v :: Value) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,11 @@ +{-| +Module : Main +Description : Main entrypoint for @req-url-extra@ tests +Copyright : (C) Richard Cook, 2018 +Licence : MIT +Maintainer : rcook@rcook.org +Stability : stable +Portability : portable +-} + +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/URISpec.hs b/test/URISpec.hs new file mode 100644 --- /dev/null +++ b/test/URISpec.hs @@ -0,0 +1,44 @@ +{-| +Module : URISpec +Description : Tests for 'URI' module +Copyright : (C) Richard Cook, 2018 +Licence : MIT +Maintainer : rcook@rcook.org +Stability : stable +Portability : portable +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module URISpec (spec) where + +import Data.Maybe (isNothing) +import Network.HTTP.Req (parseUrlHttp, parseUrlHttps) +import Network.HTTP.Req.Url.Extra +import Text.URI.QQ (uri) +import Test.Hspec + +-- | Variant of 'shouldSatisfy' where 'a' does not have to have a 'Show' +-- instance +shouldSatisfy' :: HasCallStack => a -> (a -> Bool) -> Expectation +v `shouldSatisfy'` p = let result = p v in result `shouldBe` True + +spec :: Spec +spec = do + describe "toUrlHttp" $ do + it "parses HTTP URI" $ do + -- 'Option' is opaque so there is no way to validate the query parameters + let Just (actualUrl, _) = toUrlHttp [uri|http://httpbin.org/|] + Just (expectedUrl, _) = parseUrlHttp "http://httpbin.org/" + actualUrl `shouldBe` expectedUrl + it "fails to parse HTTPS URI" $ + toUrlHttp [uri|https://httpbin.org/|] `shouldSatisfy'` isNothing + describe "toUrlHttps" $ do + it "parses HTTPS URI" $ do + -- 'Option' is opaque so there is no way to validate the query parameters + let Just (actualUrl, _) = toUrlHttps [uri|https://httpbin.org/|] + Just (expectedUrl, _) = parseUrlHttps "https://httpbin.org/" + actualUrl `shouldBe` expectedUrl + it "fails to parse HTTPS URI" $ + toUrlHttps [uri|http://httpbin.org/|] `shouldSatisfy'` isNothing