git.iko.soy/elk
on d2dacad help sign in
elk/builder/src/Reporting/Task/Http.hs
184 lines 4.7 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 Network.HTTP as Http (urlEncodeVars)
22import qualified Network.HTTP.Client as Http
24import qualified Elm.Compiler as Compiler
25import qualified Elm.Package as Pkg
26import qualified Reporting.Exit as Exit
27import qualified Reporting.Exit.Http as E
28import qualified Reporting.Progress as Progress
29import qualified Reporting.Task as Task
33-- FETCH
36data Fetch a where
37 Package :: String -> [(String,String)] -> Handler a -> Fetch a
38 Anything :: String -> Handler a -> Fetch a
39 AndThen :: Fetch a -> (a -> Fetch b) -> Fetch b
40 Parallel :: [Fetch a] -> Fetch [a]
41 Report :: Progress.Progress -> (Progress.Outcome -> Progress.Progress) -> Fetch a -> Fetch a
44type Handler a =
45 Http.Request -> Http.Manager -> IO (Either E.Exit a)
48package :: String -> [(String,String)] -> Handler a -> Fetch a
49package =
50 Package
53anything :: String -> Handler a -> Fetch a
54anything =
55 Anything
58andThen :: Fetch a -> (a -> Fetch b) -> Fetch b
59andThen =
60 AndThen
63parallel :: [Fetch a] -> Fetch [a]
64parallel =
65 Parallel
68report :: Progress.Progress -> (Progress.Outcome -> Progress.Progress) -> Fetch a -> Fetch a
69report =
70 Report
74-- RUN
77run :: Fetch a -> Task.Task a
78run fetch =
79 Task.runHttp $ \manager tell ->
80 do chan <- newChan
81 replicateM_ 4 $ forkIO $ forever $ join (readChan chan)
82 readMVar =<< runHelp chan manager tell fetch
85runHelp :: Chan (IO ()) -> Http.Manager -> (Progress.Progress -> IO ()) -> Fetch a -> IO (MVar (Either Exit.Exit a))
86runHelp chan manager tell fetch =
87 case fetch of
88 Package path params handler ->
89 do mvar <- newEmptyMVar
90 let url = makePackageUrl path params
91 writeChan chan $ putMVar mvar =<< fetchSafe url manager handler
92 return mvar
94 Anything url handler ->
95 do mvar <- newEmptyMVar
96 writeChan chan $ putMVar mvar =<< fetchSafe url manager handler
97 return mvar
99 AndThen subFetch callback ->
100 do subMVar <- runHelp chan manager tell subFetch
101 mvar <- newEmptyMVar
102 void $ forkIO $
103 do result <- readMVar subMVar
104 putMVar mvar =<<
105 case result of
106 Left err ->
107 return (Left err)
108 Right value ->
109 readMVar =<< runHelp chan manager tell (callback value)
110 return mvar
112 Parallel fetches ->
113 do mvars <- mapM (runHelp chan manager tell) fetches
114 mvar <- newEmptyMVar
115 void $ forkIO $
116 do results <- mapM readMVar mvars
117 putMVar mvar (sequence results)
118 return mvar
120 Report start toEnd subFetch ->
121 do tell start
122 subMVar <- runHelp chan manager tell subFetch
123 mvar <- newEmptyMVar
124 void $ forkIO $
125 do result <- readMVar subMVar
126 tell $ toEnd $
127 either (\_ -> Progress.Bad) (\_ -> Progress.Good) result
128 putMVar mvar result
129 return mvar
133-- PACKAGE URLS
136packageDomain :: String
137packageDomain =
138 "http://159.89.227.162:8000"
141makePackageUrl :: String -> [(String,String)] -> String
142makePackageUrl path params =
143 let
144 query =
145 if null params then
146 ""
147 else
148 "?" ++ Http.urlEncodeVars (versionParam : params)
149 in
150 packageDomain ++ "/" ++ path ++ query
153versionParam :: (String, String)
154versionParam =
155 ( "elm-package-version"
156 , Pkg.versionToString Compiler.version
157 )
161-- HTTP HELP
164fetchSafe :: String -> Http.Manager -> Handler a -> IO (Either Exit.Exit a)
165fetchSafe url manager handler =
166 fetchUnsafe url manager handler
167 `catch` \e -> handleAnyError url (e :: SomeException)
170fetchUnsafe :: String -> Http.Manager -> Handler a -> IO (Either Exit.Exit a)
171fetchUnsafe url manager handler =
172 do request <- Http.parseUrlThrow url
173 result <- handler request manager
174 case result of
175 Right value ->
176 return (Right value)
178 Left problem ->
179 return (Left (Exit.BadHttp url problem))
182handleAnyError :: (Exception e) => String -> e -> IO (Either Exit.Exit a)
183handleAnyError url exception =
184 return $ Left $ Exit.BadHttp url $ E.Unknown $ show exception