git.iko.soy/elk
on master help sign in
elk/builder/src/Http.hs
244 lines 5.9 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Http
3 ( Manager
4 , getManager
5 , toUrl
6 -- fetch
7 , get
8 , post
9 , Header
10 , accept
11 , Error(..)
12 -- archives
13 , Sha
14 , shaToChars
15 , getArchive
16 -- upload
17 , upload
18 , filePart
19 , jsonPart
20 , stringPart
21 )
22 where
25import Prelude hiding (zip)
26import qualified Codec.Archive.Zip as Zip
27import Control.Exception (SomeException, handle)
28import qualified Data.Binary as Binary
29import qualified Data.Binary.Get as Binary
30import qualified Data.ByteString.Builder as B
31import qualified Data.ByteString.Char8 as BS
32import qualified Data.Digest.Pure.SHA as SHA
33import qualified Data.String as String
34import Network.HTTP (urlEncodeVars)
35import Network.HTTP.Client
36import Network.HTTP.Client.TLS (tlsManagerSettings)
37import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
38import Network.HTTP.Types.Method (Method, methodGet, methodPost)
39import qualified Network.HTTP.Client as Multi (RequestBody(RequestBodyLBS))
40import qualified Network.HTTP.Client.MultipartFormData as Multi
42import qualified Json.Encode as Encode
43import qualified Elm.Version as V
47-- MANAGER
50getManager :: IO Manager
51getManager =
52 newManager tlsManagerSettings
56-- URL
59toUrl :: String -> [(String,String)] -> String
60toUrl url params =
61 case params of
62 [] -> url
63 _:_ -> url ++ "?" ++ urlEncodeVars params
67-- FETCH
70get :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
71get =
72 fetch methodGet
75post :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
76post =
77 fetch methodPost
80fetch :: Method -> Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
81fetch methodVerb manager url headers onError onSuccess =
82 handle (handleSomeException url onError) $
83 handle (handleHttpException url onError) $
84 do req0 <- parseUrlThrow url
85 let req1 =
86 req0
87 { method = methodVerb
88 , requestHeaders = addDefaultHeaders headers
89 }
90 withResponse req1 manager $ \response ->
91 do chunks <- brConsume (responseBody response)
92 onSuccess (BS.concat chunks)
95addDefaultHeaders :: [Header] -> [Header]
96addDefaultHeaders headers =
97 (hUserAgent, userAgent) : (hAcceptEncoding, "gzip") : headers
100{-# NOINLINE userAgent #-}
101userAgent :: BS.ByteString
102userAgent =
103 BS.pack ("elm/" ++ V.toChars V.compiler)
106accept :: BS.ByteString -> Header
107accept mime =
108 (hAccept, mime)
112-- EXCEPTIONS
115data Error
116 = BadUrl String String
117 | BadHttp String HttpExceptionContent
118 | BadMystery String SomeException
121handleHttpException :: String -> (Error -> e) -> HttpException -> IO (Either e a)
122handleHttpException url onError httpException =
123 case httpException of
124 InvalidUrlException _ reason ->
125 return (Left (onError (BadUrl url reason)))
127 HttpExceptionRequest _ content ->
128 return (Left (onError (BadHttp url content)))
131handleSomeException :: String -> (Error -> e) -> SomeException -> IO (Either e a)
132handleSomeException url onError exception =
133 return (Left (onError (BadMystery url exception)))
137-- SHA
140type Sha = SHA.Digest SHA.SHA1State
143shaToChars :: Sha -> String
144shaToChars =
145 SHA.showDigest
149-- FETCH ARCHIVE
152getArchive
153 :: Manager
154 -> String
155 -> (Error -> e)
156 -> e
157 -> ((Sha, Zip.Archive) -> IO (Either e a))
158 -> IO (Either e a)
159getArchive manager url onError err onSuccess =
160 handle (handleSomeException url onError) $
161 handle (handleHttpException url onError) $
162 do req0 <- parseUrlThrow url
163 let req1 =
164 req0
165 { method = methodGet
166 , requestHeaders = addDefaultHeaders []
167 }
168 withResponse req1 manager $ \response ->
169 do result <- readArchive (responseBody response)
170 case result of
171 Nothing -> return (Left err)
172 Just shaAndArchive -> onSuccess shaAndArchive
175readArchive :: BodyReader -> IO (Maybe (Sha, Zip.Archive))
176readArchive body =
177 readArchiveHelp body $
178 AS 0 SHA.sha1Incremental (Binary.runGetIncremental Binary.get)
181data ArchiveState =
182 AS
183 { _len :: !Int
184 , _sha :: !(Binary.Decoder SHA.SHA1State)
185 , _zip :: !(Binary.Decoder Zip.Archive)
186 }
189readArchiveHelp :: BodyReader -> ArchiveState -> IO (Maybe (Sha, Zip.Archive))
190readArchiveHelp body (AS len sha zip) =
191 case zip of
192 Binary.Fail _ _ _ ->
193 return Nothing
195 Binary.Partial k ->
196 do chunk <- brRead body
197 readArchiveHelp body $
198 AS
199 { _len = len + BS.length chunk
200 , _sha = Binary.pushChunk sha chunk
201 , _zip = k (if BS.null chunk then Nothing else Just chunk)
202 }
204 Binary.Done _ _ archive ->
205 return $ Just ( SHA.completeSha1Incremental sha len, archive )
209-- UPLOAD
212upload :: Manager -> String -> [Multi.Part] -> IO (Either Error ())
213upload manager url parts =
214 handle (handleSomeException url id) $
215 handle (handleHttpException url id) $
216 do req0 <- parseUrlThrow url
217 req1 <-
218 Multi.formDataBody parts $
219 req0
220 { method = methodPost
221 , requestHeaders = addDefaultHeaders []
222 , responseTimeout = responseTimeoutNone
223 }
224 withResponse req1 manager $ \_ ->
225 return (Right ())
228filePart :: String -> FilePath -> Multi.Part
229filePart name filePath =
230 Multi.partFileSource (String.fromString name) filePath
233jsonPart :: String -> FilePath -> Encode.Value -> Multi.Part
234jsonPart name filePath value =
235 let
236 body =
237 Multi.RequestBodyLBS $ B.toLazyByteString $ Encode.encodeUgly value
238 in
239 Multi.partFileRequestBody (String.fromString name) filePath body
242stringPart :: String -> String -> Multi.Part
243stringPart name string =
244 Multi.partBS (String.fromString name) (BS.pack string)