git.iko.soy/elk
on 50f8def help sign in
elk/builder/src/Http.hs
273 lines 5.8 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module 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
26import Prelude hiding (zip)
27import qualified Codec.Archive.Zip as Zip
28import Control.Exception (SomeException, handle)
29import qualified Data.Binary as Binary
30import qualified Data.Binary.Get as Binary
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 (methodPost)
39import qualified Network.HTTP.Client.MultipartFormData as Multi
40import qualified System.Directory as Dir
42import qualified Elm.Version as V
46-- MANAGER
49getManager :: IO Manager
50getManager =
51 newManager tlsManagerSettings
55-- URL
58toUrl :: String -> [(String,String)] -> String
59toUrl url params =
60 case params of
61 [] -> url
62 _:_ -> url ++ "?" ++ urlEncodeVars params
66-- POST
69post
70 :: Manager
71 -> String
72 -> [Header]
73 -> (Error -> e)
74 -> (BS.ByteString -> IO (Either e a))
75 -> IO (Either e a)
76post 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)
90post'
91 :: Manager
92 -> String
93 -> [Header]
94 -> Timeout
95 -> Body
96 -> (Error -> e)
97 -> (BodyReader -> IO (Either e a))
98 -> IO (Either e a)
99post' 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)
114-- HEADERS
117addDefaultHeaders :: [Header] -> [Header]
118addDefaultHeaders headers =
119 (hUserAgent, userAgent) : (hAcceptEncoding, "gzip") : headers
122{-# NOINLINE userAgent #-}
123userAgent :: BS.ByteString
124userAgent =
125 BS.pack ("elm/" ++ V.toChars V.compiler)
128accept :: BS.ByteString -> Header
129accept mime =
130 (hAccept, mime)
134-- TIMEOUT
137data Timeout
138 = DefaultTimeout
139 | NeverTimeout
142addTimeout :: Timeout -> Request -> Request
143addTimeout timeout req =
144 case timeout of
145 DefaultTimeout ->
146 req
148 NeverTimeout ->
149 req { responseTimeout = responseTimeoutNone }
153-- BODY
156data Body
157 = NoBody
158 | FormDataBody [Multi.Part]
161addBody :: Body -> Request -> IO Request
162addBody body req =
163 case body of
164 NoBody ->
165 return req
167 FormDataBody parts ->
168 Multi.formDataBody parts req
171filePart :: String -> FilePath -> Multi.Part
172filePart name filePath =
173 Multi.partFileSource (String.fromString name) filePath
176stringPart :: String -> String -> Multi.Part
177stringPart name string =
178 Multi.partBS (String.fromString name) (BS.pack string)
182-- EXCEPTIONS
185data Error
186 = BadUrl String String
187 | BadHttp String HttpExceptionContent
188 | BadMystery String SomeException
191handleHttpException :: String -> (Error -> e) -> HttpException -> IO (Either e a)
192handleHttpException url onError httpException =
193 case httpException of
194 InvalidUrlException _ reason ->
195 return (Left (onError (BadUrl url reason)))
197 HttpExceptionRequest _ content ->
198 return (Left (onError (BadHttp url content)))
201handleSomeException :: String -> (Error -> e) -> SomeException -> IO (Either e a)
202handleSomeException url onError exception =
203 return (Left (onError (BadMystery url exception)))
207-- BODY READERS
210readByteString :: BodyReader -> IO BS.ByteString
211readByteString bodyReader =
212 BS.concat <$> brConsume bodyReader
215type Sha = SHA.Digest SHA.SHA1State
218shaToChars :: Sha -> String
219shaToChars =
220 SHA.showDigest
223readArchive :: BodyReader -> IO (Maybe (Sha, Zip.Archive))
224readArchive body =
225 readArchiveHelp body $
226 AS 0 SHA.sha1Incremental (Binary.runGetIncremental Binary.get)
229data ArchiveState =
230 AS
231 { _len :: !Int
232 , _sha :: !(Binary.Decoder SHA.SHA1State)
233 , _zip :: !(Binary.Decoder Zip.Archive)
234 }
237readArchiveHelp :: BodyReader -> ArchiveState -> IO (Maybe (Sha, Zip.Archive))
238readArchiveHelp body (AS len sha zip) =
239 case zip of
240 Binary.Fail _ _ _ ->
241 return Nothing
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 }
252 Binary.Done _ _ archive ->
253 return $ Just ( SHA.completeSha1Incremental sha len, archive )
257-- WRITE ARCHIVE
260writeArchive :: Zip.Archive -> FilePath -> FilePath -> IO ()
261writeArchive 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)
267replaceRoot :: String -> Zip.Entry -> Zip.Entry
268replaceRoot root entry =
269 let
270 rootless =
271 dropWhile (/='/') (Zip.eRelativePath entry)
272 in
273 entry { Zip.eRelativePath = root ++ rootless }