git.iko.soy/elk
on 2fb73b7 help sign in
elk/builder/src/Reporting/Task.hs
189 lines 3.9 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 , getApproval
14 , silently
15 , getSilentRunner
16 , workerChan
17 , runHttp
18 )
19 where
21import Control.Concurrent (forkIO)
22import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
23import Control.Monad (forever, join, replicateM_)
24import Control.Monad.Except (ExceptT, runExceptT, throwError, withExceptT)
25import qualified Control.Monad.Reader as R
26import Control.Monad.Trans (liftIO)
27import qualified Network.HTTP.Client as Http
28import qualified Network.HTTP.Client.TLS as Http
29import qualified System.Directory as Dir
30import qualified System.Exit as Exit
31import System.FilePath ((</>))
33import Elm.Package (Name, Version)
34import qualified Elm.Package as Pkg
35import qualified Elm.PerUserCache as PerUserCache
36import qualified Reporting.Doc as D
37import qualified Reporting.Exit as Exit
38import qualified Reporting.Progress as Progress
42-- TASKS
45type Task =
46 Task_ Exit.Exit
49type Task_ e =
50 ExceptT e (R.ReaderT Env IO)
53data Env =
54 Env
55 { _cacheDir :: FilePath
56 , _worker :: IO () -> IO ()
57 , _httpManager :: Http.Manager
58 , _tell :: Progress.Progress -> IO ()
59 , _ask :: D.Doc -> IO Bool
60 }
63try :: Progress.Reporter -> Task a -> IO (Maybe a)
64try (Progress.Reporter tell ask 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 ask
69 result <- R.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 R.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 <- R.asks _tell
122 liftIO (tell progress)
125getReporter :: Task (Progress.Progress -> IO ())
126getReporter =
127 R.asks _tell
131-- APPROVAL
134getApproval :: D.Doc -> Task_ e Bool
135getApproval doc =
136 do ask <- R.asks _ask
137 liftIO (ask doc)
141-- RUNNER
144silently :: Task_ e a -> Task_ e a
145silently task =
146 do runner <- getSilentRunner
147 result <- liftIO (runner task)
148 either throw return result
151getSilentRunner :: Task_ x (Task_ e a -> IO (Either e a))
152getSilentRunner =
153 do env <- R.ask
154 let silentEnv = env { _tell = \_ -> return () }
155 return $ \task -> R.runReaderT (runExceptT task) silentEnv
159-- THREAD POOL
162workerChan :: Chan (Either e a) -> Task_ e a -> Task_ x ()
163workerChan chan task =
164 do env <- R.ask
166 liftIO $ _worker env $
167 do result <- R.runReaderT (runExceptT task) env
168 writeChan chan result
171initPool :: Int -> IO (IO () -> IO ())
172initPool size =
173 do chan <- newChan
175 replicateM_ size $ forkIO $ forever $
176 join (readChan chan)
178 return $ writeChan chan
182-- HTTP
185runHttp :: (Http.Manager -> (Progress.Progress -> IO ()) -> IO (Either Exit.Exit a)) -> Task a
186runHttp fetcher =
187 do (Env _ _ manager tell _) <- R.ask
188 result <- liftIO $ fetcher manager tell
189 either throwError return result