git.iko.soy/elk
on 0c3601e help sign in
elk/builder/src/Reporting/Task.hs
203 lines 4.3 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2module Reporting.Task
3 ( Task, Task_
4 , try
5 , run
6 , throw
7 , mapError
8 , Env
9 , getPackageCacheDir
10 , getPackageCacheDirFor
11 , report
12 , getReporter
13 , withApproval
14 , getApproval
15 , silently
16 , getSilentRunner
17 , workerChan
18 , runHttp
19 )
20 where
22import Control.Concurrent (forkIO)
23import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
24import Control.Monad (forever, join, replicateM_)
25import Control.Monad.Except (ExceptT, runExceptT, throwError, withExceptT)
26import Control.Monad.Reader (ReaderT, runReaderT, ask, asks)
27import Control.Monad.Trans (liftIO)
28import qualified Network.HTTP.Client as Http
29import qualified Network.HTTP.Client.TLS as Http
30import qualified System.Directory as Dir
31import qualified System.Exit as Exit
32import System.FilePath ((</>))
33import qualified System.IO as IO
35import Elm.Package (Name, Version)
36import qualified Elm.Package as Pkg
37import qualified Elm.PerUserCache as PerUserCache
38import qualified Reporting.Exit as Exit
39import qualified Reporting.Progress as Progress
43-- TASKS
46type Task =
47 Task_ Exit.Exit
50type Task_ e =
51 ExceptT e (ReaderT Env IO)
54data Env =
55 Env
56 { _cacheDir :: FilePath
57 , _worker :: IO () -> IO ()
58 , _httpManager :: Http.Manager
59 , _tell :: Progress.Progress -> IO ()
60 }
63try :: Progress.Reporter -> Task a -> IO (Maybe a)
64try (Progress.Reporter tell end) task =
65 do root <- PerUserCache.getPackageRoot
66 pool <- initPool 4
67 httpManager <- Http.newManager Http.tlsManagerSettings
68 let env = Env root pool httpManager tell
69 result <- runReaderT (runExceptT task) env
70 case result of
71 Left err ->
72 do end (Just err)
73 return Nothing
75 Right answer ->
76 do end Nothing
77 return (Just answer)
80run :: Progress.Reporter -> Task a -> IO ()
81run reporter task =
82 do maybeAnswer <- try reporter task
83 case maybeAnswer of
84 Nothing -> Exit.exitFailure
85 Just _ -> return ()
88throw :: e -> Task_ e a
89throw =
90 throwError
93mapError :: (x -> y) -> Task_ x a -> Task_ y a
94mapError =
95 withExceptT
99-- CACHING
102getPackageCacheDir :: Task_ e FilePath
103getPackageCacheDir =
104 asks _cacheDir
107getPackageCacheDirFor :: Name -> Version -> Task_ e FilePath
108getPackageCacheDirFor name version =
109 do cacheDir <- getPackageCacheDir
110 let dir = cacheDir </> Pkg.toFilePath name </> Pkg.versionToString version
111 liftIO (Dir.createDirectoryIfMissing True dir)
112 return dir
116-- REPORTER
119report :: Progress.Progress -> Task_ e ()
120report progress =
121 do tell <- asks _tell
122 liftIO (tell progress)
125getReporter :: Task (Progress.Progress -> IO ())
126getReporter =
127 asks _tell
131-- APPROVAL
134withApproval :: Task_ e () -> Task_ e ()
135withApproval task =
136 do approval <- getApproval
137 if approval then task else return ()
140getApproval :: Task_ e Bool
141getApproval =
142 do liftIO $ IO.hFlush IO.stdout
143 input <- liftIO getLine
144 case input of
145 "" -> return True
146 "Y" -> return True
147 "y" -> return True
148 "n" -> return False
149 _ ->
150 do liftIO $ putStr "Must type 'y' for yes or 'n' for no: "
151 getApproval
155-- RUNNER
158silently :: Task_ e a -> Task_ e a
159silently task =
160 do runner <- getSilentRunner
161 result <- liftIO (runner task)
162 either throw return result
165getSilentRunner :: Task_ x (Task_ e a -> IO (Either e a))
166getSilentRunner =
167 do env <- ask
168 let silentEnv = env { _tell = \_ -> return () }
169 return $ \task -> runReaderT (runExceptT task) silentEnv
173-- THREAD POOL
176workerChan :: Chan (Either e a) -> Task_ e a -> Task_ x ()
177workerChan chan task =
178 do env <- ask
180 liftIO $ _worker env $
181 do result <- runReaderT (runExceptT task) env
182 writeChan chan result
185initPool :: Int -> IO (IO () -> IO ())
186initPool size =
187 do chan <- newChan
189 replicateM_ size $ forkIO $ forever $
190 join (readChan chan)
192 return $ writeChan chan
196-- HTTP
199runHttp :: (Http.Manager -> (Progress.Progress -> IO ()) -> IO (Either Exit.Exit a)) -> Task a
200runHttp fetcher =
201 do (Env _ _ manager tell) <- ask
202 result <- liftIO $ fetcher manager tell
203 either throwError return result