freer-simple-http (empty) → 0.1.0.0

raw patch · 7 files changed

+261/−0 lines, 7 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, containers, freer-simple, freer-simple-http, hspec, http-client, http-types

Files

• ChangeLog.md +3/−0
• LICENSE +21/−0
• README.md +1/−0
• Setup.hs +2/−0
• freer-simple-http.cabal +64/−0
• src/Control/Monad/Freer/Http.hs +168/−0
• test/Spec.hs +2/−0

@@ -0,0 +1,3 @@+# Changelog for freer-simple-http++## Unreleased changes

@@ -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.

@@ -0,0 +1,1 @@+# freer-simple-http

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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 <https://gitlab.com/costar-astrology/freer-simple-contrib/tree/master/freer-simple-http>+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

@@ -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 ())

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"