git.iko.soy/elk
on master help sign in
Redo the Http helpers to be simpler / more like in Elm
70aed83Evan Czaplicki
builder/src/Http.hsnew file+273
compare with master
unifiedsplit
@@ -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)