git.iko.soy/elk
on 1c3cda7 help sign in
elk/builder/src/Reporting/Task/Http.hs
185 lines 4.7 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE OverloadedStrings #-}
4module Reporting.Task.Http
5 ( Fetch
6 , Handler
7 , run
8 , package
9 , anything
10 , andThen
11 , parallel
12 , report
13 )
14 where
17import Control.Concurrent (forkIO)
18import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
19import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)
20import Control.Exception (Exception, SomeException, catch)
21import Control.Monad (forever, join, replicateM_, void)
22import qualified Network.HTTP as Http (urlEncodeVars)
23import qualified Network.HTTP.Client as Http
25import qualified Elm.Compiler as Compiler
26import qualified Elm.Package as Pkg
27import qualified Reporting.Error as Error
28import qualified Reporting.Error.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.Error 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 Error.Error 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 "http://localhost:8000"
142makePackageUrl :: String -> [(String,String)] -> String
143makePackageUrl path params =
144 let
145 query =
146 if null params then
147 ""
148 else
149 "?" ++ Http.urlEncodeVars (versionParam : params)
150 in
151 packageDomain ++ "/" ++ path ++ query
154versionParam :: (String, String)
155versionParam =
156 ( "elm-package-version"
157 , Pkg.versionToString Compiler.version
158 )
162-- HTTP HELP
165fetchSafe :: String -> Http.Manager -> Handler a -> IO (Either Error.Error a)
166fetchSafe url manager handler =
167 fetchUnsafe url manager handler
168 `catch` \e -> handleAnyError url (e :: SomeException)
171fetchUnsafe :: String -> Http.Manager -> Handler a -> IO (Either Error.Error a)
172fetchUnsafe url manager handler =
173 do request <- Http.parseUrlThrow url
174 result <- handler request manager
175 case result of
176 Right value ->
177 return (Right value)
179 Left problem ->
180 return (Left (Error.BadHttp url problem))
183handleAnyError :: (Exception e) => String -> e -> IO (Either Error.Error a)
184handleAnyError url exception =
185 return $ Left $ Error.BadHttp url $ E.Unknown $ show exception