packages feed

polysemy-http 0.2.0.4 → 0.3.0.0

raw patch · 8 files changed

+169/−44 lines, 8 filesdep +timedep −http-conduit

Dependencies added: time

Dependencies removed: http-conduit

Files

integration/Main.hs view
@@ -2,6 +2,7 @@  import Test.Tasty (TestTree, defaultMain, testGroup) +import Polysemy.Http.CookieTest (test_cookies) import Polysemy.Http.RequestTest (test_request) import Polysemy.Http.StreamTest (test_httpStream) import Polysemy.Http.Test (unitTest)@@ -10,7 +11,8 @@ tests =   testGroup "integration" [     unitTest "simple request" test_request,-    unitTest "streaming http response handler" test_httpStream+    unitTest "streaming http response handler" test_httpStream,+    unitTest "cookies" test_cookies   ]  main :: IO ()
+ integration/Polysemy/Http/CookieTest.hs view
@@ -0,0 +1,44 @@+module Polysemy.Http.CookieTest where++import Control.Lens ((.~))+import Hedgehog (evalEither, (===))+import Polysemy (embedToFinal, runFinal)++import qualified Polysemy.Http.Data.Http as Http+import Polysemy.Http.Data.HttpError (HttpError)+import qualified Polysemy.Http.Data.Request as Request+import Polysemy.Http.Data.Request (Port(Port), Tls(Tls))+import qualified Polysemy.Http.Data.Response as Response+import Polysemy.Http.Data.Response (Response)+import Polysemy.Http.Log (interpretLogNull)+import Polysemy.Http.Native (interpretHttpNative)+import qualified Polysemy.Http.Request as Request+import Polysemy.Http.Request (addCookie)+import Polysemy.Http.Server (withServer)+import Polysemy.Http.Test (UnitTest)+import Polysemy.Resource (resourceToIOFinal)++c1, c1v, c2, c2v :: Text+c1 = "c1"+c1v = "c1v"+c2 = "c2"+c2v = "c2v"++runRequest ::+  Int ->+  IO (Either HttpError (Response LByteString))+runRequest port = do+  runFinal $ resourceToIOFinal $ embedToFinal $ interpretLogNull $ interpretHttpNative (Http.request request)+  where+  request =+    Request.get "localhost" "cookie"+    & Request.tls .~ Tls False+    & Request.port .~ Just (Port port)+    & addCookie "localhost" c2 c2v+    & addCookie "localhost" c1 c1v++test_cookies :: UnitTest+test_cookies = do+  result <- lift (withServer runRequest)+  response <- evalEither result+  [qt|#{c1}=#{c1v};#{c2}=#{c2v}|] === Response.body response
integration/Polysemy/Http/Server.hs view
@@ -19,7 +19,7 @@   withSocketsDo,   ) import qualified Network.Wai.Handler.Warp as Warp-import Servant (Get, Handler, JSON, PlainText, Post, ReqBody, ServerT, serve, (:<|>)((:<|>)), (:>))+import Servant (Header, Get, Handler, JSON, PlainText, Post, ReqBody, ServerT, serve, (:<|>)((:<|>)), (:>)) import Servant.Client (BaseUrl(BaseUrl), Client, ClientEnv, ClientM, Scheme(Http), client, mkClientEnv, runClientM)  freePort ::@@ -49,6 +49,8 @@   "add" :> ReqBody '[JSON] Payload :> Post '[JSON] Int   :<|>   "stream" :> Get '[PlainText] Text+  :<|>+  "cookie" :> Header "cookie" Text :> Get '[PlainText] Text  apiClient :: Client ClientM Api apiClient =@@ -71,6 +73,8 @@   (\ (Payload a b) -> pure (a + b))   :<|>   pure (Text.replicate (10 * 8192) "x")+  :<|>+  (\ cookies -> pure (fromMaybe "no cookies" cookies))  forkServer :: IO (ThreadId, Int) forkServer = do
lib/Polysemy/Http.hs view
@@ -8,7 +8,21 @@   module Polysemy.Http.Data.Request,   module Polysemy.Http.Data.Response,   module Polysemy.Http.Data.Header,-  module Polysemy.Http.Request,+  withPort,+  withTls,+  simple,+  get,+  post,+  put,+  delete,+  fromUrl,+  getUrl,+  postUrl,+  putUrl,+  deleteUrl,+  cookie,+  addCookies,+  addCookie,   HttpError(..),   -- * Streaming   module Polysemy.Http.Http,@@ -78,8 +92,25 @@ import Polysemy.Http.Http (streamResponse) import Polysemy.Http.Log (interpretLogNull, interpretLogStdout) import Polysemy.Http.Native (interpretHttpNative)-import Polysemy.Http.Request (delete, deleteUrl, get, getUrl, post, postUrl, put, putUrl)+import Polysemy.Http.Request (+  addCookie,+  addCookies,+  cookie,+  delete,+  deleteUrl,+  fromUrl,+  get,+  getUrl,+  post,+  postUrl,+  put,+  putUrl,+  simple,+  withPort,+  withTls,+  ) import Polysemy.Http.Strict (interpretHttpStrict)+import Prelude hiding (get, put)  -- $intro -- A basic 'Polysemy' effect abstracting HTTP requests:
lib/Polysemy/Http/Data/Request.hs view
@@ -2,6 +2,7 @@  import Control.Lens (makeClassy) import qualified Data.Text as Text+import Network.HTTP.Client.Internal (CookieJar)  import Polysemy.Http.Data.Header (HeaderName, HeaderValue) @@ -123,6 +124,7 @@     _tls :: Tls,     _path :: Path,     _headers :: [(HeaderName, HeaderValue)],+    _cookies :: CookieJar,     _query :: [(QueryKey, Maybe QueryValue)],     _body :: Body   }
lib/Polysemy/Http/Native.hs view
@@ -2,23 +2,9 @@  import qualified Data.CaseInsensitive as CaseInsensitive import Data.CaseInsensitive (foldedCase)+import qualified Network.HTTP.Client as HTTP import Network.HTTP.Client (BodyReader, httpLbs, responseClose, responseOpen)-import qualified Network.HTTP.Client as HTTP (Manager)-import Network.HTTP.Simple (-  defaultRequest,-  getResponseBody,-  getResponseHeaders,-  getResponseStatus,-  setRequestBodyLBS,-  setRequestHeaders,-  setRequestHost,-  setRequestMethod,-  setRequestPath,-  setRequestPort,-  setRequestQueryString,-  setRequestSecure,-  )-import qualified Network.HTTP.Simple as N (Request, Response)+import Network.HTTP.Client.Internal (CookieJar(CJ)) import Polysemy (Tactical, interpretH, runT) import qualified Polysemy.Http.Data.Log as Log import Polysemy.Http.Data.Log (Log)@@ -46,34 +32,32 @@ import Polysemy.Http.Manager (interpretManager)  -- |Converts a 'Request' to a native 'N.Request'.-nativeRequest :: Request -> N.Request-nativeRequest (Request method (Host host) portOverride (Tls tls) (Path path) headers query (Body body)) =-  cons defaultRequest+nativeRequest :: Request -> HTTP.Request+nativeRequest (Request method (Host host) portOverride (Tls tls) (Path path) headers (CJ cookies) query (Body body)) =+  HTTP.setQueryString queryParams HTTP.defaultRequest {+    HTTP.host = encodeUtf8 host,+    HTTP.port = port,+    HTTP.secure = tls,+    HTTP.method = encodeUtf8 (methodUpper method),+    HTTP.requestHeaders = encodedHeaders,+    HTTP.path = encodeUtf8 path,+    HTTP.requestBody = HTTP.RequestBodyLBS body,+    HTTP.cookieJar = CJ . toList <$> nonEmpty cookies+  }   where-    cons =-      scheme .-      setRequestMethod (encodeUtf8 $ methodUpper method) .-      setRequestHeaders encodedHeaders .-      setRequestHost (encodeUtf8 host) .-      setRequestPort port .-      setRequestPath (encodeUtf8 path) .-      setRequestQueryString queryParam .-      setRequestBodyLBS body-    queryParam =+    queryParams =       bimap (encodeUtf8 . unQueryKey) (fmap (encodeUtf8 . unQueryValue)) <$> query-    scheme =-      if tls then setRequestSecure True else id     port =       maybe (if tls then 443 else 80) unPort portOverride     encodedHeaders =       bimap (CaseInsensitive.mk . encodeUtf8 . unHeaderName) (encodeUtf8 . unHeaderValue) <$> headers -convertResponse :: N.Response b -> Response b+convertResponse :: HTTP.Response b -> Response b convertResponse response =-  Response (getResponseStatus response) (getResponseBody response) headers+  Response (HTTP.responseStatus response) (HTTP.responseBody response) headers   where     headers =-      header <$> getResponseHeaders response+      header <$> HTTP.responseHeaders response     header (foldedCase -> decodeUtf8 -> name, decodeUtf8 -> value) =       Header (fromString name) (fromString value)
lib/Polysemy/Http/Request.hs view
@@ -1,8 +1,15 @@ module Polysemy.Http.Request where +import Control.Lens ((%~)) import qualified Data.Text as Text-import Prelude hiding (get)+import Data.Time (UTCTime(UTCTime))+import Network.HTTP.Client (Cookie(Cookie))+import Network.HTTP.Client.Internal (CookieJar(CJ, expose))+import Prelude hiding (get, put) +import Data.Time.Calendar (fromGregorian)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import qualified Polysemy.Http.Data.Request as Request import Polysemy.Http.Data.Request (Body, Host(Host), Method(..), Path(Path), Port(Port), Request(Request), Tls(Tls))  invalidScheme ::@@ -48,6 +55,7 @@   (host, port) <- parseHostPort url (split ":" hostPort)   pure (tls, host, port, Path (fromMaybe "" path)) +-- |Create a request with empty headers, query and cookies. withPort ::   Maybe Port ->   Tls ->@@ -57,8 +65,9 @@   Body ->   Request withPort port tls method host path =-  Request method host port tls path [] []+  Request method host port tls path [] (CJ []) [] +-- |Create a request with default port and empty headers, query and cookies. withTls ::   Tls ->   Method ->@@ -69,6 +78,7 @@ withTls =   withPort Nothing +-- |Create a TLS request with default port and empty headers, query and cookies. simple ::   Method ->   Host ->@@ -78,6 +88,7 @@ simple =   withTls (Tls True) +-- |Create a TLS GET request with default port and empty headers, query and cookies. get ::   Host ->   Path ->@@ -85,6 +96,7 @@ get host path =   simple Get host path "" +-- |Create a TLS POST request with default port and empty headers, query and cookies. post ::   Host ->   Path ->@@ -93,6 +105,7 @@ post host path =   simple Post host path +-- |Create a TLS PUT request with default port and empty headers, query and cookies. put ::   Host ->   Path ->@@ -101,6 +114,7 @@ put host path =   simple Put host path +-- |Create a TLS DELETE request with default port and empty headers, query and cookies. delete ::   Host ->   Path ->@@ -108,6 +122,7 @@ delete host path =   simple Delete host path "" +-- |Parse the URL and create a request or return a parse error. fromUrl ::   Method ->   Body ->@@ -117,12 +132,14 @@   (tls, host, port, path) <- parseUrl url   pure (withPort port tls method host path body) +-- |Parse URL for a GET. getUrl ::   Text ->   Either Text Request getUrl =   fromUrl Get "" +-- |Parse URL for a POST. postUrl ::   Body ->   Text ->@@ -130,6 +147,7 @@ postUrl =   fromUrl Post +-- |Parse URL for a PUT. putUrl ::   Body ->   Text ->@@ -137,8 +155,47 @@ putUrl =   fromUrl Put +-- |Parse URL for a DELETE. deleteUrl ::   Text ->   Either Text Request deleteUrl =   fromUrl Delete ""++neverExpire :: UTCTime+neverExpire =+  UTCTime (fromGregorian 9999 1 1) 0++epoch :: UTCTime+epoch =+  posixSecondsToUTCTime 0++-- |Create a cookie with default values.+cookie ::+  Text ->+  Text ->+  Text ->+  Cookie+cookie domain name value =+  Cookie (encodeUtf8 name) (encodeUtf8 value) neverExpire (encodeUtf8 domain) "/" epoch epoch False False False False++-- |Add multiple cookies to a request.+addCookies ::+  [Cookie] ->+  Request ->+  Request+addCookies cookies =+  Request.cookies %~ update+  where+    update =+      CJ . (cookies <>) . expose++-- |Add a cookie to a request, using default values.+addCookie ::+  Text ->+  Text ->+  Text ->+  Request ->+  Request+addCookie domain name value =+  addCookies (pure (cookie domain name value))
polysemy-http.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           polysemy-http-version:        0.2.0.4+version:        0.3.0.0 synopsis:       Polysemy effect for http-client description:    Please see the README on Github at <https://github.com/tek/polysemy-http> category:       Network@@ -70,7 +70,6 @@     , either >=5.0.1     , http-client >=0.6.4     , http-client-tls >=0.3.5-    , http-conduit >=2.3.7     , http-types >=0.12.3     , lens >=4     , polysemy >=1.3.0@@ -79,6 +78,7 @@     , string-interpolate >=0.2.1     , template-haskell >=2.14.0     , text >=1.2.3+    , time   mixins:       base hiding (Prelude)   if impl(ghc < 8.10)@@ -89,6 +89,7 @@   type: exitcode-stdio-1.0   main-is: Main.hs   other-modules:+      Polysemy.Http.CookieTest       Polysemy.Http.RequestTest       Polysemy.Http.Server       Polysemy.Http.StreamTest@@ -113,7 +114,6 @@     , hedgehog     , http-client >=0.6.4     , http-client-tls >=0.3.5-    , http-conduit >=2.3.7     , http-types >=0.12.3     , lens >=4     , network@@ -129,6 +129,7 @@     , tasty-hedgehog     , template-haskell >=2.14.0     , text >=1.2.3+    , time     , warp   mixins:       base hiding (Prelude)@@ -165,7 +166,6 @@     , hedgehog     , http-client >=0.6.4     , http-client-tls >=0.3.5-    , http-conduit >=2.3.7     , http-types >=0.12.3     , lens >=4     , polysemy >=1.3.0@@ -177,6 +177,7 @@     , tasty-hedgehog     , template-haskell >=2.14.0     , text >=1.2.3+    , time   mixins:       base hiding (Prelude)     , polysemy-http hiding (Prelude)