diff --git a/src/Network/Wikipedia.hs b/src/Network/Wikipedia.hs --- a/src/Network/Wikipedia.hs +++ b/src/Network/Wikipedia.hs @@ -17,10 +17,8 @@ import System.FilePath import Data.List (nub) import Data.Maybe (mapMaybe, fromJust) -import Data.Either import Data.Char import qualified Data.ByteString.Lazy.Char8 as BC -import qualified Data.ByteString.Lazy as ByteString import qualified Codec.Compression.GZip as GZip data WikiArticle = WikiArticleHTML { waTitle :: String, waContent :: String } @@ -33,17 +31,16 @@ | otherwise = '_' isArticleURL :: URL -> Bool -isArticleURL (URL (Absolute (Host (HTTP False) xs Nothing)) ph []) = (xs =~ ".*en[.]wikipedia.org$") && (ph =~ "wiki/[^/]+$" ) +isArticleURL (URL (Absolute (Host (HTTP False) xs Nothing)) ph []) = (xs =~ ".*[.]wikipedia.org") && (ph =~ "wiki/.*") isArticleURL _ = False articleURL2Title :: URL -> String -articleURL2Title x | isArticleURL x = sanitizeFileName (takeFileName (url_path x)) - | otherwise = "" +articleURL2Title x = sanitizeFileName (takeFileName (url_path x)) articleRelURL2Title :: String -> String articleRelURL2Title ('#':xs) = '#':xs -articleRelURL2Title x = case importURL ("http://en.wikipedia.org"++x) of - Nothing -> "" +articleRelURL2Title x = case importURL ("http://en.wikipedia.org/"++x) of + Nothing -> error $ "Invalid article relative path: "++x Just u -> articleURL2Title u isArticleImgURL :: String -> Bool @@ -61,10 +58,11 @@ hrefs = map (fromAttrib "href") aTags in mapMaybe importURL $ nub $ filter (=~ "^/wiki/[^:/]+$") hrefs -getArticleLinksAbs :: WikiArticle -> [URL] -getArticleLinksAbs xs = let ys = getArticleLinks xs - toAbsURL (URL _ path params) = (URL (Absolute (Host (HTTP False) "en.wikipedia.org" Nothing)) path params) - in map toAbsURL ys +getArticleLinksAbs :: String -> WikiArticle -> [URL] +getArticleLinksAbs domain xs = map toAbsURL ys + where + ys = getArticleLinks xs + toAbsURL (URL _ path params) = (URL (Absolute (Host (HTTP False) domain Nothing)) path params) -- http://en.wikipedia.org/w/index.php?title=Computer&printable=yes {- @@ -86,14 +84,14 @@ processTags alnk xs = procHrefTags alnk $ procImgTags $ map processAttrs xs where - processAttrs t@(TagOpen "div" _) = TagText "" - processAttrs t@(TagClose "div") = TagText "" + processAttrs (TagOpen "div" _) = TagText "" + processAttrs (TagClose "div") = TagText "" processAttrs t@(TagOpen s ys) | null s = t | head s == '!' = t | otherwise = TagOpen s (removeStyleAttr $ removeEmptyAttr ys) processAttrs t = t - removeEmptyAttr xs = filter (not . null . snd) xs - removeStyleAttr xs = filter (\x -> (fst x) `notElem` ["style", "class"]) xs + removeEmptyAttr = filter (not . null . snd) + removeStyleAttr = filter (\x -> (fst x) `notElem` ["style", "class"]) filterAllTags tgs xs = filter (not . isTagComment) $ foldr (filterTags) xs tgs @@ -101,7 +99,7 @@ isTagComment (TagComment _) = True isTagComment _ = False -filterTags tn [] = [] +filterTags _ [] = [] filterTags tn (x:xs) | isTagOpenName tn x = filterTags tn $ dropWhile (not . isTagCloseName tn) xs | isTagCloseName tn x = filterTags tn xs | otherwise = x:filterTags tn xs diff --git a/src/Web/Firefox.hs b/src/Web/Firefox.hs deleted file mode 100644 --- a/src/Web/Firefox.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Web.Firefox (listPlacesFiles, listHistoryURLs, listAllHistoryURLs) -where -import Database.HDBC (fromSql, quickQuery') -import Database.HDBC.Sqlite3 (connectSqlite3, setBusyTimeout) -import Network.URL (importURL, URL) -import Data.List (isSuffixOf) -import Control.Monad (forM) -import Data.Maybe (mapMaybe) -import System.Directory (doesDirectoryExist, getDirectoryContents, getHomeDirectory, getTemporaryDirectory, copyFile, removeFile) -import System.FilePath (()) - -firefoxDirs :: [String] -firefoxDirs = [ ".mozilla", ".mozilla-firefox", ".firefox" ] - -placesFile :: String -placesFile = "places.sqlite" - -timeoutFox = 5 - -listPlacesFiles :: IO [FilePath] -listPlacesFiles = do - homeDir <- getHomeDirectory - xs <- mapM (getRecursiveContents . (homeDir )) firefoxDirs - return $ filter (placesFile `isSuffixOf`) (concat xs) - -listAllHistoryURLs :: IO [URL] -listAllHistoryURLs = do - putStrLn $ "Please close your Firefox if you see this message longer than "++show timeoutFox++" seconds..." - places <- listPlacesFiles - xs <- mapM listHistoryURLs places - return $ concat xs - -listHistoryURLs :: FilePath -> IO [URL] -listHistoryURLs name = do - putStrLn $ "Going to connect on Firefox SQLite DB: " ++ name - tmpDir <- getTemporaryDirectory - let tmpName = tmpDir "wiki4e_places.sqlite" - copyFile name tmpName - conn <- connectSqlite3 tmpName - setBusyTimeout conn (1000*timeoutFox) - xs <- quickQuery' conn "select url from moz_places order by last_visit_date desc" [] - let ys = map (fromSql . head) xs :: [String] - removeFile tmpName - return $ mapMaybe importURL ys - -getRecursiveContents :: FilePath -> IO [FilePath] -getRecursiveContents topdir = do - e <- doesDirectoryExist topdir - if e then do - names <- getDirectoryContents topdir - let properNames = filter (`notElem` [".", ".."]) names - paths <- forM properNames $ \name -> do - let path = topdir name - e2 <- doesDirectoryExist path - if e2 - then getRecursiveContents path - else return [path] - return (concat paths) - else return [] diff --git a/src/Wiki4e/Commands/Articles.hs b/src/Wiki4e/Commands/Articles.hs --- a/src/Wiki4e/Commands/Articles.hs +++ b/src/Wiki4e/Commands/Articles.hs @@ -70,7 +70,7 @@ wiki4e_fetchArticles config us let fs = map (outd ) $ map (articleURL2Title) us as <- mapM (wiki4e_readArticle) fs - let xs = nub $ concat $ map getArticleLinksAbs as + let xs = nub $ concat $ map (getArticleLinksAbs (w4confDomain config)) as ys <- wiki4e_crawlArticlesLinks config xs l return (nub $ us++xs++ys) where diff --git a/src/Wiki4e/Commands/Common.hs b/src/Wiki4e/Commands/Common.hs --- a/src/Wiki4e/Commands/Common.hs +++ b/src/Wiki4e/Commands/Common.hs @@ -13,14 +13,15 @@ -- | Basic configuration of the commands data Wiki4eConfig = Wiki4eConfig { w4confDirFetch :: FilePath, w4confDirImg :: FilePath, - w4confDirSanitized :: FilePath } + w4confDirSanitized :: FilePath, + w4confDomain :: String } -- Support Functions getWiki4eDir :: IO FilePath getWiki4eDir = getAppUserDataDirectory "wiki4e" -wiki4e_initConfig :: IO Wiki4eConfig -wiki4e_initConfig = do +wiki4e_initConfig :: String -> IO Wiki4eConfig +wiki4e_initConfig domain = do tmpDir <- getWiki4eDir let tmpDirFetch = tmpDir "wiki4e_fetch" let tmpDirSanitize = tmpDir "wiki4e_sanitize" @@ -28,11 +29,11 @@ createDirectoryIfMissing True tmpDirFetch createDirectoryIfMissing True tmpDirSanitize createDirectoryIfMissing True tmpDirImgs - return (Wiki4eConfig tmpDirFetch tmpDirImgs tmpDirSanitize) + return (Wiki4eConfig tmpDirFetch tmpDirImgs tmpDirSanitize domain) readFileUTF8 :: FilePath -> IO String readFileUTF8 x = do - h <- openBinaryFile x ReadMode + h <- openFile x ReadMode hSetEncoding h utf8 c <- hGetContents h forceList c `seq` hClose h diff --git a/src/wiki4e-mkepub-cache.hs b/src/wiki4e-mkepub-cache.hs deleted file mode 100644 --- a/src/wiki4e-mkepub-cache.hs +++ /dev/null @@ -1,46 +0,0 @@ -import Text.HTML.TagSoup -import System.Environment -import System.Directory -import System.FilePath -import Data.Maybe (catMaybes) -import Control.Monad (liftM) -import System.IO -import Network.URL -import Wiki4e.Commands -import Network.Wikipedia (isArticleURL) - -defaultEbookName = "Wikipedia_Articles_From_Cache" - -main = do - name <- getProgName - args <- getArgs - case args of - [] -> cache2epub defaultEbookName - ['-':_] -> usageHelp name - ['/':_] -> usageHelp name - [xs] -> cache2epub xs - _ -> usageHelp name - -usageHelp name = putStrLn $ "Usage: " ++ name ++ " []" - -cache2epub bookName = do - hSetBinaryMode stdout True - config <- wiki4e_initConfig - arts <- wiki4e_listCacheURLs config - putStrLn "# STAGE 1/5 - Verify Articles..." - wiki4e_fetchArticles config arts - putStrLn "# STAGE 2/5 - Sanitize Articles..." - wiki4e_sanitizeArticles config arts - putStrLn "# STAGE 3/5 - Inspect Articles for Images..." - imgs <- wiki4e_listArticlesImages config arts - putStrLn "# STAGE 4/5 - Download Images..." - wiki4e_fetchImages config imgs - putStrLn "# STAGE 5/5 - Constructing EPUB..." - wiki4e_createEpub config bookName arts imgs - putStrLn "Done." - --- | It is expected that all articles are from english wikipedia -wiki4e_listCacheURLs :: Wiki4eConfig -> IO [URL] -wiki4e_listCacheURLs config = do - files <- liftM (filter (\(c:_) -> c /= '.')) $ getDirectoryContents (w4confDirFetch config) - return $ catMaybes $ map (importURL) (map (\x -> "http://en.wikipedia.org/wiki/"++x) files) diff --git a/src/wiki4e-mkepub-firefox.hs b/src/wiki4e-mkepub-firefox.hs deleted file mode 100644 --- a/src/wiki4e-mkepub-firefox.hs +++ /dev/null @@ -1,44 +0,0 @@ -import Text.HTML.TagSoup -import System.Environment -import System.Directory -import System.FilePath -import Data.List (nub) -import System.IO -import Network.URL -import Wiki4e.Commands -import Network.Wikipedia (isArticleURL) -import Web.Firefox - -defaultEbookName = "Wikipedia_Articles_From_Firefox" - -main = do - name <- getProgName - args <- getArgs - case args of - [] -> firefox2epub defaultEbookName - ['-':_] -> usageHelp name - ['/':_] -> usageHelp name - [xs] -> firefox2epub xs - _ -> usageHelp name - -usageHelp name = putStrLn $ "Usage: " ++ name ++ " [<Title Name of new e-book>]" - -firefox2epub bookName = do - hSetBinaryMode stdout True - arts <- wiki4e_listFirefoxURLs - config <- wiki4e_initConfig - putStrLn "# STAGE 1/4 - Download Articles..." - wiki4e_fetchArticles config arts - putStrLn "# STAGE 2/4 - Sanitize Articles..." - wiki4e_sanitizeArticles config arts - putStrLn "# STAGE 3/4 - Download Images..." - imgs <- wiki4e_listArticlesImages config arts - wiki4e_fetchImages config imgs - putStrLn "# STAGE 4/4 - Constructing EPUB..." - wiki4e_createEpub config bookName arts imgs - putStrLn "Done." - -wiki4e_listFirefoxURLs :: IO [URL] -wiki4e_listFirefoxURLs = do - xs <- listAllHistoryURLs - return $ nub $ filter isArticleURL xs diff --git a/src/wiki4e-mkepub-subtree.hs b/src/wiki4e-mkepub-subtree.hs --- a/src/wiki4e-mkepub-subtree.hs +++ b/src/wiki4e-mkepub-subtree.hs @@ -25,7 +25,10 @@ subtree2epub cs l = do hSetBinaryMode stdout True let u = fromJust $ importURL cs - config <- wiki4e_initConfig + let domain = case url_type u of + Absolute hst -> host $ hst + _ -> error "Invalid URL: "++(show u) + config <- wiki4e_initConfig domain putStrLn $ "# INFO - download depth is hardcoded value = " ++ (show defaultDepth) putStrLn $ "# STAGE 1/4 - Fetch starting article: " ++ (exportURL u) arts <- wiki4e_crawlArticlesLinks config [u] l diff --git a/wikipedia4epub.cabal b/wikipedia4epub.cabal --- a/wikipedia4epub.cabal +++ b/wikipedia4epub.cabal @@ -1,5 +1,5 @@ Name: wikipedia4epub -Version: 0.0.10 +Version: 0.0.12 License: BSD3 License-File: LICENSE Homepage: http://rampa.sk/static/wikipedia4epub.html @@ -20,11 +20,10 @@ Source-Repository head type: darcs - location: http://patch-tag.com/r/dixiecko/wikipedia4epub + location: http://darcsden.com/dixie/wikipedia4epub Library - Build-Depends: ghc >= 6.12.1, - base < 5, + Build-Depends: base < 5, filepath, bytestring, haskell98, @@ -34,14 +33,11 @@ regex-posix, network, regex-base, - HDBC-sqlite3, - HDBC >= 2.1.1, tagsoup >= 0.8, HTTP, zip-archive, zlib, - xml, - Cabal >= 1.5 && < 1.9 + xml Hs-Source-Dirs: src Extensions: CPP, PatternGuards Ghc-Options: -Wall -fno-warn-orphans @@ -54,16 +50,8 @@ Wiki4e.Commands.Fetching Wiki4e.Commands.EPUB Network.Wikipedia - Web.Firefox -Executable wiki4e-mkepub-firefox - Hs-Source-Dirs: src - Main-Is: wiki4e-mkepub-firefox.hs - Executable wiki4e-mkepub-subtree Hs-Source-Dirs: src Main-Is: wiki4e-mkepub-subtree.hs -Executable wiki4e-mkepub-cache - Hs-Source-Dirs: src - Main-Is: wiki4e-mkepub-cache.hs