scion-browser 0.2.3 → 0.2.5
raw patch · 9 files changed
+155/−125 lines, 9 filesdep +conduitdep ~persistentdep ~persistent-sqlitedep ~persistent-template
Dependencies added: conduit
Dependency ranges changed: persistent, persistent-sqlite, persistent-template
Files
- scion-browser.cabal +13/−10
- src/Main.hs +1/−1
- src/Scion/PersistentBrowser/Build.hs +1/−1
- src/Scion/PersistentBrowser/DbTypes.hs +2/−1
- src/Scion/PersistentBrowser/Parser.hs +2/−2
- src/Scion/PersistentBrowser/Query.hs +64/−52
- src/Scion/PersistentBrowser/ToDb.hs +4/−3
- src/Scion/PersistentHoogle/Parser.hs +10/−10
- src/Server/PersistentCommands.hs +58/−45
scion-browser.cabal view
@@ -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,
src/Main.hs view
@@ -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
src/Scion/PersistentBrowser/Build.hs view
@@ -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
src/Scion/PersistentBrowser/DbTypes.hs view
@@ -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
src/Scion/PersistentBrowser/Parser.hs view
@@ -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
src/Scion/PersistentBrowser/Query.hs view
@@ -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
src/Scion/PersistentBrowser/ToDb.hs view
@@ -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 ()
src/Scion/PersistentHoogle/Parser.hs view
@@ -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)
src/Server/PersistentCommands.hs view
@@ -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-