never executed always true always false
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE DeriveDataTypeable #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE RankNTypes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE StandaloneDeriving #-}
8 -- | Implementation of 'HttpLib' using cabal-install's own 'HttpTransport'
9 module Distribution.Client.Security.HTTP (HttpLib, transportAdapter) where
10
11 import Distribution.Solver.Compat.Prelude
12 import Prelude ()
13
14 -- stdlibs
15 import System.Directory
16 ( getTemporaryDirectory )
17 import Network.URI
18 ( URI )
19 import qualified Data.ByteString.Lazy as BS.L
20 import qualified Network.HTTP as HTTP
21
22 -- Cabal/cabal-install
23 import Distribution.Verbosity
24 ( Verbosity )
25 import Distribution.Client.HttpUtils
26 ( HttpTransport(..), HttpCode )
27 import Distribution.Client.Utils
28 ( withTempFileName )
29
30 -- hackage-security
31 import Hackage.Security.Client.Repository.HttpLib (HttpLib (..))
32 import qualified Hackage.Security.Client as HC
33 import qualified Hackage.Security.Client.Repository.HttpLib as HC
34 import qualified Hackage.Security.Util.Checked as HC
35 import qualified Hackage.Security.Util.Pretty as HC
36
37 {-------------------------------------------------------------------------------
38 'HttpLib' implementation
39 -------------------------------------------------------------------------------}
40
41 -- | Translate from hackage-security's 'HttpLib' to cabal-install's 'HttpTransport'
42 --
43 -- NOTE: The match between these two APIs is currently not perfect:
44 --
45 -- * We don't get any response headers back from the 'HttpTransport', so we
46 -- don't know if the server supports range requests. For now we optimistically
47 -- assume that it does.
48 -- * The 'HttpTransport' wants to know where to place the resulting file,
49 -- whereas the 'HttpLib' expects an 'IO' action which streams the download;
50 -- the security library then makes sure that the file gets written to a
51 -- location which is suitable (in particular, to a temporary file in the
52 -- directory where the file needs to end up, so that it can "finalize" the
53 -- file simply by doing 'renameFile'). Right now we write the file to a
54 -- temporary file in the system temp directory here and then read it again
55 -- to pass it to the security library; this is a problem for two reasons: it
56 -- is a source of inefficiency; and it means that the security library cannot
57 -- insist on a minimum download rate (potential security attack).
58 -- Fixing it however would require changing the 'HttpTransport'.
59 transportAdapter :: Verbosity -> IO HttpTransport -> HttpLib
60 transportAdapter verbosity getTransport = HttpLib{
61 httpGet = \headers uri callback -> do
62 transport <- getTransport
63 httpGetImpl verbosity transport headers uri callback
64 , httpGetRange = \headers uri range callback -> do
65 transport <- getTransport
66 getRange verbosity transport headers uri range callback
67 }
68
69 httpGetImpl
70 :: HC.Throws HC.SomeRemoteError
71 => Verbosity
72 -> HttpTransport
73 -> [HC.HttpRequestHeader] -> URI
74 -> ([HC.HttpResponseHeader] -> HC.BodyReader -> IO a)
75 -> IO a
76 httpGetImpl verbosity transport reqHeaders uri callback = wrapCustomEx $ do
77 get' verbosity transport reqHeaders uri Nothing $ \code respHeaders br ->
78 case code of
79 200 -> callback respHeaders br
80 _ -> HC.throwChecked $ UnexpectedResponse uri code
81
82 getRange :: HC.Throws HC.SomeRemoteError
83 => Verbosity
84 -> HttpTransport
85 -> [HC.HttpRequestHeader] -> URI -> (Int, Int)
86 -> (HC.HttpStatus -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a)
87 -> IO a
88 getRange verbosity transport reqHeaders uri range callback = wrapCustomEx $ do
89 get' verbosity transport reqHeaders uri (Just range) $ \code respHeaders br ->
90 case code of
91 200 -> callback HC.HttpStatus200OK respHeaders br
92 206 -> callback HC.HttpStatus206PartialContent respHeaders br
93 _ -> HC.throwChecked $ UnexpectedResponse uri code
94
95 -- | Internal generalization of 'get' and 'getRange'
96 get' :: Verbosity
97 -> HttpTransport
98 -> [HC.HttpRequestHeader] -> URI -> Maybe (Int, Int)
99 -> (HttpCode -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a)
100 -> IO a
101 get' verbosity transport reqHeaders uri mRange callback = do
102 tempDir <- getTemporaryDirectory
103 withTempFileName tempDir "transportAdapterGet" $ \temp -> do
104 (code, _etag) <- getHttp transport verbosity uri Nothing temp reqHeaders'
105 br <- HC.bodyReaderFromBS =<< BS.L.readFile temp
106 callback code [HC.HttpResponseAcceptRangesBytes] br
107 where
108 reqHeaders' = mkReqHeaders reqHeaders mRange
109
110 {-------------------------------------------------------------------------------
111 Request headers
112 -------------------------------------------------------------------------------}
113
114 mkRangeHeader :: Int -> Int -> HTTP.Header
115 mkRangeHeader from to = HTTP.Header HTTP.HdrRange rangeHeader
116 where
117 -- Content-Range header uses inclusive rather than exclusive bounds
118 -- See <http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html>
119 rangeHeader = "bytes=" ++ show from ++ "-" ++ show (to - 1)
120
121 mkReqHeaders :: [HC.HttpRequestHeader] -> Maybe (Int, Int) -> [HTTP.Header]
122 mkReqHeaders reqHeaders mRange = concat [
123 tr [] reqHeaders
124 , [mkRangeHeader fr to | Just (fr, to) <- [mRange]]
125 ]
126 where
127 tr :: [(HTTP.HeaderName, [String])] -> [HC.HttpRequestHeader] -> [HTTP.Header]
128 tr acc [] =
129 concatMap finalize acc
130 tr acc (HC.HttpRequestMaxAge0:os) =
131 tr (insert HTTP.HdrCacheControl ["max-age=0"] acc) os
132 tr acc (HC.HttpRequestNoTransform:os) =
133 tr (insert HTTP.HdrCacheControl ["no-transform"] acc) os
134
135 -- Some headers are comma-separated, others need multiple headers for
136 -- multiple options.
137 --
138 -- TODO: Right we just comma-separate all of them.
139 finalize :: (HTTP.HeaderName, [String]) -> [HTTP.Header]
140 finalize (name, strs) = [HTTP.Header name (intercalate ", " (reverse strs))]
141
142 insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]
143 insert x y = modifyAssocList x (++ y)
144
145 -- modify the first matching element
146 modifyAssocList :: Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)]
147 modifyAssocList a f = go where
148 go [] = []
149 go (p@(a', b) : xs) | a == a' = (a', f b) : xs
150 | otherwise = p : go xs
151
152 {-------------------------------------------------------------------------------
153 Custom exceptions
154 -------------------------------------------------------------------------------}
155
156 data UnexpectedResponse = UnexpectedResponse URI Int
157 deriving (Typeable)
158
159 instance HC.Pretty UnexpectedResponse where
160 pretty (UnexpectedResponse uri code) = "Unexpected response " ++ show code
161 ++ " for " ++ show uri
162
163 #if MIN_VERSION_base(4,8,0)
164 deriving instance Show UnexpectedResponse
165 instance Exception UnexpectedResponse where displayException = HC.pretty
166 #else
167 instance Show UnexpectedResponse where show = HC.pretty
168 instance Exception UnexpectedResponse
169 #endif
170
171 wrapCustomEx :: ( ( HC.Throws UnexpectedResponse
172 , HC.Throws IOException
173 ) => IO a)
174 -> (HC.Throws HC.SomeRemoteError => IO a)
175 wrapCustomEx act = HC.handleChecked (\(ex :: UnexpectedResponse) -> go ex)
176 $ HC.handleChecked (\(ex :: IOException) -> go ex)
177 $ act
178 where
179 go ex = HC.throwChecked (HC.SomeRemoteError ex)