git.iko.soy/elk
on e7ca69f help sign in
elk/builder/src/Reporting/Task/Http.hs
194 lines 5.0 kB history raw
1{-# LANGUAGE GADTs #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Task.Http
4 ( Fetch
5 , Handler
6 , run
7 , package
8 , anything
9 , andThen
10 , parallel
11 , report
12 )
13 where
16import Control.Concurrent (forkIO)
17import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
18import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)
19import Control.Exception (Exception, SomeException, catch)
20import Control.Monad (forever, join, replicateM_, void)
21import qualified Data.ByteString.Char8 as BS
22import qualified Network.HTTP as Http (urlEncodeVars)
23import qualified Network.HTTP.Client as Http
24import qualified Network.HTTP.Types.Header as Http (hAcceptEncoding, hUserAgent)
26import qualified Elm.Version as V
27import qualified Reporting.Exit as Exit
28import qualified Reporting.Exit.Http as E
29import qualified Reporting.Progress as Progress
30import qualified Reporting.Task as Task
34-- FETCH
37data 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
45type Handler a =
46 Http.Request -> Http.Manager -> IO (Either E.Exit a)
49package :: String -> [(String,String)] -> Handler a -> Fetch a
50package =
51 Package
54anything :: String -> Handler a -> Fetch a
55anything =
56 Anything
59andThen :: Fetch a -> (a -> Fetch b) -> Fetch b
60andThen =
61 AndThen
64parallel :: [Fetch a] -> Fetch [a]
65parallel =
66 Parallel
69report :: Progress.Progress -> (Progress.Outcome -> Progress.Progress) -> Fetch a -> Fetch a
70report =
71 Report
75-- RUN
78run :: Fetch a -> Task.Task a
79run 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
86runHelp :: Chan (IO ()) -> Http.Manager -> (Progress.Progress -> IO ()) -> Fetch a -> IO (MVar (Either Exit.Exit a))
87runHelp 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
95 Anything url handler ->
96 do mvar <- newEmptyMVar
97 writeChan chan $ putMVar mvar =<< fetchSafe url manager handler
98 return mvar
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
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
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
134-- PACKAGE URLS
137packageDomain :: String
138packageDomain =
139 "https://package.elm-lang.org"
142makePackageUrl :: String -> [(String,String)] -> String
143makePackageUrl path params =
144 let
145 query =
146 if null params then
147 ""
148 else
149 "?" ++ Http.urlEncodeVars params
150 in
151 packageDomain ++ "/" ++ path ++ query
155-- HTTP HELP
158fetchSafe :: String -> Http.Manager -> Handler a -> IO (Either Exit.Exit a)
159fetchSafe url manager handler =
160 fetchUnsafe url manager handler
161 `catch` \e -> handleAnyError url (e :: SomeException)
164fetchUnsafe :: String -> Http.Manager -> Handler a -> IO (Either Exit.Exit a)
165fetchUnsafe 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)
172 Left problem ->
173 return (Left (Exit.BadHttp url problem))
176handleAnyError :: (Exception e) => String -> e -> IO (Either Exit.Exit a)
177handleAnyError url exception =
178 return $ Left $ Exit.BadHttp url $ E.Unknown $ show exception
181addHeaders :: Http.Request -> Http.Request
182addHeaders request =
183 request
184 { Http.requestHeaders =
185 [ (Http.hUserAgent, userAgent)
186 , (Http.hAcceptEncoding, "gzip")
187 ]
188 }
191{-# NOINLINE userAgent #-}
192userAgent :: BS.ByteString
193userAgent =
194 BS.pack ("elm/" ++ V.toChars V.compiler)