git.iko.soy/elk
on 92ee73b help sign in
elk/builder/src/Http.hs
231 lines 5.5 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 , stringPart
20 )
21 where
24import Prelude hiding (zip)
25import qualified Codec.Archive.Zip as Zip
26import Control.Exception (SomeException, handle)
27import qualified Data.Binary as Binary
28import qualified Data.Binary.Get as Binary
29import qualified Data.ByteString.Char8 as BS
30import qualified Data.Digest.Pure.SHA as SHA
31import qualified Data.String as String
32import Network.HTTP (urlEncodeVars)
33import Network.HTTP.Client
34import Network.HTTP.Client.TLS (tlsManagerSettings)
35import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
36import Network.HTTP.Types.Method (Method, methodGet, methodPost)
37import qualified Network.HTTP.Client.MultipartFormData as Multi
39import qualified Elm.Version as V
43-- MANAGER
46getManager :: IO Manager
47getManager =
48 newManager tlsManagerSettings
52-- URL
55toUrl :: String -> [(String,String)] -> String
56toUrl url params =
57 case params of
58 [] -> url
59 _:_ -> url ++ "?" ++ urlEncodeVars params
63-- FETCH
66get :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
67get =
68 fetch methodGet
71post :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
72post =
73 fetch methodPost
76fetch :: Method -> Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
77fetch methodVerb manager url headers onError onSuccess =
78 handle (handleSomeException url onError) $
79 handle (handleHttpException url onError) $
80 do req0 <- parseUrlThrow url
81 let req1 =
82 req0
83 { method = methodVerb
84 , requestHeaders = addDefaultHeaders headers
85 }
86 withResponse req1 manager $ \response ->
87 do chunks <- brConsume (responseBody response)
88 onSuccess (BS.concat chunks)
91addDefaultHeaders :: [Header] -> [Header]
92addDefaultHeaders headers =
93 (hUserAgent, userAgent) : (hAcceptEncoding, "gzip") : headers
96{-# NOINLINE userAgent #-}
97userAgent :: BS.ByteString
98userAgent =
99 BS.pack ("elm/" ++ V.toChars V.compiler)
102accept :: BS.ByteString -> Header
103accept mime =
104 (hAccept, mime)
108-- EXCEPTIONS
111data Error
112 = BadUrl String String
113 | BadHttp String HttpExceptionContent
114 | BadMystery String SomeException
117handleHttpException :: String -> (Error -> e) -> HttpException -> IO (Either e a)
118handleHttpException url onError httpException =
119 case httpException of
120 InvalidUrlException _ reason ->
121 return (Left (onError (BadUrl url reason)))
123 HttpExceptionRequest _ content ->
124 return (Left (onError (BadHttp url content)))
127handleSomeException :: String -> (Error -> e) -> SomeException -> IO (Either e a)
128handleSomeException url onError exception =
129 return (Left (onError (BadMystery url exception)))
133-- SHA
136type Sha = SHA.Digest SHA.SHA1State
139shaToChars :: Sha -> String
140shaToChars =
141 SHA.showDigest
145-- FETCH ARCHIVE
148getArchive
149 :: Manager
150 -> String
151 -> (Error -> e)
152 -> e
153 -> ((Sha, Zip.Archive) -> IO (Either e a))
154 -> IO (Either e a)
155getArchive manager url onError err onSuccess =
156 handle (handleSomeException url onError) $
157 handle (handleHttpException url onError) $
158 do req0 <- parseUrlThrow url
159 let req1 =
160 req0
161 { method = methodGet
162 , requestHeaders = addDefaultHeaders []
163 }
164 withResponse req1 manager $ \response ->
165 do result <- readArchive (responseBody response)
166 case result of
167 Nothing -> return (Left err)
168 Just shaAndArchive -> onSuccess shaAndArchive
171readArchive :: BodyReader -> IO (Maybe (Sha, Zip.Archive))
172readArchive body =
173 readArchiveHelp body $
174 AS 0 SHA.sha1Incremental (Binary.runGetIncremental Binary.get)
177data ArchiveState =
178 AS
179 { _len :: !Int
180 , _sha :: !(Binary.Decoder SHA.SHA1State)
181 , _zip :: !(Binary.Decoder Zip.Archive)
182 }
185readArchiveHelp :: BodyReader -> ArchiveState -> IO (Maybe (Sha, Zip.Archive))
186readArchiveHelp body (AS len sha zip) =
187 case zip of
188 Binary.Fail _ _ _ ->
189 return Nothing
191 Binary.Partial k ->
192 do chunk <- brRead body
193 readArchiveHelp body $
194 AS
195 { _len = len + BS.length chunk
196 , _sha = Binary.pushChunk sha chunk
197 , _zip = k (if BS.null chunk then Nothing else Just chunk)
198 }
200 Binary.Done _ _ archive ->
201 return $ Just ( SHA.completeSha1Incremental sha len, archive )
205-- UPLOAD
208upload :: Manager -> String -> [Multi.Part] -> IO (Either Error ())
209upload manager url parts =
210 handle (handleSomeException url id) $
211 handle (handleHttpException url id) $
212 do req0 <- parseUrlThrow url
213 req1 <-
214 Multi.formDataBody parts $
215 req0
216 { method = methodPost
217 , requestHeaders = addDefaultHeaders []
218 , responseTimeout = responseTimeoutNone
219 }
220 withResponse req1 manager $ \_ ->
221 return (Right ())
224filePart :: String -> FilePath -> Multi.Part
225filePart name filePath =
226 Multi.partFileSource (String.fromString name) filePath
229stringPart :: String -> String -> Multi.Part
230stringPart name string =
231 Multi.partBS (String.fromString name) (BS.pack string)