git.iko.soy/elk
on ccbc53c help sign in
elk/builder/src/Reporting/Task/Http.hs
202 lines 5.2 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 "http://159.89.227.162:8000"
143makePackageUrl :: String -> [(String,String)] -> String
144makePackageUrl path params =
145 let
146 query =
147 if null params then
148 ""
149 else
150 "?" ++ Http.urlEncodeVars (versionParam : params)
151 in
152 packageDomain ++ "/" ++ path ++ query
155versionParam :: (String, String)
156versionParam =
157 ( "elm-package-version"
158 , Pkg.versionToString Compiler.version
159 )
163-- HTTP HELP
166fetchSafe :: String -> Http.Manager -> Handler a -> IO (Either Exit.Exit a)
167fetchSafe url manager handler =
168 fetchUnsafe url manager handler
169 `catch` \e -> handleAnyError url (e :: SomeException)
172fetchUnsafe :: String -> Http.Manager -> Handler a -> IO (Either Exit.Exit a)
173fetchUnsafe url manager handler =
174 do request <- Http.parseUrlThrow url
175 result <- handler (addHeaders request) manager
176 case result of
177 Right value ->
178 return (Right value)
180 Left problem ->
181 return (Left (Exit.BadHttp url problem))
184handleAnyError :: (Exception e) => String -> e -> IO (Either Exit.Exit a)
185handleAnyError url exception =
186 return $ Left $ Exit.BadHttp url $ E.Unknown $ show exception
189addHeaders :: Http.Request -> Http.Request
190addHeaders request =
191 request
192 { Http.requestHeaders =
193 [ (Http.hUserAgent, userAgent)
194 , (Http.hAcceptEncoding, "gzip")
195 ]
196 }
199{-# NOINLINE userAgent #-}
200userAgent :: BS.ByteString
201userAgent =
202 BS.pack ("elm/" ++ Pkg.versionToString Compiler.version)