diff --git a/scion-browser.cabal b/scion-browser.cabal --- a/scion-browser.cabal +++ b/scion-browser.cabal @@ -1,5 +1,5 @@ name: scion-browser -version: 0.2.3 +version: 0.2.5 cabal-version: >= 1.8 build-type: Simple license: BSD3 @@ -34,9 +34,10 @@ aeson >= 0.4, parallel-io >= 0.3, utf8-string, - persistent, - persistent-sqlite >= 0.6, - persistent-template, + persistent >= 0.7, + persistent-sqlite >= 0.7, + persistent-template >= 0.7, + conduit, transformers, unordered-containers >= 0.1.3, zlib, @@ -112,9 +113,10 @@ aeson >= 0.4, parallel-io >= 0.3, utf8-string, - persistent, - persistent-sqlite >= 0.6, - persistent-template, + persistent >= 0.7, + persistent-sqlite >= 0.7, + persistent-template >= 0.7, + conduit, transformers, unordered-containers >= 0.1.3, zlib, @@ -201,9 +203,10 @@ -- aeson >= 0.4, -- parallel-io >= 0.3, -- utf8-string , --- persistent, --- persistent-sqlite >= 0.6, --- persistent-template, +-- persistent >= 0.7, +-- persistent-sqlite >= 0.7, +-- persistent-template >= 0.7, +-- conduit, -- transformers, -- unordered-containers >= 0.1.3, -- zlib, diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -37,7 +37,7 @@ Atto.Done _ value -> case T.parse parseJSON value of Error e -> outputStrLn ("error in command: " ++ e) >> loop Success cmd -> do (res, continue) <- lift $ executeCommand cmd - let encoded = encode res + let encoded = LBS.append (encode res) "\n" compressed = Zlib.compressWith Zlib.defaultCompressParams { Zlib.compressLevel = Zlib.bestSpeed } encoded liftIO $ LBS.putStr compressed liftIO $ hFlush stdout 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 @@ -109,7 +109,7 @@ updateDatabase' :: [InstalledPackageInfo] -> SqlPersist IO () updateDatabase' pkgInfo = do dbPersistent <- selectList ([] :: [Filter DbPackage]) [] - let dbList = map (fromDbToPackageIdentifier . snd) dbPersistent + let dbList = map (fromDbToPackageIdentifier . entityVal) dbPersistent installedList = nub $ removeSmallVersions $ map sourcePackageId pkgInfo toRemove = dbList \\ installedList toAdd = installedList \\ dbList diff --git a/src/Scion/PersistentBrowser/DbTypes.hs b/src/Scion/PersistentBrowser/DbTypes.hs --- a/src/Scion/PersistentBrowser/DbTypes.hs +++ b/src/Scion/PersistentBrowser/DbTypes.hs @@ -3,7 +3,7 @@ module Scion.PersistentBrowser.DbTypes where import Database.Persist -import Database.Persist.Base +-- import Database.Persist.Base import Database.Persist.Sqlite import Database.Persist.TH @@ -16,6 +16,7 @@ name String version String doc String Maybe + UniqueVersion name version DbModule name String doc String Maybe 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 @@ -16,7 +16,7 @@ import Scion.PersistentBrowser.FileUtil import Scion.PersistentBrowser.Util import System.Directory -import System.FilePath ((), takeFileName) +import System.FilePath (()) import System.IO import Text.Parsec.Error (Message(..), newErrorMessage) import Text.Parsec.Prim (runP) @@ -71,7 +71,7 @@ filterM doesDirectoryExist contents parseDirectoryFiles :: FilePath -> FilePath -> IO ([Documented Package], [(FilePath, ParseError)]) -parseDirectoryFiles dir tmpdir = +parseDirectoryFiles dir _ = do contents' <- getDirectoryContents dir let contents = map (\d -> dir d) (filterDots contents') files <- filterM doesFileExist contents 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 @@ -1,15 +1,17 @@ -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-} module Scion.PersistentBrowser.Query where import qualified Data.Text as T import Database.Persist -import Database.Persist.Base import Database.Persist.Sqlite -import Database.Persist.GenericSql.Raw (withStmt) -import Database.Persist.GenericSql.Internal (RowPopper) +import Database.Persist.Store +import Database.Persist.GenericSql.Raw (withStmt, execute) import Scion.PersistentBrowser.DbTypes -import Scion.PersistentBrowser.Util (escapeSql) +import Scion.PersistentBrowser.Util (logToStdout) +import Control.Monad.IO.Class (liftIO) +import Data.Conduit +import qualified Data.Conduit.List as CL -- |Get the identifiers of all packages in the database. allPackageIds :: Maybe DbPackageIdentifier -> SqlPersist IO [DbPackageIdentifier] @@ -19,52 +21,52 @@ -- |Get information of all packages in the database. allPackages :: Maybe DbPackageIdentifier -> SqlPersist IO [DbPackage] allPackages _ = do packages <- selectList ([] :: [Filter DbPackage]) [] - return $ map snd packages + return $ map entityVal packages -- |Get information of all versions of the package with that name. packagesByName :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [DbPackage] packagesByName name _ = do packages <- selectList [ DbPackageName ==. name ] [] - return $ map snd packages + return $ map entityVal packages -- |Get information about a package in the database. getPackage :: DbPackageIdentifier -> SqlPersist IO (Maybe (DbPackage)) getPackage (DbPackageIdentifier name version) = do package <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. version ] [] - return $ fmap snd package + return $ fmap entityVal package -- |Get information about all modules with that name. modulesByName :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [DbModule] modulesByName name Nothing = do mods <- selectList [ DbModuleName ==. name ] [] - return $ map snd mods + return $ map entityVal mods modulesByName name (Just (DbPackageIdentifier pkgName pkgVersion)) = do let sql = "SELECT DbModule.name, DbModule.doc, DbModule.packageId FROM DbModule, DbPackage" ++ " WHERE DbModule.packageId = DbPackage.id " - ++ " AND DbModule.name = '" ++ (escapeSql name) ++ "'" - ++ " AND DbPackage.name = '" ++ (escapeSql pkgName) ++ "'" - ++ " AND DbPackage.version = '" ++ (escapeSql pkgVersion) ++ "'" - queryDb sql moduleAction + ++ " AND DbModule.name = ?" + ++ " AND DbPackage.name = ?" + ++ " AND DbPackage.version = ?" + queryDb sql [name, pkgName, pkgVersion] moduleAction -- |Get all the modules hierarchically inside the specified one. -- For getting the entire list of modules modules, use "" as initial name. getSubmodules :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [DbModule] getSubmodules "" Nothing = do let sql = "SELECT name, doc, packageId FROM DbModule" - queryDb sql moduleAction + queryDb sql [] moduleAction getSubmodules "" (Just (DbPackageIdentifier pkgName pkgVersion)) = do let sql = "SELECT DbModule.name, DbModule.doc, DbModule.packageId FROM DbModule, DbPackage" ++ " WHERE DbModule.packageId = DbPackage.id " - ++ " AND DbPackage.name = '" ++ (escapeSql pkgName) ++ "'" - ++ " AND DbPackage.version = '" ++ (escapeSql pkgVersion) ++ "'" - queryDb sql moduleAction + ++ " AND DbPackage.name = ?" + ++ " AND DbPackage.version = ?" + queryDb sql [pkgName, pkgVersion] moduleAction getSubmodules modName Nothing = - do let sql = "SELECT name, doc, packageId FROM DbModule WHERE name LIKE '" ++ (escapeSql modName) ++ ".%'" - queryDb sql moduleAction + do let sql = "SELECT name, doc, packageId FROM DbModule WHERE name LIKE ?" + queryDb sql [modName ++ ".%"] moduleAction getSubmodules modName (Just (DbPackageIdentifier pkgName pkgVersion)) = do let sql = "SELECT DbModule.name, DbModule.doc, DbModule.packageId FROM DbModule, DbPackage" - ++ " WHERE name LIKE '" ++ (escapeSql modName) ++ ".%'" + ++ " WHERE name LIKE ?" ++ " AND DbModule.packageId = DbPackage.id " - ++ " AND DbPackage.name = '" ++ (escapeSql pkgName) ++ "'" - ++ " AND DbPackage.version = '" ++ (escapeSql pkgVersion) ++ "'" - queryDb sql moduleAction + ++ " AND DbPackage.name = ?" + ++ " AND DbPackage.version = ?" + queryDb sql [modName ++ ".%", pkgName, pkgVersion] moduleAction moduleAction :: [PersistValue] -> DbModule moduleAction [PersistText name, doc, pkgId@(PersistInt64 _)] = DbModule (T.unpack name) (fromDbText doc) (Key pkgId) @@ -75,16 +77,16 @@ declsByName name Nothing = do let sql = "SELECT DbDecl.declType, DbDecl.name, DbDecl.doc, DbDecl.kind, DbDecl.signature, DbDecl.equals, DbDecl.moduleId" ++ " FROM DbDecl, DbModule" - ++ " WHERE DbModule.name ='" ++ (escapeSql name) ++ "'" - queryDb sql declAction + ++ " WHERE DbModule.name = ?" + queryDb sql [name] declAction declsByName name (Just (DbPackageIdentifier pkgName pkgVersion)) = do let sql = "SELECT DbDecl.declType, DbDecl.name, DbDecl.doc, DbDecl.kind, DbDecl.signature, DbDecl.equals, DbDecl.moduleId" ++ " FROM DbDecl, DbModule, DbPackage" ++ " WHERE DbDecl.moduleId = DbModule.id AND DbModule.packageId = DbPackage.id" - ++ " AND DbModule.name = '" ++ (escapeSql name) ++ "'" - ++ " AND DbPackage.name = '" ++ (escapeSql pkgName) ++ "'" - ++ " AND DbPackage.version = '" ++ (escapeSql pkgVersion) ++ "'" - queryDb sql declAction + ++ " AND DbModule.name = ?" + ++ " AND DbPackage.name = ?" + ++ " AND DbPackage.version = ?" + queryDb sql [name, pkgName, pkgVersion] declAction declAction :: [PersistValue] -> DbDecl declAction [PersistText declType, PersistText name , doc, kind, signature, equals, modId@(PersistInt64 _)] = @@ -93,21 +95,39 @@ (Key modId) declAction _ = error "This should not happen" + +createIndexes :: SqlPersist IO() +createIndexes=do + liftIO $ logToStdout "creating indexes" + let idxs = [ "create index if not exists module_pkgid_name on DbModule (packageId,name)" + , "create index if not exists decl_modid on DbDecl (moduleId)" + , "create index if not exists decl_name on DbDecl (name)" + , "create index if not exists cons_name on DbConstructor (name)" + , "create index if not exists cons_declid on DbConstructor (declId)" + , "create index if not exists tyvar_declid on DbTyVar (declId)" + , "create index if not exists fundep_declid on DbFunDep (declId)" + , "create index if not exists context_declid on DbContext (declId)" + ] + mapM_ (\x -> execute x []) idxs + execute "analyze" [] + -- |Gets the declarations inside some module, -- along with information about which package it lives. getDeclsInModule :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [(DbPackageIdentifier, DbCompleteDecl)] getDeclsInModule modName pkgId = do let pkg = case pkgId of Nothing -> "" - Just (DbPackageIdentifier pkgName pkgVersion) -> " AND DbPackage.name = '" ++ (escapeSql pkgName) ++ "'" - ++ " AND DbPackage.version = '" ++ (escapeSql pkgVersion) ++ "'" + Just _ -> " AND DbPackage.name = ? AND DbPackage.version = ?" let sql = "SELECT DbDecl.id, DbDecl.declType, DbDecl.name, DbDecl.doc, DbDecl.kind, DbDecl.signature, DbDecl.equals, DbDecl.moduleId" ++ ", DbPackage.name, DbPackage.version" ++ " FROM DbDecl, DbModule, DbPackage" ++ " WHERE DbDecl.moduleId = DbModule.id AND DbModule.packageId = DbPackage.id" - ++ " AND DbModule.name = '" ++ (escapeSql modName) ++ "'" + ++ " AND DbModule.name = ?" ++ pkg - elts <- queryDb sql action + let args = case pkgId of + 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 @@ -126,48 +146,40 @@ getAllDeclInfo :: (DbDeclId, DbDecl) -> SqlPersist IO DbCompleteDecl getAllDeclInfo (declId, decl) = do ctxs' <- selectList [ DbContextDeclId ==. declId] [] - let ctxs = map snd ctxs' + let ctxs = map entityVal ctxs' tyvars' <- selectList [ DbTyVarDeclId ==. declId] [] - let tyvars = map snd tyvars' + let tyvars = map entityVal tyvars' fundeps' <- selectList [ DbFunDepDeclId ==. declId] [] - let fundeps = map snd fundeps' + let fundeps = map entityVal fundeps' consts' <- selectList [ DbConstructorDeclId ==. declId] [] - let consts = map snd consts' + let consts = map entityVal consts' return $ DbCompleteDecl decl ctxs tyvars fundeps consts -- |Get information about all constructors with that name. constructorsByName :: String -> SqlPersist IO [DbConstructor] constructorsByName name = do consts <- selectList [ DbConstructorName ==. name ] [] - return $ map snd consts + return $ map entityVal consts -- | Gets a list of modules where a declaration may live getModulesWhereDeclarationIs :: String -> SqlPersist IO [DbModule] getModulesWhereDeclarationIs declName = do let sqlDecl = "SELECT DbModule.name, DbModule.doc, DbModule.packageId" ++ " FROM DbDecl, DbModule" - ++ " WHERE DbDecl.moduleId = DbModule.id AND DbDecl.name = '" ++ (escapeSql declName) ++ "'" + ++ " WHERE DbDecl.moduleId = DbModule.id AND DbDecl.name = ?" sqlCons = "SELECT DbModule.name, DbModule.doc, DbModule.packageId" ++ " FROM DbConstructor, DbDecl, DbModule" ++ " WHERE DbConstructor.declId = DbDecl.id AND DbDecl.moduleId = DbModule.id" - ++ " AND DbConstructor.name = '" ++ (escapeSql declName) ++ "'" - decls <- queryDb sqlDecl action - cons <- queryDb sqlCons action + ++ " AND DbConstructor.name = ?" + decls <- queryDb sqlDecl [declName] action + cons <- queryDb sqlCons [declName] action return (decls ++ cons) where action :: [PersistValue] -> DbModule action [PersistText name, doc, pkgId@(PersistInt64 _)] = DbModule (T.unpack name) (fromDbText doc) (Key pkgId) action _ = error "This should not happen" -- |Executes a query. -queryDb :: String -> ([PersistValue] -> a) -> SqlPersist IO [a] -queryDb sql action = withStmt (T.pack sql) [] (withPopper action) - --- |Builds information from a database query. -withPopper :: ([PersistValue] -> a) -> RowPopper (SqlPersist IO) -> SqlPersist IO [a] -withPopper f popper = loop [] - where loop list = do mrow <- popper - case mrow of - Nothing -> return list - Just values -> loop ((f values):list) +queryDb :: String -> [String] -> ([PersistValue] -> a) -> SqlPersist IO [a] +queryDb sql params action = runResourceT (withStmt (T.pack sql) (map toPersistValue params) $= CL.map action $$ CL.consume) -- |Gets information from a text value. fromDbText :: PersistValue -> Maybe String 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 @@ -89,19 +89,20 @@ -- deletePackageByInfo :: PersistBackend backend m => PackageIdentifier -> backend m () deletePackageByInfo (PackageIdentifier (PackageName name) version) = - do Just (pkgId, _) <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. showVersion version ] [] + do Just pkg <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. showVersion version ] [] + let pkgId = entityKey pkg deletePackage pkgId -- deletePackage :: PersistBackend backend m => DbPackageId -> backend m () deletePackage pkgId = do modules <- selectList [ DbModulePackageId ==. pkgId ] [] - mapM_ (\(moduleId, _) -> deleteModule moduleId) modules + mapM_ (deleteModule . entityKey) modules delete pkgId -- deleteModule :: PersistBackend backend m => DbModuleId -> backend m () deleteModule moduleId = do decls <- selectList [ DbDeclModuleId ==. moduleId ] [] - mapM_ (\(declId, _) -> deleteDecl declId) decls + mapM_ (deleteDecl . entityKey) decls delete moduleId -- deleteDecl :: PersistBackend backend m => DbModuleId -> backend m () 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 @@ -5,14 +5,14 @@ import Data.List (intercalate) import qualified Data.Text as T import Database.Persist -import Database.Persist.Base +-- import Database.Persist.Base import Database.Persist.Sqlite +import Database.Persist.Store import Language.Haskell.Exts.Annotated.Syntax import Scion.PersistentBrowser.DbTypes import Scion.PersistentBrowser.Parser.Internal import Scion.PersistentBrowser.Query import Scion.PersistentBrowser.Types -import Scion.PersistentBrowser.Util (escapeSql) import Scion.PersistentHoogle.Types import Text.Parsec.Char import Text.Parsec.Combinator @@ -88,8 +88,8 @@ do let sql = "SELECT DbModule.name, DbModule.doc, DbModule.packageId, DbPackage.name, DbPackage.version" ++ " FROM DbModule, DbPackage" ++ " WHERE DbModule.packageId = DbPackage.id" - ++ " AND DbModule.name = '" ++ (escapeSql mname) ++ "'" - mods <- queryDb sql action + ++ " AND DbModule.name = ?" + mods <- queryDb sql [mname] action return $ if null mods then Nothing else Just (RModule mods) where action [PersistText modName, modDoc, pkgId@(PersistInt64 _), PersistText pkgName, PersistText pkgVersion] = ( DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion) @@ -101,9 +101,9 @@ ++ " FROM DbDecl, DbModule, DbPackage" ++ " WHERE DbDecl.moduleId = DbModule.id" ++ " AND DbModule.packageId = DbPackage.id" - ++ " AND DbDecl.name = '" ++ (escapeSql (getName dcl)) ++ "'" - ++ " AND DbModule.name = '" ++ (escapeSql mname) ++ "'" - decls <- queryDb sql action + ++ " AND DbDecl.name = ?" + ++ " AND DbModule.name = ?" + decls <- queryDb sql [getName dcl, mname] action completeDecls <- mapM (\(pkgId, modName, dclKey, dclInfo) -> do complete <- getAllDeclInfo (dclKey, dclInfo) return (pkgId, modName, complete) ) decls return $ if null completeDecls then Nothing else Just (RDeclaration completeDecls) @@ -128,9 +128,9 @@ ++ " WHERE DbConstructor.declId = DbDecl.id" ++ " AND DbDecl.moduleId = DbModule.id" ++ " AND DbModule.packageId = DbPackage.id" - ++ " AND DbDecl.name = '" ++ (escapeSql (getName dcl)) ++ "'" - ++ " AND DbModule.name = '" ++ (escapeSql mname) ++ "'" - decls <- queryDb sql action + ++ " AND DbDecl.name = ?" + ++ " AND DbModule.name = ?" + decls <- queryDb sql [getName dcl, mname] action completeDecls <- mapM (\(pkgId, modName, dclKey, dclInfo, cst) -> do complete <- getAllDeclInfo (dclKey, dclInfo) return (pkgId, modName, complete, cst) ) decls return $ if null completeDecls then Nothing else Just (RConstructor completeDecls) diff --git a/src/Server/PersistentCommands.hs b/src/Server/PersistentCommands.hs --- a/src/Server/PersistentCommands.hs +++ b/src/Server/PersistentCommands.hs @@ -20,14 +20,13 @@ data Command = LoadLocalDatabase FilePath Bool | LoadHackageDatabase FilePath Bool - | GetPackages - | SetCurrentDatabase CurrentDatabase - | GetModules String - | GetDeclarations String - | HoogleQuery String + | GetPackages CurrentDatabase + | GetModules CurrentDatabase String + | GetDeclarations CurrentDatabase String + | HoogleQuery CurrentDatabase String | HoogleDownloadData | HoogleCheckDatabase - | GetDeclarationModules String + | GetDeclarationModules CurrentDatabase String | SetExtraHooglePath String | Quit @@ -39,19 +38,31 @@ data BrowserState = BrowserState { localDb :: Maybe FilePath , hackageDb :: Maybe FilePath - , useLocal :: Bool - , useHackage :: Bool - , filterPackage :: Maybe DbPackageIdentifier , extraHooglePath :: Maybe String } + initialState :: BrowserState -initialState = BrowserState Nothing Nothing True True Nothing Nothing +initialState = BrowserState Nothing Nothing Nothing --True True Nothing -runWithState :: BrowserState -> (Maybe DbPackageIdentifier -> SqlPersist IO [a]) -> IO [a] -runWithState (BrowserState lDb hDb useL useH filterPkg _) action = - do localThings <- runWithState' useL lDb (action filterPkg) - hackageThings <- runWithState' useH hDb (action filterPkg) +useLocal :: CurrentDatabase -> Bool +useLocal HackageDatabase=False +useLocal _=True + +useHackage :: CurrentDatabase -> Bool +useHackage LocalDatabase=False +useHackage _=True + +filterPackage :: CurrentDatabase -> Maybe DbPackageIdentifier +filterPackage (APackage pkgId)=Just pkgId +filterPackage _ = Nothing + +runWithState :: BrowserState -> CurrentDatabase -> (Maybe DbPackageIdentifier -> SqlPersist IO [a]) -> IO [a] +runWithState (BrowserState lDb hDb _) cdb action = + do + let filterPkg=filterPackage cdb + localThings <- runWithState' (useLocal cdb) lDb (action filterPkg) + hackageThings <- runWithState' (useHackage cdb) hDb (action filterPkg) return $ localThings ++ hackageThings runWithState' :: Bool -> Maybe FilePath -> SqlPersist IO [a] -> IO [a] @@ -60,9 +71,11 @@ withSqliteConn (T.pack path) $ runSqlConn action else return [] -runDb :: (Maybe DbPackageIdentifier -> SqlPersist IO [a]) -> BrowserM [a] -runDb action = do st <- get - lift $ runWithState st action +runDb :: CurrentDatabase -> (Maybe DbPackageIdentifier -> SqlPersist IO [a]) -> BrowserM [a] +runDb cdb action = + do + st <- get + lift $ runWithState st cdb action type BrowserM = StateT BrowserState IO @@ -71,46 +84,43 @@ do fileExists <- lift $ doesFileExist path let fileExists' = fileExists `seq` fileExists when rebuild $ - lift $ do withSqliteConn (T.pack path) $ runSqlConn $ runMigration migrateAll + lift $ do withSqliteConn (T.pack path) $ runSqlConn $ do + runMigration migrateAll + createIndexes pkgInfos' <- getPkgInfos let pkgInfos = concat $ map snd pkgInfos' updateDatabase path pkgInfos 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 { hackageDb = Nothing }) - executeCommand (SetCurrentDatabase LocalDatabase) + else modify (\s -> s { localDb = Nothing }) + return (String "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) logToStdout "Rebuilding Hackage database" - withSqliteConn (T.pack path) $ runSqlConn $ runMigration migrateAll + withSqliteConn (T.pack path) $ runSqlConn $ do + runMigration migrateAll + createIndexes saveHackageDatabase path 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 }) - executeCommand (SetCurrentDatabase HackageDatabase) -executeCommand (SetCurrentDatabase db) = - do case db of - AllPackages -> do modify (\s -> s { useLocal = True, useHackage = True, filterPackage = Nothing }) - return (String "ok", True) - LocalDatabase -> do modify (\s -> s { useLocal = True, useHackage = False, filterPackage = Nothing }) - return (String "ok", True) - HackageDatabase -> do modify (\s -> s { useLocal = False, useHackage = True, filterPackage = Nothing }) - return (String "ok", True) - APackage pid -> do modify (\s -> s { useLocal = True, useHackage = True, filterPackage = Just pid }) - return (String "ok", True) -executeCommand GetPackages = do pkgs <- runDb allPackages + return (String "ok", True) +executeCommand (GetPackages cdb) = do pkgs <- runDb cdb allPackages return (toJSON pkgs, True) -executeCommand (GetModules mname) = do smods <- runDb (getSubmodules mname) +executeCommand (GetModules cdb mname) = + do smods <- runDb cdb (getSubmodules mname) return (toJSON smods, True) -executeCommand (GetDeclarations mname) = do decls <- runDb (getDeclsInModule mname) +executeCommand (GetDeclarations cdb mname) = + do decls <- runDb cdb (getDeclsInModule mname) return (toJSON decls, True) -executeCommand (HoogleQuery query) = do extraH <- fmap extraHooglePath get - results <- runDb (\_ -> H.query extraH query) +executeCommand (HoogleQuery cdb query) = + do extraH <- fmap extraHooglePath get + results <- runDb cdb (\_ -> H.query extraH query) return (toJSON results, True) executeCommand HoogleDownloadData = do extraH <- fmap extraHooglePath get _ <- lift $ H.downloadData extraH @@ -120,7 +130,8 @@ return (Bool present, True) executeCommand (SetExtraHooglePath p) = do modify (\s -> s { extraHooglePath = Just p }) return (String "ok", True) -executeCommand (GetDeclarationModules d) = do mods <- runDb (\_ -> getModulesWhereDeclarationIs d) +executeCommand (GetDeclarationModules cdb d) = + do mods <- runDb cdb (\_ -> getModulesWhereDeclarationIs d) return (toJSON mods, True) executeCommand Quit = return (String "ok", False) @@ -133,15 +144,18 @@ <*> v .: "rebuild" "load-hackage-db" -> LoadHackageDatabase <$> v .: "filepath" <*> v .: "rebuild" - "get-packages" -> pure GetPackages - "set-current-db" -> SetCurrentDatabase <$> v .: "new-db" - "get-modules" -> GetModules <$> v .: "module" - "get-declarations" -> GetDeclarations <$> v .: "module" - "hoogle-query" -> HoogleQuery <$> v .: "query" + "get-packages" -> GetPackages <$> v .: "db" + "get-modules" -> GetModules <$> v .: "db" + <*> v .: "module" + "get-declarations" -> GetDeclarations <$>v .: "db" + <*> v .: "module" + "hoogle-query" -> HoogleQuery <$> v .: "db" + <*> v .: "query" "hoogle-data" -> pure HoogleDownloadData "hoogle-check" -> pure HoogleCheckDatabase "extra-hoogle-path" -> SetExtraHooglePath <$> v .: "path" - "get-decl-module" -> GetDeclarationModules <$> v .: "decl" + "get-decl-module" -> GetDeclarationModules <$> v .: "db" + <*> v .: "decl" "quit" -> pure Quit _ -> mzero _ -> mzero @@ -154,4 +168,3 @@ "_local" -> pure LocalDatabase _ -> mzero parseJSON other = APackage <$> parseJSON other -