git.iko.soy/elk
on master help sign in
Redo the Http helpers to be simpler / more like in Elm

The tricks with GADTs were kind of neat, but it distracted from more important details. It turns out that parallel requests are only needed in one place, so rather than having a generic mechanism, it's be easier to just handle it in that one place.

commit70aed834f4b9786588656357c734cf7baf774502 authorEvan Czaplicki <evancz@users.noreply.github.com> dateTue 12 Feb 2019, 18:40 (8 years ago) parent58a25d5
2 files changed+273−194
compare with master
unifiedsplit
builder/src/Http.hs+273 builder/src/Reporting/Task/Http.hs−194
builder/src/Http.hsnew file+273
@@ -0,0 +1,273 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Http
3+ ( Manager
4+ , getManager
5+ , toUrl
6+ , post
7+ , post'
8+ , Header
9+ , accept
10+ , Timeout(..)
11+ , Body(..)
12+ , Multi.Part
13+ , filePart
14+ , stringPart
15+ , BodyReader
16+ , readByteString
17+ , Sha
18+ , shaToChars
19+ , readArchive
20+ , writeArchive
21+ , Error(..)
22+ )
23+ where
24+
25+
26+import Prelude hiding (zip)
27+import qualified Codec.Archive.Zip as Zip
28+import Control.Exception (SomeException, handle)
29+import qualified Data.Binary as Binary
30+import qualified Data.Binary.Get as Binary
31+import qualified Data.ByteString.Char8 as BS
32+import qualified Data.Digest.Pure.SHA as SHA
33+import qualified Data.String as String
34+import Network.HTTP (urlEncodeVars)
35+import Network.HTTP.Client
36+import Network.HTTP.Client.TLS (tlsManagerSettings)
37+import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
38+import Network.HTTP.Types.Method (methodPost)
39+import qualified Network.HTTP.Client.MultipartFormData as Multi
40+import qualified System.Directory as Dir
41+
42+import qualified Elm.Version as V
43+
44+
45+
46+-- MANAGER
47+
48+
49+getManager :: IO Manager
50+getManager =
51+ newManager tlsManagerSettings
52+
53+
54+
55+-- URL
56+
57+
58+toUrl :: String -> [(String,String)] -> String
59+toUrl url params =
60+ case params of
61+ [] -> url
62+ _:_ -> url ++ "?" ++ urlEncodeVars params
63+
64+
65+
66+-- POST
67+
68+
69+post
70+ :: Manager
71+ -> String
72+ -> [Header]
73+ -> (Error -> e)
74+ -> (BS.ByteString -> IO (Either e a))
75+ -> IO (Either e a)
76+post manager url headers onError onSuccess =
77+ handle (handleSomeException url onError) $
78+ handle (handleHttpException url onError) $
79+ do req0 <- parseUrlThrow url
80+ let req1 =
81+ req0
82+ { method = methodPost
83+ , requestHeaders = addDefaultHeaders headers
84+ }
85+ withResponse req1 manager $ \response ->
86+ do chunks <- brConsume (responseBody response)
87+ onSuccess (BS.concat chunks)
88+
89+
90+post'
91+ :: Manager
92+ -> String
93+ -> [Header]
94+ -> Timeout
95+ -> Body
96+ -> (Error -> e)
97+ -> (BodyReader -> IO (Either e a))
98+ -> IO (Either e a)
99+post' manager url headers timeout body onError onSuccess =
100+ handle (handleSomeException url onError) $
101+ handle (handleHttpException url onError) $
102+ do req0 <- parseUrlThrow url
103+ req1 <-
104+ addBody body $
105+ addTimeout timeout $
106+ req0
107+ { method = methodPost
108+ , requestHeaders = addDefaultHeaders headers
109+ }
110+ withResponse req1 manager (onSuccess . responseBody)
111+
112+
113+
114+-- HEADERS
115+
116+
117+addDefaultHeaders :: [Header] -> [Header]
118+addDefaultHeaders headers =
119+ (hUserAgent, userAgent) : (hAcceptEncoding, "gzip") : headers
120+
121+
122+{-# NOINLINE userAgent #-}
123+userAgent :: BS.ByteString
124+userAgent =
125+ BS.pack ("elm/" ++ V.toChars V.compiler)
126+
127+
128+accept :: BS.ByteString -> Header
129+accept mime =
130+ (hAccept, mime)
131+
132+
133+
134+-- TIMEOUT
135+
136+
137+data Timeout
138+ = DefaultTimeout
139+ | NeverTimeout
140+
141+
142+addTimeout :: Timeout -> Request -> Request
143+addTimeout timeout req =
144+ case timeout of
145+ DefaultTimeout ->
146+ req
147+
148+ NeverTimeout ->
149+ req { responseTimeout = responseTimeoutNone }
150+
151+
152+
153+-- BODY
154+
155+
156+data Body
157+ = NoBody
158+ | FormDataBody [Multi.Part]
159+
160+
161+addBody :: Body -> Request -> IO Request
162+addBody body req =
163+ case body of
164+ NoBody ->
165+ return req
166+
167+ FormDataBody parts ->
168+ Multi.formDataBody parts req
169+
170+
171+filePart :: String -> FilePath -> Multi.Part
172+filePart name filePath =
173+ Multi.partFileSource (String.fromString name) filePath
174+
175+
176+stringPart :: String -> String -> Multi.Part
177+stringPart name string =
178+ Multi.partBS (String.fromString name) (BS.pack string)
179+
180+
181+
182+-- EXCEPTIONS
183+
184+
185+data Error
186+ = BadUrl String String
187+ | BadHttp String HttpExceptionContent
188+ | BadMystery String SomeException
189+
190+
191+handleHttpException :: String -> (Error -> e) -> HttpException -> IO (Either e a)
192+handleHttpException url onError httpException =
193+ case httpException of
194+ InvalidUrlException _ reason ->
195+ return (Left (onError (BadUrl url reason)))
196+
197+ HttpExceptionRequest _ content ->
198+ return (Left (onError (BadHttp url content)))
199+
200+
201+handleSomeException :: String -> (Error -> e) -> SomeException -> IO (Either e a)
202+handleSomeException url onError exception =
203+ return (Left (onError (BadMystery url exception)))
204+
205+
206+
207+-- BODY READERS
208+
209+
210+readByteString :: BodyReader -> IO BS.ByteString
211+readByteString bodyReader =
212+ BS.concat <$> brConsume bodyReader
213+
214+
215+type Sha = SHA.Digest SHA.SHA1State
216+
217+
218+shaToChars :: Sha -> String
219+shaToChars =
220+ SHA.showDigest
221+
222+
223+readArchive :: BodyReader -> IO (Maybe (Sha, Zip.Archive))
224+readArchive body =
225+ readArchiveHelp body $
226+ AS 0 SHA.sha1Incremental (Binary.runGetIncremental Binary.get)
227+
228+
229+data ArchiveState =
230+ AS
231+ { _len :: !Int
232+ , _sha :: !(Binary.Decoder SHA.SHA1State)
233+ , _zip :: !(Binary.Decoder Zip.Archive)
234+ }
235+
236+
237+readArchiveHelp :: BodyReader -> ArchiveState -> IO (Maybe (Sha, Zip.Archive))
238+readArchiveHelp body (AS len sha zip) =
239+ case zip of
240+ Binary.Fail _ _ _ ->
241+ return Nothing
242+
243+ Binary.Partial k ->
244+ do chunk <- brRead body
245+ readArchiveHelp body $
246+ AS
247+ { _len = len + BS.length chunk
248+ , _sha = Binary.pushChunk sha chunk
249+ , _zip = k (if BS.null chunk then Nothing else Just chunk)
250+ }
251+
252+ Binary.Done _ _ archive ->
253+ return $ Just ( SHA.completeSha1Incremental sha len, archive )
254+
255+
256+
257+-- WRITE ARCHIVE
258+
259+
260+writeArchive :: Zip.Archive -> FilePath -> FilePath -> IO ()
261+writeArchive archive destination newRoot =
262+ do Dir.createDirectoryIfMissing True destination
263+ let opts = [Zip.OptDestination destination]
264+ mapM_ (Zip.writeEntry opts . replaceRoot newRoot) (Zip.zEntries archive)
265+
266+
267+replaceRoot :: String -> Zip.Entry -> Zip.Entry
268+replaceRoot root entry =
269+ let
270+ rootless =
271+ dropWhile (/='/') (Zip.eRelativePath entry)
272+ in
273+ entry { Zip.eRelativePath = root ++ rootless }
builder/src/Reporting/Task/Http.hsdeleted−194
@@ -1,194 +0,0 @@
1−{-# LANGUAGE GADTs #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Reporting.Task.Http
4− ( Fetch
5− , Handler
6− , run
7− , package
8− , anything
9− , andThen
10− , parallel
11− , report
12− )
13− where
14−
15−
16−import Control.Concurrent (forkIO)
17−import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
18−import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)
19−import Control.Exception (Exception, SomeException, catch)
20−import Control.Monad (forever, join, replicateM_, void)
21−import qualified Data.ByteString.Char8 as BS
22−import qualified Network.HTTP as Http (urlEncodeVars)
23−import qualified Network.HTTP.Client as Http
24−import qualified Network.HTTP.Types.Header as Http (hAcceptEncoding, hUserAgent)
25−
26−import qualified Elm.Version as V
27−import qualified Reporting.Exit as Exit
28−import qualified Reporting.Exit.Http as E
29−import qualified Reporting.Progress as Progress
30−import qualified Reporting.Task as Task
31−
32−
33−
34−-- FETCH
35−
36−
37−data Fetch a where
38− Package :: String -> [(String,String)] -> Handler a -> Fetch a
39− Anything :: String -> Handler a -> Fetch a
40− AndThen :: Fetch a -> (a -> Fetch b) -> Fetch b
41− Parallel :: [Fetch a] -> Fetch [a]
42− Report :: Progress.Progress -> (Progress.Outcome -> Progress.Progress) -> Fetch a -> Fetch a
43−
44−
45−type Handler a =
46− Http.Request -> Http.Manager -> IO (Either E.Exit a)
47−
48−
49−package :: String -> [(String,String)] -> Handler a -> Fetch a
50−package =
51− Package
52−
53−
54−anything :: String -> Handler a -> Fetch a
55−anything =
56− Anything
57−
58−
59−andThen :: Fetch a -> (a -> Fetch b) -> Fetch b
60−andThen =
61− AndThen
62−
63−
64−parallel :: [Fetch a] -> Fetch [a]
65−parallel =
66− Parallel
67−
68−
69−report :: Progress.Progress -> (Progress.Outcome -> Progress.Progress) -> Fetch a -> Fetch a
70−report =
71− Report
72−
73−
74−
75−-- RUN
76−
77−
78−run :: Fetch a -> Task.Task a
79−run fetch =
80− Task.runHttp $ \manager tell ->
81− do chan <- newChan
82− replicateM_ 4 $ forkIO $ forever $ join (readChan chan)
83− readMVar =<< runHelp chan manager tell fetch
84−
85−
86−runHelp :: Chan (IO ()) -> Http.Manager -> (Progress.Progress -> IO ()) -> Fetch a -> IO (MVar (Either Exit.Exit a))
87−runHelp chan manager tell fetch =
88− case fetch of
89− Package path params handler ->
90− do mvar <- newEmptyMVar
91− let url = makePackageUrl path params
92− writeChan chan $ putMVar mvar =<< fetchSafe url manager handler
93− return mvar
94−
95− Anything url handler ->
96− do mvar <- newEmptyMVar
97− writeChan chan $ putMVar mvar =<< fetchSafe url manager handler
98− return mvar
99−
100− AndThen subFetch callback ->
101− do subMVar <- runHelp chan manager tell subFetch
102− mvar <- newEmptyMVar
103− void $ forkIO $
104− do result <- readMVar subMVar
105− putMVar mvar =<<
106− case result of
107− Left err ->
108− return (Left err)
109− Right value ->
110− readMVar =<< runHelp chan manager tell (callback value)
111− return mvar
112−
113− Parallel fetches ->
114− do mvars <- mapM (runHelp chan manager tell) fetches
115− mvar <- newEmptyMVar
116− void $ forkIO $
117− do results <- mapM readMVar mvars
118− putMVar mvar (sequence results)
119− return mvar
120−
121− Report start toEnd subFetch ->
122− do tell start
123− subMVar <- runHelp chan manager tell subFetch
124− mvar <- newEmptyMVar
125− void $ forkIO $
126− do result <- readMVar subMVar
127− tell $ toEnd $
128− either (\_ -> Progress.Bad) (\_ -> Progress.Good) result
129− putMVar mvar result
130− return mvar
131−
132−
133−
134−-- PACKAGE URLS
135−
136−
137−packageDomain :: String
138−packageDomain =
139− "https://package.elm-lang.org"
140−
141−
142−makePackageUrl :: String -> [(String,String)] -> String
143−makePackageUrl path params =
144− let
145− query =
146− if null params then
147− ""
148− else
149− "?" ++ Http.urlEncodeVars params
150− in
151− packageDomain ++ "/" ++ path ++ query
152−
153−
154−
155−-- HTTP HELP
156−
157−
158−fetchSafe :: String -> Http.Manager -> Handler a -> IO (Either Exit.Exit a)
159−fetchSafe url manager handler =
160− fetchUnsafe url manager handler
161− `catch` \e -> handleAnyError url (e :: SomeException)
162−
163−
164−fetchUnsafe :: String -> Http.Manager -> Handler a -> IO (Either Exit.Exit a)
165−fetchUnsafe url manager handler =
166− do request <- Http.parseUrlThrow url
167− result <- handler (addHeaders request) manager
168− case result of
169− Right value ->
170− return (Right value)
171−
172− Left problem ->
173− return (Left (Exit.BadHttp url problem))
174−
175−
176−handleAnyError :: (Exception e) => String -> e -> IO (Either Exit.Exit a)
177−handleAnyError url exception =
178− return $ Left $ Exit.BadHttp url $ E.Unknown $ show exception
179−
180−
181−addHeaders :: Http.Request -> Http.Request
182−addHeaders request =
183− request
184− { Http.requestHeaders =
185− [ (Http.hUserAgent, userAgent)
186− , (Http.hAcceptEncoding, "gzip")
187− ]
188− }
189−
190−
191−{-# NOINLINE userAgent #-}
192−userAgent :: BS.ByteString
193−userAgent =
194− BS.pack ("elm/" ++ V.toChars V.compiler)