diff --git a/scion-browser.cabal b/scion-browser.cabal --- a/scion-browser.cabal +++ b/scion-browser.cabal @@ -1,11 +1,11 @@ name: scion-browser -version: 0.3.5 +version: 0.4.0 cabal-version: >= 1.8 build-type: Simple license: BSD3 license-file: docs/LICENSE -author: Alejandro Serrano -maintainer: Alejandro Serrano , JP Moresmau (jpmoresmau@gmail.com) +author: Alejandro Serrano , JP Moresmau +maintainer: JP Moresmau (jpmoresmau@gmail.com) homepage: http://github.com/JPMoresmau/scion-class-browser category: Development synopsis: Command-line interface for browsing and searching packages documentation @@ -17,33 +17,34 @@ library hs-source-dirs: src - build-depends: - attoparsec >= 0.10 && < 0.13, - base == 4.*, - mtl >= 2, - derive >= 2.5 && < 3, - text, - parsec >= 3 && < 4, - Cabal >= 0.10, - haskell-src-exts >= 1.11 && < 1.17, - process >= 1 && < 2, - tar >= 0.3 && < 0.5, - zlib == 0.5.*, - HTTP >= 4000 && < 5000, - deepseq >= 1.1 && < 2, - aeson >=0.4 && <0.8, - parallel-io >= 0.3, - utf8-string, - persistent >= 1.2 && < 2, - persistent-sqlite >= 1.2, - persistent-template >= 1.2, - conduit>=1.0, - resourcet, - transformers, - unordered-containers >= 0.1.3, - zlib, - ghc-paths == 0.1.*, - monad-logger >= 0.3 + build-depends: + attoparsec >= 0.10 && < 0.13, + base == 4.*, + mtl >= 2, + derive >= 2.5 && < 3, + text, + parsec >= 3 && < 4, + Cabal >= 0.10, + haskell-src-exts >= 1.11 && < 1.17, + process >= 1 && < 2, + tar >= 0.3 && < 0.5, + zlib == 0.5.*, + deepseq >= 1.1 && < 2, + aeson >=0.4 && <0.8, + parallel-io >= 0.3, + utf8-string, + persistent >= 1.2 && < 2, + persistent-sqlite >= 1.2, + persistent-template >= 1.2, + conduit>=1.0, + resourcet, + transformers, + unordered-containers >= 0.1.3, + zlib, + ghc-paths == 0.1.*, + monad-logger >= 0.3, + ghc-pkg-lib, + http-conduit >= 2.0 if !os(mingw32) build-depends: @@ -77,7 +78,6 @@ ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -fno-warn-orphans other-modules: - Scion.Packages, Scion.PersistentBrowser.DbTypes, Scion.PersistentBrowser.FileUtil, Scion.PersistentBrowser.FromMissingH, @@ -124,7 +124,9 @@ zlib, ghc-paths == 0.1.*, monad-logger >= 0.3, - vector + vector, + ghc-pkg-lib, + http-conduit >= 2.0 if !os(mingw32) build-depends: @@ -152,7 +154,6 @@ ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -fno-warn-orphans -threaded other-modules: - Scion.Packages, Scion.PersistentBrowser, Scion.PersistentBrowser.Build, Scion.PersistentBrowser.DbTypes, @@ -172,7 +173,6 @@ Scion.PersistentHoogle.Types, Scion.PersistentHoogle.Util, Server.PersistentCommands --- -- For Scion.Packages (provisional) diff --git a/src/Scion/Packages.hs b/src/Scion/Packages.hs deleted file mode 100644 --- a/src/Scion/Packages.hs +++ /dev/null @@ -1,209 +0,0 @@ -{-# LANGUAGE CPP, ScopedTypeVariables #-} --- | --- Module : Scion.Packages --- Author : Thiago Arrais --- Copyright : (c) Thiago Arrais 2009 --- License : BSD-style --- Url : http://stackoverflow.com/questions/1522104/how-to-programmatically-retrieve-ghc-package-information --- --- Maintainer : nominolo@gmail.com --- Stability : experimental --- Portability : portable --- --- Cabal-related functionality. -module Scion.Packages ( getPkgInfos ) where - -import Scion.PersistentBrowser.Util - -import Prelude hiding (Maybe) -import qualified Config -import qualified System.Info -import Data.List -import Data.Maybe -import Control.Monad -import Distribution.InstalledPackageInfo -import Distribution.Text -import System.Directory -import System.Environment (getEnv) -import System.FilePath -import System.IO -import qualified Control.Exception as Exc - -import GHC.Paths - -import qualified Control.Exception as Exception - -#if __GLASGOW_HASKELL__ < 702 -catchIOError :: IO a -> (IOError -> IO a) -> IO a -catchIOError = catch -#else -import System.IO.Error (catchIOError) -#endif - --- this was borrowed from the ghc-pkg source: -type InstalledPackageInfoString = InstalledPackageInfo_ String - --- | Types of cabal package databases -data CabalPkgDBType = - PkgDirectory FilePath - | PkgFile FilePath - -type InstalledPackagesList = [(FilePath, [InstalledPackageInfo])] - --- | Fetch the installed package info from the global and user package.conf --- databases, mimicking the functionality of ghc-pkg. - -getPkgInfos :: IO InstalledPackagesList -getPkgInfos = - let - -- | Test for package database's presence in a given directory - -- NB: The directory is returned for later scanning by listConf, - -- which parses the actual package database file(s). - lookForPackageDBIn :: FilePath -> IO (Maybe InstalledPackagesList) - lookForPackageDBIn dir = - let - path_dir = dir "package.conf.d" - path_file = dir "package.conf" - in do - exists_dir <- doesDirectoryExist path_dir - if exists_dir - then do - pkgs <- readContents (PkgDirectory path_dir) - return $ Just pkgs - else do - exists_file <- doesFileExist path_file - if exists_file - then do - pkgs <- readContents (PkgFile path_file) - return $ Just pkgs - else return Nothing - - currentArch :: String - currentArch = System.Info.arch - - currentOS :: String - currentOS = System.Info.os - - ghcVersion :: String - ghcVersion = Config.cProjectVersion - in do - -- Get the global package configuration database: - global_conf <- do - r <- lookForPackageDBIn getLibDir - case r of - Nothing -> ioError $ userError ("Can't find package database in " ++ getLibDir) - Just pkgs -> return $ pkgs - - -- Get the user package configuration database - e_appdir <- Exc.try $ getAppUserDataDirectory "ghc" - user_conf <- do - case e_appdir of - Left (_::Exc.IOException) -> return [] - Right appdir -> do - let subdir = currentArch ++ '-':currentOS ++ '-':ghcVersion - dir = appdir subdir - r <- lookForPackageDBIn dir - case r of - Nothing -> return [] - Just pkgs -> return pkgs - - -- Process GHC_PACKAGE_PATH, if present: - e_pkg_path <- Exc.try $ getEnv "GHC_PACKAGE_PATH" - env_stack <- do - case e_pkg_path of - Left (_::Exc.IOException) -> return [] - Right path -> do - pkgs <- mapM readContents [(PkgDirectory pkg) | pkg <- splitSearchPath path] - return $ concat pkgs - - -- Send back the combined installed packages list: - return (env_stack ++ user_conf ++ global_conf) - --- | Read the contents of the given directory, searching for ".conf" files, and parse the --- package contents. Returns a singleton list (directory, [installed packages]) - -readContents :: CabalPkgDBType -- ^ The package database - -> IO [(FilePath, [InstalledPackageInfo])] -- ^ Installed packages - -readContents pkgdb = - let - -- | List package configuration files that might live in the given directory - listConf :: FilePath -> IO [FilePath] - listConf dbdir = do - conf_dir_exists <- doesDirectoryExist dbdir - if conf_dir_exists - then do - files <- getDirectoryContents dbdir - return [ dbdir file | file <- files, isSuffixOf ".conf" file] - else return [] - - -- | Read a file, ensuring that UTF8 coding is used for GCH >= 6.12 - readUTF8File :: FilePath -> IO String - readUTF8File file = do - h <- openFile file ReadMode -#if __GLASGOW_HASKELL__ >= 612 - -- fix the encoding to UTF-8 - hSetEncoding h utf8 - catchIOError (hGetContents h) (\_ -> do - -- logInfo $ ioeGetErrorString err - hClose h - h' <- openFile file ReadMode - hSetEncoding h' localeEncoding - hGetContents h' - ) -#else - hGetContents h -#endif - - - -- | This function was lifted directly from ghc-pkg. Its sole purpose is - -- parsing an input package description string and producing an - -- InstalledPackageInfo structure. - convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo - convertPackageInfoIn - (pkgconf@(InstalledPackageInfo { exposedModules = e, - hiddenModules = h })) = - pkgconf{ exposedModules = map convert e, - hiddenModules = map convert h } - where convert = fromJust . simpleParse - - -- | Utility function that just flips the arguments to Control.Exception.catch - catchError :: IO a -> (String -> IO a) -> IO a - catchError io handler = io `Exception.catch` handler' - where handler' (Exception.ErrorCall err) = handler err - - -- | Slightly different approach in Cabal 1.8 series, with the package.conf.d - -- directories, where individual package configuration files are association - -- pairs. - pkgInfoReader :: FilePath - -> IO [InstalledPackageInfo] - pkgInfoReader f = - catchIOError ( - do - pkgStr <- readUTF8File f - let pkgInfo = parseInstalledPackageInfo pkgStr - case pkgInfo of - ParseOk _ info -> return [info] - ParseFailed err -> do - logToStdout (show err) - return [emptyInstalledPackageInfo] - ) (\_->return [emptyInstalledPackageInfo]) - - in case pkgdb of - (PkgDirectory pkgdbDir) -> do - confs <- listConf pkgdbDir - pkgInfoList <- mapM pkgInfoReader confs - return [(pkgdbDir, join pkgInfoList)] - - (PkgFile dbFile) -> do - pkgStr <- readUTF8File dbFile - let pkgs = map convertPackageInfoIn $ read pkgStr - pkgInfoList <- - Exception.evaluate pkgs - `catchError` - (\e-> ioError $ userError $ "parsing " ++ dbFile ++ ": " ++ (show e)) - return [(takeDirectory dbFile, pkgInfoList)] - --- GHC.Path sets libdir for us... -getLibDir :: String -getLibDir = libdir diff --git a/src/Scion/PersistentBrowser/Build.hs b/src/Scion/PersistentBrowser/Build.hs --- a/src/Scion/PersistentBrowser/Build.hs +++ b/src/Scion/PersistentBrowser/Build.hs @@ -6,6 +6,7 @@ , updateDatabase , createCabalDatabase , getCabalHoogle +, runSQL ) where import Control.Concurrent.ParallelIO.Local @@ -33,7 +34,10 @@ import Text.ParserCombinators.ReadP import Control.Monad (unless) import Control.Monad.Trans.Resource (runResourceT) +import Network.HTTP.Conduit +import qualified Data.ByteString as BS + --baseDbUrl :: String --baseDbUrl = "http://haskell.org/hoogle/base.txt" -- @@ -79,7 +83,7 @@ -- Parse Hoogle database createDirectoryIfMissing True hoogleDbDir logToStdout "Started downloading Hoogle database" - Just hoogleDownloaded <- downloadFileLazy hoogleDbUrl + hoogleDownloaded <- downloadFileLazy hoogleDbUrl logToStdout "Uncompressing Hoogle database" unTarGzip hoogleDownloaded hoogleDbDir logToStdout $ "Hoogle database is now in " ++ hoogleDbDir @@ -103,13 +107,19 @@ -} return (pkgs, errors) +-- | Run SQL on the given path +runSQL :: FilePath -> SQL a -> IO a +runSQL file f= runResourceT $ runLogging $ withSqliteConn (T.pack file) $ runSqlConn f + -- | Updates a database with changes in the installed package base. updateDatabase :: FilePath -> [InstalledPackageInfo] -> IO () -updateDatabase file pkgInfo = runResourceT $ runLogging $ withSqliteConn (T.pack file) $ runSqlConn $ updateDatabase' pkgInfo +updateDatabase file pkgInfo = do + hoogleDir <- getHoogleDir file + runSQL file $ updateDatabase' hoogleDir pkgInfo -- runStderrLoggingT $ -updateDatabase' :: [InstalledPackageInfo] -> SQL () -updateDatabase' pkgInfo = +updateDatabase' :: FilePath -> [InstalledPackageInfo] -> SQL () +updateDatabase' hoogleDir pkgInfo = do dbPersistent <- selectList ([] :: [Filter DbPackage]) [] let dbList = map (fromDbToPackageIdentifier . entityVal) dbPersistent installedList = nub $ removeSmallVersions $ map sourcePackageId pkgInfo @@ -121,7 +131,7 @@ unless (null toAdd) ( liftIO $ logToStdout $ "Adding " ++ show (map (\(PackageIdentifier (PackageName name) _) -> name) toAdd)) let ghcVersion = getGhcInstalledVersion installedList - (addedDb, errors) <- liftIO $ createCabalDatabase' ghcVersion toAdd True + (addedDb, errors) <- liftIO $ createCabalDatabase' ghcVersion hoogleDir toAdd True mapM_ savePackageToDb addedDb unless (null errors) (liftIO $ logToStdout $ show errors) @@ -129,7 +139,7 @@ fromDbToPackageIdentifier (DbPackage name version _) = PackageIdentifier (PackageName name) (getVersion version) getVersion :: String -> Version -getVersion version = (fst . last . readP_to_S parseVersion) version +getVersion = fst . last . readP_to_S parseVersion removeSmallVersions :: [PackageIdentifier] -> [PackageIdentifier] removeSmallVersions pids = filter @@ -138,24 +148,25 @@ pids -- | Get the database from a set of Cabal packages. -createCabalDatabase :: Version -> [PackageIdentifier] -> IO ([Documented Package], [(String, ParseError)]) -createCabalDatabase ghcVersion pkgs = createCabalDatabase' ghcVersion pkgs False +createCabalDatabase :: Version -> FilePath -> [PackageIdentifier] -> IO ([Documented Package], [(String, ParseError)]) +createCabalDatabase ghcVersion hoogleDir pkgs = createCabalDatabase' ghcVersion hoogleDir pkgs False -- | Get the database from a set of Cabal packages. -- If `ifFailCreateEmpty' is set, when a package gives a parse error, -- it is converted into an empty package with a note. -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) +createCabalDatabase' :: Version -> FilePath -> [PackageIdentifier] -> Bool -> IO ([Documented Package], [(String, ParseError)]) +createCabalDatabase' ghcVersion hoogleDir pkgs ifFailCreateEmpty = + withTemporaryDirectory $ \tmp -> + withManager $ \mgr -> + do + let toExecute = map (\pid -> do + db <- getCabalHoogle ghcVersion hoogleDir pid ifFailCreateEmpty tmp mgr + return (pkgString pid, db)) + pkgs + eitherHooglePkgs <- liftIO $ withThreaded $ \pool -> parallelInterleavedE pool toExecute + let hooglePkgs = rights eitherHooglePkgs + (db, errors) = partitionPackages hooglePkgs + return (db, errors) -- commented out for now (see https://github.com/haskell/HTTP/pull/26) -- pr<-fetchProxy False -- download everything in one browser session @@ -175,9 +186,9 @@ -- no liftIO but ioAction $ -- | Get the database from a Cabal package. -getCabalHoogle :: Version -> PackageIdentifier -> Bool -> FilePath -> IO(Either ParseError (Documented Package)) -getCabalHoogle ghcVersion pid ifFailCreateEmpty tmp = do - result <- getCabalHoogle' ghcVersion pid tmp +getCabalHoogle :: Version -> FilePath -> PackageIdentifier -> Bool -> FilePath -> Manager -> IO(Either ParseError (Documented Package)) +getCabalHoogle ghcVersion hoogleDir pid ifFailCreateEmpty tmp mgr = do + result <- getCabalHoogle' ghcVersion hoogleDir pid tmp mgr case result of Left e -> return $ failure e Right (Package doc _ info) -> return $ Right (Package doc pid info) @@ -189,22 +200,28 @@ else Left e -- | Get the database from a Cabal package. -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 "" cnts - Just cnts -> return $ parseHoogleString "" cnts +getCabalHoogle' :: Version -> FilePath -> PackageIdentifier -> FilePath -> Manager -> IO (Either ParseError (Documented Package)) +getCabalHoogle' ghcVersion hoogleDir pid tmp mgr = do + let downUrl1 = getPackageUrlHackage pid + let pkgV = pkgString pid + logToStdout $ "Download " ++ downUrl1 + tryDownload1 <- downloadHoogleFile mgr downUrl1 + case tryDownload1 of + Nothing -> do let downUrl2 = getPackageUrlGhcLibs ghcVersion pid + logToStdout $ "Download " ++ downUrl2 + tryDownload2 <- downloadHoogleFile mgr downUrl2 + case tryDownload2 of + Nothing -> getCabalHoogleLocal hoogleDir pid tmp + Just cnts -> do + BS.writeFile (hoogleDir addExtension pkgV "txt") cnts + return $ parseHoogleString "" cnts + Just cnts -> do + BS.writeFile (hoogleDir addExtension pkgV "txt") cnts + return $ parseHoogleString "" cnts -- | Get the database from a locally installed Cabal package. -getCabalHoogleLocal :: PackageIdentifier -> FilePath -> IO (Either ParseError (Documented Package)) -getCabalHoogleLocal pid tmp = +getCabalHoogleLocal :: FilePath -> PackageIdentifier -> FilePath -> IO (Either ParseError (Documented Package)) +getCabalHoogleLocal hoogleDir pid tmp = do let pkgV = pkgString pid (PackageName pkg) = pkgName pid logToStdout $ "Parsing " ++ pkgV @@ -218,6 +235,7 @@ do executeCommand pkgdir "cabal" ["configure"] True executeCommand pkgdir "cabal" ["haddock", "--hoogle"] True let hoogleFile = pkgdir "dist" "doc" "html" pkg (pkg ++ ".txt") + copyFile hoogleFile $ hoogleDir takeFileName hoogleFile parseHoogleFile hoogleFile pkgString :: PackageIdentifier -> String diff --git a/src/Scion/PersistentBrowser/FileUtil.hs b/src/Scion/PersistentBrowser/FileUtil.hs --- a/src/Scion/PersistentBrowser/FileUtil.hs +++ b/src/Scion/PersistentBrowser/FileUtil.hs @@ -1,22 +1,17 @@ -{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface #-} +{-# LANGUAGE ScopedTypeVariables,OverloadedStrings #-} module Scion.PersistentBrowser.FileUtil where +import Control.Applicative import qualified Codec.Archive.Tar as Tar import qualified Codec.Compression.GZip as GZip import Control.Exception (bracket) import qualified Data.ByteString as SBS -import qualified Data.ByteString.Char8 as SBS8 import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as LBS8 -import Data.List (isPrefixOf) -import Network.Browser -import Network.HTTP -import Network.HTTP.Proxy import System.Directory import System.FilePath import Scion.PersistentBrowser.TempFile -import Scion.PersistentBrowser.Util (logToStdout) +import Network.HTTP.Conduit -- |Takes out the "." and ".." special directory -- entries from a list of file paths. @@ -24,43 +19,42 @@ filterDots = filter (\d -> d /= "." && d /= "..") -- |Downloads a file from the internet. -downloadFileLazy :: String -> IO (Maybe LBS.ByteString) -downloadFileLazy url = do - response <- fetchURL url - return $ Just (LBS8.pack response) +downloadFileLazy :: String -> IO LBS.ByteString +downloadFileLazy = simpleHttp -- |Downloads a file from the internet. -downloadFileStrict :: String -> IO (Maybe SBS.ByteString) -downloadFileStrict url = do - response <- fetchURL url - return $ Just (SBS8.pack response) +downloadFileStrict :: String -> IO SBS.ByteString +downloadFileStrict = (LBS.toStrict <$>) . downloadFileLazy + -- |Downloads a file from the internet and check it's a Hoogle file. -downloadHoogleFile :: String -> IO (Maybe SBS.ByteString) -downloadHoogleFile url = do - response <- fetchURL url - return $ getHoogleFile response +downloadHoogleFile :: Manager -> String -> IO (Maybe SBS.ByteString) +downloadHoogleFile mgr url = do + req <- parseUrl url + getHoogleFile <$> LBS.toStrict <$> responseBody <$> httpLbs req mgr + -downloadHoogleFile' :: String -> BrowserAction (HandleStream String) (Maybe SBS.ByteString) -downloadHoogleFile' url = do - (_,res) <- request $ getRequest url - return $ getHoogleFile $ rspBody res -getHoogleFile :: String -> Maybe SBS.ByteString -getHoogleFile response=if "-- Hoogle documentation" `isPrefixOf` response - then Just (SBS8.pack response) +--downloadHoogleFile' :: String -> BrowserAction (HandleStream String) (Maybe SBS.ByteString) +--downloadHoogleFile' url = do +-- (_,res) <- request $ getRequest url +-- return $ getHoogleFile $ rspBody res + +getHoogleFile :: SBS.ByteString -> Maybe SBS.ByteString +getHoogleFile response=if "-- Hoogle documentation" `SBS.isPrefixOf` response + then Just response else Nothing -- |Downloads a file from the internet, using the system proxy -fetchURL :: String -> IO (String) -fetchURL url=do - pr<-fetchProxy False - (_,res) <- browse $ do - setErrHandler logToStdout - setOutHandler logToStdout - setProxy pr - request $ getRequest url - return $ rspBody res +--fetchURL :: String -> IO (String) +--fetchURL url=do +-- pr<-fetchProxy False +-- (_,res) <- browse $ do +-- setErrHandler logToStdout +-- setOutHandler logToStdout +-- setProxy pr +-- request $ getRequest url +-- return $ rspBody res -- |Un-gzip and un-tar a file into a folder. unTarGzip :: LBS.ByteString -> FilePath -> IO () diff --git a/src/Scion/PersistentBrowser/FromMissingH.hs b/src/Scion/PersistentBrowser/FromMissingH.hs --- a/src/Scion/PersistentBrowser/FromMissingH.hs +++ b/src/Scion/PersistentBrowser/FromMissingH.hs @@ -2,7 +2,7 @@ -- But MissingH does not build in 7.2.1 yet, so I included them here. module Scion.PersistentBrowser.FromMissingH where -import Data.List (intersperse, isPrefixOf) +import Data.List (isPrefixOf, intercalate) -- From Data.List.Utils @@ -14,7 +14,7 @@ {- | Removes all (key, value) pairs from the given list where the key matches the given one. -} delFromAL :: Eq key => [(key, a)] -> key -> [(key, a)] -delFromAL l key = filter (\a -> (fst a) /= key) l +delFromAL l key = filter (\a -> fst a /= key) l -- From Data.String.Utils @@ -67,7 +67,7 @@ firstline : case remainder of [] -> [] x -> if x == delim - then [] : [] + then [[]] else split delim (drop (length delim) x) @@ -84,15 +84,5 @@ -} replace :: Eq a => [a] -> [a] -> [a] -> [a] -replace old new l = join new . split old $ l - -{- | Given a delimiter and a list of items (or strings), join the items -by using the delimiter. - -Example: - -> join "|" ["foo", "bar", "baz"] -> "foo|bar|baz" --} -join :: [a] -> [[a]] -> [a] -join delim l = concat (intersperse delim l) +replace old new l = intercalate new . split old $ l diff --git a/src/Scion/PersistentBrowser/Parser.hs b/src/Scion/PersistentBrowser/Parser.hs --- a/src/Scion/PersistentBrowser/Parser.hs +++ b/src/Scion/PersistentBrowser/Parser.hs @@ -41,13 +41,16 @@ -- the documentation of the entire package, or the corresponding -- error during the parsing. parseHoogleFile :: FilePath -> IO (Either ParseError (Documented Package)) -parseHoogleFile fname = (withFile fname ReadMode $ - \hnd -> do c <- BS.hGetContents hnd - return $ parseHoogleString fname c - ) - `catchIOError` - (\_ -> return $ Left (newErrorMessage (Message "error reading file") - (newPos fname 0 0))) +parseHoogleFile fname = withFile fname ReadMode + (\ hnd -> + do c <- BS.hGetContents hnd + return $ parseHoogleString fname c) + `catchIOError` + (\ _ -> + return $ + Left + (newErrorMessage (Message "error reading file") + (newPos fname 0 0))) -- | Parses a entire directory of Hoogle documentation files -- which must be following the format of the Hackage @@ -66,11 +69,11 @@ vDirs <- mapM getVersionDirectory dirs let innerDirs = map (\d -> d "doc" "html") (concat vDirs) -- Parse directories recursively - let toExecute = map (\innerDir -> parseDirectoryFiles innerDir tmpdir) innerDirs + let toExecute = map (`parseDirectoryFiles` tmpdir) innerDirs eitherDPackages <- withThreaded $ \pool -> parallelInterleavedE pool toExecute let dPackages = rights eitherDPackages - dbs = concat $ map fst dPackages - errors = concat $ map snd dPackages + dbs = concatMap fst dPackages + errors = concatMap snd dPackages return (dbs, errors) getVersionDirectory :: FilePath -> IO [FilePath] diff --git a/src/Scion/PersistentBrowser/Query.hs b/src/Scion/PersistentBrowser/Query.hs --- a/src/Scion/PersistentBrowser/Query.hs +++ b/src/Scion/PersistentBrowser/Query.hs @@ -127,9 +127,9 @@ Nothing -> [modName] Just (DbPackageIdentifier pkgName pkgVersion) -> [modName, pkgName, pkgVersion] elts <- queryDb sql args action - completeElts <- mapM (\(dclId, dcl, p) -> do dclAll <- getAllDeclInfo (dclId, dcl) - return (p, dclAll)) elts - return completeElts + mapM (\(dclId, dcl, p) -> do + dclAll <- getAllDeclInfo (dclId, dcl) + return (p, dclAll)) elts where action :: [PersistValue] -> (DbDeclId, DbDecl, DbPackageIdentifier) action [declId@(PersistInt64 _), PersistText declType, PersistText name , doc, kind, signature, equals, modId@(PersistInt64 _) @@ -154,18 +154,18 @@ ++ " FROM DbDecl, DbModule, DbPackage" ++ " WHERE DbDecl.moduleId = DbModule.id AND DbModule.packageId = DbPackage.id" - ++ (if null prefix then "" else (" AND (DbDecl.name LIKE '" + ++ (if null prefix then "" else " AND (DbDecl.name LIKE '" ++ prefix ++ "%' or DbDecl.id in (select DbConstructor.declId from DbConstructor where DbConstructor.name LIKE '" - ++ prefix ++ "%'))")) + ++ prefix ++ "%'))") ++ pkg let args = case pkgId of Nothing -> [] Just (DbPackageIdentifier pkgName pkgVersion) -> [pkgName, pkgVersion] elts <- queryDb sql args action - completeElts <- mapM (\(dclId, dcl, p,m) -> do cs <- consts dclId - let dclAll=DbCompleteDecl dcl [] [] [] cs - return (p,m, dclAll)) elts - return completeElts + mapM (\(dclId, dcl, p,m) -> do + cs <- consts dclId + let dclAll=DbCompleteDecl dcl [] [] [] cs + return (p,m, dclAll)) elts where action :: [PersistValue] -> (DbDeclId, DbDecl, DbPackageIdentifier, DbModule) action [declId@(PersistInt64 _), PersistText declType, PersistText name , doc, kind, signature, equals, modId@(PersistInt64 _) diff --git a/src/Scion/PersistentBrowser/TempFile.hs b/src/Scion/PersistentBrowser/TempFile.hs --- a/src/Scion/PersistentBrowser/TempFile.hs +++ b/src/Scion/PersistentBrowser/TempFile.hs @@ -211,7 +211,7 @@ r <- Exc.try $ mkPrivateDir dirpath case r of Right _ -> return dirpath - Left (e::Exc.IOException) | Exc.AlreadyExists == (Exc.ioe_type e) -> findTempName (x+1) + Left (e::Exc.IOException) | Exc.AlreadyExists == Exc.ioe_type e -> findTempName (x+1) | otherwise -> ioError e mkPrivateDir :: String -> IO () diff --git a/src/Scion/PersistentBrowser/ToDb.hs b/src/Scion/PersistentBrowser/ToDb.hs --- a/src/Scion/PersistentBrowser/ToDb.hs +++ b/src/Scion/PersistentBrowser/ToDb.hs @@ -17,11 +17,19 @@ -- ====================== -- savePackageToDb :: PersistBackend backend m => Documented Package -> backend m () +savePackageToDb :: forall (m :: * -> *). + PersistStore m => + Package Doc -> m () savePackageToDb (Package doc (PackageIdentifier (PackageName name) version) modules) = do pkgId <- insert $ DbPackage name (showVersion version) (docToString doc) mapM_ (saveModuleToDb pkgId) (M.elems modules) -- saveModuleToDb :: PersistBackend backend m => DbPackageId -> Documented Module -> backend m () +saveModuleToDb :: forall (m :: * -> *). + PersistStore m => + KeyBackend + (PersistMonadBackend m) (DbPackageGeneric (PersistMonadBackend m)) + -> Module Doc -> m () saveModuleToDb pkgId (Module doc (Just (ModuleHead _ (ModuleName _ name)_ _)) _ _ decls) = do moduleId <- insert $ DbModule name (docToString doc) pkgId mapM_ (saveDeclToDb moduleId) decls @@ -29,6 +37,11 @@ -- saveDeclToDb :: PersistBackend backend m => DbModuleId -> Documented Decl -> backend m () -- Datatypes +saveDeclToDb :: forall (m :: * -> *). + PersistStore m => + KeyBackend + (PersistMonadBackend m) (DbModuleGeneric (PersistMonadBackend m)) + -> Decl Doc -> m () saveDeclToDb moduleId (GDataDecl doc (DataType _) ctx hd kind decls _) = do let (declName, declVars) = declHeadToDb hd declId <- insert $ DbDecl DbData declName (docToString doc) @@ -80,16 +93,33 @@ -- Other saveDeclToDb _ t = error $ "saveDeclToDb: This should never happen" ++ (show t) --- saveTyVarToDb :: PersistBackend backend m => DbDeclId -> String -> backend m () +saveTyVarToDb :: forall (m :: * -> *). + PersistStore m => + KeyBackend + (PersistMonadBackend m) (DbDeclGeneric (PersistMonadBackend m)) + -> String -> m (Key (DbTyVarGeneric (PersistMonadBackend m))) saveTyVarToDb declId var = insert $ DbTyVar var declId --- saveFunDepToDb :: PersistBackend backend m => DbDeclId -> String -> backend m () +saveFunDepToDb :: forall (m :: * -> *). + PersistStore m => + KeyBackend + (PersistMonadBackend m) (DbDeclGeneric (PersistMonadBackend m)) + -> String -> m (Key (DbTyVarGeneric (PersistMonadBackend m))) saveFunDepToDb declId var = insert $ DbTyVar var declId --- saveContextToDb :: PersistBackend backend m => DbDeclId -> String -> backend m () +saveContextToDb :: forall (m :: * -> *). + PersistStore m => + KeyBackend + (PersistMonadBackend m) (DbDeclGeneric (PersistMonadBackend m)) + -> String -> m (Key (DbContextGeneric (PersistMonadBackend m))) saveContextToDb declId ctx = insert $ DbContext ctx declId --- saveConstructorToDb :: PersistBackend backend m => DbDeclId -> Documented GadtDecl -> backend m () +saveConstructorToDb :: forall (m :: * -> *) l. + (SrcInfo l, PersistStore m) => + KeyBackend + (PersistMonadBackend m) (DbDeclGeneric (PersistMonadBackend m)) + -> GadtDecl l + -> m (Key (DbConstructorGeneric (PersistMonadBackend m))) #if MIN_VERSION_haskell_src_exts(1,16,0) saveConstructorToDb declId (GadtDecl _ name _ ty) = insert $ DbConstructor (getNameString name) (singleLinePrettyPrint ty) declId #else @@ -98,25 +128,39 @@ -- DELETE PACKAGE FROM DATABASE -- ============================ --- deletePackageByInfo :: PersistBackend backend m => PackageIdentifier -> backend m () +deletePackageByInfo :: forall (m :: * -> *). + PersistQuery m => + PackageIdentifier -> m () deletePackageByInfo (PackageIdentifier (PackageName name) version) = do Just pkg <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. showVersion version ] [] let pkgId = entityKey pkg deletePackage pkgId --- deletePackage :: PersistBackend backend m => DbPackageId -> backend m () +deletePackage :: forall (m :: * -> *). + PersistQuery m => + KeyBackend + (PersistMonadBackend m) (DbPackageGeneric (PersistMonadBackend m)) + -> m () deletePackage pkgId = do modules <- selectList [ DbModulePackageId ==. pkgId ] [] mapM_ (deleteModule . entityKey) modules delete pkgId --- deleteModule :: PersistBackend backend m => DbModuleId -> backend m () +deleteModule :: forall (m :: * -> *). + PersistQuery m => + KeyBackend + (PersistMonadBackend m) (DbModuleGeneric (PersistMonadBackend m)) + -> m () deleteModule moduleId = do decls <- selectList [ DbDeclModuleId ==. moduleId ] [] mapM_ (deleteDecl . entityKey) decls delete moduleId --- deleteDecl :: PersistBackend backend m => DbModuleId -> backend m () +deleteDecl :: forall (m :: * -> *). + PersistQuery m => + KeyBackend + (PersistMonadBackend m) (DbDeclGeneric (PersistMonadBackend m)) + -> m () deleteDecl declId = do deleteWhere [ DbTyVarDeclId ==. declId ] deleteWhere [ DbFunDepDeclId ==. declId ] diff --git a/src/Scion/PersistentBrowser/Util.hs b/src/Scion/PersistentBrowser/Util.hs --- a/src/Scion/PersistentBrowser/Util.hs +++ b/src/Scion/PersistentBrowser/Util.hs @@ -8,7 +8,16 @@ import System.Process import Text.Parsec.Error (ParseError) import GHC.Conc (numCapabilities) +import System.FilePath +import System.Directory +-- | Get the Hoogle dir from the db file +getHoogleDir :: FilePath -> IO FilePath +getHoogleDir file = do + let hoogleDir = takeDirectory file "hoogle" + createDirectoryIfMissing True hoogleDir + return hoogleDir + withThreaded :: (Pool -> IO a) -> IO a withThreaded = withPool numCapabilities @@ -49,6 +58,6 @@ escapeSql :: String -> String escapeSql [] = "" -escapeSql ('\'':cs) = '\'':'\'':(escapeSql cs) -escapeSql (c:cs) = c:(escapeSql cs) +escapeSql ('\'':cs) = '\'':'\'' : escapeSql cs +escapeSql (c:cs) = c : escapeSql cs diff --git a/src/Scion/PersistentHoogle.hs b/src/Scion/PersistentHoogle.hs --- a/src/Scion/PersistentHoogle.hs +++ b/src/Scion/PersistentHoogle.hs @@ -2,14 +2,18 @@ ( query , downloadData , checkDatabase +, initDatabase , module Scion.PersistentHoogle.Types ) where +import Control.Applicative import Control.Monad import Control.Monad.IO.Class (liftIO) import Scion.PersistentBrowser () import Scion.PersistentBrowser.Util import Scion.PersistentBrowser.DbTypes +import Scion.PersistentBrowser.Build +import Scion.PersistentBrowser.Types import Scion.PersistentHoogle.Types import Scion.PersistentHoogle.Instances.Json () @@ -17,48 +21,101 @@ import Scion.PersistentHoogle.Util import System.Exit (ExitCode(..)) import System.Process +import System.Directory +import System.FilePath import Text.Parsec.Prim (runP) +import Scion.PersistentBrowser.Parser (parseHoogleFile) +import Data.Maybe (catMaybes) +import Data.Either +import Scion.PersistentBrowser.ToDb (savePackageToDb, deletePackageByInfo) +import Scion.PersistentBrowser.FileUtil (withWorkingDirectory) -query :: Maybe String -> String -> SQL [Result] -query p q = do mpath <- liftIO $ findHoogleBinPath p - case mpath of - Nothing -> return [] - Just path -> do (exitCode, output, err) <- liftIO $ readProcessWithExitCode path [q] "" - case exitCode of - ExitSuccess -> do - liftIO $ logToStdout q - liftIO $ logToStdout output - let search = runP hoogleElements () "hoogle-output" output - case search of - Right result -> result - Left perr -> do - liftIO $ logToStdout $ show perr -- I like to see the error in the log - return [] - _ -> do liftIO $ logToStdout err -- I like to see the error in the log - return [] +query :: FilePath -> Maybe FilePath -> Maybe FilePath -> String -> SQL [Result] +query hoogleDir msandbox p q = do + mpath <- liftIO $ findHoogleBinPath msandbox p + case mpath of + Nothing -> return [] + Just path -> do (exitCode, output, err) <- liftIO $ readProcessWithExitCode path [q,"-d",hoogleDir] "" + case exitCode of + ExitSuccess -> do + liftIO $ logToStdout q + liftIO $ logToStdout output + let search = runP hoogleElements () "hoogle-output" output + case search of + Right result -> result + Left perr -> do + liftIO $ logToStdout $ show perr -- I like to see the error in the log + return [] + _ -> do liftIO $ logToStdout err -- I like to see the error in the log + return [] -downloadData :: Maybe String -> IO HoogleStatus -downloadData p = do mpath <- findHoogleBinPath p - case mpath of - Nothing -> return Missing - Just path -> do logToStdout "Downloading hoogle data..." - (ec, _, err) <- readProcessWithExitCode path ["data"] "" - when (ec/= ExitSuccess) (do - logToStdout path - logToStdout err) - return $ case ec of - ExitSuccess->OK - _-> Error +downloadData :: FilePath -> Maybe FilePath -> Maybe FilePath -> IO HoogleStatus +downloadData hoogleDir msandbox p = do + mpath <- findHoogleBinPath msandbox p + case mpath of + Nothing -> return Missing + Just path -> do logToStdout "Downloading hoogle data..." + (ec, _, err) <- readProcessWithExitCode path ["data","-d",hoogleDir] "" + when (ec/= ExitSuccess) (do + logToStdout path + logToStdout err) + return $ case ec of + ExitSuccess->OK + _-> Error -checkDatabase :: Maybe String -> IO HoogleStatus -checkDatabase p = do mpath <- findHoogleBinPath p - case mpath of - Nothing -> return Missing - Just path -> do (ec, _, err) <- readProcessWithExitCode path ["fmap"] "" - when (ec/= ExitSuccess) (do - logToStdout path - logToStdout err) - return $ case ec of - ExitSuccess->OK - _-> Error +checkDatabase :: FilePath -> Maybe FilePath -> Maybe FilePath -> IO HoogleStatus +checkDatabase hoogleDir msandbox p = do + mpath <- findHoogleBinPath msandbox p + case mpath of + Nothing -> return Missing + Just path -> do (ec, _, err) <- readProcessWithExitCode path ["fmap","-d",hoogleDir] "" + when (ec/= ExitSuccess) (do + logToStdout path + logToStdout err) + return $ case ec of + ExitSuccess->OK + _-> Error +-- | Init hoogle DB, adding extra files +initDatabase :: FilePath -> Maybe FilePath -> Maybe FilePath -> Bool-> IO HoogleStatus +initDatabase localDB msandbox p addToDb = do + hoogleDir <- getHoogleDir localDB + mpath <- findHoogleBinPath msandbox p + case mpath of + Nothing -> return Missing + Just path -> + withWorkingDirectory hoogleDir $ do + ok <- exec path ["fmap","-d",hoogleDir] + unless ok (do + exec path ["data","-d",hoogleDir] + return () + ) + txts <- filter ((".txt" ==) . takeExtension) <$> getDirectoryContents hoogleDir + docs <- forM txts $ \f -> do + ret <- if addToDb + then Just <$> parseHoogleFile (hoogleDir f) + else return Nothing + ok1 <- exec path ["convert",hoogleDir f] + when ok1 $ removeFile f + return ret + let (errors,okDocs) = partitionEithers $ catMaybes docs + unless (null errors) $ logToStdout $ "addtoDB errors:" ++ show errors + unless (null okDocs) $ runSQL localDB $ do + mapM_ (deletePackageByInfo . (\ (Package _ pkgid _) -> pkgid)) okDocs + mapM_ savePackageToDb okDocs + hoos <- filter (("default.hoo" /=) . takeFileName) <$> filter ((".hoo" ==) . takeExtension) <$> getDirectoryContents hoogleDir + unless (null hoos) $ do + ok2 <- exec path ("combine":hoos) + when ok2 $ forM_ hoos removeFile + return OK + +-- | Exec process and dump error +exec :: FilePath -> [String] -> IO Bool +exec path args= do + (ec, _, err) <- readProcessWithExitCode path args "" + when (ec/= ExitSuccess) (do + logToStdout path + logToStdout err) + return $ case ec of + ExitSuccess -> True + _ -> False diff --git a/src/Scion/PersistentHoogle/Parser.hs b/src/Scion/PersistentHoogle/Parser.hs --- a/src/Scion/PersistentHoogle/Parser.hs +++ b/src/Scion/PersistentHoogle/Parser.hs @@ -81,20 +81,20 @@ return (name, rest)) hooglePackageName :: BSParser String -hooglePackageName = do string "package" - spaces1 - name <- restOfLine - spaces0 - return name +hooglePackageName = string "package" >> restIsName -- | handle a keyword. For example searching for 'id' gives 'keyword hiding' in the results hoogleKeyword :: BSParser String -hoogleKeyword = do string "keyword" - spaces1 - name <- restOfLine - spaces0 - return name +hoogleKeyword = string "keyword" >> restIsName +-- | Rest of the line is a name +restIsName :: BSParser String +restIsName = do + spaces1 + name <- restOfLine + spaces0 + return name + convertHalfToResult :: HalfResult -> SQL (Maybe Result) convertHalfToResult (HalfKeyword kw) = return $ Just (RKeyword kw) diff --git a/src/Scion/PersistentHoogle/Util.hs b/src/Scion/PersistentHoogle/Util.hs --- a/src/Scion/PersistentHoogle/Util.hs +++ b/src/Scion/PersistentHoogle/Util.hs @@ -10,47 +10,49 @@ import Distribution.InstalledPackageInfo import Distribution.Package import Distribution.Simple.InstallDirs -import Scion.Packages +import Language.Haskell.Packages import System.FilePath import System.Directory (doesFileExist, getAppUserDataDirectory, getHomeDirectory) -- Functions for finding Hoogle in the system -findHoogleBinPath :: Maybe String -> IO (Maybe String) -findHoogleBinPath extraPath = do - p1 <- findHoogleBinInLibrary getHoogleBinPath1 - p2 <- findHoogleBinInLibrary getHoogleBinPath2 +findHoogleBinPath :: Maybe FilePath -> Maybe FilePath -> IO (Maybe String) +findHoogleBinPath msandbox extraPath = do + p1 <- findHoogleBinInLibrary msandbox getHoogleBinPath1 + p2 <- findHoogleBinInLibrary msandbox getHoogleBinPath2 p3 <- getHoogleBinPathCabalAPI p4 <- getHoogleBinPathCabalDir p5 <- getHoogleBinPathMacOsDir - let placesToSearch = (catMaybes [extraPath, p1, p2]) ++ [p4, p5] ++ p3 + let placesToSearch = catMaybes [extraPath, p1, p2] ++ [p4, p5] ++ p3 findPathsAndCheck placesToSearch -findPathsAndCheck :: [String] -> IO (Maybe String) +findPathsAndCheck :: [FilePath] -> IO (Maybe String) findPathsAndCheck [] = return Nothing findPathsAndCheck (f:fs) = do r <- findPathAndCheck f case r of Nothing -> findPathsAndCheck fs _ -> return r -findPathAndCheck :: String -> IO (Maybe String) +findPathAndCheck :: FilePath -> IO (Maybe String) findPathAndCheck path = do exists <- doesFileExist path - if exists - then return (Just path) - else return Nothing + return $ if exists + then Just path + else Nothing -findHoogleBinInLibrary :: (String -> String) -> IO (Maybe String) -findHoogleBinInLibrary f = do minfo <- findHoogleInfo - case minfo of - Nothing -> return Nothing - Just info -> let [libDir] = libraryDirs info - in return $ Just (f libDir) +findHoogleBinInLibrary :: Maybe FilePath -> (String -> String) -> IO (Maybe String) +findHoogleBinInLibrary msandbox f = do + minfo <- findHoogleInfo msandbox + case minfo of + Nothing -> return Nothing + Just info -> let [libDir] = libraryDirs info + in return $ Just (f libDir) -findHoogleInfo :: IO (Maybe InstalledPackageInfo) -findHoogleInfo = do infos' <- getPkgInfos - let infos = removeSmallVersions $ concat $ map snd infos' - return $ find (\m -> (pkgName (sourcePackageId m)) == PackageName "hoogle") infos +findHoogleInfo :: Maybe FilePath -> IO (Maybe InstalledPackageInfo) +findHoogleInfo msandbox = do + infos' <- getPkgInfos msandbox + let infos = removeSmallVersions $ concatMap snd infos' + return $ find (\m -> pkgName (sourcePackageId m) == PackageName "hoogle") infos removeSmallVersions :: [InstalledPackageInfo] -> [InstalledPackageInfo] removeSmallVersions pids = filter @@ -62,11 +64,11 @@ getHoogleBinPath1 :: String -> String getHoogleBinPath1 path = let (_:(_:(_:rest))) = reverse $ splitDirectories path - in (joinPath $ reverse ("bin":rest)) "hoogle" <.> exeExtension + in joinPath (reverse ("bin" : rest)) "hoogle" <.> exeExtension getHoogleBinPath2 :: String -> String getHoogleBinPath2 path = let (_:(_:rest)) = reverse $ splitDirectories path - in (joinPath $ reverse ("bin":rest)) "hoogle" <.> exeExtension + in joinPath (reverse ("bin" : rest)) "hoogle" <.> exeExtension getHoogleBinPathCabalAPI :: IO [String] getHoogleBinPathCabalAPI = do diff --git a/src/Server/PersistentCommands.hs b/src/Server/PersistentCommands.hs --- a/src/Server/PersistentCommands.hs +++ b/src/Server/PersistentCommands.hs @@ -14,23 +14,24 @@ import Scion.PersistentBrowser.Build --import Scion.PersistentBrowser.DbTypes import Scion.PersistentBrowser.Query -import Scion.PersistentBrowser.Util (logToStdout) +import Scion.PersistentBrowser.Util (logToStdout,getHoogleDir) import qualified Scion.PersistentHoogle as H -import Scion.Packages +import Language.Haskell.Packages import System.Directory import Control.Monad.Trans.Resource (runResourceT) import Data.List (nub) import Data.Vector (fromList) -data Command = LoadLocalDatabase FilePath Bool +data Command = LoadLocalDatabase FilePath Bool (Maybe FilePath) | LoadHackageDatabase FilePath Bool | GetPackages CurrentDatabase | GetModules CurrentDatabase String | GetDeclarations CurrentDatabase String - | HoogleQuery CurrentDatabase String - | HoogleDownloadData - | HoogleCheckDatabase + | HoogleQuery FilePath CurrentDatabase String (Maybe FilePath) + | HoogleDownloadData FilePath (Maybe FilePath) + | HoogleCheckDatabase FilePath (Maybe FilePath) + | HoogleInitDatabase FilePath Bool (Maybe FilePath) | GetDeclarationModules CurrentDatabase String | SetExtraHooglePath String | GetDeclarationsFromPrefix CurrentDatabase String @@ -86,32 +87,30 @@ type BrowserM = StateT BrowserState IO executeCommand :: Command -> BrowserM (Value, Bool) -- Bool indicates if continue receiving commands -executeCommand (LoadLocalDatabase path rebuild) = +executeCommand (LoadLocalDatabase path rebuild msandbox) = do fileExists <- lift $ doesFileExist path - let fileExists' = fileExists `seq` fileExists when rebuild $ lift $ do runResourceT $ runLogging $ withSqliteConn (T.pack path) $ runSqlConn $ do runMigration migrateAll createIndexes - pkgInfos' <- getPkgInfos - let pkgInfos = concat $ map snd pkgInfos' + pkgInfos' <- getPkgInfos msandbox + let pkgInfos = concatMap snd pkgInfos' updateDatabase path pkgInfos - if fileExists' || rebuild -- If the file already existed or was rebuilt + if fileExists || rebuild -- If the file already existed or was rebuilt then do modify (\s -> s { localDb = Just path }) lift $ logToStdout "Local database loaded" else modify (\s -> s { localDb = Nothing }) return (ok, True) executeCommand (LoadHackageDatabase path rebuild) = do fileExists <- lift $ doesFileExist path - let fileExists' = fileExists `seq` fileExists - when (not fileExists' || rebuild) $ - lift $ do when fileExists' (removeFile path) + when (not fileExists || rebuild) $ + lift $ do when fileExists (removeFile path) logToStdout "Rebuilding Hackage database" runResourceT $ runLogging $ withSqliteConn (T.pack path) $ runSqlConn $ do runMigration migrateAll createIndexes saveHackageDatabase path - if fileExists' || rebuild -- If the file already existed or was rebuilt + if fileExists || rebuild -- If the file already existed or was rebuilt then do modify (\s -> s { hackageDb = Just path }) lift $ logToStdout "Hackage database loaded" else modify (\s -> s { hackageDb = Nothing }) @@ -127,16 +126,25 @@ executeCommand (GetDeclarationsFromPrefix cdb prefix) = do decls <- runDb cdb (getDeclsFromPrefix prefix) return (nubJSON decls, True) -executeCommand (HoogleQuery cdb query) = - do extraH <- fmap extraHooglePath get - results <- runDb cdb (\_ -> H.query extraH query) - return (nubJSON results, True) -executeCommand HoogleDownloadData = do extraH <- fmap extraHooglePath get - ret <- lift $ H.downloadData extraH - return (String $ T.pack $ show ret, True) -executeCommand HoogleCheckDatabase = do extraH <- fmap extraHooglePath get - ret <- lift $ H.checkDatabase extraH - return (String $ T.pack $ show ret, True) +executeCommand (HoogleQuery path cdb query msandbox) = do + hoogleDir <- liftIO $ getHoogleDir path + extraH <- fmap extraHooglePath get + results <- runDb cdb (\_ -> H.query hoogleDir msandbox extraH query) + return (nubJSON results, True) +executeCommand (HoogleDownloadData path msandbox) = do + hoogleDir <- liftIO $ getHoogleDir path + extraH <- fmap extraHooglePath get + ret <- lift $ H.downloadData hoogleDir msandbox extraH + return (String $ T.pack $ show ret, True) +executeCommand (HoogleCheckDatabase path msandbox) = do + hoogleDir <- liftIO $ getHoogleDir path + extraH <- fmap extraHooglePath get + ret <- lift $ H.checkDatabase hoogleDir msandbox extraH + return (String $ T.pack $ show ret, True) +executeCommand (HoogleInitDatabase path addToDB msandbox) = do + extraH <- fmap extraHooglePath get + ret <- lift $ H.initDatabase path msandbox extraH addToDB + return (String $ T.pack $ show ret, True) executeCommand (SetExtraHooglePath p) = do modify (\s -> s { extraHooglePath = Just p }) return (ok, True) executeCommand (GetDeclarationModules cdb d) = @@ -156,6 +164,7 @@ case T.unpack e of "load-local-db" -> LoadLocalDatabase <$> v .: "filepath" <*> v .: "rebuild" + <*> v .:? "sandbox" "load-hackage-db" -> LoadHackageDatabase <$> v .: "filepath" <*> v .: "rebuild" "get-packages" -> GetPackages <$> v .: "db" @@ -165,10 +174,18 @@ <*> v .: "module" "get-decl-prefix" -> GetDeclarationsFromPrefix <$>v .: "db" <*> v .: "prefix" - "hoogle-query" -> HoogleQuery <$> v .: "db" - <*> v .: "query" - "hoogle-data" -> pure HoogleDownloadData - "hoogle-check" -> pure HoogleCheckDatabase + "hoogle-query" -> HoogleQuery <$> v .: "filepath" + <*> v .: "db" + <*> v .: "query" + <*> v .:? "sandbox" + "hoogle-data" -> HoogleDownloadData <$> v .: "filepath" + <*> v .:? "sandbox" + "hoogle-check" -> HoogleCheckDatabase <$> v .: "filepath" + <*> v .:? "sandbox" + "hoogle-init" -> HoogleInitDatabase <$> v .: "filepath" + <*> v .:? "addToDB" .!= False + <*> v .:? "sandbox" + "extra-hoogle-path" -> SetExtraHooglePath <$> v .: "path" "get-decl-module" -> GetDeclarationModules <$> v .: "db" <*> v .: "decl"