scion-browser 0.3.5 → 0.4.0
raw patch · 14 files changed
+387/−462 lines, 14 filesdep +ghc-pkg-libdep +http-conduit
Dependencies added: ghc-pkg-lib, http-conduit
Files
- scion-browser.cabal +34/−34
- src/Scion/Packages.hs +0/−209
- src/Scion/PersistentBrowser/Build.hs +55/−37
- src/Scion/PersistentBrowser/FileUtil.hs +30/−36
- src/Scion/PersistentBrowser/FromMissingH.hs +4/−14
- src/Scion/PersistentBrowser/Parser.hs +13/−10
- src/Scion/PersistentBrowser/Query.hs +9/−9
- src/Scion/PersistentBrowser/TempFile.hs +1/−1
- src/Scion/PersistentBrowser/ToDb.hs +52/−8
- src/Scion/PersistentBrowser/Util.hs +11/−2
- src/Scion/PersistentHoogle.hs +97/−40
- src/Scion/PersistentHoogle/Parser.hs +10/−10
- src/Scion/PersistentHoogle/Util.hs +25/−23
- src/Server/PersistentCommands.hs +46/−29
scion-browser.cabal view
@@ -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 <trupill@gmail.com> -maintainer: Alejandro Serrano <trupill@gmail.com>, JP Moresmau (jpmoresmau@gmail.com) +author: Alejandro Serrano <trupill@gmail.com>, JP Moresmau <jpmoresmau@gmail.com>+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)
− src/Scion/Packages.hs
@@ -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
src/Scion/PersistentBrowser/Build.hs view
@@ -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 "<package>" cnts - Just cnts -> return $ parseHoogleString "<package>" 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 "<package>" cnts + Just cnts -> do + BS.writeFile (hoogleDir </> addExtension pkgV "txt") cnts + return $ parseHoogleString "<package>" 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
src/Scion/PersistentBrowser/FileUtil.hs view
@@ -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 ()
src/Scion/PersistentBrowser/FromMissingH.hs view
@@ -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
src/Scion/PersistentBrowser/Parser.hs view
@@ -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]
src/Scion/PersistentBrowser/Query.hs view
@@ -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 _)
src/Scion/PersistentBrowser/TempFile.hs view
@@ -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 ()
src/Scion/PersistentBrowser/ToDb.hs view
@@ -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 ]
src/Scion/PersistentBrowser/Util.hs view
@@ -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
src/Scion/PersistentHoogle.hs view
@@ -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
src/Scion/PersistentHoogle/Parser.hs view
@@ -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)
src/Scion/PersistentHoogle/Util.hs view
@@ -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
src/Server/PersistentCommands.hs view
@@ -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"