importfeed: git-annex becomes a podcatcher in 150 LOC
This commit is contained in:
parent
55bd5a81ad
commit
7e66d260ea
15 changed files with 319 additions and 32 deletions
47
Logs/Web.hs
47
Logs/Web.hs
|
@ -1,6 +1,6 @@
|
|||
{- Web url logs.
|
||||
-
|
||||
- Copyright 2011 Joey Hess <joey@kitenet.net>
|
||||
- Copyright 2011, 2013 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
@ -11,12 +11,21 @@ module Logs.Web (
|
|||
getUrls,
|
||||
setUrlPresent,
|
||||
setUrlMissing,
|
||||
urlLog,
|
||||
urlLogKey,
|
||||
knownUrls
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Lazy.Char8 as L
|
||||
|
||||
import Common.Annex
|
||||
import Logs.Presence
|
||||
import Logs.Location
|
||||
import Types.Key
|
||||
import qualified Annex.Branch
|
||||
import Annex.CatFile
|
||||
import qualified Git
|
||||
import qualified Git.LsFiles
|
||||
|
||||
type URLString = String
|
||||
|
||||
|
@ -24,8 +33,24 @@ type URLString = String
|
|||
webUUID :: UUID
|
||||
webUUID = UUID "00000000-0000-0000-0000-000000000001"
|
||||
|
||||
urlLogExt :: String
|
||||
urlLogExt = ".log.web"
|
||||
|
||||
urlLog :: Key -> FilePath
|
||||
urlLog key = hashDirLower key </> keyFile key ++ ".log.web"
|
||||
urlLog key = hashDirLower key </> keyFile key ++ urlLogExt
|
||||
|
||||
{- Converts a url log file into a key.
|
||||
- (Does not work on oldurlLogs.) -}
|
||||
urlLogKey :: FilePath -> Maybe Key
|
||||
urlLogKey file
|
||||
| ext == urlLogExt = fileKey base
|
||||
| otherwise = Nothing
|
||||
where
|
||||
(base, ext) = splitAt (length file - extlen) file
|
||||
extlen = length urlLogExt
|
||||
|
||||
isUrlLog :: FilePath -> Bool
|
||||
isUrlLog file = urlLogExt `isSuffixOf` file
|
||||
|
||||
{- Used to store the urls elsewhere. -}
|
||||
oldurlLogs :: Key -> [FilePath]
|
||||
|
@ -58,3 +83,21 @@ setUrlMissing key url = do
|
|||
addLog (urlLog key) =<< logNow InfoMissing url
|
||||
whenM (null <$> getUrls key) $
|
||||
logChange key webUUID InfoMissing
|
||||
|
||||
{- Finds all known urls. -}
|
||||
knownUrls :: Annex [URLString]
|
||||
knownUrls = do
|
||||
{- Ensure the git-annex branch's index file is up-to-date and
|
||||
- any journaled changes are reflected in it, since we're going
|
||||
- to query its index directly. -}
|
||||
Annex.Branch.update
|
||||
Annex.Branch.commit "update"
|
||||
Annex.Branch.withIndex $ do
|
||||
top <- fromRepo Git.repoPath
|
||||
(l, cleanup) <- inRepo $ Git.LsFiles.stagedDetails [top]
|
||||
r <- mapM (geturls . snd) $ filter (isUrlLog . fst) l
|
||||
void $ liftIO cleanup
|
||||
return $ concat r
|
||||
where
|
||||
geturls Nothing = return []
|
||||
geturls (Just logsha) = getLog . L.unpack <$> catObject logsha
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue