git.iko.soy/elk
on 2afa146 help sign in
elk/builder/src/Http.hs
220 lines 5.2 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Http
3 ( Manager
4 , getManager
5 , toUrl
6 -- post
7 , post
8 , Header
9 , accept
10 , Error(..)
11 -- archives
12 , Sha
13 , shaToChars
14 , fetchArchive
15 -- upload
16 , upload
17 , filePart
18 , stringPart
19 )
20 where
23import Prelude hiding (zip)
24import qualified Codec.Archive.Zip as Zip
25import Control.Exception (SomeException, handle)
26import qualified Data.Binary as Binary
27import qualified Data.Binary.Get as Binary
28import qualified Data.ByteString.Char8 as BS
29import qualified Data.Digest.Pure.SHA as SHA
30import qualified Data.String as String
31import Network.HTTP (urlEncodeVars)
32import Network.HTTP.Client
33import Network.HTTP.Client.TLS (tlsManagerSettings)
34import Network.HTTP.Types.Header (Header, hAccept, hAcceptEncoding, hUserAgent)
35import Network.HTTP.Types.Method (methodPost)
36import qualified Network.HTTP.Client.MultipartFormData as Multi
38import qualified Elm.Version as V
42-- MANAGER
45getManager :: IO Manager
46getManager =
47 newManager tlsManagerSettings
51-- URL
54toUrl :: String -> [(String,String)] -> String
55toUrl url params =
56 case params of
57 [] -> url
58 _:_ -> url ++ "?" ++ urlEncodeVars params
62-- POST
65post :: Manager -> String -> [Header] -> (Error -> e) -> (BS.ByteString -> IO (Either e a)) -> IO (Either e a)
66post manager url headers onError onSuccess =
67 handle (handleSomeException url onError) $
68 handle (handleHttpException url onError) $
69 do req0 <- parseUrlThrow url
70 let req1 =
71 req0
72 { method = methodPost
73 , requestHeaders = addDefaultHeaders headers
74 }
75 withResponse req1 manager $ \response ->
76 do chunks <- brConsume (responseBody response)
77 onSuccess (BS.concat chunks)
80addDefaultHeaders :: [Header] -> [Header]
81addDefaultHeaders headers =
82 (hUserAgent, userAgent) : (hAcceptEncoding, "gzip") : headers
85{-# NOINLINE userAgent #-}
86userAgent :: BS.ByteString
87userAgent =
88 BS.pack ("elm/" ++ V.toChars V.compiler)
91accept :: BS.ByteString -> Header
92accept mime =
93 (hAccept, mime)
97-- EXCEPTIONS
100data Error
101 = BadUrl String String
102 | BadHttp String HttpExceptionContent
103 | BadMystery String SomeException
106handleHttpException :: String -> (Error -> e) -> HttpException -> IO (Either e a)
107handleHttpException url onError httpException =
108 case httpException of
109 InvalidUrlException _ reason ->
110 return (Left (onError (BadUrl url reason)))
112 HttpExceptionRequest _ content ->
113 return (Left (onError (BadHttp url content)))
116handleSomeException :: String -> (Error -> e) -> SomeException -> IO (Either e a)
117handleSomeException url onError exception =
118 return (Left (onError (BadMystery url exception)))
122-- SHA
125type Sha = SHA.Digest SHA.SHA1State
128shaToChars :: Sha -> String
129shaToChars =
130 SHA.showDigest
134-- FETCH ARCHIVE
137fetchArchive
138 :: Manager
139 -> String
140 -> (Error -> e)
141 -> e
142 -> ((Sha, Zip.Archive) -> IO (Either e a))
143 -> IO (Either e a)
144fetchArchive 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
160readArchive :: BodyReader -> IO (Maybe (Sha, Zip.Archive))
161readArchive body =
162 readArchiveHelp body $
163 AS 0 SHA.sha1Incremental (Binary.runGetIncremental Binary.get)
166data ArchiveState =
167 AS
168 { _len :: !Int
169 , _sha :: !(Binary.Decoder SHA.SHA1State)
170 , _zip :: !(Binary.Decoder Zip.Archive)
171 }
174readArchiveHelp :: BodyReader -> ArchiveState -> IO (Maybe (Sha, Zip.Archive))
175readArchiveHelp body (AS len sha zip) =
176 case zip of
177 Binary.Fail _ _ _ ->
178 return Nothing
180 Binary.Partial k ->
181 do chunk <- brRead body
182 readArchiveHelp body $
183 AS
184 { _len = len + BS.length chunk
185 , _sha = Binary.pushChunk sha chunk
186 , _zip = k (if BS.null chunk then Nothing else Just chunk)
187 }
189 Binary.Done _ _ archive ->
190 return $ Just ( SHA.completeSha1Incremental sha len, archive )
194-- UPLOAD
197upload :: Manager -> String -> [Multi.Part] -> IO (Either Error ())
198upload 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 ())
213filePart :: String -> FilePath -> Multi.Part
214filePart name filePath =
215 Multi.partFileSource (String.fromString name) filePath
218stringPart :: String -> String -> Multi.Part
219stringPart name string =
220 Multi.partBS (String.fromString name) (BS.pack string)