256cc76 · hakyll · git.iko.soy

git.iko.soy/hakyll

on master help sign in

Add pretty, thread-safe logger

256cc76Jasper Van der Jeugt16 years ago

src/Hakyll/Core/Compiler.hs−2

compare with master

unifiedsplit

@@ -253,8 +253,6 @@ cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do

253 identifier <- compilerIdentifier <$> ask

254 store <- compilerStore <$> ask

255 modified <- compilerResourceModified <$> ask

256− liftIO $ putStrLn $

257− show identifier ++ ": " ++ if modified then "MODIFIED" else "OK"

258 if modified

256 if modified

259 then do v <- unCompilerM $ j $ Resource identifier

257 then do v <- unCompilerM $ j $ Resource identifier

260 liftIO $ storeSet store name identifier v

258 liftIO $ storeSet store name identifier v

src/Hakyll/Core/Logger.hsnew file+82

@@ -0,0 +1,82 @@

1+-- | Produce pretty, thread-safe logs

2+--

3+{-# LANGUAGE BangPatterns #-}

4+module Hakyll.Core.Logger

5+ ( Logger

6+ , makeLogger

7+ , flushLogger

8+ , section

9+ , timed

10+ ) where

11+

12+import Control.Monad.Trans (MonadIO, liftIO)

13+import Control.Applicative ((<$>), (<*>))

14+import Control.Concurrent (forkIO)

15+import Control.Concurrent.Chan.Strict (Chan, newChan, readChan, writeChan)

16+import Control.Concurrent.MVar.Strict (MVar, newEmptyMVar, takeMVar, putMVar)

17+import Text.Printf (printf)

18+

19+import Data.Time (getCurrentTime, diffUTCTime)

20+

21+-- | Logger structure. Very complicated.

22+--

23+data Logger = Logger

24+ { loggerChan :: Chan (Maybe String) -- Nothing marks the end

25+ , loggerSync :: MVar () -- Used for sync on quit

26+ }

27+

28+-- | Create a new logger

29+--

30+makeLogger :: IO Logger

31+makeLogger = do

32+ logger <- Logger <$> newChan <*> newEmptyMVar

33+ _ <- forkIO $ loggerThread logger

34+ return logger

35+ where

36+ loggerThread logger = do

37+ msg <- readChan $ loggerChan logger

38+ case msg of

39+ -- Stop: sync

40+ Nothing -> putMVar (loggerSync logger) ()

41+ -- Print and continue

42+ Just m -> do

43+ putStrLn m

44+ loggerThread logger

45+

46+-- | Flush the logger (blocks until flushed)

47+--

48+flushLogger :: Logger -> IO ()

49+flushLogger logger = do

50+ writeChan (loggerChan logger) Nothing

51+ () <- takeMVar $ loggerSync logger

52+ return ()

53+

54+-- | Send a raw message to the logger

55+--

56+message :: Logger -> String -> IO ()

57+message logger = writeChan (loggerChan logger) . Just

58+

59+-- | Start a section in the log

60+--

61+section :: MonadIO m

62+ => Logger -- ^ Logger

63+ -> String -- ^ Section name

64+ -> m () -- ^ No result

65+section logger = liftIO . message logger

66+

67+-- | Execute a monadic action and log the duration

68+--

69+timed :: MonadIO m

70+ => Logger -- ^ Logger

71+ -> String -- ^ Message

72+ -> m a -- ^ Action

73+ -> m a -- ^ Timed and logged action

74+timed logger msg action = do

75+ start <- liftIO getCurrentTime

76+ !result <- action

77+ stop <- liftIO getCurrentTime

78+ let diff = fromEnum $ diffUTCTime stop start

79+ ms = diff `div` 10 ^ (9 :: Int)

80+ formatted = printf " [%4dms] %s" ms msg

81+ liftIO $ message logger formatted

82+ return result

src/Hakyll/Core/Run.hs+47−33

@@ -10,7 +10,7 @@ import Control.Monad (filterM)

10import Control.Monad.Trans (liftIO)

11import Control.Applicative (Applicative, (<$>))

12import Control.Monad.Reader (ReaderT, runReaderT, ask)

13−import Control.Monad.State (StateT, evalStateT, get, modify)

13+import Control.Monad.State.Strict (StateT, evalStateT, get, modify)

14import Control.Arrow ((&&&))

15import qualified Data.Map as M

16import Data.Monoid (mempty, mappend)

@@ -31,25 +31,36 @@ import Hakyll.Core.DirectedGraph.DependencySolver

31import Hakyll.Core.Writable

32import Hakyll.Core.Store

33import Hakyll.Core.Configuration

34+import Hakyll.Core.Logger

35-- | Run all rules needed, return the rule set used

36-- | Run all rules needed, return the rule set used

36--

37--

37run :: HakyllConfiguration -> Rules -> IO RuleSet

38run :: HakyllConfiguration -> Rules -> IO RuleSet

38run configuration rules = do

39run configuration rules = do

40+ logger <- makeLogger

41+

42+ section logger "Initialising"

43+ store <- timed logger "Creating store" $

39− store <- makeStore $ storeDirectory configuration

44+ makeStore $ storeDirectory configuration

45+ provider <- timed logger "Creating provider" $

40− provider <- fileResourceProvider configuration

46+ fileResourceProvider configuration

47+

41 let ruleSet = runRules rules provider

48 let ruleSet = runRules rules provider

42 compilers = rulesCompilers ruleSet

49 compilers = rulesCompilers ruleSet

44 -- Extract the reader/state

51 -- Extract the reader/state

45 reader = unRuntime $ addNewCompilers [] compilers

52 reader = unRuntime $ addNewCompilers [] compilers

46− state' = runReaderT reader $ env ruleSet provider store

53+ state' = runReaderT reader $ env logger ruleSet provider store

48 evalStateT state' state

55 evalStateT state' state

56+

57+ -- Flush and return

58+ flushLogger logger

49 return ruleSet

59 return ruleSet

50 where

60 where

51− env ruleSet provider store = RuntimeEnvironment

61+ env logger ruleSet provider store = RuntimeEnvironment

62+ { hakyllLogger = logger

52− { hakyllConfiguration = configuration

63+ , hakyllConfiguration = configuration

53 , hakyllRoutes = rulesRoutes ruleSet

64 , hakyllRoutes = rulesRoutes ruleSet

54 , hakyllResourceProvider = provider

65 , hakyllResourceProvider = provider

55 , hakyllStore = store

66 , hakyllStore = store

@@ -61,7 +72,8 @@ run configuration rules = do

61 }

72 }

63data RuntimeEnvironment = RuntimeEnvironment

74data RuntimeEnvironment = RuntimeEnvironment

75+ { hakyllLogger :: Logger

64− { hakyllConfiguration :: HakyllConfiguration

76+ , hakyllConfiguration :: HakyllConfiguration

65 , hakyllRoutes :: Routes

77 , hakyllRoutes :: Routes

66 , hakyllResourceProvider :: ResourceProvider

78 , hakyllResourceProvider :: ResourceProvider

67 , hakyllStore :: Store

79 , hakyllStore :: Store

@@ -96,6 +108,8 @@ addNewCompilers :: [(Identifier, Compiler () CompileRule)]

96 -> Runtime ()

108 -> Runtime ()

97addNewCompilers oldCompilers newCompilers = Runtime $ do

109addNewCompilers oldCompilers newCompilers = Runtime $ do

98 -- Get some information

110 -- Get some information

111+ logger <- hakyllLogger <$> ask

112+ section logger "Adding new compilers"

99 provider <- hakyllResourceProvider <$> ask

113 provider <- hakyllResourceProvider <$> ask

100 store <- hakyllStore <$> ask

114 store <- hakyllStore <$> ask

101

115

@@ -115,31 +129,31 @@ addNewCompilers oldCompilers newCompilers = Runtime $ do

115

129

116 -- Find the old graph and append the new graph to it. This forms the

130 -- Find the old graph and append the new graph to it. This forms the

117 -- complete graph

131 -- complete graph

132+ completeGraph <- timed logger "Creating graph" $

118− completeGraph <- mappend currentGraph . hakyllGraph <$> get

133+ mappend currentGraph . hakyllGraph <$> get

119−

120− -- Check which items are up-to-date. This only needs to happen for the new

121− -- compilers

122− oldModified <- hakyllModified <$> get

123− newModified <- liftIO $ modified provider store $ map fst newCompilers

124

134

125− let modified' = oldModified `S.union` newModified

135+ orderedCompilers <- timed logger "Solving dependencies" $ do

126−

136+ -- Check which items are up-to-date. This only needs to happen for the new

127− -- Find obsolete items. Every item that is reachable from a modified

137+ -- compilers

128− -- item is considered obsolete. From these obsolete items, we are only

138+ oldModified <- hakyllModified <$> get

129− -- interested in ones that are in the current subgraph.

139+ newModified <- liftIO $ modified provider store $ map fst newCompilers

130− obsolete = S.filter (`member` currentGraph)

131− $ reachableNodes modified' $ reverse completeGraph

132

140

133− -- Solve the graph and retain only the obsolete items

141+ let modified' = oldModified `S.union` newModified

142+

143+ -- Find obsolete items. Every item that is reachable from a modified

144+ -- item is considered obsolete. From these obsolete items, we are only

145+ -- interested in ones that are in the current subgraph.

134− ordered = filter (`S.member` obsolete) $ solveDependencies currentGraph

146+ obsolete = S.filter (`member` currentGraph)

147+ $ reachableNodes modified' $ reverse completeGraph

135

148

136− -- Join the order with the compilers again

149+ -- Solve the graph and retain only the obsolete items

137− orderedCompilers = map (id &&& (compilerMap M.!)) ordered

150+ ordered = filter (`S.member` obsolete) $ solveDependencies currentGraph

138

151

139− liftIO $ putStrLn "Adding compilers..."

152+ -- Update the state

140− liftIO $ putStrLn $ "Added: " ++ show (map fst orderedCompilers)

153+ modify $ updateState modified' completeGraph

141

154

142− modify $ updateState modified' completeGraph

155+ -- Join the order with the compilers again

156+ return $ map (id &&& (compilerMap M.!)) ordered

143

157

144 -- Now run the ordered list of compilers

158 -- Now run the ordered list of compilers

145 unRuntime $ runCompilers orderedCompilers

159 unRuntime $ runCompilers orderedCompilers

@@ -157,33 +171,33 @@ runCompilers :: [(Identifier, Compiler () CompileRule)]

157runCompilers [] = return ()

171runCompilers [] = return ()

158runCompilers ((id', compiler) : compilers) = Runtime $ do

172runCompilers ((id', compiler) : compilers) = Runtime $ do

159 -- Obtain information

173 -- Obtain information

174+ logger <- hakyllLogger <$> ask

160 routes <- hakyllRoutes <$> ask

175 routes <- hakyllRoutes <$> ask

161 provider <- hakyllResourceProvider <$> ask

176 provider <- hakyllResourceProvider <$> ask

162 store <- hakyllStore <$> ask

177 store <- hakyllStore <$> ask

163 modified' <- hakyllModified <$> get

178 modified' <- hakyllModified <$> get

164

179

180+ section logger $ "Compiling " ++ show id'

181+

165 let -- Check if the resource was modified

182 let -- Check if the resource was modified

166 isModified = id' `S.member` modified'

183 isModified = id' `S.member` modified'

167

184

168 -- Run the compiler

185 -- Run the compiler

186+ result <- timed logger "Compiling item" $

169− result <- liftIO $ runCompiler compiler id' provider routes store isModified

187+ liftIO $ runCompiler compiler id' provider routes store isModified

170− liftIO $ putStrLn $ "Generated target: " ++ show id'

171

188

172 case result of

189 case result of

173 -- Compile rule for one item, easy stuff

190 -- Compile rule for one item, easy stuff

174 CompileRule compiled -> do

191 CompileRule compiled -> do

175 case runRoutes routes id' of

192 case runRoutes routes id' of

176 Nothing -> return ()

193 Nothing -> return ()

177− Just url -> do

194+ Just url -> timed logger ("Routing to " ++ url) $ do

178− liftIO $ putStrLn $ "Routing " ++ show id' ++ " to " ++ url

179 destination <-

195 destination <-

180 destinationDirectory . hakyllConfiguration <$> ask

196 destinationDirectory . hakyllConfiguration <$> ask

181 let path = destination </> url

197 let path = destination </> url

182 liftIO $ makeDirectories path

198 liftIO $ makeDirectories path

183 liftIO $ write path compiled

199 liftIO $ write path compiled

184

200

185− liftIO $ putStrLn ""

186−

187 -- Continue for the remaining compilers

201 -- Continue for the remaining compilers

188 unRuntime $ runCompilers compilers

202 unRuntime $ runCompilers compilers

189

203