module Scion.PersistentBrowser.Build
( saveHackageDatabase
, createHackageDatabase
, updateDatabase
, createCabalDatabase
, getCabalHoogle
) where
import Control.Concurrent.ParallelIO.Local
import Control.Monad.IO.Class (liftIO)
import Data.Either (rights)
import Data.List ((\\), nub)
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Version (Version, showVersion, parseVersion)
import Database.Persist.Sqlite
import Distribution.InstalledPackageInfo
import Distribution.Package hiding (Package)
import Scion.PersistentBrowser.DbTypes
import Scion.PersistentBrowser.FileUtil
import Scion.PersistentBrowser.Parser
import Scion.PersistentBrowser.ToDb
import Scion.PersistentBrowser.Types
import Scion.PersistentBrowser.Util
import System.Directory
import System.Exit
import System.FilePath
import Text.Parsec.Error (ParseError)
import Text.ParserCombinators.Parsec.Error (newErrorMessage, Message(..))
import Text.ParserCombinators.Parsec.Pos (newPos)
import Text.ParserCombinators.ReadP
import Control.Monad (when)
import Data.Conduit (runResourceT)
import Control.Monad.Logger (runNoLoggingT) --runStderrLoggingT,
baseDbUrl :: String
baseDbUrl = "http://haskell.org/hoogle/base.txt"
ghcDbUrl :: String
ghcDbUrl = "http://www.haskell.org/ghc/docs/latest/html/libraries/ghc/ghc.txt"
hoogleDbUrl :: String
hoogleDbUrl = "http://hackage.haskell.org/packages/archive/00-hoogle.tar.gz"
getPackageUrlHackage :: PackageIdentifier -> String
getPackageUrlHackage (PackageIdentifier (PackageName name) version) =
"http://hackage.haskell.org/packages/archive/" ++ name ++ "/" ++ showVersion version ++ "/doc/html/" ++ name ++ ".txt"
getGhcInstalledVersion :: [PackageIdentifier] -> Version
getGhcInstalledVersion [] = error "No GHC found"
getGhcInstalledVersion ((PackageIdentifier (PackageName "ghc") version):_) = version
getGhcInstalledVersion (_:xs) = getGhcInstalledVersion xs
getPackageUrlGhcLibs :: Version -> PackageIdentifier -> String
getPackageUrlGhcLibs ghcVersion (PackageIdentifier (PackageName name) version) =
"http://www.haskell.org/ghc/docs/" ++ showVersion ghcVersion ++ "/html/libraries/" ++ name ++ "-" ++ showVersion version ++ "/" ++ name ++ ".txt"
saveHackageDatabase :: FilePath -> IO ()
saveHackageDatabase file = withTemporaryDirectory (saveHackageDatabaseWithTmp file)
saveHackageDatabaseWithTmp :: FilePath -> FilePath -> IO ()
saveHackageDatabaseWithTmp file tmp = do (db, _) <- createHackageDatabase tmp
runResourceT $ runNoLoggingT $ withSqliteConn (T.pack file) (runSqlConn (mapM_ savePackageToDb db))
createHackageDatabase :: FilePath -> IO ([Documented Package], [(FilePath, ParseError)])
createHackageDatabase tmp =
do let hoogleDbDir = tmp </> "hoogle-db"
tmpDir = tmp </> "tmp-db"
createDirectoryIfMissing True hoogleDbDir
logToStdout "Started downloading Hoogle database"
Just hoogleDownloaded <- downloadFileLazy hoogleDbUrl
logToStdout "Uncompressing Hoogle database"
unTarGzip hoogleDownloaded hoogleDbDir
logToStdout $ "Hoogle database is now in " ++ hoogleDbDir
createDirectoryIfMissing True tmpDir
(pkgs, errors) <- parseDirectory hoogleDbDir tmpDir
return (pkgs, errors)
updateDatabase :: FilePath -> [InstalledPackageInfo] -> IO ()
updateDatabase file pkgInfo = runResourceT $ runNoLoggingT $ withSqliteConn (T.pack file) $ runSqlConn $ updateDatabase' pkgInfo
updateDatabase' :: [InstalledPackageInfo] -> SQL ()
updateDatabase' pkgInfo =
do dbPersistent <- selectList ([] :: [Filter DbPackage]) []
let dbList = map (fromDbToPackageIdentifier . entityVal) dbPersistent
installedList = nub $ removeSmallVersions $ map sourcePackageId pkgInfo
toRemove = dbList \\ installedList
toAdd = installedList \\ dbList
when (not $ null toRemove) (do
liftIO $ logToStdout $ "Removing " ++ show (map (\(PackageIdentifier (PackageName name) _) -> name) toRemove))
mapM_ deletePackageByInfo toRemove
when (not $ null toAdd) (do
liftIO $ logToStdout $ "Adding " ++ show (map (\(PackageIdentifier (PackageName name) _) -> name) toAdd))
let ghcVersion = getGhcInstalledVersion installedList
(addedDb, errors) <- liftIO $ createCabalDatabase' ghcVersion toAdd True
mapM_ savePackageToDb addedDb
when (not $ null errors) (do
liftIO $ logToStdout $ show errors)
fromDbToPackageIdentifier :: DbPackage -> PackageIdentifier
fromDbToPackageIdentifier (DbPackage name version _) = PackageIdentifier (PackageName name)
(getVersion version)
getVersion :: String -> Version
getVersion version = (fst . last . readP_to_S parseVersion) version
removeSmallVersions :: [PackageIdentifier] -> [PackageIdentifier]
removeSmallVersions pids = filter
(not . (\(PackageIdentifier name version) ->
any (\(PackageIdentifier name' version') -> name' == name && version' > version) pids))
pids
createCabalDatabase :: Version -> [PackageIdentifier] -> IO ([Documented Package], [(String, ParseError)])
createCabalDatabase ghcVersion pkgs = createCabalDatabase' ghcVersion pkgs False
createCabalDatabase' :: Version -> [PackageIdentifier] -> Bool -> IO ([Documented Package], [(String, ParseError)])
createCabalDatabase' ghcVersion pkgs ifFailCreateEmpty =
withTemporaryDirectory $ \tmp ->
do
let toExecute = map (\pid -> do
db <- getCabalHoogle ghcVersion pid ifFailCreateEmpty tmp
return (pkgString pid, db))
pkgs
eitherHooglePkgs <- withThreaded $ \pool -> parallelInterleavedE pool toExecute
let hooglePkgs = rights eitherHooglePkgs
(db, errors) = partitionPackages hooglePkgs
return (db, errors)
getCabalHoogle :: Version -> PackageIdentifier -> Bool -> FilePath -> IO(Either ParseError (Documented Package))
getCabalHoogle ghcVersion pid ifFailCreateEmpty tmp = do
result <- getCabalHoogle' ghcVersion pid tmp
case result of
Left e -> return $ failure e
Right (Package doc _ info) -> return $ Right (Package doc pid info)
where failure e = if ifFailCreateEmpty
then Right (Package NoDoc pid M.empty)
else Left e
getCabalHoogle' :: Version -> PackageIdentifier -> FilePath -> IO (Either ParseError (Documented Package))
getCabalHoogle' ghcVersion pid tmp = do let downUrl1 = getPackageUrlHackage pid
logToStdout $ "Download " ++ downUrl1
tryDownload1 <- downloadHoogleFile downUrl1
case tryDownload1 of
Nothing -> do let downUrl2 = getPackageUrlGhcLibs ghcVersion pid
logToStdout $ "Download " ++ downUrl2
tryDownload2 <- downloadHoogleFile downUrl2
case tryDownload2 of
Nothing -> getCabalHoogleLocal pid tmp
Just cnts -> return $ parseHoogleString "<package>" cnts
Just cnts -> return $ parseHoogleString "<package>" cnts
getCabalHoogleLocal :: PackageIdentifier -> FilePath -> IO (Either ParseError (Documented Package))
getCabalHoogleLocal pid tmp =
do let pkgV = pkgString pid
(PackageName pkg) = pkgName pid
logToStdout $ "Parsing " ++ pkgV
code <- executeCommand tmp "cabal" ["unpack", pkgV] True
case code of
ExitFailure _ -> return $ Left (newErrorMessage (Message "package not found")
(newPos pkgV 0 0))
ExitSuccess ->
do let pkgdir = tmp </> pkgV
withWorkingDirectory pkgdir $
do executeCommand pkgdir "cabal" ["configure"] True
executeCommand pkgdir "cabal" ["haddock", "--hoogle"] True
let hoogleFile = pkgdir </> "dist" </> "doc" </> "html" </> pkg </> (pkg ++ ".txt")
parseHoogleFile hoogleFile
pkgString :: PackageIdentifier -> String
pkgString (PackageIdentifier (PackageName name) version) = name ++ "-" ++ showVersion version