git.iko.soy/elk
on master help sign in
Make Http functions more specific to uses throughout compiler
a2e2a9aEvan Czaplicki
builder/src/Http.hs+60−113
compare with master
unifiedsplit
@@ -3,22 +3,19 @@ module Http
3 ( Manager
3 ( Manager
4 , getManager
4 , getManager
5 , toUrl
5 , toUrl
6+ -- post
6 , post
7 , post
7− , post'
8 , Header
8 , Header
9 , accept
9 , accept
10− , Timeout(..)
10+ , Error(..)
11− , Body(..)
11+ -- archives
12− , Multi.Part
13− , filePart
14− , stringPart
15− , BodyReader
16− , readByteString
17 , Sha
12 , Sha
18 , shaToChars
13 , shaToChars
19− , readArchive
14+ , fetchArchive
20− , writeArchive
15+ -- upload
21− , Error(..)
16+ , upload
17+ , filePart
18+ , stringPart
22 )
19 )
23 where
20 where
24
21
@@ -37,7 +34,6 @@ import Network.HTTP.Client.TLS (tlsManagerSettings)
37import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
34import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
38import Network.HTTP.Types.Method (methodPost)
35import Network.HTTP.Types.Method (methodPost)
39import qualified Network.HTTP.Client.MultipartFormData as Multi
36import qualified Network.HTTP.Client.MultipartFormData as Multi
40−import qualified System.Directory as Dir
41
37
42import qualified Elm.Version as V
38import qualified Elm.Version as V
43
39
@@ -66,13 +62,7 @@ toUrl url params =
66-- POST
62-- POST
67
63
68
64
69−post
70− :: Manager
71− -> String
72− -> [Header]
73− -> (Error -> e)
74− -> (BS.ByteString -> IO (Either e a))
65+post :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
75− -> IO (Either e a)
76post manager url headers onError onSuccess =
66post manager url headers onError onSuccess =
77 handle (handleSomeException url onError) $
67 handle (handleSomeException url onError) $
78 handle (handleHttpException url onError) $
68 handle (handleHttpException url onError) $
@@ -87,33 +77,6 @@ post manager url headers onError onSuccess =
87 onSuccess (BS.concat chunks)
77 onSuccess (BS.concat chunks)
88
78
89
79
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−
117addDefaultHeaders :: [Header] -> [Header]
80addDefaultHeaders :: [Header] -> [Header]
118addDefaultHeaders headers =
81addDefaultHeaders headers =
119 (hUserAgent, userAgent) : (hAcceptEncoding, "gzip") : headers
82 (hUserAgent, userAgent) : (hAcceptEncoding, "gzip") : headers
@@ -131,54 +94,6 @@ accept mime =
131
94
132
95
133
96
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
97-- EXCEPTIONS
183
98
184
99
@@ -204,12 +119,7 @@ handleSomeException url onError exception =
204
119
205
120
206
121
207−-- BODY READERS
122+-- SHA
208−
209−
210−readByteString :: BodyReader -> IO BS.ByteString
211−readByteString bodyReader =
212− BS.concat <$> brConsume bodyReader
213
123
214
124
215type Sha = SHA.Digest SHA.SHA1State
125type Sha = SHA.Digest SHA.SHA1State
@@ -220,6 +130,33 @@ shaToChars =
220 SHA.showDigest
130 SHA.showDigest
221
131
222
132
133+
134+-- FETCH ARCHIVE
135+
136+
137+fetchArchive
138+ :: Manager
139+ -> String
140+ -> (Error -> e)
141+ -> e
142+ -> ((Sha, Zip.Archive) -> IO (Either e a))
143+ -> IO (Either e a)
144+fetchArchive manager url onError err onSuccess =
145+ handle (handleSomeException url onError) $
146+ handle (handleHttpException url onError) $
147+ do req0 <- parseUrlThrow url
148+ let req1 =
149+ req0
150+ { method = methodPost
151+ , requestHeaders = addDefaultHeaders []
152+ }
153+ withResponse req1 manager $ \response ->
154+ do result <- readArchive (responseBody response)
155+ case result of
156+ Nothing -> return (Left err)
157+ Just shaAndArchive -> onSuccess shaAndArchive
158+
159+
223readArchive :: BodyReader -> IO (Maybe (Sha, Zip.Archive))
160readArchive :: BodyReader -> IO (Maybe (Sha, Zip.Archive))
224readArchive body =
161readArchive body =
225 readArchiveHelp body $
162 readArchiveHelp body $
@@ -254,20 +191,30 @@ readArchiveHelp body (AS len sha zip) =
254
191
255
192
256
193
257−-- WRITE ARCHIVE
194+-- UPLOAD
258
195
259
196
260−writeArchive :: Zip.Archive -> FilePath -> FilePath -> IO ()
197+upload :: Manager -> String -> [Multi.Part] -> IO (Either Error ())
261−writeArchive archive destination newRoot =
198+upload manager url parts =
262− do Dir.createDirectoryIfMissing True destination
199+ handle (handleSomeException url id) $
263− let opts = [Zip.OptDestination destination]
200+ handle (handleHttpException url id) $
264− mapM_ (Zip.writeEntry opts . replaceRoot newRoot) (Zip.zEntries archive)
201+ do req0 <- parseUrlThrow url
202+ req1 <-
203+ Multi.formDataBody parts $
204+ req0
205+ { method = methodPost
206+ , requestHeaders = addDefaultHeaders []
207+ , responseTimeout = responseTimeoutNone
208+ }
209+ withResponse req1 manager $ \_ ->
210+ return (Right ())
211+
212+
213+filePart :: String -> FilePath -> Multi.Part
214+filePart name filePath =
215+ Multi.partFileSource (String.fromString name) filePath
265
216
266
217
267−replaceRoot :: String -> Zip.Entry -> Zip.Entry
218+stringPart :: String -> String -> Multi.Part
268−replaceRoot root entry =
219+stringPart name string =
269− let
220+ Multi.partBS (String.fromString name) (BS.pack string)
270− rootless =
271− dropWhile (/='/') (Zip.eRelativePath entry)
272− in
273− entry { Zip.eRelativePath = root ++ rootless }