git.iko.soy/elk
on d88abc7 help sign in
elk/builder/src/Reporting/Task/Http.hs
195 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.Compiler as Compiler
27import qualified Elm.Package as Pkg
28import qualified Reporting.Exit as Exit
29import qualified Reporting.Exit.Http as E
30import qualified Reporting.Progress as Progress
31import qualified Reporting.Task as Task
35-- FETCH
38data Fetch a where
39 Package :: String -> [(String,String)] -> Handler a -> Fetch a
40 Anything :: String -> Handler a -> Fetch a
41 AndThen :: Fetch a -> (a -> Fetch b) -> Fetch b
42 Parallel :: [Fetch a] -> Fetch [a]
43 Report :: Progress.Progress -> (Progress.Outcome -> Progress.Progress) -> Fetch a -> Fetch a
46type Handler a =
47 Http.Request -> Http.Manager -> IO (Either E.Exit a)
50package :: String -> [(String,String)] -> Handler a -> Fetch a
51package =
52 Package
55anything :: String -> Handler a -> Fetch a
56anything =
57 Anything
60andThen :: Fetch a -> (a -> Fetch b) -> Fetch b
61andThen =
62 AndThen
65parallel :: [Fetch a] -> Fetch [a]
66parallel =
67 Parallel
70report :: Progress.Progress -> (Progress.Outcome -> Progress.Progress) -> Fetch a -> Fetch a
71report =
72 Report
76-- RUN
79run :: Fetch a -> Task.Task a
80run fetch =
81 Task.runHttp $ \manager tell ->
82 do chan <- newChan
83 replicateM_ 4 $ forkIO $ forever $ join (readChan chan)
84 readMVar =<< runHelp chan manager tell fetch
87runHelp :: Chan (IO ()) -> Http.Manager -> (Progress.Progress -> IO ()) -> Fetch a -> IO (MVar (Either Exit.Exit a))
88runHelp chan manager tell fetch =
89 case fetch of
90 Package path params handler ->
91 do mvar <- newEmptyMVar
92 let url = makePackageUrl path params
93 writeChan chan $ putMVar mvar =<< fetchSafe url manager handler
94 return mvar
96 Anything url handler ->
97 do mvar <- newEmptyMVar
98 writeChan chan $ putMVar mvar =<< fetchSafe url manager handler
99 return mvar
101 AndThen subFetch callback ->
102 do subMVar <- runHelp chan manager tell subFetch
103 mvar <- newEmptyMVar
104 void $ forkIO $
105 do result <- readMVar subMVar
106 putMVar mvar =<<
107 case result of
108 Left err ->
109 return (Left err)
110 Right value ->
111 readMVar =<< runHelp chan manager tell (callback value)
112 return mvar
114 Parallel fetches ->
115 do mvars <- mapM (runHelp chan manager tell) fetches
116 mvar <- newEmptyMVar
117 void $ forkIO $
118 do results <- mapM readMVar mvars
119 putMVar mvar (sequence results)
120 return mvar
122 Report start toEnd subFetch ->
123 do tell start
124 subMVar <- runHelp chan manager tell subFetch
125 mvar <- newEmptyMVar
126 void $ forkIO $
127 do result <- readMVar subMVar
128 tell $ toEnd $
129 either (\_ -> Progress.Bad) (\_ -> Progress.Good) result
130 putMVar mvar result
131 return mvar
135-- PACKAGE URLS
138packageDomain :: String
139packageDomain =
140 "https://alpha.elm-lang.org"
143makePackageUrl :: String -> [(String,String)] -> String
144makePackageUrl path params =
145 let
146 query =
147 if null params then
148 ""
149 else
150 "?" ++ Http.urlEncodeVars params
151 in
152 packageDomain ++ "/" ++ path ++ query
156-- HTTP HELP
159fetchSafe :: String -> Http.Manager -> Handler a -> IO (Either Exit.Exit a)
160fetchSafe url manager handler =
161 fetchUnsafe url manager handler
162 `catch` \e -> handleAnyError url (e :: SomeException)
165fetchUnsafe :: String -> Http.Manager -> Handler a -> IO (Either Exit.Exit a)
166fetchUnsafe url manager handler =
167 do request <- Http.parseUrlThrow url
168 result <- handler (addHeaders request) manager
169 case result of
170 Right value ->
171 return (Right value)
173 Left problem ->
174 return (Left (Exit.BadHttp url problem))
177handleAnyError :: (Exception e) => String -> e -> IO (Either Exit.Exit a)
178handleAnyError url exception =
179 return $ Left $ Exit.BadHttp url $ E.Unknown $ show exception
182addHeaders :: Http.Request -> Http.Request
183addHeaders request =
184 request
185 { Http.requestHeaders =
186 [ (Http.hUserAgent, userAgent)
187 , (Http.hAcceptEncoding, "gzip")
188 ]
189 }
192{-# NOINLINE userAgent #-}
193userAgent :: BS.ByteString
194userAgent =
195 BS.pack ("elm/" ++ Pkg.versionToString Compiler.version)