@@ -3,22 +3,19 @@ module Http
33 ( Manager
44 , getManager
55 , toUrl
6+ -- post
67 , post
7− , post'
88 , Header
99 , accept
10− , Timeout(..)
11− , Body(..)
12− , Multi.Part
13− , filePart
14− , stringPart
15− , BodyReader
16− , readByteString
10+ , Error(..)
11+ -- archives
1712 , Sha
1813 , shaToChars
19− , readArchive
20− , writeArchive
21− , Error(..)
14+ , fetchArchive
15+ -- upload
16+ , upload
17+ , filePart
18+ , stringPart
2219 )
2320 where
2421
@@ -37,7 +34,6 @@ import Network.HTTP.Client.TLS (tlsManagerSettings)
3734import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
3835import Network.HTTP.Types.Method (methodPost)
3936import qualified Network.HTTP.Client.MultipartFormData as Multi
40−import qualified System.Directory as Dir
4137
4238import qualified Elm.Version as V
4339
@@ -66,13 +62,7 @@ toUrl url params =
6662-- POST
6763
6864
69−post
70− :: Manager
71− -> String
72− -> [Header]
73− -> (Error -> e)
74− -> (BS.ByteString -> IO (Either e a))
75− -> IO (Either e a)
65+post :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
7666post manager url headers onError onSuccess =
7767 handle (handleSomeException url onError) $
7868 handle (handleHttpException url onError) $
@@ -87,33 +77,6 @@ post manager url headers onError onSuccess =
8777 onSuccess (BS.concat chunks)
8878
8979
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−
11780addDefaultHeaders :: [Header] -> [Header]
11881addDefaultHeaders headers =
11982 (hUserAgent, userAgent) : (hAcceptEncoding, "gzip") : headers
@@ -131,54 +94,6 @@ accept mime =
13194
13295
13396
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−
18297-- EXCEPTIONS
18398
18499
@@ -204,12 +119,7 @@ handleSomeException url onError exception =
204119
205120
206121
207−-- BODY READERS
208−
209−
210−readByteString :: BodyReader -> IO BS.ByteString
211−readByteString bodyReader =
212− BS.concat <$> brConsume bodyReader
122+-- SHA
213123
214124
215125type Sha = SHA.Digest SHA.SHA1State
@@ -220,6 +130,33 @@ shaToChars =
220130 SHA.showDigest
221131
222132
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+
223160readArchive :: BodyReader -> IO (Maybe (Sha, Zip.Archive))
224161readArchive body =
225162 readArchiveHelp body $
@@ -254,20 +191,30 @@ readArchiveHelp body (AS len sha zip) =
254191
255192
256193
257−-- WRITE ARCHIVE
194+-- UPLOAD
258195
259196
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)
197+upload :: Manager -> String -> [Multi.Part] -> IO (Either Error ())
198+upload manager url parts =
199+ handle (handleSomeException url id) $
200+ handle (handleHttpException url id) $
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
265216
266217
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 }
218+stringPart :: String -> String -> Multi.Part
219+stringPart name string =
220+ Multi.partBS (String.fromString name) (BS.pack string)