git.iko.soy/elk
on 9a72bcc help sign in
elk/builder/src/Reporting/Task.hs
191 lines 4.1 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Task
4 ( Task, Task_, run, throw, mapError
5 , Env
6 , getPackageCacheDir
7 , getPackageCacheDirFor
8 , report
9 , getReporter
10 , withApproval
11 , getApproval
12 , silently
13 , getSilentRunner
14 , workerChan
15 , runHttp
16 )
17 where
19import Control.Concurrent (forkIO)
20import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
21import Control.Monad (forever, join, replicateM_)
22import Control.Monad.Except (ExceptT, runExceptT, throwError, withExceptT)
23import Control.Monad.Reader (ReaderT, runReaderT, ask, asks)
24import Control.Monad.Trans (liftIO)
25import qualified Network.HTTP.Client as Http
26import qualified Network.HTTP.Client.TLS as Http
27import System.Directory (createDirectoryIfMissing)
28import System.FilePath ((</>))
29import qualified System.IO as IO
31import Elm.Package (Name, Version)
32import qualified Elm.Package as Pkg
33import qualified Elm.PerUserCache as PerUserCache
34import qualified Reporting.Error as Error
35import qualified Reporting.Progress as Progress
39-- TASKS
42type Task =
43 Task_ Error.Error
46type Task_ e =
47 ExceptT e (ReaderT Env IO)
50data Env =
51 Env
52 { _cacheDir :: FilePath
53 , _worker :: IO () -> IO ()
54 , _httpManager :: Http.Manager
55 , _tell :: Progress.Progress -> IO ()
56 }
59run :: Progress.Reporter -> Task a -> IO (Maybe a)
60run (Progress.Reporter tell end) task =
61 do root <- PerUserCache.getPackageRoot
62 pool <- initPool 4
63 httpManager <- Http.newManager Http.tlsManagerSettings
64 let env = Env root pool httpManager tell
65 result <- runReaderT (runExceptT task) env
66 case result of
67 Left err ->
68 do end (Just err)
69 return Nothing
71 Right answer ->
72 do end Nothing
73 return (Just answer)
76throw :: e -> Task_ e a
77throw =
78 throwError
81mapError :: (x -> y) -> Task_ x a -> Task_ y a
82mapError =
83 withExceptT
87-- CACHING
90getPackageCacheDir :: Task_ e FilePath
91getPackageCacheDir =
92 asks _cacheDir
95getPackageCacheDirFor :: Name -> Version -> Task_ e FilePath
96getPackageCacheDirFor name version =
97 do cacheDir <- getPackageCacheDir
98 let dir = cacheDir </> Pkg.toFilePath name </> Pkg.versionToString version
99 liftIO (createDirectoryIfMissing True dir)
100 return dir
104-- REPORTER
107report :: Progress.Progress -> Task_ e ()
108report progress =
109 do tell <- asks _tell
110 liftIO (tell progress)
113getReporter :: Task (Progress.Progress -> IO ())
114getReporter =
115 asks _tell
119-- APPROVAL
122withApproval :: Task_ e () -> Task_ e ()
123withApproval task =
124 do approval <- getApproval
125 if approval then task else return ()
128getApproval :: Task_ e Bool
129getApproval =
130 do liftIO $ IO.hFlush IO.stdout
131 input <- liftIO getLine
132 case input of
133 "" -> return True
134 "Y" -> return True
135 "y" -> return True
136 "n" -> return False
137 _ ->
138 do liftIO $ putStr "Must type 'y' for yes or 'n' for no: "
139 getApproval
143-- RUNNER
146silently :: Task_ e a -> Task_ e a
147silently task =
148 do runner <- getSilentRunner
149 result <- liftIO (runner task)
150 either throw return result
153getSilentRunner :: Task_ x (Task_ e a -> IO (Either e a))
154getSilentRunner =
155 do env <- ask
156 let silentEnv = env { _tell = \_ -> return () }
157 return $ \task -> runReaderT (runExceptT task) silentEnv
161-- THREAD POOL
164workerChan :: Chan (Either e a) -> Task_ e a -> Task_ x ()
165workerChan chan task =
166 do env <- ask
168 liftIO $ _worker env $
169 do result <- runReaderT (runExceptT task) env
170 writeChan chan result
173initPool :: Int -> IO (IO () -> IO ())
174initPool size =
175 do chan <- newChan
177 replicateM_ size $ forkIO $ forever $
178 join (readChan chan)
180 return $ writeChan chan
184-- HTTP
187runHttp :: (Http.Manager -> (Progress.Progress -> IO ()) -> IO (Either Error.Error a)) -> Task a
188runHttp fetcher =
189 do (Env _ _ manager tell) <- ask
190 result <- liftIO $ fetcher manager tell
191 either throwError return result