packages feed

hackage-security-HTTP (empty) → 0.1.0.0

raw patch · 4 files changed

+364/−0 lines, 4 filesdep +HTTPdep +basedep +bytestringsetup-changed

Dependencies added: HTTP, base, bytestring, hackage-security, mtl, network-uri, zlib

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Well-Typed LLP++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 Well-Typed LLP 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hackage-security-HTTP.cabal view
@@ -0,0 +1,36 @@+name:                hackage-security-HTTP+version:             0.1.0.0+synopsis:            Hackage security bindings against the HTTP library+description:         The hackage security library provides a 'HttpLib'+                     abstraction to allow to bind against different HTTP+                     libraries. This library implements this abstraction using+                     the @HTTP@ library. +homepage:            http://github.com/well-typed/hackage-security/+license:             BSD3+license-file:        LICENSE+author:              Edsko de Vries+maintainer:          edsko@well-typed.com+copyright:           Copyright 2015 Well-Typed LLP+category:            Distribution+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Hackage.Security.Client.Repository.HttpLib.HTTP+  build-depends:       base             >= 4.4       && < 5,+                       bytestring       >= 0.9       && < 0.11,+                       HTTP             >= 4000.2.19 && < 4000.3,+                       mtl              >= 2.2       && < 2.3,+                       network-uri      >= 2.6       && < 2.7,+                       zlib             >= 0.5       && < 0.7,+                       hackage-security >= 0.1       && < 0.2+  hs-source-dirs:      src+  default-language:    Haskell2010+  default-extensions:  DeriveDataTypeable+                       FlexibleContexts+                       RankNTypes+                       RecordWildCards+                       ScopedTypeVariables+                       StandaloneDeriving+  other-extensions:    CPP+  ghc-options:         -Wall
+ src/Hackage/Security/Client/Repository/HttpLib/HTTP.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE CPP #-}+-- | Implementation of 'HttpClient' using the HTTP package+module Hackage.Security.Client.Repository.HttpLib.HTTP (+    withClient+    -- ** Additional operations+  , setOutHandler+  , setErrHandler+  , setProxy+  , request+    -- ** Low-level API+  , Browser -- opaque+  , withBrowser+    -- * Exception types+  , UnexpectedResponse(..)+  , InvalidProxy(..)+  ) where++import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.List (intercalate)+import Data.Typeable (Typeable)+import Network.URI+import qualified Data.ByteString.Lazy   as BS.L+import qualified Control.Monad.State    as State+import qualified Codec.Compression.GZip as GZip+import qualified Network.Browser        as HTTP+import qualified Network.HTTP           as HTTP+import qualified Network.HTTP.Proxy     as HTTP++#if MIN_VERSION_zlib(0,6,0)+import qualified Codec.Compression.Zlib.Internal as GZip (DecompressError)+#endif++import Hackage.Security.Client+import Hackage.Security.Client.Repository.HttpLib+import Hackage.Security.Util.Checked+import Hackage.Security.Util.Pretty+import qualified Hackage.Security.Util.Lens as Lens++{-------------------------------------------------------------------------------+  Top-level API+-------------------------------------------------------------------------------}++-- | Initialize the client+--+-- TODO: This currently uses the lazy bytestring API offered by the HTTP+-- library. Unfortunately this provides no way of closing the connection when+-- the callback decides it doens't require any further input. It seems+-- impossible however to implement a proper streaming API.+-- See <https://github.com/haskell/HTTP/issues/86>.+withClient :: (Browser -> HttpLib -> IO a) -> IO a+withClient callback =+    bracket browserInit browserCleanup $ \browser ->+      callback browser HttpLib {+          httpGet      = get      browser+        , httpGetRange = getRange browser+        }++{-------------------------------------------------------------------------------+  Individual methods+-------------------------------------------------------------------------------}++get :: Throws SomeRemoteError+    => Browser+    -> [HttpRequestHeader] -> URI+    -> ([HttpResponseHeader] -> BodyReader -> IO a)+    -> IO a+get browser reqHeaders uri callback = wrapCustomEx $ do+    response <- request browser+      $ setRequestHeaders reqHeaders+      $ HTTP.mkRequest HTTP.GET uri+    case HTTP.rspCode response of+      (2, 0, 0) -> withResponse response callback+      otherCode -> throwChecked $ UnexpectedResponse uri otherCode++getRange :: Throws SomeRemoteError+         => Browser+         -> [HttpRequestHeader] -> URI -> (Int, Int)+         -> ([HttpResponseHeader] -> BodyReader -> IO a)+         -> IO a+getRange browser reqHeaders uri (from, to) callback = wrapCustomEx $ do+    response <- request browser+      $ setRange from to+      $ setRequestHeaders reqHeaders+      $ HTTP.mkRequest HTTP.GET uri+    case HTTP.rspCode response of+      (2, 0, 6) -> withResponse response callback+      otherCode -> throwChecked $ UnexpectedResponse uri otherCode++{-------------------------------------------------------------------------------+  Auxiliary methods used to implement the HttpClient interface+-------------------------------------------------------------------------------}++withResponse :: Throws SomeRemoteError+             => HTTP.Response BS.L.ByteString+             -> ([HttpResponseHeader] -> BodyReader -> IO a)+             -> IO a+withResponse response callback = wrapCustomEx $ do+    br <- bodyReaderFromBS $ decompress (HTTP.rspBody response)+    callback responseHeaders $ wrapCustomEx (checkDecompressError br)+  where+    responseHeaders    = getResponseHeaders response+    needsDecompression = HttpResponseContentCompression `elem` responseHeaders+    decompress         = if needsDecompression then GZip.decompress else id++{-------------------------------------------------------------------------------+  Custom exception types+-------------------------------------------------------------------------------}++#if MIN_VERSION_zlib(0,6,0)+wrapCustomEx :: ( ( Throws UnexpectedResponse+                  , Throws IOException+                  , Throws GZip.DecompressError+                  ) => IO a)+             -> (Throws SomeRemoteError => IO a)+wrapCustomEx act = handleChecked (\(ex :: UnexpectedResponse)   -> go ex)+                 $ handleChecked (\(ex :: IOException)          -> go ex)+                 $ handleChecked (\(ex :: GZip.DecompressError) -> go ex)+                 $ act+  where+    go ex = throwChecked (SomeRemoteError ex)++checkDecompressError :: Throws GZip.DecompressError => IO a -> IO a+checkDecompressError = handle $ \(ex :: GZip.DecompressError) -> throwChecked ex+#else+wrapCustomEx :: ( ( Throws UnexpectedResponse+                  , Throws IOException+                  ) => IO a)+             -> (Throws SomeRemoteError => IO a)+wrapCustomEx act = handleChecked (\(ex :: UnexpectedResponse) -> go ex)+                 $ handleChecked (\(ex :: IOException)        -> go ex)+                 $ act+  where+    go ex = throwChecked (SomeRemoteError ex)++checkDecompressError :: IO a -> IO a+checkDecompressError = id+#endif++data UnexpectedResponse = UnexpectedResponse URI (Int, Int, Int)+  deriving (Typeable)++data InvalidProxy = InvalidProxy String+  deriving (Typeable)++instance Pretty UnexpectedResponse where+  pretty (UnexpectedResponse uri code) = "Unexpected response " ++ show code+                                      ++ "for " ++ show uri++instance Pretty InvalidProxy where+  pretty (InvalidProxy p) = "Invalid proxy " ++ show p++#if MIN_VERSION_base(4,8,0)+deriving instance Show UnexpectedResponse+deriving instance Show InvalidProxy+instance Exception UnexpectedResponse where displayException = pretty+instance Exception InvalidProxy where displayException = pretty+#else+instance Show UnexpectedResponse where show = pretty+instance Show InvalidProxy where show = pretty+instance Exception UnexpectedResponse+instance Exception InvalidProxy+#endif++{-------------------------------------------------------------------------------+  Additional operations+-------------------------------------------------------------------------------}++setProxy :: Browser -> ProxyConfig String -> IO ()+setProxy browser proxyConfig = do+    proxy <- case proxyConfig of+      ProxyConfigNone  -> return HTTP.NoProxy+      ProxyConfigAuto  -> HTTP.fetchProxy True+      ProxyConfigUse p -> case HTTP.parseProxy p of+                             Nothing -> throwUnchecked $ InvalidProxy p+                             Just p' -> return p'+    withBrowser browser $ HTTP.setProxy (emptyAsNone proxy)+  where+    emptyAsNone :: HTTP.Proxy -> HTTP.Proxy+    emptyAsNone (HTTP.Proxy uri _) | null uri = HTTP.NoProxy+    emptyAsNone p = p++setOutHandler :: Browser -> (String -> IO ()) -> IO ()+setOutHandler browser = withBrowser browser . HTTP.setOutHandler++setErrHandler :: Browser -> (String -> IO ()) -> IO ()+setErrHandler browser = withBrowser browser . HTTP.setErrHandler++-- | Execute a single request+request :: Throws IOException+        => Browser+        -> HTTP.Request BS.L.ByteString+        -> IO (HTTP.Response BS.L.ByteString)+request browser = checkIO . liftM snd . withBrowser browser . HTTP.request++{-------------------------------------------------------------------------------+  Browser state+-------------------------------------------------------------------------------}++type LazyStream = HTTP.HandleStream BS.L.ByteString++data Browser = Browser {+    browserState :: MVar (HTTP.BrowserState LazyStream)+  }++-- | Run a browser action+--+-- IMPLEMENTATION NOTE: the 'browse' action doesn't itself create any+-- connections, they are created on demand; we just need to make sure to carry+-- this state from one invocation of 'browse' to another.+withBrowser :: forall a. Browser -> HTTP.BrowserAction LazyStream a -> IO a+withBrowser Browser{..} act = modifyMVar browserState $ \bst -> HTTP.browse $ do+    State.put bst+    result <- act+    bst'   <- State.get+    return (bst', result)++-- | Initial browser state+--+-- Throws an 'InvalidProxy' exception if the proxy definition is invalid.+--+-- TODO: If the proxy configuration is automatic, the _only_ way that we can+-- find out from the @HTTP@ library is to pass @True@ as the argument to+-- 'fetchProxy'; but this prints to standard error when the proxy is invalid,+-- rather than throwing an exception :-O+browserInit :: IO Browser+browserInit = do+    browserState <- newMVar =<< HTTP.browse State.get+    return Browser{..}++-- | Cleanup browser state+--+-- NOTE: Calling 'withBrowser' after 'browserCleanup' will result in deadlock.+--+-- IMPLEMENTATION NOTE: "HTTP" does not provide any explicit API for resource+-- cleanup, so we can only rely on the garbage collector to do for us.+browserCleanup :: Browser -> IO ()+browserCleanup Browser{..} = void $ takeMVar browserState++{-------------------------------------------------------------------------------+  HTTP auxiliary+-------------------------------------------------------------------------------}++hAcceptRanges :: HTTP.HeaderName+hAcceptRanges = HTTP.HdrCustom "Accept-Ranges"++setRange :: HTTP.HasHeaders a => Int -> Int -> a -> a+setRange from to = HTTP.insertHeader HTTP.HdrRange rangeHeader+  where+    -- Content-Range header uses inclusive rather than exclusive bounds+    -- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html>+    rangeHeader = "bytes=" ++ show from ++ "-" ++ show (to - 1)++setRequestHeaders :: HTTP.HasHeaders a => [HttpRequestHeader] -> a -> a+setRequestHeaders =+    foldr (.) id . map (uncurry HTTP.insertHeader) . trOpt []+  where+    trOpt :: [(HTTP.HeaderName, [String])]+          -> [HttpRequestHeader]+          -> [(HTTP.HeaderName, String)]+    trOpt acc [] =+      concatMap finalizeHeader acc+    trOpt acc (HttpRequestMaxAge0:os) =+      trOpt (insert HTTP.HdrCacheControl ["max-age=0"] acc) os+    trOpt acc (HttpRequestNoTransform:os) =+      trOpt (insert HTTP.HdrCacheControl ["no-transform"] acc) os+    trOpt acc (HttpRequestContentCompression:os) =+      trOpt (insert HTTP.HdrAcceptEncoding ["gzip"] acc) os++    -- Some headers are comma-separated, others need multiple headers for+    -- multiple options.+    --+    -- TODO: Right we we just comma-separate all of them.+    finalizeHeader :: (HTTP.HeaderName, [String]) -> [(HTTP.HeaderName, String)]+    finalizeHeader (name, strs) = [(name, intercalate ", " (reverse strs))]++    insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]+    insert x y = Lens.modify (Lens.lookupM x) (++ y)++getResponseHeaders :: HTTP.Response a -> [HttpResponseHeader]+getResponseHeaders response = concat [+    -- Check the @Accept-Ranges@ header.+    --+    -- @Accept-Ranges@ takes a _single_ argument, but there might potentially+    -- be more than one of them (although the spec does not explicitly say so).++    -- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.5>+    -- and <http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.12>+    [ HttpResponseAcceptRangesBytes+    | "bytes" `elem` map HTTP.hdrValue (HTTP.retrieveHeaders hAcceptRanges response)+    ]+  , [ HttpResponseContentCompression+    | HTTP.findHeader HTTP.HdrContentEncoding response == Just "gzip"+    ]+  ]