git.iko.soy/elk
on b1fd35f help sign in
elk/builder/src/Reporting/Task.hs
190 lines 4.0 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Reporting.Task
3 ( Task, Task_, run, throw, mapError
4 , Env
5 , getPackageCacheDir
6 , getPackageCacheDirFor
7 , report
8 , getReporter
9 , withApproval
10 , getApproval
11 , silently
12 , getSilentRunner
13 , workerChan
14 , runHttp
15 )
16 where
18import Control.Concurrent (forkIO)
19import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
20import Control.Monad (forever, join, replicateM_)
21import Control.Monad.Except (ExceptT, runExceptT, throwError, withExceptT)
22import Control.Monad.Reader (ReaderT, runReaderT, ask, asks)
23import Control.Monad.Trans (liftIO)
24import qualified Network.HTTP.Client as Http
25import qualified Network.HTTP.Client.TLS as Http
26import System.Directory (createDirectoryIfMissing)
27import System.FilePath ((</>))
28import qualified System.IO as IO
30import Elm.Package (Name, Version)
31import qualified Elm.Package as Pkg
32import qualified Elm.PerUserCache as PerUserCache
33import qualified Reporting.Exit as Exit
34import qualified Reporting.Progress as Progress
38-- TASKS
41type Task =
42 Task_ Exit.Exit
45type Task_ e =
46 ExceptT e (ReaderT Env IO)
49data Env =
50 Env
51 { _cacheDir :: FilePath
52 , _worker :: IO () -> IO ()
53 , _httpManager :: Http.Manager
54 , _tell :: Progress.Progress -> IO ()
55 }
58run :: Progress.Reporter -> Task a -> IO (Maybe a)
59run (Progress.Reporter tell end) task =
60 do root <- PerUserCache.getPackageRoot
61 pool <- initPool 4
62 httpManager <- Http.newManager Http.tlsManagerSettings
63 let env = Env root pool httpManager tell
64 result <- runReaderT (runExceptT task) env
65 case result of
66 Left err ->
67 do end (Just err)
68 return Nothing
70 Right answer ->
71 do end Nothing
72 return (Just answer)
75throw :: e -> Task_ e a
76throw =
77 throwError
80mapError :: (x -> y) -> Task_ x a -> Task_ y a
81mapError =
82 withExceptT
86-- CACHING
89getPackageCacheDir :: Task_ e FilePath
90getPackageCacheDir =
91 asks _cacheDir
94getPackageCacheDirFor :: Name -> Version -> Task_ e FilePath
95getPackageCacheDirFor name version =
96 do cacheDir <- getPackageCacheDir
97 let dir = cacheDir </> Pkg.toFilePath name </> Pkg.versionToString version
98 liftIO (createDirectoryIfMissing True dir)
99 return dir
103-- REPORTER
106report :: Progress.Progress -> Task_ e ()
107report progress =
108 do tell <- asks _tell
109 liftIO (tell progress)
112getReporter :: Task (Progress.Progress -> IO ())
113getReporter =
114 asks _tell
118-- APPROVAL
121withApproval :: Task_ e () -> Task_ e ()
122withApproval task =
123 do approval <- getApproval
124 if approval then task else return ()
127getApproval :: Task_ e Bool
128getApproval =
129 do liftIO $ IO.hFlush IO.stdout
130 input <- liftIO getLine
131 case input of
132 "" -> return True
133 "Y" -> return True
134 "y" -> return True
135 "n" -> return False
136 _ ->
137 do liftIO $ putStr "Must type 'y' for yes or 'n' for no: "
138 getApproval
142-- RUNNER
145silently :: Task_ e a -> Task_ e a
146silently task =
147 do runner <- getSilentRunner
148 result <- liftIO (runner task)
149 either throw return result
152getSilentRunner :: Task_ x (Task_ e a -> IO (Either e a))
153getSilentRunner =
154 do env <- ask
155 let silentEnv = env { _tell = \_ -> return () }
156 return $ \task -> runReaderT (runExceptT task) silentEnv
160-- THREAD POOL
163workerChan :: Chan (Either e a) -> Task_ e a -> Task_ x ()
164workerChan chan task =
165 do env <- ask
167 liftIO $ _worker env $
168 do result <- runReaderT (runExceptT task) env
169 writeChan chan result
172initPool :: Int -> IO (IO () -> IO ())
173initPool size =
174 do chan <- newChan
176 replicateM_ size $ forkIO $ forever $
177 join (readChan chan)
179 return $ writeChan chan
183-- HTTP
186runHttp :: (Http.Manager -> (Progress.Progress -> IO ()) -> IO (Either Exit.Exit a)) -> Task a
187runHttp fetcher =
188 do (Env _ _ manager tell) <- ask
189 result <- liftIO $ fetcher manager tell
190 either throwError return result