diff --git a/darcswatch.cabal b/darcswatch.cabal --- a/darcswatch.cabal +++ b/darcswatch.cabal @@ -1,5 +1,5 @@ Name: darcswatch -version: 0.1 +version: 0.2 Category: Distribution name: darcswatch author: Joachim Breitner @@ -63,6 +63,7 @@ , zlib , filepath , bytestring + , concurrentoutput source-repository head type: darcs @@ -71,4 +72,4 @@ source-repository this type: darcs location: http://darcs.nomeata.de/darcswatch/ - tag: v0.1 + tag: v0.2 diff --git a/src/CachedGet.hs b/src/CachedGet.hs --- a/src/CachedGet.hs +++ b/src/CachedGet.hs @@ -35,22 +35,23 @@ -- an URL to download, it will return the content of the URL. -- The boolean return value is true when the file was updated, -- and False if it is the same as in the cache. -get :: FilePath -> String -> IO (Maybe (ByteString, Bool)) -get dir' uri = flip catch (\e -> putStrLn ("Error downloading uri: " ++ show e) >> return Nothing) $ do - putStr $ "Getting URL " ++ uri ++ " ... " +get :: (String -> IO ()) -> FilePath -> String -> IO (Maybe (ByteString, Bool)) +get write dir' uri = flip catch (\e -> write ("Error downloading uri: " ++ show e++ "\n") + >> return Nothing) $ do + write $ "Getting URL " ++ uri ++ " ... " e_cache <- doesFileExist cacheFile e_tag <- doesFileExist tagFile let update = do newFile <- get' uri case newFile of Nothing -> do - putStrLn "not found." + write "not found.\n" return Nothing Just (newFile, Nothing) -> do - putStrLn "downloaded." + write "downloaded.\n" return $ Just (newFile, True) Just (newFile, Just newTag) -> do - putStrLn "downloaded." + write "downloaded.\n" B.writeFile cacheFile newFile writeFile tagFile newTag return $ Just (newFile, True) @@ -66,7 +67,7 @@ maybe'' mbNewTag (return Nothing) $ \newTag -> do if oldTag == newTag then do - putStrLn "cached." + write "cached.\n" oldFile <- B.readFile cacheFile return $ Just (oldFile, False) else do diff --git a/src/Darcs.hs b/src/Darcs.hs --- a/src/Darcs.hs +++ b/src/Darcs.hs @@ -53,24 +53,24 @@ -- | Given a directory used for caching, and an URL of a Darcs repository, -- it will return the list of patches in the repository, and whether the -- repository as changed since the last run. -getInventory :: FilePath -> String -> IO ([PatchInfo], Bool) -getInventory cDir repo = do - format <- get cDir formatUrl +getInventory :: (String -> IO ()) -> FilePath -> String -> IO ([PatchInfo], Bool) +getInventory write cDir repo = do + format <- get write cDir formatUrl case format of - Nothing -> getInventory1 cDir repo - Just (f,_) | f == B.pack "hashed\ndarcs-2\n" -> getInventory2 cDir repo - | f == B.pack "darcs-1.0\n" -> getInventory1 cDir repo + Nothing -> getInventory1 write cDir repo + Just (f,_) | f == B.pack "hashed\ndarcs-2\n" -> getInventory2 write cDir repo + | f == B.pack "darcs-1.0\n" -> getInventory1 write cDir repo | otherwise -> error $ "Unkown repository format: " ++ B.unpack f where formatUrl = addSlash repo ++ "_darcs/format" -- | Gets called when old style format was detected -getInventory1 :: FilePath -> String -> IO ([PatchInfo],Bool) -getInventory1 cDir repo = getInventoryFile (addSlash repo ++ "_darcs/inventory") +getInventory1 :: (String -> IO ()) -> FilePath -> String -> IO ([PatchInfo],Bool) +getInventory1 write cDir repo = getInventoryFile (addSlash repo ++ "_darcs/inventory") where maybe' m f d = maybe d f m getInventoryFile url = do - inv <- get cDir url + inv <- get write cDir url maybe' inv parseBody $ do - putStrLn $ "Repository " ++ repo ++ " not found." + write $ "Repository " ++ repo ++ " not found.\n" return ([],False) parseBody (body, updated) = do let unzipped = maybeUnzipB body @@ -84,13 +84,13 @@ _ -> return (patches, updated) -- | Gets called when new style format was detected -getInventory2 :: FilePath -> String -> IO ([PatchInfo],Bool) -getInventory2 cDir repo = getInventoryFile (addSlash repo ++ "_darcs/hashed_inventory") +getInventory2 :: (String -> IO ()) -> FilePath -> String -> IO ([PatchInfo],Bool) +getInventory2 write cDir repo = getInventoryFile (addSlash repo ++ "_darcs/hashed_inventory") where maybe' m f d = maybe d f m getInventoryFile url = do - inv <- get cDir url + inv <- get write cDir url maybe' inv parseBody $ do - putStrLn $ "Repository " ++ repo ++ " not found." + write $ "Repository " ++ repo ++ " not found.\n" return ([],False) skip_pristine s = case breakOn '\n' s of (l1,r) | B.pack "pristine" `B.isPrefixOf` l1 -> B.tail r diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -25,6 +25,7 @@ import System.Posix.Files import System.Time import System.IO +import System.Terminal.Concurrent import qualified Data.Map as M import qualified Data.Set as S @@ -64,11 +65,13 @@ lockRestart (cOutput config) patchNew or True (do_work config) do_work config patchNew = do + writeC <- getConcurrentOutputter + putStrLn "Reading repositories..." let loadInv rep = do - putStrLn $ "Reading " ++ rep ++ ":" - (ps,thisNew) <- getInventory (cOutput config ++ "/cache/") rep - putStrLn (if thisNew then "Repostory is new." else "Repository is cached.") + writeC $ "Reading " ++ rep ++ ":\n" + (ps,thisNew) <- getInventory writeC (cOutput config ++ "/cache/") rep + writeC (if thisNew then "Repostory is new.\n" else "Repository is cached.\n") return (rep, ps, thisNew) readInv (p2r,r2p,new) (rep, ps,thisNew) = do let p2r' = foldr (\p -> MM.append p rep) p2r ps @@ -190,7 +193,6 @@ on :: (b -> b -> c) -> (a -> b) -> a -> a -> c (*) `on` f = \x y -> f x * f y -forkSequence = sequence -{- Enable for parallel downloads +{- forkSequence = sequence -} +-- Enable for parallel downloads forkSequence acts = mapM (\act -> newEmptyMVar >>= \mvar -> forkIO (act >>= putMVar mvar) >> return mvar) acts >>= mapM takeMVar --}