diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for freer-simple-http + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2018 Co—Star Astrology, Ben Weitzman + +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,1 @@ +# freer-simple-http 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/freer-simple-http.cabal b/freer-simple-http.cabal new file mode 100644 --- /dev/null +++ b/freer-simple-http.cabal @@ -0,0 +1,64 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 9135ebe4e31eff70a8da4b43092d000b4ef88a76118b666772ad5be688074db9 + +name: freer-simple-http +version: 0.1.0.0 +synopsis: Make HTTP requests with freer-simple! +description: Please see the README on GitHub at +category: Web, Control, HTTP +author: Ben Weitzman +maintainer: ben@costarastrology.com +copyright: 2018 Ben Weitzman +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://gitlab.com/costar-astrology/freer-simple-contrib/tree/master/freer-simple-http + +library + exposed-modules: + Control.Monad.Freer.Http + other-modules: + Paths_freer_simple_http + hs-source-dirs: + src + default-extensions: GADTs FlexibleContexts TypeOperators DataKinds StandaloneDeriving DeriveDataTypeable MultiParamTypeClasses FlexibleInstances UndecidableInstances TypeApplications ScopedTypeVariables TypeFamilies RankNTypes DeriveAnyClass OverloadedStrings FunctionalDependencies ConstraintKinds EmptyCase BangPatterns + build-depends: + aeson >=1.3 && <1.4 + , base >=4.7 && <5 + , bytestring >=0.10 && <0.11 + , containers >=0.5 && <0.6 + , freer-simple >=1.1 && <1.2 + , http-client >=0.5 && <0.6 + , http-types >=0.12 && <0.13 + default-language: Haskell2010 + +test-suite freer-simple-http-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_freer_simple_http + hs-source-dirs: + test + default-extensions: GADTs FlexibleContexts TypeOperators DataKinds StandaloneDeriving DeriveDataTypeable MultiParamTypeClasses FlexibleInstances UndecidableInstances TypeApplications ScopedTypeVariables TypeFamilies RankNTypes DeriveAnyClass OverloadedStrings FunctionalDependencies ConstraintKinds EmptyCase BangPatterns + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson >=1.3 && <1.4 + , base >=4.7 && <5 + , bytestring >=0.10 && <0.11 + , containers >=0.5 && <0.6 + , freer-simple >=1.1 && <1.2 + , freer-simple-http + , hspec + , http-client >=0.5 && <0.6 + , http-types >=0.12 && <0.13 + default-language: Haskell2010 diff --git a/src/Control/Monad/Freer/Http.hs b/src/Control/Monad/Freer/Http.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Freer/Http.hs @@ -0,0 +1,168 @@ +{-| +Module : Control.Monad.Freer.Http +Description : http requests with freer-simple +Copyright : (c) Ben Weitzman 2018 +License : MIT +Maintainer : ben@costarastrolgoy.com +Stability : experimental +Portability : POSIX +-} + +module Control.Monad.Freer.Http + ( Http + , get + , getJSON + , post + , postJSON + , doRequest + , request + , requestJSON + , HttpException + , JSONParseError(..) + , runHttp + , mockHttp + , staticHttpMock + ) +where + +import Control.Exception + +import Control.Monad + +import Control.Monad.Freer +import Control.Monad.Freer.Error + +import Data.Aeson + +import qualified Data.ByteString as BS +import Data.ByteString.Lazy (ByteString) + +import Data.Map (Map) +import qualified Data.Map as M + +import Data.Maybe (fromMaybe) + +import Data.Functor ((<&>)) + +import Network.HTTP.Client (Request, Response, Manager, httpLbs + ,HttpException(HttpExceptionRequest), parseRequest, requestHeaders + ,method, path, HttpExceptionContent(StatusCodeException) + ,RequestBody(..), requestBody) +import Network.HTTP.Client.Internal (Response(..), CookieJar(CJ), ResponseClose(..)) +import Network.HTTP.Types.Header (RequestHeaders) +import Network.HTTP.Types.Method (Method, methodGet, methodPost) +import Network.HTTP.Types.Status (Status, status404, statusCode) +import Network.HTTP.Types.Version (http11) + +-- | The 'Http' effect is for making http requests +data Http v where + DoRequest :: Request -> Http (Response ByteString) + ParseRequest :: String -> Http Request + DoRequestJSON :: (FromJSON a) => Request -> Http a + TryRequestJSON :: (FromJSON a) => Request -> Http (Either JSONParseError a) + +-- | Low level function for making an http request +doRequest :: Member Http r => Request -> Eff r (Response ByteString) +doRequest req = send (DoRequest req) + +-- | Parse a string representing into a url. This is an effectful computation to +-- mirror 'http-client's behavior +parseReq :: Member Http r => String -> Eff r Request +parseReq = send . ParseRequest + +-- | A higher level function that will parse the http response into a data type using aeson +doRequestJSON :: (Member Http r, FromJSON a) => Request -> Eff r a +doRequestJSON = send . DoRequestJSON + +-- | Make a request and attempt to parse the response, and report an error if parsing fails +tryRequestJSON :: (Member Http r, FromJSON a) => Request -> Eff r (Either JSONParseError a) +tryRequestJSON = send . TryRequestJSON + +-- | Make an HTTP request +request :: (Member Http r) + => Method + -> RequestHeaders + -> String + -> Maybe RequestBody + -> Eff r (Response ByteString) +request meth headers url body = do + req <- parseReq url + doRequest req + { requestHeaders = headers + , method = meth + , requestBody = fromMaybe mempty body + } + +-- | An error that an http response failed to parse +newtype JSONParseError = JSONParseError String deriving (Show) + +-- | Make an HTTP request using JSON for the body and response +requestJSON :: (FromJSON resp, ToJSON req + ,Member Http r + ) + => Method + -> RequestHeaders + -> String + -> Maybe req + -> Eff r resp +requestJSON meth headers url mBody = do + let body = maybe mempty (RequestBodyLBS . encode) mBody + req <- parseReq url <&> \req -> req { requestHeaders = headers + , method = meth + , requestBody = body + } + doRequestJSON req + +-- | Make a GET request +get :: (Member Http r) + => String -> Eff r (Response ByteString) +get url = request methodGet [] url Nothing + +-- | Make a GET request that expects a JSON response +getJSON :: (FromJSON a, Member Http r) + => String -> Eff r a +getJSON url = requestJSON methodGet [] url (Nothing @()) + + +-- | Make a POST request +post :: (Member Http r) + => String -> RequestBody -> Eff r (Response ByteString) +post url = request methodPost [] url . Just + +-- | Make a POST request with a JSON body and response +postJSON :: (FromJSON resp, ToJSON req, Member Http r) + => String -> req -> Eff r resp +postJSON url = requestJSON methodPost [("Content-Type", "application/json")] url . Just + +-- | Interpret 'Http' using 'IO' and the 'http-client' library +runHttp :: forall r w + . (Member IO r, Member (Error HttpException) r, Member (Error JSONParseError) r) + => Manager + -> Eff (Http ': r) w + -> Eff r w +runHttp mgr eff = interpret handler eff + where + handler :: Http a -> Eff r a + handler (DoRequest req) = send $ httpLbs req mgr + handler (ParseRequest str) = send $ parseRequest @IO str + handler (DoRequestJSON req) = do + response <- handler (DoRequest req) + let code = statusCode $ responseStatus response + unless (200 <= code && code < 300) $ + throwError (HttpExceptionRequest req $ StatusCodeException (() <$ response) "") + let body = responseBody response + case eitherDecode body of + Left err -> throwError $ JSONParseError err + Right val -> return val + + +-- | Interpret 'Http' using a pure function +mockHttp :: Eff (Http ': r) w -> (Request -> Response ByteString) -> Eff r w +mockHttp eff f = interpret (\(DoRequest req) -> return (f req)) eff + +-- | Interpret 'Http' using a static map. Will return a 404 if the method/path are not found in the map +staticHttpMock :: Eff (Http ': r) w -> Map (Method, BS.ByteString) (Status, ByteString) -> Eff r w +staticHttpMock eff endpoints = mockHttp eff findEndpoint + where findEndpoint req = case M.lookup (method req, path req) endpoints of + Nothing -> Response status404 http11 [] "" (CJ []) (ResponseClose $ return ()) + Just (s, b) -> Response s http11 [] b (CJ []) (ResponseClose $ return ()) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"